;;;; .title Midi Function Library ;;;; .author Kurt Nørmark ;;;; .affiliation Department of Computer Science, Aalborg University, Denmark ;;;; This is a library of common MIDI manipulation functions. ;;;; It must be loaded together with the MIDI LAML mirror library. ;;;; .laml-resource true ;;;; .css-prestylesheet compact ;;;; .css-stylesheet argentina ;;;; .css-stylesheet-copying true ;;;; .scheme-source-linking true ;;;; .source-destination-delta ;;;; .schemedoc-dependencies
; --------------------------------------------------------------------------------------------------------------- ; Mirror parameter setting
(set-xml-accept-only-string-valued-attributes-in 'midi #f) ; --------------------------------------------------------------------------------------------------------------- ; Issue a fatal error if deltaTime attributes is present in message-list. ; operation is a parameter passed for error message purposes.
(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)))) ; Issue a fatal error if absTime attributes is present in message-list. ; operation is a parameter passed for error message purposes.
(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)))) ; --------------------------------------------------------------------------------------------------------------- ; Assume absTime
(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))))) ; ---------------------------------------------------------------------------------------------------------------
;;; Message List functions. ;;; This section contains function that can be applied to lists of midi messages.
;; Fade out linearly through message-list. ;; Works in both absTime and deltaTime mode. ;; .form (fade-out . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages)

(define (fade-out . message-list) (fade-out-1 message-list)) (define (fade-out-1 message-list) (let ((lgt (length message-list))) (map (lambda (mes-ast i) (if (equal? (ast-element-name mes-ast) "NoteOn") (copy-ast-mutate-attributes mes-ast 'velocity (fade-velocity lgt i (as-number (ast-attribute mes-ast 'velocity)))) mes-ast)) message-list (number-interval 1 lgt)))) (define (fade-velocity n i input-velocity) (as-int-string (between 0 127 (to-int (/ (* input-velocity (- n i)) n))))) ; OK
;; Stretch the time of message-list with a factor. ;; Works in both absTime and deltaTime mode. ;; .form (time-stretch factor . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter factor A factor with wich to stretch the timing of the messages. A factor 1 is neutral with respect to timing.

(define time-stretch (xml-in-laml-positional-abstraction 1 0 (lambda (factor cont attr) (time-stretch-1 factor cont)))) (define (time-stretch-1 factor message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((delta-time (ast-attribute mes-ast 'deltaTime #f)) (abs-time (ast-attribute mes-ast 'absTime #f))) (cond (delta-time (copy-ast-mutate-attributes mes-ast 'deltaTime (as-int-string (* (as-number delta-time) factor)))) (abs-time (copy-ast-mutate-attributes mes-ast 'absTime (as-int-string (* (as-number abs-time) factor)))) (else (laml-error "Can only time stretch in deltaTime and absTime mode")))) mes-ast)) message-list))
;; Time displace with amount. Affects all channels as well as system messages. ;; Displacement can be positive or negative. ;; As of now, it works only in absTime mode. ;; .form (time-displace displacement . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter displacement The displacement of messages in time units, as described by the pulsesPerQuarterNote attribute of MidiHeader. Can be positive or negative.

(define time-displace (xml-in-laml-positional-abstraction 1 0 (lambda (amount cont attr) (time-displace-1 amount cont)))) (define (time-displace-1 amount message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((abs-time (ast-attribute mes-ast 'absTime #f))) (cond (abs-time (copy-ast-mutate-attributes mes-ast 'absTime (as-int-string (+ (as-number abs-time) amount)))) (else (laml-error "Can only time displace in absTime mode")))) mes-ast)) message-list))
;; As time-displace, but only affecting channels in channel-list ;; .form (time-displace-channels channel-list displacement . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter displacement The displacement of messages in time units, as described by the pulsesPerQuarterNote attribute of MidiHeader. Can be positive or negative. ;; .parameter channel-list A list of channels. (A list of integers in the interval 1..16).

(define time-displace-channels (xml-in-laml-positional-abstraction 2 0 (lambda (channel-list amount cont attr) (time-displace-channels-1 channel-list amount cont)))) (define (time-displace-channels-1 ch-list amount message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if channel (let ((channel-num (as-number channel))) (if (member channel-num ch-list) (let ((abs-time (ast-attribute mes-ast 'absTime #f))) (cond (abs-time (copy-ast-mutate-attributes mes-ast 'absTime (as-int-string (+ (as-number abs-time) amount)))) (else (laml-error "Can only time displace in absTime mode")))) mes-ast)) mes-ast)) mes-ast)) message-list))
;; Add amount to velocity of a given channel. ;; If the volicity exceeds the limits (0..127) it is enforced to the lower/upper limit. ;; Works in both absTime and deltaTime mode. ;; .form (add-to-velocity channel amount . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter amount An amount to add to the velocity. Positive or negative.

(define add-to-velocity (xml-in-laml-positional-abstraction 2 0 (lambda (channel amount cont attr) (add-to-velocity-1 channel amount cont)))) (define (add-to-velocity-1 channel amount message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "NoteOn")) (let ((velocity (ast-attribute mes-ast 'velocity #f))) (cond (velocity (copy-ast-mutate-attributes mes-ast 'velocity (as-int-string (between 0 127 (+ (as-number velocity) amount))))) (else (laml-error "Cannot find velocity of NoteOn message. Should not happen")))) mes-ast)) message-list)) ; OK
;; Replicate the events (in all channels) in message-list n times. ;; Most useful in deltaTime mode. ;; Is typically used to play n verses of a song. ;; .form (replicate n . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter n The number of replications. Must be a non-negative integer.

(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))))) ; THE CORRECT XML-IN-LAML IMPLEMENTATION, TO ALLOW FOR PROPER NESTING OF FUNCTION CALLS.
;; Change octave on channel ch with n. ;; Works in both absTime and deltaTime mode. ;; .form (octave channel n . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter n Relative octave number. n can be positive or negative. The amount 0 is neutral.

(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))
;; Put an interpolation note in between every note on the given channel. ;; Works only in absTime mode. ;; .form (interpolate channel . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter channel A channel number in the interval 1..16.

(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) ; only in beginning
(interpolate-1 ch (cdr message-list) (car message-list)) ; now the first prev-ast is in place
(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))) ))
;; Quantize channel to q. Only in absTime mode. ;; ;; ;; .form (quantize channel q pulses-per-quarter-note . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter pulses-per-quarter-note Must (redundantly) be similar to the pulsesPerQuarterNote attribute of MidiHeader. ;; .parameter q One of the integer values 1, 2, 4, 8, 16, 32, 64 and 128. 4 means a quater note quantification.

(define quantize (xml-in-laml-positional-abstraction 3 0 (lambda (channel q pulses-per-quarter-note cont attr) (quantize-1 channel q pulses-per-quarter-note cont)))) (define (quantize-1 c q pulses-per-quarter-note message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast))) (let ((channel (ast-attribute mes-ast 'channel #f))) (if (and channel (= (as-number channel) c)) (let ((abs-time (ast-attribute mes-ast 'absTime))) (if (not abs-time) (laml-error "Can only quantize in absTime mode")) (let ((time-interval (time-interval-of-note q pulses-per-quarter-note))) (copy-ast-mutate-attributes mes-ast 'absTime (quantize-int (as-number abs-time) time-interval)))))) mes-ast)) message-list)) ; ---------------------------------------------------------------------------------------------------------------
;; Distribute all NoteOn in the given channel evenly. ;; Does only work in absTime mode. ;; .form (distribute-even channel . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter channel A channel number in the interval 1..16.

(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))))) ; Adjust i to the nearest number (factor * n) for some integer n. ; Assume i is possitive
(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)) ; hel node
((= 2 note-value) (* 2 pulses-per-quarter-note)) ; halv node
((= 4 note-value) pulses-per-quarter-note) ; fjerdedels node
((= 8 note-value) (/ pulses-per-quarter-note 2)) ; ottendedels node
((= 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")))) ; Return a list of one note - the note in between note-ast-1 note-ast-2, or the empty list if note-ast-1 and note-ast-2 are too close
(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))))) '()))) ; ---------------------------------------------------------------------------------------------------------------
;; Transpose all channels with amount. ;; amount can be negative, 0 (for no transposition), or positive. ;; Works for both deltaTime and absTime. ;; .form (transpose amount . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter amount A relative number of half note values (positive or negative). The amount 0 is neutral.

(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))
;; Transpose channels in channel-list with amount. ;; amount can be negative, 0 (for no transposition), or positive. ;; Works for both deltaTime and absTime. ;; .form (transpose-channels channel-list amount . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter amount A relative number of half note values (positive or negative). The amount 0 is neutral. ;; .parameter channel-list A list of channels. (A list of integers in the interval 1..16).

(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)) ; --------------------------------------------------------------------------------------------------------------- ; Pan
;; Gradually pan a given channel from pan-from to pan-to. Works for both deltaTime and absTime. ;; The limits of pan-from and pan-to are 1..127. If exceeded, automatic cut off to min/max value is provided. ;; .form (pan-flow channel pan-from pan-to . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter channel A channel number in the interval 1..16. ;; .parameter pan-from The initial pan value. 64 is neutral, 0 is hard left, and 127 is hard right. ;; .parameter pan-to The final pan value. 64 is neutral, 0 is hard left, and 127 is hard right.

(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)))))) ; ---------------------------------------------------------------------------------------------------------------
;; Eliminate all sustain ControlChange messages on the given channel in message-list. ;; .form (no-sustain channel . messages) ;; .parameter channel A channel number in the interval 1..16. ;; .parameter messages A list of midi messages (such as NoteOn messages)

(define no-sustain (xml-in-laml-positional-abstraction 1 0 (lambda (channel contents attributes) (no-sustain-1 channel contents)))) (define (no-sustain-1 c message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "ControlChange") (= 64 (as-number (ast-attribute mes-ast 'control))) (= c (as-number (ast-attribute mes-ast 'channel)))) (midi-null-event (ast-attribute mes-ast 'deltaTime 0)) mes-ast)) message-list))
;; Eliminate ControlChange message in a given channel and with a given control number. ;; .form (eliminate-control-change channel control . messages) ;; .parameter channel A channel number in the interval 1..16. ;; .parameter control A control number in the interval 0 ..127 ;; .parameter messages A list of midi messages.

(define eliminate-control-change (xml-in-laml-positional-abstraction 2 0 (lambda (channel control contents attributes) (eliminate-control-change-1 channel control contents)))) (define (eliminate-control-change-1 ch cntrl message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "ControlChange") (= cntrl (as-number (ast-attribute mes-ast 'control))) (= ch (as-number (ast-attribute mes-ast 'channel)))) (midi-null-event (ast-attribute mes-ast 'deltaTime 0)) mes-ast)) message-list)) (define pass-through (xml-in-laml-abstraction (lambda (contents attributes) contents))) ; ---------------------------------------------------------------------------------------------------------------
;;; Midi region functions. ;;; This section contains function that establish regions around a list of midi messages.
;; Establish a context in which a smaller selection can be made. ;; Defined as a macro. ;; The context can be substituted by the selection inside it. ;; Underlying, a continuation named select is captured. ;; .form (midi-context continuation-name . messages) ;; .example (midi-context select ... (midi-region-do select ...) ...) ;; .parameter continuation-name The formal name of the continuation that controls the emitted MIDI messages. ;; .parameter messages A list of midi messages (such as NoteOn messages)

(define-syntax midi-context (syntax-rules () ((midi-context select midi-message ...) (call-with-current-continuation (lambda (select) (list midi-message ...))))))
;; Marks a region of midi messages. Pass them through to contextual-continuation and, if in absTime mode, time displace them to time 0. ;; midi-region-do is used to select and play a selected part of a MIDI LAML file. ;; .form (midi-region-do contextual-continuation . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter contextual-continuation The continuation to which messages are passed. This is normally the continuation established by the midi-context form.

(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))))))
;; Marks a region of midi messages, with the purpose of adding additional structure to a MIDI LAML file (much like span and div in HTML). Pass them through to caller. ;; Mark the region in the binary midi file with midi-comments. ;; .form (midi-region . midi-messages) ;; .attribute name implied The name of the midi region ;; .attribute drop implied A boolean attribute which allows for elimination of the region. ;; .parameter messages A list of midi messages (such as NoteOn messages)

(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) '()))))) ; ---------------------------------------------------------------------------------------------------------------
;;; Single midi message abstractions. ;;; Abstractions that generate a single, or a few midi messages.
;; A deltaTime midi null event. ;; The midi null event is neutral with respec to the midi sound. ;; Implemented as a Meta event of type 1.

(define (midi-null-event delta-time) (Meta 'deltaTime delta-time 'type "1" "Midi null-event")) (define (midi-null-event-abs-time abs-time) (Meta 'absTime abs-time 'type "1" "Midi null-event"))
;; Return a deltaTime meta event which can act as a comment in the midi file. ;; .form (midi-comment . text-strings) ;; .parameter text-strings Textual contents, in term of zero, one or several strings.

(define midi-comment (xml-in-laml-abstraction (lambda (contents attr) (Meta 'deltaTime "0" 'type 1 contents))))
;; Set the PAN of channel c to value. Returns a single MIDI ControlChange event. ;; .parameter c A channel number between 1 and 16. ;; .parameter value The pan value. 64 is neutral, 0 is hard left, and 127 is hard right.

(define (pan c value) (ControlChange 'deltaTime "0" 'channel c 'control "10" 'value value)) ; Works in certain test, but probably not in general. Too simple and specific perhaps. ; Experimental and doubtful.
(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"))) ; Voice Convenience. ; (voice c msb lsb program-number)
;; Emit two channel change messages (msb/lsb) and a program change message. ;; You should look up msb/lsb bank number and program number in a midi reference sheet. ;; The program number is according to the general midi specification. ;; .parameter channel A channel number (between 1 and 16) ;; .parameter msb Most significant byte of bank number. An integer between 0 and 127. ;; .parameter lsb Least significant byte of bank number. An integer between 0 and 127. ;; .parameter program-number. The Standard MIDI program number.

(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) )) ; Create a Yamaha Tyros Meta event that encodes a given root and chord-type. The chord-type is optional, and it defaults to "M" (for major).
;; .form (chord-meta root [chord-type]) ;; .parameter root The name of the root note. One of "C" "C#" "D" "D#" "E" "F" "F#" "G" "G#" "A" "A#" "B" (a string). ;; .parameter chord-type The name of a chord type. One of "1+8" "1+5" "M" "6" "M7" "M7b5" "M7(#11)" "9" "M7_9" "6_9" "b5" "aug" "7aug" "M7aug" "m" "m6" "m7" "m7b5" "m(9)" "m7(9)" "m7(11)" "mM7b5" "mM7" "mM7(9)" "dim" "dim7" "7" "7sus4" "7(9)" "7(#11)" "7(13)" "7b5" "7(b9)" "7(b13)" "7(#9)" "sus4" "sus2" (a string). ;; .misc Please notice that upper/lower case is important in the chord-type parameter (but not in the root parameter).

(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))) ; produces a hex string, such as "A3"
) (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))))) ; Root is a string of one or two characters, such as "C#" ; Return a number between 0 and 255 (really between 0 and 127)
(define (calculate-root-number root0) ; tyros data list page 59, cr
(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) ; natural
((eqv? root-variation #\#) 4) ; sharp
((eqv? root-variation #\b) 2) ; b - not really supported
((eqv? root-variation #\B) 2) ; b - not really supported
(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)))
;; Create a lyris meta event with the given text. ;; .parameter txt A lyrics contribution (a text string). ;; .misc Yamaha Tyros observation: Do not use the Danish Ø, ø, Æ, and æ in the text. The Danish å and Å are OK.

(define (lyrics txt) (Meta 'deltaTime "0" 'type "5" txt)) ; --------------------------------------------------------------------------------------------------------------- ; Chord playing.
; Play a given chord as a (maybe long) number of NoteOn messages, mostly for chord demo purposes. ; A list of deltaTime NoteOn messages are created; Thus, the chord sequence will be relative to the message occurring before the sequence. ; Root is a name (string): C, C#, D, D#, E, F, F#, G, G#, A, A#, B. ; Chord-type is a chord type name, as appearing in the list chord-types. ; start-octave is an octave number. Octave number 3 contains the middle C (note 60) - according the yamaha convention. Within the interval [-2..8] ; Play it through number-of-octaves (a non-negative integer), allways ended by the root note. ; Each played note will last duration time units ; There will be time-delta between notes in the played chord (meassured in basic type units, 1920 pr. quarter note on tyros). ; .form (play-chord root chord-type start-octave number-of-octaves time-delta duration [channel velocity])
(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) ))) ; Return a list of NoteOn messages ending at the note value note (an integer). ; A list of deltaTime NoteOn messages are created; Thus, the chord sequence will be relative to the message occurring before the sequence. ; Root is a name (string): C, C#, D, D#, E, F, F#, G, G#, A, A#, B. ; Chord-type is a chord type name, as appearing in the list chord-types. ; There will be time-delta between notes in the played chord (meassured in basic type units, 1920 pr. quarter note on tyros). ; Each played note will last duration time units ; Optional parameters allows for control of channel and velocity. ; .form (noteon-sequence-ending-at note lgt root chord-type time-delta duration [channel velocity]) ; .misc lgt must be at least 2 (not a problem in practical life due to lengths of chords).
(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 ; first NoteOn is moved back in time
(NoteOn 'deltaTime (- (* time-delta (- (length chord-lst) 1))) 'channel ch 'note (first chord-lst) 'velocity vel 'duration duration) ; The rest are relative to the first
(map (lambda (note-val) (NoteOn 'deltaTime time-delta 'channel ch 'note note-val 'velocity vel 'duration duration) ) (cdr chord-lst)) ) '())))) ; Add strum (a sequence of chord adapted notes) to note-ast. ; If the chord does not match note-on-ast, return (a list of) note-on-ast. Else return a longer chord adapted list ending with note-on-ast. ; note-on-ast should be with absTime. ; The parameters lgt, root, chord-type, delta-time, duration, channel and velocity is as for noteon-sequence-ending-at.
(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)) ; note-on-ast must have absTime. Strum is relative to it, therefore note-on-ast should come first
(list note-on-ast))))
;; Add strum (a sequence of chord adapted notes) to all matching notes in messages. ;; Similar to strum-2, but this version takes explicit, positional chord root, chord type and strum length parameters. ;; A given notes matches a chord and a root if the note is present in the chord sequence made by root and chord-type. ;; If the chord does not match a note, just return the note. Else return a longer chord adapted list ending with note-on-ast. ;; Should only be used on absTime (?). ;; The parameters lgt, root, chord-type, delta-time, duration, channel and velocity is as for noteon-sequence-ending-at. ;; .form (strum-1 length root chord-type . messages) ;; .parameter length The number notes produced in case of a match (a non-negative integer) ;; .parameter root The name of the root note. One of "C" "C#" "D" "D#" "E" "F" "F#" "G" "G#" "A" "A#" "B" (a string). ;; .parameter chord-type The name of a chord type. One of "1+8" "1+5" "M" "6" "M7" "M7b5" "M7(#11)" "9" "M7_9" "6_9" "b5" "aug" "7aug" "M7aug" "m" "m6" "m7" "m7b5" "m(9)" "m7(9)" "m7(11)" "mM7b5" "mM7" "mM7(9)" "dim" "dim7" "7" "7sus4" "7(9)" "7(#11)" "7(13)" "7b5" "7(b9)" "7(b13)" "7(#9)" "sus4" "sus2" (a string).

(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))))
;; Add strum (a sequence of chord adapted notes) to all matching notes in messages. ;; Similar to strum-1, but this version takes chord root, chord type and strum length from attributes of NoteOn. ;; The strum-length attribute defaults to 4 in the context of this function. ;; The chord-type defaults to major ("M"). This "C" and "C#" are legal chord attribute values of NoteOn elements. They are identical to "CM" and "C#M". ;; A given notes matches a chord and a root if the note is present in the chord sequence made by root and chord-type. ;; If the chord does not match a note, just return the note. Else return a longer chord adapted list ending with note-on-ast. ;; Should only be used on absTime (?). ;; The chord root, chord type, and strum length are taken from the chord and strum-length attributes of the NoteOn elements. ;; .form (strum-2 . messages)

(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))))
;; Add strum (a sequence of chord adapted notes) to all matching notes in messages which belong to channel. ;; Similar to strum-1, but this version takes chord root, chord type from Meta events, maybe and typically generated from the accompaniment of Keyboard. ;; It may also take chord information from a chord attribute of NoteOn messages. ;; As a distinctive feature of this version of strum, the chord information is carried through the messages. ;; The strum-length attribute defaults to 4 in the context of this function, but it can change if a NoteOn messages carries a strum-length attribute. ;; A given notes matches a chord and a root if the note is present in the chord sequence made by root and chord-type. ;; If the chord does not match a note, just return the note. Else return a longer chord adapted list ending with note-on-ast. ;; Should only be used on absTime (?). ;; .form (strum-3 channel . messages)

(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)) ; a string, maybe with b instead of #
(chord-type-new (cdr root-and-chordtype))) ; a string
(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)))))))) ; Split chord to cons of two strings: chord root and chord-type. ; Typical input "C#M7". Output ( "C#" . "M7").
(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))))))) ; ---------------------------------------------------------------------------------------------------------------
;;; Channel replication, (copying) joining, and selection.
;; Replicate each message of a given channel in message-list. Allocate each replicated message in channel ch-to. ;; Existing messages in ch-to are not affected. ;; It may be useful to use target channels outside the interval [1..16] for temporary purposes. ;; Each message belonging to channel ch-to is immediately replicated. (This is a contrast to the function replicate, which serves as "verse replication"). ;; .form (replicate-channel ch-from ch-to . messages) ;; .parameter ch-from A channel (an integer between 1 and 16) ;; .parameter ch-to A channel (an integer between 1 and 16) ;; .parameter messages A list of midi messages (such as NoteOn messages)

(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))
;; Join (remove) messages in channel-list, and instead assign these too channel ch-to. ;; Existing messages in ch-to are not affected. ;; It is allowed to use source/target channels outside the interval [1..16]. ;; ch-to is allowed to one of the channels in channel-list. ;; .form (join-channels channel-list ch-to . messages) ;; .parameter channel-list A list of channel numbers (an integer list). ;; .paramter ch-to A channel number (between 1 and 16). ;; .parameter messages A list of midi messages (such as NoteOn messages)

(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))
;; Return only those messages from message-list which belong to the given channel. ;; Also include messages without a channel assigned to them. ;; Works in both absTime and deltaTime mode. ;; .form (select-channel channel . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter channel A channel (an integer between 1 and 16)

(define select-channel (xml-in-laml-positional-abstraction 1 0 (lambda (ch cont attr) (select-channel-1 ch cont)))) (define (select-channel-1 c message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if channel (if (= c (as-number (ast-attribute mes-ast 'channel))) mes-ast (midi-null-event (ast-attribute mes-ast 'deltaTime 0))) mes-ast)) mes-ast)) message-list))
;; Select (project) to only those channels of channel-list. ;; Also include messages without a channel assigned to them. ;; .form (select-channels channel-list . messages) ;; .parameter messages A list of midi messages (such as NoteOn messages) ;; .parameter channel-list A list of channel numbers (an integer list).

(define select-channels (xml-in-laml-positional-abstraction 1 0 (lambda (ch-list cont attr) (select-channels-1 ch-list cont 0)))) ; (define (select-channels-1 c-list message-list) ; (map ; (lambda (mes-ast) ; (if (ast? mes-ast) ; (let ((channel (ast-attribute mes-ast 'channel #f))) ; (if channel ; (if (member (as-number (ast-attribute mes-ast 'channel)) c-list) ; mes-ast ; (midi-null-event (ast-attribute mes-ast 'deltaTime 0))) ; #t)) ; mes-ast)) ; message-list))
; between-time is accumulated time between deltaTime events. Only used for deltaTime mode. Rather complicated. ; Future: Split deltaTime and absTime version
(define (select-channels-1 c-list message-list between-time) (cond ((null? message-list) '()) (else (let ((mes-ast (first message-list))) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if channel (if (member (as-number (ast-attribute mes-ast 'channel)) c-list) (cons (if (delta-time-message? mes-ast) (copy-ast-mutate-attributes mes-ast 'deltaTime (+ (time-of-message mes-ast) between-time)) mes-ast) (select-channels-1 c-list (cdr message-list) 0)) (if (delta-time-message? mes-ast) (cons (midi-null-event (+ (time-of-message mes-ast) between-time)) ; remove event from unwanted channel - keep delta time in null event
(select-channels-1 c-list (cdr message-list) 0)) (select-channels-1 c-list (cdr message-list) (+ between-time (time-of-message mes-ast))) ; remove event from unwanted channel
) ) (cons ; system and meta messages
(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)) ; ---------------------------------------------------------------------------------------------------------------
;;; Overall processing utilities.
;; Spilt a given style file in midi pieces, and generate (up to) 15 different ;; midi files of the parts. Place the midi pieces in a subdirectory of output-dir-path. ;; Apply mode (deltaTime or absTime). ;; Only output channels in channel-selection (a list of integers).

(define (split-and-process-style style-file-path output-dir-path mode channel-selection) (let* ((target-dir (file-name-proper (file-name-proper style-file-path))) (midi-ast (midi-file-to-laml-ast style-file-path mode 0 #f)) (midi-header (ast-subtree midi-ast "MidiHeader")) (track-ast (ast-subtree midi-ast "MidiTrack")) (track-events (ast-subtrees track-ast)) (track-meta-divisions (filter meta-division-event? track-events)) ; a list of type 6 meta events
(track-meta-division-names (map ast-text track-meta-divisions)) ; a list of division names, taken from type 6 meta events
(init-stuff (midi-event-ast-subsequence track-events #t (third track-meta-division-names))) ; initial stuff - to be in all sections.
(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)))
;; Spilt each style file in input-dir-path in midi pieces, and generate (up to) 15 different ;; in output-dir-path. A bulk processing variant of split-and-process-style. ;; Apply mode (deltaTime or absTime) and select channels in channel-selection (a list of integers).

(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))) ; ---------------------------------------------------------------------------------------------------------------
;; Substitute sections of the midi message-list with sections from section-list. ;; The midi message-list must be in absTime mode and the replacements must be in deltaTime mode. (This is not checked). ;; The affected sections in the midi message-list are identified by bar. ;; Only messages in the given channels are substituted. ;; The inserted sections are replicated to fill the requested number of bars (but they are never divided). ;; By giving empty insertion section-list, it is possible to remove given sections. ;; .parameter channels A list of channels (a list of integers) ;; .parameter section-list A list of sections to be inserted. Each section is itself a list, which has the form (bar-number number-of-bars replacement-list).

(define substitute-section-by-bar (xml-in-laml-positional-abstraction 2 0 (lambda (channels section-list cont attr) (substitute-section-by-bar-1 channels section-list cont)))) (define (substitute-section-by-bar-1 channels section-list message-list) (let ((units-per-bar (* global-ppqn (first global-signature))) (sorted-section-list (sort-list section-list (lambda (s1 s2) (<= (bar-number-of s1) (bar-number-of s2))))) ) (let* ((section (first sorted-section-list)) (bar (bar-number-of section)) (repl-start-point (* bar units-per-bar)) (number-of-bars (bar-length-of section)) (repl-length (* number-of-bars units-per-bar)) (repl-end-point (+ repl-start-point repl-length)) (replacement-lst (replicate-if-necessary (replacement-list-of section) (* number-of-bars units-per-bar)))) (multi-substitution channels message-list repl-start-point repl-end-point replacement-lst sorted-section-list units-per-bar #f)))) ; Invariant: repl-start-point, repl-end-point and replacement-lst correspond to first element of section-inertion-list
(define (multi-substitution channels ml repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?) (cond ((null? ml) '()) ((and (not replacing?) (not (ast? (car ml)))) (cons (car ml) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?))) ((and (not replacing?) (ast? (car ml))) (let* ((mes (car ml)) (abs-time (as-number (ast-attribute mes 'absTime)))) (if (and (>= abs-time repl-start-point) (< abs-time repl-end-point)) (cons (cons (if (member (as-number (ast-attribute mes 'channel)) channels) (midi-null-event-abs-time (ast-attribute mes 'absTime)) mes) replacement-lst ; delta time events
) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb #t)) (cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?))))) ((and replacing? (not (ast? (car ml)))) (cons (car ml) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?))) ((and replacing? (ast? (car ml))) (let* ((mes (car ml)) (abs-time (as-number (ast-attribute mes 'absTime)))) (if (<= abs-time repl-end-point) (if (and (member (as-number (ast-attribute mes 'channel)) channels) (equal? (ast-element-name mes) "NoteOn")) (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?) ; removing event
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list upb replacing?))) ; outside replacing internal
(if (not (null? (cdr section-insertion-list))) (let* ((next-section (second section-insertion-list)) (next-bar (bar-number-of next-section)) (next-repl-start-point (* next-bar upb)) (next-number-of-bars (bar-length-of next-section)) (next-repl-length (* next-number-of-bars upb)) (next-repl-end-point (+ next-repl-start-point next-repl-length)) (next-replacement-lst (replicate-if-necessary (replacement-list-of next-section) (* next-number-of-bars upb)))) (cons mes (multi-substitution channels (cdr ml) next-repl-start-point next-repl-end-point next-replacement-lst (cdr section-insertion-list) upb #f))) (cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst '() upb #f)))))) (else (laml-error "multi-substitution: Should not happen")))) (define (replicate-if-necessary delta-message-list source-length) (let ((mes-lst-lgt (length-of-delta-time-midi-list delta-message-list))) (replicate-if-necessary-1 delta-message-list source-length mes-lst-lgt))) (define (replicate-if-necessary-1 delta-message-list source-length mes-lst-lgt) (if (<= mes-lst-lgt source-length) (cons delta-message-list (replicate-if-necessary-1 delta-message-list (- source-length mes-lst-lgt) mes-lst-lgt)) '())) (define (length-of-delta-time-midi-list message-list) (length-of-delta-time-midi-list-1 message-list 0)) (define (length-of-delta-time-midi-list-1 message-list res) (cond ((null? message-list) res) ((ast? (car message-list)) (length-of-delta-time-midi-list-1 (cdr message-list) (+ res (as-number (ast-attribute (car message-list) 'deltaTime))))) (else (length-of-delta-time-midi-list-1 (cdr message-list) res)))) ; Selectors of section descriptions
(define bar-number-of (make-selector-function 1 "bar-number-of")) (define bar-length-of (make-selector-function 2 "bar-length-of")) (define replacement-list-of (make-selector-function 3 "replacement-list-of"))