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