# HG changeset patch # User Steve Losh # Date 1517967759 18000 # Node ID 634d90a45d472a517d7810492213404fa2e8d546 # Parent eefee58dd4934f656114cdefe4c6cc66c083bc5c Add some basic L-Systems diff -r eefee58dd493 -r 634d90a45d47 .lispwords --- 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) diff -r eefee58dd493 -r 634d90a45d47 flax.asd --- 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"))))))) diff -r eefee58dd493 -r 634d90a45d47 package.lisp --- 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)) + diff -r eefee58dd493 -r 634d90a45d47 src/drawing.lisp --- 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))) diff -r eefee58dd493 -r 634d90a45d47 src/looms/003-basic-l-systems.lisp --- /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)) diff -r eefee58dd493 -r 634d90a45d47 vendor/make-quickutils.lisp --- 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 diff -r eefee58dd493 -r 634d90a45d47 vendor/quickutils.lisp --- 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 ;;;;