Initial abstraction layer for colours

5 files changed, 115 insertions, 19 deletions

diff --git a/examples/demo.scm b/examples/demo.scm
index 6318ccf..76f3358 100644
--- a/examples/demo.scm
+++ b/examples/demo.scm
@@ -29,6 +29,7 @@
   (starlet base)
   (starlet playback)
   (starlet effects)
+  (starlet colours)
   (starlet fixture-library generic)
   (starlet fixture-library robe)
   (starlet midi-control base)
@@ -138,8 +139,7 @@
 (at red 100)
 (at rtruss 100)
 (at rtruss 'zoom 80)
-(at rtruss 'magenta 100)
-(at rtruss 'yellow 40)
+(at rtruss 'colour (make-colour-cmy 0 100 0))
 (at rtruss 'tilt 70)
 (at rtruss 'pan 200)
 (at rtruss 'prism #f)
@@ -154,6 +154,8 @@
 (at 100)        ;; Without fixture name 'at' applies to selected fixture(s)
 (sel rtruss1)
 (sel #f)
+(sel ltruss5)
+(at 'colour (make-colour-cmy 0 0 100))
 
 
 ;; Record a state to a variable, then clear up
@@ -179,21 +181,21 @@
     (cue 1
          (lighting-state
            (at ltruss1 (quote pan) 206)
-           (at rtruss6 (quote pan) 334)
-           (at ltruss1 (quote yellow) 3800/127)
-           (at rtruss6 (quote tilt) 111)
-           (at rtruss6 (quote yellow) 3100/127)
            (at ltruss1 (quote tilt) 108.0)
-           (at ltruss1 (quote magenta) 600/127)
+           (at ltruss1 (quote zoom) 6300/127)
            (at ltruss1 (quote intensity) 109)
+           (at ltruss1 (quote colour) (make-colour-cmy 0 600/127 3800/127))
+
+           (at rtruss6 (quote pan) 334)
+           (at rtruss6 (quote intensity) 133)
+           (at rtruss6 (quote zoom) 4200/127)
+           (at rtruss6 (quote tilt) 111)
+           (at rtruss6 (quote colour) (make-colour-cmy 0 100/127 3100/127))
+
            (at red4 (quote intensity) 30)
            (at red3 (quote intensity) 30)
            (at red1 (quote intensity) 30)
-           (at rtruss6 (quote intensity) 133)
-           (at rtruss6 (quote zoom) 4200/127)
-           (at rtruss6 (quote magenta) 100/127)
-           (at red2 (quote intensity) 30)
-           (at ltruss1 (quote zoom) 6300/127)))
+           (at red2 (quote intensity) 30)))
 
     (cue 2
          (lighting-state
@@ -201,6 +203,15 @@
          #:up-time 1
          #:down-time 1)
 
+    (cue 2.5
+         (lighting-state
+           (apply-state my-state)
+           (at ltruss6 'colour (make-colour-cmy 100 0 0))
+           (at rtruss1 'colour (make-colour-cmy 0 40 0)))
+         #:up-time 3
+         #:down-time 3
+         #:attr-time 2)
+
     (cue 3
          (lighting-state
            (at floor3 (quote magenta) 11500/127)
diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm
index ea7850c..bbb98e2 100644
--- a/guile/starlet/base.scm
+++ b/guile/starlet/base.scm
@@ -1,5 +1,6 @@
 (define-module (starlet base)
   #:use-module (starlet utils)
+  #:use-module (starlet colours)
   #:use-module (oop goops)
   #:use-module (ice-9 threads)
   #:use-module (ice-9 atomic)
@@ -22,12 +23,14 @@
             <fixture-attribute>
             attr-continuous
             attr-list
+            attr-colour
             get-attr-type
             get-attr-range
             get-attr-name
             get-attr-home-val
             intensity?
             continuous-attribute?
+            colour-attribute?
 
             <starlet-state>
             make-empty-state
@@ -207,6 +210,11 @@
        (get-attr-type aobj)))
 
 
+(define (colour-attribute? aobj)
+  (eq? 'colour
+       (get-attr-type aobj)))
+
+
 (define (append-or-replace-named-state orig-list name new-state)
   (let ((new-list (map (lambda (st)
                          (if (eq? (get-state-name st) name)
@@ -520,6 +528,15 @@ pre-existing contents."
        #:home-value attr-home-value))))
 
 
+(define-syntax attr-colour
+  (syntax-rules ()
+    ((_ attr-name attr-home-value)
+     (make <fixture-attribute>
+       #:name attr-name
+       #:type 'colour
+       #:home-value attr-home-value))))
+
+
 (define current-state (make-parameter programmer-state))
 
 
diff --git a/guile/starlet/colours.scm b/guile/starlet/colours.scm
new file mode 100644
index 0000000..d390c5d
--- /dev/null
+++ b/guile/starlet/colours.scm
@@ -0,0 +1,45 @@
+(define-module (starlet colours)
+  #:use-module (oop goops)
+  #:export (<colour>
+             make-colour-cmy
+             make-colour-rgb
+             colour-as-cmy
+             white))
+
+
+(define-class <colour> (<object>)
+  (type
+    #:init-form (error "Colour type must be specified")
+    #:init-keyword #:type
+    #:getter colour-type)
+
+  (value
+    #:init-form (error "Colour value must be specified")
+    #:init-keyword #:value
+    #:getter colour-value))
+
+
+(define-method (write (col <colour>) port)
+  (format port "#<<colour> ~a ~a>"
+          (colour-type col)
+          (colour-value col)))
+
+
+(define (make-colour-cmy c m y)
+  (make <colour>
+        #:type 'cmy
+        #:value (list c m y)))
+
+
+(define (make-colour-rgb r g b)
+  (make <colour>
+        #:type 'rgb
+        #:value (list r g b)))
+
+
+(define white
+  (make-colour-cmy 0 0 0))
+
+
+(define (colour-as-cmy col)
+  (colour-value col))
diff --git a/guile/starlet/fixture-library/robe.scm b/guile/starlet/fixture-library/robe.scm
index 1dae94b..7654f69 100644
--- a/guile/starlet/fixture-library/robe.scm
+++ b/guile/starlet/fixture-library/robe.scm
@@ -1,6 +1,7 @@
 (define-module (starlet fixture-library robe)
   #:use-module (oop goops)
   #:use-module (starlet base)
+  #:use-module (starlet colours)
   #:export (<robe-dl7s-mode1>
             <robe-mmxwashbeam-mode1>
             <robe-mmxspot-mode1>))
@@ -127,9 +128,7 @@
                 (attr-list 'prism '(#t #f) #f)
                 (attr-list 'strobe '(#f #t random zap) #f)
                 (attr-continuous 'strobe-speed '(0 100) 50)
-                (attr-continuous 'cyan '(0 100) 0)
-                (attr-continuous 'magenta '(0 100) 0)
-                (attr-continuous 'yellow '(0 100) 0)
+                (attr-colour 'colour white)
                 (attr-continuous 'iris '(0 100) 0)
                 (attr-continuous 'zoom '(0 100) 0)
                 (attr-continuous 'focus '(0 100) 0)
@@ -171,9 +170,11 @@
                            (uv . 110))
                          (get-attr 'colwheel)))
 
-  (set-chan8 9 (percent->dmxval8 (get-attr 'cyan)))
-  (set-chan8 10 (percent->dmxval8 (get-attr 'magenta)))
-  (set-chan8 11 (percent->dmxval8 (get-attr 'yellow)))
+  (let ((cmy (colour-as-cmy (get-attr 'colour))))
+    (set-chan8 9 (percent->dmxval8 (car cmy)))
+    (set-chan8 10 (percent->dmxval8 (cadr cmy)))
+    (set-chan8 11 (percent->dmxval8 (caddr cmy))))
+
   (set-chan8 35 (percent->dmxval8 (get-attr 'hotspot)))
   (set-chan8 12 (scale-to-range (get-attr 'cto) '(3200 6900) '(0 255)))
   (set-chan8 27 (scale-to-range (get-attr 'frost) '(0 100) '(0 179))))
diff --git a/guile/starlet/playback.scm b/guile/starlet/playback.scm
index c9153d8..9d372bf 100644
--- a/guile/starlet/playback.scm
+++ b/guile/starlet/playback.scm
@@ -304,7 +304,28 @@
   (lambda (time)
     (cond
       ((< time fade-start-time) start-val)
-      ((> time (+ preset-start-time preset-time)) preset-val)
+      ((and (not (eq? 'no-value preset-val))
+            (> time (+ preset-start-time preset-time)))
+       preset-val)
+      (else target-val))))
+
+
+(define (make-colour-fade start-val
+                          target-val
+                          preset-val
+                          fade-time
+                          fade-start-time
+                          preset-time
+                          preset-start-time)
+  (lambda (time)
+    (cond
+
+      ((< time fade-start-time) start-val)
+
+      ((and (not (eq? 'no-value preset-val))
+            (> time (+ preset-start-time preset-time)))
+       preset-val)
+
       (else target-val))))
 
 
@@ -449,6 +470,7 @@
   (cond
     ((eq? type 'continuous) make-continuous-attr-fade)
     ((eq? type 'list) make-list-attr-fade)
+    ((eq? type 'colour) make-colour-fade)
     (else
       (raise-exception (make-exception
                          (make-exception-with-message