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