fbdceb03ce0e

Add color support
[view raw] [browse files]
author Steve Losh <steve@stevelosh.com>
date Mon, 05 Feb 2018 23:45:14 -0500
parents 2cb0d67b2cfa
children f0fe6cc0a43f
branches/tags (none)
files .hgignore flax.asd package.lisp src/colors.lisp src/drawing.lisp src/looms/001-triangles.lisp src/looms/002-wobbly-lines.lisp

Changes

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