define-fixture: Eliminate need to provide names for get-attr etc

This needed some rearranging, but I think the resulting code is a little
bit more efficient.

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