definitions/text-functions.ly

   1 %------------------------------------------------------------------%
   2 % Opéra Libre -- text-functions.ly                                 %
   3 %                                                                  %
   4 % (c) Valentin Villenave, 2008                                     %
   5 %                                                                  %
   6 %------------------------------------------------------------------%
   7
   8 #(use-modules (ice-9 regex))
   9 #(use-modules (ice-9 optargs))
  10
  11 %%%%%%%%%%%%%%%%%%%%%%%%%%% Definitions %%%%%%%%%%%%%%%%%%%%%%%%%%%%
  12
  13 %% Advanced definitions -------------------------------------------%
  14
  15 %%% This code was provided by Nicolas Sceaux.
  16
  17 #(define-public string-upper-case #f)
  18 #(define accented-char-upper-case? #f)
  19 #(define accented-char-lower-case? #f)
  20
  21 %%;; an accented character is seen as two characters by guile
  22 #(let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
  23        (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
  24    (define (group-by-2 chars result)
  25       (if (or (null? chars) (null? (cdr chars)))
  26           (reverse! result)
  27           (group-by-2 (cddr chars)
  28                       (cons (string (car chars) (cadr chars))
  29                             result))))
  30    (let ((lower-case-accented-chars
  31           (group-by-2 (string->list lower-case-accented-string) (list)))
  32          (upper-case-accented-chars
  33           (group-by-2 (string->list upper-case-accented-string) (list))))
  34      (set! string-upper-case
  35            (lambda (str)
  36              (define (replace-chars str froms tos)
  37                (if (null? froms)
  38                    str
  39                    (replace-chars (regexp-substitute/global #f (car froms) str
  40                                                             'pre (car tos) 'post)
  41                                   (cdr froms)
  42                                   (cdr tos))))
  43              (string-upcase (replace-chars str
  44                                            lower-case-accented-chars
  45                                            upper-case-accented-chars))))
  46      (set! accented-char-upper-case?
  47            (lambda (char1 char2)
  48              (member (string char1 char2) upper-case-accented-chars string=?)))
  49      (set! accented-char-lower-case?
  50            (lambda (char1 char2)
  51              (member (string char1 char2) lower-case-accented-chars string=?)))))
  52
  53 #(define-markup-command (smallCaps layout props text) (markup?)
  54   "Turn @code{text}, which should be a string, to small caps.
  55 @example
  56 \\markup \\small-caps \"Text between double quotes\"
  57 @end example"
  58   (define (string-list->markup strings lower)
  59     (let ((final-string (string-upper-case
  60                          (apply string-append (reverse strings)))))
  61       (if lower
  62           (markup #:fontsize -2 final-string)
  63           final-string)))
  64   (define (make-small-caps rest-chars currents current-is-lower prev-result)
  65     (if (null? rest-chars)
  66         (make-concat-markup (reverse! (cons (string-list->markup
  67                                               currents current-is-lower)
  68                                             prev-result)))
  69         (let* ((ch1 (car rest-chars))
  70                (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
  71                (this-char-string (string ch1))
  72                (is-lower (char-lower-case? ch1))
  73                (next-rest-chars (cdr rest-chars)))
  74           (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
  75                  (set! this-char-string (string ch1 ch2))
  76                  (set! is-lower #t)
  77                  (set! next-rest-chars (cddr rest-chars)))
  78                 ((and ch2 (accented-char-upper-case? ch1 ch2))
  79                  (set! this-char-string (string ch1 ch2))
  80                  (set! is-lower #f)
  81                  (set! next-rest-chars (cddr rest-chars))))
  82           (if (or (and current-is-lower is-lower)
  83                   (and (not current-is-lower) (not is-lower)))
  84               (make-small-caps next-rest-chars
  85                                (cons this-char-string currents)
  86                                is-lower
  87                                prev-result)
  88               (make-small-caps next-rest-chars
  89                                (list this-char-string)
  90                                is-lower
  91                                (if (null? currents)
  92                                    prev-result
  93                                    (cons (string-list->markup
  94                                             currents current-is-lower)
  95                                          prev-result)))))))
  96   (interpret-markup layout props
  97     (if (string? text)
  98         (make-small-caps (string->list text) (list) #f (list))
  99         text)))
 100
 101 %% Graphic fine-tuning --------------------------------------------%
 102
 103 #(define-markup-command (vspace layout props amount) (number?)
 104   (let ((amount (* amount 3.0)))
 105     (if (> amount 0)
 106         (ly:make-stencil "" (cons -1 1) (cons 0 amount))
 107         (ly:make-stencil "" (cons -1 1) (cons amount amount)))))
 108
 109 #(define-public (rounded-whiteout-stencil stencil blot)
 110   (let*
 111       ((x-ext (ly:stencil-extent stencil X))
 112        (y-ext (ly:stencil-extent stencil Y)))
 113     (ly:stencil-add
 114      (stencil-with-color (ly:round-filled-box x-ext y-ext blot)
 115        white)
 116      stencil)))
 117
 118 %TODO: make radius arg optional.
 119 #(define-markup-command (rounded-whiteout layout props radius arg)
 120                         (number? markup?)
 121   (rounded-whiteout-stencil (interpret-markup layout props arg) radius))
 122
 123   #(define-markup-command (line-width-ratio layout props width-ratio arg) (number? markup?)
 124   (interpret-markup layout props
 125    (markup #:override (cons 'line-width (* width-ratio (chain-assoc-get 'line-width props)))
 126            arg)))
 127
 128 %% Expressive indications -----------------------------------------%
 129
 130 #(define-markup-command (indic layout props arg) (markup?)
 131     (interpret-markup layout props
 132     (markup #:rounded-whiteout 1 #:small #:italic arg)))
 133
 134 %% Dynamics -------------------------------------------------------%
 135
 136 %%% This function was provided by Graham Percival.
 137 #(define (make-dynamic-extra dynamic string)
 138      (make-music
 139        'AbsoluteDynamicEvent
 140        'tweaks
 141          ;; calculate centering for text
 142          (list (cons (quote X-offset)
 143            (+ -0.5 (* -0.5 (string-length dynamic)))))
 144        'text
 145          (markup #:rounded-whiteout 1
 146            #:line (
 147                dynamic
 148                #:hspace -0.3
 149                #:normal-text #:italic string))
 150       ))
 151
 152 #(define (make-extra-dynamic string dynamic)
 153      (make-music
 154        'AbsoluteDynamicEvent
 155        'tweaks
 156          ;; calculate centering for text
 157          (list (cons (quote X-offset)
 158            (+ -0.5 (* -0.5 (string-length dynamic)))))
 159        'text
 160          (markup #:rounded-whiteout 1
 161            #:line (
 162                #:normal-text #:italic string
 163                #:hspace -0.3
 164                #:dynamic dynamic))
 165       ))
 166
 167 %%%%%%%%%%%%%%%%%%%%%%%%%% In-score Text %%%%%%%%%%%%%%%%%%%%%%%%%%%
 168
 169
 170 %% Non-standard synamics ------------------------------------------%
 171
 172 fpp = #(make-dynamic-script "fpp")
 173 sffz = #(make-dynamic-script "sffz")
 174
 175
 176 %% Composite Dynamics ---------------------------------------------%
 177
 178 % because of the use of a music-function,
 179 % non-predefined composite dynamics have to be entered *before*
 180 % the affected beat (unlike standard or predefined dynamics).
 181 cmb =
 182 #(define-music-function (parser location dyn str) (string? string?)
 183   (make-music 'SequentialMusic 'elements
 184     (list
 185       (make-music 'OverrideProperty
 186                   'symbol 'DynamicText
 187                   'grob-property-path (list 'self-alignment-X)
 188                   'grob-value -0.6 'once #t)
 189       (make-music 'AbsoluteDynamicEvent
 190                   'text
 191                   (markup #:rounded-whiteout 1
 192                           #:line (#:dynamic dyn
 193                           #:hspace .5
 194                           #:text #:medium #:italic str))))))
 195
 196 bmc =
 197 #(define-music-function (parser location str dyn) (string? string?)
 198   (make-music 'SequentialMusic 'elements
 199     (list
 200       (make-music 'OverrideProperty
 201                   'symbol 'DynamicText
 202                   'grob-property-path (list 'self-alignment-X)
 203                   'grob-value -0.6 'once #t)
 204       (make-music 'AbsoluteDynamicEvent
 205                   'text
 206                   (markup #:rounded-whiteout 1
 207                           #:line (#:text #:medium #:italic str
 208                           #:hspace .5
 209                           #:dynamic dyn))))))
 210
 211 %% Predefined commands
 212
 213 ffsubito = #(make-dynamic-extra "ff" "subito")
 214 fsubito = #(make-dynamic-extra "f" "subito")
 215 fsempre = #(make-dynamic-extra "f" "sempre")
 216 mfsubito = #(make-dynamic-extra "mf" "subito")
 217 fmolto = #(make-dynamic-extra "f" "molto")
 218 psempre = #(make-dynamic-extra "p" "sempre")
 219 ppsempre = #(make-dynamic-extra "pp" "sempre")
 220 mfsempre = #(make-dynamic-extra "mf" "sempre")
 221 mfintenso = #(make-dynamic-extra "mf" "intenso")
 222 mpsostenuto = #(make-dynamic-extra "mp" "sostenuto")
 223 psubito = #(make-dynamic-extra "p" "subito")
 224 pdolce = #(make-dynamic-extra "p" "dolce")
 225 pleggiero = #(make-dynamic-extra "p" "leggiero")
 226 ppsubito = #(make-dynamic-extra "pp" "subito")
 227 mfleggiero = #(make-dynamic-extra "mf" "leggiero")
 228 piuf = #(make-extra-dynamic "più" "f")
 229 pocof = #(make-extra-dynamic "poco" "f")
 230
 231
 232 %% Text indications -----------------------------------------------%
 233
 234 ind =
 235 #(define-music-function (parser location text music) (string? ly:music?)
 236    (if
 237      (equal? (ly:music-property music 'name) 'EventChord)
 238      (set! (ly:music-property music 'elements)
 239            (append (ly:music-property music 'elements)
 240                   (list (make-music 'TextScriptEvent 'direction 1
 241                   'text (markup #:indic text))))))
 242    music)
 243
 244 nind =
 245 #(define-music-function (parser location texte)
 246 (string? )
 247 (make-dynamic-script
 248               (markup  #:text #:indic texte)))
 249
 250 %% Predefined commands
 251
 252 ten =
 253 #(define-music-function (parser location music) (ly:music?)
 254    (if
 255      (equal? (ly:music-property music 'name) 'EventChord)
 256      (set! (ly:music-property music 'elements)
 257            (append (ly:music-property music 'elements)
 258                   (list (make-music 'TextScriptEvent 'text
 259                     (markup #:translate (cons 4 0)
 260                     #:indic "(ten.)"))))))
 261                  music)
 262
 263
 264 pizz =
 265 #(define-music-function (parser location music) (ly:music?)
 266 #{ \ind #"pizz." $music #})
 267
 268 arco =
 269 #(define-music-function (parser location music) (ly:music?)
 270 #{ \ind #"arco" $music #})
 271
 272 flaut =
 273 #(define-music-function (parser location music) (ly:music?)
 274 #{ \ind #"flautando" $music #})
 275
 276 simile =
 277 #(define-music-function (parser location music) (ly:music?)
 278 #{ \ind #"simile" $music #})
 279
 280 loco =
 281 #(define-music-function (parser location music) (ly:music?)
 282 #{ \ind #"loco" $music #})
 283
 284 ordin =
 285 #(define-music-function (parser location music) (ly:music?)
 286 #{ \ind #"(ordin.)" $music #})
 287
 288 meno =
 289 #(define-music-function (parser location music) (ly:music?)
 290 #{ \ind #"meno" $music #})
 291
 292 jet =
 293 #(define-music-function (parser location music) (ly:music?)
 294 #{ \ind #"jeté" $music #})
 295
 296
 297 %% Text Spanners --------------------------------------------------%
 298
 299 #(define (make-txt-span music t)
 300  (set! (ly:music-property music 'elements)
 301                        (append (ly:music-property music 'elements)
 302                        (list (make-music 'TextSpanEvent
 303                          'span-direction t))))
 304                          music)
 305
 306 %% The two following functions are deprecated. Better code follows below.
 307 startTxt =
 308 #(define-music-function (parser location texte music ) (string? ly:music?)
 309 #{ \override TextSpanner #'bound-details #'left #'text =
 310   \markup { \bold $texte }
 311                 $(make-txt-span music -1)#})
 312
 313 stopTxt =
 314 #(define-music-function (parser location music) (ly:music?)
 315      (make-txt-span music 1))
 316
 317 #(define (make-text-span txt)
 318 "Make a TextSpanner that begins with the given STR."
 319   (let* ((m (make-music 'TextSpanEvent
 320              'span-direction -1))
 321          (details (assoc-get 'bound-details
 322                    (assoc-get 'TextSpanner
 323                     all-grob-descriptions)))
 324          (left-details (assoc-get 'left
 325                         details)))
 326    (ly:music-set-property! m 'tweaks
 327     (acons 'bound-details
 328      (acons 'left
 329       (acons 'text txt
 330        left-details)
 331       details)
 332      (ly:music-property m 'tweaks)))
 333    m))
 334
 335 startText=
 336 #(define-music-function (location parser txt) (string?)
 337 (make-text-span txt))
 338
 339 stopText= #(make-music 'TextSpanEvent 'span-direction 1)
 340
 341 %% Predefined commands
 342
 343 rit = #(make-text-span "rit.")
 344
 345
 346
 347 %%%%%%%%%%%%%%%%%%%%%%%%%%%% Other Text %%%%%%%%%%%%%%%%%%%%%%%%%%%%
 348
 349
 350 %% Lyrics formatting ----------------------------------------------%
 351
 352 freeStyleOn = {
 353 \override Lyrics . LyricExtender #'stencil = ##f }
 354
 355 freeStyleOff = {
 356 \revert Lyrics . LyricExtender #'stencil }
 357
 358 leftSyl = {
 359 \once \override LyricText #'self-alignment-X = #0.9 }
 360
 361 dash = {
 362   \once \override LyricHyphen #'minimum-distance = #4
 363   \once \override LyricHyphen #'length = #2
 364   \once \override LyricHyphen #'thickness = #1.2
 365 }
 366
 367 ital = {
 368 \once \override LyricText #'font-shape = #'italic }
 369
 370 smallcaps = {
 371 \override LyricText  #'font-shape = #'caps }
 372
 373 normal = {
 374 \revert LyricText #'font-shape }
 375
 376
 377 %% Scenography formatting ---------------------------------------%
 378 long = {
 379 \once \override TextScript #'extra-spacing-width = #'(0 . 0)
 380 \once \override TextScript #'infinite-spacing-height = ##t
 381 }
 382
 383 #(define-markup-command (did layout props text) (markup?)
 384   (interpret-markup layout props
 385     (markup #:override '(line-width . 40)
 386     #:override '(box-padding . 1)
 387     #:override '(corner-radius . 2)
 388     #:rounded-box #:sans #:italic #:small #:justify-string text)))
 389
 390 #(define-markup-command (init-did layout props text) (markup?)
 391   (interpret-markup layout props
 392     (markup
 393   ;  #:override (cons 'line-width (* 1 (chain-assoc-get 'line-width props)))
 394     #:fill-line (
 395     #:override '(line-width . 60)
 396     #:override '(box-padding . 1.5)
 397     #:override '(corner-radius . 2)
 398     #:rounded-box #:sans #:italic #:small #:justify-string  text))))
 399
 400
 401 %% Table of contents --------------------------------------------%
 402 tocAct =
 403 #(define-music-function (parser location text) (markup?)
 404    (add-toc-item! 'tocActMarkup text))
 405
 406 tocQuote =
 407 #(define-music-function (parser location text) (markup?)
 408    (add-toc-item! 'tocQuoteMarkup text))
 409
 410 %% Characters and instrument names ------------------------------%
 411
 412 #(define characters `((dummy . "")))
 413 #(define instruments `((dummy . "")))
 414
 415 #(define (char-name n) (car (car (assoc-get n characters))))
 416 #(define (char-shortname n) (cdr (car (assoc-get n characters))))
 417 #(define (instr-name n) (car (car (assoc-get n instruments))))
 418 #(define (instr-shortname n) (cdr (car (assoc-get n instruments))))
 419
 420 #(define (make-char-name n . pad)
 421 (let* ((txt (char-name n))
 422        (srt (char-shortname n))
 423        (m (if (pair? pad)
 424           (markup #:hcenter-in (car pad) txt)
 425           (markup txt)))
 426        (n (markup srt))) fixme: shortname has no padding
 427     (ly:export (make-sequential-music (list
 428                 (context-spec-music (make-property-set 'instrumentName m)
 429                   'Staff)
 430                 (context-spec-music (make-property-set 'shortInstrumentName n)
 431                   'Staff)
 432                 (context-spec-music (make-property-set 'midiInstrument "voice oohs")
 433                   'Staff))))))
 434
 435 #(define (make-instrument-name n midi . pad)
 436   (let* ((txt (instr-name n))
 437          (srt (instr-shortname n))
 438          (m (if (pair? pad)
 439             (markup #:hcenter-in (car pad) txt)
 440             (markup txt)))
 441          (n (markup srt))) ;; fixme: shortname has no padding
 442     (ly:export (make-sequential-music (list
 443                 (context-spec-music (make-property-set 'instrumentName m)
 444                   'Staff)
 445                 (context-spec-music (make-property-set 'shortInstrumentName n)
 446                   'Staff)
 447                 (context-spec-music (make-property-set 'midiInstrument midi)
 448                   'Staff))))))