# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1517686274 18000
# Node ID 55c0df99bd7affc82728e5d4d4fa714fc0c6d45d

Initial commit

diff -r 000000000000 -r 55c0df99bd7a .hgignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,5 @@
+syntax: glob
+lisp.prof
+*.pnm
+*.pgm
+scratch.lisp
diff -r 000000000000 -r 55c0df99bd7a .lispwords
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.lispwords	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,1 @@
+(2 with-coordinates)
diff -r 000000000000 -r 55c0df99bd7a LICENSE.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE.markdown	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,19 @@
+Copyright (c) 2018 Steve Losh and contributors
+
+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.
diff -r 000000000000 -r 55c0df99bd7a Makefile
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +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
diff -r 000000000000 -r 55c0df99bd7a README.markdown
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/README.markdown	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,2 @@
+Weaving art from seeds.
+
diff -r 000000000000 -r 55c0df99bd7a flax.asd
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/flax.asd	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,26 @@
+(asdf:defsystem :flax
+  :description "Weaving art from seeds."
+
+  :author "Steve Losh <steve@stevelosh.com>"
+  :license "MIT"
+
+  :depends-on (:cl-pcg
+               :cl-vectors
+               :iterate
+               :losh
+               :trivial-ppm)
+
+  :serial t
+  :components ((:module "vendor" :serial t
+                :components ((:file "quickutils-package")
+                             (:file "quickutils")))
+               (:file "package")
+               (:module "src" :serial t
+                :components
+                ((:file "base")
+                 (:file "coordinates")
+                 (:file "drawing")
+                 (:module "looms" :serial nil
+                  :components
+                  ((:file "001-triangles")))))))
+
diff -r 000000000000 -r 55c0df99bd7a package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/package.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,25 @@
+(defpackage :flax.base
+  (:use :cl :iterate :losh :flax.quickutils)
+  (:export :rand :with-seed))
+
+(defpackage :flax.coordinates
+  (:use :cl :iterate :losh :flax.base :flax.quickutils)
+  (:export
+    :coord :x :y
+    :distance
+    :clerp))
+
+(defpackage :flax.drawing
+  (:use :cl :iterate :losh :flax.base :flax.quickutils
+    :flax.coordinates)
+  (:export
+    :render
+    :triangle
+    :line))
+
+(defpackage :flax.looms.001-triangles
+  (:use :cl :iterate :losh :flax.base :flax.quickutils
+    :flax.coordinates)
+  (:export :loom))
+
+
diff -r 000000000000 -r 55c0df99bd7a src/base.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/base.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,7 @@
+(in-package :flax.base)
+
+(defun rand (bound)
+  (pcg:pcg-random t bound))
+
+(defmacro with-seed (seed &body body)
+  `(let ((pcg::*global-generator* (pcg:make-pcg :seed ,seed))) ,@body))
diff -r 000000000000 -r 55c0df99bd7a src/coordinates.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/coordinates.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,18 @@
+(in-package :flax.coordinates)
+
+(defstruct (coord (:conc-name "")
+                  (:constructor make-coord (x y)))
+  (x (error "Required") :type single-float)
+  (y (error "Required") :type single-float))
+
+(defun coord (x y)
+  (make-coord (coerce x 'single-float)
+              (coerce y 'single-float)))
+
+(defun distance (c1 c2)
+  (+ (square (- (x c2) (x c1)))
+     (square (- (y c2) (y c1)))))
+
+(defun clerp (from to n)
+  (coord (lerp (x from) (x to) n)
+         (lerp (y from) (y to) n)))
diff -r 000000000000 -r 55c0df99bd7a src/drawing.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/drawing.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,125 @@
+(in-package :flax.drawing)
+
+;;;; Utils --------------------------------------------------------------------
+(defconstant +padding+ 0.03)
+
+(defun convert-coord (value dimension)
+  (map-range (- +padding+) (1+ +padding+)
+             0 dimension
+             value))
+
+(defmacro with-coordinates (image bindings &body body)
+  (with-gensyms (width height)
+    `(destructuring-bind (,width ,height) (array-dimensions ,image)
+       (let* ,(iterate (for (x-symbol y-symbol coord) :in bindings)
+                       (for c = (gensym "coord"))
+                       (appending
+                         (list `(,c ,coord)
+                               `(,x-symbol (convert-coord (x ,c) ,width))
+                               `(,y-symbol (convert-coord (y ,c) ,height)))))
+         ,@body))))
+
+
+;;;; Drawing Protocol ---------------------------------------------------------
+(defgeneric draw (image state drawing-object))
+
+
+;;;; Lines --------------------------------------------------------------------
+(defclass line ()
+  ((a :type coord :accessor a :initarg :a)
+   (b :type coord :accessor b :initarg :b)))
+
+(defun line (a b)
+  (make-instance 'line :a a :b b))
+
+(defmethod print-object ((o line) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D) to (~D, ~D)"
+            (x (a o))
+            (y (a o))
+            (x (b o))
+            (y (b o)))))
+
+
+(defmethod draw (image state (l line))
+  (with-coordinates image
+      ((ax ay (a l))
+       (bx by (b l)))
+    (-<> (list (cons ax ay)
+               (cons bx by))
+      paths:make-simple-path
+      (paths:stroke-path <> 1)
+      (vectors:update-state state <>))))
+
+
+;;;; Triangles ----------------------------------------------------------------
+(defclass triangle ()
+  ((a :type coord :accessor a :initarg :a)
+   (b :type coord :accessor b :initarg :b)
+   (c :type coord :accessor c :initarg :c)))
+
+(defun triangle (a b c)
+  (make-instance 'triangle :a a :b b :c c))
+
+(defmethod print-object ((o triangle) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D) (~D, ~D) (~D, ~D)"
+            (x (a o))
+            (y (a o))
+            (x (b o))
+            (y (b o))
+            (x (c o))
+            (y (c o)))))
+
+
+(defmethod draw (image state (tri triangle))
+  (with-coordinates image
+      ((ax ay (a tri))
+       (bx by (b tri))
+       (cx cy (c tri)))
+    (-<> (list (cons ax ay)
+               (cons bx by)
+               (cons cx cy)
+               (cons ax ay))
+      paths:make-simple-path
+      (paths:stroke-path <> 1)
+      (vectors:update-state state <>))))
+
+
+;;;; Glue ---------------------------------------------------------------------
+(defun alpha-to-black (alpha)
+  (- 255 (min 255 (abs alpha))))
+
+(defun put-pixel (image x y alpha)
+  (zapf (aref image x y)
+        ;; (round (* (alpha-to-black alpha) %))
+        (min % (alpha-to-black alpha))
+        ))
+
+
+(defun make-grayscale-image (width height)
+  (make-array (list width height)
+    :element-type '(integer 0 255)
+    :initial-element 255))
+
+(defun write-file (image filename)
+  (trivial-ppm:write-to-file filename image :if-exists :supersede :format :pgm))
+
+
+(defun blit (image state)
+  (destructuring-bind (width height) (array-dimensions image)
+    (aa:cells-sweep/rectangle state 0 0 width height (curry #'put-pixel image))))
+
+(defun render (objects filename width height)
+  (format t "Rendering ~D objects~%" (length objects))
+  (finish-output)
+  ;; #+sbcl (sb-ext:gc :full t)
+  (let ((image (make-grayscale-image width height)))
+    (dolist (o objects)
+      (let ((state (aa:make-state)))
+        (draw image state o)
+        (blit image state)))
+    (write-file image filename))
+  ;; #+sbcl (sb-ext:gc :full t)
+  (values))
+
diff -r 000000000000 -r 55c0df99bd7a src/looms/001-triangles.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/looms/001-triangles.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,93 @@
+(in-package :flax.looms.001-triangles)
+
+
+(defstruct (triangle (:conc-name ""))
+  (a (coord 0 0) :type coord)
+  (b (coord 0 0) :type coord)
+  (c (coord 0 0) :type coord))
+
+(define-with-macro (triangle :conc-name "") a b c)
+
+(defun triangle (a b c)
+  (make-triangle :a a :b b :c c))
+
+
+(defun round-to (number divisor)
+  (* divisor (round number divisor)))
+
+(defun split-triangle-evenly (triangle)
+  (with-triangle (triangle)
+    (let* ((n 1/2)
+           (p (coord (lerp (x b) (x c) n)
+                     (lerp (y b) (y c) n))))
+      (list (triangle p b a)
+            (triangle p a c)))))
+
+(defun find-longest-side (triangle)
+  (with-triangle (triangle)
+    (let* ((ab (distance a b))
+           (bc (distance b c))
+           (ca (distance 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 ((p (-<> (random-gaussian 0.5 0.1 #'rand)
+               (clamp 0.3 0.7 <>)
+               (round-to <> 1/100)
+               (clerp b c <>))))
+      (list (triangle p b a)
+            (triangle p a c)))))
+
+(defun convert-to-drawing (triangle)
+  (with-triangle (triangle)
+    (flax.drawing:triangle a b c)))
+
+(defun initial-triangles ()
+  (list (triangle (coord 0 1)
+                  (coord 1 1)
+                  (coord 0 0))
+        (triangle (coord 1 0)
+                  (coord 1 1)
+                  (coord 0 0))))
+
+(defun generate-universe-even (depth &aux (triangles (initial-triangles)))
+  (do-repeat depth
+    (zapf triangles (mappend #'split-triangle-evenly %)))
+  triangles)
+
+(defun generate-universe-balancing (depth seed)
+  (losh::clear-gaussian-spare)
+  (with-seed seed
+    (gathering
+      (labels ((should-stop-p (iteration)
+                 (or (= depth iteration)
+                     (and (> iteration 6)
+                          (randomp (map-range 0 depth
+                                              0.0 0.05
+                                              iteration)
+                                   #'rand))))
+               (recur (triangle &optional (iteration 0))
+                 (if (should-stop-p iteration)
+                   (gather triangle)
+                   (map nil (rcurry #'recur (1+ iteration))
+                        (split-triangle-self-balancing triangle)))))
+        (map nil #'recur (initial-triangles))))))
+
+(defun render (universe filename width height)
+  (flax.drawing:render (mapcar #'convert-to-drawing universe)
+                       filename width height))
+
+(defun loom (seed depth filename width height)
+  (render (generate-universe-balancing depth seed)
+          filename width height))
+
+
+
+(time (loom nil 19 "out.pnm" 4000 4000))
diff -r 000000000000 -r 55c0df99bd7a vendor/make-quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/make-quickutils.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,16 @@
+(ql:quickload 'quickutil)
+
+(qtlc:save-utils-as
+  "quickutils.lisp"
+  :utilities '(
+
+               :compose
+               :curry
+               :mappend
+               :once-only
+               :rcurry
+               :symb
+               :with-gensyms
+
+               )
+  :package "FLAX.QUICKUTILS")
diff -r 000000000000 -r 55c0df99bd7a vendor/quickutils-package.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils-package.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,12 @@
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "FLAX.QUICKUTILS")
+    (defpackage "FLAX.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use :cl))))
+
+(in-package "FLAX.QUICKUTILS")
+
+;; need to define this here so sbcl will shut the hell up about it being
+;; undefined when compiling quickutils.lisp.  computers are trash.
+(defparameter *utilities* nil)
+
diff -r 000000000000 -r 55c0df99bd7a vendor/quickutils.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/vendor/quickutils.lisp	Sat Feb 03 14:31:14 2018 -0500
@@ -0,0 +1,213 @@
+;;;; This file was automatically generated by Quickutil.
+;;;; See http://quickutil.org for details.
+
+;;;; To regenerate:
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:COMPOSE :CURRY :MAPPEND :ONCE-ONLY :RCURRY :SYMB :WITH-GENSYMS) :ensure-package T :package "FLAX.QUICKUTILS")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (find-package "FLAX.QUICKUTILS")
+    (defpackage "FLAX.QUICKUTILS"
+      (:documentation "Package that contains Quickutil utility functions.")
+      (:use #:cl))))
+
+(in-package "FLAX.QUICKUTILS")
+
+(when (boundp '*utilities*)
+  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
+                                         :COMPOSE :CURRY :MAPPEND :ONCE-ONLY
+                                         :RCURRY :MKSTR :SYMB
+                                         :STRING-DESIGNATOR :WITH-GENSYMS))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun make-gensym-list (length &optional (x "G"))
+    "Returns a list of `length` gensyms, each generated as if with a call to `make-gensym`,
+using the second (optional, defaulting to `\"G\"`) argument."
+    (let ((g (if (typep x '(integer 0)) x (string x))))
+      (loop repeat length
+            collect (gensym g))))
+  )                                        ; eval-when
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;;; To propagate return type and allow the compiler to eliminate the IF when
+  ;;; it is known if the argument is function or not.
+  (declaim (inline ensure-function))
+
+  (declaim (ftype (function (t) (values function &optional))
+                  ensure-function))
+  (defun ensure-function (function-designator)
+    "Returns the function designated by `function-designator`:
+if `function-designator` is a function, it is returned, otherwise
+it must be a function name and its `fdefinition` is returned."
+    (if (functionp function-designator)
+        function-designator
+        (fdefinition function-designator)))
+  )                                        ; eval-when
+
+  (defun compose (function &rest more-functions)
+    "Returns a function composed of `function` and `more-functions` that applies its ;
+arguments to to each in turn, starting from the rightmost of `more-functions`,
+and then calling the next one with the primary value of the last."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (reduce (lambda (f g)
+              (let ((f (ensure-function f))
+                    (g (ensure-function g)))
+                (lambda (&rest arguments)
+                  (declare (dynamic-extent arguments))
+                  (funcall f (apply g arguments)))))
+            more-functions
+            :initial-value function))
+
+  (define-compiler-macro compose (function &rest more-functions)
+    (labels ((compose-1 (funs)
+               (if (cdr funs)
+                   `(funcall ,(car funs) ,(compose-1 (cdr funs)))
+                   `(apply ,(car funs) arguments))))
+      (let* ((args (cons function more-functions))
+             (funs (make-gensym-list (length args) "COMPOSE")))
+        `(let ,(loop for f in funs for arg in args
+                     collect `(,f (ensure-function ,arg)))
+           (declare (optimize (speed 3) (safety 1) (debug 1)))
+           (lambda (&rest arguments)
+             (declare (dynamic-extent arguments))
+             ,(compose-1 funs))))))
+  
+
+  (defun curry (function &rest arguments)
+    "Returns a function that applies `arguments` and the arguments
+it is called with to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        ;; Using M-V-C we don't need to append the arguments.
+        (multiple-value-call fn (values-list arguments) (values-list more)))))
+
+  (define-compiler-macro curry (function &rest arguments)
+    (let ((curries (make-gensym-list (length arguments) "CURRY"))
+          (fun (gensym "FUN")))
+      `(let ((,fun (ensure-function ,function))
+             ,@(mapcar #'list curries arguments))
+         (declare (optimize (speed 3) (safety 1) (debug 1)))
+         (lambda (&rest more)
+           (apply ,fun ,@curries more)))))
+  
+
+  (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))
+  
+
+  (defmacro once-only (specs &body forms)
+    "Evaluates `forms` with symbols specified in `specs` rebound to temporary
+variables, ensuring that each initform is evaluated only once.
+
+Each of `specs` must either be a symbol naming the variable to be rebound, or of
+the form:
+
+    (symbol initform)
+
+Bare symbols in `specs` are equivalent to
+
+    (symbol symbol)
+
+Example:
+
+    (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
+      (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
+    (let ((gensyms (make-gensym-list (length specs) "ONCE-ONLY"))
+          (names-and-forms (mapcar (lambda (spec)
+                                     (etypecase spec
+                                       (list
+                                        (destructuring-bind (name form) spec
+                                          (cons name form)))
+                                       (symbol
+                                        (cons spec spec))))
+                                   specs)))
+      ;; bind in user-macro
+      `(let ,(mapcar (lambda (g n) (list g `(gensym ,(string (car n)))))
+              gensyms names-and-forms)
+         ;; bind in final expansion
+         `(let (,,@(mapcar (lambda (g n)
+                             ``(,,g ,,(cdr n)))
+                           gensyms names-and-forms))
+            ;; bind in user-macro
+            ,(let ,(mapcar (lambda (n g) (list (car n) g))
+                    names-and-forms gensyms)
+               ,@forms)))))
+  
+
+  (defun rcurry (function &rest arguments)
+    "Returns a function that applies the arguments it is called
+with and `arguments` to `function`."
+    (declare (optimize (speed 3) (safety 1) (debug 1)))
+    (let ((fn (ensure-function function)))
+      (lambda (&rest more)
+        (declare (dynamic-extent more))
+        (multiple-value-call fn (values-list more) (values-list arguments)))))
+  
+
+  (defun mkstr (&rest args)
+    "Receives any number of objects (string, symbol, keyword, char, number), extracts all printed representations, and concatenates them all into one string.
+
+Extracted from _On Lisp_, chapter 4."
+    (with-output-to-string (s)
+      (dolist (a args) (princ a s))))
+  
+
+  (defun symb (&rest args)
+    "Receives any number of objects, concatenates all into one string with `#'mkstr` and converts them to symbol.
+
+Extracted from _On Lisp_, chapter 4.
+
+See also: `symbolicate`"
+    (values (intern (apply #'mkstr args))))
+  
+
+  (deftype string-designator ()
+    "A string designator type. A string designator is either a string, a symbol,
+or a character."
+    `(or symbol string character))
+  
+
+  (defmacro with-gensyms (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(let ,(mapcar (lambda (name)
+                     (multiple-value-bind (symbol string)
+                         (etypecase name
+                           (symbol
+                            (values name (symbol-name name)))
+                           ((cons symbol (cons string-designator null))
+                            (values (first name) (string (second name)))))
+                       `(,symbol (gensym ,string))))
+            names)
+       ,@forms))
+
+  (defmacro with-unique-names (names &body forms)
+    "Binds each variable named by a symbol in `names` to a unique symbol around
+`forms`. Each of `names` must either be either a symbol, or of the form:
+
+    (symbol string-designator)
+
+Bare symbols appearing in `names` are equivalent to:
+
+    (symbol symbol)
+
+The string-designator is used as the argument to `gensym` when constructing the
+unique symbol the named variable will be bound to."
+    `(with-gensyms ,names ,@forms))
+  
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(compose curry mappend once-only rcurry symb with-gensyms
+            with-unique-names)))
+
+;;;; END OF quickutils.lisp ;;;;