--- 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))
+
--- 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)))
--- 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))
--- /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))