From 686cad73eca73d9bbf7122e30bb5f433f0661b86 Mon Sep 17 00:00:00 2001 From: Thomas White Date: Tue, 6 Apr 2021 21:45:15 +0200 Subject: Initial abstraction layer for colours --- examples/demo.scm | 35 +++++++++++++++++--------- guile/starlet/base.scm | 17 +++++++++++++ guile/starlet/colours.scm | 45 ++++++++++++++++++++++++++++++++++ guile/starlet/fixture-library/robe.scm | 13 +++++----- guile/starlet/playback.scm | 24 +++++++++++++++++- 5 files changed, 115 insertions(+), 19 deletions(-) create mode 100644 guile/starlet/colours.scm 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 @@ attr-continuous attr-list + attr-colour get-attr-type get-attr-range get-attr-name get-attr-home-val intensity? continuous-attribute? + colour-attribute? 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 + #: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 ( + make-colour-cmy + make-colour-rgb + colour-as-cmy + white)) + + +(define-class () + (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 ) port) + (format port "#< ~a ~a>" + (colour-type col) + (colour-value col))) + + +(define (make-colour-cmy c m y) + (make + #:type 'cmy + #:value (list c m y))) + + +(define (make-colour-rgb r g b) + (make + #: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 ( )) @@ -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 -- cgit v1.2.3