# HG changeset patch # User Steve Losh # Date 1517547818 18000 # Node ID ea247d3d5953777296ea17da923a494832f9c3b7 # Parent e7c56841f0f4c0ca7126736505087dce1adbc5d4 Triangle fun diff -r e7c56841f0f4 -r ea247d3d5953 Makefile --- 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)' diff -r e7c56841f0f4 -r ea247d3d5953 src/art/simple.lisp --- 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))) diff -r e7c56841f0f4 -r ea247d3d5953 vendor/make-quickutils.lisp --- 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 diff -r e7c56841f0f4 -r ea247d3d5953 vendor/quickutils.lisp --- 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)))