+;; Color
+
+(define-public color? list?)
+(define-public (rgb-color r g b) (list r g b))
+
+; predefined colors
+(define-public black '(0.0 0.0 0.0))
+(define-public white '(1.0 1.0 1.0))
+(define-public red '(1.0 0.0 0.0))
+(define-public green '(0.0 1.0 0.0))
+(define-public blue '(0.0 0.0 1.0))
+(define-public cyan '(0.0 1.0 1.0))
+(define-public magenta '(1.0 0.0 1.0))
+(define-public yellow '(1.0 1.0 0.0))
+
+(define-public grey '(0.5 0.5 0.5))
+(define-public darkred '(0.5 0.0 0.0))
+(define-public darkgreen '(0.0 0.5 0.0))
+(define-public darkblue '(0.0 0.0 0.5))
+(define-public darkcyan '(0.0 0.5 0.5))
+(define-public darkmagenta '(0.5 0.0 0.5))
+(define-public darkyellow '(0.5 0.5 0.0))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; key signature
+
+
+(define-public (key-signature-interface::alteration-position step alter c0-position)
+ ;; TODO: memoize - this is mostly constant.
+
+ ;; fes, ges, as and bes typeset in lower octave
+ (define FLAT_TOP_PITCH 2)
+
+ ;; ais and bis typeset in lower octave
+ (define SHARP_TOP_PITCH 4)
+
+ (if (pair? step)
+ (+ (cdr step) (* (car step) 7) c0-position)
+ (let*
+ ((from-bottom-pos (modulo (+ 4 49 c0-position) 7))
+ (p step)
+ (c0 (- from-bottom-pos 4)))
+
+ (if
+ (or (and (< alter 0) (or (> p FLAT_TOP_PITCH) (> (+ p c0) 4)) (> (+ p c0) 1))
+ (and (> alter 0) (or (> p SHARP_TOP_PITCH) (> (+ p c0) 5)) (> (+ p c0) 2))
+ )
+
+ ;; Typeset below c_position
+ (set! p (- p 7)))
+
+ ;; Provide for the four cases in which there's a glitch
+ ;; it's a hack, but probably not worth
+ ;; the effort of finding a nicer solution.
+ ;; --dl.
+ (cond
+ ((and (= c0 2) (= p 3) (> alter 0))
+ (set! p (- p 7)))
+ ((and (= c0 -3) (= p -1) (> alter 0))
+ (set! p (+ p 7)))
+ ((and (= c0 -4) (= p -1) (< alter 0))
+ (set! p (+ p 7)))
+ ((and (= c0 -2) (= p -3) (< alter 0))
+ (set! p (+ p 7))))
+
+ (+ c0 p))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; accidentals
+
+(define-public (accidental-interface::calc-alteration grob)
+ (ly:pitch-alteration (ly:event-property (event-cause grob) 'pitch)))
+
+
+(define-public cancellation-glyph-name-alist
+ '((0 . "accidentals.natural")))
+
+(define-public standard-alteration-glyph-name-alist
+ '(
+ ;; ordered for optimal performance.
+ (0 . "accidentals.natural")
+ (-1/2 . "accidentals.flat")
+ (1/2 . "accidentals.sharp")
+
+ (1 . "accidentals.doublesharp")
+ (-1 . "accidentals.flatflat")
+
+ (3/4 . "accidentals.sharp.slashslash.stemstemstem")
+ (1/4 . "accidentals.sharp.slashslash.stem")
+ (-1/4 . "accidentals.mirroredflat")
+ (-3/4 . "accidentals.mirroredflat.flat")
+ ))
+
+;; FIXME: standard vs default, alteration-FOO vs FOO-alteration
+(define-public alteration-default-glyph-name-alist standard-alteration-glyph-name-alist)
+
+(define-public makam-alteration-glyph-name-alist
+ '((1 . "accidentals.doublesharp")
+ (8/9 . "accidentals.sharp.slashslashslash.stemstem")
+ (5/9 . "accidentals.sharp.slashslashslash.stem")
+ (4/9 . "accidentals.sharp")
+ (1/9 . "accidentals.sharp.slashslash.stem")
+ (0 . "accidentals.natural")
+ (-1/9 . "accidentals.mirroredflat")
+ (-4/9 . "accidentals.flat.slash")
+ (-5/9 . "accidentals.flat")
+ (-8/9 . "accidentals.flat.slashslash")
+ (-1 . "accidentals.flatflat")
+ ))
+
+(define-public alteration-hufnagel-glyph-name-alist
+ '((-1/2 . "accidentals.hufnagelM1")
+ (0 . "accidentals.vaticana0")
+ (1/2 . "accidentals.mensural1")))
+
+(define-public alteration-medicaea-glyph-name-alist
+ '((-1/2 . "accidentals.medicaeaM1")
+ (0 . "accidentals.vaticana0")
+ (1/2 . "accidentals.mensural1")))
+
+(define-public alteration-vaticana-glyph-name-alist
+ '((-1/2 . "accidentals.vaticanaM1")
+ (0 . "accidentals.vaticana0")
+ (1/2 . "accidentals.mensural1")))
+
+(define-public alteration-mensural-glyph-name-alist
+ '((-1/2 . "accidentals.mensuralM1")
+ (0 . "accidentals.vaticana0")
+ (1/2 . "accidentals.mensural1")))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; * Pitch Trill Heads
+;; * Parentheses
+
+(define-public (parentheses-item::calc-parenthesis-stencils grob)
+ (let* ((font (ly:grob-default-font grob))
+ (lp (ly:font-get-glyph font "accidentals.leftparen"))
+ (rp (ly:font-get-glyph font "accidentals.rightparen")))
+
+ (list lp rp)))
+
+
+(define-public (grob-interpret-markup grob text)
+ (let*
+ ((layout (ly:grob-layout grob))
+ (defs (ly:output-def-lookup layout 'text-font-defaults))
+ (props (ly:grob-alist-chain grob defs)))
+
+ (ly:text-interface::interpret-markup
+ layout props text)))
+
+(define-public (parentheses-item::calc-angled-bracket-stencils grob)
+ (let* (
+ (font (ly:grob-default-font grob))
+ (lp (ly:stencil-aligned-to (ly:stencil-aligned-to (grob-interpret-markup grob (ly:wide-char->utf-8 #x2329))
+ Y CENTER) X RIGHT))
+ (rp (ly:stencil-aligned-to (ly:stencil-aligned-to (grob-interpret-markup grob (ly:wide-char->utf-8 #x232A))
+ Y CENTER) X LEFT))
+ )