Browse Source

First commit.

main
Michael Fiano 2 months ago
commit
a01431bca4
Signed by: mfiano
GPG Key ID: F87DF4666D70FC63
  1. 21
      LICENSE
  2. 15
      README.md
  3. 22
      dungen.asd
  4. 45
      src/cell.lisp
  5. 60
      src/corridor.lisp
  6. 62
      src/junction.lisp
  7. 149
      src/kernel.lisp
  8. 22
      src/package.lisp
  9. 18
      src/region.lisp
  10. 48
      src/room.lisp
  11. 62
      src/stage.lisp
  12. 16
      src/state.lisp
  13. 23
      src/test.lisp

21
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.

15
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.

22
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")))

45
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)))

60
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)))))

62
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))))

149
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)))))))

22
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))

18
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))))

48
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))))

62
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))

16
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)))

23
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 "~%"))))
Loading…
Cancel
Save