6fdb6639f071

--- a/examples/particles.lisp	Wed Apr 12 01:33:27 2017 +0000
+++ b/examples/particles.lisp	Wed Apr 12 13:08:18 2017 +0000
@@ -13,8 +13,8 @@
 
 
 ;;;; Utils --------------------------------------------------------------------
-(defun noop (particle ms)
-  (declare (ignore particle ms)))
+(defun noop (particle ms n)
+  (declare (ignore particle ms n)))
 
 (defun random-glyph ()
   (random-elt "*!#$%^&?.,-:;'/><(){}[]"))
@@ -29,28 +29,45 @@
   (x 0 :type fixnum)
   (y 0 :type fixnum))
 
-(defstruct particle
+(defstruct (particle (:constructor make-particle%))
   (x 0.0 :type single-float)
   (y 0.0 :type single-float)
   (glyph (random-glyph) :type character)
   (color (random-color) :type (unsigned-byte 32))
   (lifetime 1000 :type fixnum)
+  (remaining 0 :type fixnum)
   (transformer #'noop :type function))
 
+(defun make-particle (x y lifetime transformer)
+  (make-particle% :x x
+                  :y y
+                  :lifetime lifetime
+                  :remaining lifetime
+                  :transformer transformer))
 
 (defun update-particles (ms)
   (setf *particles*
         (delete-if (lambda (particle)
-                     (minusp (decf (particle-lifetime particle) ms)))
+                     (minusp (decf (particle-remaining particle) ms)))
                    *particles*))
   (mapc (lambda (particle)
-          (funcall (particle-transformer particle) particle ms))
+          (funcall (particle-transformer particle)
+                   particle
+                   ms
+                   (- 1.0 (/ (particle-remaining particle)
+                             (particle-lifetime particle)))))
         *particles*)
   'ok)
 
-(defun transform-drop (ms-per-cell particle ms)
+
+(defun transform-drop (ms-per-cell particle ms n)
   (incf (particle-y particle)
-        (/ ms ms-per-cell)))
+        (/ ms ms-per-cell))
+  (multiple-value-bind (h s v a)
+      (blt:color-to-hsva (particle-color particle) t)
+    (declare (ignore a))
+    (setf (particle-color particle)
+          (blt:hsva h s v (- 1.0 (expt n 4))))))
 
 
 (defun clear-layer (layer)
@@ -66,19 +83,17 @@
 
 
 (defun make-drop-particle (x y)
-  (make-particle
-    :x x
-    :y y
-    :lifetime (random-range 600 1000)
-    :transformer (losh::curry #'transform-drop (random-range 5 50))))
+  (make-particle x y
+                 (random-range 600 1000)
+                 (losh::curry #'transform-drop (random-range 10 50))))
 
 
 (defun add-particle ()
   (let ((x (coerce (mouse-x *mouse*) 'single-float))
         (y (coerce (mouse-y *mouse*) 'single-float)))
-    (iterate (repeat (random-range 1000 2000))
-             (push (make-drop-particle (+ x (random-range-inclusive -19.0 19.0))
-                                       (+ y (random-range-inclusive -19.0 19.0)))
+    (iterate (repeat (random-range 10 100))
+             (push (make-drop-particle (+ x (random-range-inclusive -9.0 9.0))
+                                       (+ y (random-range-inclusive -9.0 9.0)))
                    *particles*))))
 
 
@@ -117,7 +132,7 @@
 (defun config ()
   (blt:set "font: ./examples/ProggySquare/ProggySquare.ttf, size=20x20, spacing=2x2, align=dead-center;")
   (blt:set "input.filter = keyboard, mouse")
-  (blt:set "output.vsync = false")
+  (blt:set "output.vsync = true")
   (blt:set "window.resizeable = true")
   (blt:set "window.cellsize = 10x10")
   (blt:set "window.size = 80x50")

--- a/package.lisp	Wed Apr 12 01:33:27 2017 +0000
+++ b/package.lisp	Wed Apr 12 13:08:18 2017 +0000
@@ -34,13 +34,16 @@
     :print
     :read
     :refresh
-    :rgba
-    :hsva
     :set
     :sleep
     :width
     :with-terminal
 
+    :rgba
+    :hsva
+    :color-to-rgba
+    :color-to-hsva
+
     )
   (:shadow
 

--- a/src/high-level/bearlibterminal.lisp	Wed Apr 12 01:33:27 2017 +0000
+++ b/src/high-level/bearlibterminal.lisp	Wed Apr 12 13:08:18 2017 +0000
@@ -31,6 +31,9 @@
 
 
 ;;;; Colors -------------------------------------------------------------------
+(deftype color ()
+  '(unsigned-byte 32))
+
 (deftype color-byte ()
   '(unsigned-byte 8))
 
@@ -45,7 +48,17 @@
                    (unsigned-byte 32)) rgba-float%)
   (ftype (function (color-float color-float color-float)
                    (values color-float color-float color-float &optional))
-         hsv-to-rgb))
+         hsv-to-rgb rgb-to-hsv)
+  (ftype (function
+           (color)
+           (values color-byte color-byte color-byte color-byte &optional))
+         color-to-rgba-bytes
+         color-to-hsva-bytes)
+  (ftype (function
+           (color)
+           (values color-float color-float color-float color-float &optional))
+         color-to-rgba-floats
+         color-to-hsva-floats))
 
 
 (defun-inline hsv-to-rgb (h s v)
@@ -69,9 +82,67 @@
               (+ g m)
               (+ b m)))))
 
+(defun-inline rgb-to-hsv (r g b)
+  ;; http://www.rapidtables.com/convert/color/rgb-to-hsv.htm
+  (let* ((c-min (min r g b))
+         (c-max (max r g b))
+         (delta (- c-max c-min)))
+    (values
+      (* (/ 60 360)
+         (cond
+           ((zerop delta) 0.0)
+           ((= c-max r) (mod (/ (- g b) delta) 6.0))
+           ((= c-max g) (+ (/ (- b r) delta) 2.0))
+           ((= c-max b) (+ (/ (- r g) delta) 4.0))
+           (t 0.0)))
+      (if (zerop c-max)
+        0.0
+        (/ delta c-max))
+      c-max)))
 
-(defun-inline color-float-to-byte (r)
-  (truncate (* r 255.0)))
+
+(defun-inline color-float-to-byte (n)
+  (truncate (* n 255.0)))
+
+(defun-inline color-byte-to-float (n)
+  (/ n 255.0))
+
+
+(defun-inline color-to-rgba-bytes (color)
+  (values (ldb (byte 8 16) color)
+          (ldb (byte 8 8) color)
+          (ldb (byte 8 0) color)
+          (ldb (byte 8 24) color)))
+
+(defun-inline color-to-rgba-floats (color)
+  (multiple-value-bind (r g b a) (color-to-rgba-bytes color)
+    (values (color-byte-to-float r)
+            (color-byte-to-float g)
+            (color-byte-to-float b)
+            (color-byte-to-float a))))
+
+(defun-inline color-to-hsva-floats (color)
+  (multiple-value-bind (r g b a) (color-to-rgba-floats color)
+    (multiple-value-bind (h s v) (rgb-to-hsv r g b)
+      (values h s v a))))
+
+(defun-inline color-to-hsva-bytes (color)
+  (multiple-value-bind (h s v a) (color-to-hsva-floats color)
+    (values (color-float-to-byte h)
+            (color-float-to-byte s)
+            (color-float-to-byte v)
+            (color-float-to-byte a))))
+
+
+(defun color-to-rgba (color &optional float?)
+  (if float?
+    (color-to-rgba-floats color)
+    (color-to-rgba-bytes color)))
+
+(defun color-to-hsva (color &optional float?)
+  (if float?
+    (color-to-hsva-floats color)
+    (color-to-hsva-bytes color)))
 
 
 (defun-inline rgba-byte% (r g b a)
@@ -140,7 +211,7 @@
     (color-float (hsva-float% h s v (or a 1.0)))))
 
 (defun hsva (h s v &optional (a nil))
-  (rgba% h s v a))
+  (hsva% h s v a))
 
 
 (define-compiler-macro rgba (&whole form r g b &optional (a nil))