First commit.

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) Michael Fiano
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

README.md

@@ -0,0 +1,15 @@
+# dungen
+
+A procedural dungeon generator.
+
+## Install
+
+```lisp
+(ql:quickload :dungen)
+```
+
+## License
+
+Copyright © 2016-2022 Michael Fiano <mail@mfiano.net>.
+
+Licensed under the MIT License.

dungen.asd

@@ -0,0 +1,22 @@
+(asdf:defsystem #:dungen
+  :description "A procedural dungeon generator."
+  :author "Michael Fiano <mail@mfiano.net>"
+  :license "MIT"
+  :homepage "https://github.com/mfiano/dungen"
+  :encoding :utf-8
+  :depends-on (#:graph
+               #:mfiano-utils
+               #:seedable-rng)
+  :pathname "src"
+  :serial t
+  :components
+  ((:file "package")
+   (:file "state")
+   (:file "stage")
+   (:file "cell")
+   (:file "kernel")
+   (:file "region")
+   (:file "room")
+   (:file "junction")
+   (:file "corridor")
+   (:file "test")))

src/cell.lisp

@@ -0,0 +1,45 @@
+(in-package #:dungen)
+
+(defstruct (cell
+            (:constructor %make-cell)
+            (:copier nil)
+            (:predicate nil))
+  x
+  y
+  (features (list :wall))
+  (region 0))
+
+(defun get-cell (stage x y)
+  (when (and (< -1 x (stage-width stage))
+             (< -1 y (stage-height stage)))
+    (aref (stage-grid stage) x y)))
+
+(defun make-cell (stage x y)
+  (setf (aref (stage-grid stage) x y) (%make-cell :x x :y y)))
+
+(defun add-feature (cell feature)
+  (pushnew feature (cell-features cell)))
+
+(defun remove-feature (cell feature)
+  (u:deletef (cell-features cell) feature))
+
+(defun feature-intersect (cell &rest features)
+  (intersection features (cell-features cell)))
+
+(defun has-feature-p (cell feature)
+  (member feature (cell-features cell)))
+
+(defun carve (cell feature &key (change-region-p t))
+  (add-feature cell feature)
+  (remove-feature cell :wall)
+  (when change-region-p
+    (add-cell-to-region cell)))
+
+(defun carved-p (cell)
+  (when cell
+    (not (has-feature-p cell :wall))))
+
+(defun uncarve (cell)
+  (remhash cell (u:href (state-regions *state*) (cell-region cell)))
+  (setf (cell-region cell) 0
+        (cell-features cell) '(:wall)))

src/corridor.lisp

@@ -0,0 +1,60 @@
+(in-package #:dungen)
+
+(defun filter-carvable (kernel)
+  (not (kernel-detect kernel #'carved-p)))
+
+(defun choose-corridor-cell (stage cells)
+  (let ((rng (state-rng *state*)))
+    (if (> (rng:float rng 0.0 1.0) (stage-wild-factor stage))
+        (rng:element rng cells nil)
+        (first cells))))
+
+(defun choose-corridor-direction (kernel)
+  (let (results)
+    (dolist (dir '((0 1) (0 -1) (1 0) (-1 0)))
+      (u:when-let ((cell1 (apply #'select kernel dir))
+                   (cell2 (apply #'select kernel (mapcar #'+ dir dir))))
+        (unless (carved-p cell2)
+          (push (list cell1 cell2) results))))
+    (rng:element (state-rng *state*) results nil)))
+
+(defun carve-direction (kernel cells)
+  (let ((origin (select kernel 0 0)))
+    (u:if-let ((choice (choose-corridor-direction kernel)))
+      (loop :for cell :in choice
+            :do (carve cell :corridor)
+            :finally (return (push cell cells)))
+      (progn
+        (push origin (state-dead-ends *state*))
+        (delete origin cells :count 1)))))
+
+(defun carve-corridor-cell (kernel)
+  (let ((stage (kernel-stage kernel))
+        (origin (select kernel 0 0))
+        (layout (layout :orthogonal :max-x 2 :max-y 2)))
+    (make-region)
+    (carve origin :corridor)
+    (labels ((recurse (cells)
+               (when cells
+                 (let* ((cell (choose-corridor-cell stage cells))
+                        (kernel (cell->kernel stage cell layout)))
+                   (recurse (carve-direction kernel cells))))))
+      (recurse (list origin)))))
+
+(defun carve-corridors (stage)
+  (convolve stage (layout :rectangle) #'filter-carvable #'carve-corridor-cell))
+
+(defun filter-dead-end (kernel)
+  (let ((dirs (count nil (kernel-map kernel #'carved-p))))
+    (and (carved-p (select kernel 0 0))
+         (> dirs 2))))
+
+(defun erode-dead-end (kernel)
+  (uncarve (select kernel 0 0))
+  (remove-connectors kernel)
+  (kernel-detect kernel (lambda (x) (when (carved-p x) x))))
+
+(defun erode-dead-ends (stage)
+  (process stage nil #'filter-dead-end #'erode-dead-end
+           :items (state-dead-ends *state*)
+           :generator (lambda (x) (cell->kernel stage x (layout :orthogonal)))))

src/junction.lisp

@@ -0,0 +1,62 @@
+(in-package #:dungen)
+
+(defun filter-connectable (kernel)
+  (and (not (carved-p (select kernel 0 0)))
+       (or (cell-regions-distinct-p (select kernel 0 1) (select kernel 0 -1))
+           (cell-regions-distinct-p (select kernel 1 0) (select kernel -1 0)))))
+
+(defun make-connector (kernel)
+  (let ((cell (select kernel 0 0))
+        (regions (remove 0 (kernel-map kernel #'cell-region))))
+    (add-feature cell :connector)
+    (push cell (u:href (state-connections *state*) regions))))
+
+(defun connect-regions (stage)
+  (convolve stage (layout :orthogonal) #'filter-connectable #'make-connector))
+
+(defun connectable-edges ()
+  (let (edges)
+    (u:do-hash-keys (k (state-connections *state*))
+      (push (cons k 1) edges))
+    edges))
+
+(defun make-graph ()
+  (graph:populate (make-instance 'graph:graph)
+                  :nodes (u:iota (hash-table-count (state-regions *state*))
+                                 :start 1)
+                  :edges-w-values (connectable-edges)))
+
+(defun make-tree ()
+  (let ((graph (make-graph)))
+    (graph/graph:minimum-spanning-tree graph graph)))
+
+(defun adjacent-junction-p (kernel)
+  (kernel-detect kernel (lambda (x) (feature-intersect x :junction :door))))
+
+(defun generate-junction-feature (stage)
+  (if (rng:bool (state-rng *state*) (stage-door-rate stage))
+      :door
+      :junction))
+
+(defun remove-connectors (kernel)
+  (kernel-map kernel (lambda (x) (remove-feature x :connector))))
+
+(defun maybe-make-junction (stage cell)
+  (let ((kernel (cell->kernel stage cell (layout :orthogonal))))
+    (unless (adjacent-junction-p kernel)
+      (carve cell (generate-junction-feature stage))
+      (remove-connectors kernel)
+      (cond ((cell-regions-distinct-p (select kernel 0 1) (select kernel 0 -1))
+             (add-feature cell :door/horizontal))
+            ((cell-regions-distinct-p (select kernel 1 0) (select kernel -1 0))
+             (add-feature cell :door/vertical))))))
+
+(defun get-random-edge-connector (edge)
+  (rng:element (state-rng *state*) (u:href (state-connections *state*) edge) nil))
+
+(defun carve-junctions (stage)
+  (loop :with graph = (make-tree)
+        :for edge :in (graph:edges graph)
+        :do (maybe-make-junction stage (get-random-edge-connector edge))
+        :when (rng:bool (state-rng *state*) (stage-cycle-factor stage))
+          :do (maybe-make-junction stage (get-random-edge-connector edge))))

src/kernel.lisp

@@ -0,0 +1,149 @@
+(in-package #:dungen)
+
+(defstruct (extent
+            (:copier nil)
+            (:predicate nil))
+  (min-x 0)
+  (min-y 0)
+  (max-x 1)
+  (max-y 1))
+
+(defstruct (kernel
+            (:copier nil)
+            (:predicate nil))
+  stage
+  origin-x
+  origin-y
+  extent
+  selector
+  mapper)
+
+(defun make-kernel-factory (selector mapper &rest extent-args)
+  (let ((extent (apply #'make-extent extent-args)))
+    (lambda (stage x y)
+      (make-kernel :stage stage
+                   :origin-x x
+                   :origin-y y
+                   :extent extent
+                   :selector selector
+                   :mapper mapper))))
+
+(defun resolve-coords (kernel x y)
+  (values (+ (kernel-origin-x kernel) x)
+          (+ (kernel-origin-y kernel) y)))
+
+(defun select (kernel x y)
+  (when (selector (kernel-selector kernel) x y (kernel-extent kernel))
+    (multiple-value-bind (stage-x stage-y) (resolve-coords kernel x y)
+      (get-cell (kernel-stage kernel) stage-x stage-y))))
+
+(defun kernel-map (kernel func)
+  (mapper (kernel-mapper kernel) kernel func))
+
+(defun kernel-detect (kernel func)
+  (block nil
+    (kernel-map kernel
+                (lambda (cell)
+                  (u:when-let ((value (funcall func cell)))
+                    (return value))))
+    nil))
+
+(defun cell->kernel (stage cell layout)
+  (funcall layout stage (cell-x cell) (cell-y cell)))
+
+(defun kernel-filter (kernel filter)
+  (remove nil
+          (kernel-map kernel
+                      (lambda (x)
+                        (when (funcall filter x)
+                          x)))))
+
+(defun %selector/orthogonal (x y extent)
+  (or (and (zerop y)
+           (<= (extent-min-x extent) (abs x) (extent-max-x extent)))
+      (and (zerop x)
+           (<= (extent-min-y extent) (abs y) (extent-max-y extent)))))
+
+(defun %selector/rectangle (x y extent)
+  (let ((min-x (extent-min-x extent))
+        (min-y (extent-min-y extent))
+        (max-x (extent-max-x extent))
+        (max-y (extent-max-y extent)))
+    (and (>= x (- max-x))
+         (>= y (- max-y))
+         (<= x max-x)
+         (<= y max-y)
+         (not (and (> x (- min-x))
+                   (> y (- min-y))
+                   (< x min-x)
+                   (< y min-y))))))
+
+(defun selector (shape x y extent)
+  (case shape
+    (:orthogonal (%selector/orthogonal x y extent))
+    (t (%selector/rectangle x y extent))))
+
+(defun %mapper/orthogonal (kernel func)
+  (let* ((results)
+         (extent (kernel-extent kernel))
+         (max-x (extent-max-x extent))
+         (max-y (extent-max-y extent)))
+    (loop :for y :from (- max-y) :to max-y
+          :for cell = (select kernel 0 y)
+          :when cell
+            :do (push (funcall func cell) results))
+    (loop :for x :from (- max-x) :below 0
+          :for cell = (select kernel x 0)
+          :when cell
+            :do (push (funcall func cell) results))
+    (loop :for x :from 1 :to max-x
+          :for cell = (select kernel x 0)
+          :when cell
+            :do (push (funcall func cell) results))
+    results))
+
+(defun %mapper/rectangle (kernel func)
+  (loop :with extent = (kernel-extent kernel)
+        :with max-x = (extent-max-x extent)
+        :with max-y = (extent-max-y extent)
+        :for y :from max-y :downto (- max-y)
+        :append (loop :for x :from (- max-x) :to max-x
+                      :for cell = (select kernel x y)
+                      :when cell
+                        :collect (funcall func cell))))
+
+(defun mapper (shape kernel func)
+  (case shape
+    (:orthogonal (%mapper/orthogonal kernel func))
+    (t (%mapper/rectangle kernel func))))
+
+(defun %layout/orthogonal (extent-args)
+  (apply #'make-kernel-factory :orthogonal :orthogonal extent-args))
+
+(defun %layout/rectangle (extent-args)
+  (apply #'make-kernel-factory :rectangle :default extent-args))
+
+(defun layout (shape &rest extent-args)
+  (case shape
+    (:orthogonal (%layout/orthogonal extent-args))
+    (t (%layout/rectangle extent-args))))
+
+(defun convolve (stage layout filter effect)
+  (loop :for x :from 1 :below (1- (stage-width stage))
+        :do (loop :for y :from 1 :below (1- (stage-height stage))
+                  :for kernel = (funcall layout stage x y)
+                  :when (funcall filter kernel)
+                    :do (funcall effect kernel))))
+
+(defun collect (stage layout filter)
+  (let (items)
+    (convolve stage layout filter (lambda (x) (push x items)))
+    items))
+
+(defun process (stage layout filter processor &key items (generator #'identity))
+  (let ((items (or items (collect stage layout filter))))
+    (u:while items
+      (let ((kernel (funcall generator (pop items))))
+        (when (funcall filter kernel)
+          (u:when-let ((new (funcall processor kernel)))
+            (push new items)))))))

src/package.lisp

@@ -0,0 +1,22 @@
+(in-package #:cl-user)
+
+(defpackage #:dungen
+  (:local-nicknames
+   (#:rng #:seedable-rng)
+   (#:u #:mfiano-utils))
+  (:use #:cl)
+  (:export
+   #:carved-p
+   #:feature-intersect
+   #:features
+   #:get-cell
+   #:has-feature-p
+   #:make-seed
+   #:make-stage
+   #:region
+   #:stage-grid
+   #:stage-height
+   #:stage-seed
+   #:stage-width
+   #:x
+   #:y))

src/region.lisp

@@ -0,0 +1,18 @@
+(in-package #:dungen)
+
+(defun make-region ()
+  (incf (state-current-region *state*)))
+
+(defun add-cell-to-region (cell)
+  (let* ((region (state-current-region *state*))
+         (regions (state-regions *state*))
+         (cells (u:href regions region)))
+    (unless cells
+      (setf (u:href regions region) (u:dict #'eq)))
+    (setf (u:href regions region cell) cell
+          (cell-region cell) region)))
+
+(defun cell-regions-distinct-p (&rest cells)
+  (let ((regions (remove 0 (mapcar #'cell-region cells))))
+    (and (> (length regions) 1)
+         (apply #'/= regions))))

src/room.lisp

@@ -0,0 +1,48 @@
+(in-package #:dungen)
+
+(defun estimate-room-count (stage)
+  (let* ((room-extent (stage-room-extent stage))
+         (width (stage-width stage))
+         (height (stage-height stage))
+         (density (stage-density stage))
+         (min 9)
+         (max (expt room-extent 2))
+         (average (+ min (/ (- max min) 2))))
+    (values (floor (/ (* width height density) average)))))
+
+(defun generate-room-properties (stage)
+  (let* ((rng (state-rng *state*))
+         (width (stage-width stage))
+         (height (stage-height stage))
+         (room-extent (stage-room-extent stage))
+         (w (rng:int/parity rng 3 room-extent))
+         (h (rng:int/parity rng 3 room-extent))
+         (x (rng:int/parity rng 1 (- width w)))
+         (y (rng:int/parity rng 1 (- height h))))
+    (values x y w h)))
+
+(defun carve-room (stage)
+  (multiple-value-bind (x y w h) (generate-room-properties stage)
+    (let* ((rx (floor w 2))
+           (ry (floor h 2))
+           (px (+ rx x))
+           (py (+ ry y))
+           (k1 (funcall (layout :rectangle :max-x rx :max-y ry)
+                        stage px py))
+           (k2 (funcall (layout :rectangle :max-x (1+ rx) :max-y (1+ ry))
+                        stage px py)))
+      (unless (kernel-detect k2 #'carved-p)
+        (make-region)
+        (kernel-map k1 (lambda (x) (carve x :room)))))))
+
+(defun carve-rooms (stage)
+  (loop :with max = (estimate-room-count stage)
+        :with count = 0
+        :with tries = 0
+        :until (or (= count max)
+                   (>= tries 500))
+        :do (if (carve-room stage)
+                (progn
+                  (setf tries 0)
+                  (incf count))
+                (incf tries))))

src/stage.lisp

@@ -0,0 +1,62 @@
+(in-package #:dungen)
+
+(defstruct (stage
+            (:constructor %make-stage)
+            (:copier nil)
+            (:predicate nil))
+  (width 49)
+  (height 49)
+  (seed (rng:make-seed))
+  (density 0.5)
+  (room-extent 11)
+  (wild-factor 0.25)
+  (door-rate 0.5)
+  (cycle-factor 0.5)
+  grid)
+
+(defun make-grid (stage)
+  (let* ((width (stage-width stage))
+         (height (stage-height stage))
+         (grid (make-array (list width height))))
+    (setf (stage-grid stage) grid)
+    (dotimes (x width)
+      (dotimes (y height)
+        (make-cell stage x y)))))
+
+(defun verify-stage (stage)
+  (let* ((width (stage-width stage))
+         (height (stage-height stage))
+         (room-extent (stage-room-extent stage))
+         (max-extent (- (ceiling (min (/ width 2) (/ height 2))) 2)))
+    (unless (and (oddp width)
+                 (plusp width))
+      (error "Width must be an odd positive integer."))
+    (unless (and (oddp height)
+                 (plusp height))
+      (error "Height must be an odd positive integer."))
+    (unless (stringp (stage-seed stage))
+      (error "Seed must be a string."))
+    (unless (<= 0.1 (stage-density stage) 1.0)
+      (error "Density must be between 0.1 and 1.0."))
+    (unless (and (integerp room-extent)
+                 (oddp room-extent)
+                 (<= 3 room-extent max-extent))
+      (error "Room extent must be an odd integer between 3 and ~d" max-extent))
+    (unless (<= 0.0 (stage-wild-factor stage) 1.0)
+      (error "Wild factor must be between 0.0 and 1.0."))
+    (unless (<= 0.0 (stage-door-rate stage) 1.0)
+      (error "Door rate must be between 0.0 and 1.0."))
+    (unless (<= 0.0 (stage-cycle-factor stage) 1.0)
+      (error "Cycle factor must be between 0.0 and 1.0."))))
+
+(defun make-stage (&rest args)
+  (let* ((stage (apply #'%make-stage args))
+         (*state* (make-state (stage-seed stage))))
+    (verify-stage stage)
+    (make-grid stage)
+    (carve-rooms stage)
+    (carve-corridors stage)
+    (connect-regions stage)
+    (carve-junctions stage)
+    (erode-dead-ends stage)
+    stage))

src/state.lisp

@@ -0,0 +1,16 @@
+(in-package #:dungen)
+
+(defvar *state*)
+
+(defstruct (state
+            (:constructor %make-state)
+            (:copier nil)
+            (:predicate nil))
+  rng
+  (current-region 0)
+  (regions (u:dict #'eql))
+  (connections (u:dict #'equal))
+  dead-ends)
+
+(defun make-state (seed)
+  (%make-state :rng (rng:make-generator seed)))

src/test.lisp

@@ -0,0 +1,23 @@
+(in-package #:dungen)
+
+(defun test (&rest attrs)
+  (let ((stage (apply #'make-stage attrs)))
+    (format t "~&")
+    (loop :for y :from (1- (stage-height stage)) :downto 0
+          :do (loop :for x :below (stage-width stage)
+                    :for cell = (get-cell stage x y)
+                    :do (format t "~a"
+                                (cond ((has-feature-p cell :door/horizontal)
+                                       "──")
+                                      ((has-feature-p cell :door/vertical)
+                                       "│ ")
+                                      ((has-feature-p cell :stairs/up)
+                                       "↑↑")
+                                      ((has-feature-p cell :stairs/down)
+                                       "↓↓")
+                                      ((or (has-feature-p cell :room)
+                                           (has-feature-p cell :corridor))
+                                       "  ")
+                                      ((has-feature-p cell :wall)
+                                       "██"))))
+              (format t "~%"))))