definitions/markup.ly

   1 %------------------------------------------------------------------%
   2 % Opéra Libre -- markup.ly                                         %
   3 %                                                                  %
   4 % (c) Valentin Villenave, 2008                                     %
   5 %                                                                  %
   6 %------------------------------------------------------------------%
   7
   8 %%% The following functions were provided by
   9 %%% Nicolas Sceaux <nicolas.sceaux@free.fr>
  10 %%%
  11 %%% Markup commands
  12 %%% ===============
  13 %%%   \vspace <amount>
  14 %%%     like \hspace, but for vertical space
  15 %%%
  16 %%%   \smallCaps <string>
  17 %%%     like built-in \smallCaps, but dealing with accented letters
  18 %%%
  19 %%%   \when-property <symbol> <markup>
  20 %%%     if symbol is find in properties, interpret the markup
  21 %%%     otherwise, return an empty stencil
  22 %%%
  23 %%%   \line-width-ratio <ratio> <markup>
  24 %%%     interpret markup with a line-width set to current line-width * ratio
  25 %%%
  26 %%%   \copyright
  27 %%%     build a copyight line, using the maintainer and copyrightYear
  28 %%%     header variables.
  29 %%%
  30 %%%   \wordwrap-center <markup-list>
  31 %%%     like wordwrap, but center align the lines
  32 %%%
  33 %%% Markup lines commands
  34 %%% =====================
  35 %%%   \wordwrap-center-lines <markup-list>
  36 %%%     make a markup list composed centered lines of text.
  37
  38
  39
  40
  41 #(define-markup-command (vspace layout props amount) (number?)
  42   "This produces a invisible object taking vertical space."
  43   (let ((amount (* amount 3.0)))
  44     (if (> amount 0)
  45         (ly:make-stencil "" (cons -1 1) (cons 0 amount))
  46         (ly:make-stencil "" (cons -1 1) (cons amount amount)))))
  47
  48 #(define-markup-command (copyright layout props) ()
  49   (let* ((maintainer (chain-assoc-get 'header:maintainer props))
  50          (this-year (+ 1900 (tm:year (gmtime (current-time)))))
  51          (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
  52                                    (number->string this-year)))))
  53     (interpret-markup layout props
  54      (markup "Copyright ©"
  55              (if (= year this-year)
  56                  (format #f "~a" this-year)
  57                  (format #f "~a-~a" year this-year))
  58              maintainer))))
  59
  60 #(define-markup-command (when-property layout props symbol markp) (symbol? markup?)
  61   (if (chain-assoc-get symbol props)
  62       (interpret-markup layout props markp)
  63       (ly:make-stencil '()  '(1 . -1) '(1 . -1))))
  64
  65 #(define-markup-command (line-width-ratio layout props width-ratio arg) (number? markup?)
  66   (interpret-markup layout props
  67    (markup #:override (cons 'line-width (* width-ratio (chain-assoc-get 'line-width props)))
  68            arg)))
  69
  70 #(define-markup-list-command (wordwrap-center-lines layout props args)
  71   (markup-list?)
  72   (map (lambda (stencil)
  73         (interpret-markup layout props (markup #:fill-line (#:stencil stencil))))
  74    (interpret-markup-list layout props (make-wordwrap-lines-markup-list args))))
  75
  76 #(define-markup-command (wordwrap-center layout props args) (markup-list?)
  77   (interpret-markup layout props
  78    (make-column-markup
  79     (make-wordwrap-center-lines-markup-list args))))
  80
  81
  82 #(define (page-ref-aux layout props label gauge next)
  83   (let* ((gauge-stencil (interpret-markup layout props gauge))
  84    (x-ext (ly:stencil-extent gauge-stencil X))
  85    (y-ext (ly:stencil-extent gauge-stencil Y)))
  86     (ly:make-stencil
  87      `(delay-stencil-evaluation
  88        ,(delay (ly:stencil-expr
  89     (let* ((table (ly:output-def-lookup layout 'label-page-table))
  90            (label-page (and (list? table) (assoc label table)))
  91            (page-number (and label-page (cdr label-page)))
  92            (page-markup (if page-number
  93                                         (markup #:concat ((format "~a" page-number) next))
  94                                         "?"))
  95            (page-stencil (interpret-markup layout props page-markup))
  96            (gap (- (interval-length x-ext)
  97              (interval-length (ly:stencil-extent page-stencil X)))))
  98       (interpret-markup layout props
  99             (markup #:concat (page-markup #:hspace gap)))))))
 100      x-ext
 101      y-ext)))
 102
 103 #(define-markup-command (page-refI layout props label next)
 104   (symbol? markup?)
 105   (page-ref-aux layout props label "0" next))
 106
 107 #(define-markup-command (page-refII layout props label next)
 108   (symbol? markup?)
 109   (page-ref-aux layout props label "00" next))
 110
 111 #(define-markup-command (page-refIII layout props label next)
 112   (symbol? markup?)
 113   (page-ref-aux layout props label "000" next))
 114
 115 #(define-markup-command (super layout props arg) (markup?)
 116   (ly:stencil-translate-axis
 117    (interpret-markup
 118     layout
 119     (cons `((font-size . ,(- (chain-assoc-get 'font-size props 0) 3))) props)
 120     arg)
 121    (* 0.25 (chain-assoc-get 'baseline-skip props))
 122    Y))
 123
 124 #(define-markup-list-command (paragraph paper props text) (markup-list?)
 125   (let ((indentation (markup #:pad-to-box (cons 0 3) (cons 0 0) #:null)))
 126    (interpret-markup-list paper props
 127     (make-override-lines-markup-list '(baseline-skip . 0)
 128      (make-justified-lines-markup-list (cons indentation text))))))
 129
 130 #(define-markup-list-command (columns paper props text) (markup-list?)
 131   (interpret-markup-list paper props
 132    (make-override-lines-markup-list '(baseline-skip . 1)
 133     (make-column-lines-markup-list text))))
 134
 135 #(define-markup-command (boxed-justify layout props text) (markup-list?)
 136   (interpret-markup layout props
 137    (make-override-markup '(box-padding . 1)
 138     (make-box-markup
 139      (make-column-markup
 140       (make-justified-lines-markup-list text))))))
 141
 142 %%% Guile does not deal with accented letters
 143 #(use-modules (ice-9 regex))
 144 %%;; actually defined below, in a closure
 145 #(define-public string-upper-case #f)
 146 #(define accented-char-upper-case? #f)
 147 #(define accented-char-lower-case? #f)
 148
 149 %%;; an accented character is seen as two characters by guile
 150 #(let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
 151        (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
 152    (define (group-by-2 chars result)
 153       (if (or (null? chars) (null? (cdr chars)))
 154           (reverse! result)
 155           (group-by-2 (cddr chars)
 156                       (cons (string (car chars) (cadr chars))
 157                             result))))
 158    (let ((lower-case-accented-chars
 159           (group-by-2 (string->list lower-case-accented-string) (list)))
 160          (upper-case-accented-chars
 161           (group-by-2 (string->list upper-case-accented-string) (list))))
 162      (set! string-upper-case
 163            (lambda (str)
 164              (define (replace-chars str froms tos)
 165                (if (null? froms)
 166                    str
 167                    (replace-chars (regexp-substitute/global #f (car froms) str
 168                                                             'pre (car tos) 'post)
 169                                   (cdr froms)
 170                                   (cdr tos))))
 171              (string-upcase (replace-chars str
 172                                            lower-case-accented-chars
 173                                            upper-case-accented-chars))))
 174      (set! accented-char-upper-case?
 175            (lambda (char1 char2)
 176              (member (string char1 char2) upper-case-accented-chars string=?)))
 177      (set! accented-char-lower-case?
 178            (lambda (char1 char2)
 179              (member (string char1 char2) lower-case-accented-chars string=?)))))
 180
 181 #(define-markup-command (smallCaps layout props text) (markup?)
 182   "Turn @code{text}, which should be a string, to small caps.
 183 @example
 184 \\markup \\small-caps \"Text between double quotes\"
 185 @end example"
 186   (define (string-list->markup strings lower)
 187     (let ((final-string (string-upper-case
 188                          (apply string-append (reverse strings)))))
 189       (if lower
 190           (markup #:fontsize -2 final-string)
 191           final-string)))
 192   (define (make-small-caps rest-chars currents current-is-lower prev-result)
 193     (if (null? rest-chars)
 194         (make-concat-markup (reverse! (cons (string-list->markup
 195                                               currents current-is-lower)
 196                                             prev-result)))
 197         (let* ((ch1 (car rest-chars))
 198                (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
 199                (this-char-string (string ch1))
 200                (is-lower (char-lower-case? ch1))
 201                (next-rest-chars (cdr rest-chars)))
 202           (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
 203                  (set! this-char-string (string ch1 ch2))
 204                  (set! is-lower #t)
 205                  (set! next-rest-chars (cddr rest-chars)))
 206                 ((and ch2 (accented-char-upper-case? ch1 ch2))
 207                  (set! this-char-string (string ch1 ch2))
 208                  (set! is-lower #f)
 209                  (set! next-rest-chars (cddr rest-chars))))
 210           (if (or (and current-is-lower is-lower)
 211                   (and (not current-is-lower) (not is-lower)))
 212               (make-small-caps next-rest-chars
 213                                (cons this-char-string currents)
 214                                is-lower
 215                                prev-result)
 216               (make-small-caps next-rest-chars
 217                                (list this-char-string)
 218                                is-lower
 219                                (if (null? currents)
 220                                    prev-result
 221                                    (cons (string-list->markup
 222                                             currents current-is-lower)
 223                                          prev-result)))))))
 224   (interpret-markup layout props
 225     (if (string? text)
 226         (make-small-caps (string->list text) (list) #f (list))
 227         text)))
 228
 229 %%%
 230 %%% Markup commands
 231 %%%
 232 #(define-markup-command (rehearsal-number layout props text) (string?)
 233    (interpret-markup layout props
 234      (markup #:huge #:bold text)))
 235
 236 #(define-markup-command (rehearsal-number-toc layout props text) (string?)
 237   (let* ((gauge-stencil (interpret-markup layout props "8-88"))
 238    (x-ext (ly:stencil-extent gauge-stencil X))
 239    (y-ext (ly:stencil-extent gauge-stencil Y))
 240          (stencil (interpret-markup layout props text))
 241          (gap (- (interval-length x-ext)
 242                  (interval-length (ly:stencil-extent stencil X)))))
 243     (interpret-markup layout props
 244       (markup #:concat (#:hspace gap text #:hspace 1)))))
 245
 246 #(define-markup-command (act layout props arg) (markup?)
 247   (interpret-markup layout props
 248     (if (*part*)
 249         (markup #:pad-markup 2 #:fill-line (#:fontsize 6 arg))
 250         (markup #:column (#:vspace 3
 251                           #:pad-markup 3 #:fill-line (#:fontsize 6 arg))))))
 252
 253 #(define-markup-command (scene layout props arg) (markup?)
 254   (interpret-markup layout props
 255     (if (*part*)
 256         (markup #:pad-markup 0.5 #:fill-line (#:fontsize 4 arg))
 257         (markup #:column (#:vspace 1
 258                           #:fill-line (#:fontsize 4 arg)
 259                           #:vspace 1)))))
 260
 261 #(define-markup-command (scene-description layout props arg) (markup?)
 262   (interpret-markup layout props
 263     (if (*part*)
 264         empty-markup
 265         (markup #:column (#:fill-line (#:override '(line-width . 80)
 266                                        #:fontsize 2 arg)
 267                           #:vspace 1)))))
 268
 269 #(define-markup-command (title layout props arg) (markup?)
 270   (interpret-markup layout props
 271    (markup #:fill-line (#:override '(line-width . 80)
 272                         #:fontsize 2 arg))))
 273
 274 #(define-markup-command (small-title layout props arg) (markup?)
 275   (interpret-markup layout props
 276    (markup #:fill-line (#:override '(line-width . 80)
 277                         #:fontsize 0 #:italic arg))))
 278
 279
 280 #(define-markup-command (characteri paper props name) (markup?)
 281   (interpret-markup paper props
 282    (markup #:huge #:smallCaps name)))
 283
 284 #(define-markup-command (character paper props name) (markup?)
 285   (interpret-markup paper props
 286    (markup #:null #:translate  (cons -4 2) #:characteri name)))
 287
 288 #(define-markup-command (character-text paper props name text) (markup? markup?)
 289   (interpret-markup paper props
 290    (markup #:null #:translate  (cons -4 2)
 291     #:line (#:characteri name #:huge " " #:huge #:italic text))))
 292
 293 #(define-public (make-character-mark clefs name)
 294   #{ << { \set Staff.forceClef = ##t \clef #$clefs
 295           \once \override Staff . Clef #'full-size-change = ##t }
 296         s1*0 ^\markup \character $name >> #})
 297
 298