1 (in-package :gsharp-drawing
)
3 (defclass x-y-width-mixin
()
4 (;; indicates the absolute y position of the system to which the
6 (system-y-position :accessor system-y-position
)
7 ;; the absolute x position of the object
8 (final-absolute-measure-xoffset :accessor final-absolute-measure-xoffset
)
9 (final-width :accessor final-width
)))
11 (define-stealth-mixin dbar
(x-y-width-mixin) bar
14 (define-stealth-mixin dmeasure
(x-y-width-mixin) measure
15 (;; an elasticity function that describes how the space right after
16 ;; the initial barline of the measure behaves as a function of the
17 ;; force that is applied to it.
18 (prefix-elasticity-function :accessor prefix-elasticity-function
)))
20 (define-stealth-mixin dstaff
() staff
21 ((yoffset :initform
0 :accessor staff-yoffset
)))
23 (define-presentation-method present
24 (object (type score-pane
:clef
) stream
(view textual-view
) &key
)
25 (format stream
"[~a clef on staff step ~a]" (name object
) (lineno object
)))
27 (define-presentation-method present
28 (object (type score-pane
:fiveline-staff
) stream
(view textual-view
) &key
)
29 (format stream
"[fiveline staff ~a]" (name object
)))
31 (define-presentation-method present
32 (object (type score-pane
:lyrics-staff
) stream
(view textual-view
) &key
)
33 (format stream
"[lyrics staff ~a]" (name object
)))
35 (defun clef-for-staff (staff measures
)
36 (let ((clefs (clefs staff
))
37 (barno (gsharp-numbering:number
(car (measure-bars (car measures
))))))
39 (find barno clefs
:from-end t
:test
#'>
40 :key
(lambda (x) (gsharp-numbering:number
(bar x
)))))
43 (defun key-signature-for-staff (staff measures
)
44 (let ((key-signatures (key-signatures staff
))
45 (barno (gsharp-numbering:number
(car (measure-bars (car measures
))))))
46 (or (and key-signatures
47 (find barno key-signatures
:from-end t
:test
#'>
48 :key
(lambda (x) (gsharp-numbering:number
(bar x
)))))
51 (defmethod draw-staff-and-clef (pane (staff fiveline-staff
) measures x1 x2
)
52 (let ((clef (clef-for-staff staff measures
)))
58 :staff-step
,(lineno clef
))
60 (let ((keysig (key-signature-for-staff staff measures
)))
61 (let ((yoffset (b-position clef
)))
62 (loop for pitch in
'(6 2 5 1 4 0 3)
63 for line in
'(0 3 -
1 2 -
2 1 -
3)
64 for x from
(+ x1
10 (score-pane:staff-step
8)) by
(score-pane:staff-step
2)
65 while
(eq (aref (alterations keysig
) pitch
) :flat
)
66 do
(score-pane:draw-accidental pane
:flat x
(+ line yoffset
))))
67 (let ((yoffset (f-position clef
)))
68 (loop for pitch in
'(3 0 4 1 5 2 6)
69 for line in
'(0 -
3 1 -
2 -
5 -
1 -
4)
70 for x from
(+ x1
10 (score-pane:staff-step
8)) by
(score-pane:staff-step
2.5)
71 while
(eq (aref (alterations keysig
) pitch
) :sharp
)
72 do
(score-pane:draw-accidental pane
:sharp x
(+ line yoffset
)))))
74 `((score-pane:fiveline-staff
)
78 (defmethod draw-staff-and-clef (pane (staff lyrics-staff
) measures x1 x2
)
80 `((score-pane:lyrics-staff
)
84 ;;; Return the final absolute x offset of a note. This value is
85 ;;; computed from the x offset of the cluster of the note and the
86 ;;; relative x offset of the note with respect to the cluster.
87 (defun final-absolute-note-xoffset (note)
88 (+ (final-absolute-element-xoffset (cluster note
)) (final-relative-note-xoffset note
)))
90 ;;; Return the final absolute x offset of the accidental of a note.
91 ;;; This value is computed from the x offset of the cluster of the
92 ;;; note and the relative x offset of the accidental of the note with
93 ;;; respect to the cluster.
94 (defun final-absolute-accidental-xoffset (note)
95 (+ (final-absolute-element-xoffset (cluster note
)) (final-relative-accidental-xoffset note
)))
97 (defun final-absolute-dot-xoffset (cluster)
98 (+ (final-absolute-element-xoffset cluster
) (score-pane:staff-step
(final-relative-dot-xoffset cluster
))))
100 (defvar *cursor
* nil
)
102 ;;; Compute the elasticity of each timeline in each measure of the
103 ;;; measures of a system (line) by taking its duration to the power of
104 ;;; the spaceing style. This metric is arbitrarily normalized to the
105 ;;; duration of a whole note, which means that the force to apply to a
106 ;;; line is not comparable between two different lines. All we know
107 ;;; is that timelines with the same elasticity will grow and shrink in
108 ;;; parallel, and that proportions between two timelines of different
109 ;;; durations will be preserved.
110 (defun compute-elasticities (measures method
)
111 (loop for measure in measures
112 do
(loop with timelines
= (timelines measure
)
113 for i from
0 below
(flexichain:nb-elements timelines
)
114 for timeline
= (flexichain:element
* timelines i
)
115 do
(setf (elasticity timeline
)
116 (max (expt (duration timeline
) (spacing-style method
)) 0.0001)))))
118 ;;; FIXME: there should be an :around method that adds the value
119 ;;; return by the main method to the explicit horizontal offset that
120 ;;; the user wants to impose on an element, and the existence of this
121 ;;; around method should be documented.
122 ;;; FIXME: we should probably also allow for the user to introduce
123 ;;; explicit (positive or negative) bulges that will be added in by
124 ;;; the :around method, thus allowing the user to explicitly move two
125 ;;; adjacent elements further apart, or to bring them closer together.
126 (defgeneric left-bulge
(element pane
)
127 (:documentation
"The amount by which an element sticks out to the
128 left of the center of its timeline"))
130 ;;; FIXME: there should be an :around method that adds the value
131 ;;; return by the main method to the explicit horizontal offset that
132 ;;; the user wants to impose on an element, and the existence of this
133 ;;; around method should be documented.
134 ;;; FIXME: we should probably also allow for the user to introduce
135 ;;; explicit (positive or negative) bulges that will be added in by
136 ;;; the :around method, thus allowing the user to explicitly move two
137 ;;; adjacent elements further apart, or to bring them closer together.
138 (defgeneric right-bulge
(element pane
)
139 (:documentation
"The amount by which an element sticks out to the
140 right of the center of its timeline"))
142 (defmethod left-bulge ((element element
) pane
)
143 (score-pane:staff-step
1))
145 (defmethod left-bulge ((element lyrics-element
) pane
)
146 (+ (score-pane:staff-step
0.5)
147 (/ (text-size pane
(map 'string
'code-char
(text element
))) 2)))
149 (defmethod left-bulge ((element cluster
) pane
)
150 (+ (max (- (loop for note in
(notes element
)
151 when
(final-accidental note
)
152 minimize
(final-relative-accidental-xoffset note
)))
153 (if (and (non-empty-cluster-p element
)
154 (eq (final-stem-direction element
) :down
)
155 (element-has-suspended-notes element
))
156 (score-pane:staff-step
3)
157 (score-pane:staff-step
0)))
158 (score-pane:staff-step
2)))
160 (defmethod left-bulge :around
((element element
) pane
)
161 (+ (gsharp-buffer::left-pad element
) (call-next-method)))
162 (defmethod right-bulge :around
((element element
) pane
)
163 (+ (gsharp-buffer::right-pad element
) (call-next-method)))
165 (defmethod right-bulge ((timesig time-signature
) pane
)
166 ;; FIXME: this is probably wrong; it should either compute the bulge
167 ;; properly, or else approximate using (length - 0.5) *
168 ;; typical-width-of-component
169 (* (length (time-signature-components timesig
))
170 (score-pane:staff-step
5)))
172 (defmethod left-bulge ((element clef
) pane
)
173 (score-pane:staff-step
2))
175 (defmethod right-bulge ((element clef
) pane
)
176 (score-pane:staff-step
10))
178 (defmethod right-bulge ((element element
) pane
)
179 (score-pane:staff-step
1))
181 (defmethod right-bulge ((element lyrics-element
) pane
)
182 (+ (score-pane:staff-step
0.5)
183 (/ (text-size pane
(map 'string
'code-char
(text element
))) 2)))
185 (defmethod right-bulge ((element cluster
) pane
)
186 (if (and (non-empty-cluster-p element
)
187 (eq (final-stem-direction element
) :up
)
188 (element-has-suspended-notes element
))
189 (score-pane:staff-step
5)
190 (score-pane:staff-step
2)))
192 (defmethod right-bulge ((keysig key-signature
) pane
)
193 ;; FIXME: shares much code with DRAW-ELEMENT (KEY-SIGNATURE).
194 (let ((old-keysig (keysig keysig
)))
196 (loop with advance
= 0
197 for pitch in
'(6 2 5 1 4 0 3)
198 when
(and (eq (aref (alterations old-keysig
) pitch
) :flat
)
199 (not (eq (aref (alterations keysig
) pitch
)
201 do
(incf advance
(score-pane:staff-step
2))
202 finally
(incf bulge
(if (= advance
0) 0 (+ advance
(score-pane:staff-step
2)))))
203 (loop with advance
= 0
204 for pitch in
'(3 0 4 1 5 2 6)
205 when
(and (eq (aref (alterations old-keysig
) pitch
) :sharp
)
206 (not (eq (aref (alterations keysig
) pitch
) :sharp
)))
207 do
(incf advance
(score-pane:staff-step
2))
208 finally
(incf bulge
(if (= advance
0) 0 (+ advance
(score-pane:staff-step
2)))))
209 (loop for pitch in
'(6 2 5 1 4 0 3)
210 while
(eq (aref (alterations keysig
) pitch
) :flat
)
211 do
(incf bulge
(score-pane:staff-step
2)))
212 (loop for pitch in
'(3 0 4 1 5 2 6)
213 while
(eq (aref (alterations keysig
) pitch
) :sharp
)
214 do
(incf bulge
(score-pane:staff-step
2.5)))
217 ;;; As it turns out, the spacing algorithm would be very complicated
218 ;;; if we were to take into account exactly how elements with
219 ;;; arbitrarily many timelines between them might influence the
220 ;;; overall layout. Instead we apprixmate by obtaining a closest gap
221 ;;; only between adjacent timelines as follows: first, we consider
222 ;;; adjacent elements whose timelines are also adjacent (and there is
223 ;;; a special case for the last element of a layer), and set the
224 ;;; smallest gap between the timelines to the closest possible
225 ;;; distance between the two elements...
226 (defun compute-gaps-adjacent-timelines (bars method pane
)
227 (declare (ignore method
))
228 (loop for bar in bars
229 do
(loop for
(e1 e2
) on
(elements bar
)
230 for t1
= (timeline e1
)
232 (when (flexichain:flexi-last-p t1
)
233 (setf (smallest-gap t1
)
234 (max (smallest-gap t1
)
235 (right-bulge e1 pane
)))))
236 ((eq (flexichain:flexi-next t1
)
238 (setf (smallest-gap t1
)
239 (max (smallest-gap t1
)
240 (+ (right-bulge e1 pane
)
241 (left-bulge e2 pane
)))))))))
243 ;;; ... Then we consider adjacent elements whose timelines are
244 ;;; separated by at least one other timeline. If the sum of the
245 ;;; distances between individual timelines is greater than or equal to
246 ;;; the closest distance between the adjacent elements (which is
247 ;;; likely if we are talking melody), then there is nothing to do,
248 ;;; since the individual distances are more restrictive than that
249 ;;; imposed by the adjacent elements. If not, we try to distribute
250 ;;; the closest distance between the two adjacent elements over the
251 ;;; individual timelines proportionally to the elasticity of the
252 ;;; timlines. If in doing so, we find that some timeline already has
253 ;;; a smallest gap that is larger than the fraction of the closest
254 ;;; distance between adjacent elements that we attribute to it, then
255 ;;; that smallest gap is subtracted from the distance we need to
256 ;;; distribute, the timeline is removed from consideration, and we
257 ;;; start over. This process must terminate (or else, the sum of the
258 ;;; closest gaps must have been larger than the distance to distribute
259 ;;; in the first place) with at least one timeline to distribute over.
260 ;;; There is a special case here, which occurs when all the
261 ;;; elasticites of the timelines to be considered is zero. In this
262 ;;; case, instead of distributing proportionally to the elasticities
263 ;;; of individual timelies, we distribute evenly between the timelines.
264 (defun compute-gaps-separated-timelines (bars method pane
)
265 (declare (ignore method
))
266 (flet ((handle-timelines (timelines element-gap
)
267 (let ((sum-gap (reduce #'+ timelines
:key
#'smallest-gap
))
268 (sum-elasticity (reduce #'+ timelines
:key
#'elasticity
)))
269 (unless (> sum-gap element-gap
)
270 (if (zerop sum-elasticity
)
271 (loop for timeline
= (find (/ element-gap
(length timelines
))
275 until
(null timeline
)
276 do
(decf element-gap
(smallest-gap timeline
))
277 do
(setf timelines
(remove timeline timelines
:test
#'eq
))
278 finally
(let ((gap (/ element-gap
(length timelines
))))
279 (loop for timeline in timelines
280 do
(setf (smallest-gap timeline
) gap
))))
281 (loop for timeline
= (let ((gap/elasticity
(/ element-gap sum-elasticity
)))
282 (find-if (lambda (timeline)
283 (> (smallest-gap timeline
)
284 (* (elasticity timeline
) gap
/elasticity
)))
286 until
(null timeline
)
287 do
(decf element-gap
(smallest-gap timeline
))
288 do
(decf sum-elasticity
(elasticity timeline
))
289 do
(setf timelines
(remove timeline timelines
:test
#'eq
))
290 finally
(let ((gap/elasticity
(/ element-gap sum-elasticity
)))
291 (loop for timeline in timelines
292 do
(setf (smallest-gap timeline
)
293 (* (elasticity timeline
) gap
/elasticity
))))))))))
294 (loop for bar in bars
295 do
(loop for
(e1 e2
) on
(elements bar
)
296 for t1
= (timeline e1
)
298 (unless (flexichain:flexi-last-p t1
)
299 (let ((timelines (loop for tl
= t1 then
(flexichain:flexi-next tl
)
301 until
(flexichain:flexi-last-p tl
))))
302 (handle-timelines timelines
(right-bulge e1 pane
)))))
303 ((not (eq (flexichain:flexi-next t1
)
305 (let ((timelines (loop for tl
= t1 then
(flexichain:flexi-next tl
)
306 until
(eq tl
(timeline e2
))
308 (handle-timelines timelines
(+ (right-bulge e1 pane
)
309 (left-bulge e2 pane
))))))))))
311 (defun compute-gaps (measures method pane
)
312 (loop for measure in measures
313 ;; initially, look only at adjacent elements whose
314 ;; corrsponding timelines are also adjacent, and at the last
315 ;; element of a bar, provided that its timeline is also the
316 ;; last one in the measure
317 do
(compute-gaps-adjacent-timelines (measure-bars measure
) method pane
)
319 ;; then look at adjacent elements whose corresponding
320 ;; timelines are NOT adjacent, or the last element of a bar
321 ;; whose corresponding timeline is not the last one in the meaure
322 do
(compute-gaps-separated-timelines (measure-bars measure
) method pane
)))
324 ;;; When this function is called, each timeline has an elasticity and
325 ;;; a smallest gap to the next adjacent timline (or to the end of the
326 ;;; measure). These values, together with an elasticity function at
327 ;;; the beginning of a measure, are used to compute the total
328 ;;; elasticity function of a measure.
329 (defun compute-elasticity-functions (measures method pane
)
330 (loop for measure in measures
331 do
(setf (prefix-elasticity-function measure
)
333 (max (min-width method
)
334 (if (zerop (flexichain:nb-elements
(timelines measure
)))
336 (loop for element in
(elements (flexichain:element
* (timelines measure
) 0))
337 maximize
(left-bulge element pane
))))))
338 (make-elementary-elasticity prefix-width
0.0001)))
339 do
(loop with result
= (prefix-elasticity-function measure
)
340 with timelines
= (timelines measure
)
341 for i from
0 below
(flexichain:nb-elements timelines
)
342 for timeline
= (flexichain:element
* timelines i
)
346 (make-elementary-elasticity (smallest-gap timeline
) (elasticity timeline
))))
347 finally
(setf (elasticity-function measure
) result
)))
348 (reduce #'add-elasticities measures
:key
#'elasticity-function
))
350 (defun single-whole-rest-in-bar-p (element)
351 (let* ((bar (bar element
))
352 (elements (elements bar
)))
353 (and (null (cdr elements
))
354 (typep element
'rest
)
355 (member (notehead element
) '(:long
:breve
:whole
)))))
357 (defun compute-measure-coordinates (measure x y force
)
358 (loop with timelines
= (timelines measure
)
359 for i from
0 below
(flexichain:nb-elements timelines
)
360 for timeline
= (flexichain:element
* timelines i
)
361 and xx
= (+ x
(size-at-force (prefix-elasticity-function measure
) force
))
362 then
(+ xx
(max (smallest-gap timeline
)
363 (* force
(elasticity timeline
))))
364 do
(loop for element in
(elements timeline
)
365 do
(setf (final-absolute-element-xoffset element
)
366 (if (single-whole-rest-in-bar-p element
)
367 (round (+ x
(/ (size-at-force (elasticity-function measure
) force
) 2)))
368 (round (+ xx
(score-pane:staff-step
(xoffset element
))))))))
369 (loop for bar in
(measure-bars measure
)
370 do
(compute-bar-coordinates bar x y
(size-at-force (elasticity-function measure
) force
))))
372 (defun draw-measure (pane measure
)
373 (loop for bar in
(measure-bars measure
) do
374 (if (gsharp-cursor::cursors
(slice bar
))
376 (score-pane:with-light-glyphs pane
(draw-bar pane bar
))))
377 (let ((first-bar (car (measure-bars measure
))))
378 (let ((x (final-absolute-measure-xoffset first-bar
))
379 (y (system-y-position first-bar
))
380 (width (final-width first-bar
))
381 (staves (staves (buffer (segment (layer (slice first-bar
)))))))
382 (score-pane:draw-bar-line pane
(+ x width
)
383 (+ y
(- (score-pane:staff-step
8)))
384 (+ y
(staff-yoffset (car (last staves
))))))))
386 (defun compute-system-coordinates (measures x y force
)
387 (loop for measure in measures
388 do
(compute-measure-coordinates measure x y force
)
389 do
(incf x
(size-at-force (elasticity-function measure
) force
))))
391 (defun draw-tie (pane bars n1 n2
)
392 ;; FIXME: we'll want to draw ties between (nothing) and n2 eventually
393 (declare (type note n1
) (type (or note null
) n2
))
394 (let ((x1 (+ (final-absolute-note-xoffset n1
) (score-pane:staff-step
1.5)))
395 (x2 (if (typep n2
'note
)
396 (- (final-absolute-note-xoffset n2
) (score-pane:staff-step
1.5))
397 (+ (final-absolute-note-xoffset n1
) (score-pane:staff-step
4.5))))
398 (pos (note-position n1
)))
399 (if (eq (final-stem-direction (cluster n1
)) :up
)
400 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff n1
)))
401 (if (gsharp-cursor::cursors
(slice (car bars
)))
402 (score-pane:draw-tie-down pane x1 x2
(if (oddp pos
) (1- pos
) pos
))
403 (score-pane:with-light-glyphs pane
404 (score-pane:draw-tie-down pane x1 x2
(if (oddp pos
) (1- pos
) pos
)))))
405 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff n1
)))
406 (if (gsharp-cursor::cursors
(slice (car bars
)))
407 (score-pane:draw-tie-up pane x1 x2
(if (oddp pos
) (1+ pos
) pos
))
408 (score-pane:with-light-glyphs pane
409 (score-pane:draw-tie-up pane x1 x2
(if (oddp pos
) (1+ pos
) pos
))))))))
411 (defun notes-tieable (n1 n2
)
412 (and (= (pitch n1
) (pitch n2
))
413 (eq (staff n1
) (staff n2
))
414 (eq (accidentals n1
) (accidentals n2
))))
416 ;;; draw the ties in BARS starting at BAR and at most LENGTH bars
417 (defun draw-ties (pane bars bar length
)
418 (loop until
(eq bar
(car bars
))
420 (score-pane:with-vertical-score-position
421 (pane (system-y-position (car bars
)))
422 (loop with elements
= (mapcan (lambda (bar) (copy-seq (elements bar
)))
423 (loop for bar in bars
426 for
(e1 e2
) on elements
427 do
(when (typep e1
'cluster
)
428 (loop for n1 in
(notes e1
)
429 do
(when (tie-right n1
)
430 (loop for n2 in
(and (typep e2
'cluster
) (notes e2
))
431 do
(when (and (tie-left n2
)
432 (notes-tieable n1 n2
))
433 (draw-tie pane bars n1 n2
)
435 finally
(draw-tie pane bars n1 nil
))))))))
437 (defun draw-system (pane measures
)
438 (with-new-output-record (pane)
439 (loop with length
= (length measures
)
440 for bar in
(measure-bars (car measures
))
441 do
(draw-ties pane
(bars (slice bar
)) bar length
))
442 (loop for measure in measures do
443 (draw-measure pane measure
))))
445 (defun draw-staves (pane staves measures x y right-edge
)
446 (loop for staff in staves do
447 (score-pane:with-vertical-score-position
448 (pane (+ y
(staff-yoffset staff
)))
449 (if (member staff
(staves (layer (slice (bar *cursor
*)))))
450 (draw-staff-and-clef pane staff measures x right-edge
)
451 (score-pane:with-light-glyphs pane
452 (draw-staff-and-clef pane staff measures x right-edge
))))))
454 (defun compute-and-draw-system (pane buffer staves measures method x y timesig-offset right-edge
)
455 (compute-elasticities measures method
)
456 (compute-gaps measures method pane
)
457 (let* ((e-fun (compute-elasticity-functions measures method pane
))
458 ;; FIXME: it would be much better to compress the system
459 ;; proportionally, so that every smallest gap gets shrunk
460 ;; by the same percentage
461 (force (if (> (zero-force-size e-fun
) (line-width method
))
463 (force-at-size e-fun
(line-width method
)))))
464 (compute-system-coordinates measures
465 (+ x
(left-offset buffer
) timesig-offset
) y
467 (draw-system pane measures
)
468 (score-pane:draw-bar-line pane x
469 (+ y
(- (score-pane:staff-step
8)))
470 (+ y
(staff-yoffset (car (last staves
)))))
471 (draw-staves pane staves measures x y right-edge
))
473 (defun compute-timesig-offset (staves measures
)
474 (max (* (score-pane:staff-step
2)
475 (loop for staff in staves
477 (if (typep staff
'fiveline-staff
)
478 (count :flat
(alterations (key-signature-for-staff staff measures
)))
480 (* (score-pane:staff-step
2.5)
481 (loop for staff in staves
483 (if (typep staff
'fiveline-staff
)
484 (count :sharp
(alterations (key-signature-for-staff staff measures
)))
487 (defun split (sequence n method
)
488 (labels ((sequence-size (start end
)
489 (natural-width method
490 (reduce (lambda (seq-cost element
)
491 (combine-cost method seq-cost element
))
492 sequence
:start start
:end end
493 :initial-value nil
)))
494 (split-aux (sequence start end n
)
496 (let ((width (sequence-size start end
)))
497 (values (list (subseq sequence start end
)) width width
))
498 (let* ((nn (floor n
2))
499 (m (floor (* (- end start
) nn
) n
)))
500 (multiple-value-bind (best-left minl maxl
)
501 (split-aux sequence start
(+ start m
) nn
)
502 (multiple-value-bind (best-right minr maxr
)
503 (split-aux sequence
(+ start m
) end
(- n nn
))
504 (let* ((best-min (min minl minr
))
505 (best-max (max maxl maxr
))
506 (best-cost (/ (- best-max best-min
) 2))
507 (best-splits (append best-left best-right
)))
508 (cond ((and (< minl minr
)
511 while
(and (< minl minr
)
513 (>= (- end start m
) (- n nn
)))
514 do
(multiple-value-bind (left new-minl new-maxl
)
515 (split-aux sequence start
(+ start m
) nn
)
516 (multiple-value-bind (right new-minr new-maxr
)
517 (split-aux sequence
(+ start m
) end
(- n nn
))
522 (let ((cost (/ (- (max maxl maxr
) (min minl minr
)) 2)))
523 (when (< cost best-cost
)
524 (setf best-min
(min minl minr
)
525 best-max
(max maxl maxr
)
527 best-splits
(append left right
))))))))
531 while
(and (> minl minr
)
534 do
(multiple-value-bind (left new-minl new-maxl
)
535 (split-aux sequence start
(+ start m
) nn
)
536 (multiple-value-bind (right new-minr new-maxr
)
537 (split-aux sequence
(+ start m
) end
(- n nn
))
542 (let ((cost (/ (- (max maxl maxr
) (min minl minr
)) 2)))
543 (when (< cost best-cost
)
544 (setf best-min
(min minl minr
)
545 best-max
(max maxl maxr
)
547 best-splits
(append left right
)))))))))
548 (values best-splits best-min best-max
))))))))
549 (split-aux sequence
0 (length sequence
) n
)))
551 (defun layout-page (measures n method
)
552 (if (<= (length measures
) n
)
553 (mapcar #'list measures
)
554 (split measures n method
)))
556 (defmacro dopages
((measures buffer
) &body body
)
557 `(gsharp-measure::new-map-over-obseq-subsequences
558 (lambda (,measures
) ,@body
)
561 (defun cursor-in-measures-p (cursor measures
)
562 (member-if (lambda (measure) (member (bar cursor
) (measure-bars measure
)
566 (defun method-for-timesig (method timesig-offset
)
567 (make-measure-cost-method (min-width method
) (spacing-style method
)
568 (- (line-width method
) timesig-offset
)
569 (lines-per-page method
)))
571 (defun draw-page (pane buffer x y staves maxmethod page-measures
)
572 (let* ((systems-per-page (gsharp-measure::systems-per-page buffer
))
573 (measure-seqs (layout-page page-measures systems-per-page maxmethod
)))
574 (dolist (measures measure-seqs
)
575 (let* ((toffset (compute-timesig-offset staves measures
))
576 (method (method-for-timesig (buffer-cost-method buffer
) toffset
)))
577 (compute-and-draw-system pane buffer staves measures method
578 x y toffset
(right-edge buffer
))
579 (incf y
(+ 20 (* 70 (length staves
))))))))
581 (defmethod draw-buffer (pane (buffer buffer
) *cursor
* x y
)
582 (score-pane:with-staff-size
(gsharp-buffer::rastral-size buffer
)
583 (let* ((staves (staves buffer
))
584 (max-timesig-offset (* (score-pane:staff-step
2.5) 7))
585 (method (method-for-timesig
586 (buffer-cost-method buffer
) max-timesig-offset
)))
587 (loop for staff in staves
588 for offset from
0 by
70 do
589 (setf (staff-yoffset staff
) offset
))
590 (dopages (page-measures buffer
)
591 (when (cursor-in-measures-p *cursor
* page-measures
)
592 (draw-page pane buffer x y staves method page-measures
))))))
594 (defmethod print-buffer (pane (buffer buffer
) *cursor
* x y
)
595 (score-pane:with-staff-size
(gsharp-buffer::rastral-size buffer
)
596 (let* ((staves (staves buffer
))
597 (max-timesig-offset (* (score-pane:staff-step
2.5) 7))
598 (method (method-for-timesig
599 (buffer-cost-method buffer
) max-timesig-offset
)))
600 (loop for staff in staves
601 for offset from
0 by
70 do
602 (setf (staff-yoffset staff
) offset
))
604 (dopages (page-measures buffer
)
607 (draw-page pane buffer x y staves method page-measures
)
608 (setq first nil
))))))
610 (define-stealth-mixin xelement
() element
611 ((final-absolute-xoffset :accessor final-absolute-element-xoffset
)))
613 (define-stealth-mixin velement
() melody-element
614 (;; the position, in staff steps, of the end of the stem
615 ;; that is not attached to a note, independent of the
616 ;; staff on which it is located
617 (final-stem-position :accessor final-stem-position
)
618 ;; the yoffset of the staff relative to which the end of the
620 (final-stem-yoffset :initform
0 :accessor final-stem-yoffset
)
621 ;; the yoffset of the staff that contains the top note of
623 (top-note-staff-yoffset :accessor top-note-staff-yoffset
)
624 ;; the yoffset of the staff that contains the bottom note of
626 (bot-note-staff-yoffset :accessor bot-note-staff-yoffset
)))
628 (define-stealth-mixin welement
() lyrics-element
631 ;;; Compute and store several important pieces of information
632 ;;; about an element:
633 ;;; * the y-offset of the staff containing the top note.
634 ;;; * the y-offset of the staff containing the bottom note.
635 (defun compute-top-bot-yoffset (element)
636 (if (and (typep element
'cluster
) (notes element
))
637 (let ((top-note (top-note (notes element
)))
638 (bot-note (bot-note (notes element
))))
639 (setf (bot-note-staff-yoffset element
) (staff-yoffset (staff bot-note
))
640 (top-note-staff-yoffset element
) (staff-yoffset (staff top-note
))))
641 (setf ;; clearly wrong. should be taken from element or layer.
642 (top-note-staff-yoffset element
) 0
643 (bot-note-staff-yoffset element
) 0)))
645 (defun compute-stem-length (element)
646 (let* ((top-note-pos (top-note-pos element
))
647 (bot-note-pos (bot-note-pos element
))
648 (top-note (reduce (lambda (n1 n2
)
649 (cond ((< (staff-yoffset (staff n1
))
650 (staff-yoffset (staff n2
)))
652 ((> (staff-yoffset (staff n1
))
653 (staff-yoffset (staff n2
)))
655 ((> (note-position n1
)
660 (bot-note (reduce (lambda (n1 n2
)
661 (cond ((> (staff-yoffset (staff n1
))
662 (staff-yoffset (staff n2
)))
664 ((< (staff-yoffset (staff n1
))
665 (staff-yoffset (staff n2
)))
667 ((< (note-position n1
)
672 (length (if (eq (final-stem-direction element
) :up
)
673 (cond ((<= top-note-pos -
3) (- 4 top-note-pos
))
674 ((<= top-note-pos
3) 7)
675 ((= top-note-pos
4) 6)
677 (cond ((>= bot-note-pos
11) (- bot-note-pos
4))
678 ((>= bot-note-pos
4) 7)
679 ((= bot-note-pos
3) 6)
681 (nb-flags (max (rbeams element
) (lbeams element
))))
683 (setf length
(max length
684 (+ (if (eq (final-stem-direction element
) :up
) 6 7)
685 (* 2 (max 0 (- nb-flags
2)))))))
686 (setf (final-stem-yoffset element
)
687 (staff-yoffset (staff (if (eq (final-stem-direction element
) :up
)
688 top-note bot-note
))))
689 (setf (final-stem-position element
)
690 (if (eq (final-stem-direction element
) :up
)
691 (+ top-note-pos length
)
692 (- bot-note-pos length
)))))
694 ;;; the dominating note among a bunch of notes is the
695 ;;; one that is closest to the beam, i.e. the one
696 ;;; the one that is closest to the end of the stem that
697 ;;; is not attached to a notehead.
698 (defun dominating-note (notes stem-direction
)
699 (reduce (lambda (n1 n2
)
700 (let ((yoff1 (staff-yoffset (staff n1
)))
701 (yoff2 (staff-yoffset (staff n2
))))
702 (if (eq stem-direction
:up
)
707 (if (> (pitch n1
) (pitch n2
)) n1 n2
)))
712 (if (< (pitch n1
) (pitch n2
)) n1 n2
))))))
715 (defun cluster-p (element)
716 (typep element
'cluster
))
718 (defun map-over-cluster-pairs (fun list
)
719 (loop for sublist on list
720 do
(when (cluster-p (car sublist
))
721 (let ((second (find-if #'cluster-p
(cdr sublist
))))
723 (funcall fun
(car sublist
) second
))))))
725 (defun draw-beam-group (pane elements
)
726 (let ((e (car elements
)))
727 (when (typep e
'staffwise-element
)
728 (assert (null (cdr elements
)))
729 (return-from draw-beam-group
730 (draw-element pane e
(final-absolute-element-xoffset e
)))))
731 (mapc #'compute-top-bot-yoffset elements
)
732 (if (null (cdr elements
))
733 (let ((element (car elements
)))
734 (when (or (typep element
'rest
) (notes element
))
735 (when (non-empty-cluster-p element
)
736 (compute-stem-length element
))
737 (draw-element pane element
)))
738 (let* ((stem-direction (final-stem-direction (car elements
)))
740 (loop for element in elements
741 when
(non-empty-cluster-p element
)
742 collect
(dominating-note (notes element
) stem-direction
)))
744 (staff (dominating-note dominating-notes stem-direction
)))
745 (positions (mapcar (lambda (n)
746 (if (eq (staff n
) dominating-staff
)
748 (if (eq stem-direction
:up
) -
1000 1000)))
750 (x-positions (mapcar (lambda (element)
751 (/ (final-absolute-element-xoffset element
) (score-pane:staff-step
1)))
753 (nb-beams (mapcar (lambda (element)
754 (max (lbeams element
) (rbeams element
)))
756 (beaming (beaming-single (mapcar #'list positions x-positions nb-beams
) stem-direction
))
757 (max-nb-beams (reduce #'max nb-beams
))
758 (min-nb-beams (reduce #'min nb-beams
)))
759 (destructuring-bind ((ss1 . offset1
) (ss2 . offset2
)) beaming
760 (let* ((y1 (+ ss1
(* 1/2 offset1
)))
761 (y2 (+ ss2
(* 1/2 offset2
)))
762 (x1 (final-absolute-element-xoffset (car elements
)))
763 (x2 (final-absolute-element-xoffset (car (last elements
))))
764 (slope (/ (- y2 y1
) (- x2 x1
))))
765 (if (eq stem-direction
:up
)
766 (loop for element in elements do
767 (setf (final-stem-position element
)
768 (+ y1
(* slope
(- (final-absolute-element-xoffset element
) x1
))))
769 (setf (final-stem-yoffset element
)
770 (staff-yoffset dominating-staff
)))
771 (loop for element in elements do
772 (setf (final-stem-position element
)
773 (+ y1
(* slope
(- (final-absolute-element-xoffset element
) x1
))))
774 (setf (final-stem-yoffset element
)
775 (staff-yoffset dominating-staff
)))))
776 (score-pane:with-vertical-score-position
(pane (staff-yoffset dominating-staff
))
777 (if (eq stem-direction
:up
)
778 (score-pane:with-notehead-right-offsets
(right up
)
779 (declare (ignore up
))
780 (loop repeat min-nb-beams
783 do
(score-pane:draw-beam pane
784 (+ (final-absolute-element-xoffset (car elements
)) right
) (- ss1 ss
) (+ offset1 offset
)
785 (+ (final-absolute-element-xoffset (car (last elements
))) right
) (- ss2 ss
) (+ offset2 offset
)))
786 (let ((region +nowhere
+))
787 (loop for beams from
(1+ min-nb-beams
) to max-nb-beams
788 for ss from
(* 2 min-nb-beams
) by
2
789 for offset from min-nb-beams
790 do
(map-over-cluster-pairs
792 (cond ((and (>= (rbeams e1
) beams
) (>= (lbeams e2
) beams
))
795 (make-rectangle* (+ (final-absolute-element-xoffset e1
) right
) -
10000
796 (+ (final-absolute-element-xoffset e2
) right
) 10000))))
797 ((>= (rbeams e1
) beams
)
800 (make-rectangle* (+ (final-absolute-element-xoffset e1
) right
) -
10000
801 (+ (final-absolute-element-xoffset e1
) right
(score-pane:staff-step
2)) 10000))))
802 ((>= (lbeams e2
) beams
)
805 (make-rectangle* (+ (final-absolute-element-xoffset e2
) right
(score-pane:staff-step -
2)) -
10000
806 (+ (final-absolute-element-xoffset e2
) right
) 10000))))
809 (with-drawing-options (pane :clipping-region region
)
810 (score-pane:draw-beam pane
811 (+ (final-absolute-element-xoffset (car elements
)) right
) (- ss1 ss
) (+ offset1 offset
)
812 (+ (final-absolute-element-xoffset (car (last elements
))) right
) (- ss2 ss
) (+ offset2 offset
))))))
813 (score-pane:with-notehead-left-offsets
(left down
)
814 (declare (ignore down
))
815 (loop repeat min-nb-beams
818 do
(score-pane:draw-beam pane
819 (+ (final-absolute-element-xoffset (car elements
)) left
) (+ ss1 ss
) (- offset1 offset
)
820 (+ (final-absolute-element-xoffset (car (last elements
))) left
) (+ ss2 ss
) (- offset2 offset
)))
821 (let ((region +nowhere
+))
822 (loop for beams from
(1+ min-nb-beams
) to max-nb-beams
823 for ss from
(* 2 min-nb-beams
) by
2
824 for offset from min-nb-beams
825 do
(map-over-cluster-pairs
827 (cond ((and (>= (rbeams e1
) beams
) (>= (lbeams e2
) beams
))
830 (make-rectangle* (+ (final-absolute-element-xoffset e1
) left
) -
10000
831 (+ (final-absolute-element-xoffset e2
) left
) 10000))))
832 ((>= (rbeams e1
) beams
)
835 (make-rectangle* (+ (final-absolute-element-xoffset e1
) left
) -
10000
836 (+ (final-absolute-element-xoffset e1
) left
(score-pane:staff-step
2)) 10000))))
837 ((>= (lbeams e2
) beams
)
840 (make-rectangle* (+ (final-absolute-element-xoffset e2
) left
(score-pane:staff-step -
2)) -
10000
841 (+ (final-absolute-element-xoffset e2
) left
) 10000))))
844 (with-drawing-options (pane :clipping-region region
)
845 (score-pane:draw-beam pane
846 (+ (final-absolute-element-xoffset (car elements
)) left
) (+ ss1 ss
) (- offset1 offset
)
847 (+ (final-absolute-element-xoffset (car (last elements
))) left
) (+ ss2 ss
) (- offset2 offset
))))))))
848 (loop for element in elements do
849 (draw-element pane element nil
))))))
851 (defun draw-the-cursor (pane cursor cursor-element last-note
)
852 (let* ((staff (car (staves (layer cursor
))))
854 (sy (system-y-position bar
))
855 (yoffset (- (gsharp-drawing::staff-yoffset staff
))))
856 (let ((region (pane-viewport-region pane
)))
858 ;; FIXME: adjusting the viewport at this point leads to ugly
859 ;; jumps in the display when going across pages, as the page
860 ;; is first laid out and drawn, then the viewport is moved.
861 ;; If we instead cleared the pane, laid out the page, adjusted
862 ;; the viewport, and finally drew the page (and cursor) then
863 ;; that jump would probably go away.
865 ;; FIXME: this calculation only takes account of the centre of
866 ;; the cursor. Refactor this whole DRAW-THE-CURSOR function
867 ;; so that it's easy to take account of the vertical extent of
869 (unless (< (bounding-rectangle-min-y region
)
871 (bounding-rectangle-max-y region
))
872 (let ((maxy (- (bounding-rectangle-max-y pane
) (bounding-rectangle-height region
))))
873 (scroll-extent pane
0 (max 0 (min maxy
874 (- sy
(floor (bounding-rectangle-height region
) 2)))))))))
876 (flet ((draw-cursor (x)
877 (if (typep staff
'fiveline-staff
)
878 (let* ((clef (clef cursor
))
879 (bottom-line (bottom-line clef
))
880 (lnote-offset (score-pane:staff-step
(- last-note bottom-line
))))
882 x
(+ sy
(- (+ (score-pane:staff-step
12) yoffset
)))
883 x
(+ sy
(- (+ (score-pane:staff-step -
4) yoffset
)))
886 (- x
1) (+ sy
(- (+ (score-pane:staff-step -
3.4) yoffset lnote-offset
)))
887 (- x
1) (+ sy
(- (+ (score-pane:staff-step
3.6) yoffset lnote-offset
)))
890 (+ x
1) (+ sy
(- (+ (score-pane:staff-step -
3.4) yoffset lnote-offset
)))
891 (+ x
1) (+ sy
(- (+ (score-pane:staff-step
3.6) yoffset lnote-offset
)))
893 (progn (draw-line* pane
894 (+ x
1) (+ sy
(- (+ (score-pane:staff-step
2) yoffset
)))
895 (+ x
1) (+ sy
(- (+ (score-pane:staff-step -
2) yoffset
)))
898 (- x
1) (+ sy
(- (+ (score-pane:staff-step
2) yoffset
)))
899 (- x
1) (+ sy
(- (+ (score-pane:staff-step -
2) yoffset
)))
901 (score-pane:with-staff-size
(gsharp-buffer::rastral-size
(buffer cursor
))
902 (let* ((x (final-absolute-measure-xoffset bar
))
903 (width (final-width bar
))
904 (elements (elements bar
)))
905 (if (null cursor-element
)
906 (draw-cursor (/ (+ (if (null elements
)
908 (final-absolute-element-xoffset (car (last elements
))))
910 (loop for element in elements
911 and xx
= x then
(final-absolute-element-xoffset element
) do
912 (when (eq element cursor-element
)
913 (draw-cursor (/ (+ xx
(final-absolute-element-xoffset element
)) 2))))))))))
915 (defun compute-bar-coordinates (bar x y width
)
916 (setf (system-y-position bar
) y
917 (final-absolute-measure-xoffset bar
) x
918 (final-width bar
) width
))
920 (defmethod draw-bar (pane (bar melody-bar
))
921 (score-pane:with-vertical-score-position
922 (pane (system-y-position bar
))
923 (loop for group in
(beam-groups (elements bar
))
924 do
(draw-beam-group pane group
))))
926 (defmethod draw-bar (pane (bar lyrics-bar
))
927 (score-pane:with-vertical-score-position
928 (pane (system-y-position bar
))
929 (let ((elements (elements bar
)))
930 (loop for element in elements
931 do
(draw-element pane element
)))))
933 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
937 (defgeneric draw-element
(pane element
&optional flags
))
939 (defmethod draw-element :around
(pane element
&optional flags
)
941 (dolist (annotation (annotations element
))
942 (draw-element-annotation pane element annotation
)))
944 (defgeneric draw-element-annotation
(pane element annotation
)
945 (:method
(pane element annotation
)
946 (warn "unknown annotation ~S for ~S" annotation element
)))
948 ;;; FIXME: these methods work and have the right vertical behaviour;
949 ;;; the horizontal centering of the dot and the tenuto mark are all
951 (defmethod draw-element-annotation
952 (pane (element cluster
) (annotation (eql :staccato
)))
953 (let ((direction (final-stem-direction element
))
954 (x (final-absolute-element-xoffset element
)))
955 (if (eq direction
:up
)
956 (score-pane:with-vertical-score-position
(pane (bot-note-staff-yoffset element
))
957 (score-pane:with-notehead-right-offsets
(dx dy
)
958 (score-pane:with-notehead-left-offsets
(ddx ddy
)
959 (let ((pos (- (bot-note-pos element
) 2)))
960 (when (and (<= 0 pos
) (evenp pos
))
962 (score-pane:draw-dot pane
(+ x
(/ (+ dx ddx
) 2)) pos
)))))
963 (score-pane:with-vertical-score-position
(pane (top-note-staff-yoffset element
))
964 (score-pane:with-notehead-right-offsets
(dx dy
)
965 (score-pane:with-notehead-left-offsets
(ddx ddy
)
966 (let ((pos (+ (top-note-pos element
) 2)))
967 (when (and (<= pos
8) (evenp pos
))
969 (score-pane:draw-dot pane
(+ x
(/ (+ dx ddx
) 2)) pos
))))))))
971 (defmethod draw-element-annotation
972 (pane (element cluster
) (annotation (eql :tenuto
)))
973 (let ((direction (final-stem-direction element
))
974 (x (final-absolute-element-xoffset element
)))
975 (if (eq direction
:up
)
976 (score-pane:with-vertical-score-position
(pane (bot-note-staff-yoffset element
))
977 (score-pane:with-notehead-right-offsets
(dx dy
)
978 (score-pane:with-notehead-left-offsets
(ddx ddy
)
979 (let ((pos (- (bot-note-pos element
) 2)))
980 (when (and (<= 0 pos
) (evenp pos
))
982 (draw-rectangle* pane
(+ x ddx
) (1- (score-pane:staff-step
(- pos
)))
983 (+ x dx
) (1+ (score-pane:staff-step
(- pos
))))))))
984 (score-pane:with-vertical-score-position
(pane (top-note-staff-yoffset element
))
985 (score-pane:with-notehead-right-offsets
(dx dy
)
986 (score-pane:with-notehead-left-offsets
(ddx ddy
)
987 (let ((pos (+ (bot-note-pos element
) 2)))
988 (when (and (<= pos
8) (evenp pos
))
990 (draw-rectangle* pane
(+ x ddx
) (1- (score-pane:staff-step
(- pos
)))
991 (+ x dx
) (1+ (score-pane:staff-step
(- pos
)))))))))))
993 (defmethod note-difference ((note1 note
) (note2 note
))
994 (- (pitch note1
) (pitch note2
)))
996 (defun draw-ledger-lines (pane x notes
)
997 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff (car notes
))))
998 (let* ((positions (mapcar #'note-position notes
))
999 (top-note-pos (reduce #'max positions
))
1000 (bot-note-pos (reduce #'min positions
)))
1001 (loop for pos from
10 to top-note-pos by
2
1002 do
(score-pane:draw-ledger-line pane x pos
))
1003 (loop for pos from -
2 downto bot-note-pos by
2
1004 do
(score-pane:draw-ledger-line pane x pos
)))))
1006 (defun flags-drawn-p (element)
1007 (let ((nb (max (rbeams element
) (lbeams element
))))
1008 (and (> nb
0) (eq (notehead element
) :filled
) nb
)))
1010 (defun draw-flags (pane element x direction pos
)
1011 (let ((nb (flags-drawn-p element
)))
1013 (if (eq direction
:up
)
1014 (score-pane:with-notehead-right-offsets
(right up
)
1015 (declare (ignore up
))
1016 (score-pane:draw-flags-down pane nb
(+ x right
) pos
))
1017 (score-pane:with-notehead-left-offsets
(left down
)
1018 (declare (ignore down
))
1019 (score-pane:draw-flags-up pane nb
(+ x left
) pos
))))))
1021 (defun draw-dots (pane nb-dots x dot-xoffset dot-pos
)
1023 (let ((staff-step (score-pane:staff-step
1)))
1024 (loop repeat nb-dots
1025 for xx from dot-xoffset by staff-step do
1026 (score-pane:draw-dot pane xx dot-pos
)))))
1028 (defun draw-note (pane note notehead nb-dots x pos dot-xoffset dot-pos
)
1029 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff note
)))
1030 (score-pane:draw-notehead pane notehead x pos
)
1031 (when (final-accidental note
)
1032 (score-pane:draw-accidental pane
(final-accidental note
) (final-absolute-accidental-xoffset note
) pos
))
1033 (draw-dots pane nb-dots x dot-xoffset dot-pos
)))
1035 (defparameter *main-selected-note-colour
* +blue-violet
+)
1036 (defun draw-notes (pane notes dots notehead dot-xoffset
)
1037 (loop for note in notes
1039 (with-drawing-options (pane :ink
(if (and (gsharp::cur-notep
)
1040 (eq note
(gsharp::cur-note
))
1041 (not (typep pane
'clim-postscript
::postscript-stream
)))
1042 *main-selected-note-colour
* +black
+))
1043 (draw-note pane note notehead dots
(final-absolute-note-xoffset note
) (note-position note
) dot-xoffset
(final-absolute-dot-ypos note
)))))
1045 (defun element-has-suspended-notes (element)
1046 (not (apply #'= (mapcar #'final-relative-note-xoffset
(notes element
)))))
1048 ;;; draw a cluster. The stem direction and the stem position have
1049 ;;; already been computed.
1050 ;;; 1. Group notes by staff.
1051 ;;; 2. Draw the notes in each group
1052 ;;; 3. If necessary, draw ledger lines for notes in a group
1053 ;;; 4. Draw the stem, if any
1054 (defmethod draw-element (pane (element cluster
) &optional
(flags t
))
1055 (with-new-output-record (pane)
1056 (unless (null (notes element
))
1057 (with-output-as-presentation (pane element
'cluster
)
1058 (let* ((direction (final-stem-direction element
))
1059 (stem-pos (final-stem-position element
))
1060 (stem-yoffset (final-stem-yoffset element
))
1061 (groups (group-notes-by-staff (notes element
)))
1062 (x (final-absolute-element-xoffset element
))
1064 (let ((basic-xoffset (+ (score-pane:staff-step
2)
1065 (reduce #'max
(mapcar #'final-absolute-note-xoffset
(notes element
))))))
1066 (if (and flags
(eq direction
:up
) (flags-drawn-p element
))
1067 (max basic-xoffset
(+ (score-pane:staff-step
4) x
))
1070 (score-pane:with-vertical-score-position
(pane stem-yoffset
)
1071 (draw-flags pane element x direction stem-pos
)))
1072 (loop for group in groups do
1073 (draw-notes pane group
(dots element
) (notehead element
) dot-xoffset
)
1074 (draw-ledger-lines pane x group
))
1075 (unless (member (notehead element
) '(:whole
:breve
))
1076 (if (eq direction
:up
)
1077 (score-pane:draw-right-stem
1079 (- (bot-note-staff-yoffset element
) (score-pane:staff-step
(bot-note-pos element
)))
1080 (- stem-yoffset
(score-pane:staff-step stem-pos
)))
1081 (score-pane:draw-left-stem
1083 (- (top-note-staff-yoffset element
) (score-pane:staff-step
(top-note-pos element
)))
1084 (- stem-yoffset
(score-pane:staff-step stem-pos
))))))))))
1086 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1090 (defmethod draw-element (pane (element rest
) &optional
(flags t
))
1091 (declare (ignore flags
))
1092 (let ((x (final-absolute-element-xoffset element
)))
1093 (with-output-as-presentation (pane element
'rest
)
1094 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff element
)))
1095 (score-pane:draw-rest pane
(undotted-duration element
) x
(staff-pos element
))
1096 (draw-dots pane
(dots element
) x
(+ x
(score-pane:staff-step
2)) (1+ (staff-pos element
)))))))
1098 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1102 (defmethod draw-element (pane (element lyrics-element
) &optional
(flags t
))
1103 (declare (ignore flags
))
1104 (let ((x (final-absolute-element-xoffset element
)))
1105 (score-pane:with-vertical-score-position
(pane (staff-yoffset (staff element
)))
1106 (with-text-family (pane :serif
)
1107 (draw-text* pane
(map 'string
'code-char
(text element
))
1108 x
0 :align-x
:center
)))))
1110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1112 ;;; Key signature element
1114 (defmethod draw-element (pane (keysig key-signature
) &optional flags
)
1115 (declare (ignore flags
))
1116 (let ((staff (staff keysig
))
1117 (old-keysig (keysig keysig
))
1118 (x (final-absolute-element-xoffset keysig
)))
1119 (score-pane:with-vertical-score-position
(pane (staff-yoffset staff
))
1120 (let ((yoffset (b-position (clef keysig
))))
1121 (loop with advance
= 0
1122 for pitch in
'(6 2 5 1 4 0 3)
1123 for line in
'(0 3 -
1 2 -
2 1 -
3)
1124 when
(and (eq (aref (alterations old-keysig
) pitch
) :flat
)
1125 (not (eq (aref (alterations keysig
) pitch
)
1127 do
(score-pane:draw-accidental
1128 pane
:natural
(+ x advance
) (+ line yoffset
))
1129 and do
(incf advance
(score-pane:staff-step
2))
1130 finally
(incf x
(if (= advance
0) 0 (+ advance
(score-pane:staff-step
2))))))
1131 (let ((yoffset (f-position (clef keysig
))))
1132 (loop with advance
= 0
1133 for pitch in
'(3 0 4 1 5 2 6)
1134 for line in
'(0 -
3 1 -
2 -
5 -
1 -
4)
1135 when
(and (eq (aref (alterations old-keysig
) pitch
) :sharp
)
1136 (not (eq (aref (alterations keysig
) pitch
) :sharp
)))
1137 do
(score-pane:draw-accidental pane
:natural
(+ x advance
) (+ line yoffset
))
1138 and do
(incf advance
(score-pane:staff-step
2))
1139 finally
(incf x
(if (= advance
0) 0 (+ advance
(score-pane:staff-step
2))))))
1141 (let ((yoffset (b-position (clef keysig
))))
1142 (loop for pitch in
'(6 2 5 1 4 0 3)
1143 for line in
'(0 3 -
1 2 -
2 1 -
3)
1144 for x from x by
(score-pane:staff-step
2)
1145 while
(eq (aref (alterations keysig
) pitch
) :flat
)
1146 do
(score-pane:draw-accidental pane
:flat x
(+ line yoffset
))))
1147 (let ((yoffset (f-position (clef keysig
))))
1148 (loop for pitch in
'(3 0 4 1 5 2 6)
1149 for line in
'(0 -
3 1 -
2 -
5 -
1 -
4)
1150 for x from x by
(score-pane:staff-step
2.5)
1151 while
(eq (aref (alterations keysig
) pitch
) :sharp
)
1152 do
(score-pane:draw-accidental pane
:sharp x
(+ line yoffset
)))))))
1154 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1156 ;;; Time signature element
1158 (defmethod draw-element (pane (timesig time-signature
) &optional
(flags t
))
1159 (declare (ignore flags
))
1160 (let ((staff (staff timesig
))
1161 (x (final-absolute-element-xoffset timesig
)))
1162 (score-pane:with-vertical-score-position
(pane (staff-yoffset staff
))
1163 (dolist (component (time-signature-components timesig
))
1164 (score-pane:draw-time-signature-component pane component x
)))))
1166 (defmethod draw-element (pane (clef clef
) &optional
(flags t
))
1167 (declare (ignore flags
))
1168 (let ((x (final-absolute-element-xoffset clef
)))
1169 (score-pane:draw-clef pane
(name clef
) x
(lineno clef
))))
1171 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1173 ;;; Time signature element
1175 (defmethod draw-element (pane (timesig time-signature
) &optional
(flags t
))
1176 (declare (ignore flags
))
1177 (let ((staff (staff timesig
))
1178 (x (final-absolute-element-xoffset timesig
)))
1179 (score-pane:with-vertical-score-position
(pane (staff-yoffset staff
))
1180 (dolist (component (time-signature-components timesig
))
1181 (score-pane:draw-time-signature-component pane component x
)))))