scm/music-functions.scm

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; tuplets.
   3
   4 (define-public (denominator-tuplet-formatter mus)
   5   (number->string (ly:get-mus-property mus 'denominator)))
   6
   7 (define-public (fraction-tuplet-formatter mus)
   8   (string-append (number->string (ly:get-mus-property mus 'numerator))
   9                  ":"
  10                  (number->string (ly:get-mus-property mus 'denominator))
  11                  ))
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14
  15
  16 (define-public (shift-duration-log music shift dot)
  17   "Recurse through music, adding SHIFT to ly:duration-log and optionally
  18   a dot to any note encountered. This scales the music up by a factor
  19   2^shift * (2 - (1/2)^dot)"
  20   (let* ((es (ly:get-mus-property music 'elements))
  21          (e (ly:get-mus-property music 'element))
  22          (n  (ly:music-name music))
  23          (f  (lambda (x)  (shift-duration-log x shift dot)))
  24          )
  25
  26     ;; FIXME: broken by the great music rename.
  27     (if (or (equal? n "Note_req")
  28             (equal? n "Rest_req"))
  29         (let* (
  30                (d (ly:get-mus-property music 'duration))
  31                (cp (ly:duration-factor d))
  32                (nd (ly:make-duration (+ shift (ly:duration-log d))
  33                                   (+ dot (duration-dot-count d))
  34                                   (car cp)
  35                                   (cdr cp)))
  36
  37                )
  38           (ly:set-mus-property! music 'duration nd)
  39           ))
  40
  41     (if (pair? es)
  42         (ly:set-mus-property!
  43          music 'elements
  44          (map f es)))
  45
  46     (if (ly:music? e)
  47         (ly:set-mus-property!
  48          music 'element
  49          (f e)))
  50
  51     music))
  52
  53
  54 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55 ;; repeats.
  56
  57 (define-public (unfold-repeats music)
  58 "
  59 This function replaces all repeats  with unfold repeats. It was
  60 written by Rune Zedeler. "
  61   (let* ((es (ly:get-mus-property music 'elements))
  62          (e (ly:get-mus-property music 'element))
  63          (n  (ly:music-name music)))
  64
  65     (if (equal? n "Repeated_music")
  66         (begin
  67           (if (equal?
  68                (ly:get-mus-property music 'iterator-ctor)
  69                Chord_tremolo_iterator::constructor)
  70               (shift-duration-log music  (ly:intlog2 (ly:get-mus-property music 'repeat-count)) 0)
  71               )
  72           (ly:set-mus-property!
  73            music 'length Repeated_music::unfolded_music_length)
  74           (ly:set-mus-property!
  75            music 'start-moment-function Repeated_music::first_start)
  76           (ly:set-mus-property!
  77            music 'iterator-ctor Unfolded_repeat_iterator::constructor)))
  78
  79     (if (pair? es)
  80         (ly:set-mus-property!
  81          music 'elements
  82          (map unfold-repeats es)))
  83
  84     (if (ly:music? e)
  85         (ly:set-mus-property!
  86          music 'element
  87          (unfold-repeats e)))
  88
  89     music))
  90
  91
  92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  93 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94
  95 (define  (pitchify-scripts music)
  96   "Copy the pitch fields of the Note_requests into  Text_script_requests, to aid
  97 Fingering_engraver."
  98   (define (find-note musics)
  99     (filter-list (lambda (m) (equal? (ly:music-name m) "Note_req")) musics)
 100     )
 101   (define (find-scripts musics)
 102     (filter-list (lambda (m) (equal? (ly:music-name m) "Text_script_req")) musics))
 103
 104   (let* (
 105          (e (ly:get-mus-property music 'element))
 106          (es (ly:get-mus-property music 'elements))
 107          (notes (find-note es))
 108          (pitch (if (pair? notes) (ly:get-mus-property (car  notes) 'pitch) #f))
 109          )
 110
 111     (if pitch
 112         (map (lambda (x) (ly:set-mus-property! x 'pitch pitch)) (find-scripts es))
 113         )
 114
 115     (if (pair? es)
 116         (ly:set-mus-property!
 117          music 'elements
 118          (map pitchify-scripts es)))
 119
 120     (if (ly:music? e)
 121         (ly:set-mus-property!
 122          music 'element
 123          (pitchify-scripts e)))
 124
 125     music))
 126
 127
 128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 129 ;; property setting music objs.
 130 (define-public (make-grob-property-set grob gprop val)
 131   "Make a M-exp that sets GPROP to VAL in GROBS. Does a pop first, i.e.
 132 this is not an override
 133 "
 134
 135    (let* ((m (make-music-by-name  'OverrideProperty)))
 136      (ly:set-mus-property! m 'symbol grob)
 137      (ly:set-mus-property! m 'grob-property gprop)
 138      (ly:set-mus-property! m 'grob-value val)
 139      (ly:set-mus-property! m 'pop-first #t)
 140
 141      m
 142
 143    ))
 144
 145
 146 (define-public (make-grob-property-revert grob gprop)
 147   "Revert the grob property GPROP for GROB."
 148    (let* ((m (make-music-by-name  'OverrideProperty)))
 149      (ly:set-mus-property! m 'symbol grob)
 150      (ly:set-mus-property! m 'grob-property gprop)
 151
 152      m
 153
 154    ))
 155
 156 (define-public (make-voice-props-set n)
 157   (make-sequential-music
 158    (append
 159       (map (lambda (x) (make-grob-property-set x 'direction
 160                                                (if (odd? n) -1 1)))
 161            '(Tie Slur Stem Dots))
 162       (list
 163        (make-grob-property-set 'NoteColumn 'horizontal-shift (quotient n 2))
 164        (make-grob-property-set 'MultiMeasureRest 'staff-position
 165                                (if (odd? n) -4 4)
 166                                )
 167
 168        )
 169    )
 170   ))
 171
 172 (define-public (make-voice-props-revert)
 173   (make-sequential-music
 174    (list
 175       (make-grob-property-revert 'Tie 'direction)
 176       (make-grob-property-revert 'Dots 'direction)
 177       (make-grob-property-revert 'Stem 'direction)
 178       (make-grob-property-revert 'Slur 'direction)
 179       (make-grob-property-revert 'NoteColumn 'horizontal-shift)
 180    ))
 181   )
 182
 183 (define-public (context-spec-music m context . rest)
 184   "Add \context CONTEXT = foo to M. "
 185
 186   (let* ((cm (make-music-by-name 'ContextSpeccedMusic)))
 187     (ly:set-mus-property! cm 'element m)
 188     (ly:set-mus-property! cm 'context-type context)
 189     (if (and  (pair? rest) (string? (car rest)))
 190         (ly:set-mus-property! cm 'context-id (car rest))
 191     )
 192     cm
 193   ))
 194
 195 (define-public (make-sequential-music elts)
 196   (let*  ((m (make-music-by-name 'SequentialMusic)))
 197     (ly:set-mus-property! m 'elements elts)
 198     m
 199   ))
 200
 201 (define-public (make-simultaneous-music elts)
 202   (let*  ((m (make-music-by-name 'SimultaneousMusic)))
 203     (ly:set-mus-property! m 'elements elts)
 204     m
 205     ))
 206
 207 (define-public (make-event-chord elts)
 208   (let*  ((m (make-music-by-name 'EventChord)))
 209     (ly:set-mus-property! m 'elements elts)
 210     m
 211     ))
 212
 213
 214 (define-public (make-multi-measure-rest duration location)
 215   (let*
 216       (
 217        (start (make-music-by-name 'MultiMeasureRestEvent))
 218        (stop  (make-music-by-name 'MultiMeasureRestEvent))
 219        (skip ( make-music-by-name 'SkipEvent))
 220        (ch (make-music-by-name 'BarCheck))
 221        (ch2  (make-music-by-name 'BarCheck))
 222        )
 223
 224     (ly:set-mus-property! start 'span-direction START)
 225     (ly:set-mus-property! stop 'span-direction STOP)
 226     (ly:set-mus-property! skip 'duration duration)
 227     (map (lambda (x) (ly:set-mus-property! x 'origin location))
 228          (list start stop skip ch ch2))
 229     (make-sequential-music
 230      (list
 231       ch
 232       (make-event-chord (list start))
 233       (make-event-chord (list skip))
 234       (make-event-chord (list stop))
 235       ch2
 236       ))
 237     ))
 238
 239 (define-public (make-penalty-music pen)
 240  (let
 241      ((m (make-music-by-name 'BreakEvent)))
 242    (ly:set-mus-property! m 'penalty pen)
 243    m))
 244
 245 (define-public (make-articulation name)
 246   (let* (
 247          (m (make-music-by-name 'ArticulationEvent))
 248       )
 249       (ly:set-mus-property! m 'articulation-type name)
 250       m
 251   ))
 252
 253 (define-public (make-span-event type spandir)
 254   (let* (
 255          (m (make-music-by-name  type))
 256          )
 257     (ly:set-mus-property! m 'span-direction spandir)
 258     m
 259     ))
 260
 261 (define-public (set-mus-properties! m alist)
 262   "Set all of ALIST as properties of M."
 263   (if (pair? alist)
 264       (begin
 265         (ly:set-mus-property! m (caar alist) (cdar alist))
 266         (set-mus-properties! m (cdr alist)))
 267   ))
 268
 269 (define-public (music-separator? m)
 270   "Is M a separator?"
 271   (let* ((ts (ly:get-mus-property m 'types )))
 272     (memq 'separator ts)
 273   ))
 274
 275 (define (split-one sep?  l acc)
 276   "Split off the first parts before separator and return both parts.
 277
 278 "
 279   (if (null? l)
 280       (cons acc '())
 281       (if (sep? (car l))
 282           (cons acc (cdr l))
 283           (split-one sep? (cdr l) (cons (car l) acc))
 284           )
 285       ))
 286
 287 (define-public (split-list l sep?)
 288   "
 289
 290 (display (split-list '(a b c / d e f / g) (lambda (x) (equal? x '/))) )
 291 =>
 292  ...
 293
 294 "
 295   (if (null? l)
 296       '()
 297       (let* ((c (split-one sep? l '())))
 298         (cons (reverse! (car c) '()) (split-list (cdr c) sep?))
 299         )
 300       )
 301   )
 302
 303 ;;; splitting chords into voices.
 304
 305 (define (voicify-list lst number)
 306    "Make a list of Musics.
 307
 308    voicify-list :: [ [Music ] ] -> number -> [Music]
 309    LST is a list music-lists.
 310 "
 311
 312    (if (null? lst) '()
 313        (cons (context-spec-music
 314               (make-sequential-music
 315                (list
 316                 (make-voice-props-set number)
 317                 (make-simultaneous-music (car lst))))
 318
 319               "Voice"  (number->string number))
 320               (voicify-list (cdr lst) (+ number 1))
 321        ))
 322    )
 323
 324 (define (voicify-chord ch)
 325   "Split the parts of a chord into different Voices using separator"
 326    (let* ((es (ly:get-mus-property ch 'elements)))
 327
 328
 329      (ly:set-mus-property!  ch 'elements
 330        (voicify-list (split-list es music-separator?) 0))
 331      ch
 332    ))
 333
 334 (define (voicify-music m)
 335    "Recursively split chords that are separated with \\ "
 336
 337    (if (not (ly:music? m))
 338        (begin (display m)
 339        (error "not music!"))
 340        )
 341    (let*
 342        ((es (ly:get-mus-property m 'elements))
 343         (e (ly:get-mus-property m 'element))
 344         )
 345      (if (pair? es)
 346          (ly:set-mus-property! m 'elements (map voicify-music es)))
 347      (if (ly:music? e)
 348          (ly:set-mus-property! m 'element  (voicify-music e)))
 349      (if
 350       (and (equal? (ly:music-name m) "Simultaneous_music")
 351            (reduce (lambda (x y ) (or x y))     (map music-separator? es)))
 352       (voicify-chord m)
 353       )
 354
 355      m
 356      ))
 357
 358 (define-public (empty-music)
 359   (ly:export (make-music-by-name 'Music))
 360   )
 361 ;;;
 362
 363 ; Make a function that checks score element for being of a specific type.
 364 (define-public (make-type-checker symbol)
 365   (lambda (elt)
 366     ;;(display  symbol)
 367     ;;(eq? #t (ly:get-grob-property elt symbol))
 368     (not (eq? #f (memq symbol (ly:get-grob-property elt 'interfaces))))))
 369
 370
 371 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 372 ;; warn for bare chords at start.
 373
 374 (define (has-request-chord elts)
 375   (reduce (lambda (x y) (or x y)) (map (lambda (x) (equal? (ly:music-name x)
 376                                                            "Request_chord")) elts)
 377   ))
 378
 379 (define (ly:music-message music msg)
 380   (let* (
 381       (ip (ly:get-mus-property music 'origin))
 382       )
 383
 384     (if (ly:input-location? ip)
 385         (ly:input-message ip msg)
 386         (ly:warn msg))
 387   ))
 388
 389 (define (check-start-chords music)
 390   "Check music expression for a Simultaneous_music containing notes\n(ie. Request_chords), without context specification. Called  from parser."
 391
 392      (let*
 393        ((es (ly:get-mus-property music 'elements))
 394         (e (ly:get-mus-property music 'element))
 395         (name (ly:music-name music))
 396         )
 397
 398        (cond
 399          ((equal? name "Context_specced_music") #t)
 400          ((equal? name "Simultaneous_music")
 401
 402           (if (has-request-chord es)
 403               (ly:music-message music "Starting score with a chord.\nPlease insert an explicit \\context before chord")
 404               (map check-start-chords es)))
 405
 406          ((equal? name "Sequential_music")
 407            (if (pair? es)
 408                (check-start-chords (car es))))
 409           (else (if (ly:music? e) (check-start-chords e )))
 410
 411        ))
 412      music
 413      )
 414
 415
 416 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 417 ;; switch it on here, so parsing and init isn't checked (too slow!)
 418
 419 ;; automatic music transformations.
 420
 421 (define (switch-on-debugging m)
 422   (set-debug-cell-accesses! 15000)
 423   m
 424   )
 425
 426 (define-public toplevel-music-functions
 427   (list check-start-chords
 428         voicify-music
 429
 430 ; switch-on-debugging
 431         ))
 432
 433