# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1517720569 18000
# Node ID d3a901ef3501034ab5df0a20230bac2947278319
# Parent  3ab52c60dfee82dc9db7486de20631360c936ba3
Loom 2

diff -r 3ab52c60dfee -r d3a901ef3501 package.lisp
--- a/package.lisp	Sat Feb 03 15:42:30 2018 -0500
+++ b/package.lisp	Sun Feb 04 00:02:49 2018 -0500
@@ -13,13 +13,20 @@
   (:use :cl :iterate :losh :flax.base :flax.quickutils
     :flax.coordinates)
   (:export
+    :with-rendering
     :render
     :triangle
-    :line))
+    :path))
+
 
 (defpackage :flax.looms.001-triangles
   (:use :cl :iterate :losh :flax.base :flax.quickutils
     :flax.coordinates)
   (:export :loom))
 
+(defpackage :flax.looms.002-wobbly-lines
+  (:use :cl :iterate :losh :flax.base :flax.quickutils
+    :flax.coordinates)
+  (:export :loom))
 
+
diff -r 3ab52c60dfee -r d3a901ef3501 src/drawing.lisp
--- a/src/drawing.lisp	Sat Feb 03 15:42:30 2018 -0500
+++ b/src/drawing.lisp	Sun Feb 04 00:02:49 2018 -0500
@@ -1,10 +1,10 @@
 (in-package :flax.drawing)
 
 ;;;; Utils --------------------------------------------------------------------
-(defconstant +padding+ 0.03)
+(defparameter *padding* 0.03)
 
 (defun convert-coord (value dimension)
-  (map-range (- +padding+) (1+ +padding+)
+  (map-range (- *padding*) (1+ *padding*)
              0 dimension
              value))
 
@@ -23,43 +23,47 @@
 ;;;; 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)))))
+(defclass drawable ()
+  ((opacity :type (single-float 0.0 1.0) :accessor opacity :initarg :opacity)))
 
 
-(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 <>))))
+;;;; Paths --------------------------------------------------------------------
+(defclass path (drawable)
+  ((points :type list :accessor points :initarg :points)))
+
+(defun path (points &key (opacity 1.0))
+  (make-instance 'path
+    :points points
+    :opacity opacity))
+
+(defun coord-to-string (c)
+  (format nil "(~A, ~A)" (x c) (y c)))
+
+(defun coord-to-pair (image c)
+  (with-coordinates image ((x y c))
+    (cons x y)))
+
+(defmethod print-object ((o path) s)
+  (print-unreadable-object (o s :type t :identity nil)
+    (format s "~{~A~^ -> ~}"
+            (mapcar #'coord-to-string (points o)))))
+
+(defmethod draw (image state (p path))
+  (-<> (points p)
+    (mapcar (curry #'coord-to-pair image) <>)
+    paths:make-simple-path
+    (paths:stroke-path <> 1)
+    (vectors:update-state state <>)))
 
 
 ;;;; Triangles ----------------------------------------------------------------
-(defclass triangle ()
+(defclass triangle (drawable)
   ((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))
+(defun triangle (a b c &key (opacity 1.0))
+  (make-instance 'triangle :a a :b b :c c :opacity opacity))
 
 (defmethod print-object ((o triangle) s)
   (print-unreadable-object (o s :type t :identity nil)
@@ -71,7 +75,6 @@
             (x (c o))
             (y (c o)))))
 
-
 (defmethod draw (image state (tri triangle))
   (with-coordinates image
       ((ax ay (a tri))
@@ -87,39 +90,72 @@
 
 
 ;;;; Glue ---------------------------------------------------------------------
-(defun alpha-to-black (alpha)
-  (- 255 (min 255 (abs alpha))))
+(deftype image ()
+  '(simple-array t (* *)))
 
-(defun put-pixel (image x y alpha)
-  (zapf (aref image x y)
-        ;; (round (* (alpha-to-black alpha) %))
-        (min % (alpha-to-black alpha))
-        ))
+(deftype index ()
+  `(integer 0 (,array-dimension-limit)))
 
 
+(defun-inline normalize-alpha (alpha)
+  (declare (optimize speed)
+           (type fixnum alpha))
+  (/ (min 255 (abs alpha)) 255.0))
+
+(defun-inline blend (old new alpha)
+  (declare (optimize speed)
+           (type (single-float 0.0 1.0) old new alpha))
+  (lerp old new alpha))
+
+(defun put-pixel (image opacity x y alpha)
+  (declare (optimize speed)
+           (type image image)
+           (type index x y)
+           (type (single-float 0.0 1.0) opacity)
+           (type fixnum alpha))
+  (zapf (aref image x y)
+        (blend % 0.0 (* opacity (normalize-alpha alpha)))))
+
+(defun-inline mutate-array (array function)
+  (dotimes (i (array-total-size array))
+    (setf (row-major-aref array i)
+          (funcall function (row-major-aref array i)))))
+
+(defun-inline scale-color (value)
+  (declare (type (single-float 0.0 1.0) value))
+  (round (* 255.0 value)))
+
+(defun prepare-image (image)
+  (declare (optimize speed)
+           (type image image))
+  (mutate-array image #'scale-color)
+  image)
+
 (defun make-grayscale-image (width height)
-  (make-array (list width height)
-    :element-type '(integer 0 255)
-    :initial-element 255))
+  (make-array (list width height) :initial-element 1.0))
 
 (defun write-file (image filename)
-  (trivial-ppm:write-to-file filename image :if-exists :supersede :format :pgm))
+  (trivial-ppm:write-to-file filename (prepare-image 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 blit (image object)
+  (let ((state (aa:make-state)))
+    (draw image state object)
+    (destructuring-bind (width height) (array-dimensions image)
+      (aa:cells-sweep/rectangle state 0 0 width height
+                                (curry #'put-pixel image (opacity object))))))
+
 
-(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))
+(defun render (image objects)
+  (map nil (curry #'blit image) objects))
 
+(defmacro with-rendering
+    ((image-symbol filename width height &key (padding 0.03))
+     &body body)
+  `(let ((,image-symbol (make-grayscale-image ,width ,height))
+         (*padding* ,padding))
+     ,@body
+     (write-file ,image-symbol ,filename)
+     (values)))
diff -r 3ab52c60dfee -r d3a901ef3501 src/looms/001-triangles.lisp
--- a/src/looms/001-triangles.lisp	Sat Feb 03 15:42:30 2018 -0500
+++ b/src/looms/001-triangles.lisp	Sun Feb 04 00:02:49 2018 -0500
@@ -96,7 +96,8 @@
 
 ;;;; Main ---------------------------------------------------------------------
 (defun loom (seed depth filename width height)
-  (flax.drawing:render (convert (generate-universe-balancing depth seed))
-                       filename width height))
+  (flax.drawing:with-rendering (image filename width height)
+    (flax.drawing:render image (convert (generate-universe-balancing depth seed)))))
 
-;; (time (loom nil 19 "out.pnm" 4000 4000))
+
+;; (time (loom 12 18 "out.pnm" 3000 3000))
diff -r 3ab52c60dfee -r d3a901ef3501 src/looms/002-wobbly-lines.lisp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/looms/002-wobbly-lines.lisp	Sun Feb 04 00:02:49 2018 -0500
@@ -0,0 +1,56 @@
+(in-package :flax.looms.002-wobbly-lines)
+
+;;;; Elements -----------------------------------------------------------------
+(defstruct (line (:conc-name "")
+                 (:constructor line (points)))
+  (points (error "Required") :type vector))
+
+(define-with-macro (line :conc-name "") points)
+
+;;;; Element Conversion -------------------------------------------------------
+(defun convert (line total-ticks)
+  (list (flax.drawing::path (coerce (points line) 'list)
+                            :opacity (/ 75.0 total-ticks))))
+
+
+;;;; Generation ---------------------------------------------------------------
+(defun initial (segments)
+  (line
+    (iterate
+      (for x :from 0.0 :to (+ 1.0 least-positive-single-float) :by (/ 1.0 segments))
+      (collect (coord x 0.5) :result-type 'vector))))
+
+;;;; Tick ---------------------------------------------------------------------
+(defun perturb-line (line)
+  (map nil (lambda (c)
+             (incf (y c) (random-range-inclusive -0.02 0.02 #'rand)))
+       (points line)))
+
+(defun smooth-line (line)
+  (iterate
+    (with points = (points line))
+    (with final = (1- (length points)))
+    (for c :in-vector points :with-index i)
+    (for y = (y c))
+    (for l = (or (unless (zerop i) (y (aref points (1- i)))) y))
+    (for r = (or (unless (= final i) (y (aref points (1+ i)))) y))
+    (zapf (y c) (/ (+ % % l r) 4.0))))
+
+(defun tick (line)
+  (perturb-line line)
+  (smooth-line line))
+
+
+;;;; Main ---------------------------------------------------------------------
+(defun loom (seed ticks filename width height)
+  (with-seed seed
+    (flax.drawing:with-rendering (image filename width height :padding 0.0)
+      (let ((line (initial 300)))
+        (dotimes (tick ticks)
+          (when (dividesp tick (/ (expt 10 (floor (log ticks 10))) 2))
+            (print tick))
+          (flax.drawing:render image (convert line ticks))
+          (tick line))))))
+
+
+;; (time (loom nil 1000 "out.pnm" 2000 500))