--- a/Makefile Thu Feb 01 22:22:26 2018 -0500
+++ b/Makefile Fri Feb 02 00:03:38 2018 -0500
@@ -1,6 +1,7 @@
.PHONY: vendor
+# Vendor ----------------------------------------------------------------------
+vendor/quickutils.lisp: vendor/make-quickutils.lisp
+ cd vendor && sbcl --noinform --load make-quickutils.lisp --eval '(quit)'
+
vendor: vendor/quickutils.lisp
-
-vendor/quickutils.lisp: vendor/make-quickutils.lisp
- cd vendor && ros run -L sbcl --load make-quickutils.lisp --eval '(quit)'
--- a/src/art/simple.lisp Thu Feb 01 22:22:26 2018 -0500
+++ b/src/art/simple.lisp Fri Feb 02 00:03:38 2018 -0500
@@ -2,18 +2,14 @@
(ql:quickload '(:trivial-ppm)))
(defpackage :sand.art.simple
- (:use
- :cl
- :losh
- :iterate
- :sand.quickutils))
+ (:use :cl :losh :iterate :sand.quickutils))
(in-package :sand.art.simple)
;; http://www.tylerlhobbs.com/writings/triangle-subdivision
(defun v (x y)
- (make-array 2 :element-type 'single-float :initial-contents (list x y)))
+ (make-array 2 :element-type 'real :initial-contents (list x y)))
(defun-inline x (v)
(aref v 0))
@@ -26,30 +22,67 @@
(v (+ (x v1) (x v2))
(+ (y v1) (y v2))))
+(defun v- (v1 v2)
+ (v (- (x v1) (x v2))
+ (- (y v1) (y v2))))
+
(defun v/ (v scalar)
(v (/ (x v) scalar)
(/ (y v) scalar)))
+(defun vm2 (v)
+ (+ (square (x v))
+ (square (y v))))
+
(defstruct (triangle (:conc-name ""))
- (a (v 0.0 0.0) :type (simple-array single-float (2)))
- (b (v 0.0 0.0) :type (simple-array single-float (2)))
- (c (v 0.0 0.0) :type (simple-array single-float (2))))
+ (a (v 0.0 0.0) :type (simple-array real (2)))
+ (b (v 0.0 0.0) :type (simple-array real (2)))
+ (c (v 0.0 0.0) :type (simple-array real (2))))
+
+(define-with-macro (triangle :conc-name "") a b c)
(defun triangle (a b c)
(make-triangle :a a :b b :c c))
+(defun-inline blend (old-color new-color transparency)
+ (round (map-range 255 0
+ old-color new-color
+ transparency)))
+
(defun-inline draw-pixel (image x y color)
- (setf (aref image x y) color))
+ (zapf (aref image x y) (blend % 0 color)))
(defun draw-vertical-line (image x y1 y2)
- (iterate (for y :from (min y1 y2) :to (max y1 y2))
- (draw-pixel image x y 0)))
+ (iterate
+ (with x2 = (if (zerop x) 1 (1- x)))
+ (for y :from (min y1 y2) :to (max y1 y2))
+ (draw-pixel image x y 10)
+ (draw-pixel image x2 y (- 255 20))))
(defun draw-horizontal-line (image x1 x2 y)
- (iterate (for x :from (min x1 x2) :to (max x1 x2))
- (draw-pixel image x y 0)))
+ (iterate
+ (with y2 = (if (zerop y) 1 (1- y)))
+ (for x :from (min x1 x2) :to (max x1 x2))
+ (draw-pixel image x y 10)
+ (draw-pixel image x y2 (- 255 20))))
+
+(defun draw-diagonal-line (image x1 y1 x2 y2)
+ (when (> x1 x2)
+ (rotatef x1 x2)
+ (rotatef y1 y2))
+ (iterate
+ (with last = (1- (array-dimension image 1)))
+ (with dy = (if (> y2 y1) 1 -1))
+ (for x :from x1 :to x2)
+ (for y :from y1 :by dy)
+ (draw-pixel image x y 10)
+ (unless (zerop y)
+ (draw-pixel image x (- y 1) (- 255 50)))
+ (unless (= last y)
+ (draw-pixel image x (+ y 1) (- 255 50)))
+ ))
(defconstant +wu-bits+ 16)
@@ -59,7 +92,7 @@
`(unsigned-byte ,+wu-bits+))
(deftype wu-signed ()
- `(signed-byte ,(1+ +wu-bits+)))
+ `(signed-byte 32))
(defun-inline wu+ (value increment)
(multiple-value-bind (overflow result)
@@ -114,11 +147,13 @@
(define-wu wu-horizontal nil)
(define-wu wu-vertical t)
-(defun draw-line (image x1 y1 x2 y2)
+
+(defun wu-draw-line (image x1 y1 x2 y2)
(let ((dx (abs (- x2 x1)))
(dy (abs (- y2 y1))))
(cond ((zerop dx) (draw-vertical-line image x1 y1 y2))
((zerop dy) (draw-horizontal-line image x1 x2 y1))
+ ((= dy dx) (draw-diagonal-line image x1 y1 x2 y2))
((> dy dx) (if (> y1 y2)
(wu-vertical image x2 y2 x1 y1)
(wu-vertical image x1 y1 x2 y2)))
@@ -126,40 +161,118 @@
(wu-horizontal image x2 y2 x1 y1)
(wu-horizontal image x1 y1 x2 y2))))))
+
+
(defun image-coords (image point)
(destructuring-bind (width height) (array-dimensions image)
- (values (truncate (* (x point) (1- width)))
- (truncate (* (y point) (1- height))))))
+ (values (round (* (x point) (1- width)))
+ (round (* (y point) (1- height))))))
+
+(defun draw-line (image p1 p2)
+ (multiple-value-bind (x1 y1) (image-coords image p1)
+ (multiple-value-bind (x2 y2) (image-coords image p2)
+ (wu-draw-line image x1 y1 x2 y2))))
+
-(defun slope (v1 v2)
- (let ((run (- (x v2) (x v1)))
- (rise (- (y v2) (y v1))))
- (/ rise run)))
+(defun line< (p1 p2)
+ (let ((x1 (aref p1 0))
+ (y1 (aref p1 1))
+ (x2 (aref p2 0))
+ (y2 (aref p2 1)))
+ (cond
+ ((< x1 x2) t)
+ ((= x1 x2) (< y1 y2)))))
+
+(defun canonical-line (a b)
+ (sort (list a b) #'line<))
+(defun triangle-lines (triangle)
+ (with-triangle (triangle)
+ (list (canonical-line a b)
+ (canonical-line b c)
+ (canonical-line c a))))
+
+(defun draw-triangles (image triangles)
+ (map nil (lambda (line)
+ (destructuring-bind (a b) line
+ (draw-line image a b)))
+ (remove-duplicates (mappend #'triangle-lines triangles)
+ :test #'equalp)))
(defun draw-triangle (image triangle)
- (draw-line image (a triangle) (b triangle))
- (draw-line image (b triangle) (c triangle))
- (draw-line image (c triangle) (a triangle)))
+ (with-triangle (triangle)
+ (draw-line image a b)
+ (draw-line image b c)
+ (draw-line image c a)))
+
+(defun round-to (number divisor)
+ (* divisor (round number divisor)))
-(defun split-triangle (triangle)
- (let* ((a (a triangle))
- (b (b triangle))
- (c (c triangle))
- (n (clamp 0.2 0.8 (random-gaussian 0.5 0.05)))
- (p (v (lerp (x b) (x c) n)
- (lerp (y b) (y c) n))))
- (list (triangle p b a)
- (triangle p a c))))
+(defun split-triangle-evenly (triangle)
+ (with-triangle (triangle)
+ (let* ((n 1/2)
+ (p (v (lerp (x b) (x c) n)
+ (lerp (y b) (y c) n))))
+ (list (triangle p b a)
+ (triangle p a c)))))
+
+(defun split-triangle-randomly (triangle)
+ (with-triangle (triangle)
+ (let* ((n (-<> (random-gaussian 0.5 0.2)
+ (clamp 0.1 0.9 <>)
+ (round-to <> 1/100)))
+ (p (v (lerp (x b) (x c) n)
+ (lerp (y b) (y c) n))))
+ (list (triangle p b a)
+ (triangle p a c)))))
-(defun draw (width height)
- (let ((image (make-array (list width height) :initial-element 255)))
- (draw-line image 0 10 50 6)
- (draw-line image 0 20 50 25)
- (draw-line image 10 30 15 45)
- (time (iterate (repeat 100000)
- (draw-line image 0 0 (1- width) (- height 5))))
+(defun find-longest-side (triangle)
+ (with-triangle (triangle)
+ (let* ((ab (vm2 (v- a b)))
+ (bc (vm2 (v- b c)))
+ (ca (vm2 (v- c a)))
+ (longest (max ab bc ca)))
+ (cond
+ ((= longest ab) (list c a b))
+ ((= longest bc) (list a c b))
+ ((= longest ca) (list b c a))
+ (t (error "what?"))))))
+
+(defun split-triangle-self-balancing (triangle)
+ (destructuring-bind (a b c) (find-longest-side triangle)
+ (let* ((n (-<> (random-gaussian 0.5 0.15)
+ (clamp 0.3 0.7 <>)
+ (round-to <> 1/100)))
+ (p (v (lerp (x b) (x c) n)
+ (lerp (y b) (y c) n))))
+ (list (triangle p b a)
+ (triangle p a c)))))
+
+
+(defun draw (width height &optional (depth 2))
+ (let* ((image (make-array (list width height) :initial-element 255))
+ (pad 1/100)
+ (z pad)
+ (o (- 1 pad))
+ (initial (list (triangle (v z o)
+ (v o o)
+ (v z z))
+ (triangle (v o z)
+ (v o o)
+ (v z z)))))
+ ;; (recursively ((depth depth)
+ ;; (triangles initial))
+ ;; (if (or (zerop depth) (randomp 0.05))
+ ;; (draw-triangles image triangles)
+ ;; (recur (1- depth) (mappend #'split-triangle-self-balancing triangles))))
+ (labels ((recur (d triangle)
+ (if (or (zerop d) (randomp (map-range depth 0
+ 0.0 0.07
+ d)))
+ (draw-triangle image triangle)
+ (map nil (curry #'recur (1- d)) (split-triangle-self-balancing triangle)))))
+ (map nil (curry #'recur depth) initial))
(trivial-ppm:write-to-file "image.pgm" image
:format :pgm
:if-exists :supersede)))
--- a/vendor/make-quickutils.lisp Thu Feb 01 22:22:26 2018 -0500
+++ b/vendor/make-quickutils.lisp Fri Feb 02 00:03:38 2018 -0500
@@ -19,6 +19,7 @@
:hash-table-plist
:hash-table-values
:iota
+ :mappend
:n-grams
:once-only
:range
--- a/vendor/quickutils.lisp Thu Feb 01 22:22:26 2018 -0500
+++ b/vendor/quickutils.lisp Fri Feb 02 00:03:38 2018 -0500
@@ -2,7 +2,7 @@
;;;; See http://quickutil.org for details.
;;;; To regenerate:
-;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :ENSURE-LIST :EXTREMUM :FLIP :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SEPARATED-STRING-APPEND :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS :WRITE-STRING-INTO-FILE) :ensure-package T :package "SAND.QUICKUTILS")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :COPY-ARRAY :CURRY :DEFINE-CONSTANT :ENSURE-BOOLEAN :ENSURE-GETHASH :ENSURE-KEYWORD :ENSURE-LIST :EXTREMUM :FLIP :HASH-TABLE-ALIST :HASH-TABLE-KEYS :HASH-TABLE-PLIST :HASH-TABLE-VALUES :IOTA :MAPPEND :N-GRAMS :ONCE-ONLY :RANGE :RCURRY :READ-FILE-INTO-STRING :REQUIRED-ARGUMENT :RIFFLE :SEPARATED-STRING-APPEND :SUBDIVIDE :SYMB :TREE-COLLECT :WITH-GENSYMS :WRITE-STRING-INTO-FILE) :ensure-package T :package "SAND.QUICKUTILS")
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package "SAND.QUICKUTILS")
@@ -21,9 +21,9 @@
:HASH-TABLE-ALIST :MAPHASH-KEYS
:HASH-TABLE-KEYS :HASH-TABLE-PLIST
:MAPHASH-VALUES :HASH-TABLE-VALUES
- :IOTA :TAKE :N-GRAMS :ONCE-ONLY :RANGE
- :RCURRY :WITH-OPEN-FILE*
- :WITH-INPUT-FROM-FILE
+ :IOTA :MAPPEND :TAKE :N-GRAMS
+ :ONCE-ONLY :RANGE :RCURRY
+ :WITH-OPEN-FILE* :WITH-INPUT-FROM-FILE
:READ-FILE-INTO-STRING
:REQUIRED-ARGUMENT :RIFFLE
:SEPARATED-STRING-APPEND :SUBDIVIDE
@@ -310,6 +310,13 @@
collect i))
+ (defun mappend (function &rest lists)
+ "Applies `function` to respective element(s) of each `list`, appending all the
+all the result list to a single list. `function` must return a list."
+ (loop for results in (apply #'mapcar function lists)
+ append results))
+
+
(defun take (n sequence)
"Take the first `n` elements from `sequence`."
(subseq sequence 0 n))
@@ -615,7 +622,7 @@
(export '(compose copy-array curry define-constant ensure-boolean
ensure-gethash ensure-keyword ensure-list extremum flip
hash-table-alist hash-table-keys hash-table-plist hash-table-values
- iota n-grams once-only range rcurry read-file-into-string
+ iota mappend n-grams once-only range rcurry read-file-into-string
required-argument riffle separated-string-append
separated-string-append* subdivide symb tree-collect with-gensyms
with-unique-names write-string-into-file)))