Implement selection of multiple fixtures at once

2 files changed, 152 insertions, 91 deletions

diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm
index 8673be3..ddefcdf 100644
--- a/guile/starlet/base.scm
+++ b/guile/starlet/base.scm
@@ -42,6 +42,8 @@
             intensity?
             state-find
             get-attr-type
+            get-attr-range
+            find-attr
             fixture?
             fixture-attribute?
             programmer-state
diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm
index 1c321aa..912d9f7 100644
--- a/guile/starlet/midi-control/faders.scm
+++ b/guile/starlet/midi-control/faders.scm
@@ -30,7 +30,18 @@
      state))))
 
 
-(define* (at-midi-jogwheel fix attr cc-number
+(define (current-values fixture-list attr-name)
+  (map (lambda (fix)
+         (current-value fix attr-name))
+       fixture-list))
+
+
+(define (fixtures-with-attr fixture-list attr-name)
+  (filter (lambda (fix) (find-attr fix attr-name))
+          fixture-list))
+
+
+(define* (at-midi-jogwheel fixture-list attr cc-number
                            #:key (led #f))
 
   (define (ccval->offset a)
@@ -38,19 +49,24 @@
         -1
         1))
 
-  (when led
-    (send-note-on led))
+  (let ((fixtures (fixtures-with-attr fixture-list attr)))
+    (unless (null? fixtures)
+
+      (when led
+        (send-note-on led))
 
-  (let ((old-val (current-value fix attr))
-        (offset 0))
-    (register-midi-cc-callback!
-     #:cc-number cc-number
-     #:func (lambda (prev-cc-val new-cc-value)
-              (set! offset (+ offset (ccval->offset new-cc-value)))
-              (set-attr! programmer-state
-                         fix
-                         attr
-                         (+ old-val offset))))))
+      (let ((old-vals (current-values fixtures attr))
+            (offset 0))
+        (register-midi-cc-callback!
+         #:cc-number cc-number
+         #:func (lambda (prev-cc-val new-cc-value)
+                  (set! offset (+ offset (ccval->offset new-cc-value)))
+                  (for-each (lambda (fix old-val)
+                              (set-attr! programmer-state
+                                         fix
+                                         attr
+                                         (+ old-val offset)))
+                            fixtures old-vals)))))))
 
 
 (define (in-range a val1 val2)
@@ -61,100 +77,144 @@
         (<= a val1))))
 
 
-(define* (at-midi-fader fix
-                        attr
-                        cc-number
-                        #:key
-                        (led-incongruent #f)
-                        (led #f))
+;; Returns a pair of (low . high), which are the amount of fader
+;; space required in the downward and upward directions respectively
+(define (fader-space fixtures attr-name)
 
-  (let* ((congruent-val (percent->ccval (current-value fix attr)))
+  (define (attr-max-value attr)
+    (cadr (get-attr-range attr)))
 
-         (cc-val (get-cc-value cc-number))
-         (congruent (and cc-val
-                         (= cc-val congruent-val))))
+  (define (attr-min-value attr)
+    (car (get-attr-range attr)))
 
-    (if congruent
-        (send-note-on led)
-        (send-note-on led-incongruent))
+  (define (distance-above-min fix attr)
+    (- (current-value fix (get-attr-name attr))
+       (attr-min-value attr)))
 
-    (register-midi-cc-callback!
-     #:cc-number cc-number
-     #:func (lambda (prev-cc-val new-cc-value)
+  (define (distance-below-max fix attr)
+    (- (attr-max-value attr)
+       (current-value fix (get-attr-name attr))))
 
-              (when congruent
-                (set-attr! programmer-state
-                           fix
-                           attr
-                           (ccval->percent new-cc-value)))
+  (fold (lambda (fix prev)
+          (let ((attr (find-attr fix attr-name)))
+            (cons (max (distance-above-min fix attr)
+                       (car prev))
+                  (max (distance-below-max fix attr)
+                       (cdr prev)))))
+        (cons 0 0)
+        fixtures))
 
-              (when (or (and (not prev-cc-val)
-                             (= new-cc-value congruent-val))
-                        (and prev-cc-val new-cc-value
-                             (in-range congruent-val
-                                       prev-cc-val
-                                       new-cc-value)))
-                (set! congruent #t)
-                (send-note-on led))))))
 
+(define space-down car)
+(define space-up cdr)
 
-(define-record-type <midi-control-spec>
-  (make-midi-control-spec attr-name
-                          type
-                          cc-number
-                          leds)
-  midi-control-spec?
-  (attr-name  attr-name)
-  (type       type)
-  (cc-number  cc-number)
-  (leds       leds))
+(define (space-span r)
+  (+ (space-down r)
+     (space-up r)))
 
+(define (fader-space->congruence r)
+  (inexact->exact
+   (round
+    (* 127 (/ (space-down r)
+              (space-span r))))))
 
-(define control-map
-  (list
-   (make-midi-control-spec 'intensity 'jogwheel 21 98)
-   (make-midi-control-spec 'pan 'jogwheel 0 124)
-   (make-midi-control-spec 'tilt 'jogwheel 1 125)
-   (make-midi-control-spec 'r 'fader 4 '(120 84))
-   (make-midi-control-spec 'g 'fader 5 '(121 85))
-   (make-midi-control-spec 'b 'fader 6 '(122 86))))
 
+(define (range-scale cspace)
+  (/ (+ (space-up cspace)
+        (space-down cspace))
+     127))
 
-(define (find-control-spec control-map needle)
-  (find (lambda (a)
-          (eq? (attr-name a) needle))
-        control-map))
 
+(define (conv-fader orig-cc
+                    new-cc
+                    initial-val
+                    control-space)
+  (+ initial-val
+     (* (range-scale control-space)
+        (- new-cc orig-cc))))
 
-(define (midi-control-attr fixture attr-name)
-  (let ((control-spec (find-control-spec
-                       control-map
-                       attr-name)))
-    (cond
 
-     ((not control-spec) #f)   ;; Fixture does not have this attribute
-
-     ((eq? (type control-spec) 'jogwheel)
-      (at-midi-jogwheel fixture
+(define* (at-midi-fader fixture-list
                         attr-name
-                        (cc-number control-spec)
-                        #:led (leds control-spec)))
+                        cc-number
+                        #:key
+                        (led-incongruent #f)
+                        (led #f))
 
-     ((eq? (type control-spec) 'fader)
-      (at-midi-fader fixture
-                     attr-name
-                     (cc-number control-spec)
-                     #:led (car (leds control-spec))
-                     #:led-incongruent (cadr (leds control-spec)))))))
+  (let ((fixtures (fixtures-with-attr fixture-list attr-name)))
+    (unless (null? fixtures)
+      (let* ((control-space (fader-space fixtures attr-name))
+             (congruent-val (fader-space->congruence control-space))
+             (cc-val (get-cc-value cc-number))
+             (congruent (and cc-val (= cc-val congruent-val)))
+             (initial-vals (current-values fixture-list attr-name)))
+
+        (if congruent
+            (send-note-on led)
+            (send-note-on led-incongruent))
+
+        (register-midi-cc-callback!
+         #:cc-number cc-number
+         #:func (lambda (prev-cc-val new-cc-value)
+
+                  (when congruent
+                    (for-each (lambda (fix initial-val)
+                                (set-attr! programmer-state
+                                           fix
+                                           attr-name
+                                           (conv-fader congruent-val
+                                                       new-cc-value
+                                                       initial-val
+                                                       control-space)))
+                              fixture-list
+                              initial-vals))
+
+
+                  (when (or (and (not prev-cc-val)
+                                 (= new-cc-value congruent-val))
+                            (and prev-cc-val new-cc-value
+                                 (in-range congruent-val
+                                           prev-cc-val
+                                           new-cc-value)))
+                    (set! congruent #t)
+                    (send-note-on led))))))))
+
+
+(define control-map
+  '((intensity jogwheel 21 98)
+    (pan       jogwheel 0  124)
+    (tilt      jogwheel 1  125)
+    (cyan      fader    4  (120 84))
+    (magenta   fader    5  (121 85))
+    (yellow    fader    6  (122 86))
+    (cto       fader    7  (123 87))
+    (iris      fader    8  (116 80))
+    (zoom      fader    9  (117 81))
+    (focus     fader    10 (118 82))))
+
+
+(define (midi-control-attr control-spec fixture-list)
+  (cond
+
+   ((eq? 'jogwheel (cadr control-spec))
+    (at-midi-jogwheel fixture-list
+                      (car control-spec)
+                      (caddr control-spec)
+                      #:led (cadddr control-spec)))
+
+   ((eq? 'fader (cadr control-spec))
+    (at-midi-fader fixture-list
+                   (car control-spec)
+                   (caddr control-spec)
+                   #:led (car (cadddr control-spec))
+                   #:led-incongruent (cadr (cadddr control-spec))))))
 
 
 ;; Stuff to clear up when we're done with selected fixtures
 (define midi-callbacks '())
 
 
-(define (sel fixture)
-
-  (define (merge-rule-replace attr a b) b)
+(define (sel . fixture-list)
 
   (define (led-off leds)
     (cond
@@ -163,18 +223,17 @@
      ((number? leds)
       (send-note-off leds))))
 
-
   (for-each remove-midi-callback! midi-callbacks)
 
   (for-each (lambda (control-spec)
-              (led-off (leds control-spec)))
+              (led-off (cadddr control-spec)))
             control-map)
 
   (set! midi-callbacks '())
 
-  (when fixture
+  (when (car fixture-list)
     (set! midi-callbacks
-      (map (lambda (attr)
-             (midi-control-attr fixture
-                                (get-attr-name attr)))
-           (get-attributes fixture)))))
+      (map (lambda (control-spec)
+             (midi-control-attr control-spec
+                                fixture-list))
+           control-map))))