bin/markup-commands.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- markup-commands.scm                                ;
   3 ;                                                                  ;
   4 ; (c) 2008-2011 Valentin Villenave <valentin@villenave.net>        ;
   5 ;                                                                  ;
   6 ;     opus_libre is a free framework for GNU LilyPond: you may     ;
   7 ; redistribute it and/or modify it under the terms of the GNU      ;
   8 ; General Public License as published by the Free Software         ;
   9 ; Foundation, either version 3 of the License, or (at your option) ;
  10 ; any later version.                                               ;
  11 ;     This program is distributed WITHOUT ANY WARRANTY; without    ;
  12 ; even the implied warranty of MERCHANTABILITY or FITNESS FOR A    ;
  13 ; PARTICULAR PURPOSE.  You should have received a copy of the GNU  ;
  14 ; General Public License along with this program (typically in the ;
  15 ; share/doc/ directory).  If not, see http://www.gnu.org/licenses/ ;
  16 ;                                                                  ;
  17 ;------------------------------------------------------------------;
  18
  19
  20 ; Markup commands.
  21
  22 ;; This code was provided by Nicolas Sceaux.
  23 (define-markup-command (smallCaps layout props text) (markup?)
  24   "Turn @code{text}, which should be a string, to small caps.
  25 @example
  26 \\markup \\small-caps \"Text between double quotes\"
  27 @end example"
  28   (define string-upper-case #f)
  29   (define accented-char-upper-case? #f)
  30   (define accented-char-lower-case? #f)
  31
  32   (define (string-list->markup strings lower)
  33     (let ((final-string (string-upper-case
  34                          (apply string-append (reverse strings)))))
  35       (if lower
  36           (markup #:fontsize -2 final-string)
  37           final-string)))
  38   (define (make-small-caps rest-chars currents current-is-lower prev-result)
  39     (if (null? rest-chars)
  40         (make-concat-markup (reverse! (cons (string-list->markup
  41                                               currents current-is-lower)
  42                                             prev-result)))
  43         (let* ((ch1 (car rest-chars))
  44                (ch2 (and (not (null? (cdr rest-chars))) (cadr rest-chars)))
  45                (this-char-string (string ch1))
  46                (is-lower (char-lower-case? ch1))
  47                (next-rest-chars (cdr rest-chars)))
  48           (cond ((and ch2 (accented-char-lower-case? ch1 ch2))
  49                  (set! this-char-string (string ch1 ch2))
  50                  (set! is-lower #t)
  51                  (set! next-rest-chars (cddr rest-chars)))
  52                 ((and ch2 (accented-char-upper-case? ch1 ch2))
  53                  (set! this-char-string (string ch1 ch2))
  54                  (set! is-lower #f)
  55                  (set! next-rest-chars (cddr rest-chars))))
  56           (if (or (and current-is-lower is-lower)
  57                   (and (not current-is-lower) (not is-lower)))
  58               (make-small-caps next-rest-chars
  59                                (cons this-char-string currents)
  60                                is-lower
  61                                prev-result)
  62               (make-small-caps next-rest-chars
  63                                (list this-char-string)
  64                                is-lower
  65                                (if (null? currents)
  66                                    prev-result
  67                                    (cons (string-list->markup
  68                                             currents current-is-lower)
  69                                          prev-result)))))))
  70
  71   (let ((lower-case-accented-string "éèêëáàâäíìîïóòôöúùûüçœæ")
  72         (upper-case-accented-string "ÉÈÊËÁÀÂÄÍÌÎÏÓÒÔÖÚÙÛÜÇŒÆ"))
  73     (define (group-by-2 chars result)
  74         (if (or (null? chars) (null? (cdr chars)))
  75             (reverse! result)
  76             (group-by-2 (cddr chars)
  77                         (cons (string (car chars) (cadr chars))
  78                               result))))
  79     (let ((lower-case-accented-chars
  80             (group-by-2 (string->list lower-case-accented-string) (list)))
  81           (upper-case-accented-chars
  82             (group-by-2 (string->list upper-case-accented-string) (list))))
  83       (set! string-upper-case
  84             (lambda (str)
  85               (define (replace-chars str froms tos)
  86                 (if (null? froms)
  87                     str
  88                     (replace-chars (regexp-substitute/global #f (car froms) str
  89                                                               'pre (car tos) 'post)
  90                                     (cdr froms)
  91                                     (cdr tos))))
  92               (string-upcase (replace-chars str
  93                                             lower-case-accented-chars
  94                                             upper-case-accented-chars))))
  95       (set! accented-char-upper-case?
  96             (lambda (char1 char2)
  97               (member (string char1 char2) upper-case-accented-chars string=?)))
  98       (set! accented-char-lower-case?
  99             (lambda (char1 char2)
 100               (member (string char1 char2) lower-case-accented-chars string=?)))))
 101
 102   (interpret-markup layout props
 103     (if (string? text)
 104         (make-small-caps (string->list text) (list) #f (list))
 105         text)))
 106
 107 (define-markup-command (dynamic-string layout props str) (string?)
 108   #:category font
 109   "
 110 @cindex dynamics, composite
 111 @cindex dynamics, mixed with text
 112
 113 Print a string using the dynamic font only when appropriate.
 114 Words may be separated with @code{_}; dynamic-style characters
 115 will only be used in words that contain no other letter than
 116 @b{f}, @b{m}, @b{p}, @b{r}, @b{s} and @b{z}, and punctuation
 117 marks.  Regular spaces are allowed inside words.
 118
 119 @lilypond[verbatim,quote]
 120 \\markup {
 121   \\dynamic-string #\"mp,_quasi_mf_ma più dolce.\"
 122 }
 123 @end lilypond"
 124   (let ((composite-chars (char-set-union
 125                           char-set:dynamics
 126                           char-set:whitespace
 127                           char-set:punctuation))
 128         (split (lambda (s) (string-index s #\_ )))
 129         (str-list '())
 130         (dyn-markup (lambda (s)
 131                       (make-whiteout-markup
 132                         (make-dynamic-markup s))))
 133         (text-markup (lambda (s)
 134                        (make-whiteout-markup
 135                          (make-normal-text-markup
 136                            (make-italic-markup s))))))
 137     (do ((current-str (string-append str "_")))
 138         ((not (split current-str)))
 139       (begin
 140         (set! str-list
 141               (append str-list (list
 142                                 (string-take current-str (split current-str)))))
 143         (set! current-str
 144               (string-drop current-str (+ (split current-str) 1)))))
 145     (interpret-markup layout props
 146                       (make-line-markup
 147                        (map (lambda (word)
 148                               (if (string-every composite-chars word)
 149                                   (if (string-every char-set:dynamics word)
 150                                       (dyn-markup word)
 151                                       (let ((word-lst (string->list word)))
 152                                         (make-concat-markup
 153                                          (map (lambda (ch)
 154                                                 (let ((print-ch (string ch)))
 155                                                   (if (char-punctuation? ch)
 156                                                       (text-markup print-ch)
 157                                                       (dyn-markup print-ch))))
 158                                               word-lst))))
 159                                   (text-markup word)))
 160                             str-list)))))
 161
 162 (define-markup-command (fill-page layout props args)
 163   (markup-list?)
 164   #:properties ((text-direction UP)
 165                 (line-space 0.6)
 166                 (page-height #f))
 167
 168   (define (get-fill-space line-count page-height line-space text-heights)
 169     (cond
 170     ((null? text-heights) '())
 171
 172     ;; special case first padding
 173     ((= (length text-heights) line-count)
 174       (cons
 175       (- (- (/ page-height (1- line-count)) (car text-heights))
 176           (/ (car (cdr text-heights)) 2))
 177       (get-fill-space line-count page-height line-space (cdr text-heights))))
 178     ;; special case last padding
 179     ((= (length text-heights) 2)
 180       (list (- (/ page-height (1- line-count))
 181              (+ (/ (car text-heights) 2) (car (cdr text-heights)))) 0))
 182    (else
 183     (let ((default-padding
 184             (- (/ page-height (1- line-count))
 185                (/ (+ (car text-heights) (car (cdr text-heights))) 2))))
 186       (cons
 187        (if (> line-space default-padding)
 188            line-space
 189            default-padding)
 190        (get-fill-space line-count page-height line-space (cdr text-heights)))))))
 191
 192   (let* ((orig-stencils (interpret-markup-list layout props args))
 193          (stencils
 194           (map (lambda (stc)
 195                  (if (ly:stencil-empty? stc)
 196                      point-stencil
 197                      stc)) orig-stencils))
 198          (text-heights
 199           (map (lambda (stc)
 200                  (if (ly:stencil-empty? stc)
 201                      0.0
 202                      (interval-length (ly:stencil-extent stc Y))))
 203                stencils))
 204          (text-height (apply + text-heights))
 205          (line-count (length stencils))
 206          (page-height (- (ly:output-def-lookup layout 'paper-height)
 207                          (+ (ly:output-def-lookup layout 'top-margin)
 208                             (ly:output-def-lookup layout 'bottom-margin))))
 209          (fill-space
 210           (cond
 211            ((= line-count 1)
 212             (list
 213              (/ (- page-height text-height) 2)
 214              (/ (- page-height text-height) 2)))
 215            ((= line-count 2)
 216             (list
 217              (- page-height text-height)))
 218            (else
 219             (get-fill-space line-count page-height line-space text-heights))))
 220
 221          (page-contents (if (= line-count 1)
 222                             (list
 223                              point-stencil
 224                              (car stencils)
 225                              point-stencil)
 226                             stencils)))
 227
 228     (if (null? (remove ly:stencil-empty? orig-stencils))
 229         empty-stencil
 230         (begin
 231           (if (= text-direction UP)
 232               (set! page-contents (reverse page-contents)))
 233           (set! page-contents
 234                 (stack-stencils-padding-list
 235                  Y UP fill-space page-contents))
 236           (if (> line-count 1)
 237               (set! page-contents
 238                     (ly:stencil-translate-axis
 239                      page-contents
 240                      (- (car (ly:stencil-extent (car stencils) Y)))
 241                      Y)))
 242           page-contents))))
 243
 244
 245 ;; This markup-command may be overriden later by a theme-specific file.
 246 (define-markup-command (indic layout props arg) (markup?)
 247   (interpret-markup layout props
 248                     (markup #:whiteout #:medium #:small #:italic arg)))
 249
 250 (define-markup-command (bracketText layout props num up? arg) (number? boolean? markup?)
 251   (let* ((pos (max 3 (- 10 (- num))))
 252          (text (markup #:with-dimensions '(0 . 0)'(0 . 0) arg))
 253          (stack (lambda (x)
 254                    (markup #:normal-text #:fontsize 3
 255                            #:center-column
 256                            ((if up? text "")
 257                            #:with-dimensions
 258                            '(0 . .5)
 259                            (if up?
 260                                (cons 0 (+ x .2))
 261                                (cons (- x .2) 0))
 262                            #:postscript (format #f "
 263                              .12 setlinewidth
 264                              .5 0 -.5 0 lineto
 265                              -.5 0 -.5 ~a lineto
 266                              stroke" x)
 267                            (if up? "" text))))))
 268     (if (not up?) (set! pos (- pos)))
 269     (interpret-markup layout props (stack pos))))
 270
 271 (define-markup-command (copyright layout props) ()
 272   (let* ((maintainer (chain-assoc-get 'header:maintainer props))
 273          (this-year (+ 1900 (tm:year (gmtime (current-time)))))
 274          (year (string->number (or (chain-assoc-get 'header:copyrightYear props)
 275                                    (number->string this-year)))))
 276     (interpret-markup layout props
 277      (markup "Copyright ©"
 278              (if (= year this-year)
 279                  (format #f "~a" this-year)
 280                  (format #f "~a-~a" year this-year))
 281              maintainer))))
 282
 283 (define-markup-command (today layout props) ()
 284   (let ((today (gmtime (current-time))))
 285    (interpret-markup layout props
 286      (format #f "~a-~a-~a"
 287              (+ 1900 (tm:year today))
 288              (1+ (tm:mon today))
 289              (tm:mday today)))))
 290
 291