bin/text.scm

   1 ;------------------------------------------------------------------;
   2 ; opus_libre -- text.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 ;; Macros for entering text elements.
  21
  22 (scm-load "../lib/libtext.scm")
  23 (scm-load "../lib/libgraphics.scm")
  24
  25 ;; Composite dynamics ---------------------------------------------;
  26 (define dyn
  27   (define-event-function (parser location arg) (markup?)
  28     (let ((d (make-music 'AbsoluteDynamicEvent)))
  29       (ly:music-set-property! d 'tweaks
  30         (acons 'self-alignment-X -0.8
  31           (ly:music-property d 'tweaks)))
  32       (ly:music-set-property! d 'text
  33         (cond
  34           ((string? arg)
  35            (if (string-every char-set:dynamics arg)
  36                arg
  37                (markup #:dynamic-string arg)))
  38           (else arg)))
  39       d)))
  40
  41 (define dyncresc
  42   (define-event-function (parser location arg) (markup?)
  43     (make-music 'CrescendoEvent 'span-direction START
  44                 'span-type 'text
  45                 'span-text (cond
  46                             ((string? arg)
  47                              (if (string-every char-set:dynamics arg)
  48                                  arg
  49                                  (markup #:dynamic-string arg)))
  50                             (else arg)))))
  51
  52 (define dyndim
  53   (define-event-function (parser location arg) (markup?)
  54     (make-music 'DecrescendoEvent 'span-direction START
  55                 'span-type 'text
  56                 'span-text (cond
  57                             ((string? arg)
  58                              (if (string-every char-set:dynamics arg)
  59                                  arg
  60                                  (markup #:dynamic-string arg)))
  61                             (else arg)))))
  62
  63 ;; Adapted from LSR snippet #233 (from Reinhold?)
  64 (define (make-hairpin-text dir text)
  65   (make-music
  66      'OverrideProperty 'once #t
  67      'grob-property-path (list 'stencil)
  68      'grob-value (lambda (grob)
  69                    (ly:stencil-aligned-to
  70                     (ly:stencil-combine-at-edge
  71                      (ly:stencil-aligned-to (ly:hairpin::print grob) X CENTER)
  72                      Y dir ;;FIXME:direction should be computer automatically
  73                      (ly:stencil-aligned-to (grob-interpret-markup grob
  74                                                (make-indic-markup text)) X CENTER))
  75                     X LEFT))
  76      'symbol
  77      'Hairpin))
  78
  79 ;; (define *hairpin-text-direction* (make-parameter #f))
  80 ;; (define hairpinText
  81 ;;   (define-music-function (parser location text) (markup?)
  82 ;;     (make-sequential-music
  83 ;;      (list
  84 ;;        (make-music
  85 ;;         'ApplyContext
  86 ;;         'procedure (lambda (ctx)
  87 ;;                      (let ((parent-staff (ly:context-id (ly:context-parent ctx)))
  88 ;;                            (global-dir (assoc-get 'direction
  89 ;;                                                   (ly:context-grob-definition ctx 'DynamicLineSpanner))))
  90 ;;                        (*hairpin-text-direction*
  91 ;;                         (if (or (string-suffix-ci? lang:upper-hand parent-staff)
  92 ;;                                 (eq? global-dir UP))
  93 ;;                             UP
  94 ;;                             DOWN)))))
  95 ;;         (make-hairpin-text (*hairpin-text-direction*) text)))))
  96
  97 (define hairpinText
  98   ;; beware - this is a _music_ function, not a postfix event!
  99   (define-music-function (parser location text) (markup?)
 100     (make-hairpin-text DOWN text)))
 101
 102 (define hairpinTextUp
 103   (define-music-function (parser location text) (markup?)
 104     (make-hairpin-text UP text)))
 105
 106 (define hairpinTextDown
 107   (define-music-function (parser location text) (markup?)
 108     (make-hairpin-text DOWN text)))
 109
 110 (define startText
 111   (define-event-function (parser location txt) (markup?)
 112      (make-text-span txt)))
 113
 114 ;; for consistency only.
 115 (define stopText
 116   stopTextSpan)
 117
 118 (define ten
 119   (define-music-function (parser location music) (ly:music?)
 120     (if
 121      (equal? (ly:music-property music 'name) 'EventChord)
 122      (set! (ly:music-property music 'elements)
 123            (append (ly:music-property music 'elements)
 124                    (list (make-music 'TextScriptEvent 'text
 125                                      ;; ugh. Haphazard alignment.
 126                                      (markup #:translate-scaled (cons 4 0)
 127                                              #:indic "(ten.)"))))))
 128     music))
 129
 130 (define ind
 131  (define-music-function (parser location text music) (string? ly:music?)
 132    (if
 133      (equal? (ly:music-property music 'name) 'EventChord)
 134      (set! (ly:music-property music 'elements)
 135            (append (ly:music-property music 'elements)
 136                   (list (make-music 'TextScriptEvent 'direction 1
 137                   'text (markup #:indic text))))))
 138    music))
 139
 140 (define bracketUp
 141   (define-music-function (parser location text music) (markup? ly:music?)
 142     (let ((current-staff-position 0))
 143       ; this shouldn't be needed!!!
 144       (set! current-staff-position -4)
 145       (make-music 'ApplyOutputEvent
 146                   'origin location
 147                   'context-type 'Voice
 148                   'procedure
 149                   (lambda (grob grob-origin context)
 150                     (let ((staff-pos (ly:grob-property grob 'staff-position)))
 151                       (if (number? staff-pos)
 152                           (set! current-staff-position staff-pos)))))
 153       #{ \once \set fingeringOrientations = #'(left)
 154          \once \override Fingering #'X-extent = #'(-2.0 . 0.0)
 155          $(add-bracket current-staff-position #t text music)
 156          $music #})))
 157
 158 (define bracketDown
 159   (define-music-function (parser location text music) (markup? ly:music?)
 160     (let ((current-staff-position 0))
 161       ; this shouldn't be needed!!!
 162       (set! current-staff-position -1)
 163       (make-music 'ApplyOutputEvent
 164                   'origin location
 165                   'context-type 'Voice
 166                   'procedure
 167                   (lambda (grob grob-origin context)
 168                     (let ((staff-pos (ly:grob-property grob 'staff-position)))
 169                       (if (number? staff-pos)
 170                           (set! current-staff-position staff-pos)))))
 171       #{ \once \set fingeringOrientations = #'(left)
 172          \once \override Fingering #'X-extent = #'(-2.0 . 0.0)
 173          $(add-bracket current-staff-position #f text music)
 174          $music #})))
 175
 176 (define untaint
 177    (define-music-function (parser location expr) (ly:music?)
 178      #{ $(untaint-this expr) #}))