Browse Source

First commit.

main
Michael Fiano 4 months ago
commit
974043c645
Signed by: mfiano
GPG Key ID: F87DF4666D70FC63
  1. 21
      LICENSE
  2. 15
      README.md
  3. 17
      src/common/common.lisp
  4. 127
      src/common/conditions.lisp
  5. 124
      src/common/image.lisp
  6. 127
      src/common/priority-queue.lisp
  7. 284
      src/harrison/harrison.lisp
  8. 89
      src/package.lisp
  9. 104
      src/wfc/backtracker.lisp
  10. 28
      src/wfc/core.lisp
  11. 81
      src/wfc/grid.lisp
  12. 206
      src/wfc/kernel.lisp
  13. 206
      src/wfc/pattern.lisp
  14. 19
      src/wfc/sample.lisp
  15. 98
      src/wfc/solver.lisp
  16. 166
      src/wfc/tile-map.lisp
  17. 40
      src/wfc/util.lisp
  18. 41
      src/wfc/wfc.lisp
  19. 39
      syntex.asd

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 @@
# syntex
Various texture synthesis algorithms.
## Install
```lisp
(ql:quickload :syntex)
```
## License
Copyright © 2021-2022 Michael Fiano <mail@mfiano.net>.
Licensed under the MIT License.

17
src/common/common.lisp

@ -0,0 +1,17 @@
(in-package #:%syntex.common)
(defun check-seed (seed)
(unless (typep seed '(or string null))
(error 'cond:invalid-seed :seed seed)))
(defun check-file-exists (file-path)
(unless (uiop:file-exists-p file-path)
(error 'cond:file-not-found :file-path file-path)))
(defun check-image-dimension (dimension value)
(unless (typep value '(integer 8 65535))
(error 'cond:invalid-dimension :dimension dimension :value value)))
(defun check-output-path (output-path)
(unless (typep output-path '(or pathname string))
(error 'cond:invalid-output-path :value output-path)))

127
src/common/conditions.lisp

@ -0,0 +1,127 @@
(in-package #:%syntex.conditions)
(define-condition syntex-error (error) ())
(define-condition syntex-warning (warning) ())
(define-condition file-not-found (syntex-error)
((%file-path :reader file-path
:initarg :file-path))
(:report
(lambda (condition stream)
(format stream "File not found: ~s" (file-path condition)))))
(define-condition invalid-seed (syntex-error)
((%seed :reader seed
:initarg :seed))
(:report
(lambda (condition stream)
(format stream "Invalid seed: ~s.~%~%Seed must be a string or NIL." (seed condition)))))
(define-condition invalid-dimension (syntex-error)
((%dimension :reader dimension
:initarg :dimension)
(%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid dimension ~s for ~s.~%~%Must be an integer between 8 and 65535."
(value condition)
(dimension condition)))))
(define-condition invalid-output-path (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid output path: ~s.~%~%Must be a pathname or a string."
(value condition)))))
(define-condition invalid-harrison-kernel-size (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid kernel size ~s.~%~%Must be an integer between 1 and 255."
(value condition)))))
(define-condition invalid-harrison-rounds (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid rounds ~s for Harrison synthesizer.~%~%Must be an integer between 1 ~
and 255."
(value condition)))))
(define-condition invalid-harrison-candidate-count (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid candidate count ~s for Harrison synthesizer.~%~%Must be an integer ~
between 1 and 255."
(value condition)))))
(define-condition invalid-wfc-pattern-size (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid pattern size ~s.~%~%Must be an integer between 2 and 255."
(value condition)))))
(define-condition invalid-wfc-strategy (syntex-error)
((%value :reader value
:initarg :value)
(%allowed :reader allowed
:initarg :allowed))
(:report
(lambda (condition stream)
(format stream "Invalid strategy ~s.~%~%Must be one of ~{~a~^, ~}."
(value condition)
(allowed condition)))))
(define-condition invalid-wfc-backtrack-distance (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid backtrack distance ~s.~%~%Must be a positive fixnum."
(value condition)))))
(define-condition invalid-wfc-backtrack-retry-count (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Invalid backtrack retry count ~s.~%~%Must be a positive fixnum."
(value condition)))))
(define-condition wfc-contradiction-warning (syntex-warning)
((%progress :reader progress
:initarg :progress))
(:report
(lambda (condition stream)
(format stream "Contradiction occurred at ~d%."
(progress condition)))))
(define-condition wfc-contradiction-error (syntex-warning) ()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "Contradiction occurred and the :NONE correction strategy was supplied."))))
(define-condition wfc-max-backtrack-retries-exceeded (syntex-error)
((%value :reader value
:initarg :value))
(:report
(lambda (condition stream)
(format stream "Maximum number of backtrack retries exceeded: ~d.~%~%~
Possible solutions:~%~
- Supply a larger :BACKTRACK-RETRIES value.~%~
- Supply a larger :BACKTRACK-DISTANCE value.~%~
- Use another correction strategy by changing the value of :STRATEGY. "
(value condition)))))

124
src/common/image.lisp

@ -0,0 +1,124 @@
(in-package #:%syntex.image)
(defclass image ()
((%width :reader width
:initarg :width
:initform 0)
(%height :reader height
:initarg :height
:initform 0)
(%data :reader data
:initarg :data
:initform (u:make-ub32-array 0))))
(defun make-image (file-path)
(let ((png (png:load-file file-path :flatten t)))
(make-instance 'image
:width (png:width png)
:height (png:height png)
:data (pack png (png:color-type png)))))
(defgeneric pack (png color-type)
(:method (png color-type)
(error "Unsupported image file.")))
(defmethod pack ((png png:png) (color-type (eql :greyscale)))
(declare (optimize speed))
(loop :with width :of-type u:ub16 = (png:width png)
:with height :of-type u:ub16 = (png:height png)
:with size = (* width height)
:with data :of-type u:ub8a = (png:data png)
:with packed-data = (u:make-ub32-array size)
:for i :below size
:for value = (aref data i)
:for pixel = 0
:do (setf (ldb (byte 8 24) pixel) value
(ldb (byte 8 16) pixel) value
(ldb (byte 8 8) pixel) value
(ldb (byte 8 0) pixel) 0
(aref packed-data i) pixel)
:finally (return packed-data)))
(defmethod pack (png (color-type (eql :greyscale-alpha)))
(declare (optimize speed))
(loop :with width :of-type u:ub16 = (png:width png)
:with height :of-type u:ub16 = (png:height png)
:with size = (* width height)
:with data :of-type u:ub8a = (png:data png)
:with packed-data = (u:make-ub32-array size)
:for i :below (* size 2) :by 2
:for j :from 0
:for value = (aref data i)
:for pixel = 0
:do (setf (ldb (byte 8 24) pixel) value
(ldb (byte 8 16) pixel) value
(ldb (byte 8 8) pixel) value
(ldb (byte 8 0) pixel) 0
(aref packed-data j) pixel)
:finally (return packed-data)))
(defmethod pack (png (color-type (eql :truecolour)))
(declare (optimize speed))
(loop :with width :of-type u:ub16 = (png:width png)
:with height :of-type u:ub16 = (png:height png)
:with size = (* width height)
:with data :of-type u:ub8a = (png:data png)
:with packed-data = (u:make-ub32-array size)
:for i :below (* size 3) :by 3
:for j :from 0
:for pixel = 0
:do (setf (ldb (byte 8 24) pixel) (aref data i)
(ldb (byte 8 16) pixel) (aref data (+ i 1))
(ldb (byte 8 8) pixel) (aref data (+ i 2))
(ldb (byte 8 0) pixel) 0
(aref packed-data j) pixel)
:finally (return packed-data)))
(defmethod pack (png (color-type (eql :truecolour-alpha)))
(declare (optimize speed))
(loop :with width :of-type u:ub16 = (png:width png)
:with height :of-type u:ub16 = (png:height png)
:with size = (* width height)
:with data :of-type u:ub8a = (png:data png)
:with packed-data = (u:make-ub32-array size)
:for i :below (* size 4) :by 4
:for j :from 0
:for pixel = 0
:do (setf (ldb (byte 8 24) pixel) (aref data i)
(ldb (byte 8 16) pixel) (aref data (+ i 1))
(ldb (byte 8 8) pixel) (aref data (+ i 2))
(ldb (byte 8 0) pixel) 0
(aref packed-data j) pixel)
:finally (return packed-data)))
(u:fn-> from-rgb (u:ub32) (values u:ub8 u:ub8 u:ub8))
(declaim (inline from-rgb))
(defun from-rgb (color)
(declare (optimize speed))
(values (ldb (byte 8 24) color)
(ldb (byte 8 16) color)
(ldb (byte 8 8) color)))
(u:fn-> unpack (u:ub32a u:ub16 u:ub16) u:ub8a)
(declaim (inline unpack))
(defun unpack (data width height)
(declare (optimize speed))
(let ((unpacked-data (u:make-ub8-array (* width height 3))))
(dotimes (i (length data))
(u:mvlet ((r g b (from-rgb (aref data i)))
(offset (* i 3)))
(setf (aref unpacked-data offset) r
(aref unpacked-data (+ offset 1)) g
(aref unpacked-data (+ offset 2)) b)))
unpacked-data))
(u:fn-> write (u:ub8a u:ub16 u:ub16 (or pathname string)) (values))
(defun write (data width height file-path)
(declare (optimize speed))
(let ((png (make-instance 'zpng:png
:color-type :truecolor
:width width
:height height
:image-data data)))
(zpng:write-png png file-path)
(values)))

127
src/common/priority-queue.lisp

@ -0,0 +1,127 @@
(in-package #:%syntex.priority-queue)
(deftype data () '(simple-array t))
(declaim (inline %make-queue))
(defstruct (queue
(:constructor %make-queue)
(:conc-name nil)
(:predicate nil)
(:copier nil))
(data (make-array 256) :type data)
(priorities (make-array 256 :element-type 'u:f32) :type u:f32a)
(size 0 :type u:array-length))
(u:define-printer (queue stream)
(format stream "(~d)" (size queue)))
(u:fn-> make-queue (&key (:initial-size u:array-index)) queue)
(declaim (inline make-queue))
(defun make-queue (&key (initial-size 256))
(declare (optimize speed))
(%make-queue :data (make-array initial-size)
:priorities (make-array initial-size :element-type 'u:f32)))
(u:fn-> copy (queue) queue)
(defun copy (queue)
(declare (optimize speed))
(%make-queue :size (size queue)
:data (copy-seq (data queue))
:priorities (copy-seq (priorities queue))))
(u:fn-> heapify-up (data u:f32a u:array-length) null)
(declaim (inline heapify-up))
(defun heapify-up (data priorities index)
(declare (optimize speed))
(do ((child-index index parent-index)
(parent-index (ash (1- index) -1) (ash (1- parent-index) -1)))
((zerop child-index))
(let ((child-priority (aref priorities child-index))
(parent-priority (aref priorities parent-index)))
(cond ((< child-priority parent-priority)
(rotatef (aref priorities parent-index)
(aref priorities child-index))
(rotatef (aref data parent-index)
(aref data child-index)))
(t (return))))))
(u:fn-> enqueue (queue t u:f32) null)
(declaim (inline enqueue))
(defun enqueue (queue object priority)
(declare (optimize speed))
(symbol-macrolet ((data (data queue))
(priorities (priorities queue)))
(let ((size (size queue))
(length (length data)))
(when (>= size length)
(let ((new-length (max 1 (mod (* length 2) #.(ash 1 64)))))
(declare (type u:array-length new-length))
(setf data (adjust-array data new-length)
priorities (adjust-array priorities new-length))))
(setf (aref data size) object
(aref priorities size) priority)
(heapify-up data priorities size)
(incf (size queue))
nil)))
(u:fn-> heapify-down (data u:f32a u:array-index) null)
(declaim (inline heapify-down))
(defun heapify-down (data priorities size)
(declare (optimize speed))
(let ((parent-index 0))
(flet ((swap-left (parent-index left-index)
(rotatef (aref priorities parent-index)
(aref priorities left-index))
(rotatef (aref data parent-index)
(aref data left-index))
left-index)
(swap-right (parent-index right-index)
(rotatef (aref priorities parent-index)
(aref priorities right-index))
(rotatef (aref data parent-index)
(aref data right-index))
right-index))
(declare (inline swap-left swap-right))
(loop
(let* ((left-index (+ (* parent-index 2) 1))
(left-index-valid-p (< left-index size))
(right-index (+ (* parent-index 2) 2))
(right-index-valid-p (< right-index size)))
(when (and (not left-index-valid-p)
(not right-index-valid-p))
(return))
(let ((parent-priority (aref priorities parent-index))
(left-priority (aref priorities left-index))
(right-priority (aref priorities right-index)))
(when (and left-index-valid-p
(< parent-priority left-priority)
(or (not right-index-valid-p)
(< parent-priority right-priority)))
(return))
(if (and right-index-valid-p
(<= right-priority left-priority))
(setf parent-index (swap-right parent-index right-index))
(setf parent-index (swap-left parent-index left-index)))))))))
(u:fn-> dequeue (queue) (values t boolean))
(declaim (inline dequeue))
(defun dequeue (queue)
(declare (optimize speed))
(if (zerop (size queue))
(values nil nil)
(let ((data (data queue))
(priorities (priorities queue)))
(multiple-value-prog1 (values (aref data 0) t)
(decf (size queue))
(let ((size (size queue)))
(setf (aref data 0) (aref data size)
(aref priorities 0) (aref priorities size)))
(heapify-down data priorities (size queue))))))
(u:fn-> peek (queue) (values t boolean))
(declaim (inline peek))
(defun peek (queue)
(declare (optimize speed))
(if (zerop (size queue))
(values nil nil)
(values (aref (data queue) 0) t)))

284
src/harrison/harrison.lisp

@ -0,0 +1,284 @@
(in-package #:%syntex.harrison)
(defstruct (state
(:constructor %make-state)
(:conc-name nil)
(:predicate nil)
(:copier nil))
(rng nil :type rng:generator)
(sample-width 0 :type u:ub16)
(sample-height 0 :type u:ub16)
(sample-data (u:make-ub32-array 0) :type u:ub32a)
(indexed-p nil :type boolean)
(output-width 0 :type u:ub16)
(output-height 0 :type u:ub16)
(output-path nil :type (or pathname string))
(indexed-sample (u:make-ub32-array 0) :type u:ub32a)
(kernel-size 1 :type (and (integer 1) u:ub8))
(origins (u:make-b32-array 0) :type u:b32a)
(indices (u:make-ub32-array 0) :type u:ub32a))
(defun make-state (image &key output-width output-height indexed-p kernel-size output-path seed)
(let* ((rng (rng:make-generator seed))
(sample-width (img:width image))
(sample-height (img:height image))
(sample-data (img:data image))
(output-width (or output-width sample-width))
(output-height (or output-height sample-height)))
(%make-state :rng rng
:sample-width sample-width
:sample-height sample-height
:sample-data sample-data
:indexed-p indexed-p
:output-width output-width
:output-height output-height
:output-path output-path
:indexed-sample (u:make-ub32-array (length sample-data))
:kernel-size kernel-size
:origins (u:make-b32-array (* output-width output-height) -1)
:indices (make-shuffled-indices rng output-width output-height))))
(defun make-shuffled-indices (rng width height)
(let* ((count (* width height))
(result (u:make-ub32-array count)))
(dotimes (i count)
(setf (aref result i) i))
(values (rng:shuffle rng result))))
(u:fn-> color-metric (u:ub32 u:ub32) u:f64)
(declaim (inline color-metric))
(defun color-metric (color1 color2)
(declare (u:ub32 color1 color2))
(u:mvlet* ((r1 g1 b1 (img:from-rgb color1))
(r2 g2 b2 (img:from-rgb color2))
(r (1+ (* (expt (- r1 r2) 2) 7.62939453125d-7)))
(g (1+ (* (expt (- g1 g2) 2) 7.62939453125d-7)))
(b (1+ (* (expt (- b1 b2) 2) 7.62939453125d-7))))
(- (log (* r g b)))))
(defun build-metrics (state)
(declare (optimize speed))
(let ((sample-data (sample-data state))
(indexed-p (indexed-p state))
(indexed-sample (indexed-sample state))
(colors (u:dict #'eql))
(color-count 0)
(metric nil))
(declare (fixnum color-count))
(dotimes (i (* (sample-width state) (sample-height state)))
(let ((color (aref sample-data i)))
(unless (u:href colors color)
(setf (u:href colors color) color-count)
(incf color-count))
(setf (aref indexed-sample i) (u:href colors color))))
(when (and (not indexed-p) (<= color-count 1024))
(setf metric (u:make-f64-array (list color-count color-count)))
(u:do-hash (cx x colors)
(u:do-hash (cy y colors)
(setf (aref metric x y) (color-metric cx cy)))))
metric))
(u:fn-> update-neighbors (state u:ub32a u:ub8 u:ub32) null)
(defun update-neighbors (state neighbors neighbor-count index)
(declare (optimize speed))
(let* ((output-width (output-width state))
(output-height (output-height state))
(origins (origins state))
(x (u:make-b32-array 4))
(y (u:make-b32-array 4))
(ix (rem index output-width))
(iy (floor index output-width)))
(declare (dynamic-extent x y))
(loop :with found = 0
:while (< found neighbor-count)
:for radius :of-type u:ub32 :from 1
:do (setf (aref x 0) (- ix radius)
(aref y 0) (- iy radius)
(aref x 1) (- ix radius)
(aref y 1) (+ iy radius)
(aref x 2) (+ ix radius)
(aref y 2) (+ iy radius)
(aref x 3) (+ ix radius)
(aref y 3) (- iy radius))
(dotimes (i (* radius 2))
(dotimes (j 4)
(setf (aref x j) (rem (+ (aref x j) (* output-width 10)) output-width)
(aref y j) (rem (+ (aref y j) (* output-height 10)) output-height))
(when (< found neighbor-count)
(let ((point (+ (* (aref y j) output-width) (aref x j))))
(unless (minusp (aref origins point))
(setf (aref neighbors found) point)
(incf found)))))
(incf (aref y 0))
(incf (aref x 1))
(decf (aref y 2))
(decf (aref x 3))))))
(u:fn-> update-candidates (state u:ub32a u:ub8 u:ub32 u:b32a) null)
(defun update-candidates (state neighbors neighbor-count index candidates)
(declare (optimize speed))
(let ((sample-width (sample-width state))
(sample-height (sample-height state))
(output-width (output-width state))
(origins (origins state)))
(dotimes (i neighbor-count)
(let* ((neighbor (aref neighbors i))
(cx (rem (+ (aref origins neighbor)
(rem (- index neighbor) output-width)
(* sample-width 100))
sample-width))
(cy (rem (+ (- (+ (floor (aref origins neighbor) sample-width)
(floor index output-width))
(floor neighbor output-width))
(* sample-height 100))
sample-height)))
(setf (aref candidates i) (+ (* cy sample-width) cx))))))
(u:fn-> choose-random-candidates (state u:b32a u:ub8 u:ub16) null)
(defun choose-random-candidates (state candidates neighbor-count candidate-count)
(declare (optimize speed))
(dotimes (i candidate-count)
(let ((max (* (sample-width state) (sample-height state))))
(setf (aref candidates (+ neighbor-count i)) (rng:int (rng state) 0 max nil)))))
(u:fn-> update-origins (state u:b32a u:ub32 (or (simple-array u:f64) null)) (values))
(defun update-origins (state candidates index metrics)
(declare (optimize speed))
(let ((sample-width (sample-width state))
(sample-height (sample-height state))
(sample-data (sample-data state))
(indexed-sample (indexed-sample state))
(indexed-p (indexed-p state))
(kernel-size (kernel-size state))
(output-width (output-width state))
(output-height (output-height state))
(origins (origins state))
(rng (rng state))
(max -1d10)
(arg-max -1))
(dotimes (c (length candidates))
(let ((sum (* (rng:float rng 0.0 1.0) 1d-6)))
(declare (u:f64 sum))
(loop :for dy :from (- kernel-size) :to kernel-size
:do (loop :with origin = 0
:with si = 0
:with ix = (rem (aref candidates c) sample-width)
:with iy = (floor (aref candidates c) sample-width)
:with jx = (rem index output-width)
:with jy = (floor index output-width)
:for dx :from (- kernel-size) :to kernel-size
:for sx = (+ ix dx)
:for sy = (+ iy dy)
:for fx = (+ jx dx)
:for fy = (+ jy dy)
:when (or (/= dx 0) (/= dy 0))
:do (cond
((minusp sx)
(incf sx sample-width))
((>= sx sample-width)
(decf sx sample-width)))
(cond
((minusp sy)
(incf sy sample-height))
((>= sy sample-height)
(decf sy sample-height)))
(cond
((minusp fx)
(incf fx output-width))
((>= fx output-width)
(decf fx output-width)))
(cond
((minusp fy)
(incf fy output-height))
((>= fy output-height)
(decf fy output-height)))
(setf si (+ (* sy sample-width) sx)
origin (aref origins (+ (* fy output-width) fx)))
(unless (minusp origin)
(cond
(indexed-p
(if (= (aref sample-data origin)
(aref sample-data si))
(incf sum)
(decf sum)))
(metrics
(incf sum
(aref metrics
(aref indexed-sample origin)
(aref indexed-sample si))))
(t
(incf sum (color-metric (aref sample-data origin)
(aref sample-data si))))))))
(when (>= sum max)
(setf max sum
arg-max (aref candidates c)))))
(setf (aref origins index) arg-max)
(values)))
(defun write-image (state)
(let* ((sample-data (sample-data state))
(width (output-width state))
(height (output-height state))
(output-size (* width height))
(origins (origins state))
(data (u:make-ub32-array output-size)))
(dotimes (i (length data))
(setf (aref data i) (aref sample-data (aref origins i))))
(img:write (img:unpack data width height) width height (output-path state))))
(defun %harrison (state round candidate-count metrics indices)
(dotimes (counter (length indices))
(let* ((index (aref indices counter))
(neighbor-count (if (zerop round) (min 8 counter) 8))
(candidates (u:make-b32-array (+ neighbor-count candidate-count))))
(when (plusp neighbor-count)
(let ((neighbors (u:make-ub32-array neighbor-count)))
(declare (dynamic-extent neighbors))
(update-neighbors state neighbors neighbor-count index)
(update-candidates state neighbors neighbor-count index candidates)))
(choose-random-candidates state candidates neighbor-count candidate-count)
(update-origins state candidates index metrics))))
(defun %harrison/parallel (state round candidate-count metrics indices)
(lparallel:pdotimes (counter (length indices))
(let* ((index (aref indices counter))
(neighbor-count (if (zerop round) (min 8 counter) 8))
(candidates (u:make-b32-array (+ neighbor-count candidate-count))))
(when (plusp neighbor-count)
(let ((neighbors (u:make-ub32-array neighbor-count)))
(declare (dynamic-extent neighbors))
(update-neighbors state neighbors neighbor-count index)
(update-candidates state neighbors neighbor-count index candidates)))
(choose-random-candidates state candidates neighbor-count candidate-count)
(update-origins state candidates index metrics))))
(defun harrison (sample-path &key width height indexed-p (rounds 3) (candidate-count 20)
(kernel-size 1) seed (parallel-p t) output-path)
(com:check-file-exists sample-path)
(com:check-image-dimension :width width)
(com:check-image-dimension :height height)
(com:check-seed seed)
(com:check-output-path output-path)
(unless (typep kernel-size '(integer 1 255))
(error 'cond:invalid-harrison-kernel-size :value kernel-size))
(unless (typep rounds '(integer 1 255))
(error 'cond:invalid-harrison-rounds :value rounds))
(unless (typep candidate-count '(integer 1 255))
(error 'cond:invalid-harrison-candidate-count :value candidate-count))
(let* ((state (make-state (img:make-image sample-path)
:indexed-p indexed-p
:output-width width
:output-height height
:output-path output-path
:kernel-size kernel-size
:seed seed))
(indices (indices state))
(metrics (build-metrics state))
(lp:*kernel* (lp:make-kernel (cl-cpus:get-number-of-processors))))
(dotimes (round rounds)
(declare (fixnum round))
(format t "Round: ~d~%" (1+ round))
(if parallel-p
(%harrison/parallel state round candidate-count metrics indices)
(%harrison state round candidate-count metrics indices)))
(write-image state)))

89
src/package.lisp

@ -0,0 +1,89 @@
(in-package #:cl-user)
(defpackage #:%syntex.conditions
(:use #:cl)
(:export
#:file-not-found
#:invalid-dimension
#:invalid-harrison-candidate-count
#:invalid-harrison-rounds
#:invalid-harrison-kernel-size
#:invalid-output-path
#:invalid-seed
#:invalid-wfc-backtrack-distance
#:invalid-wfc-backtrack-retry-count
#:invalid-wfc-pattern-size
#:invalid-wfc-strategy
#:syntex-error
#:wfc-contradiction-error
#:wfc-contradiction-warning
#:wfc-max-backtrack-retries-exceeded))
(defpackage #:%syntex.image
(:local-nicknames
(#:png #:pngload)
(#:u #:mfiano-utils))
(:use #:cl)
(:shadow
#:write)
(:export
#:data
#:from-rgb
#:height
#:make-image
#:unpack
#:width
#:write))
(defpackage #:%syntex.priority-queue
(:local-nicknames
(#:u #:mfiano-utils))
(:use #:cl)
(:export
#:copy
#:dequeue
#:enqueue
#:make-queue
#:peek
#:queue))
(defpackage #:%syntex.common
(:local-nicknames
(#:cond #:%syntex.conditions))
(:use #:cl)
(:export
#:check-file-exists
#:check-image-dimension
#:check-output-path
#:check-seed))
(defpackage #:%syntex.harrison
(:local-nicknames
(#:com #:%syntex.common)
(#:cond #:%syntex.conditions)
(#:lp #:lparallel)
(#:img #:%syntex.image)
(#:rng #:seedable-rng)
(#:u #:mfiano-utils))
(:use #:cl)
(:export
#:harrison))
(defpackage #:%syntex.wfc
(:local-nicknames
(#:com #:%syntex.common)
(#:cond #:%syntex.conditions)
(#:img #:%syntex.image)
(#:pq #:%syntex.priority-queue)
(#:rng #:seedable-rng)
(#:u #:mfiano-utils))
(:use #:cl)
(:export
#:wfc))
(uiop:define-package #:syntex
(:use #:cl)
(:mix-reexport
#:%syntex.conditions
#:%syntex.harrison
#:%syntex.wfc))

104
src/wfc/backtracker.lisp

@ -0,0 +1,104 @@
(in-package #:%syntex.wfc)
(u:eval-always
(defclass backtracker ()
((%timestamp :accessor timestamp
:initform 0)
(%last-progress :accessor last-progress
:initform 0)
(%snapshots :reader snapshots
:initform (make-array 32 :fill-pointer 0 :adjustable t :initial-element nil))
(distance :reader distance
:initarg :distance
:initform 1)
(%max-retries :reader max-retries
:initarg :max-retries
:initform 10)
(%try :accessor try
:initform 0))))
(defun make-backtracker (&key distance retries)
(let ((backtracker (make-instance 'backtracker :distance distance :max-retries retries)))
(vector-push-extend 0 (snapshots backtracker))
backtracker))
(u:fn-> take-snapshot (core function) null)
(declaim (inline take-snapshot))
(defun take-snapshot (core func)
(declare (optimize speed))
(when (eq (strategy core) :backtrack)
(vector-push-extend func (snapshots (backtracker core))))
nil)
(u:fn-> take-snapshot/modify-tile (core tile simple-bit-vector) null)
(defun take-snapshot/modify-tile (core tile possible-patterns)
(declare (optimize speed))
(flet ((%restore ()
(let ((weight 0)
(weight-log-weight 0.0))
(declare (u:ub32 weight)
(u:f32 weight-log-weight))
(setf (possible-patterns tile) possible-patterns)
(dotimes (i (length possible-patterns))
(let ((frequency (get-frequency core i)))
(declare (u:ub32 frequency))
(when (possible-pattern-p tile i)
(incf weight frequency)
(incf weight-log-weight (* frequency (log frequency 2))))))
(setf (weight tile) weight
(weight-log-weight tile) weight-log-weight))))
(take-snapshot core #'%restore)
nil))
(u:fn-> take-snapshot/collapse-tile (core tile (or simple-bit-vector null)) null)
(defun take-snapshot/collapse-tile (core tile possible-patterns)
(declare (optimize speed))
(flet ((%uncollapse ()
(setf (collapsed-p tile) nil
(value tile) #xff00ffff)
(when possible-patterns
(setf (possible-patterns tile) possible-patterns
(pattern-removal-stack (tile-map core)) nil))))
(take-snapshot core #'%uncollapse)
nil))
(u:fn-> advance-time (core) null)
(declaim (inline advance-time))
(defun advance-time (core)
(declare (optimize speed))
(let* ((backtracker (backtracker core))
(snapshots (snapshots backtracker)))
(incf (the u:non-negative-fixnum (timestamp backtracker)))
(vector-push-extend (timestamp backtracker) snapshots)
nil))
(u:fn-> backtrack (core) null)
(defun backtrack (core)
(declare (optimize speed))
(let* ((backtracker (backtracker core))
(tile-map (tile-map core))
(timestamp (timestamp backtracker))
(snapshots (snapshots backtracker))
(target-timestamp (max 0 (- timestamp (the u:non-negative-fixnum (distance backtracker)))))
(progress (progress core))
(stop-p nil))
(declare (u:non-negative-fixnum timestamp target-timestamp)
(vector snapshots)
((integer 0 100) progress))
(u:until (or stop-p (zerop (length snapshots)))
(let ((item (vector-pop snapshots)))
(etypecase item
(function
(funcall item))
(u:non-negative-fixnum
(incf (the u:non-negative-fixnum (uncollapsed-count tile-map)))
(setf (timestamp backtracker) item
stop-p (< item target-timestamp))))))
(if (> progress (the (integer 0 100) (last-progress backtracker)))
(setf (try backtracker) 0)
(incf (the u:non-negative-fixnum (try backtracker))))
(when (>= (the u:non-negative-fixnum (try backtracker))
(the u:non-negative-fixnum (max-retries backtracker)))
(error 'cond:wfc-max-backtrack-retries-exceeded :value (try backtracker)))
(setf (last-progress backtracker) progress)
nil))

28
src/wfc/core.lisp

@ -0,0 +1,28 @@
(in-package #:%syntex.wfc)
(defvar *rng* nil)
(deftype strategy () '(member :none :backtrack))
(defclass core ()
((%seed :reader seed
:initarg :seed)
(%sample :reader sample
:initarg :sample)
(%data->pattern :reader data->pattern
:initform (u:dict #'equalp))
(%id->pattern :accessor id->pattern
:initform (make-array 0))
(%adjacencies :accessor adjacencies
:initform (make-array 0))
(%progress :accessor progress
:initform 0)
(%strategy :reader strategy
:initarg :strategy
:initform :backtrack)
(%backtracker :reader backtracker
:initarg :backtracker)
(%tile-map :accessor tile-map)))
(defun make-core (&key seed sample backtracker strategy)
(make-instance 'core :seed seed :sample sample :backtracker backtracker :strategy strategy))

81
src/wfc/grid.lisp

@ -0,0 +1,81 @@
(in-package #:%syntex.wfc)
(deftype grid-dimension () '(and u:ub16 (integer 2)))
(u:eval-always
(defclass cell ()
((%x :reader x
:initarg :x
:initform 0)
(%y :reader y
:initarg :y
:initform 0)
(%value :accessor value
:initform #xff00ffff))))
(u:eval-always
(defclass grid ()
((%width :reader width
:initarg :width
:initform 0)
(%height :reader height
:initarg :height
:initform 0)
(%cells :accessor cells
:initarg :cells
:initform nil)
(%cell-count :accessor cell-count
:initform 0))))
(u:define-printer (cell stream)
(format stream "~d, ~d" (x cell) (y cell)))
(u:define-printer (grid stream)
(format stream "~dx~d" (width grid) (height grid)))
(defmethod initialize-instance :after ((instance grid) &key cells)
(let* ((width (width instance))
(height (height instance))
(cell-count (* width height)))
(if cells
(setf (cells instance) cells)
(let ((cells (make-array cell-count)))
(dotimes (y height)
(dotimes (x width)
(let ((cell (make-instance 'cell :x x :y y)))
(setf (aref cells (+ (* y width) x)) cell))))
(setf (cells instance) cells)))
(setf (cell-count instance) (* width height))))
(u:fn-> make-grid (grid-dimension grid-dimension &optional simple-array) grid)
(defun make-grid (width height &optional cells)
(declare (optimize speed))
(values (make-instance 'grid :width width :height height :cells cells)))
(u:fn-> get-cell (grid fixnum fixnum &key (:periodic-p boolean)) (or cell null))
(defun get-cell (grid x y &key periodic-p)
(declare (optimize speed))
(let ((width (width grid))
(height (height grid))
(cells (cells grid)))
(declare (u:ub16 width height)
((simple-array t) cells))
(if periodic-p
(aref cells (+ (* (mod y height) width) (mod x width)))
(when (and (<= 0 x)
(< x width)
(<= 0 y)
(< y height))
(aref cells (+ (* y width) x))))))
(defmacro do-cells ((grid cell) &body body)
(u:with-gensyms (width height cells x y)
`(let ((,width (width ,grid))
(,height (height ,grid))
(,cells (cells ,grid)))
(declare (u:ub16 ,width ,height)
((simple-array t) ,cells))
(dotimes (,y ,height)
(dotimes (,x ,width)
(let ((,cell (aref ,cells (+ (* ,y ,width) ,x))))
,@body))))))

206
src/wfc/kernel.lisp

@ -0,0 +1,206 @@
(in-package #:%syntex.wfc)
(deftype kernel-dimension () '(and u:ub8 (integer 1)))
(deftype rotation () '(integer 0 3))
(u:eval-always
(defclass kernel ()
((%grid :reader grid
:initarg :grid)
(%width :reader width
:initarg :width)
(%height :reader height
:initarg :height)
(%x :accessor x
:initform 0)
(%y :accessor y
:initform 0))))
(u:fn-> make-kernel (&key (:grid grid) (:width kernel-dimension) (:height kernel-dimension)) kernel)
(defun make-kernel (&key grid (width 2) (height 2))
(declare (optimize speed))
(values (make-instance 'kernel :grid grid :width width :height height)))
(u:fn-> transform-kernel/identity (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/identity))
(defun transform-kernel/identity (width height)
(declare (optimize speed))
(loop :with coords = nil
:for y :below height
:do (loop :for x :below width
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/reflect (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/reflect))
(defun transform-kernel/reflect (width height)
(declare (optimize speed))
(loop :with coords = nil
:for y :below height
:do (loop :for x :from (1- width) :downto 0
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-90 (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-90))
(defun transform-kernel/rotate-90 (width height)
(declare (optimize speed))
(loop :with coords = nil
:for x :below width
:do (loop :for y :from (1- height) :downto 0
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-90-reflect (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-90-reflect))
(defun transform-kernel/rotate-90-reflect (width height)
(declare (optimize speed))
(loop :with coords = nil
:for x :from (1- width) :downto 0
:do (loop :for y :from (1- height) :downto 0
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-180 (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-180))
(defun transform-kernel/rotate-180 (width height)
(declare (optimize speed))
(loop :with coords = nil
:for y :from (1- height) :downto 0
:do (loop :for x :from (1- width) :downto 0
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-180-reflect (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-180-reflect))
(defun transform-kernel/rotate-180-reflect (width height)
(declare (optimize speed))
(loop :with coords = nil
:for y :from (1- height) :downto 0
:do (loop :for x :below width
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-270 (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-270))
(defun transform-kernel/rotate-270 (width height)
(declare (optimize speed))
(loop :with coords = nil
:for x :from (1- width) :downto 0
:do (loop :for y :below height
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel/rotate-270-reflect (kernel-dimension kernel-dimension) list)
(declaim (inline transform-kernel/rotate-270-reflect))
(defun transform-kernel/rotate-270-reflect (width height)
(declare (optimize speed))
(loop :with coords = nil
:for x :below width
:do (loop :for y :below height
:do (push (cons x y) coords))
:finally (return (nreverse coords))))
(u:fn-> transform-kernel (kernel &key (:rotation rotation) (:reflect-p boolean)) list)
(defun transform-kernel (kernel &key (rotation 0) reflect-p)
(declare (optimize speed))
(let ((width (width kernel))
(height (height kernel)))
(ecase rotation
(0
(if reflect-p
(transform-kernel/reflect width height)
(transform-kernel/identity width height)))
(1
(if reflect-p
(transform-kernel/rotate-90-reflect width height)
(transform-kernel/rotate-90 width height)))
(2
(if reflect-p
(transform-kernel/rotate-180-reflect width height)
(transform-kernel/rotate-180 width height)))
(3
(if reflect-p
(transform-kernel/rotate-270-reflect width height)
(transform-kernel/rotate-270 width height))))))
(u:fn-> align-kernel (kernel fixnum fixnum) kernel)
(declaim (inline align-kernel))
(defun align-kernel (kernel x y)
(declare (optimize speed))
(setf (x kernel) x
(y kernel) y)
kernel)
(u:fn-> resolve-kernel (kernel u:b16 u:b16 &key (:periodic-p boolean)) (or cell null))
(defun resolve-kernel (kernel x y &key periodic-p)
(declare (optimize speed))
(get-cell (grid kernel)
(+ (the u:b16 (x kernel)) x)
(+ (the u:b16 (y kernel)) y)
:periodic-p periodic-p))
(u:fn-> map-kernel
(kernel function &key (:rotation rotation) (:reflect-p boolean) (:periodic-p boolean))
null)
(defun map-kernel (kernel func &key (rotation 0) reflect-p periodic-p)
(declare (optimize speed))
(loop :for (x . y) :in (transform-kernel kernel :rotation rotation :reflect-p reflect-p)
:for cell = (resolve-kernel kernel x y :periodic-p periodic-p)
:when cell
:do (funcall func cell)))
(u:fn-> map-kernel/left (kernel function &key (:periodic-p boolean)) null)
(declaim (inline map-kernel/left))
(defun map-kernel/left (kernel func &key periodic-p)
(declare (optimize speed))
(u:when-let ((cell (resolve-kernel kernel -1 0 :periodic-p periodic-p)))
(funcall func cell)
nil))
(u:fn-> map-kernel/right (kernel function &key (:periodic-p boolean)) null)
(declaim (inline map-kernel/right))
(defun map-kernel/right (kernel func &key periodic-p)
(declare (optimize speed))
(u:when-let ((cell (resolve-kernel kernel 1 0 :periodic-p periodic-p)))
(funcall func cell)
nil))
(u:fn-> map-kernel/up (kernel function &key (:periodic-p boolean)) null)
(declaim (inline map-kernel/up))
(defun map-kernel/up (kernel func &key periodic-p)
(declare (optimize speed))
(u:when-let ((cell (resolve-kernel kernel 0 -1 :periodic-p periodic-p)))
(funcall func cell)
nil))
(u:fn-> map-kernel/down (kernel function &key (:periodic-p boolean)) null)
(declaim (inline map-kernel/down))
(defun map-kernel/down (kernel func &key periodic-p)
(declare (optimize speed))
(u:when-let ((cell (resolve-kernel kernel 0 1 :periodic-p periodic-p)))
(funcall func cell)
nil))
(u:fn-> count-kernel (kernel &key (:test function)) u:ub8)
(defun count-kernel (kernel &key (test (constantly t)))
(declare (optimize speed))
(let ((count 0))
(declare (u:ub8 count))
(map-kernel kernel
(lambda (x)
(when (funcall test x)
(incf count))))
count))
(u:fn-> convolve (kernel function &key (:test function)) null)
(defun convolve (kernel func &key (test (constantly t)))
(declare (optimize speed))
(let ((grid (grid kernel)))
(dotimes (y (the u:ub16 (height grid)))
(dotimes (x (the u:ub16 (width grid)))
(setf (x kernel) x
(y kernel) y)
(when (funcall test kernel)
(funcall func kernel))))))

206
src/wfc/pattern.lisp

@ -0,0 +1,206 @@
(in-package #:%syntex.wfc)
(u:eval-always
(defclass pattern ()
((%id :accessor id
:initarg :id)
(%grid :reader grid
:initarg :grid)
(%size :reader size
:initarg :size)
(%x :reader x
:initarg :x)
(%y :reader y
:initarg :y)
(%frequency :accessor frequency
:initform 1)
(%data :reader data
:initarg :data))))
(u:fn-> make-data
(grid kernel &key (:size u:ub8) (:rotation rotation) (:reflect-p boolean)
(:periodic-p boolean))
u:ub32a)
(declaim (inline make-data))
(defun make-data (grid kernel &key size rotation reflect-p periodic-p)
(declare (optimize speed))
(let ((data (u:make-ub32-array (expt size 2)))
(cells (cells grid))
(index 0))
(declare (u:ub8 index)
((simple-array t) cells))
(map-kernel kernel
(lambda (x)
(let ((value (value x)))
(setf (aref data index) value
(value (aref cells index)) value)
(incf index)))
:rotation rotation
:reflect-p reflect-p
:periodic-p periodic-p)
data))
(u:fn-> make-pattern
(kernel &key (:size u:ub8) (:rotation rotation) (:reflect-p boolean)
(:periodic-p boolean))
pattern)
(defun make-pattern (kernel &key size (rotation 0) reflect-p periodic-p)
(declare (optimize speed))
(let* ((grid (make-grid size size))
(data (make-data grid
kernel
:size size
:rotation rotation
:reflect-p reflect-p
:periodic-p periodic-p)))
(values
(make-instance 'pattern
:grid grid
:size size
:x (x kernel)
:y (y kernel)
:data data))))
(u:fn-> register (core pattern) pattern)
(defun register (core pattern)
(declare (optimize speed))
(let ((data (data pattern))
(data->pattern (data->pattern core)))
(u:if-let ((existing (u:href data->pattern data)))
(incf (the u:ub32 (frequency existing)))
(setf (id pattern) (hash-table-count data->pattern)
(u:href data->pattern data) pattern))
pattern))
(u:fn-> make-id-map (core) null)
(defun make-id-map (core)
(declare (optimize speed))
(let* ((data->pattern (data->pattern core))
(pattern-count (hash-table-count data->pattern))
(id->pattern (make-array pattern-count)))
(u:do-hash-values (pattern data->pattern)
(let ((id (id pattern)))
(setf (aref id->pattern id) pattern)))
(setf (id->pattern core) id->pattern)
nil))
(u:fn-> extract-patterns (core &key (:size u:ub8) (:periodic-p boolean)) null)
(declaim (inline extract-patterns))
(defun extract-patterns (core &key size periodic-p)
(declare (optimize speed))
(let* ((sample (sample core))
(kernel (make-kernel :grid sample :width size :height size)))
(flet ((%extract (kernel)
(dotimes (rotation 4)
(dolist (reflect-p '(nil t))
(let ((pattern (make-pattern kernel
:size size