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