definitions/text-functions.ly

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