scm/flag-styles.scm

   1 ;;;;  flag-styles.scm
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPOnd music typesetter
   4 ;;;;
   5
   6 (define-public (no-flag stem-grob)
   7   "No flag: Simply return empty stencil"
   8   empty-stencil)
   9
  10
  11 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12 ;;;;  Straight flags
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15
  16 (define-public (add-stroke-straight stencil stem-grob stem-up? log stroke-style offset length thickness stroke-thickness)
  17   "Add the stroke for acciaccatura to the given flag stencil."
  18   (let* ((udmult (if stem-up? 1 -1))
  19          (start (offset-add offset (cons 0  (* (/ length 2) udmult))))
  20          (end (offset-add (cons 0 (cdr offset))
  21                           (cons (- (/ (car offset) 2)) (* (- (+ thickness (car offset))) udmult))))
  22          (stroke (make-line-stencil stroke-thickness (car start) (cdr start) (car end) (cdr end))))
  23   (ly:stencil-add stencil stroke)))
  24
  25 (define (polar->rectangular radius angle-in-degrees)
  26   "Convert polar coordinate @code{radius} and @code{angle-in-degrees}
  27    to (x-length . y-length)"
  28   (let* ((conversion-constant (/ (atan 1 1) 45))
  29          (complex (make-polar
  30                     radius
  31                     (* conversion-constant angle-in-degrees))))
  32      (cons
  33        (real-part complex)
  34        (imag-part complex))))
  35
  36 (define (buildflag flag-stencil remain curr-stencil spacing)
  37   (if (> remain 0)
  38       (let* ((translated-stencil (ly:stencil-translate-axis curr-stencil spacing Y))
  39              (new-stencil (ly:stencil-add flag-stencil translated-stencil)))
  40         (buildflag new-stencil (- remain 1) translated-stencil spacing))
  41       flag-stencil))
  42
  43 (define-public (straight-flag flag-thickness flag-spacing
  44                        upflag-angle upflag-length
  45                        downflag-angle downflag-length)
  46     "Create a stencil for a straight flag.
  47      flag-thickness, -spacing are given in staff spaces,
  48      *flag-angle is given in degree,
  49      *flag-length is given in staff spaces"
  50   (lambda (stem-grob)
  51     (let* ((log (ly:grob-property stem-grob 'duration-log))
  52            (layout (ly:grob-layout stem-grob))
  53            (stem-up? (eqv? (ly:grob-property stem-grob 'direction) UP))
  54            ; scale with the note size (e.g. for grace notes). Default fontsize
  55            ; is fs==0, each step is ~12.246% larger / smaller
  56            (fs (ly:grob-property stem-grob 'font-size))
  57            (factor (if (number? fs) (expt 1.12246 fs) 1))
  58            (grob-stem-thickness (ly:grob-property stem-grob 'thickness))
  59            (line-thickness (ly:output-def-lookup layout 'line-thickness))
  60            (half-stem-thickness (/ (* grob-stem-thickness line-thickness) 2))
  61            (up-length (+ (* upflag-length factor) half-stem-thickness))
  62            (up-off (polar->rectangular up-length upflag-angle))
  63            (down-length (+ (* downflag-length factor) half-stem-thickness))
  64            (down-off (polar->rectangular down-length downflag-angle))
  65            (thickness (* flag-thickness factor))
  66            (offset (cons 0 (if stem-up? (- thickness) thickness)))
  67            (spacing (* flag-spacing factor (if stem-up? -1 1)))
  68            (start (cons (- half-stem-thickness) (if stem-up? half-stem-thickness (- half-stem-thickness))))
  69            (points (if stem-up? (list start up-off
  70                                       (offset-add up-off offset)
  71                                       (offset-add start offset))
  72                                 (list start
  73                                       (offset-add start offset)
  74                                       (offset-add down-off offset)
  75                                       down-off)))
  76            (stencil (ly:round-filled-polygon points half-stem-thickness))
  77            ; Log for 1/8 is 3, so we need to subtract 3
  78            (flag-stencil (buildflag stencil (- log 3) stencil spacing))
  79            (stroke-style (ly:grob-property stem-grob 'stroke-style)))
  80     (if (null? stroke-style)
  81       flag-stencil
  82       (add-stroke-straight flag-stencil stem-grob
  83                            stem-up? log
  84                            stroke-style
  85                            (if stem-up? up-off down-off)
  86                            (if stem-up? up-length down-length)
  87                            thickness
  88                            (* half-stem-thickness 2))))))
  89
  90 ;; Modern straight flags: angles are not as large as in the old style
  91 (define-public (modern-straight-flag stem-grob)
  92   ((straight-flag 0.55 1 -18 1.1 22 1.2) stem-grob))
  93
  94 ;; Old-straight flags (Bach, etc.): quite large flag angles
  95 (define-public (old-straight-flag stem-grob)
  96   ((straight-flag 0.55 1 -45 1.2 45 1.4) stem-grob))
  97
  98
  99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 100 ;;;;  Flags created from feta glyphs (normal and mensural flags)
 101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 102
 103
 104 ; NOTE: By default, lilypond uses the C++ method Stem::calc-flag
 105 ; (ly:stem::calc-flag is the corresponding Scheme interface) to generate the
 106 ; flag stencil. The following functions are simply a reimplementation in
 107 ; Scheme, so that one has that functionality available in Scheme, if one
 108 ; wants to write a flag style, which modifies one of the standard flags
 109 ; by some stencil operations.
 110
 111
 112 (define-public (add-stroke-glyph stencil stem-grob dir stroke-style flag-style)
 113   "Load and add a stroke (represented by a glyph in the font) to the given
 114    flag stencil"
 115   (if (not (string? stroke-style))
 116     stencil
 117     ; Otherwise: look up the stroke glyph and combine it with the flag
 118     (let* ((font-char (string-append "flags." flag-style dir stroke-style))
 119            (alt-font-char (string-append "flags." dir stroke-style))
 120            (font (ly:grob-default-font stem-grob))
 121            (tmpstencil (ly:font-get-glyph font font-char))
 122            (stroke-stencil (if (ly:stencil-empty? tmpstencil)
 123                                (ly:font-get-glyph font alt-font-char)
 124                                tmpstencil)))
 125       (if (ly:stencil-empty? stroke-stencil)
 126         (begin
 127           (ly:warning (_ "flag stroke `~a' or `~a' not found") font-char alt-font-char)
 128           stencil)
 129         (ly:stencil-add stencil stroke-stencil)))))
 130
 131
 132 (define-public (retrieve-glyph-flag flag-style dir dir-modifier stem-grob)
 133   "Load the correct flag glyph from the font"
 134   (let* ((log (ly:grob-property stem-grob 'duration-log))
 135          (font (ly:grob-default-font stem-grob))
 136          (font-char (string-append "flags." flag-style dir dir-modifier (number->string log)))
 137          (flag (ly:font-get-glyph font font-char)))
 138     (if (ly:stencil-empty? flag)
 139       (ly:warning "flag ~a not found" font-char))
 140     flag))
 141
 142
 143 (define-public (create-glyph-flag flag-style dir-modifier stem-grob)
 144   "Create a flag stencil by looking up the glyph from the font"
 145   (let* ((dir (if (eqv? (ly:grob-property stem-grob 'direction) UP) "u" "d"))
 146          (flag (retrieve-glyph-flag flag-style dir dir-modifier stem-grob))
 147          (stroke-style (ly:grob-property stem-grob 'stroke-style)))
 148     (if (null? stroke-style)
 149       flag
 150       (add-stroke-glyph flag stem-grob dir stroke-style flag-style))))
 151
 152
 153
 154 (define-public (mensural-flag stem-grob)
 155   "Mensural flags: Create the flag stencil by loading the glyph from the font.
 156    Flags are always aligned with staff lines, so we need to check the end point
 157    of the stem: For stems ending on staff lines, use different flags than for
 158    notes between staff lines.  The idea is that flags are always vertically
 159    aligned with the staff lines, regardless of whether the note head is on a
 160    staff line or between two staff lines.  In other words, the inner end of
 161    a flag always touches a staff line."
 162
 163   (let* ((adjust #t)
 164          (stem-end (inexact->exact (round (ly:grob-property stem-grob 'stem-end-position))))
 165          ; For some reason the stem-end is a real instead of an integer...
 166          (dir-modifier (if (ly:position-on-line? stem-grob stem-end) "1" "0"))
 167          (modifier (if adjust dir-modifier "2")))
 168     (create-glyph-flag "mensural" modifier stem-grob)))
 169
 170
 171
 172 (define-public ((glyph-flag flag-style) stem-grob)
 173   "Simulates the default way of generating flags: look up glyphs
 174    flags.style[ud][1234] from the feta font and use it for the flag stencil."
 175   (create-glyph-flag flag-style "" stem-grob))
 176
 177
 178
 179 (define-public (normal-flag stem-grob)
 180   "Create a default flag"
 181   (create-glyph-flag "" "" stem-grob))
 182
 183
 184
 185 (define-public (default-flag stem-grob)
 186   "Create a flag stencil for the stem. Its style will be derived from the
 187    @code{'flag-style} Stem property. By default, @code{lilypond} uses a
 188    C++ Function (which is slightly faster) to do exactly the same as this
 189    function. However, if one wants to modify the default flags, this function
 190    can be used to obtain the default flag stencil, which can then be modified
 191    at will. The correct way to do this is:
 192 @example
 193 \\override Stem #'flag = #default-flag
 194 \\override Stem #'flag-style = #'mensural
 195 @end example
 196 "
 197   (let* ((flag-style-symbol (ly:grob-property stem-grob 'flag-style))
 198          (flag-style (if (symbol? flag-style-symbol)
 199                          (symbol->string flag-style-symbol)
 200                          "")))
 201     (cond
 202         ((equal? flag-style "") (normal-flag stem-grob))
 203         ((equal? flag-style "mensural") (mensural-flag stem-grob))
 204         ((equal? flag-style "no-flag") (no-flag stem-grob))
 205         (else ((glyph-flag flag-style) stem-grob)))))