scm/ly-syntax-constructors.scm

   1 ;;;; This file is part of LilyPond, the GNU music typesetter.
   2 ;;;;
   3 ;;;; Copyright (C) 2006--2015 Erik Sandberg <mandolaerik@gmail.com>
   4 ;;;;
   5 ;;;; LilyPond is free software: you can redistribute it and/or modify
   6 ;;;; it under the terms of the GNU General Public License as published by
   7 ;;;; the Free Software Foundation, either version 3 of the License, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; LilyPond is distributed in the hope that it will be useful,
  11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;;;; GNU General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with LilyPond.  If not, see <http://www.gnu.org/licenses/>.
  17
  18 (define-module (scm ly-syntax-constructors)
  19   #:use-module (lily)
  20   #:use-module (srfi srfi-1))
  21
  22 ;; Sets music origin to (*location*)
  23 (define (here! m)
  24   (set! (ly:music-property m 'origin) (*location*))
  25   m)
  26
  27 (define-public (music-function-call-error fun m)
  28   (let* ((sig (ly:music-function-signature fun))
  29          (pred (if (pair? (car sig)) (caar sig) (car sig))))
  30     (ly:parser-error
  31      (format #f (_ "~a function cannot return ~a")
  32              (type-name pred)
  33              (value->lily-string m))
  34      (*location*))
  35     (and (pair? (car sig)) (cdar sig))))
  36
  37 ;; Music function: Apply function and check return value.
  38 ;; args are in reverse order, rest may specify additional ones
  39 ;;
  40 ;; If args is not a proper list, an error has been flagged earlier
  41 ;; and no fallback value had been available.  In this case,
  42 ;; we don't call the function but rather return the general
  43 ;; fallback.
  44 (define-public (music-function fun args . rest)
  45   (let* ((sig (ly:music-function-signature fun))
  46          (pred (if (pair? (car sig)) (caar sig) (car sig)))
  47          (good (proper-list? args))
  48          (m (and good (apply (ly:music-function-extract fun)
  49                              (reverse! args rest)))))
  50     (if (and good (pred m))
  51         (if (ly:music? m) (here! m) m)
  52         (if good
  53             (music-function-call-error fun m)
  54             (and (pair? (car sig)) (cdar sig))))))
  55
  56 (define-public (argument-error n pred arg)
  57   (ly:parser-error
  58    (format #f
  59            (_ "wrong type for argument ~a.  Expecting ~a, found ~s")
  60            n (type-name pred) (music->make-music arg))
  61    (*location*)))
  62
  63 (define-public (void-music)
  64   (here! (make-music 'Music)))
  65
  66 (define-public (sequential-music mlist)
  67   (here! (make-sequential-music mlist)))
  68
  69 (define-public (simultaneous-music mlist)
  70   (here! (make-simultaneous-music mlist)))
  71
  72 (define-public (event-chord mlist)
  73   (here! (make-music 'EventChord
  74                      'elements mlist)))
  75
  76 (define-public (unrelativable-music mus)
  77   (here! (make-music 'UnrelativableMusic
  78                      'element mus)))
  79
  80 (define-public (context-change type id)
  81   (here! (make-music 'ContextChange
  82                      'change-to-type type
  83                      'change-to-id id)))
  84
  85 (define-public (tempo text . rest)
  86   (let* ((unit (and (pair? rest)
  87                     (car rest)))
  88          (count (and unit
  89                      (cadr rest)))
  90          (range-tempo? (pair? count))
  91          (tempo-change (here! (make-music 'TempoChangeEvent
  92                                           'text text
  93                                           'tempo-unit unit
  94                                           'metronome-count count)))
  95          (tempo-set
  96           (and unit
  97                (context-spec-music
  98                 (make-property-set 'tempoWholesPerMinute
  99                                    (ly:moment-mul
 100                                     (ly:make-moment
 101                                      (if range-tempo?
 102                                          (round (/ (+ (car count) (cdr count))
 103                                                    2))
 104                                          count)
 105                                      1)
 106                                     (ly:duration-length unit)))
 107                 'Score))))
 108
 109     (if tempo-set
 110         (make-sequential-music (list tempo-change tempo-set))
 111         tempo-change)))
 112
 113 (define-public (repeat type num body alts)
 114   (here! (make-repeat type num body alts)))
 115
 116 (define (script-to-mmrest-text music)
 117   "Extract @code{'direction} and @code{'text} from @var{music}, and transform
 118 into a @code{MultiMeasureTextEvent}."
 119
 120   (if (music-is-of-type? music 'script-event)
 121       (make-music 'MultiMeasureTextEvent music)
 122       music))
 123
 124 (define-public (multi-measure-rest duration articulations)
 125   (here! (make-music 'MultiMeasureRestMusic
 126                      'articulations (map script-to-mmrest-text articulations)
 127                      'duration duration)))
 128
 129 (define-public (repetition-chord duration articulations)
 130   (here! (make-music 'EventChord
 131                      'duration duration
 132                      'elements articulations)))
 133
 134 (define-public (context-specification type id ops create-new mus)
 135   (let ((csm (context-spec-music mus type id)))
 136     (set! (ly:music-property csm 'property-operations) ops)
 137     (if create-new (set! (ly:music-property csm 'create-new) #t))
 138     (here! csm)))
 139
 140 (define-public (composed-markup-list commands markups)
 141   ;; `markups' being a list of markups, eg (markup1 markup2 markup3),
 142   ;; and `commands' a list of commands with their scheme arguments, in reverse order,
 143   ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 144   ;;  ((bold (raise 4 (italic markup1)))
 145   ;;   (bold (raise 4 (italic markup2)))
 146   ;;   (bold (raise 4 (italic markup3))))
 147
 148   (define (compose arg)
 149     (fold
 150      (lambda (cmd prev) (append cmd (list prev)))
 151      arg
 152      commands))
 153   (let loop ((markups markups) (completed '()))
 154     (cond ((null? markups) (reverse! completed))
 155           ((markup? (car markups))
 156            (loop (cdr markups)
 157                  (cons (compose (car markups)) completed)))
 158           (else
 159            (call-with-values
 160                (lambda () (break! markup? markups))
 161              (lambda (complex rest)
 162                (loop rest
 163                      (reverse!
 164                       (make-map-markup-commands-markup-list
 165                        compose complex) completed))))))))
 166
 167 (define-public (property-operation ctx music-type symbol . args)
 168   (let* ((props (case music-type
 169                   ((PropertySet) (list 'value (car args)))
 170                   ((PropertyUnset) '())
 171                   ((OverrideProperty) (list 'grob-value (car args)
 172                                             'grob-property-path (if (list? (cadr args))
 173                                                                     (cadr args)
 174                                                                     (cdr args))
 175                                             'pop-first #t))
 176                   ((RevertProperty)
 177                    (if (list? (car args))
 178                        (list 'grob-property-path (car args))
 179                        (list 'grob-property-path args)))
 180                   (else (ly:error (_ "Invalid property operation ~a") music-type))))
 181          (m (here! (apply make-music music-type
 182                           'symbol symbol
 183                           props))))
 184     (here! (make-music 'ContextSpeccedMusic
 185                        'element m
 186                        'context-type ctx))))
 187
 188 (define (get-first-context-id! mus)
 189   "Find the name of a ContextSpeccedMusic, possibly naming it"
 190   (let ((id (ly:music-property mus 'context-id)))
 191     (if (eq? (ly:music-property mus 'name) 'ContextSpeccedMusic)
 192         (if (and (string? id)
 193                  (not (string-null? id)))
 194             id
 195             ;; We may reliably give a new context a unique name, but
 196             ;; not an existing one
 197             (if (ly:music-property mus 'create-new #f)
 198                 (let ((id (get-next-unique-voice-name)))
 199                   (set! (ly:music-property mus 'context-id) id)
 200                   id)
 201                 '()))
 202         '())))
 203
 204 (define-public (lyric-event text duration)
 205   (here! (make-lyric-event text duration)))
 206
 207 (define (lyric-combine-music sync sync-type music loc)
 208   ;; CompletizeExtenderEvent is added following the last lyric in MUSIC
 209   ;; to signal to the Extender_engraver that any pending extender should
 210   ;; be completed if the lyrics end before the associated voice.
 211   (append! (ly:music-property music 'elements)
 212            (list (make-music 'CompletizeExtenderEvent)))
 213   (make-music 'LyricCombineMusic
 214               'element music
 215               'associated-context sync
 216               'associated-context-type sync-type
 217               'origin loc))
 218
 219 (define-public (lyric-combine voice typ music)
 220   (lyric-combine-music voice typ music (*location*)))
 221
 222 (define-public (add-lyrics music addlyrics-list)
 223   (let* ((existing-voice-name (get-first-context-id! music))
 224          (voice-name (if (string? existing-voice-name)
 225                          existing-voice-name
 226                          (get-next-unique-voice-name)))
 227          (voice (if (string? existing-voice-name)
 228                     music
 229                     (make-music 'ContextSpeccedMusic
 230                                 'element music
 231                                 'context-type 'Voice
 232                                 'context-id voice-name
 233                                 'origin (ly:music-property music 'origin))))
 234          (voice-type (ly:music-property voice 'context-type))
 235          (lyricstos (map (lambda (mus)
 236                            (let* ((loc (ly:music-property mus 'origin))
 237                                   (lyr (lyric-combine-music
 238                                         voice-name voice-type mus loc)))
 239                              (make-music 'ContextSpeccedMusic
 240                                          'create-new #t
 241                                          'context-type 'Lyrics
 242                                          'element lyr
 243                                          'origin loc)))
 244                          addlyrics-list)))
 245     (make-simultaneous-music (cons voice lyricstos))))