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 (define-public (music-function-call-error fun m)
  23   (let* ((sigcar (car (ly:music-function-signature fun)))
  24          (pred? (if (pair? sigcar) (car sigcar) sigcar)))
  25     (ly:parser-error
  26      (format #f (_ "~a function cannot return ~a")
  27              (type-name pred?)
  28              (value->lily-string m))
  29      (*location*))
  30     (and (pair? sigcar)
  31          (if (ly:music? (cdr sigcar))
  32              (ly:music-deep-copy (cdr sigcar) (*location*))
  33              (cdr sigcar)))))
  34
  35 ;; Music function: Apply function and check return value.
  36 ;; args are in reverse order.
  37 ;;
  38 ;; If args is not a proper list, an error has been flagged earlier
  39 ;; and no fallback value had been available.  In this case,
  40 ;; we don't call the function but rather return the general
  41 ;; fallback.
  42 (define-public (music-function fun args)
  43   (let* ((sigcar (car (ly:music-function-signature fun)))
  44          (pred? (if (pair? sigcar) (car sigcar) sigcar))
  45          (good (list? args))
  46          (m (and good (apply (ly:music-function-extract fun) (reverse! args)))))
  47     (if good
  48         (if (pred? m)
  49             (if (ly:music? m) (ly:set-origin! m) m)
  50             (music-function-call-error fun m))
  51         (and (pair? sigcar)
  52              (if (ly:music (cdr sigcar))
  53                  (ly:music-deep-copy (cdr sigcar) (*location*))
  54                  (cdr sigcar))))))
  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 (partial-music-function fun args)
  64   (let* ((sig (ly:music-function-signature fun))
  65          (args (and (list args) (reverse! args))))
  66     (and args
  67          (ly:make-music-function
  68           (cons (car sig) (list-tail (cdr sig) (length args)))
  69           (lambda rest
  70             (apply (ly:music-function-extract fun)
  71                    (append args rest)))))))
  72
  73 (define-public (void-music)
  74   (ly:set-origin! (make-music 'Music)))
  75
  76 (define-public (sequential-music mlist)
  77   (ly:set-origin! (make-sequential-music mlist)))
  78
  79 (define-public (simultaneous-music mlist)
  80   (ly:set-origin! (make-simultaneous-music mlist)))
  81
  82 (define-public (event-chord mlist)
  83   (ly:set-origin! (make-music 'EventChord
  84                               'elements mlist)))
  85
  86 (define-public (unrelativable-music mus)
  87   (ly:set-origin! (make-music 'UnrelativableMusic
  88                               'element mus)))
  89
  90 (define-public (context-change type id)
  91   (ly:set-origin! (make-music 'ContextChange
  92                               'change-to-type type
  93                               'change-to-id id)))
  94
  95 (define-public (tempo text . rest)
  96   (let* ((unit (and (pair? rest)
  97                     (car rest)))
  98          (count (and unit
  99                      (cadr rest)))
 100          (range-tempo? (pair? count))
 101          (tempo-change (ly:set-origin! (make-music 'TempoChangeEvent
 102                                                    'text text
 103                                                    'tempo-unit unit
 104                                                    'metronome-count count)))
 105          (tempo-set
 106           (and unit
 107                (context-spec-music
 108                 (make-property-set 'tempoWholesPerMinute
 109                                    (ly:moment-mul
 110                                     (ly:make-moment
 111                                      (if range-tempo?
 112                                          (round (/ (+ (car count) (cdr count))
 113                                                    2))
 114                                          count)
 115                                      1)
 116                                     (ly:duration-length unit)))
 117                 'Score))))
 118
 119     (if tempo-set
 120         (make-sequential-music (list tempo-change tempo-set))
 121         tempo-change)))
 122
 123 (define-public (repeat type num body alts)
 124   (ly:set-origin! (make-repeat type num body alts)))
 125
 126 (define (script-to-mmrest-text music)
 127   "Extract @code{'direction} and @code{'text} from @var{music}, and transform
 128 into a @code{MultiMeasureTextEvent}."
 129
 130   (if (music-is-of-type? music 'script-event)
 131       (make-music 'MultiMeasureTextEvent music)
 132       music))
 133
 134 (define-public (multi-measure-rest duration articulations)
 135   (ly:set-origin! (make-music 'MultiMeasureRestMusic
 136                               'articulations (map script-to-mmrest-text articulations)
 137                               'duration duration)))
 138
 139 (define-public (repetition-chord duration articulations)
 140   (ly:set-origin! (make-music 'EventChord
 141                               'duration duration
 142                               'elements articulations)))
 143
 144 (define-public (context-specification type id ops create-new mus)
 145   (let ((csm (context-spec-music mus type id)))
 146     (set! (ly:music-property csm 'property-operations) ops)
 147     (if create-new (set! (ly:music-property csm 'create-new) #t))
 148     (ly:set-origin! csm)))
 149
 150 (define-public (composed-markup-list commands markups)
 151   ;; `markups' being a list of markups, eg (markup1 markup2 markup3),
 152   ;; and `commands' a list of commands with their scheme arguments, in reverse order,
 153   ;; eg: ((italic) (raise 4) (bold)), maps the commands on each markup argument, eg:
 154   ;;  ((bold (raise 4 (italic markup1)))
 155   ;;   (bold (raise 4 (italic markup2)))
 156   ;;   (bold (raise 4 (italic markup3))))
 157
 158   (define (compose arg)
 159     (fold
 160      (lambda (cmd prev) (append cmd (list prev)))
 161      arg
 162      commands))
 163   (let loop ((markups markups) (completed '()))
 164     (cond ((null? markups) (reverse! completed))
 165           ((markup? (car markups))
 166            (loop (cdr markups)
 167                  (cons (compose (car markups)) completed)))
 168           (else
 169            (call-with-values
 170                (lambda () (break! markup? markups))
 171              (lambda (complex rest)
 172                (loop rest
 173                      (reverse!
 174                       (make-map-markup-commands-markup-list
 175                        compose complex) completed))))))))
 176
 177 (define-public (property-operation ctx music-type symbol . args)
 178   (let* ((props (case music-type
 179                   ((PropertySet) (list 'value (car args)))
 180                   ((PropertyUnset) '())
 181                   ((OverrideProperty) (list 'grob-value (car args)
 182                                             'grob-property-path (if (list? (cadr args))
 183                                                                     (cadr args)
 184                                                                     (cdr args))
 185                                             'pop-first #t))
 186                   ((RevertProperty)
 187                    (if (list? (car args))
 188                        (list 'grob-property-path (car args))
 189                        (list 'grob-property-path args)))
 190                   (else (ly:error (_ "Invalid property operation ~a") music-type))))
 191          (m (ly:set-origin! (apply make-music music-type
 192                                    'symbol symbol
 193                                    props))))
 194     (ly:set-origin! (make-music 'ContextSpeccedMusic
 195                                 'element m
 196                                 'context-type ctx))))
 197
 198 (define (get-first-context-id! mus)
 199   "Find the name of a ContextSpeccedMusic, possibly naming it"
 200   (let ((id (ly:music-property mus 'context-id)))
 201     (if (eq? (ly:music-property mus 'name) 'ContextSpeccedMusic)
 202         (if (and (string? id)
 203                  (not (string-null? id)))
 204             id
 205             ;; We may reliably give a new context a unique name, but
 206             ;; not an existing one
 207             (if (ly:music-property mus 'create-new #f)
 208                 (let ((id (get-next-unique-voice-name)))
 209                   (set! (ly:music-property mus 'context-id) id)
 210                   id)
 211                 '()))
 212         '())))
 213
 214 (define-public (lyric-event text duration)
 215   (ly:set-origin! (make-lyric-event text duration)))
 216
 217 (define-public (lyric-combine sync sync-type music)
 218   ;; CompletizeExtenderEvent is added following the last lyric in MUSIC
 219   ;; to signal to the Extender_engraver that any pending extender should
 220   ;; be completed if the lyrics end before the associated voice.
 221   (append! (ly:music-property music 'elements)
 222            (list (make-music 'CompletizeExtenderEvent)))
 223   (ly:set-origin!
 224    (make-music 'LyricCombineMusic
 225                'element music
 226                'associated-context sync
 227                'associated-context-type sync-type)))
 228
 229 (define-public (add-lyrics music addlyrics-list)
 230   (let* ((existing-voice-name (get-first-context-id! music))
 231          (voice-name (if (string? existing-voice-name)
 232                          existing-voice-name
 233                          (get-next-unique-voice-name)))
 234          (voice (if (string? existing-voice-name)
 235                     music
 236                     (make-music 'ContextSpeccedMusic
 237                                 'element music
 238                                 'context-type 'Voice
 239                                 'context-id voice-name
 240                                 'origin (ly:music-property music 'origin))))
 241          (voice-type (ly:music-property voice 'context-type))
 242          (lyricstos (map
 243                      (lambda (mus)
 244                        (with-location
 245                         (ly:music-property mus 'origin)
 246                         (ly:set-origin! (make-music 'ContextSpeccedMusic
 247                                                     'create-new #t
 248                                                     'context-type 'Lyrics
 249                                                     'element
 250                                                     (lyric-combine
 251                                                      voice-name voice-type mus)))))
 252                      addlyrics-list)))
 253     (make-simultaneous-music (cons voice lyricstos))))