634d90a45d47

Add some basic L-Systems
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Tue, 06 Feb 2018 20:42:39 -0500
parents eefee58dd493
children 2288ce7181a1
branches/tags (none)
files .lispwords flax.asd package.lisp src/drawing.lisp src/looms/003-basic-l-systems.lisp vendor/make-quickutils.lisp vendor/quickutils.lisp

Changes

--- a/.lispwords	Tue Feb 06 19:06:57 2018 -0500
+++ b/.lispwords	Tue Feb 06 20:42:39 2018 -0500
@@ -1,1 +1,2 @@
 (2 with-coordinates)
+(1 with-rendering)
--- a/flax.asd	Tue Feb 06 19:06:57 2018 -0500
+++ b/flax.asd	Tue Feb 06 20:42:39 2018 -0500
@@ -24,5 +24,6 @@
                  (:module "looms" :serial nil
                   :components
                   ((:file "001-triangles")
-                   (:file "002-wobbly-lines")))))))
+                   (:file "002-wobbly-lines")
+                   (:file "003-basic-l-systems")))))))
 
--- a/package.lisp	Tue Feb 06 19:06:57 2018 -0500
+++ b/package.lisp	Tue Feb 06 20:42:39 2018 -0500
@@ -26,7 +26,8 @@
     :render
     :fade
     :triangle
-    :path))
+    :path
+    :rectangle))
 
 (defpackage :flax.looms.001-triangles
   (:use :cl :iterate :losh :flax.base :flax.quickutils
@@ -39,4 +40,10 @@
     :flax.coordinates)
   (:export :loom))
 
+(defpackage :flax.looms.003-basic-l-systems
+  (:use :cl :iterate :losh :flax.base :flax.quickutils
+    :flax.colors
+    :flax.coordinates)
+  (:export :loom))
 
+
--- a/src/drawing.lisp	Tue Feb 06 19:06:57 2018 -0500
+++ b/src/drawing.lisp	Tue Feb 06 20:42:39 2018 -0500
@@ -93,6 +93,42 @@
       (vectors:update-state state <>))))
 
 
+;;;; Rectangles ---------------------------------------------------------------
+(defclass rectangle (drawable)
+  ((a :type coord :accessor a :initarg :a)
+   (b :type coord :accessor b :initarg :b)
+   (round-corners :type (or null integer)
+                  :accessor round-corners
+                  :initarg :round-corners)))
+
+(defun rectangle (a b &key (opacity 1.0d0) (color *black*) round-corners)
+  (make-instance 'rectangle :a a :b b
+    :color color
+    :opacity opacity
+    :round-corners round-corners))
+
+(defmethod print-object ((o rectangle) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "(~D, ~D) (~D, ~D)"
+            (x (a o))
+            (y (a o))
+            (x (b o))
+            (y (b o)))))
+
+(defmethod draw (image state (rect rectangle))
+  (with-coordinates image
+      ((ax ay (a rect))
+       (bx by (b rect)))
+    (-<> (paths:make-rectangle-path ax ay bx by
+                                    :round (* (round-corners rect)
+                                              (* (- 1.0 *padding* *padding*)
+                                                 (min (array-dimension image 0)
+                                                      (array-dimension image 1)))))
+      ;; paths:make-simple-path
+      ;; (paths:stroke-path <> 1)
+      (vectors:update-state state <>))))
+
+
 ;;;; Glue ---------------------------------------------------------------------
 (deftype image ()
   '(simple-array (double-float 0.0d0 1.0d0) (* * 3)))
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/looms/003-basic-l-systems.lisp	Tue Feb 06 20:42:39 2018 -0500
@@ -0,0 +1,105 @@
+(in-package :flax.looms.003-basic-l-systems)
+
+;;;; L-Systems ----------------------------------------------------------------
+(defclass lsystem ()
+  ((axiom :type list :accessor axiom :initarg :axiom)
+   (productions :type hash-table :accessor productions :initarg :productions)))
+
+(defun make-lsystem (axiom productions)
+  (make-instance 'lsystem
+    :axiom (ensure-list axiom)
+    :productions (iterate (with result = (make-hash-table))
+                          (for (symbol . word) :in productions)
+                          (setf (gethash symbol result)
+                                (ensure-list word))
+                          (finally (return result)))))
+
+(defun run-lsystem (lsystem iterations mutate callback)
+  (recursively ((word (axiom lsystem))
+                (iteration 0))
+    (when callback
+      (funcall callback iteration word))
+    (if (= iterations iteration)
+      word
+      (recur (funcall mutate (mappend (rcurry #'gethash (productions lsystem)) word))
+             (1+ iteration)))))
+
+(defmacro define-lsystem (name axiom &rest productions)
+  (let ((var (symb '* name '*)))
+    `(progn
+       (defparameter ,var (make-lsystem ',axiom ',productions))
+       (defun ,name (iterations &key mutate callback)
+         (run-lsystem ,var iterations mutate callback)))))
+
+
+(define-lsystem anabaena-catenula ar
+  (ar . (al br))
+  (al . (bl ar))
+  (br . ar)
+  (bl . al))
+
+
+(defun cull (word)
+  (iterate
+    (with chance = (map-range 0 150
+                              0 0.8
+                              (length word)))
+    (for symbol :in word)
+    (if-first-time
+      (collect symbol)
+      (unless (randomp chance #'rand)
+        (collect symbol)))))
+
+
+;;;; Drawing ------------------------------------------------------------------
+(defparameter *cell-unit* 0.007)
+(defparameter *aspect-ratio* 9/8)
+(defparameter *cell-width*  (* *cell-unit* *aspect-ratio*))
+(defparameter *cell-height* (* *cell-unit* (/ *aspect-ratio*)))
+(defparameter *horizontal-padding* (/ *cell-width* 2))
+(defparameter *vertical-padding* (/ *cell-height* 1.5))
+(defparameter *brush* (rgb 1.000 0.920 0.850))
+(defparameter *background* (rgb 0.337 0.196 0.063))
+
+(defun symbol-width (symbol)
+  (ecase symbol
+    ((al ar) (* 2 *cell-width*))
+    ((bl br) *cell-width*)))
+
+(defun word-width (word)
+  (+ (reduce #'+ word :key #'symbol-width)
+     (* (1- (length word)) *horizontal-padding*)))
+
+(defun convert-symbol (symbol x y)
+  (flax.drawing:rectangle
+    (coord x y)
+    (coord (+ x (symbol-width symbol))
+           (+ y *cell-height*))
+    :color *brush*
+    :round-corners (/ *cell-unit* 2)))
+
+(defun convert (word iteration)
+  (let ((y (* iteration (+ *cell-height* *vertical-padding*)))
+        (width (word-width word)))
+    (iterate
+      (with x = (- 0.5 (/ width 2)))
+      (for symbol :in word)
+      (collect (convert-symbol symbol x y))
+      (incf x (+ (symbol-width symbol) *horizontal-padding*)))))
+
+
+(defun maximum-words ()
+  (truncate 1.0 (+ *cell-height* *vertical-padding*)))
+
+
+;;;; Main ---------------------------------------------------------------------
+(defun loom-anabaena-catenula (seed filename width height)
+  (with-seed seed
+    (flax.drawing:with-rendering
+        (image filename width height :background *background*)
+      (anabaena-catenula (maximum-words)
+                         :mutate #'cull
+                         :callback (lambda (iteration word)
+                                     (flax.drawing:render image (convert word iteration)))))))
+
+;; (time (loom-anabaena-catenula nil "out.png" 2000 2000))
--- a/vendor/make-quickutils.lisp	Tue Feb 06 19:06:57 2018 -0500
+++ b/vendor/make-quickutils.lisp	Tue Feb 06 20:42:39 2018 -0500
@@ -4,8 +4,10 @@
   "quickutils.lisp"
   :utilities '(
 
+               :alist-hash-table
                :compose
                :curry
+               :ensure-list
                :mappend
                :once-only
                :rcurry
--- a/vendor/quickutils.lisp	Tue Feb 06 19:06:57 2018 -0500
+++ b/vendor/quickutils.lisp	Tue Feb 06 20:42:39 2018 -0500
@@ -2,7 +2,7 @@
 ;;;; 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")
+;;;; (qtlc:save-utils-as "quickutils.lisp" :utilities '(:ALIST-HASH-TABLE :COMPOSE :CURRY :ENSURE-LIST :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")
@@ -13,10 +13,20 @@
 (in-package "FLAX.QUICKUTILS")
 
 (when (boundp '*utilities*)
-  (setf *utilities* (union *utilities* '(:MAKE-GENSYM-LIST :ENSURE-FUNCTION
-                                         :COMPOSE :CURRY :MAPPEND :ONCE-ONLY
+  (setf *utilities* (union *utilities* '(:ALIST-HASH-TABLE :MAKE-GENSYM-LIST
+                                         :ENSURE-FUNCTION :COMPOSE :CURRY
+                                         :ENSURE-LIST :MAPPEND :ONCE-ONLY
                                          :RCURRY :MKSTR :SYMB
                                          :STRING-DESIGNATOR :WITH-GENSYMS))))
+
+  (defun alist-hash-table (alist &rest hash-table-initargs)
+    "Returns a hash table containing the keys and values of the association list
+`alist`. Hash table is initialized using the `hash-table-initargs`."
+    (let ((table (apply #'make-hash-table hash-table-initargs)))
+      (dolist (cons alist)
+        (setf (gethash (car cons) table) (cdr cons)))
+      table))
+  
 (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`,
@@ -90,6 +100,13 @@
            (apply ,fun ,@curries more)))))
   
 
+  (defun ensure-list (list)
+    "If `list` is a list, it is returned. Otherwise returns the list designated by `list`."
+    (if (listp list)
+        list
+        (list list)))
+  
+
   (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."
@@ -207,7 +224,7 @@
     `(with-gensyms ,names ,@forms))
   
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  (export '(compose curry mappend once-only rcurry symb with-gensyms
-            with-unique-names)))
+  (export '(alist-hash-table compose curry ensure-list mappend once-only rcurry
+            symb with-gensyms with-unique-names)))
 
 ;;;; END OF quickutils.lisp ;;;;