(set-xml-accept-only-string-valued-attributes-in 'midi #f)
(define (ensure-all-abstime-in! operation message-list)
(let ((delta-time-messages
(traverse-and-collect-all-from-ast
message-list
(lambda (x) (and (ast? x) (equal? (ast-element-name x) "NoteOn") (ast-attribute x 'deltaTime #f)))
id-1)))
(if (> (length delta-time-messages) 0)
(laml-error "Only absTime mode is supported by" operation))))
(define (ensure-all-deltatime-in! operation message-list)
(let ((delta-time-messages
(traverse-and-collect-all-from-ast
message-list
(lambda (x) (and (ast? x) (equal? (ast-element-name x) "NoteOn") (ast-attribute x 'absTime #f)))
id-1)))
(if (> (length delta-time-messages) 0)
(laml-error "Only deltaTime mode is supported by" operation))))
(define (fuzzy-drums message-list)
(map fuzzy-drum-1
message-list
(append (cdr message-list) (list #f))
(cons #f (butlast message-list))))
(define (fuzzy-drum-1 this-mes next-mes prev-mes)
(cond ((drum-message? this-mes)
(fuzzy-drum-message this-mes next-mes prev-mes))
(else this-mes)))
(define (fuzzy-drum-message this-mes next-mes prev-mes)
(let ((window-size (if (and this-mes next-mes prev-mes)
(max (- (as-number (ast-attribute next-mes 'absTime)) (as-number (ast-attribute this-mes 'absTime)))
(- (as-number (ast-attribute this-mes 'absTime)) (as-number (ast-attribute prev-mes 'absTime))))
0)))
(cond
((delete-message? this-mes) '())
((change-message-velocity? this-mes)
(copy-ast-mutate-attributes this-mes 'velocity (as-int-string (between 0 127 (+ (as-number (ast-attribute this-mes 'velocity)) (delta-velocity))))))
((move-message? this-mes)
(copy-ast-mutate-attributes this-mes 'absTime (as-int-string (+ (as-number (ast-attribute this-mes 'absTime)) (delta-move window-size)))))
(else this-mes))))
(define (drum-message? mes)
(or (equal? "9" (ast-attribute mes 'channel))
(equal? "10" (ast-attribute mes 'channel))))
(define delete-frequency 5)
(define move-frequency 5)
(define velocity-change-frequency 20)
(define velocity-max-change 40)
(define (delete-message? mes)
(let ((r (random 100)))
(< r delete-frequency)))
(define move-r 0)
(define (move-message? mes)
(let ((r (random 100)))
(if (< r move-frequency)
(begin (set! move-r r) #t)
(begin (set! move-r 0) #f))))
(define (delta-move window-size)
(if (even? move-r)
(- (to-int (* (/ move-r 100) window-size)))
(+ (to-int (* (/ move-r 100) window-size)))))
(define vel-r 0)
(define (change-message-velocity? mes)
(let ((r (random 100)))
(if (< r velocity-change-frequency)
(begin (set! vel-r r) #t)
(begin (set! vel-r 0) #f))))
(define (delta-velocity)
(to-int
(if (even? vel-r)
(- (* (/ vel-r 100) velocity-max-change))
(+ (* (/ vel-r 100) velocity-max-change)))))
(define (fade-out . message-list)
(fade-out-1 message-list))
(define (fade-out-1 message-list)
(let ((lgt (length message-list)))
(map
(lambda (mes-ast i)
(if (equal? (ast-element-name mes-ast) "NoteOn")
(copy-ast-mutate-attributes mes-ast
'velocity (fade-velocity lgt i (as-number (ast-attribute mes-ast 'velocity))))
mes-ast))
message-list
(number-interval 1 lgt))))
(define (fade-velocity n i input-velocity)
(as-int-string (between 0 127 (to-int (/ (* input-velocity (- n i)) n)))))
(define time-stretch
(xml-in-laml-positional-abstraction
1 0
(lambda (factor cont attr)
(time-stretch-1 factor cont))))
(define (time-stretch-1 factor message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((delta-time (ast-attribute mes-ast 'deltaTime #f))
(abs-time (ast-attribute mes-ast 'absTime #f)))
(cond (delta-time
(copy-ast-mutate-attributes mes-ast
'deltaTime (as-int-string (* (as-number delta-time) factor))))
(abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (* (as-number abs-time) factor))))
(else (laml-error "Can only time stretch in deltaTime and absTime mode"))))
mes-ast))
message-list))
(define time-displace
(xml-in-laml-positional-abstraction
1 0
(lambda (amount cont attr)
(time-displace-1 amount cont))))
(define (time-displace-1 amount message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((abs-time (ast-attribute mes-ast 'absTime #f)))
(cond (abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (+ (as-number abs-time) amount))))
(else (laml-error "Can only time displace in absTime mode"))))
mes-ast))
message-list))
(define time-displace-channels
(xml-in-laml-positional-abstraction
2 0
(lambda (channel-list amount cont attr)
(time-displace-channels-1 channel-list amount cont))))
(define (time-displace-channels-1 ch-list amount message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(let ((channel-num (as-number channel)))
(if (member channel-num ch-list)
(let ((abs-time (ast-attribute mes-ast 'absTime #f)))
(cond (abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (+ (as-number abs-time) amount))))
(else (laml-error "Can only time displace in absTime mode"))))
mes-ast))
mes-ast))
mes-ast))
message-list))
(define add-to-velocity
(xml-in-laml-positional-abstraction
2 0
(lambda (channel amount cont attr)
(add-to-velocity-1 channel amount cont))))
(define (add-to-velocity-1 channel amount message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "NoteOn"))
(let ((velocity (ast-attribute mes-ast 'velocity #f)))
(cond (velocity
(copy-ast-mutate-attributes mes-ast
'velocity (as-int-string (between 0 127 (+ (as-number velocity) amount)))))
(else (laml-error "Cannot find velocity of NoteOn message. Should not happen"))))
mes-ast))
message-list))
(define replicate
(xml-in-laml-positional-abstraction 1 0
(lambda (n cont attr)
(replicate-1 n cont))))
(define (replicate-1 n message-list)
(cond ((= n 0) '())
(else (append message-list (replicate-1 (- n 1) message-list)))))
(define octave
(xml-in-laml-positional-abstraction
2 0
(lambda (ch n cont attr)
(octave-1 ch n cont))))
(define (octave-1 c n message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (or (equal? "NoteOn" (ast-element-name mes-ast)) (equal? "NoteOff" (ast-element-name mes-ast))))
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if (and channel (= (as-number channel) c))
(let* ((old-note (as-number (ast-attribute mes-ast 'note)))
(new-note (+ old-note (* 12 n))))
(if (or (> new-note 127) (< new-note 0))
(laml-error "Octave underflow or overflow" (ast-attribute mes-ast 'info) new-note))
(copy-ast-mutate-attributes mes-ast 'note new-note))
mes-ast))
mes-ast))
message-list))
(define interpolate
(xml-in-laml-positional-abstraction
1 0
(lambda (channel cont attr)
(interpolate-1 channel cont #f))))
(define (interpolate-1 ch message-list prev-ast)
(cond ((and (null? message-list) prev-ast) (list prev-ast))
((and (null? message-list) (not prev-ast)) '())
((and (ast? (car message-list))
(equal? "NoteOn" (ast-element-name (car message-list)))
(= (as-number (ast-attribute (car message-list) 'channel #f)) ch))
(if (not prev-ast)
(interpolate-1 ch (cdr message-list) (car message-list))
(let* ((first prev-ast)
(second (car message-list))
(note-in-between-list (calculate-note-in-between first second))
)
(cons
(cons first note-in-between-list)
(interpolate-1 ch (cdr message-list) second)
))))
(else (cons (car message-list)
(interpolate-1 ch (cdr message-list) prev-ast))) ))
(define quantize
(xml-in-laml-positional-abstraction
3 0
(lambda (channel q pulses-per-quarter-note cont attr)
(quantize-1 channel q pulses-per-quarter-note cont))))
(define (quantize-1 c q pulses-per-quarter-note message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)))
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if (and channel (= (as-number channel) c))
(let ((abs-time (ast-attribute mes-ast 'absTime)))
(if (not abs-time)
(laml-error "Can only quantize in absTime mode"))
(let ((time-interval (time-interval-of-note q pulses-per-quarter-note)))
(copy-ast-mutate-attributes mes-ast
'absTime (quantize-int (as-number abs-time) time-interval))))))
mes-ast))
message-list))
(define distribute-even
(xml-in-laml-positional-abstraction
1 0
(lambda (channel cont attr)
(distribute-even-1 channel cont))))
(define (distribute-even-1 channel message-list)
(ensure-all-abstime-in! "distribute-even" message-list)
(let* ((relevante-note-on-list
(filter (lambda (x)
(and (ast? x) (equal? "NoteOn" (ast-element-name x)) (= (as-number (ast-attribute x 'channel #f)) channel)))
message-list))
(number-of-relevant-notes (length relevante-note-on-list ))
)
(if (>= number-of-relevant-notes 3)
(let* ((abs-time-first (as-number (ast-attribute (first relevante-note-on-list) 'absTime #f)))
(abs-time-last (as-number (ast-attribute (last relevante-note-on-list) 'absTime #f)))
(distance (/ (- abs-time-last abs-time-first) (- number-of-relevant-notes 1)))
)
(distribute-even-2 channel message-list distance 0 abs-time-first) )
message-list)))
(define (distribute-even-2 channel message-list distance i start-time)
(cond ((null? message-list) '())
((and (ast? (car message-list)) (equal? "NoteOn" (ast-element-name (car message-list))) (= (as-number (ast-attribute (car message-list) 'channel #f)) channel))
(cons (copy-ast-mutate-attributes (car message-list) 'absTime (as-int-string (to-int (+ (* i distance) start-time))))
(distribute-even-2 channel (cdr message-list) distance (+ i 1) start-time)))
(else (cons (car message-list) (distribute-even-2 channel (cdr message-list) distance i start-time)))))
(define (quantize-int i factor)
(let* ((half-factor (/ factor 2))
(rem (remainder i factor))
(quot (quotient i factor))
(grid-point (* quot factor))
)
(if (<= rem half-factor)
grid-point
(+ grid-point factor))))
(define (time-interval-of-note note-value pulses-per-quarter-note)
(cond ((= 1 note-value) (* 4 pulses-per-quarter-note))
((= 2 note-value) (* 2 pulses-per-quarter-note))
((= 4 note-value) pulses-per-quarter-note)
((= 8 note-value) (/ pulses-per-quarter-note 2))
((= 16 note-value) (/ pulses-per-quarter-note 4))
((= 32 note-value) (/ pulses-per-quarter-note 8))
((= 64 note-value) (/ pulses-per-quarter-note 16))
((= 128 note-value) (/ pulses-per-quarter-note 32))
(else (laml-error "time-interval-of-note: note-value must be a power of 2 in between 1 and 128"))))
(define (calculate-note-in-between note-ast-1 note-ast-2)
(let ((note-val-1 (as-number (ast-attribute note-ast-1 'note)))
(note-val-2 (as-number (ast-attribute note-ast-2 'note)))
(abs-time-1 (as-number (ast-attribute note-ast-1 'absTime #f)))
(abs-time-2 (as-number (ast-attribute note-ast-2 'absTime #f)))
(channel-1 (as-number (ast-attribute note-ast-1 'channel)))
(channel-2 (as-number (ast-attribute note-ast-2 'channel)))
(velocity-1 (as-number (ast-attribute note-ast-1 'velocity)))
(velocity-2 (as-number (ast-attribute note-ast-2 'velocity)))
(duration-1 (as-number (ast-attribute note-ast-1 'duration)))
(duration-2 (as-number (ast-attribute note-ast-2 'duration)))
)
(if (or (not abs-time-1) (not abs-time-2) )
(laml-error "The function interpolate can only be used with asbTime"))
(if (> (abs (- note-val-1 note-val-2)) 1)
(list (NoteOn 'absTime (as-int-string (to-int (+ abs-time-1 (/ (- abs-time-2 abs-time-1) 2))))
'channel channel-1
'note (as-int-string (to-int (+ note-val-1 (/ (- note-val-2 note-val-1) 2))))
'velocity velocity-1
'duration (as-int-string (to-int (/ duration-1 2)))))
'())))
(define transpose
(xml-in-laml-positional-abstraction 1 0
(lambda (amount contents attributes)
(transpose-1 amount contents))))
(define (transpose-1 amount message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (or (equal? "NoteOn" (ast-element-name mes-ast)) (equal? "NoteOff" (ast-element-name mes-ast))))
(let* ((old-note (as-number (ast-attribute mes-ast 'note)))
(new-note (+ old-note amount)))
(copy-ast-mutate-attributes mes-ast 'note new-note))
mes-ast))
message-list))
(define transpose-channels
(xml-in-laml-positional-abstraction 2 0
(lambda (channel-list amount contents attributes)
(transpose-channels-1 channel-list amount contents))))
(define (transpose-channels-1 ch-list amount message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (or (equal? "NoteOn" (ast-element-name mes-ast)) (equal? "NoteOff" (ast-element-name mes-ast))))
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(if (member (as-number channel) ch-list)
(let* ((old-note (as-number (ast-attribute mes-ast 'note)))
(new-note (+ old-note amount)))
(copy-ast-mutate-attributes mes-ast 'note new-note))
mes-ast)
mes-ast))
mes-ast))
message-list))
(define pan-flow
(xml-in-laml-positional-abstraction 3 0
(lambda (channel pan-from pan-to contents attributes)
(pan-flow-1 channel pan-from pan-to contents))))
(define (pan-flow-1 ch pan-from pan-to message-list)
(let* ((pan-diff (abs (- pan-to pan-from)))
(number-of-note-ons
(length (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)) (= ch (as-number (ast-attribute x 'channel -1))))) message-list)))
(pan-step (if (> number-of-note-ons 1)
(if (< pan-from pan-to)
(/ pan-diff (- number-of-note-ons 1))
(- (/ pan-diff (- number-of-note-ons 1))))
#f))
)
(if pan-step
(pan-flow-2 ch pan-from pan-to pan-step 0 message-list)
message-list)))
(define (pan-flow-2 ch pan-from pan-to pan-step i message-list)
(cond ((null? message-list) '())
((and (ast? (car message-list)) (equal? "NoteOn" (ast-element-name (car message-list))))
(let* ((mes-ast (car message-list))
(channel (ast-attribute mes-ast 'channel #f)))
(if (and channel (= (as-number channel) ch))
(cons
(list
(ControlChange 'deltaTime "0" 'channel ch 'control "10" 'value (as-int-string (between 0 127 (to-int (+ pan-from (* i pan-step))))))
mes-ast)
(pan-flow-2 ch pan-from pan-to pan-step (+ i 1) (cdr message-list)))
(cons mes-ast (pan-flow-2 ch pan-from pan-to pan-step i (cdr message-list))))))
(else
(cons (car message-list) (pan-flow-2 ch pan-from pan-to pan-step i (cdr message-list))))))
(define no-sustain
(xml-in-laml-positional-abstraction 1 0
(lambda (channel contents attributes)
(no-sustain-1 channel contents))))
(define (no-sustain-1 c message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast)
(equal? (ast-element-name mes-ast) "ControlChange")
(= 64 (as-number (ast-attribute mes-ast 'control)))
(= c (as-number (ast-attribute mes-ast 'channel))))
(midi-null-event (ast-attribute mes-ast 'deltaTime 0))
mes-ast))
message-list))
(define eliminate-control-change
(xml-in-laml-positional-abstraction 2 0
(lambda (channel control contents attributes)
(eliminate-control-change-1 channel control contents))))
(define (eliminate-control-change-1 ch cntrl message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast)
(equal? (ast-element-name mes-ast) "ControlChange")
(= cntrl (as-number (ast-attribute mes-ast 'control)))
(= ch (as-number (ast-attribute mes-ast 'channel))))
(midi-null-event (ast-attribute mes-ast 'deltaTime 0))
mes-ast))
message-list))
(define pass-through
(xml-in-laml-abstraction
(lambda (contents attributes)
contents)))
(define-syntax midi-context
(syntax-rules ()
((midi-context select midi-message ...)
(call-with-current-continuation
(lambda (select)
(list midi-message ...))))))
(define midi-region-do
(xml-in-laml-positional-abstraction 1 0
(lambda (contextual-continuation contents attributes)
(let* ((ast-contents (filter ast? contents))
(first-mes (if (not (null? ast-contents)) (first ast-contents) #f))
(abs-time (if first-mes (ast-attribute first-mes 'absTime #f) #f)))
(if abs-time
(contextual-continuation (time-displace (- (as-number abs-time)) contents))
(contextual-continuation contents))))))
(define midi-region
(xml-in-laml-abstraction
(lambda (contents attributes)
(let* ((drop (as-boolean (defaulted-get-prop 'drop attributes #f)))
(name (defaulted-get-prop 'name attributes ""))
(sep (if (empty-string? name) "" ":"))
(midi-comment-start (midi-comment (string-append "Midi region start" sep) name ))
(midi-comment-end (midi-comment (string-append "Midi region end" sep) name ))
)
(if (not drop)
(list midi-comment-start contents midi-comment-end)
'())))))
(define (midi-null-event delta-time)
(Meta 'deltaTime delta-time 'type "1" "Midi null-event"))
(define (midi-null-event-abs-time abs-time)
(Meta 'absTime abs-time 'type "1" "Midi null-event"))
(define midi-comment
(xml-in-laml-abstraction
(lambda (contents attr)
(Meta 'deltaTime "0" 'type 1 contents))))
(define (pan c value)
(ControlChange 'deltaTime "0" 'channel c 'control "10" 'value value))
(define (dsp-variation-on)
(list
(SysEx 'deltaTime "0" "08 43 10 4C 03 00 02 5B F7")
(SysEx 'deltaTime "0" "08 43 10 4C 03 00 03 05 F7")))
(define (dsp-variation-off)
(list
(SysEx 'deltaTime "0" "08 43 10 4C 03 00 02 28 F7")
(SysEx 'deltaTime "0" "08 43 10 4C 03 00 03 04 F7")))
(define (voice channel msb lsb program-number)
(list
(ControlChange 'deltaTime "0" 'channel channel 'control "0" 'value msb)
(ControlChange 'deltaTime "0" 'channel channel 'control "32" 'value lsb)
(ProgramChange 'deltaTime "0" 'channel channel 'number program-number)
))
(define (chord-meta root . optional-parameter-list)
(let ((chord-type (optional-parameter 1 optional-parameter-list "M")))
(let* ((chord-type-number (index-in-list-by-predicate chord-types chord-type (lambda (chord-types-row ct) (equal? (car chord-types-row) ct))))
(root-number (calculate-root-number root))
(chord-type-number-two-ciffer-hex-string (binary-to-hex-string (int10-to-binary chord-type-number 1)))
(chord-root-number-two-ciffer-hex-string (binary-to-hex-string (int10-to-binary root-number 1)))
)
(Meta 'deltaTime "0" 'type "127"
(string-append "43 7B 01" " "
chord-root-number-two-ciffer-hex-string " " chord-type-number-two-ciffer-hex-string " "
chord-root-number-two-ciffer-hex-string " " chord-type-number-two-ciffer-hex-string)))))
(define (calculate-root-number root0)
(let* ((root (upcase-string root0))
(real-root (string-ref root 0))
(root-variation (if (> (string-length root) 1) (string-ref root 1) #f))
(part1-hex-ciffer
(cond ((not root-variation) 3)
((eqv? root-variation #\#) 4)
((eqv? root-variation #\b) 2)
((eqv? root-variation #\B) 2)
(else (laml-error "chord-meta -> calculate-root-number. Unknown root variation. Use only the empty or '#'" root))))
(part2-hex-ciffer
(cond ((eqv? #\C real-root) 1)
((eqv? #\D real-root) 2)
((eqv? #\E real-root) 3)
((eqv? #\F real-root) 4)
((eqv? #\G real-root) 5)
((eqv? #\A real-root) 6)
((eqv? #\B real-root) 7)
((eqv? #\H real-root) 7)
(else (laml-error "chord-meta -> calculate-root-number. Unknown root. Use only C D E F G A H B (or H for B)")))))
(+ (* 16 part1-hex-ciffer) part2-hex-ciffer)))
(define (lyrics txt)
(Meta 'deltaTime "0" 'type "5" txt))
(define (play-chord root chord-type start-octave number-of-octaves time-delta duration . optional-parameter-list)
(let ((ch (optional-parameter 1 optional-parameter-list 1))
(vel (optional-parameter 2 optional-parameter-list 80)))
(let* ((absolute-repeated-root-chord-formula (chord-note-list root chord-type start-octave number-of-octaves))
(time-delta-list (make-list (length absolute-repeated-root-chord-formula) time-delta))
)
(map
(lambda (nn dt)
(NoteOn 'deltaTime dt 'channel ch 'note (between 0 127 nn) 'velocity vel 'duration duration))
absolute-repeated-root-chord-formula
time-delta-list)
)))
(define (noteon-sequence-ending-at note lgt root chord-type time-delta duration . optional-parameter-list)
(let ((ch (optional-parameter 1 optional-parameter-list 1))
(vel (optional-parameter 2 optional-parameter-list 80)))
(let ((chord-lst (chord-note-list-ending-at note lgt root chord-type)))
(if chord-lst
(cons
(NoteOn 'deltaTime (- (* time-delta (- (length chord-lst) 1))) 'channel ch 'note (first chord-lst) 'velocity vel 'duration duration)
(map
(lambda (note-val)
(NoteOn 'deltaTime time-delta 'channel ch 'note note-val 'velocity vel 'duration duration)
)
(cdr chord-lst))
)
'()))))
(define (strum-one-note note-on-ast lgt root chord-type time-delta duration . optional-parameter-list)
(let* ((ch (optional-parameter 1 optional-parameter-list (ast-attribute note-on-ast 'channel)))
(vel (optional-parameter 2 optional-parameter-list (ast-attribute note-on-ast 'velocity)))
(note (as-number (ast-attribute note-on-ast 'note)))
(seq (noteon-sequence-ending-at note lgt root chord-type time-delta duration ch vel)))
(if (not (null? seq))
(append (list note-on-ast) (butlast seq))
(list note-on-ast))))
(define strum-1
(xml-in-laml-positional-abstraction 3 0
(lambda (lgt root chord-type contents attributes)
(map (lambda (mes-ast)
(if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)))
(strum-one-note mes-ast lgt root chord-type 300 300)
mes-ast))
contents))))
(define strum-2
(xml-in-laml-abstraction
(lambda (contents attributes)
(map (lambda (mes-ast)
(if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)))
(let* ((lgt (as-number (ast-attribute mes-ast 'strum-length 4)))
(chord (ast-attribute mes-ast 'chord #f)))
(if chord
(let* ((root-chordtype (split-chord-to-root-and-type chord))
(root (car root-chordtype))
(chord-type (cdr root-chordtype)))
(strum-one-note mes-ast lgt root chord-type 300 300))
mes-ast))
mes-ast))
contents))))
(define strum-3
(xml-in-laml-positional-abstraction 1 0
(lambda (ch contents attributes)
(strum-3-internal ch contents #f #f 10))))
(define (strum-3-internal ch contents root chord-type strum-length)
(cond ((null? contents) '())
(else (let ((mes-ast (car contents)))
(cond ((and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)) (= ch (as-number (ast-attribute mes-ast 'channel))))
(let* ((lgt-new (as-number (ast-attribute mes-ast 'strum-length strum-length)))
(chord-new (ast-attribute mes-ast 'chord #f)))
(if chord-new
(let* ((root-chordtype (split-chord-to-root-and-type chord-new))
(root-new (car root-chordtype))
(chord-type-new (cdr root-chordtype)))
(append (strum-one-note mes-ast lgt-new root-new chord-type-new 300 300)
(strum-3-internal ch (cdr contents) root-new chord-type-new lgt-new)))
(if (and root chord-type)
(append (strum-one-note mes-ast lgt-new root chord-type 300 300)
(strum-3-internal ch (cdr contents) root chord-type strum-length))
(cons mes-ast (strum-3-internal ch (cdr contents) root chord-type strum-length))))))
((meta-chord-ast? mes-ast)
(let* ((root-and-chordtype (meta-chord-root-and-chordtype mes-ast))
(root-new (car root-and-chordtype))
(chord-type-new (cdr root-and-chordtype)))
(cons mes-ast (strum-3-internal ch (cdr contents) root-new chord-type-new strum-length))))
(else (cons mes-ast (strum-3-internal ch (cdr contents) root chord-type strum-length))))))))
(define (split-chord-to-root-and-type chord)
(let ((lgt (string-length chord)))
(cond ((= lgt 1) (cons (substring chord 0 1) "M"))
((= lgt 2)
(if (eqv? (string-ref chord 1) #\#)
(cons (substring chord 0 2) "M")
(cons (substring chord 0 1) (substring chord 1 lgt))))
((>= lgt 2)
(if (eqv? (string-ref chord 1) #\#)
(cons (substring chord 0 2) (substring chord 2 lgt))
(cons (substring chord 0 1) (substring chord 1 lgt)))))))
(define replicate-channel
(xml-in-laml-positional-abstraction 2 0
(lambda (ch-from ch-to cont attr)
(replicate-channel-1 ch-from ch-to cont))))
(define (replicate-channel-1 ch-from ch-to message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(if (= ch-from (as-number channel))
(list
mes-ast
(copy-ast-mutate-attributes mes-ast 'channel ch-to)
)
mes-ast)
mes-ast))
mes-ast))
message-list))
(define join-channels
(xml-in-laml-positional-abstraction 2 0
(lambda (ch-list ch-to cont attr)
(join-channels-1 ch-list ch-to cont))))
(define (join-channels-1 ch-list ch-to message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(if (member (as-number channel) ch-list)
(copy-ast-mutate-attributes mes-ast 'channel ch-to)
mes-ast)
mes-ast))
mes-ast))
message-list))
(define select-channel
(xml-in-laml-positional-abstraction 1 0
(lambda (ch cont attr)
(select-channel-1 ch cont))))
(define (select-channel-1 c message-list)
(map
(lambda (mes-ast)
(if (ast? mes-ast)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(if (= c (as-number (ast-attribute mes-ast 'channel)))
mes-ast
(midi-null-event (ast-attribute mes-ast 'deltaTime 0)))
mes-ast))
mes-ast))
message-list))
(define select-channels
(xml-in-laml-positional-abstraction 1 0
(lambda (ch-list cont attr)
(select-channels-1 ch-list cont 0))))
(define (select-channels-1 c-list message-list between-time)
(cond ((null? message-list) '())
(else (let ((mes-ast (first message-list)))
(if (ast? mes-ast)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(if (member (as-number (ast-attribute mes-ast 'channel)) c-list)
(cons (if (delta-time-message? mes-ast)
(copy-ast-mutate-attributes mes-ast 'deltaTime (+ (time-of-message mes-ast) between-time))
mes-ast)
(select-channels-1 c-list (cdr message-list) 0))
(if (delta-time-message? mes-ast)
(cons (midi-null-event (+ (time-of-message mes-ast) between-time))
(select-channels-1 c-list (cdr message-list) 0))
(select-channels-1 c-list (cdr message-list) (+ between-time (time-of-message mes-ast)))
)
)
(cons
(if (delta-time-message? mes-ast)
(copy-ast-mutate-attributes mes-ast 'deltaTime (+ (time-of-message mes-ast) between-time))
mes-ast)
(select-channels-1 c-list (cdr message-list) 0))
)
)
(cons mes-ast (select-channels-1 c-list (cdr message-list) between-time)))))))
(define (time-of-message mes-ast)
(let ((abs-time (ast-attribute mes-ast 'absTime #f))
(delta-time (ast-attribute mes-ast 'deltaTime #f)))
(cond (abs-time (as-number abs-time))
(delta-time (as-number delta-time))
(else (laml-error "time-of-message: Message AST without deltaTime or absTime attribute")))))
(define (delta-time-message? mes-ast)
(if (ast? mes-ast)
(as-boolean (ast-attribute mes-ast 'deltaTime #f))
#f))
(define (abs-time-message? mes-ast)
(if (ast? mes-ast)
(as-boolean (ast-attribute mes-ast 'absTime #f))
#f))
(define (split-and-process-style style-file-path output-dir-path mode channel-selection)
(let* ((target-dir (file-name-proper (file-name-proper style-file-path)))
(midi-ast (midi-file-to-laml-ast style-file-path mode 0 #f))
(midi-header (ast-subtree midi-ast "MidiHeader"))
(track-ast (ast-subtree midi-ast "MidiTrack"))
(track-events (ast-subtrees track-ast))
(track-meta-divisions (filter meta-division-event? track-events))
(track-meta-division-names (map ast-text track-meta-divisions))
(init-stuff (midi-event-ast-subsequence track-events #t (third track-meta-division-names)))
(section-list
(map
(lambda (from to)
(midi-event-ast-subsequence track-events from to))
(cddr track-meta-division-names)
(append (cdddr track-meta-division-names) (list #t))))
(section-name-list (map no-spaces-in-string (cddr track-meta-division-names)))
(end-of-track-event (Meta 'deltaTime "0" 'type "47" "")))
(ensure-directory-existence! output-dir-path target-dir)
(for-each
(lambda (section section-name)
(write-text-file
(standard-midi-file-ast-to-bin
(StandardMidiFile 'internal:run-action-procedure "false"
midi-header
(MidiTrack
init-stuff
(select-channels channel-selection section)
end-of-track-event)))
(string-append output-dir-path target-dir "/" section-name "." "mid")
)
)
section-list section-name-list)))
(define (split-and-process-all-styles input-dir-path output-dir-path mode channel-selection)
(let* ((file-list (directory-list input-dir-path))
(style-file-list (filter (lambda (fn) (member (file-name-extension fn) (list "sty" "pst" "psc" "sst" "prs" "bcs"))) file-list)))
(for-each (lambda (style-file)
(display-message style-file)
(split-and-process-style (string-append input-dir-path style-file) output-dir-path mode channel-selection)
(display-message "")
)
style-file-list)))
(define substitute-section-by-bar
(xml-in-laml-positional-abstraction 2 0
(lambda (channels section-list cont attr)
(substitute-section-by-bar-1 channels section-list cont))))
(define (substitute-section-by-bar-1 channels section-list message-list)
(let ((units-per-bar (* global-ppqn (first global-signature)))
(sorted-section-list
(sort-list
section-list
(lambda (s1 s2) (<= (bar-number-of s1) (bar-number-of s2)))))
)
(let* ((section (first sorted-section-list))
(bar (bar-number-of section))
(repl-start-point (* bar units-per-bar))
(number-of-bars (bar-length-of section))
(repl-length (* number-of-bars units-per-bar))
(repl-end-point (+ repl-start-point repl-length))
(replacement-lst (replicate-if-necessary (replacement-list-of section) (* number-of-bars units-per-bar))))
(multi-substitution channels message-list repl-start-point repl-end-point replacement-lst sorted-section-list units-per-bar #f))))
(define (multi-substitution channels ml repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)
(cond ((null? ml) '())
((and (not replacing?) (not (ast? (car ml))))
(cons (car ml) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)))
((and (not replacing?) (ast? (car ml)))
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime))))
(if (and (>= abs-time repl-start-point) (< abs-time repl-end-point))
(cons
(cons
(if (member (as-number (ast-attribute mes 'channel)) channels)
(midi-null-event-abs-time (ast-attribute mes 'absTime))
mes)
replacement-lst
)
(multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb #t))
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)))))
((and replacing? (not (ast? (car ml))))
(cons (car ml) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)))
((and replacing? (ast? (car ml)))
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime))))
(if (<= abs-time repl-end-point)
(if (and (member (as-number (ast-attribute mes 'channel)) channels) (equal? (ast-element-name mes) "NoteOn"))
(multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?)))
(if (not (null? (cdr section-insertion-list)))
(let* ((next-section (second section-insertion-list))
(next-bar (bar-number-of next-section))
(next-repl-start-point (* next-bar upb))
(next-number-of-bars (bar-length-of next-section))
(next-repl-length (* next-number-of-bars upb))
(next-repl-end-point (+ next-repl-start-point next-repl-length))
(next-replacement-lst (replicate-if-necessary (replacement-list-of next-section) (* next-number-of-bars upb))))
(cons mes (multi-substitution channels (cdr ml) next-repl-start-point next-repl-end-point next-replacement-lst (cdr section-insertion-list) upb #f)))
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst '() upb #f))))))
(else (laml-error "multi-substitution: Should not happen"))))
(define (replicate-if-necessary delta-message-list source-length)
(let ((mes-lst-lgt (length-of-delta-time-midi-list delta-message-list)))
(replicate-if-necessary-1 delta-message-list source-length mes-lst-lgt)))
(define (replicate-if-necessary-1 delta-message-list source-length mes-lst-lgt)
(if (<= mes-lst-lgt source-length)
(cons delta-message-list (replicate-if-necessary-1 delta-message-list (- source-length mes-lst-lgt) mes-lst-lgt))
'()))
(define (length-of-delta-time-midi-list message-list)
(length-of-delta-time-midi-list-1 message-list 0))
(define (length-of-delta-time-midi-list-1 message-list res)
(cond ((null? message-list) res)
((ast? (car message-list))
(length-of-delta-time-midi-list-1 (cdr message-list) (+ res (as-number (ast-attribute (car message-list) 'deltaTime)))))
(else (length-of-delta-time-midi-list-1 (cdr message-list) res))))
(define bar-number-of (make-selector-function 1 "bar-number-of"))
(define bar-length-of (make-selector-function 2 "bar-length-of"))
(define replacement-list-of (make-selector-function 3 "replacement-list-of"))