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 mpsempre = #(make-dynamic-extra "mp" "sempre")
 221 mfsempre = #(make-dynamic-extra "mf" "sempre")
 222 mfintenso = #(make-dynamic-extra "mf" "intenso")
 223 mpsostenuto = #(make-dynamic-extra "mp" "sostenuto")
 224 psubito = #(make-dynamic-extra "p" "subito")
 225 pdolce = #(make-dynamic-extra "p" "dolce")
 226 ppdolce = #(make-dynamic-extra "pp" "dolce")
 227 pleggiero = #(make-dynamic-extra "p" "leggiero")
 228 ppleggiero = #(make-dynamic-extra "pp" "leggiero")
 229 ppsubito = #(make-dynamic-extra "pp" "subito")
 230 mfleggiero = #(make-dynamic-extra "mf" "leggiero")
 231 piuf = #(make-extra-dynamic "più" "f")
 232 pocof = #(make-extra-dynamic "poco" "f")
 233
 234
 235 %% Text indications -----------------------------------------------%
 236
 237 ind =
 238 #(define-music-function (parser location text music) (string? ly:music?)
 239    (if
 240      (equal? (ly:music-property music 'name) 'EventChord)
 241      (set! (ly:music-property music 'elements)
 242            (append (ly:music-property music 'elements)
 243                   (list (make-music 'TextScriptEvent 'direction 1
 244                   'text (markup #:indic text))))))
 245    music)
 246
 247 nind =
 248 #(define-music-function (parser location texte)
 249 (string? )
 250 (make-dynamic-script
 251               (markup  #:text #:indic texte)))
 252
 253 %% Predefined commands
 254
 255 ten =
 256 #(define-music-function (parser location music) (ly:music?)
 257    (if
 258      (equal? (ly:music-property music 'name) 'EventChord)
 259      (set! (ly:music-property music 'elements)
 260            (append (ly:music-property music 'elements)
 261                   (list (make-music 'TextScriptEvent 'text
 262                     (markup #:translate (cons 4 0)
 263                     #:indic "(ten.)"))))))
 264                  music)
 265
 266
 267 pizz =
 268 #(define-music-function (parser location music) (ly:music?)
 269 #{ \ind #"pizz." $music #})
 270
 271 arco =
 272 #(define-music-function (parser location music) (ly:music?)
 273 #{ \ind #"arco" $music #})
 274
 275 flaut =
 276 #(define-music-function (parser location music) (ly:music?)
 277 #{ \ind #"flautando" $music #})
 278
 279 simile =
 280 #(define-music-function (parser location music) (ly:music?)
 281 #{ \ind #"simile" $music #})
 282
 283 loco =
 284 #(define-music-function (parser location music) (ly:music?)
 285 #{ \ind #"loco" $music #})
 286
 287 ordin =
 288 #(define-music-function (parser location music) (ly:music?)
 289 #{ \ind #"(ordin.)" $music #})
 290
 291 meno =
 292 #(define-music-function (parser location music) (ly:music?)
 293 #{ \ind #"meno" $music #})
 294
 295 jet =
 296 #(define-music-function (parser location music) (ly:music?)
 297 #{ \ind #"jeté" $music #})
 298
 299
 300 %% Text Spanners --------------------------------------------------%
 301
 302 #(define (make-txt-span music t)
 303  (set! (ly:music-property music 'elements)
 304                        (append (ly:music-property music 'elements)
 305                        (list (make-music 'TextSpanEvent
 306                          'span-direction t))))
 307                          music)
 308
 309 %% The two following functions are deprecated. Better code follows below.
 310 startTxt =
 311 #(define-music-function (parser location texte music ) (string? ly:music?)
 312 #{ \override TextSpanner #'bound-details #'left #'text =
 313   \markup { \bold $texte }
 314                 $(make-txt-span music -1)#})
 315
 316 stopTxt =
 317 #(define-music-function (parser location music) (ly:music?)
 318      (make-txt-span music 1))
 319
 320 #(define (make-text-span txt)
 321 "Make a TextSpanner that begins with the given STR."
 322   (let* ((m (make-music 'TextSpanEvent
 323              'span-direction -1))
 324          (details (assoc-get 'bound-details
 325                    (assoc-get 'TextSpanner
 326                     all-grob-descriptions)))
 327          (left-details (assoc-get 'left
 328                         details)))
 329    (ly:music-set-property! m 'tweaks
 330     (acons 'bound-details
 331      (acons 'left
 332       (acons 'text txt
 333        left-details)
 334       details)
 335      (ly:music-property m 'tweaks)))
 336    m))
 337
 338 startText=
 339 #(define-music-function (location parser txt) (string?)
 340 (make-text-span txt))
 341
 342 stopText= #(make-music 'TextSpanEvent 'span-direction 1)
 343
 344 %% Predefined commands
 345
 346 rit = #(make-text-span "rit.")
 347
 348
 349
 350 %%%%%%%%%%%%%%%%%%%%%%%%%%%% Other Text %%%%%%%%%%%%%%%%%%%%%%%%%%%%
 351
 352
 353 %% Lyrics formatting ----------------------------------------------%
 354
 355 freeStyleOn = {
 356 \override Lyrics . LyricExtender #'stencil = ##f }
 357
 358 freeStyleOff = {
 359 \revert Lyrics . LyricExtender #'stencil }
 360
 361 leftSyl = {
 362 \once \override LyricText #'self-alignment-X = #0.9 }
 363
 364 dash = {
 365   \once \override LyricHyphen #'minimum-distance = #4
 366   \once \override LyricHyphen #'length = #2
 367   \once \override LyricHyphen #'thickness = #1.2
 368 }
 369
 370 ital = {
 371 \once \override LyricText #'font-shape = #'italic }
 372
 373 smallcaps = {
 374 \override LyricText  #'font-shape = #'caps }
 375
 376 normal = {
 377 \revert LyricText #'font-shape }
 378
 379
 380 %% Scenography formatting ---------------------------------------%
 381 long = {
 382 \once \override TextScript #'extra-spacing-width = #'(0 . 0)
 383 \once \override TextScript #'infinite-spacing-height = ##t
 384 }
 385
 386 #(define-markup-command (did layout props text) (markup?)
 387   (interpret-markup layout props
 388     (markup #:override '(line-width . 40)
 389     #:override '(box-padding . 1)
 390     #:override '(corner-radius . 2)
 391     #:rounded-box #:sans #:italic #:small #:justify-string text)))
 392
 393 #(define-markup-command (init-did layout props text) (markup?)
 394   (interpret-markup layout props
 395     (markup
 396   ;  #:override (cons 'line-width (* 1 (chain-assoc-get 'line-width props)))
 397     #:fill-line (
 398     #:override '(line-width . 60)
 399     #:override '(box-padding . 1.5)
 400     #:override '(corner-radius . 2)
 401     #:rounded-box #:sans #:italic #:small #:justify-string  text))))
 402
 403
 404 %% Table of contents --------------------------------------------%
 405 tocAct =
 406 #(define-music-function (parser location text) (markup?)
 407    (add-toc-item! 'tocActMarkup text))
 408
 409 tocQuote =
 410 #(define-music-function (parser location text) (markup?)
 411    (add-toc-item! 'tocQuoteMarkup text))
 412
 413 %% Characters and instrument names ------------------------------%
 414
 415 #(define characters `((dummy . "")))
 416 #(define instruments `((dummy . "")))
 417
 418 #(define (char-name n) (car (car (assoc-get n characters))))
 419 #(define (char-shortname n) (cdr (car (assoc-get n characters))))
 420 #(define (instr-name n) (car (car (assoc-get n instruments))))
 421 #(define (instr-shortname n) (cdr (car (assoc-get n instruments))))
 422
 423 #(define (make-char-name n . pad)
 424 (let* ((txt (char-name n))
 425        (srt (char-shortname n))
 426        (m (if (pair? pad)
 427           (markup #:hcenter-in (car pad) txt)
 428           (markup txt)))
 429        (n (markup srt))) fixme: shortname has no padding
 430     (ly:export (make-sequential-music (list
 431                 (context-spec-music (make-property-set 'instrumentName m)
 432                   'Staff)
 433                 (context-spec-music (make-property-set 'shortInstrumentName n)
 434                   'Staff)
 435                 (context-spec-music (make-property-set 'midiInstrument "voice oohs")
 436                   'Staff))))))
 437
 438 #(define (make-instrument-name n midi . pad)
 439   (let* ((txt (instr-name n))
 440          (srt (instr-shortname n))
 441          (m (if (pair? pad)
 442             (markup #:hcenter-in (car pad) txt)
 443             (markup txt)))
 444          (n (markup srt))) ;; fixme: shortname has no padding
 445     (ly:export (make-sequential-music (list
 446                 (context-spec-music (make-property-set 'instrumentName m)
 447                   'Staff)
 448                 (context-spec-music (make-property-set 'shortInstrumentName n)
 449                   'Staff)
 450                 (context-spec-music (make-property-set 'midiInstrument midi)
 451                   'Staff))))))