--- a/.hgignore Sun Feb 04 00:51:37 2018 -0500
+++ b/.hgignore Mon Feb 05 23:45:14 2018 -0500
@@ -3,3 +3,4 @@
*.pnm
*.pgm
scratch.lisp
+*.png
--- a/flax.asd Sun Feb 04 00:51:37 2018 -0500
+++ b/flax.asd Mon Feb 05 23:45:14 2018 -0500
@@ -8,7 +8,7 @@
:cl-vectors
:iterate
:losh
- :trivial-ppm)
+ :zpng)
:serial t
:components ((:module "vendor" :serial t
@@ -19,6 +19,7 @@
:components
((:file "base")
(:file "coordinates")
+ (:file "colors")
(:file "drawing")
(:module "looms" :serial nil
:components
--- a/package.lisp Sun Feb 04 00:51:37 2018 -0500
+++ b/package.lisp Mon Feb 05 23:45:14 2018 -0500
@@ -9,8 +9,18 @@
:distance
:clerp))
+(defpackage :flax.colors
+ (:use :cl :iterate :losh :flax.base :flax.quickutils)
+ (:export
+ :color
+ :with-color
+ :blend!
+ :hsv
+ :rgb))
+
(defpackage :flax.drawing
(:use :cl :iterate :losh :flax.base :flax.quickutils
+ :flax.colors
:flax.coordinates)
(:export
:with-rendering
@@ -18,7 +28,6 @@
:triangle
:path))
-
(defpackage :flax.looms.001-triangles
(:use :cl :iterate :losh :flax.base :flax.quickutils
:flax.coordinates)
@@ -26,6 +35,7 @@
(defpackage :flax.looms.002-wobbly-lines
(:use :cl :iterate :losh :flax.base :flax.quickutils
+ :flax.colors
:flax.coordinates)
(:export :loom))
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/colors.lisp Mon Feb 05 23:45:14 2018 -0500
@@ -0,0 +1,61 @@
+(in-package :flax.colors)
+
+(declaim (inline color make-color))
+
+(deftype color-float ()
+ '(double-float 0.0d0 1.0d0))
+
+(defstruct (color (:conc-name "")
+ (:constructor make-color (r g b)))
+ (r 0.0d0 :type color-float)
+ (g 0.0d0 :type color-float)
+ (b 0.0d0 :type color-float))
+
+(define-with-macro (color :conc-name "") r g b)
+
+(defun rgb (r g b)
+ (make-color (coerce r 'double-float)
+ (coerce g 'double-float)
+ (coerce b 'double-float)))
+
+(defun-inline hsv-to-rgb (h s v)
+ (declare (optimize speed)
+ (type color-float h s v))
+ ;; https://en.wikipedia.org/wiki/HSL_and_HSV#From_HSV
+ ;; look i don't know either mate i just transcribed the fuckin thing
+ (let* ((h (* h 360.0d0)) ; convert 0-1 to 0-360
+ (h% (/ h 60.0d0))
+ (c (* v s))
+ (x (* c (- 1.0d0 (abs (1- (mod h% 2))))))
+ (m (- v c)))
+ (multiple-value-bind (r g b)
+ (cond
+ ((<= h% 1.0d0) (values c x 0.0d0))
+ ((<= h% 2.0d0) (values x c 0.0d0))
+ ((<= h% 3.0d0) (values 0.0d0 c x))
+ ((<= h% 4.0d0) (values 0.0d0 x c))
+ ((<= h% 5.0d0) (values x 0.0d0 c))
+ ((<= h% 6.0d0) (values c 0.0d0 x))
+ (t (values 0.0d0 0.0d0 0.0d0)))
+ (values (+ r m)
+ (+ g m)
+ (+ b m)))))
+
+(defun hsv (h s v)
+ (multiple-value-call #'make-color
+ (hsv-to-rgb (coerce h 'double-float)
+ (coerce s 'double-float)
+ (coerce v 'double-float))))
+
+
+(defun blend! (destination color alpha)
+ (declare (optimize speed)
+ (type color destination color)
+ (type color-float alpha))
+ (with-color (destination dr dg db)
+ (with-color (color r g b)
+ (setf dr (lerp dr r alpha)
+ dg (lerp dg g alpha)
+ db (lerp db b alpha))))
+ (values))
+
--- a/src/drawing.lisp Sun Feb 04 00:51:37 2018 -0500
+++ b/src/drawing.lisp Mon Feb 05 23:45:14 2018 -0500
@@ -2,6 +2,7 @@
;;;; Utils --------------------------------------------------------------------
(defparameter *padding* 0.03)
+(defparameter *black* (rgb 0 0 0))
(defun convert-coord (value dimension)
(map-range (- *padding*) (1+ *padding*)
@@ -24,16 +25,18 @@
(defgeneric draw (image state drawing-object))
(defclass drawable ()
- ((opacity :type (single-float 0.0 1.0) :accessor opacity :initarg :opacity)))
+ ((opacity :type (double-float 0.0d0 1.0d0) :accessor opacity :initarg :opacity)
+ (color :type color :accessor color :initarg :color)))
;;;; Paths --------------------------------------------------------------------
(defclass path (drawable)
((points :type list :accessor points :initarg :points)))
-(defun path (points &key (opacity 1.0))
+(defun path (points &key (opacity 1.0d0) (color *black*))
(make-instance 'path
:points points
+ :color color
:opacity opacity))
(defun coord-to-string (c)
@@ -62,8 +65,8 @@
(b :type coord :accessor b :initarg :b)
(c :type coord :accessor c :initarg :c)))
-(defun triangle (a b c &key (opacity 1.0))
- (make-instance 'triangle :a a :b b :c c :opacity opacity))
+(defun triangle (a b c &key (opacity 1.0d0) (color *black*))
+ (make-instance 'triangle :a a :b b :c c :color color :opacity opacity))
(defmethod print-object ((o triangle) s)
(print-unreadable-object (o s :type t :identity nil)
@@ -91,7 +94,10 @@
;;;; Glue ---------------------------------------------------------------------
(deftype image ()
- '(simple-array t (* *)))
+ '(simple-array color (* *)))
+
+(deftype prepared-image ()
+ '(simple-array (simple-array (integer 0 255) (3)) (* *)))
(deftype index ()
`(integer 0 (,array-dimension-limit)))
@@ -100,52 +106,72 @@
(defun-inline normalize-alpha (alpha)
(declare (optimize speed)
(type fixnum alpha))
- (/ (min 255 (abs alpha)) 255.0))
+ (/ (min 255 (abs alpha)) 255.0d0))
-(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)
+(defun put-pixel (image color opacity x y alpha)
(declare (optimize speed)
(type image image)
+ (type color color)
(type index x y)
- (type (single-float 0.0 1.0) opacity)
+ (type (double-float 0.0d0 1.0d0) opacity)
(type fixnum alpha))
- (zapf (aref image x y)
- (blend % 0.0 (* opacity (normalize-alpha alpha)))))
+ (let ((pixel (aref image x y)))
+ (declare (type color pixel))
+ (blend! pixel color (* opacity (normalize-alpha alpha)))
+ (values)))
-(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 prepare-channel (value)
+ (declare (optimize speed)
+ (type (double-float 0.0d0 1.0d0) value))
+ (round (* 255.0d0 value)))
-(defun-inline scale-color (value)
- (declare (type (single-float 0.0 1.0) value))
- (round (* 255.0 value)))
-
-(defun prepare-image (image)
+(defun-inline prepare-pixel (pixel)
(declare (optimize speed)
- (type image image))
- (mutate-array image #'scale-color)
- image)
+ (type color pixel))
+ (with-color (pixel r g b)
+ (list (prepare-channel r)
+ (prepare-channel g)
+ (prepare-channel b)
+ 255)))
+
-(defun make-grayscale-image (width height)
- (make-array (list width height) :initial-element 1.0))
+(defun make-initialized-array (dimensions function &rest make-array-args)
+ (let ((result (apply #'make-array dimensions make-array-args)))
+ (do-array (v result)
+ (setf v (funcall function)))
+ result))
+
+(defun make-image (width height)
+ (make-initialized-array (list width height)
+ (curry #'rgb 1 1 1)))
+
(defun write-file (image filename)
- (trivial-ppm:write-to-file filename (prepare-image image)
- :if-exists :supersede
- :format :pgm))
+ (destructuring-bind (width height) (array-dimensions image)
+ (let ((png (make-instance 'zpng:pixel-streamed-png
+ :color-type :truecolor-alpha
+ :width width
+ :height height)))
+ (with-open-file (stream filename
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create
+ :element-type '(unsigned-byte 8))
+ (zpng:start-png png stream)
+ (dotimes (y height)
+ (dotimes (x width)
+ (zpng:write-pixel (prepare-pixel (aref image x y)) png)))
+ (zpng:finish-png png)))))
(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))))))
+ (aa:cells-sweep/rectangle
+ state 0 0 width height
+ (curry #'put-pixel image (color object) (opacity object))))))
(defun render (image objects)
@@ -154,8 +180,9 @@
(defmacro with-rendering
((image-symbol filename width height &key (padding 0.03))
&body body)
- `(let ((,image-symbol (make-grayscale-image ,width ,height))
+ `(let ((,image-symbol (make-image ,width ,height))
(*padding* ,padding))
+ (sb-ext:gc :full t)
,@body
(write-file ,image-symbol ,filename)
(values)))
--- a/src/looms/001-triangles.lisp Sun Feb 04 00:51:37 2018 -0500
+++ b/src/looms/001-triangles.lisp Mon Feb 05 23:45:14 2018 -0500
@@ -100,4 +100,4 @@
(flax.drawing:render image (convert (generate-universe-balancing depth seed)))))
-;; (time (loom 12 18 "out.pnm" 3000 3000))
+;; (time (loom 19 15 "out.png" 1000 1000))
--- a/src/looms/002-wobbly-lines.lisp Sun Feb 04 00:51:37 2018 -0500
+++ b/src/looms/002-wobbly-lines.lisp Mon Feb 05 23:45:14 2018 -0500
@@ -1,5 +1,11 @@
(in-package :flax.looms.002-wobbly-lines)
+;;;; Data ---------------------------------------------------------------------
+(defvar *brush* nil)
+(defvar *hue* nil)
+(defvar *hue-increment* nil)
+
+
;;;; Elements -----------------------------------------------------------------
(defstruct (line (:conc-name "")
(:constructor line (points)))
@@ -11,7 +17,8 @@
;;;; Element Conversion -------------------------------------------------------
(defun convert (line total-ticks)
(list (flax.drawing::path (coerce (points line) 'list)
- :opacity (/ 75.0 total-ticks))))
+ :color (hsv *hue* 1 1)
+ :opacity (/ 95.0d0 total-ticks))))
;;;; Generation ---------------------------------------------------------------
@@ -25,7 +32,7 @@
;;;; Tick ---------------------------------------------------------------------
(defun perturb-line (line)
(map nil (lambda (c)
- (incf (y c) (random-range-inclusive -0.02 0.02 #'rand)))
+ (incf (y c) (random-range-inclusive -0.025 0.025 #'rand)))
(points line)))
(defun smooth-line (line)
@@ -40,19 +47,22 @@
(defun tick (line)
(perturb-line line)
- (smooth-line line))
+ (smooth-line line)
+ (zapf *hue* (mod (+ % *hue-increment*) 1.0d0)))
;;;; 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)))
+ (let ((line (initial 300))
+ (*hue* (random-range 0.0d0 1.0d0 #'rand))
+ (*hue-increment* (/ (random-range 0.15d0 0.3d0 #'rand) ticks)))
(dotimes (tick ticks)
- (when (dividesp tick (/ (expt 10 (floor (log ticks 10))) 2))
+ (when (dividesp tick (/ (expt 10 (floor (log (1- ticks) 10))) 2))
(print tick))
(flax.drawing:render image (convert line ticks))
(tick line))))))
-;; (time (loom nil 1000 "out.pnm" 2000 500))
+;; (time (loom nil 1000 "out.png" 3000 500))