maze.lisp

(ql:quickload :sketch)
(ql:quickload :alexandria)

(in-package :sketch)

(defparameter *maze-w* 60)
(defparameter *maze-h* 40)
(defparameter *tile-size* 10)
(defparameter *maze* nil)

(defun v*s (v s)
  "Vector math, multiplies vector V by scalar S"
  `(,(* (first v) s) ,(* (second v) s)))

(defun v+v (v1 v2)
  "Vector math, adds two vectors, V1 and V2"
  `(,(+ (first v1) (first v2)) ,(+ (second v1) (second v2))))

(defun neighbors (x y)
  "For position (X Y) in maze grid returns unit vectors "
  (remove-if (lambda (a)
	       (or (< (+ x (first a)) 1)
		   (< (+ y (second a)) 1)
		   (> (+ x (first a)) (- *maze-w* 2))
		   (> (+ y (second a)) (- *maze-h* 2))
		   (apply #'aref `(,*maze* ,@(v+v `(,x ,y) (v*s a 2))))))
	     `((-1 0) (1 0) (0 -1) (0 1))))

(defun get-cell (cells)
  "Selects a cell from available cells"
  (if (> (random 1.0) 0.8)
      (car (last cells))
      (alexandria:random-elt cells)))

(defun get-neighbor (neighbors)
  "Selects carving direction"
  (alexandria:random-elt neighbors))

(defun carve-1 (cells)
  "Executes one iteration of maze carving"
  (when cells
    (let* ((cell (get-cell cells))
	   (neighbors (neighbors (first cell) (second cell))))
      (setf cells (remove cell cells :test #'equal))
      (when neighbors
	(let* ((direction (get-neighbor neighbors)))
	  (loop for i below 2 do
	       (setf (apply #'aref `(,*maze* ,@(v+v cell (v*s direction (1+ i))))) t))
	  (setf cells (append `(,cell ,(v+v cell (v*s direction 2))) cells))))))
  cells)

(defun carve ()
  "Carves the whole maze, using
http://weblog.jamisbuck.org/2011/1/27/maze-generation-growing-tree-algorithm"
  (setf *maze* (make-array `(,*maze-w* ,*maze-h*) :initial-element nil))
  (let ((cells `((,(random *maze-w*) ,(random *maze-h*)))))
    (loop while cells do
	 (setf cells (carve-1 cells)))))

;;;;

(defsketch maze (:title "Maze"
		 :width (* *tile-size* *maze-w*)
		 :height (* *tile-size* *maze-h*))
    ((white (make-pen :fill (gray 1 0)))
     (black (make-pen :fill (gray 0))))
  (dotimes (x *maze-w*)
    (dotimes (y *maze-h*)
      (when (aref *maze* x y)
	(with-pen black
	  (rect (* x *tile-size*) (* y *tile-size*) *tile-size* *tile-size*))))))

(define-sketch-setup maze
  (background (gray 1))
  (carve))

(defmethod kit.sdl2:mousebutton-event ((w maze) s ts b x y)
  (when (equal s :mousebuttonup)
    (background (gray 1))
    (carve)))