2 %% ========================================================
3 % blackmensural.ly – Black Mensural Notation for Lilypond
4 % Version 0.1, January 2011
6 % Released under the GNU General Public License
7 %% ========================================================
9 %% ===============================================
10 % Context type definitions
11 %% ===============================================
13 %% some settings on score level
14 mensuralTightSetting
= {
15 \override Score
.SpacingSpanner
#'base-shortest-duration
= #(ly
:make-moment
1 2)
16 \override Score
.SpacingSpanner
#'common-shortest-duration
= #(ly
:make-moment
1 2)
17 \override Score
.SpacingSpanner
#'shortest-duration-space
= #1.5
18 \override Score
.SpacingSpanner
#'spacing-increment
= #0.05
19 \override NoteSpacing
#'stem-spacing-correction
= #0.0
20 \override Score
.BarLine
#'stencil
= #empty-stencil
21 \override Score
.BarNumber
#'stencil
= #empty-stencil
28 \name BlackMensuralVoice
%% adapted from MensuralVoice definition
32 \override Stem
#'transparent
= ##t
33 \override Flag
#'transparent
= ##t
34 \override Beam
#'transparent
= ##t
35 \override Accidental
#'stencil
= #empty-stencil
36 \override Accidental
#'font-size
= #-
2
37 \override Accidental
#'X-offset
= #-
2
41 \name BlackMensuralStaff
%% adapted from MensuralStaff definition
44 \defaultchild BlackMensuralVoice
45 \accepts BlackMensuralVoice
46 \description "Same as @code{Staff} context, except that it is
47 accommodated for typesetting a piece in mensural style."
49 \consists "Custos_engraver"
51 %% We can not remove Bar_engraver; otherwise clefs and custodes will
52 %% not show up any more among other line breaking issues.
53 %% Instead, we make the grob invisible
54 \override BarLine
#'stencil
= #empty-stencil
55 %\override BarLine #'transparent = ##t
57 \override StaffSymbol
#'thickness
= #0.6
58 \override KeySignature
#'font-size
= #-
2
59 \override TimeSignature
#'font-size
= #-
2
61 %% Choose c clef on 3rd line as default.
62 clefGlyph
= #"clefs.vaticana.do"
63 middleCClefPosition
= #0
68 %% Select mensural style font.
69 \override NoteHead
#'style
= #'mensural
% will be further overridden
70 \override TimeSignature
#'style
= #'mensural
71 \override KeySignature
#'style
= #'mensural
72 \override Accidental
#'glyph-name-alist
= #alteration-mensural-glyph-name-alist
73 \override Custos
#'style
= #'mensural
74 \override Custos
#'neutral-position
= #3
75 \override Custos
#'neutral-direction
= #DOWN
76 \override Dots
#'font-size
= #-
3
78 %% Accidentals are valid only once (same as
79 %% #(set-accidental-style 'forget))
81 autoAccidentals
= #`
(Staff
,(make-accidental-rule
'same-octave -
1))
82 autoCautionaries
= #'()
83 printKeyCancellation
= ##f
89 \accepts BlackMensuralStaff
93 %% ===============================================
94 % declaring some custom properties
95 %% ===============================================
97 %% custom NoteHead property, for \override-able notehead style definitions
98 #(set-object-property
! 'mensural
_glyphs
'backend-type? list?
)
99 #(set-object-property
! 'mensural
_glyphs
'backend-doc
"current set of mensural display settings")
101 %% custom Voice context property, needed for ligature assembly
102 #(set-object-property
! 'mensural
_ligature
_queue
'backend-type? list?
)
103 #(set-object-property
! 'mensural
_ligature
_queue
'backend-doc
"current set of note grobs to be assembled into a ligature")
104 #(set-object-property
! 'mensural
_accidentals
_queue
'backend-type? list?
)
105 #(set-object-property
! 'mensural
_accidentals
_queue
'backend-doc
"current set of accidentals to be collected for a ligature")
107 %% custom entry in an event's 'tweak property
108 #(set-object-property
! 'mensural
_tags
'backend-type? list?
)
109 #(set-object-property
! 'mensural
_tags
'backend-doc
"various tags set in a notehead tweak to control mensural note display")
112 %% ==============================================
113 % convenience definition - empty stencil
114 %% ==============================================
115 #(define-public empty-stencil
116 (ly
:make-stencil
(list
'embedded-ps
"") '(0 . 0) '(0 . 0)))
118 %% ==============================================
119 % convenience shortcut: set a custom flag in our
120 % "mensural_tags" tweak property
121 %% ==============================================
122 #(define
(set-mensural-flag
! note key val
)
123 (let
* ((tweaks
(ly
:music-property note
'tweaks
))
124 (flags
(if tweaks
(assq-ref tweaks
'mensural
_tags
) '())))
125 (if
(not tweaks
) (set
! tweaks
'()))
126 (if
(not flags
) (set
! flags
'()))
127 (set
! flags
(assq-set
! flags key val
))
128 (set
! tweaks
(assq-set
! tweaks
'mensural
_tags flags
))
129 (ly
:music-set-property
! note
'tweaks tweaks
)
131 #(define
(get-mensural-flag note key
)
132 (let
* ((flags
(get-tweak note
'mensural
_tags
)))
133 (assq-ref flags key
)))
134 #(define
(set-tweak
! event key val frc
)
135 (let
* ((tw
(ly
:music-property event
'tweaks
))
137 (if
(or frc
(not old
))
139 (set
! tw
(assq-set
! tw key val
))
140 (ly
:music-set-property
! event
'tweaks tw
)))
142 #(define
(get-tweak event key
)
144 (tw
(if
(ly
:music? event
) (ly
:music-property event
'tweaks
) (ly
:event-property event
'tweaks
))))
147 #(define
(flag-notes
! key val onlynotes music
)
148 (let
((test
(if onlynotes
'note-event
'rhythmic-event
)))
152 (if
(memq test
(ly
:music-property event
'types
))
153 (set-mensural-flag
! event key val
)))
157 #(define
(tweak-notes
! key val onlynotes music
)
158 (let
((test
(if onlynotes
'note-event
'rhythmic-event
)))
162 (if
(memq test
(ly
:music-property event
'types
))
163 (set-tweak
! event key val onlynotes
)))
167 flagNotes
= #(define-music-function
(parser location key val music
) (symbol? boolean? ly
:music?
)
168 (flag-notes
! key val
#t music
))
171 %% =================================================
172 % Mark an event as explicitly imperfect. Needed only
173 % for imperfect longa rests in perfect modus
174 %% =================================================
175 imperfect
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
176 (flag-notes
! 'imperfect
#t
#f mymusic
))
177 %% =================================================
178 % Make a row of "currentes" ("coniunctura") rhombic
179 % noteheads inside a ligature
180 %% =================================================
181 currentes
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
182 (flag-notes
! 'currens
#t
#t mymusic
))
183 %% =================================================
184 % Mark whether a final ascending L in a ligature
185 % should be folded in
186 %% =================================================
187 pes
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
188 (flag-notes
! 'pes
#t
#t mymusic
))
189 nopes
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
190 (flag-notes
! 'nopes
#t
#t mymusic
))
191 %% =================================================
192 % Mark various options for vertical stems
193 %% =================================================
194 virga
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
195 (flag-notes
! 'altvirga
#t
#t mymusic
))
196 novirga
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
197 (flag-notes
! 'novirga
#t
#t mymusic
))
198 %% =================================================
199 % Mark whether two notes in a ligature
200 % should be displayed as an oblique
201 %% =================================================
202 obliqua
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
203 (flag-notes
! 'obliqua
#t
#t mymusic
))
204 noobliqua
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
205 (flag-notes
! 'noobliqua
#t
#t mymusic
))
208 %% =================================================
209 % Mark one or several notes with a special stencil
210 % Needed for Italian trecento and French "mannered"
211 % notation, e.g. various "semibreves signatae".
212 %% =================================================
213 signata
= #(define-music-function
(parser location stencilfunction mymusic
) (ly
:stencil? ly
:music?
)
214 (make-music
'SequentialMusic
216 (make-music ;
= \override NoteHead
#'stencil
= #stencilfunction
218 'context-type
'Bottom
223 'grob-property-path
(list
'stencil
)
224 'grob-value stencilfunction
))
228 'context-type
'Bottom
233 'grob-property-path
(list
'stencil
))))))
235 %% alternative version using a 'stencil tweak, but
236 %% the override seems to get better horizontal spacing.
237 signataB
= #(define-music-function
(parser location stencil mymusic
) (ly
:stencil? ly
:music?
)
238 (tweak-notes
! 'stencil stencil
#t mymusic
))
240 %% ==================================================
242 %% ==================================================
243 coloratio
= #(define-music-function
(parser location col mymusic
) (symbol? ly
:music?
)
245 (music-map ; iterate through all the music
248 ;; for notes
: use our custom color flag
249 ((memq
'note-event
(ly
:music-property event
'types
))
250 (set-mensural-flag
! event
'color col
))
251 ;; for rests
: use the standard color mechanism
252 ((memq
'rest-event
(ly
:music-property event
'types
))
255 (set-tweak
! event
'color
(rgb-color
0.7 0 0) #f)))))
260 %% ==============================================
262 %% ==============================================
264 %% =========================================================
265 % This is the music function that will be called during
266 % input processing. It does no processing of its own, but
267 % only adds "applyContext" callbacks at the beginning and
268 % end of the ligature in the input stream. These, together
269 % with the "applyOutput" callbacks inserted by the
270 % \mensura command, will later get executed during translation.
271 %% =========================================================
272 ligatura
= #(define-music-function
(parser location mymusic
) (ly
:music?
)
277 ;; call to start
_ligature callback
280 'context-type
'Bottom
281 'procedure start
_ligature
)
284 ;; call to finish
_ligature callback
287 'context-type
'Bottom
288 'procedure finish
_ligature
)
290 ;; ugly workaround to get horizontal spacing right
:
291 ;; insert an invisible breathing mark
as a dummy grob
294 'context-type
'Bottom
297 'symbol
'BreathingSign
298 'grob-property-path
'(text
)
305 (list
(make-music
(quote BreathingEvent
))))
309 %% =========================================================
310 % This procedure will be called for every grob in the Voice
311 % context during the translation phase, through ApplyOutput
312 % calls (placed throughout the music by the \mensura command).
313 % It checks whether we are in a ligature, and if yes, places
314 % relevant grobs in a queue to be processed at the end of the
315 % ligature. It also queries each grob's X-extent property,
316 % to force Lilypond to calculate the stencil widths properly.
317 %% =========================================================
318 #(define
(mensural
_processing grob origin context
)
319 (let
* ((ifs
(ly
:grob-interfaces grob
))
320 (cause
(ly
:grob-property grob
'cause
))
321 (type
(cdr
(assq
'name
(ly
:grob-property grob
'meta
))))
322 (queue
(ly
:context-property
324 'mensural
_ligature
_queue
))
325 (inligature
(if queue
#t
#f))
327 ;
(display
(format
#f "We got a ~a\n" type
))
330 ((eq? type
'NoteHead
)
332 (ly
:context-set-property
!
334 'mensural
_ligature
_queue
335 (append queue
(list grob
)))))
337 ;; discard the standard dot grob
, but mark the parent note with
a flag
338 ;; so that the ligature creation procedure can add it
as part of the ligature stencil
.
339 (let
* ((lastnote
(car
(last-pair queue
)))
340 (lastflags
(if lastnote
(ly
:grob-property lastnote
'mensural
_tags
))))
341 (ly
:grob-set-property
! lastnote
'mensural
_tags
342 (assq-set
! lastflags
'punctum
#t
))
343 (ly
:grob-set-property
! grob
'stencil empty-stencil
)))
344 ((eq? type
'Accidental
)
345 ;; put ligature accidentals into
a queue of their own
.
346 (let
* ((stencil
(ly
:grob-property grob
'stencil
))
347 (position
(ly
:grob-property cause
'Y-offset
))
348 (accqueue
(ly
:context-property context
'mensural
_accidentals
_queue
)))
349 (if
(eq? accqueue
#f) (set
! accqueue
'()))
350 (ly
:grob-set-property
! grob
'stencil empty-stencil
)
351 (ly
:context-set-property
!
353 'mensural
_accidentals
_queue
354 (append accqueue
(list
(cons position stencil
)))))))
356 ;; need to do this for every note head
, or Lilypond won
't figure out
357 ;; the customized X-width in time
.
358 (if
(or
(eq? type
'NoteHead
) (eq? type
'Rest
))
359 (ly
:grob-property grob
'X-extent
))
363 % ===========================================
364 % convenience function: use explanatory
365 % symbols rather than duration logs for
367 % ===========================================
368 #(define
(duration
_log
_to
_note
_symbol log
)
380 #(define
(start
_ligature context
)
381 (ly
:context-set-property
!
383 'mensural
_ligature
_queue
386 %% ========================================================
387 % This procedure will be called after the last notehead
388 % grob of each ligature, through ApplyContext.
389 % It recovers the stored grobs from the custom
390 % context property 'mensural_ligature_queue, calculates
391 % a single postscript stencil for the ligature, assigns
392 % this stencil to one of the note grobs, and makes the
394 %% =========================================================
395 #(define
(finish
_ligature context
)
396 (let
* ((findcontext
(ly
:context-property-where-defined context
'mensural
_ligature
_queue
))
397 (notes
(if
(ly
:context? findcontext
)
398 (ly
:context-property findcontext
'mensural
_ligature
_queue
)
400 (imaxall
(-
(length notes
) 1))
402 (imiddle
(truncate
(/ imax
2))) ; this is the note we
'll assign our customized stencil to
.
403 (ymiddle
(ly
:grob-property
(list-ref notes imiddle
) 'Y-offset
))
405 (ypositions
(map
(lambda
(gr
) (ly
:grob-property gr
'Y-offset
)) notes
) )
406 (vals
(map
(lambda
(gr
) (duration
_log
_to
_note
_symbol
(ly
:grob-property gr
'duration-log
))) notes
))
407 (flags
(map
(lambda
(gr
) (ly
:grob-property gr
'mensural
_tags
)) notes
))
409 (glyphsettings
(ly
:grob-property
(car notes
) 'mensural
_glyphs
))
410 (foldpes
(assq-ref glyphsettings
'foldpes
))
411 (basecolor
(or
(assq-ref glyphsettings
'color
) 'black
))
418 (rightX
(* notewidth
(+ imaxall
1)))
420 (firstpos
(car ypositions
))
423 (list-ref ypositions i
)))
426 (set
! postscript
(string-append postscript ps
))))
430 (add-postscript
(format
#f " ~a ~a translate " dX
dY
))
431 (set
! curX
(+ curX
dX
)))))
434 (+
(* adiff adiff
(/ 1.0 12.0)) (* adiff
(/ 7.0 12.0)) (/ 4.0 3.0))))
437 ; we need at least two notes to proceed beyond here
.
441 ;check how many of our notes are regular ligature notes
,
442 ;and how many are trailing currentes or plicae
444 ((or
(> i imaxall
) (< imax imaxall
)))
445 (if
(assq-ref
(list-ref flags i
) 'currens
)
447 (if
(assq-ref
(list-ref flags i
) 'plica
)
450 ; also check whether the preceding note is manually forced to be folded in
453 (assq-ref
(list-ref flags
(- i
1)) 'pes
))
455 (set
! foldpes
#f)))))
457 ;
(display
(format
#f "Finishing ligature with ~a (~a) notes.\n" (+
1 imaxall
) (+
1 imax
)))
459 ;;
===========================
460 ;; main loop through note list
461 ;;
===========================
462 (do
((i imaxall
(1- i
)) ;backwards loop-index variable
463 (nextobliqua
#f nextobliqua
)) ; flag to indicate we are inside an obliqua
468 (atpenult
(= i
(- imax
1)))
470 (atverylast
(= i imaxall
))
471 (inmiddle
(and
(> i
0) (< i imax
)))
473 (previous
(if atfirst
#f (list-ref notes
(- i
1))))
474 (prevval
(if atfirst
#f (list-ref vals
(- i
1))))
475 (prevpos
(if atfirst firstpos
(list-ref ypositions
(- i
1))))
476 (prevflag
(if atfirst
#f (list-ref flags
(- i
1))))
478 (this
(list-ref notes i
))
479 (thisval
(list-ref vals i
))
480 (thispos
(list-ref ypositions i
))
481 (thisflag
(list-ref flags i
))
483 (next
(if atverylast
#f (list-ref notes
(+ i
1))))
484 (nextval
(if atverylast
#f (list-ref vals
(+ i
1))))
485 (nextpos
(if atverylast
#f (list-ref ypositions
(+ i
1))))
486 (nextflag
(if atverylast
#f (list-ref flags
(+ i
1))))
488 (descending
(if atverylast
(< thispos prevpos
) (< nextpos thispos
)))
489 (descended
(if atfirst descending
(< thispos prevpos
)))
491 (singlebr
(and atfirst atlast
(eq? thisval
'br
)))
492 (singlelg
(and atfirst atlast
(eq? thisval
'lg
)))
494 (thiscolor
(or
(assq-ref thisflag
'color
) basecolor
))
495 (currens
(assq-ref thisflag
'currens
))
497 (obliquaB
(and
(not atfirst
)
499 (and atlast ; obligatory sine-perf obliqua
501 (not
(and
(= i
1)(eq? prevval
'sb
)))
503 (assq-ref prevflag
'obliqua
) ; manually set obliqua
504 (and
(assq-ref nextflag
'pes
) ;
507 (not
(assq-ref prevflag
'noobliqua
))
508 (not
(and
(>= i
2) (assq-ref
(list-ref flags
(- i
2)) 'obliqua
))))
509 (and
(= i
1) ; try to use obliqua in descending
c.opp
.prop
.
513 (not
(assq-ref thisflag
'obliqua
))
514 (not
(assq-ref prevflag
'noobliqua
))))))
515 (obliquaA nextobliqua
)
518 (and atpenult ;automatic fold-in pes in ascending cum-perf
523 (not
(eq? thisval
'sb
))
524 (not
(assq-ref nextflag
'plica
))
525 (not
(assq-ref nextflag
'nopes
)))
526 (and
(not descending
) ;manually tweaked fold-in pes
528 (not
(eq? thisval
'sb
))
529 (assq-ref nextflag
'pes
))))
531 (and atlast ;automatic fold-in pes
536 (not
(eq? prevval
'sb
))
537 (not
(assq-ref thisflag
'plica
))
538 (not
(assq-ref thisflag
'nopes
)))
539 (and
(not descended
) ;manually tweaked fold-in pes
540 (assq-ref thisflag
'pes
))))
541 (plica
(and atlast
(assq-ref thisflag
'plica
) (< imax imaxall
)))
542 (skipplica
(and atverylast
(assq-ref prevflag
'plica
)))
543 (opposita
(and atfirst
546 (online
(= 0 (modulo
(inexact-
>exact
(* 2 thispos
)) 2)))
547 (dotatside
(lambda
(x
) (cons
(+ x
0.3) 0)))
548 (dotabove
(cons
0 (if online
0.8 0.8)))
549 (processdot
(lambda
(flag offset
)
550 (if
(assq-ref flag
'punctum
)
551 (let
((y
(cdr offset
)))
553 (< linewidth
(abs
(- y
(inexact-
>exact y
))))
556 (format
#f "gsave newpath ~a ~a ~a 0 360 arc fill grestore "
557 (car offset
) y
(* 1.3 linewidth
)))))))
560 ;; connector lines and relative y positioning
562 (shift-postscript
0 (- thispos ymiddle
))
563 (shift-postscript
0 (- thispos nextpos
)))
564 (if
(or inmiddle atfirst
)
565 (let
((ydiff
(- nextpos thispos
)))
567 (shift-postscript -
0.2 0)
568 (if
(and
(not obliquaA
) (not
(assq-ref nextflag
'currens
)))
569 (add-postscript
(ps
_virga
0 ydiff thiscolor
))))
572 ;; longa and plica strokes
(virgae
)
575 (let
((plicadiff
(-
(posref
(+ i
1)) (posref i
))))
577 (let
* ((plicadir
(if
(= plicadiff
0) 1 (/ plicadiff
(abs plicadiff
))))
581 (alternate
(assq-ref thisflag
'altvirga
)))
584 ;use additional plica note on the side; early-
1200s style; Apel
248f.
586 (shift-postscript
(* 0.8 notewidth
) 0)
588 (ps
_notehead
'pes thiscolor
(* plicadir -
0.8 notewidth
) (* plicadir -
0.8 noteheight
)))
589 (add-postscript
(ps
_virga
(* -
0.4 notewidth
) (* plicadir longplica
) thiscolor
))
590 (add-postscript
(ps
_virga
(* 0.4 notewidth
) (* plicadir longplica
) thiscolor
)))
591 (shift-postscript
(* -
0.8 notewidth
) 0)
593 ((and atfirst atlast
)
594 ;standalone nota plicata; Ars antiqua
/ Ars nova style; Apel
334
595 (let
* ((leftplica
(* plicadir
596 (if
(eq? thisval
'lg
)
597 (if
(and
(= plicadir
1) alternate
) noplica shortplica
)
598 (if alternate shortplica longplica
))))
599 (rightplica
(* plicadir
600 (if
(eq? thisval
'lg
)
603 (add-postscript
(ps
_virga
(* (- linewidth
1) notewidth
) leftplica thiscolor
))
604 (if
(!= rightplica
0)
605 (add-postscript
(ps
_virga
0 rightplica thiscolor
)))))
607 ;normal ligatura plicata; Apel
248f.
608 (add-postscript
(ps
_virga
0 (* plicadir longplica
) thiscolor
))))))))
610 ; alternative longa stroke of initial ascending
616 (assq-ref thisflag
'altvirga
))
617 (add-postscript
(ps
_virga
(- linewidth notewidth
) -
2.2 thiscolor
)))
619 ; normal longa
/maxima stroke
625 (not
(assq-ref thisflag
'obliqua
))
627 (and atlast
(not pestop
) (not descended
))
628 (and atfirst
(not descending
))
630 (let
* ((usevirga
(not
(and
(eq? thisval
'mx
) (assq-ref thisflag
'novirga
))))
631 (virga
_down
(not
(assq-ref thisflag
'altvirga
)))
633 ((and usevirga virga
_down descending
) (- nextpos thispos
))
634 ((and usevirga
(not virga
_down
) (not descending
)) (- nextpos thispos
))
636 (ylength
(+ ydiff
(if virga
_down -
2.2 2.2)))
639 (add-postscript
(ps
_virga
0 ylength thiscolor
)))))
641 ; exceptional forms
: non-paired semibreve; Apel
100
645 (not
(eq? thisval
'sb
)))
646 (let
((virga
(if
(eq? thisval
'lg
) -
1.5 1.5)))
647 (add-postscript
(ps
_virga
0 virga thiscolor
))))
649 ; end of virga condition block
659 (shift-postscript
(* -
0.1 notewidth
) 0)
660 (add-postscript
(ps
_notehead
'rhombus thiscolor notewidth
(* 1.3 notewidth
)))
661 (shift-postscript
(* -
0.7 notewidth
) 0)))
664 (let
* ((ydiff
(- nextpos thispos
))
666 (width
(obliqua-width adiff
)))
667 (set
! thisflag
(assq-set
! thisflag
'obliqua
#t
))
668 (list-set
! flags i thisflag
)
669 (add-postscript
(ps
_notehead
'obliqua thiscolor width ydiff
))
670 (processdot thisflag
(cons
0.3 (+
0.8 (* 0.3 (/ ydiff width
)))))
671 (set
! nextobliqua
#f)))
674 (let
* ((ydiff
(- thispos prevpos
))
676 (width
(obliqua-width adiff
)))
677 (shift-postscript linewidth
0)
678 (add-postscript
(ps
_notehead
'obliqua thiscolor
(* -
1 width
) (* -
1 ydiff
)))
680 (processdot thisflag
(dotatside
0))
681 (processdot thisflag
(cons -
0.3 (+
0.8 (* 0.3 (/ ydiff width
))))))
682 (shift-postscript
(-
0 width
) 0)
683 (set
! nextobliqua
#t
)))
686 (let
* ((ycorr
(if
(< (- nextpos thispos
) 1) -
0.15 0)))
687 (shift-postscript
(- linewidth
(* 0.5 notewidth
)) ycorr
)
688 (add-postscript
(ps
_notehead
692 (processdot thisflag
(dotatside
(* 0.5 notewidth
)))
693 (shift-postscript
(* -
0.5 notewidth
) (-
0 ycorr
))))
696 (let
* ((ycorr
(if
(< (- thispos prevpos
) 1) 0.15 0)))
697 (set
! thisflag
(assq-set
! thisflag
'pes
#t
))
698 (list-set
! flags i thisflag
)
699 (shift-postscript
(- linewidth
(* 0.5 notewidth
)) ycorr
)
700 (add-postscript
(ps
_notehead
'pes thiscolor notewidth noteheight
))
702 (processdot thisflag
(dotatside
(* 0.5 notewidth
)))
703 (processdot thisflag dotabove
))
704 (shift-postscript
(-
(* 0.5 notewidth
) linewidth
) (-
0 ycorr
))
707 (else ; normal quadrata shape
708 (let
* ((ismax
(eq? thisval
'mx
))
709 (w
(if ismax
(* 2.0 notewidth
) notewidth
)))
710 (shift-postscript
(- linewidth
(* 0.5 w
)) 0)
711 (add-postscript
(ps
_notehead
'quadrata thiscolor w noteheight
))
713 (processdot thisflag
(dotatside
(* 0.5 w
)))
714 (processdot thisflag dotabove
))
715 (shift-postscript
(* -
0.5 w
) 0))))
716 ;; end of notehead condition block
720 ;; cum-opp-prop
.: use initial upward stroke
722 (add-postscript
(ps
_virga
0 2.2 thiscolor
)))
729 ;;descending cum proprietate
: use initial downwards stroke
730 (add-postscript
(ps
_virga
0 -
2.2 thiscolor
)))
737 (or
(and
(eq? thisval
'lg
) (assq-ref thisflag
'altvirga
))
738 (and
(eq? thisval
'br
) (not
(assq-ref thisflag
'novirga
)))))
739 ;;rare ascending obliques
, cf
. Apel
1962: 97
740 (add-postscript
(ps
_virga
0 -
2.2 thiscolor
)))
743 )) ; end of note loop
750 (format
#f "gsave currentpoint translate ~a 0 moveto currentpoint translate ~a setlinewidth 1 setlinecap " rightX linewidth
)
755 (list
'embedded-ps postscript
)
760 (let
((accstencil empty-stencil
)
761 (accqueue
(ly
:context-property context
'mensural
_accidentals
_queue
)))
762 (if
(eq? accqueue
#f) (set
! accqueue
'()))
767 (ly
:stencil-translate-axis
(cdr entry
) (-
(car entry
) ymiddle
) 1))))
769 (if
(> (length accqueue
) 0)
771 (ly
:stencil-combine-at-edge
772 mystencil
0 -
1 accstencil
0.2)))
773 (ly
:context-set-property
! context
'mensural
_accidentals
_queue
'()))
775 ;; set the middle note
's stencil to our custom stencil;
776 ;; all other stencils to zero
779 (let
* ((thisnote
(list-ref notes i
)))
781 ;
(ly
:context-set-property
!
783 ;
'mensuralNotesQueue
784 ;
(append
(ly
:context-property context
'mensuralNotesQueue
) (list thisnote
)))
787 (ly
:grob-set-property
! thisnote
'stencil mystencil
)
788 (ly
:grob-set-property
! thisnote
'stencil empty-stencil
))))
791 (ly
:context-set-property
!
792 (ly
:context-property-where-defined context
'mensural
_ligature
_queue
)
793 'mensural
_ligature
_queue
798 %% ==============================================
800 %% ==============================================
801 %% ==============================================
802 % Top-level note shape functions
803 %% ==============================================
804 #(define-public
(make-mensural-note-stencil
805 notehead-type ; one of
'quadrata
, 'rhombus
, 'obliqua
, 'pes
806 color-type ; one of
'black
, 'white
, 'halfblack
, 'blackhollow
,
807 ;
'red
, 'halfred
, 'redhollow
809 width height ; desired dimensions
, measured in staff space
810 . additions
) ; optional list of keys defined in mensural
_flags below
811 ;
e.g. 'stem
_above
, 'flag
_above
_right etc
.
815 "gsave currentpoint translate "
816 (format
#f "~a 0 translate " (* 0.5 width
))
817 (ps
_notehead notehead-type color-type width height
)
818 (string-concatenate
(map
(lambda
(x
) (ps
_flag x color-type
)) additions
))
827 #(define-public
(ps
_notehead head-type color width height
)
828 (let
* ((contours
(assq-ref mensural
_notehead
_contour
_funcs head-type
))
829 (outerfunc
(list-ref contours
0))
830 (innerfunc
(list-ref contours
(case color
((halfblack halfwhite halfred halfgray halfhollow
) 2) (else
1))))
831 (outerps
(outerfunc width height
))
832 (innerps
(innerfunc width height
))
842 "0 setgray eofill grestore newpath "
844 "0.7 setgray fill grestore "))
851 "0 setgray eofill grestore newpath "
853 "0.7 0 0 setrgbcolor fill grestore "))
858 "0.7 0 0 setrgbcolor fill grestore "))
863 ;; turn the inner shape around so that the left half will be white and the right half black
864 "[-1 0 0 1 0 0] concat "
866 "0 setgray eofill grestore "))
867 ((white blackhollow halfwhite hollow halfhollow
)
872 "0 setgray eofill grestore "))
878 "0.7 0 0 setrgbcolor eofill grestore "))
883 (if
(eq? head-type
'obliqua
) "closepath " "")
884 "0 setgray fill grestore "))
887 #(define-public
(ps
_flag type color
)
888 (let
* ((postscript
(if
(string? type
) type
(assq-ref mensural
_flags type
)))
889 (ps
_linestyle
"1 setlinecap 0.11 setlinewidth ")
893 "0.7 0 0 setrgbcolor ")
896 (string-append ps
_linestyle ps
_color postscript
)))
899 %% ====================================================
901 %% ====================================================
902 %% We need to fix Lilypond's buggy treatment of large
903 %% mensural rests. Lilypond thinks a single three-space
904 %% line is a Mx rest, when in reality it's a perfect
905 %% Lg rest. A Mx rest is a combination of two or three
906 %% vertical lines, which may be either two-space or
908 %% ====================================================
909 #(define
(large
_rest
_stencil value modus maximodus imperfect
)
912 ((or imperfect
(eq? maximodus
#f)) 2)
915 ((and
(eq? value -
2) imperfect
) 2)
920 (prefix
(format
#f "gsave currentpoint translate newpath ~a setlinewidth 0 setlinecap 0 0 moveto " width
))
921 (psA
(format
#f "0 ~a rlineto " length
))
922 (psB
(format
#f "~a ~a rmoveto " dist
(-
0 length
)))
923 (ps
(string-append prefix psA
))
924 (xmax
(+
(* dist
(- lines
1)) (* 0.5 width
)))
928 (set
! ps
(string-append ps psB psA
)))
929 (set
! ps
(string-append ps
"stroke grestore "))
930 (ly
:make-stencil
(list
'embedded-ps ps
) (cons
(* -
0.5 width
) xmax
) (cons -
0.0 length
))))
934 % ======================================================
935 % control the vertical position of rest signs
936 % ======================================================
937 pausa
= #(define-music-function
(parser location position music
) (number? ly
:music?
)
938 (let
* ((fixed
(if
(>= position
1) #t
#f))
939 (y
(if fixed position
2)))
942 (if
(memq
'rest-event
(ly
:music-property event
'types
))
944 (set-tweak
! event
'Y-offset
(- y
3) #f)
946 (set
! y
(if
(<= y
1) 2 (- y
1))))))
953 %% ==================================================
955 % (lplica: to be called from within a ligature)
956 % takes a pair of notes, treats the second as a kind
957 % of grace note subtracting its duration from the first,
958 % and marks the first with the 'plica tag for later
960 %% ==================================================
961 lplica
= #(define-music-function
(parser location noteA noteB
) (ly
:music? ly
:music?
)
962 (let
* ((neA
(car
(ly
:music-property noteA
'elements
)))
963 (neB
(car
(ly
:music-property noteB
'elements
)))
964 (durA
(ly
:music-property neA
'duration
))
965 (durB
(ly
:music-property neB
'duration
))
966 (momA
(ly
:music-length noteA
))
967 (momB
(ly
:music-length noteB
))
968 (numA
(ly
:moment-main-numerator momA
))
969 (denA
(ly
:moment-main-denominator momA
))
970 (numB
(ly
:moment-main-numerator momB
))
971 (denB
(ly
:moment-main-denominator momB
))
972 (numC
(if
(= denA denB
)
974 (-
(* numA denB
) (* numB denA
))))
975 (denC
(if
(= denA denB
)
979 (denF
(* denC numA
)))
980 (set-mensural-flag
! neA
'plica
#t
)
981 (make-music
'SequentialMusic
983 (ly
:music-compress noteA
(ly
:make-moment numF denF
))
986 plica
= #(define-music-function
(parser location noteA noteB
) (ly
:music? ly
:music?
)
988 \ligatura { \lplica $noteA $noteB
}
991 %% ===================================================
992 % postscript definitions for note shape primitives
993 %% ===================================================
995 %% ===================================================
996 % diagonal flexa shape, ligatures
997 %% ===================================================
998 #(define
(ps
_obliqua
_outer
_side width ydiff
)
1000 ;
(display
(format
#f "width: ~a; ydiff: ~a\n" width ydiff
))
1004 [1 ~a 0 1 0 0] concat
1006 0 -0.3 0 -0.5 0 -0.3 curveto
1008 0 0.45 0 0.45 1.05 0.45 curveto "
1009 (* -
0.2 (/ ydiff
(-
(abs width
) 0.4)))
1011 (* (/ ydiff
2.0) (/ (abs width
) (-
(abs width
) 0.4)))
1014 #(define
(ps
_obliqua
_inner
_side width ydiff
)
1017 ~a 0.33 ~:*~a 0.33 ~:*~a 0.15 curveto
1019 ~:*~a -0.3 ~:*~a -0.18 1.05 -0.18 curveto "
1020 (* 0.15 (/ 1 (abs width
)))
1023 %% ===================================================
1024 % rhombus shapes (semibreves and below)
1025 %% ===================================================
1026 #(define
(ps
_rhombus
_outer
_side width height
)
1030 0 0.5 0 0.5 0.1 0.4 curveto
1032 0.5 0 0.5 0 0.45 -0.05 curveto
1034 0 -0.5 0 -0.5 -0.1 -0.4 curveto
1036 -0.5 0 -0.5 0 -0.45 0.05 curveto
1041 #(define
(ps
_rhombus
_inner
_side width height
)
1042 "[0.7 -0.1 -0.1 0.7 0 0] concat
1044 0 0.5 0 0.5 0.1 0.4 curveto
1046 0.5 0 0.5 0 0.45 -0.05 curveto
1048 0 -0.5 0 -0.5 -0.1 -0.4 curveto
1050 -0.5 0 -0.5 0 -0.45 0.05 curveto
1053 #(define
(ps
_rhombus
_half
_inner
_side width height
)
1054 "[0.7 -0.1 -0.1 0.7 0 0] concat
1058 0 0.5 lineto closepath ")
1060 %% ===================================================
1061 % quadrata shapes (brevis and above)
1062 %% ===================================================
1063 #(define
(ps
_quadrata
_outer
_side width height
)
1067 -0.5 0.48 -0.48 0.5 -0.45 0.5 curveto
1068 -0.4 0.5 -0.4 0.45 -0.25 0.45 curveto
1070 0.4 0.45 0.4 0.5 0.45 0.5 curveto
1071 0.48 0.5 0.5 0.48 0.5 0.45 curveto
1073 0.5 -0.48 0.48 -0.5 0.45 -0.5 curveto
1074 0.4 -0.5 0.4 -0.45 0.3 -0.45 curveto
1076 -0.4 -0.45 -0.4 -0.5 -0.45 -0.5 curveto
1077 -0.48 -0.5 -0.5 -0.48 -0.5 -0.45 curveto
1078 closepath " width height
))
1080 #(define
(ps
_quadrata
_inner
_side width height
)
1084 -0.5 0.46 -0.46 0.5 -0.4 0.5 curveto
1086 0.46 0.5 0.5 0.46 0.5 0.4 curveto
1088 0.5 -0.46 0.46 -0.5 0.4 -0.5 curveto
1090 -0.46 -0.5 -0.5 -0.46 -0.5 -0.4 curveto
1092 (/ (- width
(* 0.4 height
)) width
)
1095 #(define
(ps
_quadrata
_half
_inner
_side width height
)
1099 0.5 0.46 0.46 0.5 0.4 0.5 curveto
1103 0.46 -0.5 0.5 -0.46 0.5 -0.4 curveto
1105 (/ (- width
(* 0.3 height
)) width
)
1109 %% ===================================================
1110 % pes shapes (slightly rounded quadrata to be used
1112 %% ===================================================
1113 #(define
(ps
_pes
_outer
_side width height
. diffs
)
1114 (let
* ((yshift
(if
(> (length diffs
) 0) (car diffs
) 0)))
1119 -0.5 0.45 -0.3 0.45 0 0.45 curveto
1120 0.3 0.45 0.5 0.45 0.5 0.35 curveto
1122 0.5 -0.55 0.4 -0.45 0 -0.45 curveto
1123 -0.4 -0.45 -0.5 -0.55 -0.5 -0.45 curveto
1124 closepath " yshift width height
)))
1126 #(define
(ps
_pes
_inner
_side width height
)
1129 ~a 0.31 ~:*~a 0.42 ~:*~a 0 curveto
1130 ~:*~a -0.42 ~:*~a -0.31 0 -0.31 curveto
1131 ~a -0.31 ~:*~a -0.42 ~:*~a 0 curveto
1132 ~:*~a 0.42 ~:*~a 0.31 0 0.31 curveto closepath "
1133 (-
0.5 (/ 0.15 (abs width
)))
1134 (+ -
0.5 (/ 0.15 (abs width
)))))
1136 #(define
(ps
_pes
_half
_inner
_side width height
)
1139 ~a 0.31 ~:*~a 0.42 ~:*~a 0 curveto
1140 ~:*~a -0.42 ~:*~a -0.31 0 -0.31 curveto closepath "
1141 (-
0.5 (/ 0.15 (abs width
)))
1142 (+ -
0.5 (/ 0.15 (abs width
)))))
1145 %% ==============================================
1146 % List of functions to combine into note shapes
1147 %% ==============================================
1148 #(define mensural
_notehead
_contour
_funcs
1151 (list ps
_quadrata
_outer
_side
1152 ps
_quadrata
_inner
_side
1153 ps
_quadrata
_half
_inner
_side
))
1155 (list ps
_rhombus
_outer
_side
1156 ps
_rhombus
_inner
_side
1157 ps
_rhombus
_half
_inner
_side
))
1159 (list ps
_pes
_outer
_side
1161 ps
_pes
_half
_inner
_side
))
1163 (list ps
_obliqua
_outer
_side
1164 ps
_obliqua
_inner
_side
1165 ps
_obliqua
_inner
_side
))
1168 %% =============================================
1169 % List of available stem/flag additions
1170 %% =============================================
1172 #(define
(ps
_virga x y color
)
1173 (let
* ((realx
(+ x
(if
(<= x
0.0) 0.055 -
0.055)))
1174 (usered
(if
(or
(eq? color
'red
) (eq? color
'redhollow
)) #t
#f)))
1176 (if usered
"gsave 0.7 0 0 setrgbcolor " "")
1177 (format
#f "newpath ~a 0 moveto 0 ~a rlineto stroke " realx y
)
1178 (if usered
"grestore " ""))))
1180 #(define mensural
_flags
1183 "newpath 0 0.51 moveto 0 1.8 rlineto stroke ")
1186 "newpath 0 -0.51 moveto 0 -1.4 rlineto stroke ")
1189 "newpath 0 0.51 moveto
1190 0 1.7 rlineto stroke
1191 newpath 0 2.26 moveto
1192 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1193 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1195 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1198 (double
_flag
_above
_right
.
1199 "newpath 0 0.51 moveto
1200 0 1.7 rlineto stroke
1201 newpath 0 2.26 moveto
1202 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1203 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1205 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1207 newpath 0 1.75 moveto
1208 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1209 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1211 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1214 (triple
_flag
_above
_right
.
1215 "newpath 0 0.51 moveto
1216 0 1.7 rlineto stroke
1217 newpath 0 2.26 moveto
1218 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1219 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1221 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1223 newpath 0 1.75 moveto
1224 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1225 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1227 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1229 newpath 0 1.24 moveto
1230 0.019 -0.05 0.073 -0.077 0.154 -0.126 rcurveto
1231 0.324 -0.192 0.387 -0.356 0.45 -0.7 rcurveto
1233 -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1237 "newpath 0 0.51 moveto
1238 0 1.7 rlineto stroke
1239 newpath 0 2.26 moveto
1240 -0.019 -0.05 -0.073 -0.077 -0.154 -0.126 rcurveto
1241 -0.324 -0.192 -0.387 -0.356 -0.45 -0.7 rcurveto
1243 0.138 0.5 0.49 0.46 0.55 0.66 rcurveto
1247 "newpath 0 -0.51 moveto
1248 0 -1.4 rlineto stroke
1249 newpath 0 -1.96 moveto
1250 0.019 0.05 0.073 0.077 0.154 0.126 rcurveto
1251 0.324 0.192 0.387 0.356 0.45 0.7 rcurveto
1253 -0.138 -0.5 -0.49 -0.46 -0.55 -0.66 rcurveto
1257 "newpath 0 -0.51 moveto
1258 0 -1.4 rlineto stroke
1259 newpath 0 -1.96 moveto
1260 -0.019 0.05 -0.073 0.077 -0.154 0.126 rcurveto
1261 -0.324 0.192 -0.387 0.356 -0.45 0.7 rcurveto
1263 0.138 -0.5 0.49 -0.46 0.55 -0.66 rcurveto
1266 (vg
_diagonal
. "-0.33 0 moveto -0.558 -0.86 rlineto stroke ")
1268 (dovetail
_above
. "0.45 1.19 moveto -0.45 -0.65 rlineto -0.45 0.65 rlineto stroke ")
1270 (pigtail
_above
_right
.
1271 "newpath 0 0.51 moveto
1274 0.26921 0.1805 0.4441 0.3356 0.44088 0.5202 rcurveto
1275 -0.001 0.07 -0.0409 0.131 -0.10692 0.1443 rcurveto
1276 -0.2204 0.044 -0.40347 -0.2512 -0.40614 -0.4129 rcurveto
1278 -0.10074 -0.063 -0.20675 -0.1174 -0.31864 -0.1686 rcurveto
1279 -0.004 -0.013 0.0309 -0.026 0.06 -0.019 rcurveto
1280 0.0658 0.023 0.15663 0.07 0.25761 0.1271 rcurveto
1283 0.089 0.7869 rmoveto
1284 0.004 0.1896 rlineto
1285 -0.006 0.1884 0.23085 0.3833 0.28863 0.2504 rcurveto
1286 0.0653 -0.1501 -0.0975 -0.2895 -0.29263 -0.44 rcurveto
1290 "newpath 0 -0.51 moveto
1297 (fishhook
_below
_right
.
1298 "newpath 0.0 -0.5 moveto
1300 0 -0.55 0.7 -0.55 0.7 0 rcurveto
1303 (fishhook
_below
_left
.
1304 "newpath 0.0. -0.5 moveto
1306 0 -0.55 -0.7 -0.55 -0.7 0 rcurveto
1309 (pigtail
_below
_right
.
1310 "newpath -0.05 -0.5 moveto
1311 0.0037844 0.0576394 0.0964026 0.0612589 0.09375 0 rcurveto
1312 0 -0.65624995 rlineto
1313 0.10524882 0.069477 0.44311832 0.017572 0.4375 -0.28125 rcurveto
1314 -0.002977 -0.1583168 -0.11875128 -0.2150484 -0.25 -0.21875 rcurveto
1315 -0.0702051 -0.00198 -0.13284105 0.014921 -0.18359375 0.058593 rcurveto
1316 -0.045778 0.039392 -0.09367625 0.1098058 -0.09765625 0.1914068 rcurveto
1317 -3.2669e-4 0.032748 -0.0012314 0.060905 0 0.09375 rcurveto
1318 -0.0896129 -0.075841 -0.1447283 -0.193056 -0.21875 -0.34375 rcurveto
1319 -0.005961 -0.012135 -0.0533322 -0.030701 -0.03125 0.023437 rcurveto
1320 0.062823 0.190669 0.10011305 0.298224 0.25 0.4140631 rcurveto
1321 0 0.71874995 rlineto
1324 0.1122116 -0.049485 0.233678 -0.00259 0.25 0.125 rcurveto
1325 0.009906 0.077436 -0.0676818 0.189745 -0.15625 0.21875 rcurveto
1326 -0.0643557 0.021076 -0.1424987 0.00582 -0.19921875 -0.027344 rcurveto
1328 0.0020787 -0.068953 0.03860102 -0.1619177 0.10546875 -0.191406 rcurveto
1332 #(define mensural
_c_clef
1333 (ly
:make-stencil
(list
1335 "gsave currentpoint translate newpath
1338 0.0106 0.4047 0.0429 0.5475 0.101 0.606 rcurveto
1339 0.0429 0.043 0.27535 0.039 0.45998 0 rcurveto
1340 0.13076 -0.035 0.15309 -0.046 0.15699 -0.1878 rcurveto
1341 0.003 -0.1276 -0.004 -0.1808 -0.13219 -0.1701 rcurveto
1342 -0.10879 0 -0.42567 0.1169 -0.4519 0 rcurveto
1343 -0.0372 -0.1666 -0.0429 -0.319 -0.004 -0.4664 rcurveto
1344 0.0283 -0.1063 0.30583 -0.1063 0.43121 -0.096 rcurveto
1345 0.12545 0 0.16372 0.071 0.16372 -0.1063 rcurveto
1346 0 -0.1807 -0.0106 -0.2374 -0.1701 -0.2445 rcurveto
1347 -0.18428 0 -0.33595 0 -0.435 0.1311 rcurveto
1348 -0.11092 0.1772 -0.11021 0.2658 -0.1134 0.4462 rcurveto
1349 closepath fill grestore ")
1353 #(define mensural
_f_clef
1354 (ly
:make-stencil
(list
1356 "gsave currentpoint translate newpath
1359 0.24312 -0.3359 rlineto
1360 0.018 -0.02 0.0546 -0.023 0.0724 0 rcurveto
1361 0.24212 0.3335 rlineto
1362 0.008 0.01 0.005 0.017 0 0.026 rcurveto
1363 -0.24212 0.3335 rlineto
1364 -0.026 0.023 -0.0506 0.024 -0.0724 0 rcurveto
1365 -0.24345 -0.3335 rlineto
1366 -0.003 -0.01 -0.003 -0.016 0.0003 -0.023 rcurveto
1367 closepath fill newpath
1369 0.003 -0.055 0.004 -0.652 0.0007 -0.8674 rcurveto
1370 -4.8e-4 -0.034 0.0796 -0.039 0.0796 -0.01 rcurveto
1371 0 0.2232 0.0116 0.8065 0.0142 0.8669 rcurveto
1372 0.24212 0.3335 rlineto
1373 0.008 0.01 0.006 0.017 0 0.026 rcurveto
1374 -0.24212 0.3335 rlineto
1375 -0.0233 0.02 -0.056 0.017 -0.0724 0 rcurveto
1376 -0.24211 -0.3335 rlineto
1377 -0.007 -0.01 -0.006 -0.018 0 -0.026 rcurveto
1378 closepath fill newpath
1380 0.0297 0.039 0.2465 -0.02 0.34237 -0.01 rcurveto
1381 0.0969 0.014 0.21204 0.011 0.21204 -0.073 rcurveto
1382 0 -0.085 -0.0196 -1.0593 -0.0478 -1.7195 rcurveto
1383 -0.0282 -0.6602 0.0282 -0.7617 -0.0169 -0.7617 rcurveto
1384 -0.0451 0 -0.0559 0.047 -0.062 0.2031 rcurveto
1385 -0.006 0.1657 0.01 1.0342 -0.0104 1.0845 rcurveto
1386 -0.0201 0.05 -0.38575 -0.023 -0.41353 0.014 rcurveto
1387 -0.0307 0.04 -0.0381 0.3139 4.4e-4 0.3589 rcurveto
1388 0.0183 0.021 0.42054 -0.051 0.42515 0.035 rcurveto
1389 0.004 0.075 -0.003 0.4276 -0.005 0.4853 rcurveto
1390 -0.002 0.066 -0.4088 -0.01 -0.43227 0.021 rcurveto
1391 -0.0254 0.034 -0.028 0.3126 0.008 0.3599 rcurveto
1392 closepath fill grestore ")
1396 #(define mensural
_g_clef
1397 (ly
:make-stencil
(list
1399 "gsave currentpoint translate 1.5 1.5 scale newpath
1400 -0.208455 0.4111 moveto
1401 -0.189143 -0.01 -0.369817 0.034 -0.525083 0.034 rcurveto
1402 -0.115744 0 -0.4291 -0.042 -0.426277 -0.3952 rcurveto
1403 0 -0.3501 0.262541 -0.5025 0.4291 -0.494 rcurveto
1404 0.143974 0.01 0.265365 0.042 0.316179 0.096 rcurveto
1405 -0.04799 0.1581 rlineto
1406 0 0 -0.06211 -0.2004 -0.208904 -0.1976 rcurveto
1407 -0.175028 0 -0.268188 0.085 -0.282303 0.3952 rcurveto
1408 -0.0056 0.1779 0.152443 0.3501 0.287949 0.3416 rcurveto
1409 0.141151 -0.01 0.446038 -0.073 0.446038 -0.073 rcurveto
1410 closepath fill newpath
1411 -0.462527 0.4716 moveto
1412 -0.06211 -0.4263 0 -0.7142 0.02258 -0.8638 rcurveto
1413 0.03952 -0.2823 -0.07058 -0.3896 -0.200435 -0.4037 rcurveto
1414 -0.127036 -0.014 -0.27948 0.065 -0.27948 0.065 rcurveto
1415 -0.112921 -0.087 rlineto
1416 0 0 0.05928 -0.048 0.160913 -0.065 rcurveto
1417 0.112921 -0.02 0.231488 -0.02 0.3557 0.017 rcurveto
1418 0.177852 0.056 0.330294 0.2033 0.293595 0.463 rcurveto
1419 -0.03388 0.2399 -0.104452 0.4601 -0.09316 0.6154 rcurveto
1420 0.0085 0.1327 0.04517 0.2682 0.04517 0.2682 rcurveto
1421 closepath fill newpath
1422 -0.414536 -0.7225 moveto
1423 0.149621 0 0.208904 0 0.333117 0.1185 rcurveto
1424 0.135506 0.1327 0.104452 0.7312 0.06211 0.9542 rcurveto
1425 -0.04234 0.2259 -0.127036 0.5477 -0.129859 0.6126 rcurveto
1426 -0.01129 0.1609 0.09598 0.2089 0.155266 0.1045 rcurveto
1427 0.110098 -0.192 0.09598 -0.4065 0.0367 -0.4969 rcurveto
1428 -0.07622 -0.1157 -0.197612 -0.1044 -0.364171 -0.093 rcurveto
1430 0.355702 -0.031 0.533552 0.2512 0.516614 0.4827 rcurveto
1431 -0.01694 0.223 -0.09034 0.3388 -0.225842 0.3501 rcurveto
1432 -0.138328 0.014 -0.262542 -0.2259 -0.242781 -0.415 rcurveto
1433 0.01694 -0.3444 0.302065 -0.9711 0.146798 -1.2986 rcurveto
1434 -0.06493 -0.1383 -0.191966 -0.1581 -0.299241 -0.175 rcurveto
1435 closepath fill grestore ")
1439 % ===========================================================
1440 % fix mensural clefs
1441 % \clavis #'f #3 gives f clef on 3rd line (from bottom)
1442 % ===========================================================
1443 clavis
= #(define-music-function
(parser location type line
) (symbol? number?
)
1446 ((f) mensural
_f_clef
)
1447 ((g) mensural
_g_clef
)
1448 (else mensural
_c_clef
)))
1449 (linepos
(* 2 (- line
3)))
1452 ((f) (+
(* 2 (- line
3)) 4))
1453 ((g) (-
(* 2 (- line
3)) 4))
1454 (else
(* 2 (- line
3))))))
1457 'ContextSpeccedMusic
1458 'context-type
'Staff
1468 'grob-property-path
(list
'stencil
)
1469 'grob-value mystencil
)
1470 (make-music ; dummy setting
1476 'symbol
'middleCClefPosition
1480 'symbol
'clefPosition
1484 'procedure ly
:set-middle-C
!)
1487 %% ==============================================
1489 %% ==============================================
1490 #(define
(signature
_stencil sign
)
1492 ; sign is
a custom stencil
1495 ; sign is
a glyph name
1497 (lambda
(grob
) (grob-interpret-markup grob
(markup
(#:musicglyph sign
)))))
1498 ; sign is
a markup expression
1500 (lambda
(grob
) (grob-interpret-markup grob sign
)))
1501 ; sign is
a number pair
1502 ((number-pair? sign
)
1503 (lambda
(grob
) (grob-interpret-markup grob
1504 ;; TODO
: fix vertical alignment of denominator
1505 (markup
(make-column-markup
(list
1506 (number-
>string
(car sign
))
1507 (number-
>string
(cdr sign
))))))))
1509 ; sign is
a rational number
1511 (let
* ((num
(numerator sign
))
1512 (den
(denominator sign
))
1513 (marknum
(markup
(number-
>string num
)))
1514 (markden
(markup
(number-
>string den
))))
1516 (lambda
(grob
) (grob-interpret-markup grob marknum
))
1517 (lambda
(grob
) (grob-interpret-markup grob
1518 ;; TODO
: fix vertical alignment of denominator
1519 (markup
(make-column-markup
(list marknum markden
))))))))
1520 ; if
#f has been passed in
: print nothing
1524 %% ==============================================
1526 %% ==============================================
1527 proportio
= #(define-music-function
(parser location prop music
) (rational? ly
:music?
)
1528 (let
* ((num
(numerator prop
))
1529 (den
(denominator prop
))
1530 (mom
(ly
:make-moment den num
))
1531 (stencil
(signature
_stencil prop
))
1533 (make-music ;
= \override Staff
.TimeSignature
#'stencil
=
1534 'ContextSpeccedMusic
1535 'context-type
'Staff
1537 make-music
'OverrideProperty
1540 'symbol
'TimeSignature
1541 'grob-property-path
'(stencil
)
1542 'grob-value stencil
))
1544 'ContextSpeccedMusic
1545 'context-type
'Staff
1549 'ContextSpeccedMusic
1550 'context-type
'Timing
1554 'symbol
'timeSignatureFraction
1555 'value
'(4 . 4))))))
1562 (ly
:music-compress music mom
))))))
1564 %% =======================================================
1565 % check if a music event is an 'event-chord that contains
1566 % at least one 'rhythmic-event (i.e. a note or rest).
1567 %% =======================================================
1568 #(define
(rhythmicchord? event
)
1569 (let
* ((types
(ly
:music-property event
'types
))
1570 (elements
(ly
:music-property event
'elements
))
1571 (hasrhythmicchild
#f))
1572 (if
(and
(memq
'event-chord types
) (list? elements
))
1573 (map
(lambda
(child
)
1574 (let
((childtypes
(ly
:music-property child
'types
)))
1575 (if
(memq
'rhythmic-event childtypes
)
1576 (set
! hasrhythmicchild
#t
))))
1581 %% ==============================================
1583 %% ==============================================
1584 mensura
= #(define-music-function
(parser location vals music
) (list? ly
:music?
)
1586 (newmusic
(ly
:music-deep-copy music
))
1587 (sign
(assq-ref vals
'sign
))
1588 (prolatio
(assq-ref vals
'prolatio
))
1589 (tempus
(assq-ref vals
'tempus
))
1590 ; if neither tempus nor prolatio are explicitly set
, assume an
1591 ; ars-antiqua-style mensuration on modus level
(1mx
= 2lg
= 6br
)
1592 (usetempus
(if
(or
(assq
'prolatio vals
) (assq
'tempus vals
)) #t
#f))
1593 (modus
(if
(assq
'modus vals
) (assq-ref vals
'modus
) (if usetempus
#t
#f)))
1594 (maximodus
(assq-ref vals
'maximodus
))
1596 (ly
:make-moment
1 2) ;basic beat unit is the minim
(1/2)
1597 (ly
:make-moment
2 1))) ;basic beat unit is the breve
1599 (dimin
(or
(assq-ref vals
'diminutio
) 1))
1600 (beatgroup
(if usetempus
(if prolatio
3 2) 3))
1601 (groupcount
(if usetempus
(if tempus
3 2) 2))
1602 (measurelength
(ly
:moment-mul beat
(ly
:make-moment
(* beatgroup groupcount
) 1)))
1603 (beatlist
(if tempus
1604 (list beatgroup beatgroup beatgroup
)
1605 (list beatgroup beatgroup
)))
1607 ((and prolatio tempus
(= dimin
2)) '(9 . 8))
1608 ((and prolatio tempus
) '(9 . 4))
1609 ((and prolatio
(= dimin
2)) '(6 . 8))
1610 ( prolatio
'(6 . 4))
1611 ((and tempus
(= dimin
2)) '(3 . 4))
1612 ( (= dimin
2) '(2 . 2))
1614 (usetempus
'(4 . 4))
1615 (else
#f))) ;dummy setting
1616 (glyphname
(if fakesign
1619 (number-
>string
(car fakesign
))
1620 (number-
>string
(cdr fakesign
)))
1625 ; signature has been explicitly set to false
: print nothing
1626 ((and
(pair?
(assq
'sign vals
)) (not sign
))
1628 ; use default mensuration signs
1629 ((and usetempus
(not
(assq
'sign vals
)))
1633 (unflagged
_sm
(assq-ref vals
'unflagged
_sm
))
1634 (basecolor
(or
(assq-ref vals
'color
) 'black
))
1637 (cons
'mx
(lambda
(color
)
1638 (or
(assq-ref vals
'mx
)
1639 (make-mensural-note-stencil
1640 'quadrata color
1.7 0.75 (ps
_virga
0.85 -
1.4 color
))))) ;mx
1641 (cons
'lg
(lambda
(color
)
1642 (or
(assq-ref vals
'lg
)
1643 (make-mensural-note-stencil
1644 'quadrata color
1.10 0.90 (ps
_virga
0.425 -
1.4 color
))))) ;lg
1645 (cons
'br
(lambda
(color
)
1646 (or
(assq-ref vals
'br
)
1647 (make-mensural-note-stencil
1648 'quadrata color
1.10 0.90 )))) ;br
1649 (cons
'sb
(lambda
(color
)
1650 (or
(assq-ref vals
'sb
)
1651 (make-mensural-note-stencil
1652 'rhombus color
1.3 1.1 )))) ;sb
1653 (cons
'mn
(lambda
(color
)
1654 (or
(assq-ref vals
'mn
)
1655 (make-mensural-note-stencil
1656 'rhombus color
1.3 1.1 'stem
_above
)))) ;mn
1657 (cons
'sm
(lambda
(color
)
1658 (or
(assq-ref vals
'sm
)
1659 (if unflagged
_sm ;sm
1660 (make-mensural-note-stencil
1662 (case color
(( black
) 'blackhollow
) (( white blackhollow hollow
) 'black
) (else color
))
1665 (make-mensural-note-stencil
1669 'flag
_above
_right
)))))
1670 (cons
'fu
(lambda
(color
)
1671 (or
(assq-ref vals
'fu
) ;fu
1673 (make-mensural-note-stencil
1675 (case color
(( black
) 'blackhollow
) (( white blackhollow hollow
) 'black
) (else color
))
1678 (make-mensural-note-stencil
1682 'double
_flag
_above
_right
)))))
1683 (cons
'sf
(lambda
(color
)
1684 (or
(assq-ref vals
'sf
) ;semifusa
1686 (make-mensural-note-stencil
1688 (case color
(( black
) 'blackhollow
) (( white blackhollow hollow
) 'black
) (else color
))
1690 'double
_flag
_above
_right
)
1691 (make-mensural-note-stencil
1695 'triple
_flag
_above
_right
)))))
1699 (cons
'foldpes
(assq-ref vals
'foldpes
))
1700 (cons
'color basecolor
)
1701 (cons
'unflagged
_sm unflagged
_sm
)))
1702 (notestencilfunction
(lambda
(grob
)
1703 (let
* ((cause
(ly
:grob-property grob
'cause
))
1704 (duration
(ly
:event-property cause
'duration
))
1705 (durlog
(ly
:duration-log duration
))
1706 (dur
(duration
_log
_to
_note
_symbol durlog
))
1707 (tags
(ly
:grob-property grob
'mensural
_tags
))
1708 (colortweak
(get-mensural-flag cause
'color
))
1709 (thiscolor
(if colortweak colortweak basecolor
))
1711 (if
(assoc duration vals
)
1712 (set
! thisstencil
(assoc-ref vals duration
))
1713 (set
! thisstencil
((assq-ref noteglyphs dur
) thiscolor
))
1716 (reststencilfunction
(lambda
(grob
)
1717 (let
* ((cause
(ly
:grob-property grob
'cause
))
1718 (duration
(ly
:event-property cause
'duration
))
1719 (durlog
(ly
:duration-log duration
))
1720 (tags
(ly
:grob-property grob
'mensural
_tags
))
1721 (imperfect
(if tags
(assq-ref tags
'imperfect
) #f))
1724 (large
_rest
_stencil durlog modus maximodus imperfect
)
1725 (ly
:rest
::print grob
)))))
1726 (widthfunction
(lambda
(grob
)
1727 (let
* ((cause
(ly
:grob-property grob
'cause
))
1728 (duration
(ly
:event-property cause
'duration
))
1729 (durlog
(ly
:duration-log duration
)))
1731 (ly
:grob
::stencil-width grob
)
1732 (ly
:rest
::width grob
)))))
1736 'ContextSpeccedMusic
1737 'context-type
'Bottom
1742 'grob-property-path
(list
'mensural
_glyphs
)
1743 'grob-value notesettings
))
1745 'ContextSpeccedMusic ;
= \set mensural
_ligature
_queue
= #f
1746 'context-type
'Bottom
1750 'symbol
'mensural
_ligature
_queue
1753 ;
(make-music ;
= \override NoteHead
#'X-extent
= #widthfunction
1754 ;
'ContextSpeccedMusic
1755 ;
'context-type
'Bottom
1761 ;
'grob-property-path
(list
'X-extent
)
1762 ;
'grob-value widthfunction
))
1763 (make-music ;
= \override Rest
#'X-extent
= #widthfunction
1764 'ContextSpeccedMusic
1765 'context-type
'Bottom
1770 'grob-property-path
(list
'X-extent
)
1771 'grob-value widthfunction
))
1773 (make-music ;
= \override NoteHead
#'stencil
= #notestencilfunction
1774 'ContextSpeccedMusic
1775 'context-type
'Bottom
1780 'grob-property-path
(list
'stencil
)
1781 'grob-value notestencilfunction
))
1783 (make-music ;
= \override Rest
#'stencil
= #reststencilfunction
1784 'ContextSpeccedMusic
1785 'context-type
'Bottom
1790 'grob-property-path
(list
'stencil
)
1791 'grob-value reststencilfunction
))
1795 'ContextSpeccedMusic ;
= \override Rest
#'style
= #'mensural
1796 'context-type
'Bottom
1801 'grob-property-path
(list
'style
)
1802 'grob-value
'mensural
))
1803 (make-music ;
= \override Staff
.TimeSignature
#'stencil
= #signstencil
1804 'ContextSpeccedMusic
1805 'context-type
'Staff
1807 make-music
'OverrideProperty
1809 'symbol
'TimeSignature
1810 'grob-property-path
'(stencil
)
1811 'grob-value signstencil
))
1813 'ContextSpeccedMusic
1814 'context-type
'Staff
1818 'ContextSpeccedMusic
1819 'context-type
'Timing
1824 (if
(pair? fakesign
)
1828 'symbol
'timeSignatureFraction
1834 ;
'symbol
'beatLength
1838 'symbol
'measureLength
1839 'value measurelength
)
1842 'symbol
'beatStructure
1849 ;; now process the actual music
, setting durations according to tempus
/prolatio
1853 ;;every chord of the music needs to be prefixed
1854 ;;with an ApplyOutput call to our mensural
_processing function
1855 ((rhythmicchord? event
)
1857 ;
(display
"prefixing an event-chord:\n")
1864 'context-type
'Bottom
1865 'procedure mensural
_processing
)
1867 ((memq
'rhythmic-event
(ly
:music-property event
'types
))
1868 (let
* ((duration
(ly
:music-property event
'duration
))
1869 (durlog
(ly
:duration-log duration
))
1870 (dur
(duration
_log
_to
_note
_symbol durlog
))
1871 (dots
(ly
:duration-dot-count duration
))
1872 (durfactor
(ly
:duration-factor duration
))
1873 (color
(or
(get-mensural-flag event
'color
) basecolor
))
1874 (newfactor
'(1 . 1))
1875 (fprol
(if prolatio
3 2))
1876 (ftemp
(if tempus
3 2))
1877 (fmod
(if modus
3 2))
1878 (fmax
(if maximodus
3 2))
1879 (multiply
(lambda
(pairA pairB
) (cons
(* (car pairA
)(car pairB
)) (* (cdr pairA
)(cdr pairB
)))))
1882 ;
(display
(format
#f "We have a rhythmic event: ~a\n" event
))
1885 (set
! newfactor
(cons
(* fprol ftemp fmod fmax
) 16)))
1887 (set
! newfactor
(cons
(* fprol ftemp fmod
) 8)))
1889 (set
! newfactor
(cons
(* fprol ftemp
) 4)))
1891 (set
! newfactor
(cons fprol
2))))
1892 (set
! newfactor
(multiply newfactor durfactor
))
1893 (ly
:music-set-property
!
1896 (ly
:make-duration durlog dots
(car newfactor
) (cdr newfactor
)))
1908 (ly
:music-compress newmusic
1909 (ly
:make-moment
(denominator dimin
) (numerator dimin
)))))
1911 ; insert the time sig code together with the modified music
1921 linea
= #(define-music-function
(parser location type
) (string?
)
1923 \once \override Staff
.BarLine
#'stencil
= #ly
:bar-line
::print
1927 %% ==================================================================
1928 % Accidentals function: use medieval b molle and b durum,
1929 % "♮" = b natural or f sharp; "♭" = b flat or f natural
1930 %% ==================================================================
1931 accidens
= #(define-music-function
(parser location note
) (ly
:music?
)
1933 (notecopy
(ly
:music-deep-copy note
)))
1936 (if
(memq
'note-event
(ly
:music-property event
'types
))
1937 (let
* ((pitch
(ly
:music-property event
'pitch
))
1938 (notename
(ly
:pitch-notename pitch
))
1939 (alteration
(ly
:pitch-alteration pitch
)))
1943 'elements
(append
(list
1945 'ContextSpeccedMusic
1946 'context-type
'Bottom
1947 'element
(make-music
1951 'grob-property-path
'(stencil
)
1952 'grob-value ly
:accidental-interface
::print
))
1954 'ContextSpeccedMusic
1955 'context-type
'Bottom
1956 'element
(make-music
1960 'grob-property-path
'(glyph-name-alist
)
1963 ((3 0 4) '((0 . "accidentals.flat")(1/2 . "accidentals.natural"))) ;
c,f,g
1964 (else
'((-
1/2 . "accidentals.flat")(0 . "accidentals.natural")))) ;
b,e,a,d
1967 (ly
:music-set-property
! event
'force-accidental
#t
)