blob: 1c321aaf4f709e311e6c1f6e571d073ec19831a5 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
(define-module (starlet midi-control faders)
#:use-module (starlet midi-control base)
#:use-module (starlet base)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-1)
#:export (on-fader
sel))
(define* (on-fader cc-number state
#:key (channel #f))
(register-state!
(lighting-state
(state-for-each
(lambda (fix attr val)
(if (intensity? attr)
;; Intensity parameters get scaled according to the fader
(at fix attr (lambda (time)
(let ((cc-val (get-cc-value cc-number
#:channel channel)))
(if cc-val
(* 0.01 val (ccval->percent cc-val))
0))))
;; Non-intensity parameters just get set in our new state
(at fix attr val)))
state))))
(define* (at-midi-jogwheel fix attr cc-number
#:key (led #f))
(define (ccval->offset a)
(if (eq? a 127)
-1
1))
(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))))))
(define (in-range a val1 val2)
(or
(and (>= a val1)
(<= a val2))
(and (>= a val2)
(<= a val1))))
(define* (at-midi-fader fix
attr
cc-number
#:key
(led-incongruent #f)
(led #f))
(let* ((congruent-val (percent->ccval (current-value fix attr)))
(cc-val (get-cc-value cc-number))
(congruent (and cc-val
(= cc-val congruent-val))))
(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
(set-attr! programmer-state
fix
attr
(ccval->percent new-cc-value)))
(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-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 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 (find-control-spec control-map needle)
(find (lambda (a)
(eq? (attr-name a) needle))
control-map))
(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
attr-name
(cc-number control-spec)
#:led (leds control-spec)))
((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)))))))
;; 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 (led-off leds)
(cond
((list? leds)
(for-each send-note-off leds))
((number? leds)
(send-note-off leds))))
(for-each remove-midi-callback! midi-callbacks)
(for-each (lambda (control-spec)
(led-off (leds control-spec)))
control-map)
(set! midi-callbacks '())
(when fixture
(set! midi-callbacks
(map (lambda (attr)
(midi-control-attr fixture
(get-attr-name attr)))
(get-attributes fixture)))))
|
