scm/output-lib.scm

   1 ;;;; output-lib.scm -- implement Scheme output helper functions
   2 ;;;;
   3 ;;;;  source file of the GNU LilyPond music typesetter
   4 ;;;;
   5 ;;;; (c) 1998--2006 Jan Nieuwenhuizen <janneke@gnu.org>
   6 ;;;; Han-Wen Nienhuys <hanwen@cs.uu.nl>
   7
   8
   9
  10 (define-public (event-cause grob)
  11   (let*
  12       ((cause (ly:grob-property  grob 'cause)))
  13
  14     (cond
  15      ((ly:stream-event? cause) cause)
  16      ((ly:grob? cause) (event-cause cause))
  17      (else #f))))
  18
  19 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20 ;; note heads
  21
  22 (define-public (note-head::calc-duration-log grob)
  23   (ly:duration-log
  24    (ly:event-property (event-cause grob) 'duration)))
  25
  26 (define-public (dots::calc-dot-count grob)
  27   (ly:duration-dot-count
  28    (ly:event-property (event-cause grob) 'duration)))
  29
  30 ;; The TabNoteHead stem attachment function.
  31 (define (note-head::calc-tablature-stem-attachment grob)
  32   (cons 0.0 1.35))
  33
  34 ;; The TabNoteHead tablatureFormat callback.
  35 ;; Compute the text grob-property
  36 (define-public (fret-number-tablature-format string tuning pitch)
  37   (make-whiteout-markup
  38    (make-vcenter-markup
  39     (number->string
  40      (- (ly:pitch-semitones pitch)
  41         (list-ref tuning
  42                   ;; remove 1 because list index starts at 0 and guitar string at 1.
  43                   (- string 1)))))))
  44
  45 ;; The 5-string banjo has got a extra string, the fifth (duh), wich
  46 ;; starts at the fifth fret on the neck. Frets on the fifth string
  47 ;; are referred to relative to the other frets:
  48 ;;   the "first fret" on the fifth string is really the sixth fret
  49 ;;   on the banjo neck.
  50 ;; We solve this by defining a new fret-number-tablature function:
  51 (define-public (fret-number-tablature-format-banjo string tuning pitch)
  52   (make-whiteout-markup
  53    (make-vcenter-markup
  54     (let ((fret (- (ly:pitch-semitones pitch) (list-ref tuning (- string 1)))))
  55       (number->string (cond
  56                        ((and (> fret 0) (= string 5))
  57                         (+ fret 5))
  58                        (else fret)))))))
  59
  60
  61 ; default tunings for common string instruments
  62 (define-public guitar-tuning '(4 -1 -5 -10 -15 -20))
  63 (define-public guitar-open-g-tuning '(2 -1 -5 -10 -17 -22))
  64 (define-public bass-tuning '(-17 -22 -27 -32))
  65 (define-public mandolin-tuning '(16 9 2 -5))
  66
  67 ;; tunings for 5-string banjo
  68 (define-public banjo-open-g-tuning '(2 -1 -5 -10 7))
  69 (define-public banjo-c-tuning '(2 -1 -5 -12 7))
  70 (define-public banjo-modal-tuning '(2 0 -5 -10 7))
  71 (define-public banjo-open-d-tuning '(2 -3 -6 -10 9))
  72 (define-public banjo-open-dm-tuning '(2 -3 -6 -10 9))
  73 ;; convert 5-string banjo tuning to 4-string by removing the 5th string
  74 (define-public (four-string-banjo tuning)
  75   (reverse (cdr (reverse tuning))))
  76
  77 ;;; end of tablature functions
  78
  79 (define-public (make-stencil-boxer thickness padding callback)
  80
  81   "Return function that adds a box around the grob passed as argument."
  82   (lambda (grob)
  83
  84     (box-stencil (callback grob) thickness padding)))
  85
  86 (define-public (make-stencil-circler thickness padding callback)
  87   "Return function that adds a circle around the grob passed as argument."
  88   (lambda (grob) (circle-stencil (callback grob) thickness padding)))
  89
  90 (define-public (arg->string arg)
  91   (cond ((number? arg) (ly:inexact->string arg 10))
  92         ((string? arg) (string-append "\"" arg "\""))
  93         ((symbol? arg) (string-append "\"" (symbol->string arg) "\""))))
  94
  95 (define-public (print-circled-text-callback grob)
  96   (let* ((text (ly:grob-property grob 'text))
  97
  98          (layout (ly:grob-layout grob))
  99          (defs (ly:output-def-lookup layout 'text-font-defaults))
 100          (props (ly:grob-alist-chain grob defs))
 101          (circle (ly:text-interface::interpret-markup
 102                   layout props (make-circle-markup text))))
 103     circle))
 104
 105 ;; silly, use alist?
 106 (define-public (note-head::calc-glyph-name grob)
 107   (let*
 108       ((style (ly:grob-property grob 'style))
 109        (log (min 2 (ly:grob-property grob 'duration-log))))
 110
 111     (case style
 112       ((xcircle) "2xcircle")
 113       ((harmonic) "0harmonic")
 114       ((baroque)
 115        ;; Oops, I actually would not call this "baroque", but, for
 116        ;; backwards compatibility to 1.4, this is supposed to take
 117        ;; brevis, longa and maxima from the neo-mensural font and all
 118        ;; other note heads from the default font.  -- jr
 119        (if (< log 0)
 120            (string-append (number->string log) "neomensural")
 121            (number->string log)))
 122       ((mensural)
 123        (string-append (number->string log) (symbol->string style)))
 124       ((petrucci)
 125        (if (< log 0)
 126            (string-append (number->string log) "mensural")
 127            (string-append (number->string log) (symbol->string style))))
 128       ((neomensural)
 129        (string-append (number->string log) (symbol->string style)))
 130       ((default)
 131        ;; The default font in mf/feta-bolletjes.mf defines a brevis, but
 132        ;; neither a longa nor a maxima.  Hence let us, for the moment,
 133        ;; take these from the neo-mensural font.  TODO: mf/feta-bolletjes
 134        ;; should define at least a longa for the default font.  The longa
 135        ;; should look exactly like the brevis of the default font, but
 136        ;; with a stem exactly like that of the quarter note. -- jr
 137        (if (< log -1)
 138            (string-append (number->string log) "neomensural")
 139            (number->string log)))
 140       (else
 141        (if (string-match "vaticana*|hufnagel*|medicaea*" (symbol->string style))
 142            (symbol->string style)
 143            (string-append (number->string (max 0 log))
 144                           (symbol->string style)))))))
 145
 146 ;; TODO junk completely?
 147 (define (note-head-style->attachment-coordinates grob axis)
 148   "Return pair (X . Y), containing multipliers for the note head
 149 bounding box, where to attach the stem. e.g.: X==0 means horizontally
 150 centered, X==1 is at the right, X == -1 is at the left."
 151
 152   '(1.0 . 0.0))
 153
 154 (define-public (string-encode-integer i)
 155   (cond
 156    ((= i  0) "o")
 157    ((< i 0)   (string-append "n" (string-encode-integer (- i))))
 158    (else (string-append
 159           (make-string 1 (integer->char (+ 65 (modulo i 26))))
 160           (string-encode-integer (quotient i 26))))))
 161
 162 (define-public ((every-nth-bar-number-visible n) barnum) (= 0 (modulo barnum n)))
 163
 164 (define-public ((modulo-bar-number-visible n m) barnum) (and (> barnum 1) (= m (modulo barnum n))))
 165
 166 (define-public ((set-bar-number-visibility n) tr)
 167   (let* ((bn (ly:context-property tr 'currentBarNumber)))
 168     (ly:context-set-property! tr 'barNumberVisibility (modulo-bar-number-visible n (modulo bn n)))))
 169
 170 (define-public (first-bar-number-invisible barnum) (> barnum 1))
 171
 172 ;; See documentation of ly:item::visibility-lambda-
 173 (define-public begin-of-line-visible
 174   #(#f #f #t))
 175 (define-public end-of-line-visible
 176   #(#t #f #f))
 177 (define-public end-of-line-invisible
 178   #(#f #t #t))
 179 (define-public spanbar-begin-of-line-invisible
 180   #(#t #f #f))
 181 (define-public all-visible #(#t #t #t))
 182 (define-public all-invisible #(#f #f #f))
 183 (define-public begin-of-line-invisible
 184   #(#t #t #f))
 185 (define-public center-invisible #(#t #f #t))
 186
 187 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 188 ;; Bar lines.
 189
 190 ;;
 191 ;; How should a  bar line behave at a break?
 192 ;;
 193 ;; Why prepend `default-' to every scm identifier?
 194 (define-public (bar-line::calc-glyph-name grob)
 195   (let* (
 196          (glyph (ly:grob-property grob 'glyph))
 197          (dir (ly:item-break-dir grob))
 198          (result (assoc glyph
 199                        '((":|:" . (":|" . "|:"))
 200                          ("||:" . ("||" . "|:"))
 201                          ("dashed" . ("dashed" . '()))
 202                          ("|" . ("|" . ()))
 203                          ("||:" . ("||" . "|:"))
 204                          ("|s" . (() . "|"))
 205                          ("|:" . ("|" . "|:"))
 206                          ("|." . ("|." . ()))
 207
 208                          ;; hmm... should we end with a bar line here?
 209                          (".|" . ("|" . ".|"))
 210                          (":|" . (":|" . ()))
 211                          ("||" . ("||" . ()))
 212                          (".|." . (".|." . ()))
 213                          ("" . ("" . ""))
 214                          (":" . (":" . ""))
 215                          ("." . ("." . ()))
 216                          ("empty" . (() . ()))
 217                          ("brace" . (() . "brace"))
 218                          ("bracket" . (() . "bracket"))  )))
 219          (glyph-name (if (= dir CENTER)
 220                          glyph
 221                          (if (and result (string? (index-cell (cdr result) dir)))
 222                              (index-cell (cdr result) dir)
 223                              #f)))
 224          )
 225
 226     (if (not glyph-name)
 227         (ly:grob-suicide! grob))
 228
 229     glyph-name))
 230
 231
 232 (define-public (shift-right-at-line-begin g)
 233   "Shift an item to the right, but only at the start of the line."
 234   (if (and (ly:item? g)
 235            (equal? (ly:item-break-dir g) RIGHT))
 236       (ly:grob-translate-axis! g 3.5 X)))
 237
 238
 239 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 240 ;; Tuplets
 241
 242 (define-public (tuplet-number::calc-denominator-text grob)
 243   (let*
 244       ((ev (ly:grob-property grob 'cause)))
 245
 246     (number->string (ly:event-property ev 'denominator))))
 247
 248
 249 (define-public (tuplet-number::calc-fraction-text grob)
 250   (let*
 251       ((ev (ly:grob-property grob 'cause)))
 252     (format "~a:~a"
 253       (ly:event-property ev 'denominator)
 254       (ly:event-property ev 'numerator))))
 255
 256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 257 ;; Color
 258
 259 (define-public color? list?)
 260
 261 ; predefined colors
 262 (define-public black       '(0.0 0.0 0.0))
 263 (define-public white       '(1.0 1.0 1.0))
 264 (define-public red         '(1.0 0.0 0.0))
 265 (define-public green       '(0.0 1.0 0.0))
 266 (define-public blue        '(0.0 0.0 1.0))
 267 (define-public cyan        '(0.0 1.0 1.0))
 268 (define-public magenta     '(1.0 0.0 1.0))
 269 (define-public yellow      '(1.0 1.0 0.0))
 270
 271 (define-public grey        '(0.5 0.5 0.5))
 272 (define-public darkred     '(0.5 0.0 0.0))
 273 (define-public darkgreen   '(0.0 0.5 0.0))
 274 (define-public darkblue    '(0.0 0.0 0.5))
 275 (define-public darkcyan    '(0.0 0.5 0.5))
 276 (define-public darkmagenta '(0.5 0.0 0.5))
 277 (define-public darkyellow  '(0.5 0.5 0.0))
 278
 279 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 280 ;; * Pitch Trill Heads
 281 ;; * Parentheses
 282
 283 (define (parenthesize-elements grob . rest)
 284   (let*
 285       ((refp (if (null? rest)
 286                  grob
 287                  (car rest)))
 288        (elts (ly:grob-object grob 'elements))
 289        (x-ext (ly:relative-group-extent elts refp X))
 290
 291        (font (ly:grob-default-font grob))
 292        (lp (ly:font-get-glyph font "accidentals.leftparen"))
 293        (rp (ly:font-get-glyph font "accidentals.rightparen"))
 294        (padding (ly:grob-property grob 'padding 0.1)))
 295
 296     (ly:stencil-add
 297      (ly:stencil-translate-axis lp (- (car x-ext) padding) X)
 298      (ly:stencil-translate-axis rp (+ (cdr x-ext) padding) X))
 299   ))
 300
 301
 302 (define (parentheses-item::print me)
 303   (let*
 304       ((elts (ly:grob-object me 'elements))
 305        (y-ref (ly:grob-common-refpoint-of-array me elts Y))
 306        (x-ref (ly:grob-common-refpoint-of-array me elts X))
 307        (stencil (parenthesize-elements me x-ref))
 308        (elt-y-ext  (ly:relative-group-extent elts y-ref Y))
 309        (y-center (interval-center elt-y-ext)))
 310
 311     (ly:stencil-translate
 312      stencil
 313      (cons
 314       (-
 315        (ly:grob-relative-coordinate me x-ref X))
 316       (-
 317        y-center
 318        (ly:grob-relative-coordinate me y-ref Y))))
 319     ))
 320
 321
 322
 323
 324 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 325 ;;
 326
 327 (define-public (chain-grob-member-functions grob value . funcs)
 328   (for-each
 329    (lambda (func)
 330      (set! value (func grob value)))
 331    funcs)
 332
 333   value)
 334
 335 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 336 ;; falls
 337
 338 (define-public (fall::print spanner)
 339   (let*
 340       ((delta-y (* 0.5 (ly:grob-property spanner 'delta-position)))
 341        (left-span (ly:spanner-bound spanner LEFT))
 342        (right-span (ly:spanner-bound spanner RIGHT))
 343        (thickness (* (ly:grob-property spanner 'thickness)
 344                      (ly:output-def-lookup (ly:grob-layout spanner)
 345                                            'line-thickness)))
 346        (padding (ly:grob-property spanner 'padding 0.5))
 347        (common (ly:grob-common-refpoint right-span
 348                                         (ly:grob-common-refpoint spanner
 349                                                 left-span X)
 350                                         X))
 351        (left-x (+ padding  (interval-end  (ly:grob-robust-relative-extent left-span common X))))
 352        (right-x (- (interval-start  (ly:grob-robust-relative-extent right-span common X)) padding))
 353        (self-x (ly:grob-relative-coordinate spanner common X))
 354        (dx (- right-x left-x))
 355        (exp (list 'path thickness
 356                   `(quote
 357                     (rmoveto
 358                      ,(- left-x self-x) 0
 359
 360                      rcurveto
 361                      ,(/ dx 3)
 362                      0
 363                      ,dx ,(* 0.66 delta-y)
 364                      ,dx ,delta-y
 365                      ))))
 366        )
 367
 368     (ly:make-stencil
 369      exp
 370      (cons 0 dx)
 371      (cons (min 0 delta-y)
 372            (max 0 delta-y)))))
 373
 374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375 ;; grace spacing
 376
 377
 378 (define-public (grace-spacing::calc-shortest-duration grob)
 379   (let*
 380      ((cols (ly:grob-object grob 'columns))
 381       (get-difference
 382        (lambda (idx)
 383          (ly:moment-sub (ly:grob-property (ly:grob-array-ref cols (1+ idx)) 'when)
 384                         (ly:grob-property (ly:grob-array-ref cols idx) 'when))))
 385
 386       (moment-min (lambda (x y)
 387                     (cond
 388                      ((and x y)
 389                       (if (ly:moment<? x y)
 390                             x
 391                             y))
 392                      (x x)
 393                      (y y)))))
 394
 395     (fold moment-min #f (map get-difference
 396                              (iota (1- (ly:grob-array-length cols)))))))
 397
 398
 399
 400 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 401 ;; fingering
 402
 403 (define-public (fingering::calc-text grob)
 404   (let*
 405       ((event (ly:grob-property grob 'cause))
 406        (digit (ly:event-property event 'digit)))
 407
 408     (if (> digit 5)
 409         (ly:input-message (ly:music-property event 'origin)
 410                           "Music for the martians"))
 411
 412     (number->string digit 10)
 413   ))
 414
 415 (define-public (string-number::calc-text grob)
 416   (let*
 417       ((event (ly:grob-property grob 'cause))
 418        (digit (ly:event-property event 'string-number)))
 419
 420     (number->string digit 10)
 421   ))