ea247d3d5953

Triangle fun
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Fri, 02 Feb 2018 00:03:38 -0500
parents e7c56841f0f4
children f2a11ed01196
branches/tags (none)
files Makefile src/art/simple.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

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