# HG changeset patch # User Steve Losh # Date 1517892314 18000 # Node ID fbdceb03ce0e1806f2bb57c66d7178690726c34e # Parent 2cb0d67b2cfa652c54ddec3ee9a2fcf266f6165f Add color support diff -r 2cb0d67b2cfa -r fbdceb03ce0e .hgignore --- 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 diff -r 2cb0d67b2cfa -r fbdceb03ce0e flax.asd --- 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 diff -r 2cb0d67b2cfa -r fbdceb03ce0e package.lisp --- 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)) diff -r 2cb0d67b2cfa -r fbdceb03ce0e src/colors.lisp --- /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)) + diff -r 2cb0d67b2cfa -r fbdceb03ce0e src/drawing.lisp --- 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))) diff -r 2cb0d67b2cfa -r fbdceb03ce0e src/looms/001-triangles.lisp --- 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)) diff -r 2cb0d67b2cfa -r fbdceb03ce0e src/looms/002-wobbly-lines.lisp --- 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))