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