scm/define-markup-commands.scm

   1
   2
   3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   4 ;;; markup commands
   5 ;; TODO:
   6 ;; each markup function should have a doc string with
   7 ;; syntax, description and example.
   8 ;;
   9
  10
  11 (def-markup-command (simple paper props str) (string?)
  12   "A simple text-string; @code{\\markup @{ foo @}} is equivalent with
  13 @code{\\markup @{ \\simple #\"foo\" @}}.
  14 "
  15   (interpret-markup paper props str))
  16
  17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  18 ;; fonts
  19
  20 (define (font-markup qualifier value)
  21   (lambda (paper props arg)
  22     (interpret-markup paper
  23                       (prepend-alist-chain qualifier value props)
  24                       arg)))
  25
  26
  27
  28 (define-public empty-markup
  29   (make-simple-markup ""))
  30
  31 (def-markup-command (line paper props args) (markup-list?)
  32   "Put @var{args} in a horizontal line. The property @code{word-space} determines
  33 the space between each markup in @var{args}.
  34 "
  35   (stack-stencil-line
  36    (cdr (chain-assoc 'word-space props))
  37    (map (lambda (m) (interpret-markup paper props m)) args)))
  38
  39 (def-markup-command (combine paper props m1 m2) (markup? markup?)
  40   "Print two markups on top of each other."
  41   (ly:stencil-add
  42    (interpret-markup paper props m1)
  43    (interpret-markup paper props m2)))
  44
  45
  46 (def-markup-command (finger paper props arg) (markup?)
  47   "Set the argument as small numbers."
  48   (interpret-markup paper
  49                     (cons '((font-size . -4) (font-family . number)) props)
  50                     arg))
  51
  52
  53 (def-markup-command (fontsize paper props mag arg) (number? markup?)
  54   "This sets the relative font size, eg.
  55 @example
  56 A \\fontsize #2 @{ B C @} D
  57 @end example
  58
  59
  60 This will enlarge the B and the C by two steps.
  61 "
  62   (interpret-markup
  63    paper
  64    (prepend-alist-chain 'font-size mag props)
  65    arg))
  66
  67 (def-markup-command (magnify paper props sz arg) (number? markup?)
  68   "This sets the font magnification for the its argument. In the following
  69 example, the middle A will be 10% larger:
  70 @example
  71 A \\magnify #1.1 @{ A @} A
  72 @end example
  73
  74 Note: magnification only works if a font-name is explicitly selected.
  75 Use @code{\\fontsize} otherwise."
  76
  77   (interpret-markup
  78    paper
  79    (prepend-alist-chain 'font-magnification sz props)
  80    arg))
  81
  82 (def-markup-command (bold paper props arg) (markup?)
  83   "Switch to bold font-series"
  84   (interpret-markup paper (prepend-alist-chain 'font-series 'bold props) arg))
  85
  86 (def-markup-command (sans paper props arg) (markup?)
  87   "Switch to the sans-serif family"
  88   (interpret-markup paper (prepend-alist-chain 'font-family 'sans props) arg))
  89
  90 (def-markup-command (number paper props arg) (markup?)
  91   "Set font family to @code{number}, which yields the font used for
  92 time signatures and fingerings.  This font only contains numbers and
  93 some punctuation. It doesn't have any letters.  "
  94   (interpret-markup paper (prepend-alist-chain 'font-family 'number props) arg))
  95
  96 (def-markup-command (roman paper props arg) (markup?)
  97   "Set font family to @code{roman}."
  98   (interpret-markup paper (prepend-alist-chain 'font-family 'roman props) arg))
  99
 100 (def-markup-command (huge paper props arg) (markup?)
 101   "Set font size to +2."
 102   (interpret-markup paper (prepend-alist-chain 'font-size 2 props) arg))
 103
 104 (def-markup-command (large paper props arg) (markup?)
 105   "Set font size to +1."
 106   (interpret-markup paper (prepend-alist-chain 'font-size 1 props) arg))
 107
 108 (def-markup-command (normalsize paper props arg) (markup?)
 109   "Set font size to default."
 110   (interpret-markup paper (prepend-alist-chain 'font-size 0 props) arg))
 111
 112 (def-markup-command (small paper props arg) (markup?)
 113   "Set font size to -1."
 114   (interpret-markup paper (prepend-alist-chain 'font-size -1 props) arg))
 115
 116 (def-markup-command (tiny paper props arg) (markup?)
 117   "Set font size to -2."
 118   (interpret-markup paper (prepend-alist-chain 'font-size -2 props) arg))
 119
 120 (def-markup-command (teeny paper props arg) (markup?)
 121   "Set font size to -3."
 122   (interpret-markup paper (prepend-alist-chain 'font-size -3 props) arg))
 123
 124 (def-markup-command (dynamic paper props arg) (markup?)
 125   "Use the dynamic font.  This font only contains s, f, m, z, p, and
 126 r.  When producing phrases, like ``piu f'', the normal words (like
 127 ``piu'') should be done in a different font.
 128 The recommend font for this is bold and italic
 129 "
 130   (interpret-markup paper (prepend-alist-chain 'font-family 'dynamic props) arg))
 131
 132 (def-markup-command (italic paper props arg) (markup?)
 133   (interpret-markup paper (prepend-alist-chain 'font-shape 'italic props) arg))
 134
 135 (def-markup-command (typewriter paper props arg) (markup?)
 136   (interpret-markup paper (prepend-alist-chain 'font-family 'typewriter props) arg))
 137
 138 (def-markup-command (doublesharp paper props) ()
 139   (interpret-markup paper props (markup #:musicglyph "accidentals-4")))
 140 (def-markup-command (threeqsharp paper props) ()
 141   (interpret-markup paper props (markup #:musicglyph "accidentals-3")))
 142 (def-markup-command (sharp paper props) ()
 143   (interpret-markup paper props (markup #:musicglyph "accidentals-2")))
 144 (def-markup-command (semisharp paper props) ()
 145   (interpret-markup paper props (markup #:musicglyph "accidentals-1")))
 146 (def-markup-command (natural paper props) ()
 147   (interpret-markup paper props (markup #:musicglyph "accidentals-0")))
 148 (def-markup-command (semiflat paper props) ()
 149   (interpret-markup paper props (markup #:musicglyph "accidentals--1")))
 150 (def-markup-command (flat paper props) ()
 151   (interpret-markup paper props (markup #:musicglyph "accidentals--2")))
 152 (def-markup-command (threeqflat paper props) ()
 153   (interpret-markup paper props (markup #:musicglyph "accidentals--3")))
 154 (def-markup-command (doubleflat paper props) ()
 155   (interpret-markup paper props (markup #:musicglyph "accidentals--4")))
 156
 157
 158 (def-markup-command (column paper props args) (markup-list?)
 159   (stack-lines
 160    -1 0.0 (cdr (chain-assoc 'baseline-skip props))
 161    (map (lambda (m) (interpret-markup paper props m)) args)))
 162
 163 (def-markup-command (dir-column paper props args) (markup-list?)
 164   "Make a column of args, going up or down, depending on the setting
 165 of the #'direction layout property."
 166   (let* ((dir (cdr (chain-assoc 'direction props))))
 167     (stack-lines
 168      (if (number? dir) dir -1)
 169      0.0
 170      (cdr (chain-assoc 'baseline-skip props))
 171      (map (lambda (x) (interpret-markup paper props x)) args))))
 172
 173 (def-markup-command (center paper props args) (markup-list?)
 174   (let* ((mols (map (lambda (x) (interpret-markup paper props x)) args))
 175          (cmols (map (lambda (x) (ly:stencil-align-to! x X CENTER)) mols)))
 176     (stack-lines -1 0.0 (cdr (chain-assoc 'baseline-skip props)) mols)))
 177
 178 (def-markup-command (right-align paper props arg) (markup?)
 179   (let* ((m (interpret-markup paper props arg)))
 180     (ly:stencil-align-to! m X RIGHT)
 181     m))
 182
 183 (def-markup-command (left-align paper props arg) (markup?)
 184   (let* ((m (interpret-markup paper props arg)))
 185     (ly:stencil-align-to! m X LEFT)
 186     m))
 187
 188 (def-markup-command (halign paper props dir arg) (number? markup?)
 189   "Set horizontal alignment. @var{dir} = -1 is left, @var{dir} = 1 is
 190 right, values in between vary alignment accordingly."
 191
 192
 193   (let* ((m (interpret-markup paper props arg)))
 194     (ly:stencil-align-to! m X dir)
 195     m))
 196
 197 (def-markup-command (musicglyph paper props glyph-name) (string?)
 198   "This is converted to a musical symbol, e.g. @code{\\musicglyph
 199 #\"accidentals-0\"} will select the natural sign from the music font.
 200 See @usermanref{The Feta font} for  a complete listing of the possible glyphs.
 201 "
 202   (ly:find-glyph-by-name
 203    (ly:paper-get-font paper (cons '((font-name . ())
 204                                     (font-shape . *)
 205                                     (font-series . *)
 206                                     (font-family . music))
 207                                   props))
 208    glyph-name))
 209
 210
 211 (def-markup-command (lookup paper props glyph-name) (string?)
 212   "Lookup a glyph by name."
 213   (ly:find-glyph-by-name (ly:paper-get-font paper props)
 214                          glyph-name))
 215
 216 (def-markup-command (char paper props num) (integer?)
 217   "This produces a single character, e.g. @code{\\char #65} produces the
 218 letter 'A'."
 219   (ly:get-glyph (ly:paper-get-font paper props) num))
 220
 221 (def-markup-command (raise paper props amount arg) (number? markup?)
 222   "
 223 This  raises  @var{arg}, by the distance @var{amount}.
 224 A negative @var{amount} indicates lowering:
 225 @c
 226 @lilypond[verbatim,fragment,relative=1,quote]
 227  c1^\\markup { C \\small \\raise #1.0 \\bold { \"9/7+\" }}
 228 @end lilypond
 229 The argument to @code{\\raise} is the vertical displacement amount,
 230 measured in (global) staff spaces.  @code{\\raise} and @code{\\super}
 231 raise objects in relation to their surrounding markups.
 232
 233 If the text object itself is positioned above or below the staff, then
 234 @code{\\raise} cannot be used to move it, since the mechanism that
 235 positions it next to the staff cancels any shift made with
 236 @code{\\raise}. For vertical positioning, use the @code{padding}
 237 and/or @code{extra-offset} properties. "
 238
 239
 240   (ly:stencil-translate-axis (interpret-markup paper props arg)
 241                               amount Y))
 242
 243 (def-markup-command (fraction paper props arg1 arg2) (markup? markup?)
 244   "Make a fraction of two markups.
 245
 246 Syntax: \\fraction MARKUP1 MARKUP2."
 247   (let* ((m1 (interpret-markup paper props arg1))
 248          (m2 (interpret-markup paper props arg2)))
 249     (ly:stencil-align-to! m1 X CENTER)
 250     (ly:stencil-align-to! m2 X CENTER)
 251     (let* ((x1 (ly:stencil-get-extent m1 X))
 252            (x2 (ly:stencil-get-extent m2 X))
 253            (line (ly:round-filled-box (interval-union x1 x2) '(-0.05 . 0.05) 0.0))
 254            ;; should stack mols separately, to maintain LINE on baseline
 255            (stack (stack-lines -1 0.2 0.6 (list m1 line m2))))
 256       (ly:stencil-align-to! stack Y CENTER)
 257       (ly:stencil-align-to! stack X LEFT)
 258       ;; should have EX dimension
 259       ;; empirical anyway
 260       (ly:stencil-translate-axis stack 0.75 Y))))
 261
 262
 263 ;; TODO: better syntax.
 264
 265 (def-markup-command (note-by-number paper props log dot-count dir) (number? number? number?)
 266   "Syntax: \\note-by-number #LOG #DOTS #DIR.  By using fractional values
 267 for DIR, you can obtain longer or shorter stems."
 268   (let* ((font (ly:paper-get-font paper (cons '((font-family .  music)) props)))
 269          (stemlen (max 3 (- log 1)))
 270          (headgl (ly:find-glyph-by-name
 271                   font
 272                   (string-append "noteheads-" (number->string (min log 2)))))
 273          (stemth 0.13)
 274          (stemy (* dir stemlen))
 275          (attachx (if (> dir 0)
 276                       (- (cdr (ly:stencil-get-extent headgl X)) stemth)
 277                       0))
 278          (attachy (* dir 0.28))
 279          (stemgl (and (> log 0)
 280                       (ly:round-filled-box
 281                        (cons attachx (+ attachx  stemth))
 282                        (cons (min stemy attachy)
 283                              (max stemy attachy))
 284                        (/ stemth 3))))
 285          (dot (ly:find-glyph-by-name font "dots-dot"))
 286          (dotwid (interval-length (ly:stencil-get-extent dot X)))
 287          (dots (and (> dot-count 0)
 288                     (apply ly:stencil-add
 289                            (map (lambda (x)
 290                                   (ly:stencil-translate-axis
 291                                    dot  (* (+ 1 (* 2 x)) dotwid) X) )
 292                                 (iota dot-count 1)))))
 293          (flaggl (and (> log 2)
 294                       (ly:stencil-translate
 295                        (ly:find-glyph-by-name font
 296                                               (string-append "flags-"
 297                                                              (if (> dir 0) "u" "d")
 298                                                              (number->string log)))
 299                        (cons (+ attachx (/ stemth 2)) stemy)))))
 300     (if flaggl
 301         (set! stemgl (ly:stencil-add flaggl stemgl)))
 302     (if (ly:stencil? stemgl)
 303         (set! stemgl (ly:stencil-add stemgl headgl))
 304         (set! stemgl headgl))
 305     (if (ly:stencil? dots)
 306         (set! stemgl
 307               (ly:stencil-add
 308                (ly:stencil-translate-axis dots
 309                                            (+ (if (and (> dir 0) (> log 2))
 310                                                   (* 1.5 dotwid)
 311                                                   0)
 312                                               ;; huh ? why not necessary?
 313                                               ;;(cdr (ly:stencil-get-extent headgl X))
 314                                               dotwid)
 315                                            X)
 316                stemgl)))
 317     stemgl))
 318
 319 (use-modules (ice-9 regex))
 320
 321 (define-public log2
 322   (let ((divisor (log 2)))
 323     (lambda (z) (inexact->exact (/ (log z) divisor)))))
 324
 325 (define (parse-simple-duration duration-string)
 326   "Parse the `duration-string', eg ''4..'' or ''breve.'', and return a (log dots) list."
 327   (let ((match (regexp-exec (make-regexp "(breve|longa|maxima|[0-9]+)(\\.*)") duration-string)))
 328     (if (and match (string=? duration-string (match:substring match 0)))
 329         (let ((len  (match:substring match 1))
 330               (dots (match:substring match 2)))
 331           (list (cond ((string=? len "breve")  -1)
 332                       ((string=? len "longa")  -2)
 333                       ((string=? len "maxima") -3)
 334                       (else (log2 (string->number len))))
 335                 (if dots (string-length dots) 0)))
 336         (error "This is not a valid duration string:" duration-string))))
 337
 338 (def-markup-command (note paper props duration dir) (string? number?)
 339   "This produces a note with a stem pointing in @var{dir} direction, with
 340 the @var{duration} for the note head type and augmentation dots. For
 341 example, @code{\\note #\"4.\" #-0.75} creates a dotted quarter note, with
 342 a shortened down stem."
 343
 344   (let ((parsed (parse-simple-duration duration)))
 345     (note-by-number-markup paper props (car parsed) (cadr parsed) dir)))
 346
 347 (def-markup-command (normal-size-super paper props arg) (markup?)
 348   "A superscript which does not use a smaller font."
 349   (ly:stencil-translate-axis (interpret-markup
 350                                paper
 351                                props arg)
 352                               (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 353                               Y))
 354
 355 (def-markup-command (super paper props arg) (markup?)
 356   "
 357 @cindex raising text
 358 @cindex lowering text
 359 @cindex moving text
 360 @cindex translating text
 361
 362 @cindex @code{\\super}
 363
 364
 365 Raising and lowering texts can be done with @code{\\super} and
 366 @code{\\sub}:
 367
 368 @lilypond[verbatim,fragment,relative=1]
 369  c1^\\markup { E \"=\" mc \\super \"2\" }
 370 @end lilypond
 371
 372 "
 373
 374   (ly:stencil-translate-axis
 375    (interpret-markup
 376     paper
 377     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
 378     arg)
 379    (* 0.5 (cdr (chain-assoc 'baseline-skip props)))
 380    Y))
 381
 382 (def-markup-command (translate paper props offset arg) (number-pair? markup?)
 383   "This translates an object. Its first argument is a cons of numbers
 384 @example
 385 A \\translate #(cons 2 -3) @{ B C @} D
 386 @end example
 387 This moves `B C' 2 spaces to the right, and 3 down, relative to its
 388 surroundings. This command cannot be used to move isolated scripts
 389 vertically, for the same reason that @code{\\raise} cannot be used for
 390 that.
 391
 392 . "
 393   (ly:stencil-translate (interpret-markup  paper props arg)
 394                          offset))
 395
 396 (def-markup-command (sub paper props arg) (markup?)
 397   "Syntax: \\sub MARKUP."
 398   (ly:stencil-translate-axis
 399    (interpret-markup
 400     paper
 401     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
 402     arg)
 403    (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 404    Y))
 405
 406 (def-markup-command (normal-size-sub paper props arg) (markup?)
 407   (ly:stencil-translate-axis
 408    (interpret-markup paper props arg)
 409    (* -0.5 (cdr (chain-assoc 'baseline-skip props)))
 410    Y))
 411
 412 (def-markup-command (hbracket paper props arg) (markup?)
 413   "Horizontal brackets around @var{arg}."
 414   (let ((th 0.1) ;; todo: take from GROB.
 415         (m (interpret-markup paper props arg)))
 416     (bracketify-stencil m X th (* 2.5 th) th)))
 417
 418 (def-markup-command (bracket paper props arg) (markup?)
 419   "Vertical brackets around @var{arg}."
 420   (let ((th 0.1) ;; todo: take from GROB.
 421         (m (interpret-markup paper props arg)))
 422     (bracketify-stencil m Y th (* 2.5 th) th)))
 423
 424 ;; todo: fix negative space
 425 (def-markup-command (hspace paper props amount) (number?)
 426   "This produces a invisible object taking horizontal space.
 427 @example
 428 \\markup @{ A \\hspace #2.0 B @}
 429 @end example
 430 will put extra space between A and B, on top of the space that is
 431 normally inserted before elements on a line.
 432 "
 433   (if (> amount 0)
 434       (ly:make-stencil "" (cons 0 amount) '(-1 . 1) )
 435       (ly:make-stencil "" (cons amount amount) '(-1 . 1))))
 436
 437 (def-markup-command (override paper props new-prop arg) (pair? markup?)
 438   "Add the first argument in to the property list.  Properties may be
 439 any sort of property supported by @internalsref{font-interface} and
 440 @internalsref{text-interface}, for example
 441
 442 @verbatim
 443 \\override #'(font-family . married) \"bla\"
 444 @end verbatim
 445
 446 "
 447   (interpret-markup paper (cons (list new-prop) props) arg))
 448
 449 (def-markup-command (smaller paper props arg) (markup?)
 450   "Decrease the font size relative to current setting"
 451   (let* ((fs (chain-assoc-get 'font-size props 0))
 452          (entry (cons 'font-size (- fs 1))))
 453     (interpret-markup paper (cons (list entry) props) arg)))
 454
 455
 456 (def-markup-command (bigger paper props arg) (markup?)
 457   "Increase the font size relative to current setting"
 458   (let* ((fs (chain-assoc-get 'font-size props 0))
 459          (entry (cons 'font-size (+ fs 1))))
 460     (interpret-markup paper (cons (list entry) props) arg)))
 461
 462 (def-markup-command larger (markup?)
 463   bigger-markup)
 464
 465 (def-markup-command (box paper props arg) (markup?)
 466   "Draw a box round @var{arg}"
 467
 468   (let ((th 0.1)
 469         (pad 0.2)
 470         (m (interpret-markup paper props arg)))
 471     (box-stencil m th pad)))
 472
 473 (def-markup-command (strut paper props) ()
 474
 475   "Create a box of the same height as the space in the current font.
 476
 477 FIXME: is this working?
 478 "
 479
 480   (let ((m (Text_item::interpret_markup paper props " ")))
 481     (ly:stencil-set-extent! m X '(1000 . -1000))
 482     m))
 483
 484 (define number->mark-letter-vector (make-vector 25 #\A))
 485
 486 (do ((i 0 (1+ i))
 487      (j 0 (1+ j)))
 488     ((>= i 26))
 489   (if (= i (- (char->integer #\I) (char->integer #\A)))
 490       (set! i (1+ i)))
 491   (vector-set! number->mark-letter-vector j
 492                (integer->char (+ i (char->integer #\A)))))
 493
 494 (define (number->markletter-string n)
 495   "Double letters for big marks."
 496   (let*
 497       ((l (vector-length number->mark-letter-vector)))
 498
 499   (if (>= n l)
 500       (string-append (number->markletter-string (1- (quotient n l)))
 501                      (number->markletter-string (remainder n l)))
 502       (make-string 1 (vector-ref number->mark-letter-vector n)))))
 503
 504
 505 (def-markup-command (markletter paper props num) (integer?)
 506   "Make a markup letter for @var{num}.  The letters start with A to Z
 507 (skipping I), and continues with double letters."
 508
 509   (Text_item::interpret_markup paper props (number->markletter-string num)))
 510