diff options
-rw-r--r-- | guile/starlet/fixture-library/adj/mega-tripar-profile.scm | 9 | ||||
-rw-r--r-- | guile/starlet/fixture-library/generic/dimmer.scm | 5 | ||||
-rw-r--r-- | guile/starlet/fixture-library/robe/dl7s/mode1.scm | 43 | ||||
-rw-r--r-- | guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm | 7 | ||||
-rw-r--r-- | guile/starlet/fixture.scm | 35 | ||||
-rw-r--r-- | guile/starlet/scanout.scm | 94 |
6 files changed, 95 insertions, 98 deletions
diff --git a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm index 6f70d40..90a84f6 100644 --- a/guile/starlet/fixture-library/adj/mega-tripar-profile.scm +++ b/guile/starlet/fixture-library/adj/mega-tripar-profile.scm @@ -19,6 +19,7 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library adj mega-tripar-profile) + #:use-module (starlet scanout) #:use-module (starlet fixture) #:use-module (starlet utils) #:use-module (starlet colours) @@ -32,12 +33,10 @@ <adj-mega-tripar-profile-3ch> - (list + (fixture-attributes (attr-continuous 'intensity '(0 100) 0) (attr-colour 'colour white)) - (get-attr set-chan8) - (let ((intensity (/ (get-attr 'intensity) 100)) (rgb (colour-as-rgb (get-attr 'colour)))) (set-chan8 1 (percent->dmxval8 (* intensity (car rgb)))) @@ -51,12 +50,10 @@ <adj-mega-tripar-profile-4ch> - (list + (fixture-attributes (attr-continuous 'intensity '(0 100) 0) (attr-colour 'colour white)) - (get-attr set-chan8) - (let ((rgb (colour-as-rgb (get-attr 'colour)))) (set-chan8 1 (percent->dmxval8 (get-attr 'intensity))) (set-chan8 2 (percent->dmxval8 (car rgb))) diff --git a/guile/starlet/fixture-library/generic/dimmer.scm b/guile/starlet/fixture-library/generic/dimmer.scm index 844b697..e823dc7 100644 --- a/guile/starlet/fixture-library/generic/dimmer.scm +++ b/guile/starlet/fixture-library/generic/dimmer.scm @@ -19,6 +19,7 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library generic dimmer) + #:use-module (starlet scanout) #:use-module (starlet fixture) #:use-module (starlet utils) #:export (<generic-dimmer>)) @@ -27,10 +28,8 @@ <generic-dimmer> - (list + (fixture-attributes (attr-continuous 'intensity '(0 100) 0)) - (get-attr set-chan8) - (set-chan8 1 (percent->dmxval8 (get-attr 'intensity)))) diff --git a/guile/starlet/fixture-library/robe/dl7s/mode1.scm b/guile/starlet/fixture-library/robe/dl7s/mode1.scm index e9d5a9a..2a5eb46 100644 --- a/guile/starlet/fixture-library/robe/dl7s/mode1.scm +++ b/guile/starlet/fixture-library/robe/dl7s/mode1.scm @@ -25,22 +25,18 @@ #:export (<robe-dl7s-mode1>)) -(define-class <robe-dl7s-mode1> (<fixture>) - (attributes - #:init-form (list - (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'pan '(0 540) 270) - (attr-continuous 'tilt '(0 270) 135) - (attr-list 'strobe '(#t #f) #f) - (attr-list 'prism '(#t #f) #f) - (attr-list 'tungsten-watts-emulation '(750 1000 1200 2000 2500 #f) #f) - (attr-colour 'colour white) - (attr-continuous 'colour-temperature-correction '(2700 8000) 8000) - (attr-continuous 'green-correction '(-100 100) 0)))) +(define-fixture + <robe-dl7s-mode1> -(define-method (scanout-fixture (fixture <robe-dl7s-mode1>) - get-attr set-chan8 set-chan16) + (fixture-attributes + (attr-continuous 'intensity '(0 100) 0) + (attr-continuous 'pan '(0 540) 270) + (attr-continuous 'tilt '(0 270) 135) + (attr-list 'strobe '(#t #f) #f) + (attr-list 'prism '(#t #f) #f) + (attr-colour 'colour white) + (attr-continuous 'colour-temperature '(2700 8000) 3200)) (set-chan16 50 (percent->dmxval16 (get-attr 'intensity))) @@ -51,15 +47,14 @@ (set-chan8 28 (if (get-attr 'prism) 50 0)) - (set-chan8 7 (assv-ref '((750 . 82) - (1000 . 88) - (1200 . 92) - (2000 . 97) - (2500 . 102) - (#f . 107)) - (get-attr 'tungsten-watts-emulation))) + (set-chan8 6 0) ;; Power/special function: default + (set-chan8 7 0) ;; Colour mode: default + + (set-chan8 15 + (scale-and-clamp-to-range (get-attr 'colour-temperature) + '(8000 2700) '(0 255))) (let ((cmy (colour-as-cmy (get-attr 'colour)))) - (set-chan8 9 (percent->dmxval8 (car cmy))) - (set-chan8 11 (percent->dmxval8 (cadr cmy))) - (set-chan8 13 (percent->dmxval8 (caddr cmy))))) + (set-chan16 9 (percent->dmxval16 (car cmy))) + (set-chan16 11 (percent->dmxval16 (cadr cmy))) + (set-chan16 13 (percent->dmxval16 (caddr cmy))))) diff --git a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm index f2ed8a5..b42de26 100644 --- a/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm +++ b/guile/starlet/fixture-library/stairville/octagon-theater-cw-ww.scm @@ -19,6 +19,7 @@ ;; along with this program. If not, see <http://www.gnu.org/licenses/>. ;; (define-module (starlet fixture-library stairville octagon-theater-cw-ww) + #:use-module (starlet scanout) #:use-module (starlet fixture) #:use-module (starlet utils) #:export (<stairville-octagon-theater-cw-ww>)) @@ -27,11 +28,9 @@ <stairville-octagon-theater-cw-ww> - (list + (fixture-attributes (attr-continuous 'intensity '(0 100) 0) - (attr-continuous 'colour-temperature '(2800 6400) 4600)) - - (get-attr set-chan8 set-chan16) + (attr-continuous 'colour-temperature '(2800 6400) 3200)) (let ((coltemp (get-attr 'colour-temperature))) (set-chan8 1 (scale-and-clamp-to-range coltemp '(2800 6400) '(0 255))) diff --git a/guile/starlet/fixture.scm b/guile/starlet/fixture.scm index c6a6edf..8aaccc4 100644 --- a/guile/starlet/fixture.scm +++ b/guile/starlet/fixture.scm @@ -31,18 +31,18 @@ get-fixture-attrs find-attr fixture? - scanout-fixture attr-continuous attr-list attr-colour + define-fixture + get-attr-type get-attr-range get-attr-home-val continuous-attribute? colour-attribute? - intensity? - define-fixture)) + intensity?)) (define-class <fixture-attribute> (<object>) @@ -97,9 +97,6 @@ #:getter get-scanout-func)) -(define-generic scanout-fixture) - - (define-syntax attr-continuous (syntax-rules () ((_ attr-name attr-range attr-home-value) @@ -183,32 +180,14 @@ (define-syntax define-fixture - (syntax-rules () - - ((_ classname - attrs - (get-attr set-chan8) - scanout-code ...) - - (begin - (define-class classname (<fixture>) - (attributes #:init-form attrs)) - - (define-method (scanout-fixture (fixture classname) - get-attr set-chan8 dummy) - - scanout-code ...))) + (syntax-rules (fixture-attributes) ((_ classname - attrs - (get-attr set-chan8 set-chan16) + (fixture-attributes attr ...) scanout-code ...) (begin (define-class classname (<fixture>) - (attributes #:init-form attrs)) - - (define-method (scanout-fixture (fixture classname) - get-attr set-chan8 set-chan16) - + (attributes #:init-form (list attr ...))) + (define-method (scanout-fixture (fixture classname)) scanout-code ...))))) diff --git a/guile/starlet/scanout.scm b/guile/starlet/scanout.scm index 43c2cf0..8cea49a 100644 --- a/guile/starlet/scanout.scm +++ b/guile/starlet/scanout.scm @@ -35,7 +35,11 @@ total-num-attrs register-state! current-value - patched-fixture-names)) + patched-fixture-names + get-attr + set-chan8 + set-chan16 + scanout-fixture)) ;; The list of patched fixtures @@ -47,6 +51,9 @@ ;; Association list of names to states (define state-names (make-atomic-box '())) +;; Method for scanning out fixtures +(define-generic scanout-fixture) + (define (patched-fixture-names) (map get-fixture-name (atomic-box-ref fixtures))) @@ -202,51 +209,72 @@ (define scanout-freq 0) (define ola-thread #f) +(define current-scanout-fixture (make-parameter #f)) +(define current-scanout-universe (make-parameter #f)) +(define current-scanout-addr (make-parameter #f)) -(define (scanout-loop ola-client start-time count previous-universes) - (let ((universes '())) +(define (get-attr attr-name) + (current-value + (current-scanout-fixture) + attr-name)) - ;; Helper function for scanout functions to set individual DMX values - (define (set-dmx universe addr value) - (ensure-number value (list universe addr value)) - ;; Create DMX array for universe if it doesn't exist already - (unless (assq universe universes) - (set! universes (acons universe - (make-ola-dmx-buffer) - universes))) +(define (set-dmx universe addr value) + (ensure-number value (list universe addr value)) - (set-ola-dmx-buffer! (assq-ref universes universe) - (- addr 1) ; OLA indexing starts from zero - (round-dmx value))) + ;; Create DMX array for universe if it doesn't exist already + (set-ola-dmx-buffer! universe + (- addr 1) ; OLA indexing starts from zero + (round-dmx value))) - (for-each update-state! (atomic-box-ref state-list)) - (for-each - (lambda (fix) +(define (set-chan8 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-dmx + (current-scanout-universe) + (+ (current-scanout-addr) + relative-channel-number + -1) + value)) - (let ((univ (get-fixture-universe fix)) - (addr (get-fixture-addr fix))) - ;; Helper function to get a value for this - ;; fixture in the current state - (define (get-attr attr-name) - (current-value fix attr-name)) +(define (set-chan16 relative-channel-number value) + (ensure-number + value + (list (current-scanout-fixture) + relative-channel-number + value)) + (set-chan8 relative-channel-number (msb value)) + (set-chan8 (+ relative-channel-number 1) (lsb value))) - ;; Helper function to set 8-bit DMX value - (define (set-chan relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-dmx univ (+ addr relative-channel-number -1) value)) - ;; Helper function to set 16-bit DMX value - (define (set-chan-16bit relative-channel-number value) - (ensure-number value (list fix relative-channel-number value)) - (set-chan relative-channel-number (msb value)) - (set-chan (+ relative-channel-number 1) (lsb value))) +(define (scanout-loop ola-client start-time count previous-universes) - (scanout-fixture fix get-attr set-chan set-chan-16bit))) + (let ((universes '())) + + (for-each update-state! (atomic-box-ref state-list)) + + (for-each + (lambda (fix) + ;; Ensure the DMX array exists for this fixture's universe + (unless (assq (get-fixture-universe fix) universes) + (set! universes (acons (get-fixture-universe fix) + (make-ola-dmx-buffer) + universes))) + + (parameterize + ((current-scanout-fixture fix) + (current-scanout-universe (assq-ref + universes + (get-fixture-universe fix))) + (current-scanout-addr (get-fixture-addr fix))) + (scanout-fixture fix))) (atomic-box-ref fixtures)) ;; Send everything to OLA |