(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 (NoteOn? x)
(and (ast? x) (equal? (ast-element-name x) "NoteOn")))
(define (Meta? x . optional-parameter-list)
(let ((type-1 (optional-parameter 1 optional-parameter-list "*")))
(and (ast? x) (equal? (ast-element-name x) "Meta")
(if (equal? type-1 "*")
#t
(= type-1 (as-number (ast-attribute x 'type #f)))))))
(define (drum-NoteOn? x)
(and (NoteOn? x) (or (equal? (ast-attribute x 'channel) "9") (equal? (ast-attribute x 'channel) "10"))))
(define (midi-null-event-message? x)
(and (ast? x) (equal? (ast-element-name x) "Meta")
(equal? (ast-attribute x 'type) "1")))
(define (channel-message? x)
(if (ast? x)
(let ((ch (ast-attribute x 'channel #f)))
(if ch #t #f))
#f))
(define (non-channel-message? x)
(if (ast? x)
(let ((ch (ast-attribute x 'channel #f)))
(if ch #f #t))
#f))
(define (midi attribute-name mes)
(let ((attribute-name-symbol (as-symbol attribute-name)))
(if (ast? mes)
(let ((attr-val (ast-attribute mes attribute-name-symbol #f)))
(if (and attr-val
(member attribute-name-symbol '(deltaTime absTime channel note velocity duration value number pressure strum-length )))
(as-number attr-val)
attr-val))
#f)))
(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-out-channels channel-list . message-list)
(fade-out-channel-1 channel-list message-list))
(define (fade-out-channel-1 channel-list message-list)
(let ((lgt (length message-list)))
(map
(lambda (mes-ast i)
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if channel
(let ((channel-num (as-number channel)))
(if (member channel-num channel-list)
(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)
mes-ast))
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))
(dur (ast-attribute mes-ast 'duration 0))
)
(cond (delta-time
(copy-ast-mutate-attributes mes-ast
'deltaTime (as-int-string (* (as-number delta-time) factor))
'duration (as-int-string (* (as-number dur) factor)) ))
(abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (* (as-number abs-time) factor))
'duration (as-int-string (* (as-number dur) factor)) ))
(else (laml-error "Can only time stretch in deltaTime and absTime mode")) ))
mes-ast))
message-list))
(define transform-attribute
(xml-in-laml-positional-abstraction
3 0
(lambda (ast-predicate attribute-name transformation-fn contents attributes)
(transform-attribute-1 ast-predicate attribute-name transformation-fn contents))))
(define (transform-attribute-1 ast-predicate attribute-name transformation-fn message-list)
(map
(lambda (x)
(if (and (ast? x) (ast-predicate x))
(let* ((mes-ast x)
(attribute-value (ast-attribute mes-ast attribute-name #f))
)
(if attribute-value
(copy-ast-mutate-attributes mes-ast attribute-name (as-int-string (transformation-fn (as-number attribute-value))))
mes-ast))
x))
message-list))
(define scale-attribute-by-factor
(xml-in-laml-positional-abstraction
3 0
(lambda (ast-predicate attribute-name factor contents attributes)
(transform-attribute-1 ast-predicate attribute-name (lambda (value) (* factor value)) contents))))
(define time-adapt-to
(xml-in-laml-positional-abstraction
1 0
(lambda (new-length cont attr)
(time-adapt-to-1 new-length cont))))
(define (time-adapt-to-1 new-length message-list)
(let* ((old-length (total-length-of-message-list message-list))
(factor (/ new-length old-length)))
(time-stretch-1 factor 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))
(delta-time (ast-attribute mes-ast 'deltaTime #f))
)
(cond (abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (+ (as-number abs-time) amount))))
(delta-time
mes-ast)
(else (laml-error "time-displace: Problems!"))))
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))
(delta-time (ast-attribute mes-ast 'deltaTime #f)))
(cond (abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (+ (as-number abs-time) amount))))
(delta-time
mes-ast)
(else (laml-error "time-displace-channels: Problems!"))))
mes-ast))
mes-ast))
mes-ast))
message-list))
(define time-displace-channels-with-scaling
(xml-in-laml-positional-abstraction
3 0
(lambda (channel-list amount scaling-fn cont attr)
(time-displace-channels-with-scaling-1 channel-list amount scaling-fn cont))))
(define (time-displace-channels-with-scaling-1 ch-list amount scaling-fn message-list)
(let* ((number-list (consequtive-numbering-by-predicate (ast-with-channel-pred ch-list) message-list 1 0))
(number-list-count (length (filter (lambda (x) (> x 0)) number-list)))
(max-n number-list-count)
)
(map
(lambda (mes-ast n)
(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))
(delta-time (ast-attribute mes-ast 'deltaTime #f))
(scaled-amount (* amount (scaling-fn (/ n max-n))))
)
(if (= n 0) (laml-error "time-displace-channels-with-scaling-1: Should not happen"))
(cond (abs-time
(copy-ast-mutate-attributes mes-ast
'absTime (as-int-string (+ (as-number abs-time) scaled-amount))))
(delta-time
(laml-error "time-displace-channels-with-scaling-1: Only supports absTime"))
(else (laml-error "time-displace-channels: Problems!"))))
mes-ast))
mes-ast))
mes-ast))
message-list
number-list)))
(define (ast-with-channel-pred ch-list)
(lambda (x)
(and (ast? x)
(let ((ch (ast-attribute x 'channel #f)))
(and ch (member (as-number ch) ch-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") (= (as-number (ast-attribute mes-ast 'channel)) channel))
(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)
(cond ((abs-time-sequence? cont) (quantize-abs-timing channel q pulses-per-quarter-note cont))
((delta-time-sequence? cont)
(abs-time-message-list-to-delta-timing
(quantize-abs-timing
channel q pulses-per-quarter-note (delta-time-message-list-to-abs-timing cont 0))
0)
)
(else (laml-error "quantize: Problems determining absTime or deltaTime mode of sequence"))))))
(define (quantize-abs-timing c q pulses-per-quarter-note message-list)
(map
(lambda (mes-ast)
(if (and (ast? 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 #f)))
(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))
mes-ast))
message-list))
(define (abs-time-sequence? message-list)
(cond ((null? message-list) #f)
((ast? (first message-list))
(has-ast-attribute? (car message-list) 'absTime))
(else (abs-time-sequence? (cdr message-list)))))
(define (delta-time-sequence? message-list)
(cond ((null? message-list) #f)
((ast? (first message-list))
(has-ast-attribute? (car message-list) 'deltaTime))
(else (delta-time-sequence? (cdr message-list)))))
(define (has-ast-attribute? ast name)
(let ((attr-list (ast-attributes ast)))
(turn-into-boolean (find-in-property-list name attr-list))))
(define quantize-channels
(xml-in-laml-positional-abstraction
3 0
(lambda (channel-list q pulses-per-quarter-note cont attr)
(cond ((abs-time-sequence? cont) (quantize-channels-abs-timing channel-list q pulses-per-quarter-note cont))
((delta-time-sequence? cont)
(abs-time-message-list-to-delta-timing
(quantize-channels-abs-timing
channel-list q pulses-per-quarter-note (delta-time-message-list-to-abs-timing cont 0))
0)
)
(else (laml-error "quantize-channels: Problems determining absTime or deltaTime mode of sequence"))))))
(define (quantize-channels-abs-timing c-lst q pulses-per-quarter-note message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast))
(let ((channel (ast-attribute mes-ast 'channel #f)))
(if (and channel (member (as-number channel) c-lst))
(let ((abs-time (ast-attribute mes-ast 'absTime #f)))
(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))
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 channel-volume-flow
(xml-in-laml-positional-abstraction 3 0
(lambda (channel channel-volume-from channel-volume-to contents attributes)
(channel-volume-flow-1 channel channel-volume-from channel-volume-to contents))))
(define (channel-volume-flow-1 ch channel-volume-from channel-volume-to message-list)
(let* ((channel-volume-diff (abs (- channel-volume-to channel-volume-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)))
(channel-volume-step (if (> number-of-note-ons 1)
(if (< channel-volume-from channel-volume-to)
(/ channel-volume-diff (- number-of-note-ons 1))
(- (/ channel-volume-diff (- number-of-note-ons 1))))
#f))
)
(if channel-volume-step
(channel-volume-flow-2 ch channel-volume-from channel-volume-to channel-volume-step 0 message-list)
message-list)))
(define (channel-volume-flow-2 ch channel-volume-from channel-volume-to channel-volume-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 "7" 'value (as-int-string (between 0 127 (to-int (+ channel-volume-from (* i channel-volume-step))))))
mes-ast)
(channel-volume-flow-2 ch channel-volume-from channel-volume-to channel-volume-step (+ i 1) (cdr message-list)))
(cons mes-ast (channel-volume-flow-2 ch channel-volume-from channel-volume-to channel-volume-step i (cdr message-list))))))
(else
(cons (car message-list) (channel-volume-flow-2 ch channel-volume-from channel-volume-to channel-volume-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 ch message-list)
(eliminate-control-change-1 ch 64 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)
(eliminate-midi-null-events
(map
(lambda (mes-ast)
(if (and (ast? mes-ast)
(equal? (ast-element-name mes-ast) "ControlChange")
(if (and (boolean? cntrl) cntrl) #t (= cntrl (as-number (ast-attribute mes-ast 'control))))
(if (and (boolean? ch) ch) #t (= ch (as-number (ast-attribute mes-ast 'channel))))
)
(let ((abs-time (ast-attribute mes-ast 'absTime #f))
(delta-time (ast-attribute mes-ast 'deltaTime #f)))
(cond (abs-time
(midi-null-event-abs-time (ast-attribute mes-ast 'absTime)))
(delta-time
(midi-null-event-delta-time (ast-attribute mes-ast 'deltaTime)))
(else (laml-error "eliminate-control-change-1: Not absTime and not deltaTime. Should not happen"))))
mes-ast)
)
message-list)))
(define eliminate-program-change
(xml-in-laml-positional-abstraction 1 0
(lambda (channel contents attributes)
(eliminate-program-change-1 channel contents))))
(define (eliminate-program-change-1 ch message-list)
(eliminate-midi-null-events
(map
(lambda (mes-ast)
(if (and (ast? mes-ast)
(equal? (ast-element-name mes-ast) "ProgramChange")
(if (and (boolean? ch) ch) #t (= ch (as-number (ast-attribute mes-ast 'channel))))
)
(let ((abs-time (ast-attribute mes-ast 'absTime #f))
(delta-time (ast-attribute mes-ast 'deltaTime #f)))
(cond (abs-time
(midi-null-event-abs-time (ast-attribute mes-ast 'absTime)))
(delta-time
(midi-null-event-delta-time (ast-attribute mes-ast 'deltaTime)))
(else (laml-error "eliminate-program-change-1: Not absTime and not deltaTime. Should not happen"))))
mes-ast)
)
message-list)))
(define pass-through
(xml-in-laml-abstraction
(lambda (contents attributes)
contents)))
(define delta-merge
(xml-in-laml-positional-abstraction 1 0
(lambda (other-message-list contents attributes)
(delta-merge-two-lists contents other-message-list))))
(define (delta-merge-two-lists message-list-1 message-list-2)
(delta-merge-two-lists-1 message-list-1 0 message-list-2 0 '()))
(define (delta-merge-two-lists-1 message-list-1 subtraction-1 message-list-2 subtraction-2 res)
(cond ((and (null? message-list-1)
(null? message-list-2)) (reverse res))
((null? message-list-1)
(append (reverse res)
(let* ((ast (car message-list-2))
(delta-time (as-number (ast-attribute ast 'deltaTime)))
(effective-delta-time (- delta-time subtraction-2)))
(cons (copy-ast-mutate-attributes ast 'deltaTime effective-delta-time) (cdr message-list-2)))))
((null? message-list-2)
(append (reverse res)
(let* ((ast (car message-list-1))
(delta-time (as-number (ast-attribute ast 'deltaTime)))
(effective-delta-time (- delta-time subtraction-1)))
(cons (copy-ast-mutate-attributes ast 'deltaTime effective-delta-time) (cdr message-list-1)))))
((not (ast? (car message-list-1))) (delta-merge-two-lists-1 (cdr message-list-1) subtraction-1 message-list-2 subtraction-2 res))
((not (ast? (car message-list-2))) (delta-merge-two-lists-1 message-list-1 subtraction-1 (cdr message-list-2) subtraction-2 res))
(else
(let* ((ast-1 (car message-list-1))
(ast-2 (car message-list-2))
(delta-time-1 (as-number (ast-attribute ast-1 'deltaTime)))
(delta-time-2 (as-number (ast-attribute ast-2 'deltaTime)))
(effective-delta-time-1 (- delta-time-1 subtraction-1))
(effective-delta-time-2 (- delta-time-2 subtraction-2)))
(if (< effective-delta-time-1 effective-delta-time-2)
(delta-merge-two-lists-1 (cdr message-list-1) 0 message-list-2 (+ subtraction-2 effective-delta-time-1)
(cons (copy-ast-mutate-attributes ast-1 'deltaTime effective-delta-time-1) res))
(delta-merge-two-lists-1 message-list-1 (+ subtraction-1 effective-delta-time-2) (cdr message-list-2) 0
(cons (copy-ast-mutate-attributes ast-2 'deltaTime effective-delta-time-2) res))
)))))
(define abs-merge
(xml-in-laml-positional-abstraction 1 0
(lambda (other-message-list contents attributes)
(abs-merge-two-lists contents other-message-list))))
(define (abs-merge-two-lists message-list-1 message-list-2)
(abs-merge-two-lists-1 message-list-1 message-list-2 '()))
(define (abs-merge-two-lists-1 message-list-1 message-list-2 res)
(cond ((and (null? message-list-1)
(null? message-list-2)) (reverse res))
((null? message-list-1) (append (reverse res) message-list-2))
((null? message-list-2) (append (reverse res) message-list-1))
((not (ast? (car message-list-1))) (abs-merge-two-lists-1 (cdr message-list-1) message-list-2 res))
((not (ast? (car message-list-2))) (abs-merge-two-lists-1 message-list-1 (cdr message-list-2) res))
(else
(let* ((ast-1 (car message-list-1))
(ast-2 (car message-list-2))
(abs-time-1 (as-number (ast-attribute ast-1 'absTime)))
(abs-time-2 (as-number (ast-attribute ast-2 'absTime))))
(if (<= abs-time-1 abs-time-2)
(abs-merge-two-lists-1 (cdr message-list-1) message-list-2
(cons (car message-list-1) res))
(abs-merge-two-lists-1 message-list-1 (cdr message-list-2)
(cons (car message-list-2) res))
)))))
(define transform-messages
(xml-in-laml-positional-abstraction 2 0
(lambda (filter-fn transformation-fn contents attributes)
(transform-messages-1 filter-fn transformation-fn contents ))))
(define (transform-messages-1 filter-fn transformation-fn message-list)
(map
(lambda (mes-ast)
(if (and (ast? mes-ast) (filter-fn mes-ast))
(transformation-fn mes-ast)
mes-ast))
message-list))
(define filter-messages
(xml-in-laml-positional-abstraction 1 0
(lambda (pred-fn contents attributes)
(filter-messages-1 pred-fn contents ))))
(define (filter-messages-1 pred-fn message-list)
(filter
(lambda (x)
(if (ast? x)
(pred-fn x)
#t))
message-list))
(define thin-out-messages-abs-time
(xml-in-laml-positional-abstraction 2 0
(lambda (channel-list abs-time-pred contents attributes)
(thin-out-messages-abs-time-1 channel-list abs-time-pred contents))))
(define (thin-out-messages-abs-time-1 channel-list abs-time-pred message-list)
(filter-messages-1
(lambda (mes-ast)
(let ((ch (ast-attribute mes-ast 'channel #f))
(delta-time? (ast-attribute mes-ast 'deltaTime #f))
)
(if delta-time? (laml-error "thin-out-message-abs-time: Encountered a deltaTime message. Can only be applied in pure absTime mode."))
(if ch
(if (member (as-number ch) channel-list)
(abs-time-pred (as-number (ast-attribute mes-ast 'absTime)))
#t)
#t)))
message-list))
(define thin-out-messages-delta-time
(xml-in-laml-positional-abstraction 3 0
(lambda (channel-list abs-time-pred start-time contents attributes)
(thin-out-messages-delta-time-1 channel-list abs-time-pred start-time contents))))
(define (thin-out-messages-delta-time-1 channel-list abs-time-pred start-time message-list)
(thin-out-messages-delta-time-2 channel-list abs-time-pred start-time 0 message-list '()))
(define (thin-out-messages-delta-time-2 channel-list abs-time-pred previous-abs-time accumulated-deltas message-list result-list)
(cond ((null? message-list) (reverse result-list))
((ast? (car message-list))
(let* ((mes-ast (car message-list))
(ch (ast-attribute mes-ast 'channel #f))
(abs-time? (ast-attribute mes-ast 'absTime #f)))
(if abs-time? (laml-error "thin-out-message-delta-time: Encountered an absTime message. Can only be applied in deltaTime mode."))
(let* ((delta-time (as-number (ast-attribute mes-ast 'deltaTime)))
(new-abs-time (+ previous-abs-time delta-time))
)
(if (and ch
(member (as-number ch) channel-list)
(abs-time-pred new-abs-time)
)
(let ((delta-modifier-mes-ast (copy-ast-mutate-attributes mes-ast 'deltaTime (+ delta-time accumulated-deltas))))
(thin-out-messages-delta-time-2 channel-list abs-time-pred new-abs-time 0 (cdr message-list) (cons delta-modifier-mes-ast result-list)))
(thin-out-messages-delta-time-2 channel-list abs-time-pred new-abs-time (+ accumulated-deltas delta-time) (cdr message-list) result-list)))))
(else (thin-out-messages-delta-time-2 channel-list abs-time-pred previous-abs-time accumulated-deltas (cdr message-list) result-list))))
(define (keep-beat n . optional-parameter-list)
(let ((displacement (optional-parameter 1 optional-parameter-list 0))
(ppqn (optional-parameter 2 optional-parameter-list 1920))
)
(lambda (abs-time)
(= (remainder
(- abs-time displacement)
(to-int (* ppqn (expt 2 (- 2 (round (log2 n))))))
)
0))))
(define (log2 x)
(* (/ 1 (log 2)) (log x)))
(define scale-attribute
(xml-in-laml-positional-abstraction 2 0
(lambda (attribute-name scaling-function contents attributes)
(scale-attribute-1 attribute-name scaling-function contents ))))
(define (scale-attribute-1 attribute-name f contents)
(let* ((attr-name (as-symbol attribute-name))
(noteon-contents (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)))) contents))
(number-of-noteon-messages (length noteon-contents))
(number-list (consequtive-numbering-by-predicate NoteOn? contents 1 0))
)
(map
(lambda (mes-ast i)
(if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)))
(let ((attr-value (ast-attribute mes-ast attr-name #f)))
(if attr-value
(let* ((attr-val-number (as-number attr-value))
(max-i number-of-noteon-messages)
(scaled-attr-value (* attr-val-number (f (/ i max-i))))
)
(copy-ast-mutate-attributes mes-ast
(as-symbol attr-name)
(as-int-string scaled-attr-value)))
mes-ast))
mes-ast)
)
contents
number-list)))
(define (consequtive-numbering-by-predicate pred lst first-val missing-value)
(consequtive-numbering-by-predicate-1 pred lst 1 missing-value '()))
(define (consequtive-numbering-by-predicate-1 pred lst first-val missing-value res)
(cond ((null? lst) (reverse res))
((pred (car lst)) (consequtive-numbering-by-predicate-1 pred (cdr lst) (+ first-val 1) missing-value (cons first-val res)))
(else (consequtive-numbering-by-predicate-1 pred (cdr lst) first-val missing-value (cons missing-value res)))))
(define marker-channel
(xml-in-laml-positional-abstraction 1 0
(lambda (channel contents attributes)
(eliminate-program-change-1 channel
(eliminate-control-change-1 channel #t
(marker-channel-1 channel contents ))))))
(define (marker-channel-1 channel message-list)
(let ((numbering (consequtive-numbering-by-predicate
(lambda (x) (and (NoteOn? x) (= channel (as-number (ast-attribute x 'channel)))))
message-list 1 0))
)
(append
(list
((treat-marking channel) (car message-list) (car numbering))
(Meta 'deltaTime "0"
'type "6"
(string-append "M" "-" "0" " " "**"))
)
(map2 (treat-marking channel)
(cdr message-list)
(cdr numbering)))
)
)
(define (treat-marking channel)
(lambda (mes n)
(if (and (NoteOn? mes) (= channel (as-number (ast-attribute mes 'channel))))
(let ((abs-time (ast-attribute mes 'absTime #f))
(delta-time (ast-attribute mes 'deltaTime #f)))
(Meta (if abs-time 'absTime 'deltaTime) (time-of-message mes)
'type "6"
(string-append "M" "-" (as-string n) " " (star-marking-of (marker-level-of-note-on mes)))))
mes)
))
(define (marker-level-of-note-on noteon-ast)
(let* ((note-attr (as-number (ast-attribute noteon-ast 'note)))
(level-number (remainder note-attr 12)))
(cond ((= level-number 0) 0)
((= level-number 1) 0)
((= level-number 2) 1)
((= level-number 3) 1)
((= level-number 4) 2)
((= level-number 5) 3)
((= level-number 6) 3)
((= level-number 7) 4)
((= level-number 8) 4)
((= level-number 9) 5)
((= level-number 10) 5)
((= level-number 11) 6)
)))
(define (star-marking-of level)
(make-string level #\*))
(define repeat-messages
(xml-in-laml-positional-abstraction 1 0
(lambda (n contents attributes)
(repeat-messages-1 n contents))))
(define (repeat-messages-1 n flat-message-list)
(if (= n 0)
'()
(append flat-message-list (repeat-messages-1 (- n 1) flat-message-list))))
(define repeat-messages-enforce-periode-length
(xml-in-laml-positional-abstraction 2 0
(lambda (n min-period-length contents attributes)
(repeat-messages-enforce-periode-length-1 n min-period-length contents))))
(define (repeat-messages-enforce-periode-length-1 n min-period-length flat-message-list)
(if (= n 0)
'()
(append (enforce-minimum-message-length min-period-length flat-message-list)
(repeat-messages-enforce-periode-length-1 (- n 1) min-period-length flat-message-list))))
(define same-time-transform
(xml-in-laml-positional-abstraction 2 0
(lambda (channels transformer contents attributes)
(same-time-transform-1 channels transformer contents))))
(define (same-time-transform-1 channels transformer message-list)
(same-time-transform-2 channels transformer message-list '() '()))
(define (same-time-transform-2 channels transformer message-list same-time-lst result-lst)
(if (null? message-list)
(reverse (append same-time-lst result-lst))
(let* ((mes (first message-list))
(absTime? (ast-attribute mes 'absTime #f))
(same-mes (if (not (null? same-time-lst)) (first same-time-lst) #f))
(same-mes-ch (if same-mes (ast-attribute same-mes 'channel #f) #f))
)
(if (not absTime?) (laml-error "Same time transformation must occur in pure abs-time mode."))
(cond
((and same-mes
(ast? mes)
(equal? (ast-attribute same-mes 'absTime) (ast-attribute mes 'absTime))
same-mes-ch (member (as-number same-mes-ch) channels))
(same-time-transform-2 channels transformer (cdr message-list) (cons mes same-time-lst) result-lst))
((and (ast? mes) (>= (length same-time-lst) 2))
(same-time-transform-2 channels transformer (cdr message-list) (list mes)
(append (maybe-transformer transformer (filter (NoteOnCh? channels) same-time-lst)) (filter (negate (NoteOnCh? channels)) same-time-lst) result-lst)))
((and (not (ast? mes)) (>= (length same-time-lst) 2))
(same-time-transform-2 channels transformer (cdr message-list) '()
(append (maybe-transformer transformer (filter (NoteOnCh? channels) same-time-lst)) (filter (negate (NoteOnCh? channels)) same-time-lst) result-lst)))
((and (ast? mes) same-mes (< (length same-time-lst) 2))
(same-time-transform-2 channels transformer (cdr message-list) (list mes) (append same-time-lst result-lst)))
((and (not (ast? mes)) same-mes (< (length same-time-lst) 2))
(same-time-transform-2 channels transformer (cdr message-list) '() (append same-time-lst result-lst)))
((ast? mes)
(same-time-transform-2 channels transformer (cdr message-list) (list mes) result-lst))
(else
(same-time-transform-2 channels transformer (cdr message-list) same-time-lst result-lst))))))
(define (NoteOnCh? channels)
(lambda (x)
(if (NoteOn? x)
(let ((ch (ast-attribute x 'channel #f)))
(if ch
(member (as-number ch) channels)
#f))
#f)))
(define (maybe-transformer transformer lst)
(if (>= (length lst) 2)
(transformer lst)
lst))
(define (make-scale-fn-pol-one-pol shape-start shape-end c d)
(letrec ((f-up (lambda (x) (+ 1 (* c (- x d) (- x (- 1 d))))))
(f-down (lambda (x) (max (- 1 (* c (- x d) (- x (- 1 d)))) 0)))
(f-flat (lambda (x) 1))
)
(lambda (x)
(cond ((< x 0) (error "the input is not supposed to be negative"))
((< x d) ((cond ((eq? shape-start 'up) f-up)
((eq? shape-start 'flat) f-flat)
((eq? shape-start 'down) f-down)
(else (laml-error "shape-start must be one of the symbols up, flat, or down"))) x))
((< x (- 1 d)) 1)
((<= x 1) ((cond ((eq? shape-end 'up) f-up)
((eq? shape-end 'flat) f-flat)
((eq? shape-end 'down) f-down)
(else (laml-error "shape-end must be one of the symbols up, flat, or down"))) x))
(else (error "the input is not supposed to larger than one"))))))
(define (make-scale-fn-pol-one-pol-general shape-start shape-end cs ds ce de)
(letrec ((f-up-s (lambda (x) (+ 1 (* cs (- x ds) (- x (- 1 ds))))))
(f-down-s (lambda (x) (max (- 1 (* cs (- x ds) (- x (- 1 ds)))) 0)))
(f-up-e (lambda (x) (+ 1 (* ce (- x de) (- x (- 1 de))))))
(f-down-e (lambda (x) (max (- 1 (* ce (- x de) (- x (- 1 de)))) 0)))
(f-flat (lambda (x) 1))
)
(lambda (x)
(cond ((< x 0) (error "the input is not supposed to be negative"))
((< x ds) ((cond ((eq? shape-start 'up) f-up-s)
((eq? shape-start 'flat) f-flat)
((eq? shape-start 'down) f-down-s)
(else (laml-error "shape-start must be one of the symbols up, flat, or down"))) x))
((< x (- 1 de)) 1)
((<= x 1) ((cond ((eq? shape-end 'up) f-up-e)
((eq? shape-end 'flat) f-flat)
((eq? shape-end 'down) f-down-e)
(else (laml-error "shape-end must be one of the symbols up, flat, or down"))) x))
(else (error "the input is not supposed to larger than one"))))))
(define (make-scale-function-by-xy-points xy-list)
(letrec ((x-of car)
(y-of cdr)
)
(let ((sorted-xy-list (sort-list
xy-list
(lambda (p1 p2) (<= (x-of p1) (x-of p2))))))
(lambda (x)
(let* ((first-pair-0 (find-in-list (lambda (pair) (> (x-of pair) x)) sorted-xy-list))
(first-pair (if (and (boolean? first-pair-0) (not first-pair-0))
(last sorted-xy-list)
first-pair-0))
(second-pair (element-before first-pair sorted-xy-list id-1 equal?))
(x1 (x-of first-pair))
(y1 (y-of first-pair))
(x2 (x-of second-pair))
(y2 (y-of second-pair)))
(+ y1 (* (/ (- y2 y1) (- x2 x1)) (- x x1))))))))
(define (multiply-scaling-function factor sf)
(lambda (x)
(* factor (sf x))))
(define (add-two-scaling-functions sf1 sf2)
(lambda (x)
(+ (sf1 x) (sf2 x) )))
(define (subtract-two-scaling-functions sf1 sf2)
(lambda (x)
(- (sf1 x) (sf2 x) )))
(define (multiply-two-scaling-functions sf1 sf2)
(lambda (x)
(* (sf1 x) (sf2 x) )))
(define (from-percent-points point-lst)
(map (lambda (point)
(cons (/ (first point) 100)
(/ (second point) 100)))
point-lst))
(define (from-permille-points point-lst)
(map (lambda (point)
(cons (/ (first point) 1000)
(/ (second point) 1000)))
point-lst))
(define pi 3.141592654)
(define sf1
(multiply-scaling-function 2.5
(make-scale-function-by-xy-points
(from-permille-points '((0 -150) (350 -110) (700 0) (760 50) (800 70) (850 60) (900 30) (1000 0)))
)))
(define sf2
(multiply-scaling-function 1.0
(make-scale-function-by-xy-points
(from-permille-points '((0 -250) (500 -150) (750 -75) (800 -50) (900 -10) (1000 0)))
)))
(define sf3
(multiply-scaling-function 1.8
(make-scale-function-by-xy-points
(from-permille-points '((0 0) (33 -50) (66 50) (100 0) (133 -50) (166 50)
(200 0) (233 -50) (266 50) (300 0) (333 -50) (366 50)
(400 0) (433 -40) (466 40) (500 0) (533 -40) (566 40)
(600 0) (633 -30) (666 30) (700 0) (733 -30) (766 30)
(800 0) (833 -25) (866 25) (900 0) (933 -25) (966 25) (1000 0) ))
)))
(define sf4
(make-scale-fn-pol-one-pol 'down 'down 4.5 0.35))
(define sf5
(make-scale-fn-pol-one-pol 'up 'down 5.5 0.25))
(define sf6
(multiply-two-scaling-functions
(make-scale-function-by-xy-points
(from-percent-points '((0 100) (100 0))))
(lambda (x) (sin (* x 15 pi)))
))
(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-text "Midi null-event")
(define (midi-null-event delta-time . optional-parameter-list)
(let ((info-text (optional-parameter 1 optional-parameter-list midi-null-event-text)))
(Meta 'deltaTime delta-time 'type "1" info-text)))
(define midi-null-event-delta-time midi-null-event)
(define (midi-null-event-abs-time abs-time . optional-parameter-list)
(let ((info-text (optional-parameter 1 optional-parameter-list midi-null-event-text)))
(Meta 'absTime abs-time 'type "1" info-text)))
(define midi-comment
(xml-in-laml-abstraction
(lambda (contents attr)
(Meta 'deltaTime "0" 'type 1 contents))))
(define (midi-marker marker-txt)
(Meta 'deltaTime "0" 'type "6" marker-txt))
(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 (tempo bpm)
(Meta 'deltaTime "0" 'type "81" (tempo= bpm)))
(define (pitch-bend-range channel range . optional-parameter-list)
(let ((cents (optional-parameter 1 optional-parameter-list 0)))
(list
(ControlChange 'deltaTime "0" 'channel channel 'control "101" 'value "0")
(ControlChange 'deltaTime "0" 'channel channel 'control "100" 'value "0")
(ControlChange 'deltaTime "0" 'channel channel 'control "6" 'value range)
(ControlChange 'deltaTime "0" 'channel channel 'control "38" 'value cents)
)))
(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 (make-pitch-bend-change-list ch n duration scale-fn . optional-parameters)
(let ((first-delta-time (optional-parameter 1 optional-parameters (/ duration n))))
(letrec ((make-function-domain-values
(lambda (length increment actual)
(if (= length 0)
'()
(cons actual (make-function-domain-values (- length 1) increment (+ actual increment))))))
)
(let ((pitch-value-fn (compose (lambda (r) (+ (* r 8192) 8192)) scale-fn))
(delta-dur (/ duration n))
(function-unit-domain-values (make-function-domain-values n (/ 1 (- n 1)) 0))
)
(cons (let ((value (between 0 16383 (pitch-value-fn (car function-unit-domain-values)))))
(PitchBendChange 'deltaTime (as-int-string first-delta-time) 'channel (as-string ch)
'value (as-int-string value)))
(map
(lambda (unit-domain-value)
(let ((value (between 0 16383 (pitch-value-fn unit-domain-value))))
(PitchBendChange 'deltaTime (as-int-string delta-dur) 'channel (as-string ch) 'value (as-int-string value))))
(cdr function-unit-domain-values)))))))
(define (make-tempo-change-list n duration base-tempo scale-fn . optional-parameter-list)
(let ((last-tempo (optional-parameter 1 optional-parameter-list #f)))
(letrec ((make-function-domain-values
(lambda (length increment actual)
(if (= length 0)
'()
(cons actual (make-function-domain-values (- length 1) increment (+ actual increment))))))
)
(if last-tempo
(let ((function-unit-domain-values (make-function-domain-values (+ n 1) (/ 1 n) 0))
(delta-dur (/ duration n))
)
(append
(map
(lambda (unit-domain-value)
(Meta 'deltaTime (as-int-string delta-dur) 'type "81" (tempo= (* base-tempo (scale-fn unit-domain-value))))
)
(butlast function-unit-domain-values))
(list
(Meta 'deltaTime (as-int-string delta-dur) 'type "81" (tempo= last-tempo)))))
(let ((function-unit-domain-values (make-function-domain-values (+ n 1) (/ 1 n) 0))
(delta-dur (/ duration n))
)
(map
(lambda (unit-domain-value)
(Meta 'deltaTime (as-int-string delta-dur) 'type "81" (tempo= (* base-tempo (scale-fn unit-domain-value))))
)
function-unit-domain-values))
))))
(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)
(eliminate-midi-null-events (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 delete-channel
(xml-in-laml-positional-abstraction 1 0
(lambda (ch cont attr)
(delete-channel-1 ch cont))))
(define (delete-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)))
(midi-null-event (ast-attribute mes-ast 'deltaTime 0))
mes-ast)
mes-ast))
mes-ast))
message-list))
(define delete-channel-abs-time
(xml-in-laml-positional-abstraction 1 0
(lambda (ch cont attr)
(delete-channel-abs-time-1 ch cont))))
(define (delete-channel-abs-time-1 ch message-list)
(delete-channel-abs-time-2 ch message-list '()))
(define (delete-channel-abs-time-2 ch message-list res)
(if (null? message-list)
(reverse res)
(let ((mes-ast (car message-list)))
(if (and (ast? mes-ast) (ast-attribute mes-ast 'channel #f) (= ch (as-number (ast-attribute mes-ast 'channel))))
(delete-channel-abs-time-2 ch (cdr message-list) res)
(delete-channel-abs-time-2 ch (cdr message-list) (cons mes-ast res))))))
(define select-channels
(xml-in-laml-positional-abstraction 1 0
(lambda (ch-list cont attr)
(if (and (boolean? ch-list) ch-list)
cont
(eliminate-midi-null-events (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 (or (and (boolean? c-list) c-list) (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 eliminate-midi-null-events
(xml-in-laml-abstraction
(lambda (cont attr)
(eliminate-midi-null-events-1 cont 0 0))))
(define (eliminate-midi-null-events-1 message-list abs-time acc-delta)
(eliminate-events-1 midi-null-event-message? message-list abs-time acc-delta))
(define eliminate-events
(xml-in-laml-positional-abstraction 1 0
(lambda (predicate cont attr)
(eliminate-events-1 predicate cont 1 0))))
(define (eliminate-events-1 predicate message-list abs-time acc-delta)
(cond ((null? message-list) '())
(else (let ((mes-ast (first message-list)))
(if (ast? mes-ast)
(cond ((and (abs-time-message? mes-ast) (predicate mes-ast))
(let ((delta-time (- (time-of-message mes-ast) abs-time)))
(eliminate-events-1 predicate (cdr message-list) (time-of-message mes-ast) (+ delta-time acc-delta))))
((and (abs-time-message? mes-ast) (not (predicate mes-ast)))
(cons mes-ast (eliminate-events-1 predicate (cdr message-list) (time-of-message mes-ast) 0)))
((and (delta-time-message? mes-ast) (predicate mes-ast))
(let ((delta-time (time-of-message mes-ast)))
(eliminate-events-1 predicate (cdr message-list) (+ abs-time delta-time) (+ delta-time acc-delta))))
((and (delta-time-message? mes-ast) (not (predicate mes-ast)))
(let ((delta-time (time-of-message mes-ast)))
(cons (copy-ast-mutate-attributes mes-ast 'deltaTime (+ acc-delta delta-time))
(eliminate-events-1 predicate (cdr message-list) (+ abs-time delta-time) 0))))
(else (laml-error "eliminate-events-1: Should not happen.")))
(cons mes-ast (eliminate-events-1 predicate (cdr message-list) abs-time acc-delta)))))))
(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 ((sorted-section-list
(sort-list
section-list
(lambda (s1 s2) (<= (bar-number-of s1) (bar-number-of s2)))))
)
(let* ((section (first sorted-section-list))
(start-end-repl (by-bar-advancement-substitution section))
)
(multi-substitution channels message-list
(first start-end-repl) (second start-end-repl) (third start-end-repl) sorted-section-list by-bar-advancement-substitution #f))))
(define (by-bar-advancement-substitution section)
(let* ((units-per-bar (* global-ppqn (first global-signature)))
(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)))
)
(list repl-start-point repl-end-point replacement-lst)))
(define (multi-substitution channels ml repl-start-point repl-end-point replacement-lst section-insertion-list section-advancement-fn 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 section-advancement-fn 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 section-advancement-fn #t))
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list section-advancement-fn 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 section-advancement-fn 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 section-advancement-fn replacing?)
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list section-advancement-fn replacing?)))
(if (not (null? (cdr section-insertion-list)))
(let* ((next-section (second section-insertion-list))
(start-end-repl (section-advancement-fn next-section))
)
(cons mes (multi-substitution channels (cdr ml)
(first start-end-repl) (second start-end-repl) (third start-end-repl)
(cdr section-insertion-list) section-advancement-fn #f)))
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst '() section-advancement-fn #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 thin-out-section-by-bar
(xml-in-laml-positional-abstraction 2 0
(lambda (channels section-list cont attr)
(thin-out-section-by-bar-1 channels section-list cont))))
(define (thin-out-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))
(keep-pred (keep-predicate-of section))
)
(multi-thin-out channels message-list repl-start-point repl-end-point keep-pred sorted-section-list units-per-bar #f))))
(define (multi-thin-out channels ml repl-start-point repl-end-point keep-pred section-list upb thinning-out?)
(cond ((null? ml) '())
((and (not thinning-out?) (not (ast? (car ml))))
(cons (car ml) (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb thinning-out?)))
((and (not thinning-out?) (ast? (car ml)))
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime)))
(delta-time? (ast-attribute mes 'deltaTime #f))
)
(if delta-time?
(laml-error "thin-out-section-by-bar: Encountered a deltaTime message. Can only be applied in pure absTime mode."))
(if (and (>= abs-time repl-start-point) (< abs-time repl-end-point))
(let ((ch (ast-attribute mes 'channel #f))
)
(if ch
(if (member (as-number ch) channels)
(if (keep-pred abs-time)
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb #t))
(multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb #t))
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb #t)))))
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb thinning-out?)))))
((and thinning-out? (not (ast? (car ml))))
(cons (car ml) (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb thinning-out?)))
((and thinning-out? (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"))
(if (keep-pred abs-time)
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb #t))
(multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb #t))
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred section-list upb thinning-out?)))
(if (not (null? (cdr section-list)))
(let* ((next-section (second section-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-keep-pred (keep-predicate-of next-section)))
(cons mes (multi-thin-out channels (cdr ml) next-repl-start-point next-repl-end-point next-keep-pred (cdr section-list) upb #f)))
(cons mes (multi-thin-out channels (cdr ml) repl-start-point repl-end-point keep-pred '() upb #f))))))
(else (laml-error "multi-thin-out: Should not happen"))))
(define scale-velocity-of-sections-by-bar
(xml-in-laml-positional-abstraction 2 0
(lambda (channels section-list cont attr)
(let ((min-vel (as-number (defaulted-get-prop 'min-velocity attr "0")))
(max-vel (as-number (defaulted-get-prop 'max-velocity attr "127"))))
(scale-velocity-of-sections-by-bar-1 channels section-list min-vel max-vel cont)))))
(define (scale-velocity-of-sections-by-bar-1 channels section-list min-vel max-vel message-list)
(let ((sorted-section-list
(sort-list
section-list
(lambda (s1 s2) (<= (bar-number-of s1) (bar-number-of s2)))))
)
(let* ((section (first sorted-section-list))
(start-end-sf (by-bar-advancement-velocity-scaling section))
)
(multi-scale-velocity channels message-list min-vel max-vel (first start-end-sf) (second start-end-sf) (third start-end-sf)
sorted-section-list by-bar-advancement-velocity-scaling #f 0 0))))
(define (by-bar-advancement-velocity-scaling section)
(let* ((units-per-bar (* global-ppqn (first global-signature)))
(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))
(scaling-fu (scaling-function-of section))
)
(list repl-start-point repl-end-point scaling-fu)))
(define (multi-scale-velocity channels ml min-vel max-vel repl-start-point repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling scaling? nss i)
(cond ((null? ml) '())
((and (not scaling?) (not (ast? (car ml))))
(cons (car ml) (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point
repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling scaling? nss i)))
((and (not scaling?) (ast? (car ml)))
(display "X")
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime)))
(delta-time? (ast-attribute mes 'deltaTime #f))
)
(if delta-time?
(laml-error "scale-velocity-of-sections-by-bar: Encountered a deltaTime message."))
(if (and (>= abs-time repl-start-point) (< abs-time repl-end-point))
(let ((ch (ast-attribute mes 'channel #f))
)
(if ch
(let ((scaling-steps (find-number-of-scaling-steps-in ml channels repl-end-point)))
(if (member (as-number ch) channels)
(cons (scale-message mes scaling-fu scaling-steps 1 min-vel max-vel)
(multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point
repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling #t scaling-steps 2))
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point
repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling #t scaling-steps 1))
))
(let ((scaling-steps (find-number-of-scaling-steps-in ml channels repl-end-point)))
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point
repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling #t scaling-steps 1)))))
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point repl-end-point
scaling-fu section-list by-bar-advancement-velocity-scaling scaling? nss i)))))
((and scaling? (not (ast? (car ml))))
(cons (car ml) (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point repl-end-point
scaling-fu section-list by-bar-advancement-velocity-scaling scaling? nss i)))
((and scaling? (ast? (car ml)))
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime))))
(if (<= abs-time repl-end-point)
(begin
(display-message "W" nss i)
(if (and (member (as-number (ast-attribute mes 'channel)) channels) (equal? (ast-element-name mes) "NoteOn"))
(cons (scale-message mes scaling-fu nss i min-vel max-vel)
(multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point
repl-end-point scaling-fu section-list by-bar-advancement-velocity-scaling #t nss (+ i 1)))
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point repl-end-point
scaling-fu section-list by-bar-advancement-velocity-scaling scaling? nss i))))
(begin
(display "V")
(if (not (null? (cdr section-list)))
(let* ((next-section (second section-list))
(start-end-sf (by-bar-advancement-velocity-scaling next-section))
)
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel (first start-end-sf) (second start-end-sf) (third start-end-sf)
(cdr section-list) by-bar-advancement-velocity-scaling #f 0 0)))
(cons mes (multi-scale-velocity channels (cdr ml) min-vel max-vel repl-start-point repl-end-point
scaling-fu '() by-bar-advancement-velocity-scaling #f 0 0)))))))
(else (laml-error "multi-scale-velocity: Should not happen"))))
(define (find-number-of-scaling-steps-in message-list channels time-limit)
(find-number-of-scaling-steps-in-1 message-list channels time-limit 0))
(define (find-number-of-scaling-steps-in-1 message-list channels time-limit count)
(cond ((null? message-list) count)
((not (ast? (car message-list)))
(find-number-of-scaling-steps-in-1 (cdr message-list) channels time-limit count))
((> (as-number (ast-attribute (car message-list) 'absTime)) time-limit) count)
((and (equal? (ast-element-name (car message-list)) "NoteOn")
(ast-attribute (car message-list) 'channel #f)
(member (as-number (ast-attribute (car message-list) 'channel)) channels))
(find-number-of-scaling-steps-in-1 (cdr message-list) channels time-limit (+ count 1)))
(else
(find-number-of-scaling-steps-in-1 (cdr message-list) channels time-limit count))))
(define (scale-message noteon-ast scaling-fu scaling-steps i min-vel max-vel)
(display-message i scaling-steps)
(let* ((old-velocity (as-number (ast-attribute noteon-ast 'velocity)))
(new-velocity (between min-vel max-vel
(+ min-vel (* (- old-velocity min-vel) (scaling-fu (/ i scaling-steps)))))))
(copy-ast-mutate-attributes noteon-ast 'velocity (as-int-string new-velocity))))
(define envelope-sections-by-bar
(xml-in-laml-positional-abstraction 1 0
(lambda (section-list cont attr)
(envelope-sections-by-bar-1 section-list cont))))
(define (envelope-sections-by-bar-1 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))
(pre-envelope-list (pre-envelope-of section))
(post-envelope-list (post-envelope-of section))
(post-envelope-list-length (total-length-of-message-list post-envelope-list))
)
(multi-enveloping message-list repl-start-point repl-end-point pre-envelope-list post-envelope-list post-envelope-list-length
sorted-section-list units-per-bar #f #f))))
(define (multi-enveloping ml repl-start-point repl-end-point pre-envelope-list post-envelope-list
post-envelope-length section-envelope-list upb enveloping? post-env-inserted?)
(cond ((null? ml) '())
((and (not enveloping?) (not (ast? (car ml))))
(cons (car ml)
(multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list post-envelope-list
post-envelope-length section-envelope-list upb enveloping? post-env-inserted? )))
((and (not enveloping?) (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))
(append
pre-envelope-list
(cons
mes
(multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list post-envelope-list
post-envelope-length section-envelope-list upb #t #f)))
(cons mes (multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list post-envelope-list
post-envelope-length section-envelope-list upb enveloping? post-env-inserted?)))))
((and enveloping? (not (ast? (car ml))))
(cons (car ml) (multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list
post-envelope-list post-envelope-length section-envelope-list upb enveloping?
post-env-inserted?)))
((and enveloping? (ast? (car ml)))
(let* ((mes (car ml))
(abs-time (as-number (ast-attribute mes 'absTime))))
(if (<= abs-time repl-end-point)
(if (and (>= abs-time (- repl-end-point post-envelope-length)) (not post-env-inserted?))
(append
post-envelope-list
(cons
mes
(multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list post-envelope-list
post-envelope-length section-envelope-list upb #t #t)))
(cons mes (multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list
post-envelope-list post-envelope-length section-envelope-list upb enveloping?
post-env-inserted?)) )
(if (not (null? (cdr section-envelope-list)))
(let* ((next-section (second section-envelope-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))
(pre-envelope-list (pre-envelope-of next-section))
(post-envelope-list (post-envelope-of next-section))
(post-envelope-list-length (total-length-of-message-list post-envelope-list))
)
(cons mes
(multi-enveloping (cdr ml) next-repl-start-point next-repl-end-point pre-envelope-list post-envelope-list
post-envelope-length (cdr section-envelope-list) upb #f #f)))
(cons mes (multi-enveloping (cdr ml) repl-start-point repl-end-point pre-envelope-list
post-envelope-list post-envelope-length '() upb #f #f))))))
(else (laml-error "multi-enveloping: Should not happen"))))
(define bar-number-of (make-selector-function 1 "bar-number-of"))
(define bar-length-of (make-selector-function 2 "bar-length-of"))
(define start-time-of (make-selector-function 1 "start-time-of"))
(define end-time-of (make-selector-function 2 "end-time-of"))
(define replacement-list-of (make-selector-function 3 "replacement-list-of"))
(define keep-predicate-of (make-selector-function 3 "keep-predicate-of"))
(define scaling-function-of (make-selector-function 3 "scaling-function-of"))
(define pre-envelope-of (make-selector-function 3 "pre-envelope-of"))
(define post-envelope-of (make-selector-function 4 "post-envelope-of"))
(define substitute-section-by-time
(xml-in-laml-positional-abstraction 2 0
(lambda (channels section-list cont attr)
(substitute-section-by-time-1 channels section-list cont))))
(define contextual-message-list '())
(define (substitute-section-by-time-1 channels section-list message-list)
(set! contextual-message-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))
(start-end-repl (by-time-advancement-substitution section))
)
(multi-substitution channels message-list
(first start-end-repl) (second start-end-repl) (third start-end-repl)
sorted-section-list by-time-advancement-substitution #f))))
(define (by-time-advancement-substitution section)
(let* ((repl-start-point (start-time-of section))
(repl-end-point (end-time-of section))
(replacement-lst (stretch-if-necessary (replacement-list-of section) (- repl-end-point repl-start-point)))
)
(list repl-start-point repl-end-point replacement-lst)))
(define (stretch-if-necessary delta-message-list to-length)
(let* ((mes-lst-lgt (length-of-delta-time-midi-list delta-message-list))
(stretch-factor (/ to-length mes-lst-lgt)))
(time-stretch-1 stretch-factor delta-message-list)))
(define scale-velocity-of-sections-by-time
(xml-in-laml-positional-abstraction 2 0
(lambda (channels section-list cont attr)
(let ((min-vel (as-number (defaulted-get-prop 'min-velocity attr "0")))
(max-vel (as-number (defaulted-get-prop 'max-velocity attr "127"))))
(scale-velocity-of-sections-by-time-1 channels section-list min-vel max-vel cont)))))
(define (scale-velocity-of-sections-by-time-1 channels section-list min-vel max-vel message-list)
(set! contextual-message-list message-list)
(let ((sorted-section-list
(sort-list
section-list
(lambda (s1 s2) (<= (bar-number-of s1) (bar-number-of s2)))))
)
(let* ((section (first sorted-section-list))
(start-end-sf (by-time-advancement-velocity-scaling section))
)
(multi-scale-velocity channels message-list min-vel max-vel (first start-end-sf) (second start-end-sf) (third start-end-sf)
sorted-section-list by-time-advancement-velocity-scaling #f 0 0))))
(define (by-time-advancement-velocity-scaling section)
(let* ((repl-start-point (start-time-of section))
(repl-end-point (end-time-of section))
(scaling-fu (scaling-function-of section))
)
(list repl-start-point repl-end-point scaling-fu)))
(define (time-of-marker marker-name . optional-parameter-list)
(let ((message-lst (optional-parameter 1 optional-parameter-list contextual-message-list)))
(let* ((marker-lgt (string-length marker-name))
(res-mes (find-in-list
(lambda (mes)
(and (Meta? mes 6)
(let ((meta-txt (ast-text mes)))
(and (>= (string-length meta-txt) marker-lgt)
(equal? (substring meta-txt 0 marker-lgt) marker-name)))))
message-lst)))
(if res-mes
(ast-attribute res-mes 'absTime)
(laml-error "Cannot find marker" marker-name (length message-lst))))))
(define (beat direction stretch base-velocity total-length velocity-scaling-fn delta-time-scaling-fn . optional-parameter-list)
(let ((transposition (optional-parameter 1 optional-parameter-list 0))
(ch (optional-parameter 2 optional-parameter-list 1))
(base-duration (optional-parameter 3 optional-parameter-list 960))
(time-note-list (optional-parameter 4 optional-parameter-list '((240 C2) (240 E2) (240 G2) (240 B2) (240 C3) (240 E3))))
)
(transpose-channels (list ch) transposition
(let* ((directional-time-note-list (if (eq? direction 'down) (reverse time-note-list) time-note-list))
(notes
(scale-attribute-1 'deltaTime delta-time-scaling-fn
(scale-attribute-1 'velocity velocity-scaling-fn
(time-stretch stretch
(cons
(let* ((t 0)
(nv (second (first directional-time-note-list)))
(n-velocity (third-else (first directional-time-note-list) base-velocity))
(nn (cond ((eq? nv '-) #f) ((number? nv) nv) (else (note-name-to-note-number nv))))
)
(if (eq? nn #f)
(midi-null-event-delta-time t "Dropped note")
(NoteOn 'deltaTime t 'channel ch 'note nn 'velocity n-velocity (duration-to-next base-duration))))
(map
(lambda (t-nv)
(let* ((t (first t-nv))
(nv (second t-nv))
(n-velocity (third-else t-nv base-velocity))
(nn (cond ((eq? nv '-) #f) ((number? nv) nv) (else (note-name-to-note-number nv))))
)
(if (eq? nn #f)
(midi-null-event-delta-time t "Dropped note")
(NoteOn 'deltaTime t 'channel ch 'note nn 'velocity n-velocity (duration-to-next base-duration)))))
(cdr directional-time-note-list)))
))))
(note-lgt (accumulate-right + 0 (map (lambda (ast) (as-number (ast-attribute ast 'deltaTime))) notes)))
)
(if (> note-lgt total-length) (laml-error "Stretched NoteOn sequence of length" note-lgt "does not fit in an interval of length" total-length))
(list
(midi-comment (if (eq? direction 'down) "Downwards:" "Upwards:"))
notes
(midi-null-event-delta-time (- total-length note-lgt) (string-append "Filling to total-length " (as-string total-length)))
(midi-comment (if (eq? direction 'down) "End downwards." "End upwards."))
)))))
(define (third-else lst default)
(if (>= (length lst) 3) (third lst) default))
(define (add-together-delta-times-until ast-list stop-ast)
(cond ((null? ast-list) 0)
((not (ast? (car ast-list))) (add-together-delta-times-until (cdr ast-list) stop-ast))
((eq? (car ast-list) stop-ast) (as-number (ast-attribute stop-ast 'deltaTime)) )
(else (+ (as-number (ast-attribute (car ast-list) 'deltaTime)) (add-together-delta-times-until (cdr ast-list) stop-ast)))))
(define (duration-to-next default-duration)
(lambda (root-ast note-ast)
(let* ((track (find-first-ast root-ast "MidiTrack"))
(events-in-track (ast-subtrees track))
(note-value (ast-attribute note-ast 'note -1))
(channel (ast-attribute note-ast 'channel -1))
(events-from-note-ast (find-tail-in-list (lambda (el) (eq? el note-ast)) events-in-track))
(events-after-note-ast (if (not (null? events-from-note-ast)) (cdr events-from-note-ast) '()))
(next-similar-note-ast (find-in-list
(lambda (n-ast)
(and (NoteOn? n-ast)
(equal? note-value (ast-attribute n-ast 'note))
(equal? channel (ast-attribute n-ast 'channel))
))
events-after-note-ast))
(dur (if next-similar-note-ast (add-together-delta-times-until events-after-note-ast next-similar-note-ast) default-duration))
)
(list 'duration (max 0 dur)))))
(define (generate-mega-voice-function mega-voice-map)
(lambda (note-name section-name velocity)
(let* ((note-name-str (as-string note-name))
(relative-note-name? (member (as-number (string-ref note-name-str 0)) lower-case-interval))
(min-note-mvm (min-note-of-mega-voice-map section-name mega-voice-map))
(max-note-mvm (max-note-of-mega-voice-map section-name mega-voice-map))
(min-vel-mvm (min-velocity-of-mega-voice-map section-name mega-voice-map))
(max-vel-vmv (max-velocity-of-mega-voice-map section-name mega-voice-map))
)
(list
(if relative-note-name?
(mv-relative-to-absolute-note-number (- (note-name-to-note-number note-name) 24) min-note-mvm max-note-mvm)
(between min-note-mvm max-note-mvm (note-name-to-note-number note-name)))
(mv-scale-velocity velocity min-vel-mvm max-vel-vmv)))))
(define lower-case-interval (number-interval 97 122))
(define (min-note-of-mega-voice-map section-name mega-voice-map)
(let ((section (find-in-list (lambda (sec) (equal? (as-string section-name) (as-string (first sec)))) mega-voice-map)))
(if section (second section) (laml-error "min-note-of-mega-voice-map: Unknown section" section-name))))
(define (max-note-of-mega-voice-map section-name mega-voice-map)
(let ((section (find-in-list (lambda (sec) (equal? (as-string section-name) (as-string (first sec)))) mega-voice-map)))
(if section (third section) (laml-error "max-note-of-mega-voice-map: Unknown section" section-name))))
(define (min-velocity-of-mega-voice-map section-name mega-voice-map)
(let ((section (find-in-list (lambda (sec) (equal? (as-string section-name) (as-string (first sec)))) mega-voice-map)))
(if section (fourth section) (laml-error "min-velocity-of-mega-voice-map: Unknown section" section-name))))
(define (max-velocity-of-mega-voice-map section-name mega-voice-map)
(let ((section (find-in-list (lambda (sec) (equal? (as-string section-name) (as-string (first sec)))) mega-voice-map)))
(if section (fifth section) (laml-error "max-velocity-of-mega-voice-map: Unknown section" section-name))))
(define (mv-scale-velocity velocity min-vel max-vel)
(to-int (+ min-vel (* (/ (- max-vel min-vel) 127) (- velocity 1)))))
(define (mv-relative-to-absolute-note-number rel-note-number min-note max-note)
(let ((result (+ rel-note-number min-note)))
(if (<= result max-note)
result
max-note)))
(define steel-guitar-megavoice-map
(list
(list 'harmonics 0 95 121 127) (list 'slide 0 95 106 120) (list 'hammer 0 95 91 105) (list 'mute 0 95 76 90) (list 'dead 0 95 61 75)
(list 'open-hard 0 95 41 60) (list 'open-medium 0 95 21 40) (list 'open-soft 0 95 1 20)
(list 'strum-noice 96 119 1 127) (list 'fret-noice 120 127 1 127)))
(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 #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 (split-and-process-style-one-channel-refined style-file-path output-dir-path mode channel)
(let ((midi-ast (midi-file-to-laml-ast style-file-path mode 0 #f #f)))
(split-and-process-style-one-channel-given-ast-refined #f style-file-path midi-ast output-dir-path mode channel)))
(define (split-and-process-style-one-channel-given-ast-refined meta-file-path style-file-path midi-ast output-dir-path mode channel)
(if (not (eq? mode 'deltaTime))
(laml-error "split-and-process-style-one-channel-given-ast-refined: mode must be deltaTime" mode))
(if (not (directory-exists? output-dir-path))
(let ((parent-output-dir (parent-directory output-dir-path))
(last-dir (directory-leave-name output-dir-path))
)
(if (or (not parent-output-dir) (not last-dir))
(laml-error "You should not work in the root directory"))
(display-message "Creating" last-dir "in" parent-output-dir)
(ensure-directory-existence! parent-output-dir last-dir)))
(let* ((style-name-0 (file-name-proper (file-name-proper style-file-path)))
(style-name (transliterate style-name-0 #\space "-"))
(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 style-name)
(ensure-directory-existence! (string-append output-dir-path style-name "/") (as-string channel))
(for-each
(lambda (section section-name)
(let* ((init-events-for-selected-channel (select-channel channel init-stuff))
(body-events-for-selected-channel (select-channel channel section))
(target-file-path (string-append output-dir-path style-name "/" (as-string channel) "/" section-name "." "mid"))
)
(if (not (null? (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)))) body-events-for-selected-channel)))
(let ((meta-info (make-meta-info-about-style-part
style-name-0 section-name channel style-file-path target-file-path
midi-header init-events-for-selected-channel body-events-for-selected-channel)))
(if meta-file-path (add-meta-info-to-meta-base meta-file-path meta-info))
(write-text-file
(standard-midi-file-ast-to-bin
(StandardMidiFile 'internal:run-action-procedure "false"
midi-header
(MidiTrack
init-events-for-selected-channel
body-events-for-selected-channel
end-of-track-event)))
target-file-path
))
'do-nothing)))
section-list section-name-list)))
(define (split-and-process-style-refined meta-file-path style-file-path output-dir-path mode)
(set! global-meta-info-list '())
(split-and-process-style-refined-1 meta-file-path style-file-path output-dir-path mode))
(define (split-and-process-style-refined-1 meta-file-path style-file-path output-dir-path mode)
(let ((midi-ast (midi-file-to-laml-ast style-file-path mode 0 #f #f)))
(for-each (lambda (channel)
(split-and-process-style-one-channel-given-ast-refined meta-file-path style-file-path midi-ast output-dir-path mode channel))
(number-interval 1 16))))
(define (split-and-process-all-styles-refined meta-file-path input-dir-path output-dir-path mode)
(set! global-meta-info-list '())
(split-and-process-all-styles-refined-1 meta-file-path input-dir-path output-dir-path mode))
(define (split-and-process-all-styles-refined-1 meta-file-path input-dir-path output-dir-path mode)
(let* ((file-list (directory-list input-dir-path))
(style-file-list (filter (lambda (fn) (member (downcase-string (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-refined-1 meta-file-path (string-append input-dir-path style-file) output-dir-path mode)
(display-message "")
)
style-file-list)))
(define (split-and-process-all-style-directory-refined meta-file-path input-dir-path output-dir-path mode)
(set! global-meta-info-list '())
(split-and-process-all-style-directory-refined-1 meta-file-path input-dir-path output-dir-path mode)
)
(define (split-and-process-all-style-directory-refined-1 meta-file-path input-dir-path output-dir-path mode)
(let* ((directory-list (filter directory-exists? (map (lambda (subdir) (string-append input-dir-path subdir "/"))
(directory-list input-dir-path))))
(leave-output-dir (directory-leave-name output-dir-path))
(output-parent-dir (parent-directory output-dir-path))
)
(ensure-directory-existence! output-parent-dir leave-output-dir)
(for-each (lambda (dir)
(let ((leave-dir (directory-leave-name dir)))
(display-message "***" dir)
(ensure-directory-existence! output-dir-path leave-dir)
(split-and-process-all-styles-refined-1 meta-file-path dir (string-append output-dir-path leave-dir "/") mode)
(display-message ""))
)
directory-list)
(save-meta-info-on-file meta-file-path global-meta-info-list)
)
)
(define (make-meta-info-about-style-part style-name section-name channel style-file-path target-file-path
midi-header init-events-for-selected-channel body-events-for-selected-channel)
(let* ((nil-if-false (lambda (x) (if (and (boolean? x) (not x)) 'nil x)))
(ppqn (as-number (ast-attribute midi-header 'pulsesPerQuarterNote)))
(meta-time-signature-ast (find-in-list (lambda (x) (and (ast? x) (equal? "Meta" (ast-element-name x)) (equal? (ast-attribute x 'type #f) "88")))
init-events-for-selected-channel))
(time-signature (if meta-time-signature-ast (time-signature-of-meta-type-88-ast meta-time-signature-ast) #f))
(instrument-tuple (find-instrument-info-of channel init-events-for-selected-channel))
(instrument-name (if instrument-tuple (find-tyros-voice (first instrument-tuple) (second instrument-tuple) (third instrument-tuple)) #f))
(number-of-notes (length (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)))) body-events-for-selected-channel)))
(number-of-different-notes (count-number-of-different-notes body-events-for-selected-channel))
(program-control-changes (program-control-change-info init-events-for-selected-channel body-events-for-selected-channel))
(length-of-body
(accumulate-right + 0
(map (lambda (ast) (as-number (ast-attribute ast 'deltaTime)))
(cdr
(filter (lambda (x) (ast? x)) body-events-for-selected-channel)))))
)
(list
(nil-if-false time-signature)
(ceiling (/ length-of-body ppqn))
number-of-notes
(nil-if-false instrument-tuple)
(nil-if-false instrument-name)
(nil-if-false section-name)
channel
ppqn
length-of-body
(nil-if-false style-name)
(nil-if-false (truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/" style-file-path))
(nil-if-false (truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/MIDI-PIECES/All-pieces/" target-file-path))
number-of-different-notes
program-control-changes
)
)
)
(define (count-number-of-different-notes midi-even-list)
(let ((occ-count (make-vector 128 0)))
(for-each
(lambda (x)
(if (and (ast? x) (equal? "NoteOn" (ast-element-name x)))
(let ((note (as-number (ast-attribute x 'note))))
(vector-set! occ-count note (+ 1 (vector-ref occ-count note)))))
)
midi-even-list)
(accumulate-right + 0 (map (lambda (note) (if (> (vector-ref occ-count note) 0) 1 0)) (number-interval 0 127)))))
(define (program-control-change-info init-event-list body-event-list)
(let* ((all-events (append init-event-list body-event-list))
(program-events (filter (lambda (x) (and (ast? x) (equal? "ProgramChange" (ast-element-name x)))) all-events))
(control-change-expression-events
(filter (lambda (x) (and (ast? x) (equal? "ControlChange" (ast-element-name x)) (= 11 (as-number (ast-attribute x 'control))))) all-events))
(pitch-bend-change-events
(filter (lambda (x) (and (ast? x) (equal? "PitchBendChange" (ast-element-name x)))) all-events))
)
(list (length program-events)
(length control-change-expression-events)
(length pitch-bend-change-events))))
(define (find-instrument-info-of channel midi-events-for-selected-channel)
(let* ((msb-ast (find-in-list (lambda (x) (and (ast? x)
(equal? "ControlChange" (ast-element-name x))
(= (as-number (ast-attribute x 'channel)) channel)
(equal? (ast-attribute x 'control #f) "0")))
midi-events-for-selected-channel))
(msb (if msb-ast (ast-attribute msb-ast 'value #f) #f))
(lsb-ast (find-in-list (lambda (x) (and (ast? x)
(equal? "ControlChange" (ast-element-name x))
(= (as-number (ast-attribute x 'channel)) channel)
(equal? (ast-attribute x 'control #f) "32")))
midi-events-for-selected-channel))
(lsb (if lsb-ast (ast-attribute lsb-ast 'value #f) #f))
(prog-number-ast (find-in-list (lambda (x) (and (ast? x)
(equal? "ProgramChange" (ast-element-name x))
(= (as-number (ast-attribute x 'channel)) channel)))
midi-events-for-selected-channel))
(prog-number (if prog-number-ast (ast-attribute prog-number-ast 'number #f) #f)))
(if (and msb lsb prog-number)
(list (as-number msb) (as-number lsb) (as-number prog-number))
#f) ))
(define global-meta-info-list '())
(define (add-meta-info-to-meta-base meta-file-path meta-info)
(set! global-meta-info-list (cons meta-info global-meta-info-list))
(if (= 0 (remainder (length global-meta-info-list) 1000))
(begin
(display "Saving meta info about midi-pieces... ")
(save-meta-info-on-file meta-file-path global-meta-info-list)
(display-message " DONE")))
)
(define (save-meta-info-on-file meta-file-path meta-info-list)
(if (not (file-exists? meta-file-path))
(let ((fnpe (file-name-proper-and-extension meta-file-path))
(fnip (file-name-initial-path meta-file-path)))
(display-message "Creating meta piece file" fnpe "in" fnip)
(if (directory-exists? fnip)
(file-write '() meta-file-path)
(laml-error "Trying to make meta midi piece file in non-existing directory" fnip))))
(file-write (reverse meta-info-list) meta-file-path)
)
(define (adapt-meta-info-file-to-relative-file-paths meta-info-path)
(let ((meta-lst (file-read meta-info-path)))
(file-write (map adapt-meta-entry-to-relative-file-paths meta-lst) meta-info-path)))
(define (adapt-meta-entry-to-relative-file-paths me)
(list (list-ref me 0) (list-ref me 1) (list-ref me 2) (list-ref me 3) (list-ref me 4) (list-ref me 5) (list-ref me 6) (list-ref me 7) (list-ref me 8) (list-ref me 9)
(truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/" (list-ref me 10))
(truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/MIDI-PIECES/All-pieces/" (list-ref me 11))
(list-ref me 12) (list-ref me 13)))
(define (truncate-this-string str in-str)
(let ((str-lgt (string-length str)))
(if (equal? (substring in-str 0 str-lgt) str )
(substring in-str str-lgt (string-length in-str))
(laml-error "truncate-this-string: problems" str in-str))))
(define (abs-time-message-list-to-delta-timing message-ast-list previous-abs-time)
(cond ((null? message-ast-list) '())
((ast? (car message-ast-list))
(let* ((message-ast (car message-ast-list))
(this-abs-time (as-number (ast-attribute message-ast 'absTime)))
(new-delta-time (- this-abs-time previous-abs-time))
)
(cons (sm-abs-to-delta-time message-ast new-delta-time)
(abs-time-message-list-to-delta-timing (cdr message-ast-list) this-abs-time))))
(else (cons (car message-ast-list) (abs-time-message-list-to-delta-timing (cdr message-ast-list) previous-abs-time)))))
(define (sm-abs-to-delta-time ast delta-time)
(make-ast (ast-element-name ast)
(ast-subtrees ast)
(append (list 'deltaTime
(as-string delta-time))
(but-props (ast-attributes ast) (list 'absTime)))
(ast-kind ast)
(ast-language ast)
(ast-internal-attributes ast)))
(define (delta-time-message-list-to-abs-timing message-ast-list start-time)
(cond ((null? message-ast-list) '())
((ast? (car message-ast-list))
(let* ((message-ast (car message-ast-list))
(delta-time (ast-attribute message-ast 'deltaTime))
(new-abs-time (+ start-time (as-number delta-time)))
)
(cons (sm-delta-to-abs-time message-ast new-abs-time)
(delta-time-message-list-to-abs-timing (cdr message-ast-list) new-abs-time))))
(else (cons (car message-ast-list) (delta-time-message-list-to-abs-timing (cdr message-ast-list) start-time)))))
(define (sm-delta-to-abs-time ast abs-time)
(let ((existing-info (ast-attribute ast 'info "")))
(make-ast (ast-element-name ast)
(ast-subtrees ast)
(append (list
'absTime (as-string abs-time)
)
(but-props (ast-attributes ast) (list 'deltaTime 'info)))
(ast-kind ast)
(ast-language ast)
(ast-internal-attributes ast))))
(define (pitch-bend-scale factor)
(let ((mid-value 8192))
(lambda (value)
(+ (* (- value mid-value) factor) mid-value))))
(define (copy-midi-ast-list ast-lst)
(map copy-midi-ast ast-lst))
(define (copy-midi-ast x)
(if (ast? x)
(make-ast
(ast-element-name x)
(ast-subtrees x)
(copy-midi-property-list (ast-attributes x))
(ast-kind x)
(ast-language x)
(ast-internal-attributes x))
x))
(define (copy-midi-property-list plst)
(if (null? plst)
'()
(cons (car plst) (cons (cadr plst) (copy-midi-property-list (cddr plst))))))
(define (total-length-of-message-list message-list)
(let ((message-list-asts-only (filter ast? message-list)))
(cond ((abs-time-sequence? message-list)
(let* ((first-message (first message-list-asts-only))
(last-message (last message-list-asts-only)))
(- (time-of-message last-message) (time-of-message first-message))))
((delta-time-sequence? message-list)
(accumulate-right + 0 (map (lambda (ast) (time-of-message ast)) message-list-asts-only)))
(else (laml-error "total-length-of-message-list: Cannot determine time mode of message-list. Is the message-list maybe empty?")))))
(define (enforce-minimum-message-length min-length message-list)
(let ((lgt (total-length-of-message-list message-list)))
(if (< lgt min-length)
(append
message-list
(list (midi-null-event-delta-time (- min-length lgt) (string-append "Enforcing of minium length"))))
message-list)))
(define (icon name)
(cond ((equal? name "penguin") "S713")
((equal? name "butterfly") "S690")
((equal? name "candle") "S719")
((equal? name "banana") "S696")
((equal? name "orange") "S697")
((equal? name "lighting") "S718")
(else "S713")))
(define (note-complement note-str-list)
(let* ((note-list (string-to-list (transliterate note-str-list #\space "") (list #\,)))
(complement-note-list
(map (lambda (nn) (if (member nn note-list) #f nn)) note-name-list)))
(list-to-string (filter (lambda (x) x) complement-note-list) ",")))
(define (chord-complement chord-str-list)
(let* ((chord-list (string-to-list (transliterate chord-str-list #\space "") (list #\,)))
(complement-chord-list
(map (lambda (cn) (if (member cn chord-list) #f cn)) chord-name-list)))
(list-to-string (filter (lambda (x) x) complement-chord-list) ",")))