;;;; .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 <a href= "midi-mirror.html">MIDI LAML mirror library</a>. ;;;; .laml-resource true ;;;; .css-prestylesheet compact ;;;; .css-stylesheet argentina ;;;; .css-stylesheet-copying true ;;;; .scheme-source-linking true ;;;; .source-destination-delta
; schemedoc-dependencies "man/midi-mirror.manlsp" "man/midi-laml-processing-lib.manlsp" ; .schemedoc-dependencies "man/midi-mirror.manlsp" ; .source-file-dependencies "midi.scm"
; --------------------------------------------------------------------------------------------------------------- ; 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))))) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id midi-mes-predicates ;;; Midi message predicates.

(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)) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id midi-mes-accessors ;;; Midi message accessor. ;;; Convenient accessor of Midi Asts. Can be used instead of the general purpose accessors of LAML asts.

(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))) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id midi-list-fn ;;; Message List functions. ;;; This section contains function that can be applied on lists of midi messages. ;;; As such, this is the important 'bread and butter' functions of this library. ;;; Most functions come in two flavors. The main function, f, can be applied in this way (f m1 m2 ... mk) on k midi messages m1 ... mk. ;;; The other flavor, always named f-1, is applied as (f-1 (list m1 m2 ... mk)). ;;; In many cases there will be a few positional and required parameters before the first message. ;;; Thus, if there are two such required parameters p1 and p2, the calling forms are (f p1 p2 m1 m2 ... mk) and (f-1 p1 p2 (list m1 m2 ... mk)) respectively. ;;; Notice that the f-1 flavor of the functions are not explicitly documented below. If necessary, consult the Scheme source file to see f-1 via the provided links under 'See also'.

(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) ; Not NoteOn
mes-ast)) ; Not right channel
mes-ast))) ; Not channel message
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) ; just alias
(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)) ; progressing integer for each NoteOn message.
(number-list-count (length (filter (lambda (x) (> x 0)) number-list))) (max-n number-list-count) ; alias
) (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))) ; Generates a predicate which asserts that x is a message ast belonging to a given channel 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)) ; OK

(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.

(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) ; 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))) ))
(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) ) ; earlier: (and ... (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 #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)) ; Is message-list an absTime sequence. ; Please notice that the choice is made from the first message in the 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))))) ; Is message-list an deltaTime sequence. ; Please notice that the choice is made from the first message in the 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))))) ; To general
(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)) ; earlier: (and ... (equal? "NoteOn" (ast-element-name 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))))) ; 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))))) '()))) ; ---------------------------------------------------------------------------------------------------------------

(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)) ; --------------------------------------------------------------------------------------------------------------- ; Pan

(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 '())) ; Tail recursive implementation. ; Only one of subtraction-1 and subtraction-2 is non-zero (positive) at a given time.
(define (delta-merge-two-lists-1 message-list-1 subtraction-1 message-list-2 subtraction-2 res) ; (display-message (length message-list-1) subtraction-1 (length message-list-2) subtraction-2 (length res) (if (not (null? res)) (ast-attribute (car res) 'deltaTime) #f))
(cond ((and (null? message-list-1) ; both message lists empty
(null? message-list-2)) (reverse res)) ((null? message-list-1) ; message-list-1 empty. Adjust deltaTime of first element of message-list-2
(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) ; message-list-2 empty. Adjust deltaTime of first element of message-list-1
(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 ; do proper merging
(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) ; both message lists empty
(null? message-list-2)) (reverse res)) ((null? message-list-1) (append (reverse res) message-list-2)) ; one of the message lists is empty
((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)) ; drop non-AST element
((not (ast? (car message-list-2))) (abs-merge-two-lists-1 message-list-1 (cdr message-list-2) res)) ; ditto
(else ; do proper merging - none of the message lists are empty
(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)) ; for error reporting purposes only.
) (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)))))) ; if n is 4, then (- 2 (log2 n)) is 0. ; Thus (expt 2 (- 2 (log2 n))) is 1. expt is the usual power function - std scheme.
) 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)) ; progressing integer for each NoteOn message. ; 0 for non-NoteOn messages.
) (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) ; a conveninent alias
(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))) ; Return a consequtive numbering of those elements of lst that satisfy the predicate pred. ; Numbering starts with first-val ; Those elements that do not satisfy pred are given the value missing-value in the resulting list. ; .parameter pred A predicate which must be applicable on all elements of lst ; .parameter lst A list of elements ; .parameter first-val An arbitray integer value. Typically 0 or 1. ; .parameter missing-val An arbitrary value which is given for those elements in lst that do not satisfy pred. ; .returns A list of the same length as lst, of consequtive numbering of those elements of lst that satisfy pred.
(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 )))))) ; Assume as a precondition that message-list holds at least one message.
(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" ; initial marker - after first (possible) absTime event
'type "6" (string-append "M" "-" "0" " " "**")) ) (map2 (treat-marking channel) (cdr message-list) (cdr numbering))) ) ) ; marker transformation of mes as number n
(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) )) ; Mapping from notes (non-octave) to marker levels. ; The black (#/b) keys count as the white key to the left of them (instead of errors).
(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) ; C
((= level-number 1) 0) ; C#
((= level-number 2) 1) ; D
((= level-number 3) 1) ; D#
((= level-number 4) 2) ; E
((= level-number 5) 3) ; F
((= level-number 6) 3) ; F#
((= level-number 7) 4) ; G
((= level-number 8) 4) ; G#
((= level-number 9) 5) ; A
((= level-number 10) 5) ; A#
((= level-number 11) 6) ; H
))) (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)))) ; Assume as a precondition that message-list is sorted by absTime.
(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 ; adding to same-time-lst
((and same-mes ; same-time-lst non-empty
(ast? mes) (equal? (ast-attribute same-mes 'absTime) (ast-attribute mes 'absTime)) ; same time
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)) ; transforming non-singleton same-time-lst. Start new same-time-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))) ; ditto - do not start new same-time-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))
;;; .section-id scaling-function-generation ;;; Generation of Scaling Functions. ;;; Scaling functions are used for smooth scaling of attributes such as deltaTime, duration, and velocity. ;;; A scaling function has the simple signature [0,1] -> Real. ;;; The functions in this section generate such scaling functions. ;;; The next section contains concrete scaling functions. ;;; The most useful - and the most versatile - generator is make-scale-function-by-xy-points.

(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) ; x in [0,1]
(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))
;;; .section-id scaling-functions ;;; Examples of Concrete Scaling Functions. ;;; This section contains concrete scaling functions, as generated by the functions in the previous section. ;;; These scaling functions may serve as inspiration when new scaling functions are needed. ;;; As already mentioned above, a scaling function has the simple signature [0,1] -> Real. ;;; We link to SVG illustrations of the graphs of the scaling functions. ;;; When a new scaling function is developed it can be tried out in <a href = "scaling-functions/try.laml"> man/scaling-functions/try.laml </a> ;;; and visualized in <a href="scaling-functions/try.svg"> man/scaling-functions/try.svg </a>. ;;; Consult the Scheme source to access the source form of the scaling function.
(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))) )) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id midi-region-functions ;;; Midi region functions. ;;; This section contains function that establish regions around a list of midi messages.

(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) '()))))) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id sing-midi-abstractions ;;; Single midi message abstractions. ;;; Abstractions that generate a single, or a few midi messages.

(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)) ; 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)

(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 ; Tell that the following data entry messages encoded Pitch Bend
(ControlChange 'deltaTime "0" 'channel channel 'control "101" 'value "0") (ControlChange 'deltaTime "0" 'channel channel 'control "100" 'value "0") ; Sets the pitch bend semi-tone and fine tune adjustments
(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))) ; 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)))
(define (lyrics txt) (Meta 'deltaTime "0" 'type "5" txt)) ; --------------------------------------------------------------------------------------------------------------- ; Chord playing.

(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))))
(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)) ; 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)))))))
(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 ; produces length equidistant values between 0 and 1. actual is used for accumulation, and should initially be 0.
(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)) ; [0,1] -> pitch value
(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 ; produces length equidistant values between 0 and 1. actual is used for accumulation, and should initially be 0.
(lambda (length increment actual) (if (= length 0) '() (cons actual (make-function-domain-values (- length 1) increment (+ actual increment)))))) ) (if last-tempo ; insert a forced tempo event as the last in the list of deltaTimed meta events
(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)) ; notice butlast
(list ; the last forced tempo Meta event
(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)) )))) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id channel-repl-join-sel ;;; Channel replication, (copying) joining, and selection.

(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) ; channel-list is #t
cont (eliminate-midi-null-events (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 (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)) ; 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))
(define eliminate-midi-null-events (xml-in-laml-abstraction (lambda (cont attr) (eliminate-midi-null-events-1 cont 0 0)))) ; acc-delta is accumulated delta-time until a non-null event ; abs-time is the current absolute time.
(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)))) ; acc-delta is accumulated delta-time until a non-null event ; abs-time is the current absolute time.
(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)) ; just drop message
(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)))))))
;;; .section-id bar-transformations ;;; Midi transformations on given bars.

(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)))) ; returns a list of start-point, end-point, and effective replacement-list of section - of replication and bar version. ; holds detailed knowledge of the structure of a section
(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))) ; Invariant: repl-start-point, repl-end-point and replacement-lst correspond to first element of section-insertion-list. ; repl-start-point and repl-end-point is measured in (abs)time units. ; section-advancement-fn is a function that returns a list of start time, end time, and effective replacment (stretched or replicated or...) ; of a given entry of the replacement-list.
(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)) ; insert replacement-list and enter relacing mode
(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 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)))) ; replacing mode - replacement-lst has already been inserted or waiting for it to happen
(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?) ; removing event
(cons mes (multi-substitution channels (cdr ml) repl-start-point repl-end-point replacement-lst section-insertion-list section-advancement-fn replacing?))) ; outside replacing interval - advance replacement-lst
(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)))) ; Invariant: repl-start-point, repl-end-point and keep-pred correspond to first element of section-list
(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)) ; for error reporting purposes only.
) (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)) ; entering thin-out zone
(let ((ch (ast-attribute mes 'channel #f)) ) (if ch ; channel message
(if (member (as-number ch) channels) ; channel in the channel list channels
(if (keep-pred abs-time) ; retain this mes
(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) ; retain this mes
(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?))) ; now again outside thin-out zone
(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))) ; Invariant: repl-start-point, repl-end-point and scaling-fu correspond to first element of section-list ; nss is the number of scaling steps, and i is the actual scaling step (progressing from 1 to nss).
(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)) ; for error reporting purposes only.
) (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)) ; entering scaling zone
(let ((ch (ast-attribute mes 'channel #f)) ) (if ch ; channel message
(let ((scaling-steps (find-number-of-scaling-steps-in ml channels repl-end-point))) (if (member (as-number ch) channels) ; channel in the channel list 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)))) ; now again outside thin-out zone
(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)) ; Find the number of NoteOn messages in channels before time-limit
(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)))) ; Invariant: repl-start-point, repl-end-point and replacement-lst correspond to first element of section-insertion-list
(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)) ; insert the pre-envelope here
(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?)) ) ; outside enveloping interval
(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")))) ; Selectors of section descriptions - kind of overloaded.
(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")) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id ;;; Midi transformations on sections. ;;; The functions in this section are similar to the functions in the previous sections. ;;; The main difference is that the functions in this section work on sections, identified ;;; by absolute time ticks, not bar numbers. The function time-of-marker allows for identification ;;; of sections by markers.

(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)))) ; Used by substitute-section-by-time-1 to access the message-list on which the substitution is being performed
(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)))) ; Returns a list of start-point, end-point, and effective replacement-list of section - of stretching and given time version. ; holds detailed knowledge of the structure of a section
(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))))))
;;; .section-id guitar-beats ;;; Generation of guitar beats. ;;; The function beat generates (typically, but not necessarily) guitar beats. ;;; The instrument definition is outside the context of the beat function. ;;; The generated beats are affected by a large number of parameters. ;;; The function duration-to-next is a function which makes it possible to express the duration contextually. ;;; LAML technically, duration-to-next, is an attribute-returning delayed procedural content item function.

(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) ; First - forced zero deltaTime
(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 ; Rest
(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)) ) ; thus including deltaTime of stop-ast. Maybe not correct?
(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
(events-after-note-ast (if (not (null? events-from-note-ast)) (cdr events-from-note-ast) '())) ; tail of
(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))))) ; ---------------------------------------------------------------------------------------------------------------------------------------------------- ; Mega voice maps
; The functions in this section are used to encapsulate the details of a mega voice map. ; A mega voice map is a list of mega voice entries. ; A mega voice entry is a list of ; (mega-voice-section-name min-note max-note min-velocity max-melocity) ; A mega voice function, defined relative to a mega voice map, maps ; note-name' section-name velocity' ; to ; note-number velocity ; where note-name' is an extended note name, section-name is a name of mega voice section, and velocity' is a normal velocity in the interval [1 .. 127]. ; note-name' examples: ; C2 mapped by note-name-to-note-number ; c2 mapped such that c0 is the minimum note in its section. ; The given velocity is mapped to the interval which is characteristic of the mega voice section.

(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))))) ; The interval of the lower case letters
(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)))) ; Scale velocity and displace it in the interval from min-vel to max-vel.
(define (mv-scale-velocity velocity min-vel max-vel) (to-int (+ min-vel (* (/ (- max-vel min-vel) 127) (- velocity 1))))) ; Displace rel-note-number to the interval from min-note to max-note.
(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))) ; ----------------------------------------------------------------------------------------------------------------------------------------------------
;;; .section-id style-splitting ;;; Style Splitting. The functions in this section split a style file in its midi path. ;;; In this context, a style file is a Yamaha Keyboard style file which control the automatic accompaniment. ;;; The first functions are older versions. The refined functions are more advanced. ;;; The refined functions are able to extract meta information about the midi contents of the pieces. ;;; Some levels of bulk processing is provided.

(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")) ; format 0 - thus a single track
(track-events (ast-subtrees track-ast)) ; all midi events in this track
(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)))
(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))) ; last #f: produce midi format 0 AST
(split-and-process-style-one-channel-given-ast-refined #f style-file-path midi-ast output-dir-path mode channel))) ; Doing the real work, given the ast. ; If meta-file-path is not #f, store meta information in this path. ; Factored out of efficiency reasons when repeating the splitting many times for the same style.
(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)) ; Create last directory in output-dir-path if necessary
(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")) ; format 0 - thus a single track
(track-events (ast-subtrees track-ast)) ; all midi events in this track
(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 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 ; There are relevant NoteOn eventsin the selectec channels
(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)) ; just without resetting global-meta-info-list
(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))) ; last #f: produce midi format 0 AST
(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)) ; just without resetting global-meta-info-list
(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) ) ; just without resetting global-meta-info-list
(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)))) ; only directories, full paths - after filtering
(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 (fix-it) ; (let* ((mel (file-read "c:/users/kurt/Media/Tyros/Styles/style-meta-info.lsp")) ; (nl (number-interval 1 (length mel)))) ; (file-write ; (map (lambda (e n) ; (cons n e)) ; mel nl) ; "c:/users/kurt/Media/Tyros/Styles/style-meta-info-1.lsp")))
; --------------------------------------------------------------------------------------------------------------- ; Meta data of style pieces.
; Return a list of meta information of a given channel or a given section of a style file. ; channel is an integer
(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))) ; #f -> nil
(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 ; in pulses
(accumulate-right + 0 (map (lambda (ast) (as-number (ast-attribute ast 'deltaTime))) (cdr ; do not count first deltaTime
(filter (lambda (x) (ast? x)) body-events-for-selected-channel))))) ; (bar-beat-clock ; a list of 3 numbers ; (if (and ppqn time-signature last-abs-time) (bar-beat-clock length-of-body ppqn (first time-signature) (second time-signature)) #f))
) (list (nil-if-false time-signature) (ceiling (/ length-of-body ppqn)) ; approximate number of quater notes. Rounded up.
number-of-notes (nil-if-false instrument-tuple) (nil-if-false instrument-name) (nil-if-false section-name) channel ppqn ; in pulses
length-of-body ; in pulses
(nil-if-false style-name) (nil-if-false (truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/" style-file-path)) ; path to style file - the ultimate source of this inforamation
(nil-if-false (truncate-this-string "c:/users/kurt/Media/Tyros/Styles/midi/MIDI-PIECES/All-pieces/" target-file-path)) ; path the midi file - the midi file with the essential result of this meta information
number-of-different-notes program-control-changes ) ) ) (define (count-number-of-different-notes midi-even-list) (let ((occ-count (make-vector 128 0))) ; 128 elements, initial value 0 ; register number of occurrences in vector
(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))))) ; increment
) midi-even-list) (accumulate-right + 0 (map (lambda (note) (if (> (vector-ref occ-count note) 0) 1 0)) (number-interval 0 127))))) ; Return a list of the number of Program change events, Expression controller events, and PitchBend controller events. ; A list of three integer numbers.
(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)))) ; Find the msb, lsb, prog-number for a selected channel in a list of midi event ASTs that ; contains the releveant ControlChange and ProgramChange informations. ; Returns a list of three integers, of #f.
(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) )) ; The list where we - internally - accumulates meta info about midi pieces.
(define global-meta-info-list '()) ; Add meta-info (a list) to the contents of meta-file-path (a full path to a file with a 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)) ; For each 1000 new elements in global-meta-info-list, save it on meta-file-path.
(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) ; Create file in existing directory if necessary
(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) ) ; ----------------------------------------------------------------------------- ; Utility procedures
(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))) ; when applied to remembered pieces: Add (list-ref me 14)
(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)))) ; End utility procedures ; -----------------------------------------------------------------------------
; --------------------------------------------------------------------------------------------------------------- ; Abs time to delta time conversion and vice versa. ; Does only affect the deltaTime and absTime attributes. ; All other attributes are left unchanged.
(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)))) ; ---------------------------------------------------------------------------------------------------------------
;;; .section-id aux-functions ;;; Auxiliary functions. ;;; Miscellaneous function that are not naturally contained in the categories from above.

(define (pitch-bend-scale factor) (let ((mid-value 8192)) (lambda (value) (+ (* (- value mid-value) factor) mid-value)))) ; Copy a list of midi ASTs. ; Useful if the same list of Midi ASTs are used several places in a song. ; The out list structure, the AST list structure and the attribute property list structures are copied. ; Strings are not copied. ; Not necessary any more (as of May 15, 2008).
(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))) ; --------------------------------------------------------------------------------------------------------------- ; Image file names

(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) ","))) ; ---------------------------------------------------------------------------------------------------------------