-
Notifications
You must be signed in to change notification settings - Fork 4
/
megra-dispatchers.lisp
331 lines (300 loc) · 15.2 KB
/
megra-dispatchers.lisp
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
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
;; event dispatching and related stuff ...
;; simple time-recursive dispatching
(in-package :megra)
;; activate if debugging ...
(incudine::set-sharp-square-bracket-syntax)
(incudine::add-sharp-square-bracket-syntax)
;; helper to store sync informations, wraps around the event generator
(defclass processor-sync ()
((name :accessor name :initarg :name)
(processor :accessor processor :initarg :processor)
(synced-syncs :accessor synced-syncs :initform nil)
(synced-progns :accessor synced-progns :initform nil)
(wait-for-sync :accessor wait-for-sync :initform nil)
(active :accessor is-active :initform nil :initarg :is-active)
(shift :accessor sync-shift :initform 0.0 :initarg :shift)))
(defmethod activate ((sync processor-sync))
(setf (wait-for-sync sync) nil)
(setf (is-active sync) t)
(if (processor sync) (activate (processor sync))))
;; deactivate ... if it's a modifying event processor, delete it ...
(defmethod deactivate ((sync processor-sync))
(setf (wait-for-sync sync) nil)
(setf (is-active sync) nil)
(if (processor sync) (deactivate (processor sync))))
(defmethod pull-events ((p processor-sync) &key)
(pull-events (processor p)))
(defmethod pull-transition ((p processor-sync) &key)
(pull-transition (processor p)))
;;;;;;;;;;;;;;;; EVENT DISPATCHING ;;;;;;;;;;;;;;;;;;;;
;; time recursions and management thereof ...
;; this one is used for mac, because time handling is a bit different
;; there with port
(defun perform-dispatch-sep-times (sync osc-time incudine-time)
;; regular case ...
(when (and sync (is-active sync))
;; here, the events are produced and handled ...
(when (synced-syncs sync)
(loop for synced-sync in (synced-syncs sync)
;; don't check if it's active, as only deactivated procs
;; are added to sync list
do (let ((sync-shift (sync-shift synced-sync)))
(activate synced-sync)
(setf (sync-shift synced-sync) 0)
;; secure this to ensure smooth operation in case of
;; forgotten graphs ...
(handler-case
(incudine:aat (+ incudine-time #[sync-shift ms])
#'perform-dispatch-sep-times
synced-sync
(+ osc-time (* sync-shift 0.001))
it)
(simple-error (e) (incudine::msg error "~D" e)))))
;; reset all synced processors
(setf (synced-syncs sync) nil))
(handler-case
(when (synced-progns sync)
(mapc #'funcall (synced-progns sync))
(setf (synced-progns sync) nil))
(simple-error (e)
(incudine::msg error "cannot handle sync-progns: ~D" e)
(setf (synced-progns sync) nil)))
;; handle events from current graph
;; again, secure this, so that the sync can be restarted
;; without having to clear everything ...
(handler-case (handle-events (pull-events sync) osc-time)
(error (e)
(incudine::msg error "cannot pull and handle events: ~D" e)))
;; here, the transition time between events is determinend,
;; and the next evaluation is scheduled ...
;; this method works only with SC,
;; with INCUDINE itself it'll be imprecise ...
(let* ((trans-time (* (if (typep *global-tempo-mod* 'param-mod-object) (evaluate *global-tempo-mod*) *global-tempo-mod*)
(transition-duration (car (pull-transition sync)))))
(next-osc-time (+ osc-time (* trans-time 0.001)))
(next-incu-time (+ incudine-time
#[(- next-osc-time (incudine::timestamp)) s])))
(incudine:aat next-incu-time
#'perform-dispatch-sep-times sync next-osc-time it))))
(defun perform-dispatch (sync incudine-time)
(when (and sync (is-active sync))
;; here, the events are produced and handled ...
(when (synced-syncs sync)
(loop for synced-sync in (synced-syncs sync)
;; don't check if it's active, as only deactivated procs
;; are added to sync list
do (let ((sync-shift (sync-shift synced-sync)))
(incudine::msg error "sync-start: ~D" (name synced-sync))
(activate synced-sync)
(setf (wait-for-sync synced-sync) nil)
(setf (sync-shift synced-sync) 0)
;; secure this to ensure smooth operation in case of
;; forgotten graphs ...
(handler-case
(incudine:aat (+ incudine-time #[sync-shift ms])
#'perform-dispatch
synced-sync
it)
(simple-error (e) (incudine::msg error "~D" e)))))
;; reset all synced processors
(setf (synced-syncs sync) nil))
(handler-case
(when (synced-progns sync)
(mapc #'funcall (synced-progns sync))
(setf (synced-progns sync) nil))
(simple-error (e)
(incudine::msg error "cannot handle sync-progns: ~D" e)
(setf (synced-progns sync) nil)))
;; handle events from current graph
;; again, secure this, so that the sync can be restarted
;; without having to clear everything ...
(handler-case (handle-events (pull-events sync) (incudine::rt-time-offset))
(error (e)
(incudine::msg error "cannot pull and handle events: ~D" e)))
(if *vis-active* (incudine::nrt-funcall (vis-update (processor sync))))
;; here, the transition time between events is determinend,
;; and the next evaluation is scheduled ...
(let* ((shift-time (sync-shift sync))
(trans-time (* (if (typep *global-tempo-mod* 'param-mod-object) (evaluate *global-tempo-mod*) *global-tempo-mod*)
(transition-duration (car (pull-transition sync)))))
(next-incu-time (+ incudine-time #[trans-time ms] #[shift-time ms])))
(incudine:aat next-incu-time #'perform-dispatch sync it))))
(defun handle-events (events osc-timestamp)
(mapc #'(lambda (event) (handle-event event (+ osc-timestamp *global-osc-delay*))) events))
(defun inner-dispatch (sync sync-to)
(let ((sync-to-sync-to (gethash sync-to *global-syncs*)))
;; now, if we want to sync the current sync to :sync-to,
;; and :sync-to denotes a sync that is actually present,
(cond
((and sync-to-sync-to (is-active sync-to-sync-to))
;; when the current sync is NOT yet synced to sync-to-sync-to ...
(unless (wait-for-sync sync)
(deactivate sync)
(setf (wait-for-sync sync) t)
;;(incudine::msg info "syncing ~D to ~D, ~D will start at next dispatch of ~D" name sync-to name sync-to)
(setf (synced-syncs sync-to-sync-to)
(nconc (synced-syncs sync-to-sync-to)
(list sync)))))
(t (unless (or (is-active sync) (wait-for-sync sync))
(incudine::msg error "start sync ~D" (name sync))
(activate sync)
;; different methods work, unfortunately, better on different operating systems ...
#-linux (incudine:at (+ (incudine:now) #[(sync-shift sync) ms])
#'perform-dispatch-sep-times
sync
(+ (incudine:timestamp) (* (sync-shift sync) 0.001))
(+ (incudine:now) #[(sync-shift sync) ms]))
#+linux (incudine:aat (+ (incudine:now) #[(sync-shift sync) ms])
#'perform-dispatch
sync
it))))))
(defun dispatch (name proc &key (sync nil) (shift 0.0) (intro nil))
(let ((sync-to (cond ((gethash sync *global-syncs*) sync)
((gethash sync *multichain-directory*) (car (last (gethash sync *multichain-directory*))))
(t sync)))
(old-sync (gethash name *global-syncs*)))
;; first, construct the sync ...
(cond ((and old-sync (wait-for-sync old-sync))) ;; don't do anything, as there's a sync for this already ...
(old-sync
(setf (sync-shift old-sync) (max 0 (- shift (sync-shift old-sync))))
(setf (processor old-sync) (if (functionp proc) (funcall proc) proc))
(activate (processor old-sync))
(unless (is-active old-sync)
(if intro
(progn (handle-event intro 0)
(incudine:at (+ (incudine:now) #[(event-duration intro) ms])
#'(lambda ()
(inner-dispatch
old-sync
sync-to))))
(inner-dispatch old-sync sync-to))))
(t (let ((new-sync (make-instance 'processor-sync :name name :shift shift :processor (if (functionp proc) (funcall proc) proc) :is-active nil)))
;; store sync flag
(setf (gethash name *global-syncs*) new-sync)
(setf (sync-shift new-sync) shift)
(if intro
(progn (handle-event intro 0)
(incudine:at (+ (incudine:now) #[(event-duration intro) ms])
#'(lambda ()
(inner-dispatch
new-sync
sync-to))))
(inner-dispatch new-sync sync-to)))))))
(defun once (event)
"one-shot sound event"
(handle-event event 0))
(defun sx-inner (procs-and-names new sync shift)
(loop for pn in procs-and-names
do (dispatch (cadr pn) (car pn) :sync (if (not (equal (cadr pn) sync)) sync) :shift shift)))
(defun sx (basename act &rest rest)
(let* ((intro (find-keyword-val :intro rest :default nil))
(sync (find-keyword-val :sync rest :default nil))
(shift (find-keyword-val :shift rest :default 0.0))
(procs (delete-if #'(lambda (i) (member i (list :sync :shift :intro sync shift intro))) rest))) ;; remove found args
(if (not act)
(loop for name in (gethash basename *multichain-directory*) do (clear name))
(let* ((fprocs (mapcar #'(lambda (p) (if (functionp p) (funcall p) p)) (alexandria::flatten procs)))
(names (loop for n from 0 to (- (length fprocs) 1)
collect (intern (format nil "~D-~D" basename (name (nth n fprocs))))))
(all-in (mapcar 'list fprocs names))
(prev-names (gethash basename *multichain-directory*))
(remaining (intersection names prev-names))
(gone (remove-if #'(lambda (c) (member c names)) prev-names))
(new (remove-if #'(lambda (c) (member c prev-names)) names))
(sync-to (if sync sync
(if remaining
(alexandria::lastcar remaining)
(alexandria::lastcar new)))))
;; set current names
(setf (gethash basename *multichain-directory*) names)
;;(format t "~D ~D ~D ~D ~D~%" names prev-names new gone remaining)
;; clear old
(mapc #'(lambda (s) (clear s)) gone)
;; start new after handling eventual intro
(if intro
(progn (handle-event intro 0)
(incudine:at (+ (incudine:now) #[(event-duration intro) ms])
#'(lambda () (sx-inner all-in new sync-to shift))))
(sx-inner all-in new sync-to shift))))))
(defun xdup (&rest funs-and-proc)
(let* ((funs (butlast funs-and-proc))
(proc (if (functionp (car (last funs-and-proc)))
(funcall (car (last funs-and-proc)))
(car (last funs-and-proc))))
(duplicates (loop for p from 0 to (- (length funs) 1)
collect (funcall (nth p funs) (lambda () (deepcopy proc))))))
(nconc duplicates (list proc))))
;; helper functions for copy names
(defun fix-copy (gen copy-num)
(cond ((typep gen 'generator)
(setf (generator-name gen) (intern (concatenate 'string (symbol-name (name gen)) "-" (write-to-string copy-num))))
(setf (gethash (generator-name gen) *processor-directory*) gen)
(when (successor gen) (fix-copy (successor gen) copy-num)))
((typep gen 'event-processor-wrapper)
(fix-copy (wrapper-wrapped-processor gen) copy-num)))
gen)
(defun xdup (&rest funs-and-proc)
(let* ((funs (butlast funs-and-proc))
(proc (if (functionp (car (last funs-and-proc)))
(funcall (car (last funs-and-proc)))
(car (last funs-and-proc))))
(Count 0)
(duplicates (mapcar #'(lambda (f) (funcall f (lambda () (let ((ng (deepcopy proc)))
(fix-copy ng count)
(incf count)
ng))))
funs)))
(format t "~D~%" duplicates)
(nconc duplicates (list proc))))
;; calculate spreading intervals
(defun spread-pos (n)
(if (eql n 1)
(list 0.0)
(loop for i from 0 to (- n 1)
collect (coerce (- (* i (/ 2 (- n 1))) 1) 'float))))
(defun xspread2 (&rest funs-and-proc)
(let* ((positions (spread-pos (length funs-and-proc)))
(funs (butlast funs-and-proc))
(proc (if (functionp (car (last funs-and-proc)))
(funcall (car (last funs-and-proc)))
(car (last funs-and-proc))))
(count 0)
(duplicates (mapcar #'(lambda (f) (funcall f (lambda () (let ((ng (deepcopy proc)))
(fix-copy ng count)
(incf count)
ng))))
funs)))
(mapcar #'(lambda (pr po) (pear (pos po) pr)) (nconc duplicates (list (lambda () proc))) positions)))
;; calculate spreading intervals
(defun spread-pos-8 (n)
(if (eql n 1)
(list 1.0)
(loop for i from 0 to (- n 1)
collect (coerce (+ 1 (* i (/ 7 (- n 1)))) 'float))))
(defun xspread8 (&rest funs-and-proc)
(let* ((positions (spread-pos-8 (length funs-and-proc)))
(funs (butlast funs-and-proc))
(proc (if (functionp (car (last funs-and-proc)))
(funcall (car (last funs-and-proc)))
(car (last funs-and-proc))))
(count 0)
(duplicates (mapcar #'(lambda (f) (funcall f (lambda () (let ((ng (deepcopy proc)))
(fix-copy ng count)
(incf count)
ng))))
funs)))
(mapcar #'(lambda (pr po) (pear (pos po) pr)) (nconc duplicates (list (lambda () proc))) positions)))
(defun xrot8 (offset range &rest funs-and-proc)
(let* ((offsets (mapcar #'(lambda (o) (* offset o)) (loop for i from 0 to (length funs-and-proc) collect i)))
(funs (butlast funs-and-proc))
(proc (if (functionp (car (last funs-and-proc)))
(funcall (car (last funs-and-proc)))
(car (last funs-and-proc))))
(count 0)
(duplicates (mapcar #'(lambda (f) (funcall f (lambda () (let ((ng (deepcopy proc)))
(fix-copy ng count)
(incf count)
ng))))
funs)))
(mapcar #'(lambda (pr po) (pear (pos (oscil po (+ po range))) pr))
(nconc duplicates (list (lambda () proc))) offsets)))