Source Code for https://youtu.be/_PYGSfiX6tw

clim-maze.lisp

;;;; clim-maze.lisp

(defpackage #:clim-maze
  (:use #:clim-lisp)
  (:export #:main))

(in-package #:clim-maze)

(defparameter *sleep-time* 0.01)



(defclass maze-size ()
  ((%width :initarg :width :accessor width)
   (%height :initarg :height :accessor height)))

(defclass maze-color ()
  ((%wall :initform clim:+red+ :accessor wall-color)
   (%floor :initform clim:+white+ :accessor floor-color)
   (%forward :initform clim:+blue+ :accessor forward-color)
   (%backward :initform clim:+yellow+ :accessor backward-color)))

(defclass maze-piece-amount ()
  ((%horizontal :initarg :horizontal :accessor horizontal)
   (%vertical :initarg :vertical :accessor vertical)))

(defclass maze-piece-position ()
  ((%x :initarg :position-x :accessor position-x)
   (%y :initarg :position-y :accessor position-y)))

(defclass maze-generator ()
  ((%record-forwards :initform '() :accessor record-forwards)
   (%record-backwards :initform '() :accessor record-backwards)))

(defclass maze-piece (maze-size maze-piece-position)
  ((%top :initarg :top :initform nil :accessor top)
   (%right :initarg :right :initform nil :accessor right)
   (%bottom :initarg :bottom :initform nil :accessor bottom)
   (%left :initarg :left :initform nil :accessor left)))

(defclass maze-area (maze-size maze-color maze-piece-amount maze-generator)
  ((%pieces :accessor pieces)
   (%thickness :initform 3 :accessor thickness))
  (:default-initargs :width 600 :height 600
                     :horizontal 6 :vertical 6))



(defmethod compute-width ((area maze-area))
  (/ (width area) (horizontal area)))

(defmethod compute-height ((area maze-area))
  (/ (height area) (vertical area)))

(defun make-piece (width height x y)
  (make-instance 'maze-piece :width width :height height
                             :position-x x :position-y y))

(defmethod initialize-instance
    :after ((instance maze-area) &key &allow-other-keys)
  (setf (pieces instance)
        (make-array
         (list (vertical instance)
               (horizontal instance))
         :initial-contents
         (loop for y from 0 below (vertical instance)
               collect (loop for x from 0 below (horizontal instance)
                             collect (make-piece (compute-width instance)
                                                 (compute-height instance)
                                                 x y))))))

(defun make-maze (width height horizontal vertical)
  (make-instance 'maze-area :width width :height height
                            :horizontal horizontal :vertical vertical))



(clim:define-application-frame maze-frame ()
  ((%maze :accessor maze :initform (make-maze 1342 718 90 48)))
  (:panes
   (maze-pane clim:clim-stream-pane
              :width :compute
              :height :compute
              :scroll-bars nil
              :display-time nil
              :background clim:+gray88+
              :display-function 'display))
  (:layouts
   (default (clim:outlining (:thickness 10 :background clim:+white+)
              maze-pane))))



(defgeneric display (frame pane))
(defgeneric start-generator-p (maze))
(defgeneric end-generator-p (maze))
;; drawing
(defgeneric draw-circle (pane maze color))
(defgeneric draw-rectangle (pane maze color thickness))
(defgeneric draw-wall (pane maze color thickness))
(defgeneric draw-progress (pane maze))
(defgeneric draw-final (pane maze))
;; processing
(defgeneric process-step (pane maze))
(defgeneric random-position (maze))
(defgeneric next-piece-candidates (maze))
(defgeneric next-piece-random (maze))
(defgeneric previous-piece (maze))



(defmethod display ((frame maze-frame) pane)
  (let ((maze (maze frame)))
    (draw-rectangle pane maze (wall-color maze)
                    (thickness maze))))

(defmethod start-generator-p ((maze maze-area))
  (and (null (record-forwards maze))
       (null (record-backwards maze))))

(defmethod end-generator-p ((maze maze-area))
  (and (null (record-forwards maze))
       (>= (length (record-backwards maze))
           (array-total-size (pieces maze)))))

(defmethod draw-circle (pane (piece maze-piece) color)
  (let* ((width (width piece))
         (height (height piece))
         (x (+ (* (position-x piece) width) (/ width 2)))
         (y (+ (* (position-y piece) height) (/ height 2)))
         (radius (/ (if (> width height) height width) 3)))
    (clim:draw-circle* pane x y radius :ink color)))

(defmethod draw-rectangle (pane (maze maze-area) color thickness)
  (clim:draw-rectangle* pane 1 1 (width maze) (height maze)
                        :filled nil
                        :ink color
                        :line-thickness thickness))

(defmethod draw-wall (pane (piece maze-piece) color thickness)
  (let* ((width (width piece))
         (height (height piece))
         (x (* (position-x piece) width))
         (y (* (position-y piece) height)))
    ;; top
    (typecase (top piece)
      ;; (maze-piece nil)
      ;; (string nil)
      (null nil)
      (t (clim:draw-line* pane
                          x y (+ x width) y
                          :ink color
                          :line-thickness thickness)))
    ;; right
    (typecase (right piece)
      ;; (maze-piece nil)
      ;; (string nil)
      (null nil)
      (t (clim:draw-line* pane
                          (+ x width) y (+ x width) (+ y height)
                          :ink color
                          :line-thickness thickness)))
    ;; bottom
    (typecase (bottom piece)
      ;; (maze-piece nil)
      ;; (string nil)
      (null nil)
      (t (clim:draw-line* pane
                          x (+ y height) (+ x width) (+ y height)
                          :ink color
                          :line-thickness thickness)))
    ;; left
    (typecase (left piece)
      ;; (maze-piece nil)
      ;; (string nil)
      (null nil)
      (t (clim:draw-line* pane
                          x y x (+ y height)
                          :ink color
                          :line-thickness thickness)))))



(defclass generate-event (clim:window-manager-event)
  ((%finalp :initarg :finalp :initform nil :accessor finalp)))

(defmethod clim:handle-event ((frame maze-frame) (event generate-event))
  (let ((pane (clim:find-pane-named frame 'maze-pane))
        (maze (maze frame)))
    (if (finalp event)
        (draw-final pane maze)
        (draw-progress pane maze))))

(defmethod process-step (pane (maze maze-area))
  (cond ((start-generator-p maze) (random-position maze))
        ((end-generator-p maze) nil)
        (t (or (next-piece-random maze)
               (previous-piece maze)))))

(defmethod random-position ((maze maze-area))
  (let ((y (random (vertical maze)))
        (x (random (horizontal maze))))
    (let ((piece (aref (pieces maze) y x)))
      (push piece (record-forwards maze)) piece)))

(defmethod next-piece-candidates ((maze maze-area))
  (let ((current (car (record-forwards maze))))
    (unless (null current)
      (let ((x (position-x current))
            (y (position-y current)))
        (flet ((piece-available (a b)
                 (handler-case (aref (pieces maze) a b)
                   (error () "limit"))))
          ;; top right bottom left
          (list (piece-available (1- y) x)
                (piece-available y (1+ x))
                (piece-available (1+ y) x)
                (piece-available y (1- x))))))))

(defmethod next-piece-random ((maze maze-area))
  (let* ((candidates (mapcar (lambda (it)
                               (unless (member it (union
                                                   (record-forwards maze)
                                                   (record-backwards maze)))
                                 it))
                             (next-piece-candidates maze)))
         (available (remove-if #'stringp (remove nil candidates))))
    (unless (null available)
      (let ((current (car (record-forwards maze)))
            (piece (nth (random (length available)) available)))
        (destructuring-bind (top right bottom left)
            (mapcar (lambda (it) (unless (equal it piece) it))
                    candidates)
          ;; top
          (unless (null top)
            (setf (top current) top)
            (unless (stringp top) (setf (bottom top) current)))
          ;; right
          (unless (null right)
            (setf (right current) right)
            (unless (stringp right) (setf (left right) current)))
          ;; bottom
          (unless (null bottom)
            (setf (bottom current) bottom)
            (unless (stringp bottom) (setf (top bottom) current)))
          ;; left
          (unless (null left)
            (setf (left current) left)
            (unless (stringp left) (setf (right left) current))))
        (push piece (record-forwards maze))
        (case (position piece candidates)
          (0 (setf (top current) nil))
          (1 (setf (right current) nil))
          (2 (setf (bottom current) nil))
          (3 (setf (left current) nil)))
        (values piece available)))))

(defmethod previous-piece ((maze maze-area))
  (let ((backward (pop (record-forwards maze)))
        (current (car (record-forwards maze))))
    (push backward (record-backwards maze))
    (case (position current (list (top backward)
                                  (right backward)
                                  (bottom backward)
                                  (left backward)))
      (0 (setf (top backward) nil))
      (1 (setf (right backward) nil))
      (2 (setf (bottom backward) nil))
      (3 (setf (left backward) nil)))
    (values current backward)))



(defmethod draw-progress (pane (maze maze-area))
  (let ((forward (car (record-forwards maze)))
        (backward (car (record-backwards maze))))
    (unless (null forward)
      (draw-circle pane forward (forward-color maze)))
    (unless (null backward)
      (draw-wall pane backward (wall-color maze) (thickness maze))
      (draw-circle pane backward (backward-color maze)))))

(defmethod draw-final (pane (maze maze-area))
  (clim:window-clear pane)
  (clim:draw-rectangle* pane
                        1 1 (width maze) (height maze)
                        :ink (floor-color maze))
  (draw-rectangle pane maze (wall-color maze) (thickness maze))
  (destructuring-bind (ny nx) (array-dimensions (pieces maze))
    (loop for y from 0 below ny
          do (loop for x from 0 below nx
                   do (draw-wall pane (aref (pieces maze) y x)
                                 (wall-color maze)
                                 (thickness maze))))))

(define-maze-frame-command (com-clear :menu t) ()
  (clim:with-application-frame (frame)
    (let ((pane (clim:find-pane-named frame 'maze-pane))
          (maze (maze frame)))
      (destructuring-bind (y x) (array-dimensions (pieces maze))
        (setf (maze frame) (make-maze (width maze) (height maze) x y))
        (clim:window-clear pane)
        (display frame pane)))))

(define-maze-frame-command (com-generate :menu t) ()
  (clim:with-application-frame (frame)
    (let ((pane (clim:find-pane-named frame 'maze-pane))
          (maze (maze frame)))
      (clim-sys:make-process
       (lambda ()
         (loop while (< (length (record-backwards maze))
                        (array-total-size (pieces maze)))
               do (sleep *sleep-time*)
                  (process-step pane maze)
                  (clim:queue-event
                   (clim:frame-top-level-sheet frame)
                   (make-instance 'generate-event
                                  :sheet frame))
               finally
                  (sleep *sleep-time*)
                  (process-step pane maze)
                  (clim:queue-event
                   (clim:frame-top-level-sheet frame)
                   (make-instance 'generate-event
                                  :sheet frame :finalp t))))))))

(defun main (&optional new-process)
  (let ((frame (clim:make-application-frame 'maze-frame)))
    (if new-process
        (clim-sys:make-process (lambda () (clim:run-frame-top-level frame)))
        (clim:run-frame-top-level frame))))