common/blackmensural.ly

   1 \version "2.12.0"
   2 %% ========================================================
   3 %  blackmensural.ly – Black Mensural Notation for Lilypond
   4 %  Version 0.1, January 2011
   5 %  (C) Lukas Pietsch
   6 %  Released under the GNU General Public License
   7 %% ========================================================
   8
   9 %% ===============================================
  10 %  Context type definitions
  11 %% ===============================================
  12
  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
  22 }
  23
  24 \layout {
  25     ragged-right = ##t
  26     \context {
  27       \Voice
  28       \name BlackMensuralVoice  %% adapted from MensuralVoice definition
  29       \alias Voice
  30       \remove Beam_engraver
  31       \remove Stem_engraver
  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
  38     }
  39     \context {
  40       \Staff
  41       \name BlackMensuralStaff  %% adapted from MensuralStaff definition
  42       \alias Staff
  43       \denies Voice
  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."
  48
  49       \consists "Custos_engraver"
  50
  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
  56
  57       \override StaffSymbol #'thickness = #0.6
  58       \override KeySignature #'font-size = #-2
  59       \override TimeSignature #'font-size = #-2
  60
  61       %% Choose c clef on 3rd line as default.
  62       clefGlyph = #"clefs.vaticana.do"
  63       middleCClefPosition = #0
  64       middleCPosition = #0
  65       clefPosition = #0
  66       clefOctavation = #0
  67
  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
  77
  78       %% Accidentals are valid only once (same as
  79       %% #(set-accidental-style 'forget))
  80       extraNatural = ##f
  81       autoAccidentals = #`(Staff ,(make-accidental-rule 'same-octave -1))
  82       autoCautionaries = #'()
  83       printKeyCancellation = ##f
  84
  85
  86     }
  87     \context {
  88       \Score
  89       \accepts BlackMensuralStaff
  90     }
  91 }
  92
  93 %% ===============================================
  94 %  declaring some custom properties
  95 %% ===============================================
  96
  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")
 100
 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")
 106
 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")
 110
 111
 112 %% ==============================================
 113 %  convenience definition - empty stencil
 114 %% ==============================================
 115 #(define-public empty-stencil
 116    (ly:make-stencil (list 'embedded-ps "") '(0 . 0) '(0 . 0)))
 117
 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)
 130     note))
 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))
 136          (old (assq key tw)))
 137     (if (or frc (not old))
 138       (begin
 139         (set! tw (assq-set! tw key val))
 140         (ly:music-set-property! event 'tweaks tw)))
 141     event))
 142 #(define (get-tweak event key)
 143   (let* (
 144     (tw (if (ly:music? event) (ly:music-property event 'tweaks) (ly:event-property event 'tweaks))))
 145     (assq-ref tw key)))
 146
 147 #(define (flag-notes! key val onlynotes music )
 148   (let ((test (if onlynotes 'note-event 'rhythmic-event)))
 149     (music-map
 150       (lambda (event)
 151         (begin
 152           (if (memq test (ly:music-property event 'types))
 153             (set-mensural-flag! event key val)))
 154         event)
 155       music)
 156     music))
 157 #(define (tweak-notes! key val onlynotes music )
 158   (let ((test (if onlynotes 'note-event 'rhythmic-event)))
 159     (music-map
 160       (lambda (event)
 161         (begin
 162           (if (memq test (ly:music-property event 'types))
 163             (set-tweak! event key val onlynotes)))
 164         event)
 165       music)
 166     music))
 167 flagNotes = #(define-music-function (parser location key val music) (symbol? boolean? ly:music?)
 168   (flag-notes! key val #t music))
 169
 170
 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))
 206
 207
 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
 215    'elements (list
 216       (make-music                         ; =   \override NoteHead #'stencil = #stencilfunction
 217         'ContextSpeccedMusic
 218         'context-type 'Bottom
 219         'element
 220         (make-music
 221           'OverrideProperty
 222           'symbol 'NoteHead
 223           'grob-property-path (list 'stencil)
 224           'grob-value stencilfunction))
 225       mymusic
 226       (make-music
 227         'ContextSpeccedMusic
 228         'context-type 'Bottom
 229         'element
 230         (make-music
 231           'RevertProperty
 232           'symbol 'NoteHead
 233           'grob-property-path (list 'stencil))))))
 234
 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))
 239
 240 %% ==================================================
 241 %  Coloratio
 242 %% ==================================================
 243 coloratio = #(define-music-function (parser location col mymusic) (symbol? ly:music?)
 244   (begin
 245     (music-map                 ; iterate through all the music
 246       (lambda (event)
 247         (cond
 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))
 253             (case col
 254               ((red redhollow)
 255                 (set-tweak! event 'color (rgb-color 0.7 0 0) #f)))))
 256         event)
 257       mymusic)
 258     mymusic))
 259
 260 %% ==============================================
 261 %  LIGATURE CODE
 262 %% ==============================================
 263
 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?)
 273      (make-music
 274       'SequentialMusic
 275       'elements
 276       (list
 277         ;; call to start_ligature callback
 278         (make-music
 279           'ApplyContext
 280           'context-type 'Bottom
 281           'procedure start_ligature)
 282         ;; original music
 283         mymusic
 284         ;; call to finish_ligature callback
 285         (make-music
 286           'ApplyContext
 287           'context-type 'Bottom
 288           'procedure finish_ligature)
 289
 290         ;; ugly workaround to get horizontal spacing right:
 291         ;; insert an invisible breathing mark as a dummy grob
 292         (make-music
 293           'ContextSpeccedMusic
 294           'context-type 'Bottom
 295           'element (make-music
 296             'OverrideProperty
 297             'symbol 'BreathingSign
 298             'grob-property-path '(text)
 299             'grob-value " "
 300             'pop-first #t
 301             'once #t))
 302         (make-music
 303           'EventChord
 304           'elements
 305           (list (make-music (quote BreathingEvent))))
 306
 307         )))
 308
 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
 323                  context
 324                  'mensural_ligature_queue ))
 325         (inligature (if queue #t #f))
 326        )
 327     ;(display (format #f "We got a ~a\n" type))
 328     (if inligature
 329       (cond
 330         ((eq? type 'NoteHead)
 331           (begin
 332             (ly:context-set-property!
 333               context
 334               'mensural_ligature_queue
 335               (append queue (list grob)))))
 336         ((eq? type 'Dots)
 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!
 352               context
 353               'mensural_accidentals_queue
 354               (append accqueue (list (cons position stencil)))))))
 355
 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))
 360     )))
 361
 362
 363 % ===========================================
 364 % convenience function: use explanatory
 365 % symbols rather than duration logs for
 366 % note values
 367 % ===========================================
 368 #(define (duration_log_to_note_symbol log)
 369   (case log
 370     ((-3) 'mx)
 371     ((-2) 'lg)
 372     ((-1) 'br)
 373     ((0)  'sb)
 374     ((1)  'mn)
 375     ((2)  'sm)
 376     ((3)  'fu)
 377     ((4)  'sf)
 378     (else #f)))
 379
 380 #(define (start_ligature context)
 381   (ly:context-set-property!
 382     context
 383     'mensural_ligature_queue
 384     '()))
 385
 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
 393 %  others invisible.
 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 )
 399                    '()))
 400          (imaxall (- (length notes) 1))
 401          (imax imaxall)
 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))
 404
 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))
 408
 409          (glyphsettings (ly:grob-property (car notes) 'mensural_glyphs))
 410          (foldpes    (assq-ref glyphsettings 'foldpes))
 411          (basecolor  (or (assq-ref glyphsettings 'color) 'black))
 412
 413          (mystencil  #f)
 414          (postscript "")
 415          (notewidth 1.1)
 416          (noteheight 0.9)
 417          (linewidth 0.11)
 418          (rightX (* notewidth (+ imaxall 1)))
 419          (curX rightX)
 420          (firstpos (car ypositions))
 421          (posref
 422            (lambda (i)
 423              (list-ref ypositions i)))
 424          (add-postscript
 425            (lambda (ps)
 426              (set! postscript (string-append postscript ps))))
 427          (shift-postscript
 428            (lambda (dX dY)
 429              (begin
 430                (add-postscript (format #f " ~a ~a translate " dX dY))
 431                (set! curX (+ curX dX)))))
 432          (obliqua-width
 433            (lambda (adiff)
 434              (+ (* adiff adiff (/ 1.0 12.0)) (* adiff (/ 7.0 12.0)) (/ 4.0 3.0))))
 435          )
 436
 437     ; we need at least two notes to proceed beyond here.
 438     (if (>= imaxall 1)
 439       (begin
 440
 441         ;check how many of our notes are regular ligature notes,
 442         ;and how many are trailing currentes or plicae
 443         (do ((i 0 (1+ i)))
 444             ((or (> i imaxall) (< imax imaxall)))
 445           (if (assq-ref (list-ref flags i) 'currens)
 446              (set! imax (- i 1)))
 447           (if (assq-ref (list-ref flags i) 'plica)
 448             (begin
 449               (set! imax (- i 1))
 450               ; also check whether the preceding note is manually forced to be folded in
 451               (if (and
 452                    (> i 0)
 453                    (assq-ref (list-ref flags (- i 1)) 'pes))
 454                   (set! foldpes #t)
 455                   (set! foldpes #f)))))
 456
 457         ;(display (format #f "Finishing ligature with ~a (~a) notes.\n" (+ 1 imaxall) (+ 1 imax)))
 458
 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
 464             ((< i 0))
 465
 466           (let* (
 467                  (atfirst  (= i 0))
 468                  (atpenult (= i (- imax 1)))
 469                  (atlast   (>= i imax))
 470                  (atverylast (= i imaxall))
 471                  (inmiddle (and (> i 0) (< i imax)))
 472
 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))))
 477
 478                  (this      (list-ref notes i))
 479                  (thisval   (list-ref vals i))
 480                  (thispos   (list-ref ypositions i))
 481                  (thisflag  (list-ref flags i))
 482
 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))))
 487
 488                  (descending (if atverylast (< thispos prevpos) (< nextpos thispos)))
 489                  (descended  (if atfirst descending (< thispos prevpos)))
 490
 491                  (singlebr (and atfirst atlast (eq? thisval 'br)))
 492                  (singlelg (and atfirst atlast (eq? thisval 'lg)))
 493
 494                  (thiscolor  (or (assq-ref thisflag 'color) basecolor))
 495                  (currens    (assq-ref thisflag 'currens))
 496
 497                  (obliquaB  (and (not atfirst)
 498                             (or
 499                               (and atlast                      ; obligatory sine-perf obliqua
 500                                    descended
 501                                    (not (and (= i 1)(eq? prevval 'sb)))
 502                                    (eq? thisval 'br))
 503                               (assq-ref prevflag 'obliqua)     ; manually set obliqua
 504                               (and (assq-ref nextflag 'pes)    ;
 505                                    descended
 506                                    (not descending)
 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.
 510                                    descending
 511                                    (eq? thisval 'sb)
 512                                    (eq? prevval 'sb)
 513                                    (not (assq-ref thisflag 'obliqua))
 514                                    (not (assq-ref prevflag 'noobliqua))))))
 515                  (obliquaA   nextobliqua)
 516
 517                  (pesbottom (or
 518                               (and atpenult                     ;automatic fold-in pes in ascending cum-perf
 519                                    foldpes                      ;(old style)
 520                                    (not descending)
 521                                    (not obliquaB)
 522                                    (eq? nextval 'lg)
 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
 527                                    (not obliquaB)
 528                                    (not (eq? thisval 'sb))
 529                                    (assq-ref nextflag 'pes))))
 530                  (pestop    (or
 531                               (and atlast                      ;automatic fold-in pes
 532                                    (not atfirst)
 533                                    foldpes
 534                                    (not descended)
 535                                    (eq? thisval 'lg)
 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
 544                                   (< i imax)
 545                                   (eq? thisval 'sb)))
 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)))
 552                                    (while
 553                                      (< linewidth (abs (- y (inexact->exact y))))
 554                                      (set! y (+ y 0.05)))
 555                                    (add-postscript
 556                                      (format #f "gsave newpath ~a ~a ~a 0 360 arc fill grestore "
 557                                        (car offset) y (* 1.3 linewidth)))))))
 558                 )
 559
 560              ;; connector lines and relative y positioning
 561              (if atverylast
 562                (shift-postscript 0 (- thispos ymiddle))
 563                (shift-postscript 0 (- thispos nextpos)))
 564              (if (or inmiddle atfirst)
 565                (let ((ydiff (- nextpos thispos)))
 566                  (if (= ydiff 0)
 567                    (shift-postscript -0.2 0)
 568                    (if (and (not obliquaA) (not (assq-ref nextflag 'currens)))
 569                      (add-postscript (ps_virga 0 ydiff thiscolor))))
 570                  ))
 571
 572              ;; longa and plica strokes (virgae)
 573              (cond
 574                (plica
 575                  (let ((plicadiff (- (posref (+ i 1)) (posref i))))
 576                    (if (!= 0 plicadiff)
 577                      (let* ((plicadir  (if (= plicadiff 0) 1 (/ plicadiff (abs plicadiff))))
 578                             (shortplica 0.7)
 579                             (longplica  1.5)
 580                             (noplica    0)
 581                             (alternate  (assq-ref thisflag 'altvirga)))
 582                        (cond
 583                          (pestop
 584                            ;use additional plica note on the side; early-1200s style; Apel 248f.
 585                            (begin
 586                              (shift-postscript (* 0.8 notewidth) 0)
 587                              (add-postscript
 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)
 592                              )
 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)
 601                                       longplica
 602                                       shortplica))))
 603                               (add-postscript (ps_virga (* (- linewidth 1) notewidth) leftplica thiscolor))
 604                               (if (!= rightplica 0)
 605                                 (add-postscript (ps_virga 0 rightplica thiscolor)))))
 606                          (else
 607                            ;normal ligatura plicata; Apel 248f.
 608                            (add-postscript (ps_virga 0 (* plicadir longplica) thiscolor))))))))
 609
 610                ; alternative longa stroke of initial ascending
 611                ((and
 612                   atfirst
 613                   (not descending)
 614                   (not obliquaA)
 615                   (eq? thisval 'lg)
 616                   (assq-ref thisflag 'altvirga))
 617                  (add-postscript (ps_virga (- linewidth notewidth) -2.2 thiscolor)))
 618
 619                ; normal longa/maxima stroke
 620                ((or
 621                  (eq? thisval 'mx)
 622                  singlelg
 623                  (and
 624                    (eq? thisval 'lg)
 625                    (not (assq-ref thisflag 'obliqua))
 626                    (or
 627                      (and atlast (not pestop) (not descended))
 628                      (and atfirst (not descending))
 629                      inmiddle)))
 630                    (let* ((usevirga (not (and (eq? thisval 'mx) (assq-ref thisflag 'novirga))))
 631                           (virga_down (not (assq-ref thisflag 'altvirga)))
 632                           (ydiff (cond
 633                                    ((and usevirga virga_down descending) (- nextpos thispos))
 634                                    ((and usevirga (not virga_down) (not descending)) (- nextpos thispos))
 635                                    (else 0)))
 636                           (ylength (+ ydiff (if virga_down -2.2 2.2)))
 637                           )
 638                      (if usevirga
 639                        (add-postscript (ps_virga 0 ylength thiscolor)))))
 640
 641                ; exceptional forms: non-paired semibreve; Apel 100
 642                ((and
 643                  (= i 1)
 644                  (eq? prevval 'sb)
 645                  (not (eq? thisval 'sb)))
 646                  (let ((virga (if (eq? thisval 'lg) -1.5 1.5)))
 647                    (add-postscript (ps_virga 0 virga thiscolor))))
 648
 649                ; end of virga condition block
 650                )
 651
 652
 653              ;; main note shapes
 654              (cond
 655                (skipplica i)
 656
 657                (currens
 658                  (begin
 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)))
 662
 663                (obliquaA
 664                  (let* ((ydiff (- nextpos thispos))
 665                         (adiff (abs ydiff))
 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)))
 672
 673                (obliquaB
 674                  (let* ((ydiff (- thispos prevpos))
 675                         (adiff (abs ydiff))
 676                         (width (obliqua-width adiff)))
 677                    (shift-postscript linewidth 0)
 678                    (add-postscript (ps_notehead 'obliqua thiscolor (* -1 width) (* -1 ydiff)))
 679                    (if atverylast
 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)))
 684
 685                (pesbottom
 686                     (let* ((ycorr (if (< (- nextpos thispos) 1) -0.15 0)))
 687                       (shift-postscript (- linewidth (* 0.5 notewidth)) ycorr)
 688                       (add-postscript (ps_notehead
 689                                       'pes thiscolor
 690                                       (* -1 notewidth)
 691                                       (* -1 noteheight)))
 692                       (processdot thisflag (dotatside (* 0.5 notewidth)))
 693                       (shift-postscript (* -0.5 notewidth) (- 0 ycorr))))
 694
 695                (pestop
 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))
 701                      (if atverylast
 702                         (processdot thisflag (dotatside (* 0.5 notewidth)))
 703                         (processdot thisflag dotabove))
 704                       (shift-postscript (- (* 0.5 notewidth) linewidth) (- 0 ycorr))
 705                       ))
 706
 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))
 712                    (if atverylast
 713                       (processdot thisflag (dotatside (* 0.5 w)))
 714                       (processdot thisflag dotabove))
 715                    (shift-postscript (* -0.5 w) 0))))
 716                ;; end of notehead condition block
 717
 718             ;; initial strokes
 719             (cond
 720               ;; cum-opp-prop.: use initial upward stroke
 721               (opposita
 722                 (add-postscript (ps_virga 0 2.2 thiscolor)))
 723               ((and
 724                  atfirst
 725                  (not atlast)
 726                  descending
 727                  (eq? thisval 'br)
 728                 )
 729                 ;;descending cum proprietate: use initial downwards stroke
 730                 (add-postscript (ps_virga 0 -2.2 thiscolor)))
 731               ((and
 732                  atfirst
 733                  (not atlast)
 734                  (not descending)
 735                  (eq? nextval 'br)
 736                  obliquaA
 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)))
 741               )
 742
 743              ))  ; end of note loop
 744
 745
 746
 747         (set! postscript
 748
 749           (string-append
 750             (format #f "gsave currentpoint translate ~a 0 moveto currentpoint translate ~a setlinewidth 1 setlinecap " rightX linewidth)
 751             postscript
 752             " grestore"))
 753         (set! mystencil
 754           (ly:make-stencil
 755             (list 'embedded-ps postscript)
 756             (cons curX rightX)
 757             (cons 0 0)))
 758
 759         ;; add accidentals
 760         (let ((accstencil empty-stencil)
 761               (accqueue   (ly:context-property context 'mensural_accidentals_queue )))
 762           (if (eq? accqueue #f) (set! accqueue '()))
 763           (map (lambda (entry)
 764             (set! accstencil
 765               (ly:stencil-add
 766                 accstencil
 767                 (ly:stencil-translate-axis (cdr entry) (- (car entry) ymiddle) 1))))
 768             accqueue)
 769           (if (> (length accqueue) 0)
 770             (set! mystencil
 771               (ly:stencil-combine-at-edge
 772                 mystencil 0 -1 accstencil 0.2)))
 773           (ly:context-set-property! context 'mensural_accidentals_queue '()))
 774
 775         ;; set the middle note's stencil to our custom stencil;
 776         ;; all other stencils to zero
 777         (do ((i 0 (1+ i)))
 778             ((> i imaxall))
 779           (let* ((thisnote (list-ref notes i)))
 780             ;(begin
 781             ;  (ly:context-set-property!
 782             ;    context
 783             ;    'mensuralNotesQueue
 784             ;    (append (ly:context-property context 'mensuralNotesQueue) (list thisnote)))
 785             ;    )
 786             (if (= i imiddle)
 787               (ly:grob-set-property! thisnote 'stencil mystencil)
 788               (ly:grob-set-property! thisnote 'stencil empty-stencil))))
 789
 790         ;reset queue
 791         (ly:context-set-property!
 792           (ly:context-property-where-defined context 'mensural_ligature_queue)
 793           'mensural_ligature_queue
 794           #f)))))
 795
 796
 797
 798 %% ==============================================
 799 %  NOTEHEAD CODE
 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
 808                                   ;        'gray, 'halfgray
 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.
 812    (let* (
 813           (postscript
 814             (string-append
 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))
 819               "grestore ")))
 820       (ly:make-stencil
 821         (list
 822           'embedded-ps
 823           postscript)
 824         (cons -0.0 width)
 825         (cons -0.6 0.6))))
 826
 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))
 833          )
 834
 835     (case color
 836       ((gray halfgray)
 837         (string-append
 838           "gsave newpath "
 839           outerps
 840           "gsave "
 841           innerps
 842           "0 setgray eofill grestore newpath "
 843           innerps
 844           "0.7 setgray fill grestore "))
 845       ((halfred)
 846         (string-append
 847           "gsave newpath "
 848           outerps
 849           "gsave "
 850           innerps
 851           "0 setgray eofill grestore newpath "
 852           innerps
 853           "0.7 0 0 setrgbcolor fill grestore "))
 854       ((red)
 855         (string-append
 856           "gsave newpath "
 857           outerps
 858           "0.7 0 0 setrgbcolor fill grestore "))
 859       ((halfblack)
 860         (string-append
 861           "gsave newpath "
 862           outerps
 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 "
 865           innerps
 866           "0 setgray eofill grestore "))
 867       ((white blackhollow halfwhite hollow halfhollow)
 868         (string-append
 869           "gsave newpath "
 870           outerps
 871           innerps
 872           "0 setgray eofill grestore "))
 873       ((redhollow)
 874         (string-append
 875           "gsave newpath "
 876           outerps
 877           innerps
 878           "0.7 0 0 setrgbcolor eofill grestore "))
 879       (else
 880         (string-append
 881           "gsave newpath "
 882           outerps
 883           (if (eq? head-type 'obliqua) "closepath " "")
 884           "0 setgray fill grestore "))
 885       )))
 886
 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 ")
 890           (ps_color
 891             (case color
 892               ((red redhollow)
 893                "0.7 0 0 setrgbcolor ")
 894               (else
 895                "0 setgray "))))
 896     (string-append ps_linestyle ps_color postscript)))
 897
 898
 899 %% ====================================================
 900 %  Rests
 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
 907 %% three-space long.
 908 %% ====================================================
 909 #(define (large_rest_stencil value modus maximodus imperfect)
 910   (let* ((lines (cond
 911                  ((eq? value -2) 1)
 912                  ((or imperfect (eq? maximodus #f)) 2)
 913                  (else 3)))
 914          (length (cond
 915                   ((and (eq? value -2) imperfect) 2)
 916                   ((eq? modus #f) 2)
 917                   (else 3)))
 918          (dist   0.6)
 919          (width  0.3)
 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)))
 925         )
 926     (do ((i 2 (1+ i)))
 927         ((> i lines))
 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))))
 931
 932
 933
 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)))
 940     (music-map
 941       (lambda (event)
 942         (if (memq 'rest-event (ly:music-property event 'types))
 943           (begin
 944             (set-tweak! event 'Y-offset (- y 3) #f)
 945             (if (not fixed)
 946               (set! y (if (<= y 1) 2 (- y 1))))))
 947         event)
 948       music)
 949     music))
 950
 951
 952
 953 %% ==================================================
 954 %  Plica function
 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
 959 %  formatting.
 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)
 973                   (- numA numB)
 974                   (- (* numA denB) (* numB denA))))
 975         (denC (if (= denA denB)
 976                   denA
 977                   (* denA denB)))
 978         (numF (* numC denA))
 979         (denF (* denC numA)))
 980     (set-mensural-flag! neA 'plica #t)
 981     (make-music 'SequentialMusic
 982       'elements (list
 983       (ly:music-compress noteA (ly:make-moment numF denF))
 984       noteB))))
 985
 986 plica = #(define-music-function (parser location noteA noteB) (ly:music? ly:music?)
 987 #{
 988   \ligatura { \lplica $noteA $noteB }
 989 #})
 990
 991 %% ===================================================
 992 %  postscript definitions for note shape primitives
 993 %% ===================================================
 994
 995 %% ===================================================
 996 %  diagonal flexa shape, ligatures
 997 %% ===================================================
 998 #(define (ps_obliqua_outer_side width ydiff)
 999   (begin
1000     ;(display (format #f "width: ~a; ydiff: ~a\n" width ydiff))
1001     (format #f
1002 "0 ~a translate
1003 ~a 1 scale
1004 [1 ~a 0 1 0 0] concat
1005 1.05 -0.3 moveto
1006 0 -0.3 0 -0.5 0 -0.3 curveto
1007 0 0.25 lineto
1008 0 0.45 0 0.45 1.05 0.45 curveto "
1009     (* -0.2 (/ ydiff (- (abs width) 0.4)))
1010     (/ width 2.0)
1011     (* (/ ydiff 2.0) (/ (abs width) (- (abs width) 0.4)))
1012     )))
1013
1014 #(define (ps_obliqua_inner_side width ydiff)
1015   (format #f
1016   "1.05 0.33 moveto
1017 ~a 0.33 ~:*~a 0.33 ~:*~a 0.15 curveto
1018  ~:*~a -0.18 lineto
1019  ~:*~a -0.3 ~:*~a -0.18 1.05 -0.18 curveto "
1020    (* 0.15 (/ 1 (abs width)))
1021   ))
1022
1023 %% ===================================================
1024 %  rhombus shapes (semibreves and below)
1025 %% ===================================================
1026 #(define (ps_rhombus_outer_side width height)
1027   (format #f
1028 "~a ~a scale
1029 -0.1 0.4 moveto
1030 0 0.5 0 0.5 0.1 0.4 curveto
1031 0.45 0.05 lineto
1032 0.5 0 0.5 0 0.45 -0.05 curveto
1033 0.1 -0.4 lineto
1034 0 -0.5 0 -0.5 -0.1 -0.4 curveto
1035 -0.45 -0.05 lineto
1036 -0.5 0 -0.5 0 -0.45 0.05 curveto
1037 closepath "
1038     width
1039     height))
1040
1041 #(define (ps_rhombus_inner_side width height)
1042 "[0.7 -0.1 -0.1 0.7 0 0] concat
1043 -0.1 0.4 moveto
1044 0 0.5 0 0.5 0.1 0.4 curveto
1045 0.45 0.05 lineto
1046 0.5 0 0.5 0 0.45 -0.05 curveto
1047 0.1 -0.4 lineto
1048 0 -0.5 0 -0.5 -0.1 -0.4 curveto
1049 -0.45 -0.05 lineto
1050 -0.5 0 -0.5 0 -0.45 0.05 curveto
1051 closepath ")
1052
1053 #(define (ps_rhombus_half_inner_side width height)
1054 "[0.7 -0.1 -0.1 0.7 0 0] concat
1055 0 0.5 moveto
1056 0 -0.5 lineto
1057 -0.5 0 lineto
1058 0 0.5 lineto closepath ")
1059
1060 %% ===================================================
1061 %  quadrata shapes (brevis and above)
1062 %% ===================================================
1063 #(define (ps_quadrata_outer_side width height)
1064   (format #f
1065 "~a ~a scale
1066 -0.5 0.45 moveto
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
1069 0.25 0.45 lineto
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
1072 0.5 -0.45 lineto
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
1075 -0.3 -0.45 lineto
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))
1079
1080 #(define (ps_quadrata_inner_side width height)
1081   (format #f
1082 "~a ~a scale
1083 -0.5 0.4 moveto
1084 -0.5 0.46 -0.46 0.5 -0.4 0.5 curveto
1085 0.4 0.5 lineto
1086 0.46 0.5 0.5 0.46 0.5 0.4 curveto
1087 0.5 -0.4 lineto
1088 0.5 -0.46 0.46 -0.5 0.4 -0.5 curveto
1089 -0.4 -0.5 lineto
1090 -0.46 -0.5 -0.5 -0.46 -0.5 -0.4 curveto
1091 closepath "
1092     (/ (- width (* 0.4 height)) width)
1093     0.65))
1094
1095 #(define (ps_quadrata_half_inner_side width height)
1096   (format #f
1097 "~a ~a scale
1098 0.5 0.4 moveto
1099 0.5 0.46 0.46 0.5 0.4 0.5 curveto
1100 0 0.5 lineto
1101 0 -0.5 lineto
1102 0.4 -0.5 lineto
1103 0.46 -0.5 0.5 -0.46 0.5 -0.4 curveto
1104 closepath "
1105     (/ (- width (* 0.3 height)) width)
1106     0.76))
1107
1108
1109 %% ===================================================
1110 %  pes shapes (slightly rounded quadrata to be used
1111 %  in ligatures)
1112 %% ===================================================
1113 #(define (ps_pes_outer_side width height . diffs)
1114   (let* ((yshift (if (> (length diffs) 0) (car diffs) 0)))
1115     (format #f
1116 "0 ~a translate
1117 ~a ~a scale
1118 -0.5 0.35 moveto
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
1121 0.5 -0.45 lineto
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)))
1125
1126 #(define (ps_pes_inner_side width height)
1127   (format #f
1128   "0 0.31 moveto
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)))))
1135
1136 #(define (ps_pes_half_inner_side width height)
1137   (format #f
1138   "0 0.31 moveto
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)))))
1143
1144
1145 %% ==============================================
1146 %  List of functions to combine into note shapes
1147 %% ==============================================
1148 #(define mensural_notehead_contour_funcs
1149   (list
1150     (cons 'quadrata
1151        (list ps_quadrata_outer_side
1152         ps_quadrata_inner_side
1153         ps_quadrata_half_inner_side))
1154     (cons 'rhombus
1155        (list ps_rhombus_outer_side
1156         ps_rhombus_inner_side
1157         ps_rhombus_half_inner_side))
1158     (cons 'pes
1159        (list ps_pes_outer_side
1160         ps_pes_inner_side
1161         ps_pes_half_inner_side))
1162     (cons 'obliqua
1163       (list ps_obliqua_outer_side
1164        ps_obliqua_inner_side
1165        ps_obliqua_inner_side))
1166     ))
1167
1168 %% =============================================
1169 %  List of available stem/flag additions
1170 %% =============================================
1171
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)))
1175    (string-append
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 " ""))))
1179
1180 #(define mensural_flags
1181  '(
1182   (stem_above .
1183    "newpath 0 0.51 moveto 0 1.8 rlineto stroke ")
1184
1185   (stem_below .
1186    "newpath 0 -0.51 moveto 0 -1.4 rlineto stroke ")
1187
1188   (flag_above_right .
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
1194     -0.06 0 rlineto
1195     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1196     closepath fill ")
1197
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
1204     -0.06 0 rlineto
1205     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1206     closepath fill
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
1210     -0.06 0 rlineto
1211     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1212     closepath fill ")
1213
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
1220     -0.06 0 rlineto
1221     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1222     closepath fill
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
1226     -0.06 0 rlineto
1227     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1228     closepath fill
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
1232     -0.06 0 rlineto
1233     -0.138 0.5 -0.49 0.46 -0.55 0.66 rcurveto
1234     closepath fill ")
1235
1236   (flag_above_left .
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
1242     0.06 0 rlineto
1243     0.138 0.5 0.49 0.46 0.55 0.66 rcurveto
1244     closepath fill ")
1245
1246   (flag_below right .
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
1252     -0.06 0 rlineto
1253     -0.138 -0.5 -0.49 -0.46 -0.55 -0.66 rcurveto
1254     closepath fill ")
1255
1256   (flag_below left .
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
1262     0.06 0 rlineto
1263     0.138 -0.5 0.49 -0.46 0.55 -0.66 rcurveto
1264     closepath fill ")
1265
1266   (vg_diagonal . "-0.33 0 moveto -0.558 -0.86 rlineto stroke ")
1267
1268   (dovetail_above . "0.45 1.19 moveto -0.45 -0.65 rlineto -0.45 0.65 rlineto stroke ")
1269
1270   (pigtail_above_right .
1271     "newpath 0 0.51 moveto
1272     0.0733 0 rlineto
1273     0 0.7263 rlineto
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
1277     0 -0.2422 rlineto
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
1281     0 -0.6775 rlineto
1282     closepath
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
1287     closepath fill ")
1288
1289   (dovetail_below  .
1290     "newpath 0 -0.51 moveto
1291     0 -0.6 rlineto
1292     -0.45 -0.7 rmoveto
1293      0.45  0.7 rlineto
1294      0.45 -0.7 rlineto
1295     stroke ")
1296
1297   (fishhook_below_right .
1298     "newpath 0.0 -0.5 moveto
1299     0 -0.8 rlineto
1300     0 -0.55 0.7 -0.55 0.7 0 rcurveto
1301     stroke ")
1302
1303   (fishhook_below_left .
1304     "newpath 0.0. -0.5 moveto
1305     0 -0.8 rlineto
1306     0 -0.55 -0.7 -0.55 -0.7 0 rcurveto
1307     stroke ")
1308
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
1322 closepath
1323 0.19 -1.08 rmoveto
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
1327 0 -0.125 rlineto
1328 0.0020787 -0.068953 0.03860102 -0.1619177 0.10546875 -0.191406 rcurveto
1329 closepath eofill ")
1330 ))
1331
1332 #(define mensural_c_clef
1333    (ly:make-stencil (list
1334      'embedded-ps
1335 "gsave currentpoint translate newpath
1336 -0.35 0 moveto
1337 1.4 1.4 scale
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 ")
1350    '(-0.8 . 0.8)
1351    '(0 . 0)))
1352
1353 #(define mensural_f_clef
1354    (ly:make-stencil (list
1355      'embedded-ps
1356 "gsave currentpoint translate newpath
1357 1.2 1.2 scale
1358 0.1 0.46 moveto
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
1368 0.33 -0.79 moveto
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
1379 -0.5 0.7 moveto
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 ")
1393    '(-1 . 1)
1394    '(0 . 0)))
1395
1396 #(define mensural_g_clef
1397    (ly:make-stencil (list
1398      'embedded-ps
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
1429 0 -0.1073  rlineto
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 ")
1436    '(-1.8 . 0.8)
1437    '(0 . 0)))
1438
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? )
1444   (let* ((mystencil
1445            (case type
1446              ((f) mensural_f_clef)
1447              ((g) mensural_g_clef)
1448              (else mensural_c_clef)))
1449          (linepos   (* 2 (- line 3)))
1450          (midCpos
1451            (case type
1452              ((f) (+ (* 2 (- line 3)) 4))
1453              ((g) (- (* 2 (- line 3)) 4))
1454              (else   (* 2 (- line 3))))))
1455
1456      (make-music
1457        'ContextSpeccedMusic
1458        'context-type 'Staff
1459        'element
1460          (make-music
1461            'SequentialMusic
1462            'elements (list
1463              (make-music
1464                'OverrideProperty
1465                ;'pop-first #t
1466                ;'once #t
1467                'symbol 'Clef
1468                'grob-property-path (list 'stencil)
1469                'grob-value mystencil)
1470              (make-music            ; dummy setting
1471                'PropertySet
1472                'symbol 'clefGlyph
1473                'value "clefs.C")
1474              (make-music
1475                'PropertySet
1476                'symbol 'middleCClefPosition
1477                'value midCpos)
1478              (make-music
1479                'PropertySet
1480                'symbol 'clefPosition
1481                'value linepos)
1482              (make-music
1483                'ApplyContext
1484                'procedure ly:set-middle-C!)
1485           )))))
1486
1487 %% ==============================================
1488 %  signature_stencil
1489 %% ==============================================
1490 #(define (signature_stencil sign)
1491   (cond
1492     ; sign is a custom stencil
1493     ((ly:stencil? sign)
1494       sign)
1495     ; sign is a glyph name
1496     ((string? sign)
1497       (lambda (grob) (grob-interpret-markup grob (markup (#:musicglyph sign)))))
1498     ; sign is a markup expression
1499     ((markup? sign)
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))))))))
1508
1509     ; sign is a rational number
1510     ((rational? sign)
1511       (let* ((num (numerator sign))
1512              (den (denominator sign))
1513              (marknum (markup (number->string num)))
1514              (markden (markup (number->string den))))
1515         (if (= 1 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
1521     (else
1522       empty-stencil)))
1523
1524 %% ==============================================
1525 %  Proportions
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))
1532           (sign (list
1533             (make-music                     ; = \override Staff.TimeSignature #'stencil =
1534               'ContextSpeccedMusic
1535               'context-type 'Staff
1536               'element (
1537                  make-music 'OverrideProperty
1538                   'pop-first #t
1539                   'once #t
1540                   'symbol 'TimeSignature
1541                   'grob-property-path '(stencil)
1542                   'grob-value stencil))
1543             (make-music
1544               'ContextSpeccedMusic
1545               'context-type 'Staff
1546               'descend-only #t
1547               'element (
1548                 make-music
1549                   'ContextSpeccedMusic
1550                   'context-type 'Timing
1551                   'element
1552                     (make-music
1553                       'PropertySet
1554                       'symbol 'timeSignatureFraction
1555                       'value '(4 . 4))))))
1556         )
1557     (make-music
1558       'SequentialMusic
1559       'elements (append
1560         sign
1561         (list
1562           (ly:music-compress music mom))))))
1563
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))))
1577         elements))
1578     hasrhythmicchild))
1579
1580
1581 %% ==============================================
1582 %  mensura command
1583 %% ==============================================
1584 mensura = #(define-music-function (parser location vals music) (list? ly:music?)
1585   (let* (
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))
1595           (beat      (if usetempus
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
1598
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)))
1606           (fakesign   (cond
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))
1613                          (              tempus              '(3 . 2))
1614                          (usetempus                         '(4 . 4))
1615                          (else #f))) ;dummy setting
1616           (glyphname (if fakesign
1617             (string-append
1618               "timesig.mensural"
1619               (number->string (car fakesign))
1620               (number->string (cdr fakesign)))
1621             ""))
1622           (signstencil
1623             (signature_stencil
1624               (cond
1625                 ; signature has been explicitly set to false: print nothing
1626                 ((and (pair? (assq 'sign vals)) (not sign))
1627                   #f)
1628                 ; use default mensuration signs
1629                 ((and usetempus (not (assq 'sign vals)))
1630                   glyphname)
1631                 (else
1632                   sign))))
1633           (unflagged_sm (assq-ref vals 'unflagged_sm))
1634           (basecolor  (or (assq-ref vals 'color) 'black))
1635           (noteglyphs
1636             (list
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
1661                             'rhombus
1662                             (case color (( black ) 'blackhollow ) (( white blackhollow hollow ) 'black) (else color))
1663                             1.3 1.1
1664                             'stem_above)
1665                           (make-mensural-note-stencil
1666                             'rhombus
1667                             color
1668                             1.3 1.1
1669                             'flag_above_right)))))
1670               (cons 'fu (lambda (color)
1671                 (or (assq-ref vals 'fu)                                   ;fu
1672                         (if unflagged_sm
1673                           (make-mensural-note-stencil
1674                             'rhombus
1675                             (case color (( black ) 'blackhollow ) (( white blackhollow hollow ) 'black) (else color))
1676                             1.3 1.1
1677                             'flag_above_right)
1678                           (make-mensural-note-stencil
1679                            'rhombus
1680                            color
1681                            1.3 1.1
1682                            'double_flag_above_right)))))
1683               (cons 'sf (lambda (color)
1684                 (or (assq-ref vals 'sf)                                   ;semifusa
1685                         (if unflagged_sm
1686                           (make-mensural-note-stencil
1687                             'rhombus
1688                             (case color (( black ) 'blackhollow ) (( white blackhollow hollow ) 'black) (else color))
1689                             1.3 1.1
1690                             'double_flag_above_right)
1691                           (make-mensural-note-stencil
1692                            'rhombus
1693                            color
1694                            1.3 1.1
1695                            'triple_flag_above_right)))))
1696              ))
1697              (notesettings
1698                (list
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))
1710                    (thisstencil #f))
1711               (if (assoc duration vals)
1712                 (set! thisstencil (assoc-ref vals duration))
1713                 (set! thisstencil ((assq-ref noteglyphs dur) thiscolor))
1714                )
1715               thisstencil)))
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))
1722                   )
1723               (if (<= durlog -2)
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)))
1730               (if (<= durlog -2)
1731                 (ly:grob::stencil-width grob)
1732                 (ly:rest::width grob)))))
1733
1734           (result (list
1735             (make-music
1736               'ContextSpeccedMusic
1737               'context-type 'Bottom
1738               'element
1739               (make-music
1740                 'OverrideProperty
1741                 'symbol 'NoteHead
1742                 'grob-property-path (list 'mensural_glyphs)
1743                 'grob-value notesettings))
1744             (make-music
1745               'ContextSpeccedMusic               ; = \set mensural_ligature_queue = #f
1746               'context-type 'Bottom
1747               'element
1748               (make-music
1749                 'PropertySet
1750                 'symbol 'mensural_ligature_queue
1751                 'value #f))
1752
1753             ;(make-music                         ; =   \override NoteHead #'X-extent = #widthfunction
1754             ;  'ContextSpeccedMusic
1755             ;  'context-type 'Bottom
1756             ;  'element
1757             ;  (make-music
1758             ;    'OverrideProperty
1759             ;    'pop-first #t
1760             ;    'symbol 'NoteHead
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
1766               'element
1767               (make-music
1768                 'OverrideProperty
1769                 'symbol 'Rest
1770                 'grob-property-path (list 'X-extent)
1771                 'grob-value widthfunction))
1772
1773             (make-music                         ; =   \override NoteHead #'stencil = #notestencilfunction
1774               'ContextSpeccedMusic
1775               'context-type 'Bottom
1776               'element
1777               (make-music
1778                 'OverrideProperty
1779                 'symbol 'NoteHead
1780                 'grob-property-path (list 'stencil)
1781                 'grob-value notestencilfunction))
1782
1783             (make-music                         ; =   \override Rest #'stencil = #reststencilfunction
1784               'ContextSpeccedMusic
1785               'context-type 'Bottom
1786               'element
1787               (make-music
1788                 'OverrideProperty
1789                 'symbol 'Rest
1790                 'grob-property-path (list 'stencil)
1791                 'grob-value reststencilfunction))
1792
1793
1794            (make-music
1795               'ContextSpeccedMusic              ; = \override Rest #'style = #'mensural
1796               'context-type 'Bottom
1797               'element
1798               (make-music
1799                 'OverrideProperty
1800                 'symbol 'Rest
1801                 'grob-property-path (list 'style)
1802                 'grob-value 'mensural))
1803             (make-music                     ; = \override Staff.TimeSignature #'stencil = #signstencil
1804               'ContextSpeccedMusic
1805               'context-type 'Staff
1806               'element (
1807                  make-music 'OverrideProperty
1808                   'once #t
1809                   'symbol 'TimeSignature
1810                   'grob-property-path '(stencil)
1811                   'grob-value signstencil))
1812             (make-music
1813               'ContextSpeccedMusic
1814               'context-type 'Staff
1815               'descend-only #t
1816               'element (
1817                 make-music
1818                   'ContextSpeccedMusic
1819                   'context-type 'Timing
1820                   'element (
1821                     make-music
1822                       'SequentialMusic
1823                       'elements (append
1824                         (if (pair? fakesign)
1825                           (list
1826                             (make-music
1827                               'PropertySet
1828                               'symbol 'timeSignatureFraction
1829                               'value fakesign))
1830                           '())
1831                         (list
1832                           ;(make-music
1833                           ;  'PropertySet
1834                           ;  'symbol 'beatLength
1835                           ;  'value beat)
1836                           (make-music
1837                             'PropertySet
1838                             'symbol 'measureLength
1839                             'value measurelength)
1840                           (make-music
1841                             'PropertySet
1842                             'symbol 'beatStructure
1843                             'value beatlist)
1844                           )))))))
1845
1846
1847        )
1848
1849    ;; now process the actual music, setting durations according to tempus/prolatio
1850    (music-map
1851      (lambda (event)
1852        (cond
1853          ;;every chord of the music needs to be prefixed
1854          ;;with an ApplyOutput call to our mensural_processing function
1855          ((rhythmicchord? event)
1856            (begin
1857              ;(display "prefixing an event-chord:\n")
1858              (make-music
1859                'SequentialMusic
1860                'elements
1861                (list
1862                  (make-music
1863                    'ApplyOutputEvent
1864                    'context-type 'Bottom
1865                    'procedure mensural_processing)
1866                    event))))
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)))))
1880                   (newevent '())
1881                  )
1882              ;(display (format #f "We have a rhythmic event: ~a\n" event))
1883              (case dur
1884                (( mx )  ; maxima
1885                  (set! newfactor (cons (* fprol ftemp fmod fmax) 16)))
1886                (( lg )  ; longa
1887                    (set! newfactor (cons (* fprol ftemp fmod) 8)))
1888                (( br )  ; breve
1889                  (set! newfactor (cons (* fprol ftemp) 4)))
1890                (( sb )   ; semibreve
1891                  (set! newfactor (cons fprol 2))))
1892              (set! newfactor (multiply newfactor durfactor))
1893              (ly:music-set-property!
1894                event
1895                'duration
1896                (ly:make-duration durlog dots (car newfactor) (cdr newfactor)))
1897
1898
1899
1900          event))
1901          (else event)
1902          ))
1903      newmusic)
1904
1905    ; apply proportion
1906    (if (!= dimin 1)
1907      (set! newmusic
1908        (ly:music-compress newmusic
1909                      (ly:make-moment (denominator dimin) (numerator dimin)))))
1910
1911    ; insert the time sig code together with the modified music
1912    (make-music
1913      'SequentialMusic
1914      'elements (append
1915       result
1916       (list
1917         newmusic
1918       )))
1919    ))
1920
1921 linea = #(define-music-function (parser location type) (string?)
1922 #{
1923   \once \override Staff.BarLine #'stencil = #ly:bar-line::print
1924   \bar $type
1925 #})
1926
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?)
1932   (let ((result '())
1933         (notecopy (ly:music-deep-copy note)))
1934     (music-map
1935       (lambda (event)
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)))
1940             (set! result
1941                   (make-music
1942                     'SequentialMusic
1943                     'elements (append (list
1944                       (make-music
1945                         'ContextSpeccedMusic
1946                         'context-type 'Bottom
1947                         'element (make-music
1948                           'OverrideProperty
1949                           'once #t
1950                           'symbol 'Accidental
1951                           'grob-property-path '(stencil)
1952                           'grob-value ly:accidental-interface::print))
1953                       (make-music
1954                         'ContextSpeccedMusic
1955                         'context-type 'Bottom
1956                         'element (make-music
1957                           'OverrideProperty
1958                           'once #t
1959                           'symbol 'Accidental
1960                           'grob-property-path '(glyph-name-alist)
1961                           'grob-value
1962                             (case notename
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
1965                        )))
1966                        (list note))))
1967             (ly:music-set-property! event 'force-accidental #t)
1968             )))
1969       notecopy)
1970     result ))
1971
1972
1973
1974