-
Notifications
You must be signed in to change notification settings - Fork 0
/
staves.lisp
439 lines (419 loc) · 23.3 KB
/
staves.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
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
;; -*- lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;**************************************************************************************************
;; FOMUS
;; staves.lisp
;;**************************************************************************************************
(in-package :fomus)
(compile-settings)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; STAVES/CLEFS
(declaim (type boolean *auto-staff/clef-changes*))
(defparameter *auto-staff/clef-changes* t)
(declaim (type symbol *auto-staff/clefs-plugin* *auto-staff/clefs-module*))
(defparameter *auto-staff/clefs-plugin* nil)
(defparameter *auto-staff/clefs-module* t)
(declaim (inline auto-clefs-fun))
(defun auto-clefs-fun () (if (truep *auto-staff/clefs-module*) :staves/clefs1 *auto-staff/clefs-module*))
(declaim (type (real 0) *clef-force-clef-change-dist*))
(defparameter *clef-force-clef-change-dist* 2) ; 2 can be nil
(declaim (type #-allegro (float 0 1) #+allegro float *clef-change-clef-penalty* *clef-change-staff-penalty* *clef-polyphony-perbeat-penalty* *clef-order-perbeat-penalty*))
(defparameter *clef-change-clef-penalty* (float 1)) ; 1
(defparameter *clef-change-staff-penalty* (float 1/2)) ; 1/4 should probably be less than change-clef-penalty
(defparameter *clef-polyphony-perbeat-penalty* (float 1/3)) ; 1/16 per beat
(defparameter *clef-order-perbeat-penalty* (float 1/8)) ; 1/16
;; rests should be filtered out before this function is called
;; staff is a number
(declaim (type cons *clef-midwhites* *clef-switchthrs* *clef-list*))
(declaim (special *clef-midwhites* *clef-switchthrs* *clef-list*))
(defun clefs-getclef (clef events staff)
(declare (type symbol clef) (type list events) (type (integer 0) staff))
(let ((mi (mloop for e of-type noteex in events minimize (event-writtennote e))) ; GUESS WRITTENNOTE
(ma (mloop for e of-type noteex in events maximize (event-writtennote e))))
(flet ((cf () ; choose clef--mi and ma assumed to be written notes
(let ((m (/ (+ (notetowhite mi) (notetowhite ma)) 2)))
(loop-return-argmin (diff (the integer (lookup cl *clef-midwhites*)) m)
for cl of-type symbol in *clef-list*))))
(if clef
(if (or (null events)
(let ((cd (lookup clef *clef-switchthrs*)))
(declare (type cons cd))
(let ((u (cdr cd)) (l (car cd)))
(declare (type (or integer null) u l))
(and (if l (>= mi l) t) (if u (<= ma u) t)))))
clef (cf))
(if events (cf) (or (the symbol (nth staff *clef-list*)) (the symbol (last-element *clef-list*))))))))
(declaim (type (integer 1) *staff-engine-heap*))
(defparameter *staff-engine-heap* 30)
(defstruct (clefnode (:copier nil) (:predicate clefnodep))
(sc 0.0 :type #-allegro (float 0) #+allegro float)
(lo 0 :type (rational 0))
(lg 0 :type (rational 0))
(ics #() :type (vector symbol))
(cs #() :type (vector symbol))
(lvs #() :type (vector list))
(ret nil :type list)
(evs nil :type list)
(o 0 :type (rational 0))
(co 0 :type (integer 0))) ; ics is vector of init-clef, cs is vector of clefs, lvs = vector of last voices
(defun clefs-bylegscore (events instr name)
(let ((nst (instr-staves instr))
(co 0))
(declare (type (integer 0) co))
(labels ((cm (vs al &optional (s 0)) ; all combinations of staff/voice assignmets (list of lists of (staff . voice))
(declare (type list vs) (type list al) (type (integer 0) s))
(when vs
(loop for i of-type (integer 0) in (or al (loop for i0 from s below nst collect i0)) nconc
(loop for j of-type list in (or (cm (rest vs) al i) '(nil)) collect
(cons (cons i (first vs)) j))))))
(flet ((scorefun (no) (declare (type clefnode no)) (cons (clefnode-sc no) (clefnode-co no)))
(expandfun (no)
(declare (type clefnode no))
(when (> (clefnode-co no) co) ;; progress
(setf co (clefnode-co no))
(print-dot))
(let ((o (event-off (first (clefnode-evs no)))))
(multiple-value-bind (al es rs vs gd) ; es = events at cur. offset, rs = rest of evs, vs = sorted voices, gd = 0 or effgracedur if grace notes
(loop
with g = (event-grace (first (clefnode-evs no))) and al and pe
for rs on (clefnode-evs no) for e of-type noteex = (first rs)
while (and (= (event-off e) o) (eql (event-grace e) g) (or (null pe) (equal (event-userstaff e) (event-userstaff pe))))
collect e into es
do (setf al (event-userstaff e) pe e)
collect (event-voice* e) into v
when g maximize (event-graceeffdur e) into gd
finally (return (values al es rs (sort (delete-duplicates v) #'<) #-clisp gd #+clisp (or gd 0))))
(loop
with nco = (if (or (null (clefnode-o no)) (> o (clefnode-o no))) (1+ (clefnode-co no)) (clefnode-co no))
for vas of-type cons in (cm vs (loop for e of-type (integer 0) in al if (< e nst) collect e else do
(error "Invalid staff number ~S in :STAFF mark at offset ~S, part ~S" (1+ e) (coerce o 'float) name))) ; iterate over all possible arrangements, vas is a possible combination of (cons staff voice)
collect (loop
with sc = (clefnode-sc no) ; score
and ics = (copy-seq (clefnode-ics no)) ; initial clefs
and cs = (copy-seq (clefnode-cs no)) ; current clefs
and lvs = (copy-seq (clefnode-lvs no)) ; last voices
for sv of-type cons in (split-into-groups vas #'car) ; sv is list of (cons staff voice) for one staff
nconc (let* ((vv (mapcar #'cdr sv)) ; vv = voices for this staff
(ve (remove-if-not (lambda (x) (declare (type noteex x)) (find (event-voice* x) vv)) es))) ; ve = events for this staff
(let ((s (car (first sv))) ; s = staff
(uc (find-if #'identity ve :key #'event-userclef)))
(declare (type (integer 0) s) (type (or note null) uc))
(let ((c0 (svref cs s))
(c (or uc ; override
(clefs-getclef nil ve s)))) ; c = new clef (maybe)
(if (svref (clefnode-ics no) s)
(when (and (not (eq c c0)) ; clef change suggested
(or uc ; forced override
(eq c (clefs-getclef c0 ve s)) ; supported by necessary change
(loop with li and oo of-type (rational 0) and gg ; look ahead to be sure
for e of-type noteex in rs
when (find (event-voice* e) vv) do
(if li
(if (and (= (event-off e) oo) (eql (event-grace e) gg))
(push e li)
(if (eq c0 (clefs-getclef nil li s)) ; goes back to original clef
(return)
(if (or (and *clef-force-clef-change-dist*
(> (- oo o) *clef-force-clef-change-dist*)) ; going too far
(eq c (clefs-getclef c0 li s))) ; finally supported by necessary change
(return t)
(setf li (list e))))) ; necessary to change
(setf oo (event-off e) gg (event-grace e) li (list e)))
finally
(return (unless (or (null li) (eq c0 (clefs-getclef nil li s))) ; goes back to original clef
(or (and *clef-force-clef-change-dist*
(> (- oo o) *clef-force-clef-change-dist*)) ; going too far
(eq c (clefs-getclef c0 li s))))))))
(setf (svref cs s) c ve (cons (let ((x (copy-event (first ve))))
(addmark x (list :clef c)) x)
(rest ve)))
(incf sc *clef-change-clef-penalty*))
(setf (svref ics s) c (svref cs s) c)))
(mapc (lambda (v)
(declare (type (integer 1) v))
(let ((p (position v lvs :test #'find))) ; p = last staff this voice was on
(when (or (null p) (/= p s))
(incf sc *clef-change-staff-penalty*)
(when p (setf (svref lvs p) (remove v (svref lvs p))))
(push v (svref lvs s)))))
vv)
(if (> nst 1)
(mapcar (lambda (x) (declare (type noteex x)) (copy-event x :voice (cons (1+ s) (event-voice* x)))) ve)
(copy-list ve)))) into ret
finally
(incf sc (* (+ (* (loop for e across lvs sum (max (1- (length e)) 0)) ; avoid excessive polyphony on one staff
*clef-polyphony-perbeat-penalty*)
(* (loop ; clef order
with xl = (loop for x across cs when x collect (position x +clefs+ :key #'car)) and xh #-clisp while #-clisp xl
for e of-type (integer 0) = #-clisp (pop xl) #+clisp (if xl (pop xl) (loop-finish))
count (or (when xh (< (min-list xh) e)) (when xl (> (or (max-list xl) -1) e)))
do (push e xh))
*clef-order-perbeat-penalty*))
(max (- o (clefnode-lo no)) (clefnode-lg no))))
(return (make-clefnode :sc sc :lo o :lg gd :ics ics :cs cs :lvs lvs :ret (nconc ret (clefnode-ret no)) :evs rs :o o :co nco))))))) ; ret is out of order
(scoregreaterfun (s1 s2) (declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float *) s1 s2)) (< (car s1) (car s2)))
(remscoregreaterfun (r1 r2)
(declare (type (cons #-(or openmcl allegro) (float 0) #+(or openmcl allegro) float (integer 0)) r1 r2))
(if (= (cdr r1) (cdr r2)) (> (car r1) (car r2)) (< (cdr r1) (cdr r2))))
(solutfun (no) (declare (type clefnode no)) (null (clefnode-evs no))))
(let ((*clef-list* (force-list (instr-clefs instr))))
(multiple-value-bind (*clef-midwhites* *clef-switchthrs*) ; so = middle whitenotes, sx = switching thresholds
(loop
with pp and l = (instr-cleflegls instr)
for (c . p) of-type (symbol . (or integer null)) in +clefs+
when (find c *clef-list*)
do (setf pp (notetowhite p))
and collect (cons c pp) into r
and collect (cons c (cons (whitetonote (- pp
(* (if (numberp l) l
(loop
with l0 of-type integer
for z of-type (or (integer 1) cons) in l
for (e a1 a2) of-type ((or (integer 1) symbol) symbol (or (integer 1) null)) in (force-list z)
if (numberp e) do (setf l0 e)
else if (and (eq e c) (eq a1 :dn)) do (return a2)
finally (return l0))) 2)
5))
(whitetonote (+ pp
(* (if (numberp l) l
(loop
with l0 of-type integer
for z of-type (or (integer 1) cons) in l
for (e a1 a2) of-type ((or (integer 1) symbol) symbol (or (integer 1) null)) in (force-list z)
if (numberp e) do (setf l0 e)
else if (and (eq e c) (eq a1 :up)) do (return a2)
finally (return l0))) 2)
5)))) into re
finally
(setf (cadr (first re)) nil
(cddr (last-element re)) nil)
(return (values r re)))
(let ((n (or (let ((*staff-engine-heap* (max (roundint (* *staff-engine-heap* *quality*)) 1)))
(bfs*-engine (list (make-clefnode :ics (make-array nst :initial-element nil)
:cs (make-array nst :initial-element nil)
:lvs (make-array nst :initial-element nil)
:evs events))
#'scorefun
#'expandfun
#'solutfun
:heaplim *staff-engine-heap*
:scoregreaterfun #'scoregreaterfun
:remscoregreaterfun #'remscoregreaterfun))
(error "Cannot find staff/clef assignments for part ~S" name))))
(values (clefnode-ret n)
(loop for i from 0 below nst collect
(list :clef (or (svref (clefnode-ics n) i)
(clefs-getclef nil nil i))
(1+ i)))))))))))
(declaim (inline load-staff/clef-modules))
(defun load-staff/clef-modules ()
(unless (eq (auto-clefs-fun) :staves/clefs1) (load-fomus-module (auto-clefs-fun))))
(defun clefs (parts)
(loop
for p of-type partex in parts
for ns = (instr-staves (part-instr p))
do (rmprop p :clef)
if (is-percussion p) do
(loop for i from 1 to ns do (addprop p (list :clef :percussion i)))
(loop for g of-type cons in (split-into-groups (part-events p) #'event-voice*) do
(get-usermarks g :staff :startstaff- :staff- :endstaff-
(lambda (e s)
(declare (type (or noteex restex) e) (type list s))
(when (> ns 1) (setf (event-staff* e) (1- (first s))))) (part-name p)))
(loop for e of-type (or noteex restex) in (part-events p) do (rmmark e :clef))
else do ; not percussion..., voices aren't separated yet!--separate voices
(loop for g of-type cons in (split-into-groups (part-events p) #'event-voice*) do
(get-usermarks g :staff :startstaff- :staff- :endstaff-
(lambda (e s)
(declare (type (or noteex restex) e) (type list s))
(if (notep e) (setf (event-userstaff e) (mapcar #'1- (force-list s))))
(addmark e (cons :staff s))
#|(if (notep e) (setf (event-userstaff e) (mapcar #'1- (force-list s))) (addmark e (print (cons :staff s))))|#)
(part-name p)))
(multiple-value-bind (no re) (split-list (part-events p) #'notep)
(get-usermarks no :clef :startclef- :clef- :endclef-
(lambda (e c)
(declare (type (or noteex restex) e) (type list c))
(setf (event-userclef e) (first c)))
(part-name p))
(multiple-value-bind (evs prs)
(if (eq (auto-clefs-fun) :staves/clefs1)
(clefs-bylegscore no (part-instr p) (part-name p))
(call-module (auto-clefs-fun) (list "Unknown staff/clefs assignment module ~S" *auto-staff/clefs-module*) no (part-instr p) (part-name p)))
(setf (part-events p) (sort (nconc re evs) #'sort-offdur))
(mapc (lambda (x) (declare (type cons x)) (addprop p x)) prs)))
(loop ; temporarily assign rests to staves (will become defaults if distr-rests isn't run)
for g of-type cons in (split-into-groups (part-events p) #'event-voice*)
do (loop
with s of-type (or list (integer 1))
for e of-type (or noteex restex) in (sort g #'sort-offdur)
if (and (restp e) (null (getmark e :staff))) do (if (listp s) (push e s) (setf (event-staff* e) s))
else do
(let ((v (if (restp e) (second (popmark e :staff)) (event-staff e))))
(when v
(when (listp s)
(mapc (lambda (x) (declare (type restex x)) (setf (event-staff* x) v)) s))
(setf s v)))))))
(defun clefs-generic (parts)
(loop for p of-type partex in parts
for ns = (instr-staves (part-instr p)) do
(get-usermarks (part-events p) :staff :startstaff- :staff- :endstaff-
(lambda (e s)
(declare (type (or noteex restex) e) (type list s))
(when (> ns 1) (setf (event-staff* e) (first s))))
(part-name p))
(loop for ee of-type cons in (split-into-groups (part-events p) #'event-staff) do
(get-usermarks (part-events p) :clef :startclef- :clef- :endclef-
(lambda (e c)
(declare (type (or noteex restex) e) (type list c))
(setf (event-userclef e) (first c))) (part-name p))
(loop with s
for e of-type (or noteex restex) in (sort ee #'sort-offdur)
unless (eq s (event-userclef e)) do (addmark e :clef) (setf s (event-userclef e))))))
(defun clean-clefs (pts)
(loop for p of-type partex in pts
do (loop for s from 1 to (instr-staves (part-instr p)) do
(loop with x
for m of-type meas in (reverse (part-meas p))
do (loop
for p = e
for e of-type (or noteex restex)
in (reverse (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-staff x) s)) (meas-events m)))
when (or (restp e) (and p (< (event-endoff e) (event-off p)))) do (setf x nil)
if (and (notep e) (or-list (force-list (event-tielt e))))
do (let ((x0 (popmark e :clef)))
(when (and x0 (null x)) (setf x x0)))
else if x do (rmmark e :clef) (addmark e x) (setf x nil)))
(loop with x
for m in (part-meas p)
do (loop for e of-type (or noteex restex)
in (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-staff x) s)) (meas-events m))
for m = (getmark e :clef)
when m do (if (eq (second m) x) (rmmark e :clef) (setf x (second m)))))) (print-dot)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DISTRIBUTE RESTS
(declaim (type (member nil t :some :all) *grandstaff-hide-rests*)
(type (real (0)) *min-grandstaff-hide-rests-dur*))
(defparameter *grandstaff-hide-rests* t) ; nil (t or :some) or :all, can override in part properties?
(defparameter *min-grandstaff-hide-rests-dur* 1)
(declaim (type symbol *auto-distr-rests-plugin* *auto-distr-rests-module*))
(defparameter *auto-distr-rests-plugin* nil)
(defparameter *auto-distr-rests-module* t)
(declaim (inline auto-distr-rests-fun))
(defun auto-distr-rests-fun () (if (truep *auto-distr-rests-module*) :rests1 *auto-distr-rests-module*))
;; call AFTER ass-voices but BEFORE anything else (need to know where the rests are)
;; assigns all rests to staves and hides some rests
;; if other voice in OTHER staff crosses to staff w/ rests & includes notes AND flag set & >= min dur AND region includes beg/end of measure, make rests invisible (do in distr-rests)
;; (if rests hidden at beg. of measure, don't hide rest of measure)
(defun distr-rests-byconfl (parts)
(declare (type list parts))
(loop
with rl of-type list ; (cons (cons (rational 0) (rational 0)) list)
and lo = (meas-endoff (last-element (part-meas (first parts)))) ; list of lists of rests to turn invisible
for p of-type partex in (remove-if #'is-percussion parts)
for sv = (> (instr-staves (part-instr p)) 1) do
(loop
for v in (loop with v for m of-type meas in (part-meas p) do
(loop for e of-type (or noteex restex) in (meas-events m) do (pushnew (event-voice* e) v))
finally (return v)) do
(loop
with s and r and r0 and r1 ; r is rests up to endoff falling even w/ beat, r0 = remaining, r1 = to turn invisible
and ae0 = (remove-if-not #'notep (loop for m of-type meas in (part-meas p) append (meas-events m))) and ae
for m of-type meas in (part-meas p) ; all one voice
and cm = t and ba = nil do ; cm = intersect or align w/ beg/end of measure, ba = already made some rests invisible this measure
(loop
with mo = (let ((x (if (meas-div m)
(nconc (loop with o = (meas-off m) with d = (- (meas-endoff m) o)
for e of-type (rational (0)) in (meas-div m) collect o do (incf o (* e d))) (list (meas-endoff m)))
(list (meas-off m) (meas-endoff m)))))
(loop for (e n) of-type ((rational 0) (or (rational 0) null)) on x
if n nconc (loop for i from e below n collect i)
else collect e))
and tu = 0 ; tu = tuplet
for e in (remove-if-not (lambda (x) (declare (type (or noteex restex) x)) (= (event-voice* x) v)) (meas-events m)) and lt = tu ; lt = last tuplet
do (incf tu (apply #'* (event-tupfrac e)))
if (restp e) do
(if (and (null r) (null r0) s (not (and (integerp lt) (find (event-off e) mo))))
(setf (event-voice e) (if sv (cons s v) v)) ; set it and leave it, can't start group yet
(if (and (integerp tu) (find (event-endoff e) mo)) ; at end of group--save it
(progn (unless ba (prepend r0 r1) (push e r1)) ; r1 to possibly turn invisible
(prenconc r0 r) (push e r) (setf r0 nil)) ; r to put on a staff, r0 is remaining ones
(push e r0)))
else if (notep e) do
(unless s (setf s (event-staff e)))
(let ((ss (event-staff e))) ; decide which staff to stick the rests on
(if r ; have remaining ones
(let ((o1 (event-off (last-element r))) ; o1, o2 offset bounds of r
(o2 (event-endoff (first r))))
(setf ae (nconc (delete-if (lambda (x) (declare (type noteex x)) (<= (event-endoff x) o1)) ae) ; ae is all notes in span o1 to o2 on all staves (one voice)
(loop for x0 on ae0 for x of-type noteex = (first x0) while (< (event-off x) o2) when (> (event-endoff x) o1) collect x finally (setf ae0 x0))))
#+debug (check-order ae "DISTR-RESTS-BYCONFL" #'sort-offdur)
(flet ((td (s) ; total duration of notes
(declare (type (integer 1) s))
(multiple-value-bind (gr no) (split-list (remove-if-not (lambda (x) (declare (type noteex x)) (= (event-staff x) s)) ae) #'event-grace)
(max (mloop for e of-type noteex in gr maximize (event-graceeffdur e))
(loop
for (a . b) of-type ((rational 0) . (rational 0))
in (merge-linear (mapcar (lambda (x) (declare (type noteex x)) (cons (max (event-off x) o1) (min (event-endoff x) o2))) no)
(lambda (x y) (declare (type (cons (rational 0) (rational 0)) x y)) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
sum (- b a)))))
(iv (ts) ; make rests in r1 invisible
(when (and (or (eq *grandstaff-hide-rests* :all) (and *grandstaff-hide-rests* (> ts 0))) ; ts > 0 means some conflict w/ notes
cm (not ba) r1 (or (null *min-grandstaff-hide-rests-dur*) (>= (- o2 o1) *min-grandstaff-hide-rests-dur*))) ; 4/1/06 r1
(mapc (lambda (x) (declare (type restex x)) (setf (event-inv x) t)) r1)
(push (cons (cons (event-off (last-element r1)) o2) r1) rl) ; rl = list of ((o1 . o2) . inv-rests)
(setf ba t)))) ; already made rests inv this measure
(let ((ts1 nil) (ts2 nil))
(if (and (/= s ss) (> (setf ts1 (td s)) (setf ts2 (td ss)))) ; amount of conflict with staves of first/last note--s is staff of last note before e
(progn (setf s ss)
(mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r)
(iv ts2)) ; go with staff of last note
(progn (mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r)
(setf s ss)
(iv (or ts1 (td s))))))))
(setf s ss))) ; go with staff of first note
(mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons s v) v))) r0) ; set rest of the rests
(setf r nil r0 nil r1 nil cm nil)) (print-dot)
finally
(mapc (lambda (x) (declare (type restex r)) (setf (event-voice x) (if sv (cons (or s 1) v) v))) (nconc r0 r))))
(loop
with ee
do (loop ; find the holes and plug them
for e in (setf ee (get-holes (merge-linear (mapcan (lambda (m)
(declare (type meas m))
(loop for y of-type (or noteex restex) in (meas-events m)
unless (and (restp y) (event-inv y))
collect (cons (event-off y) (event-endoff y))))
(part-meas p))
(lambda (x y) (declare (type (cons (rational 0) (rational 0)) x y)) (when (<= (car y) (cdr x)) (cons (car x) (cdr y)))))
0 lo))
for m = (loop-return-argmin
(event-voice* (first (cdr i))) ; first voice
for i of-type (cons (cons (rational 0) (rational 0)) *)
in (loop-return-argmins
(cdar i)
for i of-type (cons (cons (rational 0) (rational 0)) *)
in (loop-return-argmins
(caar i) ; earliest one
for i of-type (cons (cons (rational 0) (rational 0)) *)
in (loop-return-argmins
(- (cdar i) (caar i)) ; smallest one
for i of-type (cons (cons (rational 0) (rational 0)) *)
in (let ((o1 (car e)) (o2 (cdr e)))
(declare (type (rational 0) o1 o2))
(or (remove-if-not (lambda (x)
(declare (type (cons (cons (rational 0) (rational 0)) *) x))
(and (<= (caar x) o1) (>= (cdar x) o2))) rl) ; complete fit
(remove-if-not (lambda (x)
(declare (type (cons (cons (rational 0) (rational 0)) *) x))
(and (< (caar x) o2) (> (cdar x) o1))) rl))))))) ; partial fit
#+debug unless #+debug m #+debug do #+debug (error "Error in DISTR-RESTS-BYCONFL")
do
(mapc (lambda (x) (declare (type restex x)) (setf (event-inv x) nil)) (cdr m)) ; turn back to visible
(setf rl (delete m rl :test #'equal))
(print-dot))
while ee)))
(defun distr-rests (parts)
(case (auto-distr-rests-fun)
(:rests1 (distr-rests-byconfl parts))
(otherwise (error "Unknown rest to staves distribution module ~S" *auto-distr-rests-module*))))