diff options
author | Thomas White <taw@physics.org> | 2020-07-02 22:47:15 +0200 |
---|---|---|
committer | Thomas White <taw@physics.org> | 2020-07-02 22:47:15 +0200 |
commit | 047bb46e042d896470cd8ebbe5546e421149e10d (patch) | |
tree | 368e38260230c4e4822cc361d6c63c59648f5c51 | |
parent | 3a53e4672af6e9d572d6c59e24e8559d35266b11 (diff) |
Implement generic-rgb
-rw-r--r-- | guile/nanolight/fixture-library/generic.scm | 38 |
1 files changed, 37 insertions, 1 deletions
diff --git a/guile/nanolight/fixture-library/generic.scm b/guile/nanolight/fixture-library/generic.scm index ff497b3..ef462fe 100644 --- a/guile/nanolight/fixture-library/generic.scm +++ b/guile/nanolight/fixture-library/generic.scm @@ -1,7 +1,9 @@ (define-module (nanolight fixture-library generic) #:use-module (oop goops) #:use-module (nanolight fixture) - #:export (generic-dimmer)) + #:export (generic-dimmer generic-rgb)) + +(use-modules (srfi srfi-1)) (define (generic-dimmer) @@ -11,3 +13,37 @@ #:translator (lambda (universe start-addr value set-dmx) (set-dmx universe start-addr (percent->dmxval value)))))) + + +(define (feature-char->attr-name c) + (case c + ((i) 'intensity) + ((r) 'red) + ((g) 'green) + ((b) 'blue) + ((w) 'white) + (else + (error "Unrecognised symbol for generic RGB fixture" c)))) + + +(define (generic-rgb feature-list) + (lambda () + (fold + (lambda (feature addr-offset list-so-far) + (if (eq? feature 0) + list-so-far + (cons + (make <fixture-attribute> + #:name (feature-char->attr-name feature) + #:range '(0 100) + #:type 'continuous + #:home-value 0 + #:translator (lambda (universe start-addr value set-dmx) + (set-dmx universe + (+ start-addr addr-offset) + (percent->dmxval value)))) + list-so-far))) + + '() + feature-list + (iota (length feature-list) 0)))) |