;; John Wiseman
;; 1997

(require :quickdraw-3d)



(defparameter $empty 0)
(defparameter $north 1)
(defparameter $south 2)
(defparameter $east  4)
(defparameter $west  8)
(defparameter $up    16)
(defparameter $down  32)


(defparameter *vectors*
  `((,$north  ,$south  0  1  0)
    (,$south  ,$north  0 -1  0)
    (,$east   ,$west   1  0  0)
    (,$west   ,$east  -1  0  0)
    (,$up     ,$down   0  0  1)
    (,$down   ,$up     0  0 -1)))

(defun opposite-direction (direction)
  (let ((v (assoc direction *vectors*)))
    (assert (not (null v)))
    (second v)))



(defparameter *directions*
  (list $north $south $east $west $up $down))

(defun random-directions ()
  (sort (copy-list *directions*)
        #'(lambda (x y)
            (declare (ignore x y))
            (zerop (random 2)))))


(defstruct maze
  array
  width
  height
  depth)

(defmethod print-object ((self maze) stream)
  (print-unreadable-object (self stream :type T :identity T)
    (format stream "~dx~dx~d"
            (maze-width self)
            (maze-height self)
            (maze-depth self))))


(defun maze-cell (maze x y z)
  (aref (maze-array maze) x y z))

(defun (setf maze-cell) (value maze x y z)
  (setf (aref (maze-array maze) x y z) value))

(defun in-bounds? (maze x y z)
  (and (>= x 0) (>= y 0) (>= z 0)
       (< x (maze-width maze))
       (< y (maze-height maze))
       (< z (maze-depth maze))))

;(defun neighbor-cell-empty? (maze x y direction)
;  (multiple-value-bind (nx ny) (neighbor x y direction)
;    (and (in-bounds? maze nx ny)
;         (= (maze-cell maze nx ny) $empty))))


(defun neighbor (x y z direction)
  (multiple-value-bind (dx dy dz) (dir-vector direction)
    (values (+ x dx) (+ y dy) (+ z dz))))

(defun dir-vector (direction)
  (let ((v (assoc direction *vectors*)))
    (assert (not (null v)))
    (destructuring-bind (dx dy dz) (cddr v)
      (values dx dy dz))))

(defun cells-connected? (maze x1 y1 z1 x2 y2 z2)
  (let ((c1 (maze-cell maze x1 y1 z1)))
    (some #'(lambda (dir)
              (and (not (zerop (logand c1 dir)))
                   (multiple-value-bind (x y z) (neighbor x1 y1 z1 dir)
                     (and (= x x2) (= y y2) (= z z2)))))
          *directions*)))

                
  


(defun random-direction ()
  (let ((l *directions*))
    (elt l (random (length l)))))


(defun open-cell (maze x y z direction)
  (setf (maze-cell maze x y z)
        (logior (maze-cell maze x y z) direction)))




(defun expand-maze (maze x y z)
  (dolist (direction (random-directions))
    (multiple-value-bind (nx ny nz) (neighbor x y z direction)
      (when (and (in-bounds? maze nx ny nz)
                 (= (maze-cell maze nx ny nz) $empty))
        (open-cell maze x y z direction)
        (open-cell maze nx ny nz (opposite-direction direction))
        (expand-maze maze nx ny nz))))
  maze)


(defun generate-maze (x y z)
  (let ((maze (make-maze :array (make-array (list x y z)) :width x :height y :depth z)))
    (expand-maze maze 0 0 0)))



;(defun display-maze (maze)
;  (let ((cx (/ 500 (maze-width maze)))
;        (cy (/ 500 (maze-height maze))))
;    (flet ((coord (x y)
;             (values (round (+ (* x cx)
;                               (/ cx 2)))
;                     (round (+ (* y cy)
;                               (/ cy 2))))))
;      (let ((v (make-instance 'window
;                 :view-size #@(500 500))))
;        (sleep 0.5)
;        (dotimes (y (maze-height maze))
;          (dotimes (x (maze-width maze))
;            (dolist (direction *directions*)
;              (when (not (zerop (logand (maze-cell maze x y) direction)))
;                (multiple-value-bind (h1 v1) (coord x y)
;                  (multiple-value-bind (h2 v2) (apply #'coord
;                                                      (multiple-value-list (neighbor x y direction)))
;                    (move-to v h1 v1)
;                    (line-to v h2 v2)))))))))))
;
;(defun display-maze-2 (maze)
;  (flet ((c (x) (+ (* x 2) 1)))
;    (let ((a (make-array (list (+ (* 2 (maze-width maze)) 2)
;                               (+ (* 2 (maze-height maze)) 2))
;                         :initial-element T)))
;      (dotimes (x (maze-width maze))
;        (dotimes (y (maze-height maze))
;          (let ((i (c x))
;                (j (c y)))
;            (setf (aref a i j) NIL)
;            (dolist (direction *directions*)
;              (when (not (zerop (logand (maze-cell maze x y) direction)))
;                (multiple-value-bind (di dj) (dir-vector direction)
;                  (setf (aref a (+ i di) (+ j dj)) NIL)))))))
;      (dotimes (j (+ (* 2 (maze-height maze)) 1))
;        (terpri)
;        (dotimes (i (+ (* 2 (maze-width maze)) 1))
;          (if (aref a i j)
;            (princ "*")
;            (princ " ")))))))
;
;(defun create-maze-model (maze &optional inverse)
;  (flet ((c (x) (+ (* x 2) 1)))
;    (let ((a (make-array (list (+ (c (maze-width maze)) 1)
;                               (+ (c (maze-height maze)) 1)
;                               (+ (c (maze-depth maze)) 1))
;                         :initial-element T)))
;      (dotimes (z (maze-depth maze))
;        (dotimes (x (maze-width maze))
;          (dotimes (y (maze-height maze))
;            (let ((i (c x))
;                  (j (c y))
;                  (k (c z)))
;              (setf (aref a i j k) NIL)
;              (dolist (direction *directions*)
;                (when (not (zerop (logand (maze-cell maze x y z) direction)))
;                  (multiple-value-bind (di dj dk) (dir-vector direction)
;                    (setf (aref a (+ i di) (+ j dj) (+ k dk)) NIL))))))))
;      (let ((g (q3:create-display-group)))
;        (dotimes (k (c (maze-depth maze)))
;          (dotimes (j (c (maze-height maze)))
;            (dotimes (i (c (maze-width maze)))
;              (when (or (and (not inverse) (aref a i j k))
;                        (and inverse (not (aref a i j k))))
;                (q3:group-add g (q3:create-box i j k 1 1 1))))))
;        g))))
;
;(defun create-maze-model (maze &optional inverse)
;  (flet ((c (x) (+ (* x 2) 1)))
;    (let ((a (make-array (list (+ (c (maze-width maze)) 1)
;                               (+ (c (maze-height maze)) 1)
;                               (+ (c (maze-depth maze)) 1))
;                         :initial-element NIL)))
;      (dotimes (z (maze-depth maze))
;        (dotimes (x (maze-width maze))
;          (dotimes (y (maze-height maze))
;            (let ((i (c x))
;                  (j (c y))
;                  (k (c z)))
;              (setf (aref a i j k) T)
;              (dolist (direction *directions*)
;                (when (not (zerop (logand (maze-cell maze x y z) direction)))
;                  (multiple-value-bind (di dj dk) (dir-vector direction)
;                    (setf (aref a (+ i di) (+ j dj) (+ k dk)) T))))))))
;      (let ((g (q3:create-display-group)))
;        (dotimes (k (c (maze-depth maze)))
;          (dotimes (j (c (maze-height maze)))
;            (dotimes (i (c (maze-width maze)))
;              (when (or (and (not inverse) (not (aref a i j k)))
;                        (and inverse (aref a i j k)))
;                (q3:group-add g (q3:create-box i j k 1 1 1))))))
;        g))))

(defun maze-model-array (maze &optional inverse)
  (flet ((c (x) (+ (* x 2) 1)))
    (let ((a (make-array (list (+ (c (maze-width maze)) 1)
                               (+ (c (maze-height maze)) 1)
                               (+ (c (maze-depth maze)) 1))
                         :initial-element NIL)))
      (dotimes (z (maze-depth maze))
        (dotimes (y (maze-width maze))
          (dotimes (x (maze-height maze))
            (let ((i (c x))
                  (j (c y))
                  (k (c z)))
              (setf (aref a i j k) T)
              (dolist (direction *directions*)
                (when (not (zerop (logand (maze-cell maze x y z) direction)))
                  (multiple-value-bind (di dj dk) (dir-vector direction)
                    (setf (aref a (+ i di) (+ j dj) (+ k dk)) T))))))))
      (dotimes (k (c (maze-depth maze)))
        (dotimes (j (c (maze-height maze)))
          (dotimes (i (c (maze-width maze)))
            (when (or (and (not inverse) (not (aref a i j k)))
                      (and inverse (aref a i j k)))
              (setf (aref a i j k) (q3:create-box i j k 1 1 1))))))
      a)))



(defun create-maze-model (maze &optional inverse)
  (let ((a (maze-model-array maze inverse))
        (g (q3:create-display-group)))
    (dotimes (i (array-total-size a))
      (when (macptrp (row-major-aref a i))
        (q3:group-add g (row-major-aref a i))))
    g))
  


(defun solve-maze (maze)
  (let ((a (maze-model-array maze T))
        (g (q3:create-display-group
            (q3:create-attribute-set :ambient-coefficient 1.0)
            (q3:create-line 0 0 0 8 0 0 (q3:create-attribute-set :diffuse-color 1 0 0))
            (q3:create-line 0 0 0 0 8 0 (q3:create-attribute-set :diffuse-color 0 1 0))
            (q3:create-line 0 0 0 0 0 8 (q3:create-attribute-set :diffuse-color 0 0 1)))))
    (dotimes (i (array-total-size a))
      (when (macptrp (row-major-aref a i))
        (q3:group-add g (row-major-aref a i))))
    (let ((w (make-instance 'q3:qd3d-viewer-window
               :model g))
          (solution-path '()))
      (labels ((c (x) (+ (* x 2) 1))
               (highlight (x y z direction state)
                 ;(format T "~&HL: (~S,~S,~S) ~S ~S" x y z direction state)
                 (let ((i (c x))
                       (j (c y))
                       (k (c z)))
                   (q3:object-attribute-set-add (aref a i j k)
                                                :highlight-state state)
                   (if state
                     (push (aref a i j k) solution-path)
                     (setf solution-path (delete (aref a i j k)
                                                 solution-path
                                                 :count 1)))
                   (when direction
                     (multiple-value-bind (di dj dk) (dir-vector (opposite-direction direction))
                       (q3:object-attribute-set-add (aref a (+ i di) (+ j dj) (+ k dk))
                                                    :highlight-state state)
                       (if state
                         (push (aref a (+ i di) (+ j dj) (+ k dk)) solution-path)
                         (setf solution-path (delete (aref a (+ i di) (+ j dj) (+ k dk))
                                                     solution-path
                                                     :count 1)))))
                   (q3:render-view w))))
        (trace-maze maze
                    0 0 0
                    (- (maze-width maze) 1)
                    (- (maze-height maze) 1)
                    (- (maze-depth maze) 1)
                    #'(lambda (x y z dir)
                        (highlight x y z dir T)
                        )
                    #'(lambda (x y z dir)
                        (highlight x y z dir NIL)
                        ))
        (make-instance 'q3:qd3d-viewer-window
          :model (apply #'q3:create-display-group solution-path))))))


(defun trace-maze (maze x y z gx gy gz enter-fn leave-fn)
  (labels ((tm (x y z dir)
             (funcall enter-fn x y z dir)
             (when (and (= x gx) (= y gy) (= z gz))
               (return-from trace-maze))
             (dolist (direction (if dir
                                  (remove (opposite-direction dir) (random-directions))
                                  (random-directions)))
               (multiple-value-bind (nx ny nz) (neighbor x y z direction)
                 (when (and (not (zerop (logand (maze-cell maze x y z) direction)))
                            (in-bounds? maze nx ny nz)
                            (not (= (maze-cell maze nx ny nz) $empty)))
                   (tm nx ny nz direction))))
             (funcall leave-fn x y z dir)
             (values)))
    (tm x y z nil)))