From 42f49129729e3f74244c4d752b225877cba631d2 Mon Sep 17 00:00:00 2001
From: Thomas White <taw@bitwiz.me.uk>
Date: Thu, 31 Dec 2020 10:50:16 +0100
Subject: Select fixture and change parameters via MIDI

---
 guile/starlet/base.scm                | 20 +++++++++++++++
 guile/starlet/midi-control/base.scm   | 10 +++++++-
 guile/starlet/midi-control/faders.scm | 47 ++++++++++++++++++++++++++++++++++-
 3 files changed, 75 insertions(+), 2 deletions(-)

diff --git a/guile/starlet/base.scm b/guile/starlet/base.scm
index 15b6b72..76d6f61 100644
--- a/guile/starlet/base.scm
+++ b/guile/starlet/base.scm
@@ -24,6 +24,7 @@
             merge-states-htp
             get-state-hash-table
             set-state-hash-table!
+            add-state-to-state!
             scanout-fixture
             attr-continuous
             attr-boolean
@@ -33,6 +34,7 @@
             apply-state
             at
             blackout
+            clear-state!
             home-val
             intensity?
             state-find
@@ -260,6 +262,10 @@
       val))
 
 
+(define (clear-state! state)
+  (set-state-hash-table! state (make-hash-table)))
+
+
 (define (merge-rule-ltp attr a b)
   (lambda (time)
     (value->number b time)))
@@ -420,6 +426,20 @@
        #:unwind? #f))))
 
 
+
+(define (current-value fix attr-name)
+  ;; FIXME: Only need to track one fixture through the state stack
+  (let ((combined-state (merge-states-ltp
+                         (list
+                          (merge-states-htp
+                           (reverse   ;; Put "home" state last
+                            (atomic-box-ref state-list)))
+                          programmer-state
+                          selection-state)))
+        (attr (find-attr fix attr-name)))
+    (value->number (state-find fix attr combined-state) 0)))
+
+
 (define-syntax attr-continuous
   (syntax-rules ()
     ((_ attr-name attr-range attr-home-value)
diff --git a/guile/starlet/midi-control/base.scm b/guile/starlet/midi-control/base.scm
index 21692b5..fece2be 100644
--- a/guile/starlet/midi-control/base.scm
+++ b/guile/starlet/midi-control/base.scm
@@ -10,7 +10,8 @@
             send-note-on
             send-note-off
             register-midi-note-callback!
-            register-midi-cc-callback!))
+            register-midi-cc-callback!
+            remove-midi-callback!))
 
 
 (define cc-arrays (make-atomic-box '()))
@@ -62,6 +63,13 @@
   (register-midi-callback! 'cc channel cc-number func))
 
 
+(define (remove-midi-callback! callback)
+  (atomic-box-set! callback-list
+                   (remove (lambda (a)
+                             (eq? callback a))
+                           (atomic-box-ref callback-list))))
+
+
 (define enqueue-midi-bytes!
   (lambda bytes
     (unless (eq? (atomic-box-compare-and-swap! send-queue '() bytes)
diff --git a/guile/starlet/midi-control/faders.scm b/guile/starlet/midi-control/faders.scm
index 5abbe8a..8fa7351 100644
--- a/guile/starlet/midi-control/faders.scm
+++ b/guile/starlet/midi-control/faders.scm
@@ -1,7 +1,8 @@
 (define-module (starlet midi-control faders)
   #:use-module (starlet midi-control base)
   #:use-module (starlet base)
-  #:export (on-fader))
+  #:export (on-fader
+            sel))
 
 
 (define* (on-fader cc-number state
@@ -23,3 +24,47 @@
            (at fix attr val)))
 
      state))))
+
+
+(define (at-midi-jogwheel fix attr cc-number)
+
+  (define (ccval->offset a)
+    (if (eq? a 127)
+        -1
+        1))
+
+  (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! selection-state
+                         fix
+                         attr
+                         (+ old-val offset))))))
+
+
+(define (select-fixtures fixture)
+  (list
+   (at-midi-jogwheel fixture 'intensity 21)
+   (at-midi-jogwheel fixture 'pan 0)
+   (at-midi-jogwheel fixture 'tilt 1)))
+
+
+(define midi-callbacks '())
+
+(define (merge-rule-replace attr a b)
+  b)
+
+
+(define (sel fixture)
+  (when selection-state
+    (add-state-to-state! merge-rule-replace
+                         selection-state
+                         programmer-state)
+    (clear-state! selection-state)
+    (for-each remove-midi-callback! midi-callbacks))
+  (when fixture
+    (set! midi-callbacks
+      (select-fixtures fixture))))
-- 
cgit v1.2.3