;;; -*- Mode:LISP; Readtable:CL; Base:10 -*-

;;;; Object system

(defun get-option (option-name options default)
  (let ((op (assoc option-name options)))
    (if op
	(cdr op)
      default)))

(defmacro defclass (name-or-stuff &rest slots)
  (let ((name (if (symbolp name-or-stuff)
		  name-or-stuff
		(car name-or-stuff)))
	(options (if (symbolp name-or-stuff)
		     '()
		   (cdr name-or-stuff))))
    (let ((included (get-option :include options '()))
	  (conc-name (string (get-option :conc-name options name)))
	  (slot-names (mapcar #'(lambda (slot) (if (symbolp slot) slot (car slot)))
			      slots)))
      `(progn
	 (defflavor ,name ,slots ,included
	   :initable-instance-variables
	   :settable-instance-variables
	   :gettable-instance-variables)
	 (defun ,(intern (format nil "MAKE-~a" name)) (&rest init-options)
	   (apply #'make-instance ',name init-options))
	 ,@(mapcar #'(lambda (slot)
		       (create-accessor slot conc-name))
		   slot-names)))))

(defun create-accessor (slot conc-name)
  (let ((acc-name (intern (format nil "~a-~a" conc-name slot))))
    `(progn
       (defsubst ,acc-name (obj)
	 (send obj ,(intern (string slot) 'keyword)))
       (defsetf ,acc-name (obj) (value)
	 `(send ,obj ,',(intern (format nil "SET-~a" slot) 'keyword)
		,value))))) 
			     
	  
(setq si:*use-generic-function-as-message* t)

(defclass (view (:include tv:window))
  (label nil)
  (blinker-p nil)
  (x-offset 0)
  (y-offset 0))

(defvar *default-font* fonts:hl12b)
(defvar *current-view* (make-view :left  30 :top 30
				  :right (- (tv:sheet-width tv:main-screen) 30)
				  :bottom (- (tv:sheet-height tv:main-screen) 200)
				  :borders 4))


(defun draw-character (view ch x y &optional (alu tv:alu-ior) (font *default-font*))
  (tv:prepare-sheet (view)
    (tv:draw-char font ch x y alu view)))

(defun draw-string (view string x y &optional (alu tv:alu-ior) (font *default-font*))
  (send view :string-out-explicit string x y 10000 10000 font alu))

(defun frame-rectangle (view x y w h &optional (thickness 1))
  (when (plusp thickness)
    (paint:frame-rect w h x y view tv:alu-ior thickness)))

(defun pattern-rectangle (view x y w h pattern)
  (bitblt tv:alu-ior w h pattern 0 0 (tv:sheet-screen-array view) x y))
 
;----------------------------------------------------------------
(defclass thing
  (x 0)
  (y 0))

(defgeneric draw (thing))
(defgeneric description (thing))

(defmethod (thing draw) ()
  (draw-string *current-view* "?" x y))

(defmethod (thing description) ()
  "A random Thing")

;----------------------------------------------------------------
(defclass (room (:include thing))
  (width 10)
  (height 10)
  (wall-thickness 2)
  (exits '())
  (objects-within '()))

;(defun rectangle-overlap (x1 y1 w1 h1 x2 y2 w2 h2)
;  (declare (values x y w h))
;  (let ((right1 (+ x1 w1))
;	(bottom1 (+ y1 h1))
;	(right2 (+ x2 w2))
;	(bottom2 (+ y2 h2)))
;    (let ((left (cond ((<= x1 x2 right1) x2)
;		      ((<= ))))))))

		       
	   
(defmethod (room draw) ()
  (pattern-rectangle *current-view* x y width height paint:light-gray)
  (frame-rectangle *current-view* x y width height
		   wall-thickness)
  (dolist (exit exits))
  (dolist (obj objects-within)
    (draw obj)))

(defgeneric in?     (place pt-x pt-y))
(defgeneric within? (place pt-x pt-y))

(defmethod (room in?) (pt-x pt-y)
  (and (> pt-x x)
	   (> pt-y y)
	   (< pt-x (+ x width))
	   (< pt-y (+ y height))))
  
(defmethod (room within?) (pt-x pt-y)
  (if (and (> pt-x x)
	   (> pt-y y)
	   (< pt-x (+ x width))
	   (< pt-y (+ y height)))
      self
    (dolist (exit exits)
      (when (in? exit pt-x pt-y)
	(return exit)))))


;----------------------------------------------------------------
(defclass (passage (:include room))
   (width 16.)
   (length 16.)
   (end-1 nil)
   (end-2 nil))

;----------------------------------------------------------------
(defclass (ns-passage (:include passage)))

(defmethod (ns-passage draw) ()
  (pattern-rectangle *current-view* (- x (truncate width 2)) y
		     width length paint:gray))

(defmethod (ns-passage in?) (pt-x pt-y)
  (let ((left (- x (truncate width 2))))
    (and (>= pt-y y)
	 (>= pt-x left)
	 (<= pt-y (+ y length))
	 (<= pt-x (+ left width)))))

(defmethod (ns-passage within?) (pt-x pt-y)
  (let ((left (- x (truncate width 2))))
    (cond ((and (>= pt-y y)
		(>= pt-x left)
		(<= pt-y (+ y length))
		(<= pt-x (+ left width)))
	   self)
	  ((and end-1 (in? end-1 pt-x pt-y))
	   end-1)
	  ((and end-2 (in? end-2 pt-x pt-y))
	   end-2)
	  (t nil))))
		
	   

;----------------------------------------------------------------
(defclass (ew-passage (:include passage)))

(defmethod (ew-passage draw) ()
  (pattern-rectangle *current-view* x (- y (truncate width 2))
		     length width paint:gray))

(defmethod (ew-passage in?) (pt-x pt-y)
  (let ((top (- y (truncate width 2))))
    (and (>= pt-x x)
	 (>= pt-y top)
	 (<= pt-x (+ x length))
	 (<= pt-y (+ top width)))))

(defmethod (ew-passage within?) (pt-x pt-y)
  (let ((top (- y (truncate width 2))))
    (cond ((and (>= pt-x x)
		(>= pt-y top)
		(<= pt-x (+ x length))
		(<= pt-y (+ top width)))
	   self)
	  ((and end-1 (in? end-1 pt-x pt-y))
	   end-1)
	  ((and end-2 (in? end-2 pt-x pt-y))
	   end-2)
	  (t nil))))


;----------------------------------------------------------------
(defclass (joint (:include thing))
   (height 16.)
   (width 16.)
   (top nil)
   (bottom nil)
   (left nil)
   (right nil))

(defmethod (joint draw) ()
  (pattern-rectangle *current-view*))
   
;----------------------------------------------------------------
(defclass (moving-thing (:include thing))
   (within nil))

(defgeneric erase (thing))
(defgeneric move (moving-thing new-x new-y))

(defun check-move (moving-thing new-x new-y)
  (let ((within (moving-thing-within moving-thing)))
    (let ((within? (within? within new-x new-y)))
      (cond ((null within?) (tv:beep) nil)
	    ((eq within? within) t)
	    (t
	     (erase moving-thing)
	     (draw within?)
	     (draw moving-thing)
	     (setf (moving-thing-within moving-thing)
		   within?)
	     t)))))

(defmethod (moving-thing move) (new-x new-y)
  (when (check-move self new-x new-y)
    (erase self)
    (setf (thing-x self) new-x)
    (setf (thing-y self) new-y)
    (draw self)))



(defun move-right (moving-thing &optional (amount 10.))
  (move moving-thing
	(+ (thing-x moving-thing) amount)
	(thing-y moving-thing)))

(defun move-left (moving-thing &optional (amount 10.))
  (move moving-thing
	(- (thing-x moving-thing) amount)
	(thing-y moving-thing)))

(defun move-up (moving-thing &optional (amount 10.))
  (move moving-thing
	(thing-x moving-thing)
	(- (thing-y moving-thing) amount)))

(defun move-down (moving-thing &optional (amount 10.))
  (move moving-thing
	(thing-x moving-thing)
	(+ (thing-y moving-thing) amount)))

(defmethod (moving-thing erase) ()
  (draw self))
  
;----------------------------------------------------------------
(defclass (character (:include moving-thing))
  (strength   0)
  (hit-points 0)
  (char       #\?))

(defmethod (character draw) ()
  (draw-character *current-view* char (- x 7) (- y 7) tv:alu-xor))

;----------------------------------------------------------------
(defclass (player (:include character)))

;----------------------------------------------------------------
(defclass (monster (:include character)))

;----------------------------------------------------------------
(defclass (money (:include moving-thing))
  (amount 10.))

(defmethod (money draw) ()
  (draw-character *current-view* #\$ (- x 7) (- y 7) tv:alu-xor))

(defmethod (money description) ()
  (format nil "~d Gold Pieces" (money-amount self)))
  

;----------------------------------------------------------------
(defvar *you* (make-player :char #\@))

(defun com-loop ()
  (send *current-view* :expose)
  (send *current-view* :clear-screen)
  (draw (moving-thing-within *you*))
  (draw *you*)
  (do () (())
    (case (read-char)
      ((#\hand-up) (move-up *you*))
      ((#\hand-down) (move-down *you*))
      ((#\hand-left) (move-left *you*))
      ((#\hand-right) (move-right *you*)))))