Source file

;;;; .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 (NoteOnCh? channels) (lambda (x) (if (NoteOn? x) (let ((ch (ast-attribute x 'channel #f))) (if ch (member (as-number ch) channels) #f)) #f)))

(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 (ProgramChange? x . optional-parameter-list) (let ((channel (optional-parameter 1 optional-parameter-list #t))) (and (ast? x) (cond ((and (boolean? channel) channel) (equal? (ast-element-name x) "ProgramChange")) ((and (number? channel) (>= channel 1) (<= channel 16)) (and (equal? (ast-element-name x) "ProgramChange") (= channel (as-number (ast-attribute x 'channel))))) ((and (string? channel) (>= (as-number channel) 1) (<= (as-number channel) 16)) (and (equal? (ast-element-name x) "ProgramChange") (equal? channel (as-number (ast-attribute x 'channel))))) (else #f)))))

(define (SysEx? x . optional-parameter-list) (let ((sys-ex-hex-string (optional-parameter 1 optional-parameter-list #f))) (if (ast? x) (cond ((not sys-ex-hex-string) (equal? (ast-element-name x) "SysEx")) (sys-ex-hex-string (and (equal? (ast-element-name x) "SysEx") (equal? (ast-text x) sys-ex-hex-string))) (else #f)) #f)))

(define (ControlChange? x . optional-parameter-list) (let* ((control (optional-parameter 1 optional-parameter-list #t)) (channel (optional-parameter 2 optional-parameter-list #t)) (control-nr (if (and (boolean? control) control) #t (as-number control))) (channel-nr (if (and (boolean? channel) channel) #t (as-number channel)))) (and (ast? x) (cond ((and (boolean? control) control (boolean? channel) channel) (equal? (ast-element-name x) "ControlChange")) ((and (boolean? control) control (number? channel-nr)) (and (equal? (ast-element-name x) "ControlChange") (= (as-number (ast-attribute x 'channel)) channel-nr))) ((and (number? control-nr) (boolean? channel) channel) (and (equal? (ast-element-name x) "ControlChange") (= (as-number (ast-attribute x 'control)) control-nr))) ((and (number? control-nr) (number? channel-nr)) (and (equal? (ast-element-name x) "ControlChange") (= (as-number (ast-attribute x 'control)) control-nr) (= (as-number (ast-attribute x 'channel)) channel-nr))) (else #f)))))

(define (PitchBendChange? x . optional-parameter-list) (let* ((channel (optional-parameter 1 optional-parameter-list #f))) (if channel (and (ast? x) (equal? (ast-element-name x) "PitchBendChange") (= (as-number channel) (as-number (ast-attribute x 'channel -1)))) ; -1: forces a number out of ast-attribute which compare with a legal channel always will give a false result.
(and (ast? x) (equal? (ast-element-name x) "PitchBendChange")))))

(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 control type))) (as-number attr-val) attr-val)) #f))) ; ---------------------------------------------------------------------------------------------------------------

;;; .section-id midi-list-fn-gp ;;; Message List functions - General Purpose. ;;; This section and the following sections contain function that can be applied on lists of midi messages. ;;; The functions in this section are general purpose. ;;; 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 arbitrary many 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 delta-merge (xml-in-laml-positional-abstraction 1 0 (lambda (other-message-list contents attributes) (delta-merge-two-lists contents other-message-list))))

(define (delta-merge-two-lists message-list-1 message-list-2) (delta-merge-two-lists-1 message-list-1 0 message-list-2 0 '()))

(define (delta-merge-lists . list-of-message-lists) (if (null? list-of-message-lists) '() (let ((first-list (first list-of-message-lists)) (rest-list-of-message-lists (cdr list-of-message-lists))) (delta-merge-two-lists first-list (apply delta-merge-lists rest-list-of-message-lists))))) ; 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 abs-time-reverse (xml-in-laml-positional-abstraction 0 0 (lambda (contents attributes) (abs-time-reverse-1 contents)))) (define (abs-time-reverse-1 messages) (let ((rev-messages (reverse messages))) (map (lambda (m mr) (copy-ast-mutate-attributes m 'absTime (midi 'absTime mr))) messages rev-messages)))

(define delta-abs-merge (xml-in-laml-positional-abstraction 1 0 (lambda (delta-message-list contents attributes) (delta-abs-merge-two-lists delta-message-list contents)))) (define (delta-abs-merge-two-lists delta-message-list abs-message-list) (let* ((first-abs-time (as-number (ast-attribute (first abs-message-list) 'absTime))) (delta-to-abs-message-list (delta-time-list-to-abs-time-list delta-message-list first-abs-time))) (abs-merge-two-lists delta-to-abs-message-list abs-message-list))) (define (delta-time-list-to-abs-time-list delta-message-list first-abs-time) (if (null? delta-message-list) '() (let* ((first-delta-mes (first delta-message-list)) (next-abs-time (+ first-abs-time (as-number (ast-attribute first-delta-mes 'deltaTime))))) (cons (single-message-ast-delta-to-abs-time first-delta-mes next-abs-time) (delta-time-list-to-abs-time-list (cdr delta-message-list) next-abs-time)))))

(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 filter-messages-keep-residual-and-accumulate! (xml-in-laml-positional-abstraction 3 0 (lambda (pred-fn abs-target-file-path abs-merge-file-path contents attributes) (filter-messages-keep-residual-and-accumulate-1! pred-fn abs-target-file-path abs-merge-file-path contents)))) (define (filter-messages-keep-residual-and-accumulate-1! pred-fn abs-target-file-path abs-merge-file-path message-list) (filter-messages-keep-residual-and-accumulate-2 pred-fn abs-target-file-path abs-merge-file-path message-list '() '())) (define (filter-messages-keep-residual-and-accumulate-2 pred-fn abs-target-file-path abs-merge-file-path message-list result-list residual-list) (cond ((null? message-list) (let ((merge-list (if (and abs-merge-file-path (file-exists? abs-merge-file-path)) (file-read abs-merge-file-path) '()))) (file-write (append merge-list (map compact-midi-laml-ast (reverse residual-list))) abs-target-file-path) ; save reversed residual-list
(reverse result-list) ; return list of messages on which the predicate holds
) ) ((and (ast? (car message-list)) (pred-fn (car message-list))) (filter-messages-keep-residual-and-accumulate-2 pred-fn abs-target-file-path abs-merge-file-path (cdr message-list) (cons (car message-list) result-list) residual-list)) ((and (ast? (car message-list)) (not (pred-fn (car message-list)))) (filter-messages-keep-residual-and-accumulate-2 pred-fn abs-target-file-path abs-merge-file-path (cdr message-list) result-list (cons (car message-list) residual-list))) (else (filter-messages-keep-residual-and-accumulate-2 pred-fn abs-target-file-path abs-merge-file-path (cdr message-list) result-list residual-list))))

(define filter-messages-keep-residual-and-reprocess! (xml-in-laml-positional-abstraction 3 0 (lambda (pred-fn abs-target-file-path abs-merge-file-path contents attributes) (filter-messages-keep-residual-and-reprocess-1! pred-fn abs-target-file-path abs-merge-file-path contents)))) (define (filter-messages-keep-residual-and-reprocess-1! pred-fn abs-target-file-path abs-merge-file-path message-list) (let ((merge-list (if (and abs-merge-file-path (file-exists? abs-merge-file-path)) (map uncompact-midi-laml-entry (file-read abs-merge-file-path)) '()))) (filter-messages-keep-residual-and-reprocess-2 pred-fn abs-target-file-path (abs-merge-two-lists message-list merge-list) '() '()))) (define (filter-messages-keep-residual-and-reprocess-2 pred-fn abs-target-file-path message-list result-list residual-list) (cond ((null? message-list) (file-write (map compact-midi-laml-ast (reverse residual-list)) abs-target-file-path) ; save reversed residual-list
(reverse result-list) ; return list of messages on which the predicate holds
) ((and (ast? (car message-list)) (pred-fn (car message-list))) (filter-messages-keep-residual-and-reprocess-2 pred-fn abs-target-file-path (cdr message-list) (cons (car message-list) result-list) residual-list)) ((and (ast? (car message-list)) (not (pred-fn (car message-list)))) (filter-messages-keep-residual-and-reprocess-2 pred-fn abs-target-file-path (cdr message-list) result-list (cons (car message-list) residual-list))) (else (filter-messages-keep-residual-and-reprocess-2 pred-fn abs-target-file-path (cdr message-list) result-list residual-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) (scale-attribute-by-factor-1 ast-predicate attribute-name factor contents)))) (define (scale-attribute-by-factor-1 ast-predicate attribute-name factor messages) (transform-attribute-1 ast-predicate attribute-name (lambda (value) (* factor value)) messages))

(define randomize-attribute (xml-in-laml-positional-abstraction 7 0 (lambda (pred attribute-name channel-list lower-number upper-number min-attribute-value max-attribute-value cont attr) (randomize-attribute-1 pred attribute-name channel-list lower-number upper-number min-attribute-value max-attribute-value cont)))) (define (randomize-attribute-1 pred attribute-name channel-list lower-number upper-number min-attribute-value max-attribute-value message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (pred mes-ast)) (let ((channel (ast-attribute mes-ast 'channel #f))) (if (and channel (memv (as-number channel) channel-list)) (let ((attr-value (as-number (ast-attribute mes-ast attribute-name #f))) (random-number (random-real-number-between lower-number upper-number)) ) (if attr-value (copy-ast-mutate-attributes mes-ast attribute-name (if (and min-attribute-value max-attribute-value) (between min-attribute-value max-attribute-value (to-int (* random-number attr-value))) (to-int (* random-number attr-value)))) mes-ast)) mes-ast)) mes-ast)) message-list)) (define random-real-number-between (let ((seed (- (power 2 31) 1))) (random-seed seed) (lambda (a b) (let* ((lgt (- b a)) (r (exact->inexact (/ (random seed) seed))) ; between 0 and 1
(rl (* r lgt)) (rla (+ a rl))) rla)))) ; 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))))) (define (assert-abs-time messages) (if (not (abs-time-sequence? messages)) (laml-error "In this context, you must use absTime sequences."))) (define (assert-delta-time messages) (if (not (delta-time-sequence? messages)) (laml-error "In this context, you must use deltaTime sequences.")))

(define replicate (xml-in-laml-positional-abstraction 1 0 (lambda (n cont attr) (replicate-1 n cont)))) (define (replicate-1 n message-list) (cond ((= n 0) '()) (else (append message-list (replicate-1 (- n 1) message-list)))))

(define 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 convenient 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)))

(define scale-attribute-of-channel (xml-in-laml-positional-abstraction 3 0 (lambda (ch attribute-name scaling-function contents attributes) (scale-attribute-of-channel-1 ch attribute-name scaling-function contents )))) (define (scale-attribute-of-channel-1 ch 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)) (= ch (as-number (ast-attribute x 'channel))))) contents)) (number-of-noteon-messages (length noteon-contents)) (number-list (consequtive-numbering-by-predicate ; progressing integer for each NoteOn message.
(lambda (x) (and (NoteOn? x) (= ch (as-number (ast-attribute x 'channel))))) contents 1 0)) ) (map (lambda (mes-ast i) (if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast))) (let ((attr-value (ast-attribute mes-ast attr-name #f))) (if (and attr-value (= ch (as-number (ast-attribute mes-ast 'channel)))) (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)))

(define scale-attribute-by-predicate (xml-in-laml-positional-abstraction 4 0 (lambda (ch-list attribute-name scaling-function note-value-predicate contents attributes) (let ((domaining (defaulted-get-prop 'domaining attributes 'relative-position))) (scale-attribute-by-predicate-1 ch-list attribute-name scaling-function note-value-predicate (as-symbol domaining) (filter ast? contents)))))) (define (scale-attribute-by-predicate-1 ch-list attribute-name f note-value-predicate domaining contents) (if (and (delta-time-sequence? contents) (eq? domaining 'abs-time-domain-scaling)) (laml-error "abs-time-domain-scaling can only be sued in pure absTime mode")) (let* ((attr-name (as-symbol attribute-name)) (noteon-contents (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)) (note-value-predicate (as-number (ast-attribute x 'note))))) contents)) (number-of-noteon-messages (length noteon-contents)) (number-list (consequtive-numbering-by-predicate (lambda (x) (NoteOn? x) (note-value-predicate (as-number (ast-attribute x 'note)))) contents 1 0)) ; progressing integer for each NoteOn message which satisfy the predicate. ; 0 for non-NoteOn messages etc.
(t-start (if (eq? domaining 'abs-time-domain-scaling) (as-number (ast-attribute (first contents) 'absTime)) 0)) ; dummy
(t-end (if (eq? domaining 'abs-time-domain-scaling) (as-number (ast-attribute (last contents) 'absTime)) 0)) ) (map (lambda (mes-ast i) (if (and (ast? mes-ast) (equal? "NoteOn" (ast-element-name mes-ast)) (note-value-predicate (as-number (ast-attribute mes-ast 'note)))) ; implies that i is not zero
(let ((attr-value (ast-attribute mes-ast attr-name #f))) (if (and attr-value (member (as-number (ast-attribute mes-ast 'channel)) ch-list)) (let* ((attr-val-number (as-number attr-value)) (max-i number-of-noteon-messages) ; a convenient alias
(scaled-attr-value (cond ((eq? domaining 'abs-time-domain-scaling) (let ((t-cur (as-number (ast-attribute mes-ast 'absTime)))) (* attr-val-number (f (/ (- t-cur t-start) (- t-end t-start))))) ) ((eq? domaining 'relative-position) (* attr-val-number (f (/ i max-i))) ) (else (laml-error "scale-attribute-by-predicate-1: Unknown domaining" domaining)) )) ) (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 enforce-attribute-value (xml-in-laml-positional-abstraction 3 0 (lambda (form-name attribute-name attribute-value contents attributes) (enforce-attribute-value-1 form-name attribute-name attribute-value contents)))) (define (enforce-attribute-value-1 form-name attribute-name attribute-value message-list) (map (lambda (x) (if (and (ast? x) (equal? (ast-element-name x) (as-string form-name))) (copy-ast-mutate-attributes x (as-symbol attribute-name) (as-string attribute-value)) x) ) message-list) )

(define insert-leading-and-trailing-beats (xml-in-laml-positional-abstraction 1 0 (lambda (ch contents attributes) (let ((ppqn (defaulted-get-prop 'ppqn attributes #f)) (n (defaulted-get-prop 'n attributes #f)) (m (defaulted-get-prop 'm attributes #f))) (insert-leading-and-trailing-beats-1 ch (if ppqn (as-number ppqn) 1920) (if n (as-number n) 4) (if m (as-number n) 4) contents))))) ; ppqn: typically 1920 - when recorded at Tyros. ; n:m: time signature. Typically n = 4 and m = 4. m is not used.
(define (insert-leading-and-trailing-beats-1 ch ppqn n m messages) (let* ((messages-only-ast (filter ast? messages)) (end-of-track-message (last messages-only-ast)) (before-end-of-track-messages (butlast messages-only-ast))) (if (not (and (equal? (ast-element-name end-of-track-message) "Meta") (= 47 (midi 'type end-of-track-message)))) (laml-error "insert-leading-and-trailing-beats-1 ch messages: Last message is not a Meta end of track message.")) (let* ((first-mes-abs-time (midi 'absTime (first before-end-of-track-messages))) (end-of-track-time (midi 'absTime end-of-track-message)) (last-bar (quotient end-of-track-time (* ppqn n))) (trailing-insert-abs-time (* (+ last-bar 1) (* ppqn n))) (end-of-track-abs-time (+ trailing-insert-abs-time (* ppqn n 2)))) (append (map (lambda (at) (NoteOn 'absTime at 'channel ch 'note "37" 'velocity "127" 'duration "100") ) (list first-mes-abs-time (+ first-mes-abs-time (* 1 ppqn)) (+ first-mes-abs-time (* 2 ppqn)) (+ first-mes-abs-time (* 3 ppqn)))) (time-displace (* 2 n ppqn) before-end-of-track-messages) (map (lambda (at) (NoteOn 'absTime at 'channel ch 'note "37" 'velocity "127" 'duration "100") ) (list trailing-insert-abs-time (+ trailing-insert-abs-time (* 1 ppqn)) (+ trailing-insert-abs-time (* 2 ppqn)) (+ trailing-insert-abs-time (* 3 ppqn)))) (list (Meta 'absTime end-of-track-abs-time 'info "End of track" 'type "47" ""))))))

(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 marker-channel (xml-in-laml-positional-abstraction 2 0 (lambda (channel marker-letter contents attributes) (if (ast? marker-letter) (laml-error "Be sure to supply maker-letter as second argument to marker-channel")) ; backward compatibility error message
(eliminate-program-change-1 channel (eliminate-control-change-1 channel #t (marker-channel-1 channel marker-letter contents )))))) ; Assume as a precondition that message-list holds at least one message.
(define (marker-channel-1 channel marker-letter 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 marker-letter) (car message-list) (car numbering)) (Meta 'deltaTime "0" ; initial marker - after first (possible) absTime event
'type "6" (string-append marker-letter "-" "0" " " "**")) ) (map2 (treat-marking channel marker-letter) (cdr message-list) (cdr numbering))) ) ) ; marker transformation of mes as number n
(define (treat-marking channel marker-letter) (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 marker-letter "-" (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 marker-silence (xml-in-laml-positional-abstraction 2 0 (lambda (silence-ticks marker-letter contents attributes) (marker-silence-1 silence-ticks marker-letter contents )))) (define (marker-silence-1 silence-ticks marker-letter messages) (let ((next-marker-number 0) (first-mes (car messages)) (in-between-messages (butlast (cdr messages))) (last-mes (last (cdr messages))) ; expected to be end of track message
) (assert-abs-time messages) ; It causes weird problems if we insert a marker after the end of track message. Therefore ; last-mes is taken out before map-bites is called.
(append (list (Meta 'absTime (time-of-message first-mes) 'type "6" (string-append marker-letter "-" "0" " "))) (map-n-bites ; ealier: (take-message-bite-until-silence silence-ticks)
(bite-while-element-with-accumulation (lambda (mes sound-frontier-time) (not (and (> (midi 'absTime mes) sound-frontier-time) (> (- (midi 'absTime mes) sound-frontier-time) silence-ticks)))) (lambda (sound-frontier-time NoteOnMes) (max sound-frontier-time (+ (midi 'absTime NoteOnMes) (midi 'duration NoteOnMes)))) 0 (lambda (x) (not (NoteOn? x)))) (lambda (midi-messages-bite next-marker-number) (let ((last-mes (last midi-messages-bite))) (append midi-messages-bite (list (Meta 'absTime (time-of-message last-mes) 'type "6" (string-append marker-letter "-" (as-string next-marker-number) " ")))))) in-between-messages) (list last-mes)))) ; NOT USED. ; A bite function. Takes a bite until an integer of silence of at least silence-ticks has been identified. ; Relies on pure absTime in the list of messages.
(define (take-message-bite-until-silence silence-ticks) (lambda (messages . rest) (take-message-bite-until-silence-1 silence-ticks messages #f '()))) ; if sound-frontier-time is boolean #f, initiate the biting.
(define (take-message-bite-until-silence-1 silence-ticks messages sound-frontier-time res-messages) (if (null? messages) (reverse res-messages) (let ((mes (car messages))) (cond ((and (boolean? sound-frontier-time) (not sound-frontier-time) (NoteOn? mes)) ; get started
(take-message-bite-until-silence-1 silence-ticks (cdr messages) (+ (midi 'absTime mes) (midi 'duration mes)) (cons mes res-messages))) ((and (boolean? sound-frontier-time) (not sound-frontier-time) (not (NoteOn? mes))) ; get started
(take-message-bite-until-silence-1 silence-ticks (cdr messages) #f (cons mes res-messages))) ((and (NoteOn? mes) (> (midi 'absTime mes) sound-frontier-time) (> (- (midi 'absTime mes) sound-frontier-time) silence-ticks)) ; large enough gap found
(reverse res-messages)) ((NoteOn? mes) (take-message-bite-until-silence-1 silence-ticks (cdr messages) ; adjust sound-frontier-time
(max sound-frontier-time (+ (midi 'absTime mes) (midi 'duration mes))) (cons mes res-messages))) (else ; iterate
(take-message-bite-until-silence-1 silence-ticks (cdr messages) sound-frontier-time (cons mes res-messages)))))))

(define markup-chords (xml-in-laml-positional-abstraction 2 0 (lambda (channel marker-letter contents attributes) (markup-chords-1 channel marker-letter contents)))) (define (markup-chords-1 channel marker-letter messages) (let ((first-mes (car messages)) (in-between-messages (butlast (cdr messages))) (last-mes (last (cdr messages))) ; expected to be end of track message
(normalized-note-val (lambda (noteon-mes) (remainder (midi 'note noteon-mes) 12))) ) (assert-abs-time messages) (append (list (Meta 'absTime (time-of-message first-mes) 'type "6" (string-append marker-letter "-" "0" " "))) (step-and-map-n-bites (bite-while-element-with-accumulation (lambda (mes prev-chords) (let ((chord-candidate-list (append prev-chords (list (normalized-note-val mes))))) (if (< (length chord-candidate-list) 3) #t (chord-match? (normalize-chord-list chord-candidate-list))))) (lambda (chord-candidate-list mes) (append chord-candidate-list (list (normalized-note-val mes)))) '() (lambda (x) (not (and (NoteOn? x) (= channel (midi 'channel x))))) ) (lambda (bite) (let ((chord-list (map (lambda (no) (normalized-note-val no)) (filter (lambda (x) (and (NoteOn? x) (= channel (midi 'channel x)))) bite)))) (if (chord-match? (normalize-chord-list chord-list)) (length bite) -1))) (lambda (bite i) (let ((first-mes (first bite)) (last-mes (last bite)) (normalized-chord-list (normalize-chord-list (map (lambda (no) (normalized-note-val no)) (filter (lambda (x) (and (NoteOn? x) (= channel (midi 'channel x)))) bite))))) (append (list (Meta 'absTime (time-of-message first-mes) 'type "6" (string-append marker-letter "-" (as-string (- (* i 2) 1)) " " "#" (as-string channel) ": " "Start of chord: " (chord-name-of-normalized-note-list normalized-chord-list)))) bite (list (Meta 'absTime (time-of-message last-mes) 'type "6" (string-append marker-letter "-" (as-string (* i 2)) " " "#" (as-string channel) ": " "End of chord")))))) in-between-messages ) (list last-mes))))

(define map-chords (xml-in-laml-positional-abstraction 3 0 (lambda (channel max-time-diff f contents attributes) (map-chords-1 channel max-time-diff f contents)))) (define (map-chords-1 channel max-time-diff f messages) (let ((normalized-note-val (lambda (noteon-mes) (remainder (midi 'note noteon-mes) 12))) (relevant-message? (lambda (x) (and (NoteOn? x) (= channel (midi 'channel x))))) ) (assert-abs-time messages) (step-and-map-n-bites (bite-while-element-with-accumulation ; accumulates time of previous absTime note
(lambda (mes prev-time) ; keep going while notes are dense
(if prev-time (if (< (- (time-of-message mes) prev-time) max-time-diff) #t #f) #t)) (lambda (time mes) (time-of-message mes)) #f (negate relevant-message?) ) (lambda (bite) (let ((chord-list (map (lambda (no) (normalized-note-val no)) (filter relevant-message? bite)))) (if (chord-match? (normalize-chord-list chord-list)) (length bite) -1))) (lambda (bite n) (let ((normalized-chord-list (normalize-chord-list (map (lambda (no) (normalized-note-val no)) (filter relevant-message? bite))))) (f bite channel n normalized-chord-list (chord-name-of-normalized-note-list normalized-chord-list)))) messages))) (define (map-chords-1-old channel f messages) (let ((normalized-note-val (lambda (noteon-mes) (remainder (midi 'note noteon-mes) 12))) (relevant-message? (lambda (x) (and (NoteOn? x) (= channel (midi 'channel x))))) ) (assert-abs-time messages) (step-and-map-n-bites (bite-while-element-with-accumulation (lambda (mes prev-chords) (let ((chord-candidate-list (append prev-chords (list (normalized-note-val mes))))) (if (< (length chord-candidate-list) 3) #t (chord-match? (normalize-chord-list chord-candidate-list))))) (lambda (chord-candidate-list mes) (append chord-candidate-list (list (normalized-note-val mes)))) '() (negate relevant-message?) ) (lambda (bite) (let ((chord-list (map (lambda (no) (normalized-note-val no)) (filter relevant-message? bite)))) (if (chord-match? (normalize-chord-list chord-list)) (length bite) -1))) (lambda (bite n) (let ((normalized-chord-list (normalize-chord-list (map (lambda (no) (normalized-note-val no)) (filter relevant-message? bite))))) (f bite channel n normalized-chord-list (chord-name-of-normalized-note-list normalized-chord-list)))) messages)))

(define (chord-marker bite channel n chord-formula chord-name) (let ((first-mes (first bite)) (last-mes (last bite)) (marker-letter "C") ) (append (list (midi-marker-abs-time (+ (time-of-message first-mes) 1) (string-append "#" (as-string channel) ": " "Start of chord: " chord-name) (- (* n 2) 1) marker-letter) ) bite (list (midi-marker-abs-time (- (time-of-message last-mes) 1) (string-append "#" (as-string channel) ": " "End of chord") (* n 2) marker-letter)))))

(define map-sustain-intervals (xml-in-laml-positional-abstraction 2 0 (lambda (channel f contents attributes) (map-sustain-intervals-1 channel f contents)))) (define (map-sustain-intervals-1 channel f messages) (let ((cc-val-comparator (make-comparator (lambda (cc1 cc2) (< (midi 'value cc1) (midi 'value cc2))) (lambda (cc1 cc2) (> (midi 'value cc1) (midi 'value cc2))))) (noice-fn (lambda (x) (not (ControlChange? x 64 channel))))) (map-n-bites (bite-while-monotone cc-val-comparator noice-fn) (lambda (messages bite-number) ; earlier, in a simpler version, just f. It is very helpful for f to get direct acccess to whether the bite is increasing, decreasing or constant.
(f messages bite-number (cond ((increasing-list-with-noice? cc-val-comparator noice-fn messages) 'increasing) ((decreasing-list-with-noice? cc-val-comparator noice-fn messages) 'decreasing) (else 'constant)))) messages)))

(define map-bars (xml-in-laml-positional-abstraction 3 0 (lambda (f ppqn time-signature contents attributes) (map-bars-1 f ppqn time-signature contents)))) (define (map-bars-1 f ppqn time-signature messages) (let* ((num (first time-signature)) (denom (second time-signature)) (pulses-per-whole-note (* 4 ppqn)) (ticks-per-bar (to-int (* pulses-per-whole-note (/ (exact->inexact num) (exact->inexact denom))))) ) (if (null? messages) '() (let* ((first-mes (car messages)) (delta-time? (delta-time-message? first-mes)) (abs-time? (abs-time-message? first-mes))) (cond (abs-time? (map-bites (lambda (lst . rest) (let* ((start-time-first-mes (midi 'absTime (first lst))) (bar-number (quotient start-time-first-mes ticks-per-bar)) ; zero based
(bar-start-time (* bar-number ticks-per-bar)) (bar-end-time (+ bar-start-time ticks-per-bar)) ) ((bite-while-element (lambda (mes) (< (midi 'absTime mes) bar-end-time)) 'sentinel "first") lst))) (lambda (bite) (let* ((start-time-first-mes (midi 'absTime (first bite))) ; As a service - recalculate these informations in the bite transformation function
(bar-number (quotient start-time-first-mes ticks-per-bar)) (bar-start-time (* bar-number ticks-per-bar)) (bar-end-time (+ bar-start-time ticks-per-bar)) ) (f bite (+ bar-number 1) bar-start-time (- bar-end-time 1)))) messages) ) (delta-time? ; Assume that messages (the parameter to map-bars-1) start at absolute time 0 ; NOT CORRECT YET!!!! ; Der sker en tidsforskydning når der starter en ny bite. Dette ødelægger gradvist timingen af bars fuldstændigt!!!!
(map-n-bites (lambda (lst n) ; n is one-based
(let* ((bar-start-time (* (- n 1) ticks-per-bar)) (bar-end-time (+ bar-start-time ticks-per-bar)) ) ((bite-while-element-with-accumulation (lambda (mes absTime) (< (+ absTime (midi 'deltaTime mes)) bar-end-time)) (lambda (absTime mes) (+ absTime (midi 'deltaTime mes))) bar-start-time ; Dette er ikke et korrekt start punkt for næste bid...
) lst))) (lambda (bite n) (let* ((bar-number (- n 1)) (bar-start-time (* bar-number ticks-per-bar)) (bar-end-time (+ bar-start-time ticks-per-bar)) ) (f bite (+ bar-number 1) bar-start-time (- bar-end-time 1)))) messages) ) (else (laml-error "map-bars-abs-time-1: Time problem. Should not happen"))))))) ; just playing: map with noice
(define (n-map f lst noice?) (map (lambda (el) (if (noice? el) el (f el))) lst)) ; A comprehensive mapping of chord names to a list of notes in the chords. ; The notes in the chord are ordered, and all in the interval 0..11. The list is read when needed the first time, ; and cached for subsequent use. ; May come from a file, such as data/extended-chord-list.lsp. ; Can also be calculated from a C-rooted chord list, via use of the function generate-complete-chord-list.
(define chord-map #f) ; Chord map selectors
(define (chord-name-of chord-entry) (car chord-entry)) (define (chord-notes-of chord-entry) (cdr chord-entry)) ; Do cache the chord info list
(define (do-ensure-chord-map) (if chord-map 'do-nothing (set! chord-map (generate-complete-chord-list basic-chord-list) ; earlier: (file-read (string-append midi-software-dir "data/" "extended-chord-list.lsp"))
))) (define (normalize-chord-list chord-notes) (sort-list (remove-duplicates (map (lambda (note-val) (remainder note-val 12)) chord-notes)) <=)) (define (chord-match? normalized-note-list) (do-ensure-chord-map) (find-in-list (lambda (chord-entry) (equal? normalized-note-list (chord-notes-of chord-entry))) chord-map)) (define (chord-name-of-normalized-note-list normalized-note-list) (do-ensure-chord-map) (let ((search-res (find-in-list (lambda (chord-entry) (equal? normalized-note-list (chord-notes-of chord-entry))) chord-map))) (if search-res (chord-name-of search-res) (list-to-string normalized-note-list ",")))) ; A chord formula list for the root of C. A possible input to the function generate-complete-chord-list below.
(define basic-chord-list '(("major" 0 4 7) ("6" 0 4 7 9) ("7" 0 4 7 10) ("M7" 0 4 7 11) ("Aug" 0 4 8) ("maj 9" 0 2 4 7) ("minor" 0 3 7) ("min6" 0 3 7 9) ("min7" 0 3 7 10) ("dim" 0 3 6) ("dim 6" 0 3 6 9) ("dim 7" 0 3 6 9) ("min 9" 0 2 3 7) ("sus4" 0 5 7) ("sus2" 0 2 7))) ; An more complete - and a much more complex - chord formula list for the root of C. A possible input to the function generate-complete-chord-list below.
(define extended-chord-list '(("major" 0 4 7) ("maj 6" 0 4 7 9) ("maj 7" 0 4 7 11) ("maj 9" 0 2 4 7 11) ("maj 11" 0 2 4 5 7 11) ("maj 13" 0 2 4 7 9 11) ("maj b5" 0 4 6) ("maj 7b5" 0 4 6 11) ("maj 9b5" 0 2 4 6 11) ("maj 11b5" 0 2 4 5 6 11) ("maj 13 b5" 0 2 4 6 9 11) ("Aug" 0 4 8) ("maj 7#5" 0 4 8 11) ("maj 9 #5" 0 2 4 8 11) ("maj 11 #5" 0 2 4 5 8 11) ("maj 13 #5" 0 2 4 8 9 11) ("maj/9" 0 2 4 7) ("maj 6/9" 0 2 4 7 9) ("maj 7/6" 0 4 7 9 11) ("maj 7/11" 0 4 5 7 11) ("maj 11/13" 0 2 4 5 7 9 11) ("maj 7b9" 0 1 4 7 11) ("maj 11b9" 0 1 4 5 7 11) ("maj 7#9" 0 3 4 7 11) ("maj 11 #9" 0 3 4 5 7 11) ("maj 9#11" 0 2 4 6 7 11) ("maj 7b5#9" 0 3 4 6 11) ("minor" 0 3 7) ("min6" 0 3 7 9) ("min7" 0 3 7 10) ("min9" 0 2 3 7 10) ("min 11" 0 2 3 5 7 10) ("min 13" 0 2 3 7 9 10) ("diminished" 0 3 6) ("dim 6" 0 3 6 9) ("dim 7" 0 3 6 9) ("minor Major 7" 0 3 7 11) ("min Maj 9" 0 2 3 7 11) ("min Maj 11" 0 2 3 5 7 11) ("min 7 b5 - half dim" 0 3 6 10) ("min9 b5" 0 2 3 6 10) ("min 11b5" 0 2 3 5 6 10) ("min 13 b 5" 0 2 3 6 9 10) ("min 7#5" 0 3 8 10) ("min 9#5" 0 2 3 8 10) ("min 11#5" 0 2 3 5 8 10) ("min/9" 0 2 3 7) ("min 6/9" 0 2 3 7 9) ("min 7/6" 0 3 7 9 10) ("min 7/11" 0 3 5 7 10) ("min 7b 9" 0 1 3 7 10) ("min 7#9" 0 3 3 7 10) ("Dominant 7" 0 4 7 10) ("Dom 9" 0 2 4 7 10) ("Dom 11" 0 2 4 5 7 10) ("Dom 13" 0 2 4 7 9 10) ("Dom 7b5" 0 4 6 10) ("Dom 9b5" 0 2 4 6 10) ("Dom 11b5" 0 2 4 5 6 10) ("Dom 7#5" 0 4 8 10) ("Dom 9#5" 0 2 4 8 10) ("Dom 7/6" 0 4 7 9 10) ("Dom 7/11" 0 4 5 7 10) ("Dom 7b9" 0 1 4 7 10) ("Dom 7#9" 0 3 4 7 10) ("Suspended 4" 0 5 7) ("Sus 6" 0 5 7 9) ("Sus 7" 0 5 7 11) ("Sus 9" 0 2 5 7 11) ("Sus 7b5" 0 5 6 11) ("Sus 7#5" 0 5 8 11) ("Sus/9" 0 2 5 7) ("Sus 6/9" 0 2 5 7 9) ("Maj/4" 0 4 5 7) ("maj 6/4" 0 4 5 7 9) ("maj 7/4" 0 4 5 7 11) ("maj/9/4" 0 2 4 5 7) ("min/4" 0 3 5 7) ("min 6/4" 0 3 5 7 9) ("min 7/4" 0 3 5 7 10) ("dim Sus" 0 5 6) ("dim 6 Sus" 0 5 6 9) ("dim 7 Sus" 0 5 6 9) ("aug Sus" 0 5 8) ("Dom 7 Sus" 0 5 7 10) ("Dom 7/4" 0 4 5 7 11) ("Aug/4" 0 4 5 8)))

(define (generate-complete-chord-list basic-chord-list . optional-parameter-list) (let ((chord-naming-style (optional-parameter 1 optional-parameter-list 'sharp))) (let* ((displacements (number-interval 0 11)) (roots-sharp (list "C" "C#" "D" "D#" "E" "F" "F#" "G" "G#" "A" "A#" "B")) (roots-flat (list "C" "Db" "D" "Eb" "E" "F" "Gb" "G" "Ab" "A" "Bb" "B")) (roots (if (eq? chord-naming-style 'sharp) roots-sharp roots-flat)) (transpose-chord-formula (lambda (formula displacement) (normalize-chord-list (map (lambda (formula-entry) (+ formula-entry displacement)) formula)))) ) (flatten (map (lambda (displ root) (map (lambda (chord-formula) (let ((chord-name (chord-name-of chord-formula)) (chord-formula (chord-notes-of chord-formula))) (cons (string-append root " " chord-name) (transpose-chord-formula chord-formula displ)) ) ) basic-chord-list ) ) displacements roots )))))

(define map-paused-sections (xml-in-laml-positional-abstraction 3 0 (lambda (f pause-ticks relevance-predicate contents attributes) (map-paused-sections-1 f pause-ticks relevance-predicate contents)))) (define (map-paused-sections-1 f pause-ticks relevance-predicate messages) (assert-abs-time messages) (map-n-bites (bite-while-element-with-accumulation (lambda (mes sound-frontier-time) ; pred
(not (and (> (midi 'absTime mes) sound-frontier-time) (> (- (midi 'absTime mes) sound-frontier-time) pause-ticks)))) (lambda (sound-frontier-time NoteOnMes) ; accumulator
(max sound-frontier-time (+ (midi 'absTime NoteOnMes) (midi 'duration NoteOnMes)))) 0 ; init-val
(lambda (x) (and (ast? x) (or (not (relevance-predicate x)) (not (NoteOn? x))))) ; noise function
) (lambda (midi-messages-bite n) (f n midi-messages-bite)) messages))

(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 surround-by-delta-time-note-list (xml-in-laml-positional-abstraction 1 0 (lambda (delta-time-note-list contents attributes) (let ((lgt (length-of-delta-time-midi-list delta-time-note-list))) (list delta-time-note-list (time-displace lgt contents) delta-time-note-list)))))

(define pass-through (xml-in-laml-abstraction (lambda (contents attributes) contents)))

(define map-midi-sections (xml-in-laml-positional-abstraction 3 0 (lambda (prefix-bite sublist-pred sublist-trans contents attributes) (map-midi-sections-1 prefix-bite sublist-pred sublist-trans contents)))) (define (map-midi-sections-1 prefix-bite sublist-pred sublist-trans message-list) (step-and-map-n-bites prefix-bite sublist-pred sublist-trans message-list))

;;; .section-id midi-list-fn-time ;;; Message List functions - Time related

(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 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) (cond ((null? message-list) '()) ((abs-time-message? (first 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)) ((delta-time-message? (first message-list)) (let* ((first-mes (first message-list)) (first-delta-time (ast-attribute first-mes 'deltaTime #f)) (rest-messages (cdr message-list))) (cons (copy-ast-mutate-attributes first-mes 'deltaTime (as-int-string (+ (as-number first-delta-time) amount))) rest-messages))) (else (laml-error "time-displace-1: First message must reveal time mode."))))

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

(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 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 (maybe-transformer transformer lst) (if (>= (length lst) 2) (transformer lst) lst))

(define cut-at-time (xml-in-laml-positional-abstraction 2 0 (lambda (abs-cut-time channel-list cont attr) (cut-at-time-1 abs-cut-time channel-list cont)))) (define (cut-at-time-1 abs-cut-time channel-list-0 message-list) (ensure-all-abstime-in! "cut-at-time-1" message-list) (let ((channel-list (if (and (boolean? channel-list-0) channel-list-0) (number-interval 1 16) channel-list-0))) (cut-at-time-2 abs-cut-time channel-list message-list '()))) (define (cut-at-time-2 abs-cut-time channel-list message-list res-lst) (if (null? message-list) (reverse res-lst) (let* ((m (car message-list)) (m-in-relevant-channel (and (channel-message? m) (member (midi 'channel m) channel-list)))) (cond ((and m-in-relevant-channel (not (NoteOn? m)) (> (midi 'absTime m) abs-cut-time)) ; Non-NoteOn that starts after cut time are deleted
(cut-at-time-2 abs-cut-time channel-list (cdr message-list) res-lst)) ((and m-in-relevant-channel (NoteOn? m) (> (midi 'absTime m) abs-cut-time)) ; NoteOn messages that starts after cut time are deleted in the same way
(cut-at-time-2 abs-cut-time channel-list (cdr message-list) res-lst)) ((and m-in-relevant-channel (NoteOn? m) (<= (midi 'absTime m) abs-cut-time) (> (+ (midi 'absTime m) (midi 'duration m)) abs-cut-time)) ; Note messages that 'cross' the cut-time are given shorter duration
(cut-at-time-2 abs-cut-time channel-list (cdr message-list) (cons (copy-ast-mutate-attributes m 'duration (- abs-cut-time (midi 'absTime m))) res-lst))) (else (cut-at-time-2 abs-cut-time channel-list (cdr message-list) (cons m res-lst))) ; Keep all other messages
))))

;;; .section-id midi-list-fn-note ;;; Message List functions - Note related

(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 transpose (xml-in-laml-positional-abstraction 1 0 (lambda (amount contents attributes) (transpose-1 amount contents)))) (define (transpose-1 amount message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (or (equal? "NoteOn" (ast-element-name mes-ast)) (equal? "NoteOff" (ast-element-name mes-ast)))) (let* ((old-note (as-number (ast-attribute mes-ast 'note))) (new-note (+ old-note amount))) (copy-ast-mutate-attributes mes-ast 'note new-note)) mes-ast)) message-list))

(define transpose-channels (xml-in-laml-positional-abstraction 2 0 (lambda (channel-list amount contents attributes) (transpose-channels-1 channel-list amount contents)))) (define (transpose-channels-1 ch-list amount message-list) (map (lambda (mes-ast) (if (and (ast? mes-ast) (or (equal? "NoteOn" (ast-element-name mes-ast)) (equal? "NoteOff" (ast-element-name mes-ast)))) (let ((channel (ast-attribute mes-ast 'channel #f))) (if channel (if (member (as-number channel) ch-list) (let* ((old-note (as-number (ast-attribute mes-ast 'note))) (new-note (+ old-note amount))) (copy-ast-mutate-attributes mes-ast 'note new-note)) mes-ast) mes-ast)) mes-ast)) message-list))

(define map-notes-in-channels (xml-in-laml-positional-abstraction 2 0 (lambda (note-map channel-list contents attributes) (map-notes-in-channels-1 note-map channel-list contents)))) (define (map-notes-in-channels-1 note-map channel-list message-list) (let ((note-map-numbers (map (lambda (map-entry) (let ((source (car map-entry)) (dest (cadr map-entry))) (list (number-of-note-name (upcase-string (as-string source))) (number-of-note-name (upcase-string (as-string dest)))))) note-map))) (letrec ((note-mapper (lambda (source-note-value) ; a midi note-value, such as 64. Mapped to the appropriate midi note value, or #f is it is not mapped.
(let ((map-res (find-in-list (lambda (entry) (= (first entry) (remainder source-note-value 12))) note-map-numbers))) (if map-res (+ (* (quotient source-note-value 12) 12) (second map-res)) #f))))) (map-notes-in-channels-2 note-mapper channel-list message-list '()) ) ) ) ; iterative processing
(define (map-notes-in-channels-2 note-mapper channel-list message-list res-lst) (cond ((null? message-list) (reverse res-lst)) (else (let ((message (car message-list))) (if (ast? message) (if (NoteOn? message) (if (member (as-number (ast-attribute message 'channel)) channel-list) (let* ((target-note-value (note-mapper (as-number (ast-attribute message 'note))))) (if target-note-value (map-notes-in-channels-2 note-mapper channel-list (cdr message-list) (cons (copy-ast-mutate-attributes message 'note target-note-value) res-lst)) ; map note value!!
(map-notes-in-channels-2 note-mapper channel-list (cdr message-list) (cons (copy-ast-mutate-attributes message 'velocity "1") res-lst)) ; exclude message - muted (cannot use value 0 - WHY???).
) ) (map-notes-in-channels-2 note-mapper channel-list (cdr message-list) (cons message res-lst))) ; unchanged - other channel
(map-notes-in-channels-2 note-mapper channel-list (cdr message-list) (cons message res-lst))) ; unchanged - non-NoteOn
(map-notes-in-channels-2 note-mapper channel-list (cdr message-list) res-lst) ; drop: non-ast
) ) ) ) )

;;; .section-id midi-list-fn-vel ;;; Message List functions - Velocity related

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

;;; .section-id midi-list-fn-dur ;;; Message List functions - Duration related

(define eliminate-breaks (xml-in-laml-positional-abstraction 1 0 (lambda (channel contents attributes) (eliminate-breaks-1 channel contents)))) (define (eliminate-breaks-1 channel messages) (let* ((channel-messages (filter (lambda (x) (and (ast? x) (NoteOn? x) (= channel (midi 'channel x)))) messages)) (abs-time-list (map (lambda (noteon-ast) (midi 'absTime noteon-ast)) channel-messages)) (abs-time-diff-list (map2 (lambda (at1 at2) (- at1 at2)) (cdr abs-time-list) abs-time-list))) (adjust-duration channel messages abs-time-diff-list '()))) ; Adjust duration of messages in the given channel to the max of the existing duration and the calculated absTime diffes in abs-time-diff-list ; Iterative.
(define (adjust-duration channel messages abs-time-diff-list res-messages) (cond ((null? messages) (reverse res-messages)) ((not (ast? (car messages))) (adjust-duration channel (cdr messages) abs-time-diff-list res-messages)) ; just skip
((not (has-ast-attribute? (car messages) 'channel)) (adjust-duration channel (cdr messages) abs-time-diff-list (cons (car messages) res-messages))) ; non-channel mes
((and (NoteOn? (car messages)) (= channel (midi 'channel (car messages))) (not (null? abs-time-diff-list))) ; channel NoteOn message
(adjust-duration channel (cdr messages) (cdr abs-time-diff-list) (cons (copy-ast-mutate-attributes (car messages) 'duration (max (midi 'duration (car messages)) (car abs-time-diff-list))) res-messages))) (else (adjust-duration channel (cdr messages) abs-time-diff-list (cons (car messages) res-messages)))))

(define legato-in-channel (xml-in-laml-positional-abstraction 1 0 (lambda (channel contents attributes) (let ((time-slack-delta (as-number (defaulted-get-prop 'time-slack-delta attributes 20))) (strict (as-boolean (defaulted-get-prop 'strict attributes #f))) (offset (as-number (defaulted-get-prop 'offset attributes 0))) (max-tie-span (defaulted-get-prop 'max-tie-span attributes #f)) ) (legato-in-channel-1 channel time-slack-delta strict max-tie-span offset contents))))) (define (legato-in-channel-1 channel time-slack-delta strict max-tie-span offset message-list) (let ((message-list-1 (filter ast? message-list))) (cond ((abs-time-sequence? message-list-1) (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset message-list-1 '() 0 '())) ((delta-time-sequence? message-list-1) (if max-tie-span (laml-error "legato-in-channel-1: max-timespan cannot be used in delta time mode")) (legato-in-channel-delta-time channel time-slack-delta strict offset message-list-1 '() 0 '() 0)) (else (laml-error "legato-in-channel-1: Either pure absTime or pure deltaTime mode is expected"))))) ; t0 is the absolute time (relative to the place of application) of the first NoteOn message that belongs to channel in message-list ; tcur is the current absolute time, as accumulated during traversal. tcur is new in the delta time version.
(define (legato-in-channel-delta-time channel time-slack-delta strict offset message-list pending-message-list t0 res-list tcur) (cond ((null? message-list) (append (reverse res-list) (reverse pending-message-list))) (else (let* ((first-mes (first message-list)) (time-first (+ tcur (as-number (ast-attribute first-mes 'deltaTime))))) (display-message (length pending-message-list) "note = " (midi 'note first-mes) "time-first = " time-first "t0 = " t0 "tcur = " tcur) (cond ; getting started: going through messages irrelevant for legato in channel.
((and (null? pending-message-list) (or (not (NoteOn? first-mes)) (and (NoteOn? first-mes) (not (= channel (as-number (ast-attribute first-mes 'channel))))))) (legato-in-channel-delta-time channel time-slack-delta strict offset (cdr message-list) '() 0 (cons first-mes res-list) (+ tcur (as-number (ast-attribute first-mes 'deltaTime))))) ; locating a Noteon in channel. Serves as the first reference point in pending-message-list.
((and (null? pending-message-list) (and (NoteOn? first-mes) (= channel (as-number (ast-attribute first-mes 'channel))))) (legato-in-channel-delta-time channel time-slack-delta strict offset (cdr message-list) (list first-mes) time-first res-list (+ tcur (as-number (ast-attribute first-mes 'deltaTime))))) ; locating messages to pass to pending messages. Either nearby NoteOns in samme channel, or irrelevant messages.
((and (not (null? pending-message-list)) (or (not (NoteOn? first-mes)) (and (NoteOn? first-mes) (not (= channel (as-number (ast-attribute first-mes 'channel))))) (and (NoteOn? first-mes) (= channel (as-number (ast-attribute first-mes 'channel))) (<= (- time-first t0) time-slack-delta)))) (legato-in-channel-delta-time channel time-slack-delta strict offset (cdr message-list) (cons first-mes pending-message-list) t0 res-list (+ tcur (as-number (ast-attribute first-mes 'deltaTime))))) ; Locating a more distant NoteOn messages in channel. Now add the pending messages up to first-mes. And continue recursively.
(else (legato-in-channel-delta-time channel time-slack-delta strict offset (cdr message-list) (list first-mes) time-first (let* ((note-to-modify (last pending-message-list)) (note-now-modified (copy-ast-mutate-attributes note-to-modify 'duration (cond (strict (max 0 (+ offset (- time-first t0)))) (else (max 0 (+ offset (max (as-number (ast-attribute note-to-modify 'duration)) (- time-first t0)))))))) (other-pendings-messages (butlast pending-message-list))) (append (append other-pendings-messages (list note-now-modified)) res-list)) (+ tcur (as-number (ast-attribute first-mes 'deltaTime))))) ))))) (define (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset message-list pending-message-list t0 res-list) (cond ((null? message-list) (append (reverse res-list) (reverse pending-message-list))) (else (let* ((first-mes (first message-list)) (time-first (as-number (ast-attribute first-mes 'absTime)))) (display-message (length pending-message-list) " " (midi 'note first-mes)) (cond ; getting started: going through messages irrelevant for legato in channel.
((and (null? pending-message-list) (or (not (NoteOn? first-mes)) (and (NoteOn? first-mes) (not (= channel (as-number (ast-attribute first-mes 'channel))))))) (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset (cdr message-list) '() 0 (cons first-mes res-list))) ; locating a Noteon in channel. Serves as first reference point in pending-message-list.
((and (null? pending-message-list) (and (NoteOn? first-mes) (= channel (as-number (ast-attribute first-mes 'channel))))) (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset (cdr message-list) (list first-mes) (as-number (ast-attribute first-mes 'absTime)) res-list)) ; locating messages to pass to pending messages. Either close NoteOns in samme channel or irrelevant messages.
((and (not (null? pending-message-list)) (or (not (NoteOn? first-mes)) (and (NoteOn? first-mes) (not (= channel (as-number (ast-attribute first-mes 'channel))))) (and (NoteOn? first-mes) (= channel (as-number (ast-attribute first-mes 'channel))) (<= (- time-first t0) time-slack-delta)))) (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset (cdr message-list) (cons first-mes pending-message-list) t0 res-list)) ; Locating a more distant NoteOn messages in channel. Now add pending messages up to first-mes.
(else (legato-in-channel-abs-time channel time-slack-delta strict max-tie-span offset (cdr message-list) (list first-mes) (as-number (ast-attribute first-mes 'absTime)) (append (map (lambda (pending-mes) (if (and (NoteOn? pending-mes) (= channel (as-number (ast-attribute pending-mes 'channel)))) (if (or (not max-tie-span) (and max-tie-span (<= (- (as-number (ast-attribute first-mes 'absTime)) (as-number (ast-attribute pending-mes 'absTime))) (as-number max-tie-span)))) (copy-ast-mutate-attributes pending-mes 'duration (cond (strict (max 0 (+ offset (- (as-number (ast-attribute first-mes 'absTime)) (as-number (ast-attribute pending-mes 'absTime)))))) (else (max 0 (+ offset (max (as-number (ast-attribute pending-mes 'duration)) (- (as-number (ast-attribute first-mes 'absTime)) (as-number (ast-attribute pending-mes 'absTime))))))))) pending-mes) pending-mes)) pending-message-list) res-list))))))))

;;; .section-id midi-list-fn-others ;;; Message List functions - Control Related and Misc

(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 pan-left-right (xml-in-laml-positional-abstraction 2 0 (lambda (channel pan-level contents attributes) (pan-left-right-1 channel pan-level contents)))) (define (pan-left-right-1 ch pan-level message-list) (letrec ( (arc-pan (lambda (pan-value) ; pan-value between 0 and 128. Return an "arccos value"...
(acos (/ (- pan-value 64) 64)))) (pan-fn (lambda (x) (+ 64 (* 64 (cos x))))) (interval-of-reals (lambda (lower upper step) (if (< lower upper) (cons lower (interval-of-reals (+ lower step) upper step)) '()))) (interval-of-n-reals (lambda (lower upper n) (let ((step (/ (- upper lower) n))) (interval-of-reals lower upper step)))) (PI 3.14159) ) (let* ((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))) (ap (arc-pan pan-level)) ; (pan-fn ap) = pan-level
(pan-value-list (map (lambda (r) (pan-fn r)) (interval-of-n-reals ap (+ ap (* 2 PI)) number-of-note-ons))) ; a list of values in the interval 0 .. 128
(pan-message-list (map (lambda (pan-val) (ControlChange 'deltaTime "0" 'channel ch 'control "10" 'value (as-int-string (between 0 127 (to-int pan-val))))) pan-value-list)) ) (pan-left-right-2 ch pan-level pan-message-list message-list)))) (define (pan-left-right-2 ch pan-level pan-message-list message-list) (cond ((null? message-list) (list (ControlChange 'deltaTime "0" 'channel ch 'control "10" 'value pan-level))) ((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 (if (not (null? pan-message-list)) (car pan-message-list) '()) mes-ast) (pan-left-right-2 ch pan-level (cdr pan-message-list) (cdr message-list))) (cons mes-ast (pan-left-right-2 ch pan-level pan-message-list (cdr message-list)))))) (else (cons (car message-list) (pan-left-right-2 ch pan-level pan-message-list (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-channel-key-pressure (xml-in-laml-positional-abstraction 1 0 (lambda (channel contents attributes) (eliminate-channel-key-pressure-1 channel contents)))) (define (eliminate-channel-key-pressure-1 ch message-list) (eliminate-midi-null-events (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "ChannelKeyPressure") (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-channel-key-pressure-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 eliminate-pitch-bend (xml-in-laml-positional-abstraction 1 0 (lambda (channel contents attributes) (eliminate-pitch-bend-1 channel contents)))) (define (eliminate-pitch-bend-1 ch message-list) (eliminate-midi-null-events (map (lambda (mes-ast) (if (and (ast? mes-ast) (equal? (ast-element-name mes-ast) "PitchBendChange") (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-pitch-bend-1: Not absTime and not deltaTime. Should not happen")))) mes-ast) ) message-list)))

(define revoice (xml-in-laml-positional-abstraction 1 0 (lambda (revoice-map contents attributes) (let ((revoice-file (defaulted-get-prop 'revoice-file attributes #f))) (revoice-1 revoice-map contents revoice-file))))) (define (revoice-1 revoice-map contents revoice-file) (let ((contents-1 (msb-lsb-to-internal-pc-attributes contents '(#t . 0) '(#t . 0) '() ))) (if revoice-file (let ((file-path (in-startup-directory revoice-file))) (if (file-exists? file-path) (delete-file file-path)) (write-text-file (extract-revoice-file-info contents-1) file-path))) (revoice-2 revoice-map contents-1))) (define (extract-revoice-file-info contents) (string-append "(" CR (list-to-string (filter (lambda (x) x) (map (lambda (ast) (if (ProgramChange? ast) (if (and (ast-internal-attribute ast 'msb) (ast-internal-attribute ast 'lsb)) (let* ((msb (ast-internal-attribute ast 'msb)) (lsb (ast-internal-attribute ast 'lsb)) (pc (midi 'number ast))) (single-msb-lsb-pc-info-string msb lsb pc)) #f) #f)) contents)) CR) CR ")")) (define (single-msb-lsb-pc-info-string msb lsb pc) (string-append " (list " " (list " (as-string msb) " " (as-string lsb) " " (as-string pc) " " (string-it (as-string (find-voice-info-string msb lsb pc))) ")" CR " (list ) " ")")) ; Traverse messages in contents, and put internal attributes on ProgramChange messages that reflect the msb and lsb of preceding ControlChange messages. ; The meaning of previous-msb previous-lsb corresponds to the global variables previous-msb-control-channel-value and ; previous-lsb-control-channel-value in midi.scm ; Decorate program change messages in contents with internal lsb and msb attributes. ; Return a list of ProgramChange ASTs decorated with interal attributes for msb and lsb information (control change info).
(define (msb-lsb-to-internal-pc-attributes contents previous-msb previous-lsb out-contents) (cond ((null? contents) (reverse out-contents)) ((not (ast? (car contents))) (msb-lsb-to-internal-pc-attributes (cdr contents) previous-msb previous-lsb out-contents)) ((ControlChange? (car contents) 0) ; LSB
(msb-lsb-to-internal-pc-attributes (cdr contents) (cons (midi 'channel (car contents)) (midi 'value (car contents))) previous-lsb out-contents)) ; remove from midi stream
((ControlChange? (car contents) 32) ; MSB
(msb-lsb-to-internal-pc-attributes (cdr contents) previous-msb (cons (midi 'channel (car contents)) (midi 'value (car contents))) out-contents)) ; remove from midi stream
((ProgramChange? (car contents)) (let* ((element (car contents)) ; alias
(channel (midi 'channel element))) (if #t ; (and (not (boolean? (first previous-msb))) (not (boolean? (first previous-lsb))) ; (= channel (first previous-msb)) (= channel (first previous-lsb)))
(let ((new-element (make-ast (ast-element-name element) (ast-subtrees element) (ast-attributes element) (ast-kind element) (ast-language element) (list 'msb (cdr previous-msb) 'lsb (cdr previous-lsb))))) (msb-lsb-to-internal-pc-attributes (cdr contents) '(#t . 0) '(#t . 0) (cons new-element out-contents))) (msb-lsb-to-internal-pc-attributes (cdr contents) previous-msb previous-lsb (cons element out-contents))))) (else (msb-lsb-to-internal-pc-attributes (cdr contents) previous-msb previous-lsb (cons (car contents) out-contents))))) ; Carry out the revoicing on the a contents list in which program change messages are decorated with internal msb and lsb attributes.
(define (revoice-2 revoice-map contents) (map (lambda (ast) (if (ProgramChange? ast) (if (and (ast-internal-attribute ast 'msb) (ast-internal-attribute ast 'lsb)) (let* ((msb (ast-internal-attribute ast 'msb)) (lsb (ast-internal-attribute ast 'lsb)) (pc (midi 'number ast)) (ch (midi 'channel ast)) (res (lookup-revoice-map revoice-map msb lsb pc))) (if res (apply voice (cons ch res)) (voice ch 0 0 pc) ; Revocing to GM
)) (let ((pc (midi 'number ast)) (ch (midi 'channel ast))) (voice ch 0 0 pc))) ast) ) contents)) ; A revoice map is a list mapping entries. ; A mapping entry is of the form ((msb-from lsb-from pc-from) (msb-to lsb-to pc-to)) where all constituents are integers ; Return the list (msb-to lsb-to pc-to) if msb, lsb and pc match (msb-from lsb-from pc-from). If not, return #f.
(define (lookup-revoice-map revoice-map msb lsb pc) (let ((res (find-in-list (lambda (e) (let ((from (car e))) (and (= msb (first from)) (= lsb (second from)) (= pc (third from))))) revoice-map))) (if res (cadr res) #f)))

(define eliminate-voice-messages (xml-in-laml-positional-abstraction 0 0 (lambda (contents attributes) (let ((info-file (defaulted-get-prop 'info-file attributes #f))) (eliminate-voice-messages-1 info-file contents)) ))) (define (eliminate-voice-messages-1 info-file contents) (let ((contents-1 (msb-lsb-to-internal-pc-attributes contents '(#t . 0) '(#t . 0) '() ))) (if info-file (let ((file-path (in-startup-directory info-file))) (if (file-exists? file-path) (delete-file file-path)) (write-text-file (make-voices-info-string contents-1) file-path))) (map (lambda (ast) (cond ((ProgramChange? ast) (cond ((midi 'absTime ast) (midi-comment-abs-time (midi 'absTime ast) (string-append "Was ProgramChange" " " (ast-attribute ast 'channel) " " (as-string (ast-internal-attribute ast 'msb "?")) " " (as-string (ast-internal-attribute ast 'lsb "?")) " " (ast-attribute ast 'number)))) ((midi 'deltaTime ast) (midi-comment-delta-time (midi 'deltaTime ast) (string-append "Was ProgramChange" " " (ast-attribute ast 'channel) " " (as-string (ast-internal-attribute ast 'msb "?")) " " (as-string (ast-internal-attribute ast 'lsb "?")) " " (ast-attribute ast 'number)))) (else (laml-error "eliminate-voice-messages-1 (A): Should not happen")))) ((SysEx? ast "05 7E 7F 09 01 F7") (cond ((midi 'absTime ast) (midi-comment-abs-time (midi 'absTime ast) (string-append "Was SysEx" " " (ast-text ast)))) ((midi 'deltaTime ast) (midi-comment-delta-time (midi 'deltaTime ast) (string-append "Was SysEx" " " (ast-text ast)))) (else (laml-error "eliminate-voice-messages-1 (B): Should not happen")))) (else ast))) contents-1) ) ) (define (make-voices-info-string messages) (list-to-string (map (lambda (lst) (apply make-single-voice-info lst)) (sort-list (filter pair? (map (lambda (ast) (if (ProgramChange? ast) (if (and (ast-internal-attribute ast 'msb) (ast-internal-attribute ast 'lsb)) (let* ((ch (midi 'channel ast)) (msb (ast-internal-attribute ast 'msb)) (lsb (ast-internal-attribute ast 'lsb)) (pc (midi 'number ast))) (list ch msb lsb pc)) #f) #f)) messages)) (lambda (lst1 lst2) (<= (first lst1) (first lst2))))) ; sort according to channel
CR)) (define (make-single-voice-info ch msb lsb pc) (let ((voice-name (find-voice-info-string msb lsb pc))) (string-append "Channel: " (as-string ch) CR (if voice-name voice-name "???") CR "MSB LSB PC: " (as-string msb) " " (as-string lsb) " " (as-string pc) " " CR (xs-instrument-how-to msb lsb pc) CR))) (define (xs-instrument-how-to msb lsb pc) (let ((bank (cond ((and (= msb 63) (= lsb 0)) "PRE1") ; 128
((and (= msb 63) (= lsb 1)) "PRE2") ((and (= msb 63) (= lsb 2)) "PRE3") ((and (= msb 63) (= lsb 3)) "PRE4") ((and (= msb 63) (= lsb 4)) "PRE5") ((and (= msb 63) (= lsb 5)) "PRE6") ((and (= msb 63) (= lsb 6)) "PRE7") ((and (= msb 63) (= lsb 7)) "PRE8") ((and (= msb 63) (= lsb 8)) "USR1") ((and (= msb 63) (= lsb 9)) "USR2") ((and (= msb 63) (= lsb 10)) "USR3") ((and (= msb 0) (= lsb 0)) "GM") ; 128
((and (= msb 63) (= lsb 32)) "PRE DRUM") ; 64
((and (= msb 63) (= lsb 40)) "USR DRUM") ; 32
((and (= msb 127) (= lsb 0)) "GM Drum") ; 1
(else "??"))) (number (+ (remainder pc 16) 1)) (letter-number (quotient pc 16))) (string-append bank " " (as-string (as-char (+ 65 letter-number))) (as-string number))))

(define clean-for-motif (xml-in-laml-positional-abstraction 0 0 (lambda (contents attributes) (let ((info-file (defaulted-get-prop 'info-file attributes #f))) (clean-for-motif-1 info-file contents))))) (define (clean-for-motif-1 info-file contents) (let ((contents-1 (eliminate-voice-messages-1 info-file contents))) (filter (lambda (x) (cond ((not (ast? x)) #f) ((and (ControlChange? x) (not (member (midi 'control x) (list 64 84)))) #f) ((and (SysEx? x) (equal? (substring (ast-text x) 3 5) "43") (equal? (substring (ast-text x) 9 11) "4C")) #f) (else #t))) contents-1)))

(define clean-for-sectional-playing (xml-in-laml-positional-abstraction 3 0 (lambda (time-mode time-start include-voice-messages? contents attributes) (clean-for-sectional-playing-1 time-mode time-start include-voice-messages? contents)))) (define (clean-for-sectional-playing-1 time-mode-0 time-start include-voice-messages? messages) (let ((time-mode (as-symbol time-mode-0))) (let* ((suffix-starting-with-note-on (find-tail-in-list (lambda (mes-ast) (and (ast? mes-ast) (NoteOn? mes-ast))) messages)) (prefix-before-starting-note-on (find-but-tail-in-list (lambda (mes-ast) (and (ast? mes-ast) (NoteOn? mes-ast))) messages)) (cleaned-prefix ; does not work correctly in deltaTime mode!
(if include-voice-messages? (let* ((voice-messages (filter-messages-1 (lambda (mes-ast) (or (ProgramChange? mes-ast) (ControlChange? mes-ast 0) (ControlChange? mes-ast 32))) prefix-before-starting-note-on)) ) (map (lambda (voice-mes-ast) (if (eq? time-mode 'abs-time) (copy-ast-mutate-attributes voice-mes-ast 'absTime "0") ; enforce absTime "0"
(copy-ast-mutate-attributes voice-mes-ast 'deltaTime "0"))) voice-messages)) '())) ) (if (null? suffix-starting-with-note-on) cleaned-prefix (let ((first-time (time-of-message (first suffix-starting-with-note-on)))) (append cleaned-prefix (time-displace-1 (- (- first-time time-start)) (cond ((eq? time-mode 'abs-time) (filter-messages (lambda (mes-ast) (not (or (Meta? mes-ast 81) (ProgramChange? mes-ast) (ControlChange? mes-ast 0) (ControlChange? mes-ast 32) (PitchBendChange? mes-ast)))) suffix-starting-with-note-on)) ((eq? time-mode 'delta-time) (transform-messages (lambda (mes-ast) (or (Meta? mes-ast 81) (ProgramChange? mes-ast) (ControlChange? mes-ast 0) (ControlChange? mes-ast 32) (PitchBendChange? mes-ast))) (lambda (mes-ast) (midi-null-event-delta-time (as-number (ast-attribute mes-ast 'deltaTime)))) suffix-starting-with-note-on)) (else (laml-error "clean-for-sectional-playing-1: Should not happen."))))))))))

(define tempo-scale (xml-in-laml-positional-abstraction 2 0 (lambda (base-tempo scale-fn contents attributes) (let* ((duration (total-length-of-message-list contents)) (n (defaulted-get-prop 'n attributes (quotient duration 960))) (last-tempo (defaulted-get-prop 'last-tempo attributes #f))) (tempo-scale-1 n base-tempo scale-fn last-tempo contents))))) ; The signature of tempo-scale-1 has been changed a little on December 16, 2010 (eliminated duration parameter - recalculated in tempo-scale-1)
(define (tempo-scale-1 n base-tempo scale-fn last-tempo contents) (assert-abs-time contents) (let ((duration (total-length-of-message-list contents)) ; recalculated of convenience, need not be passed as parameter
) (delta-abs-merge-two-lists (if last-tempo (make-tempo-change-list n duration base-tempo scale-fn (as-number last-tempo)) (make-tempo-change-list n duration base-tempo scale-fn)) contents)))

(define volume-scale (xml-in-laml-positional-abstraction 3 0 (lambda (ch start-volume scale-fn contents attributes) (let* ((duration (total-length-of-message-list contents)) (n (defaulted-get-prop 'n attributes (quotient duration 960))) (end-volume (defaulted-get-prop 'end-volume attributes #f))) (volume-scale-1 ch n duration start-volume scale-fn end-volume contents))))) ; (define (volume-scale-1 ch n duration start-volume scale-fn end-volume contents) ; (list ; (if end-volume ; (make-volume-change-list ch n duration start-volume scale-fn (as-number end-volume)) ; (make-volume-change-list ch n duration start-volume scale-fn)) ; contents) ; )
(define (volume-scale-1 ch n duration start-volume scale-fn end-volume contents) (get-rid-of-delta-times (delta-abs-merge-two-lists (if end-volume (make-volume-change-list ch n duration start-volume scale-fn (as-number end-volume)) (make-volume-change-list ch n duration start-volume scale-fn)) (map ast-copy contents) ; conservative: copy perhaps not necessary?
) 0) )

(define volume-scale-multi-channel (xml-in-laml-positional-abstraction 1 0 (lambda (volume-scale-list contents attributes) (let* ((duration (total-length-of-message-list contents)) (n (quotient duration 960))) (volume-scale-multi-channel-1 n duration volume-scale-list contents))))) (define (volume-scale-multi-channel-1 n duration volume-scale-list contents) (if (null? volume-scale-list) contents (let* ((vol-scale-entry (car volume-scale-list)) (ch (first vol-scale-entry)) (start-vol (second vol-scale-entry)) (scaling-fn (third vol-scale-entry)) (end-vol (if (>= (length vol-scale-entry) 4) (fourth vol-scale-entry) #f))) (volume-scale-multi-channel-1 n duration (cdr volume-scale-list) (volume-scale-1 ch n duration start-vol scaling-fn end-vol contents)))))

(define insert-lyric (xml-in-laml-positional-abstraction 1 0 (lambda (lyric-syllable-list contents attributes) (insert-lyric-1 lyric-syllable-list contents)))) (define (insert-lyric-1 lyric-syllable-list messages) (insert-lyric-2 lyric-syllable-list messages '()) ) (define (insert-lyric-2 lyric-syllable-list messages res-messages) (cond ((null? messages) (reverse res-messages)) (else (let ((mes (first messages))) (cond ((not (ast? mes)) (insert-lyric-2 lyric-syllable-list (cdr messages) res-messages)) ((and (Meta? mes 5) ; empty lyric meta message
(empty-string? (ast-text mes)) (not (null? lyric-syllable-list))) (insert-lyric-2 (cdr lyric-syllable-list) (cdr messages) (cons (Meta 'deltaTime (midi 'deltaTime mes) 'type 5 (as-string (car lyric-syllable-list))) res-messages))) (else (insert-lyric-2 lyric-syllable-list (cdr messages) (cons mes res-messages))))))))

;;; .section-id smf-functions ;;; Standard Midi File functions. ;;; Functions which should be applied on a StandardMidiFile form.

(define (smf-to-ppqn target-ppqn context-mode smf-ast) (let* ((header (ast-subtree smf-ast "MidiHeader")) (source-ppqn (as-number (ast-attribute header 'pulsesPerQuarterNote))) (format (as-number (ast-attribute header 'format))) (mode (ast-attribute header 'mode)) (ct (ast-attribute header 'counterTransposition)) (no-of-tracks (as-number (ast-attribute header 'numberOfTracks))) (track-list (filter (lambda (x) (and (ast? x) (equal? (ast-element-name x) "MidiTrack"))) (ast-subtrees smf-ast))) ) (StandardMidiFile (if (eq? context-mode 'nested) (list 'internal:run-action-procedure "false") (list)) (MidiHeader 'format format 'numberOfTracks no-of-tracks 'pulsesPerQuarterNote target-ppqn 'mode mode 'counterTransposition ct) (map (lambda (track-ast) (MidiTrack (time-stretch-1 (/ target-ppqn source-ppqn) (ast-subtrees track-ast))) ) track-list))))

(define (smf-to-format-0 context-mode smf-ast . optional-parameters) (let* ((ppqn-distance-to-end-of-track (optional-parameter 1 optional-parameters 8)) (header (ast-subtree smf-ast "MidiHeader")) (ppqn (as-number (ast-attribute header 'pulsesPerQuarterNote))) (format (as-number (ast-attribute header 'format))) (mode (ast-attribute header 'mode)) (ct (ast-attribute header 'counterTransposition)) (no-of-tracks (as-number (ast-attribute header 'numberOfTracks))) ; not used
(track-list (filter (lambda (x) (and (ast? x) (equal? (ast-element-name x) "MidiTrack"))) (ast-subtrees smf-ast))) (no-end-of-track (lambda (message-list) (filter (lambda (x) (not (and (ast? x) (Meta? x 47)))) message-list))) ) (if (= format 0) smf-ast ; the identity function
(cond ((equal? mode "absTime") (StandardMidiFile (if (eq? context-mode 'nested) (list 'internal:run-action-procedure "false") (list)) (MidiHeader 'format 0 'numberOfTracks 1 'pulsesPerQuarterNote ppqn 'mode "absTime" 'counterTransposition ct) (MidiTrack (accumulate-right abs-merge-two-lists '() (map (compose no-end-of-track ast-subtrees) track-list)) (Meta 'deltaTime (* ppqn-distance-to-end-of-track ppqn) 'type "47" "")))) ((equal? mode "deltaTime") (StandardMidiFile (if (eq? context-mode 'nested) (list 'internal:run-action-procedure "false") (list)) (MidiHeader 'format 0 'numberOfTracks 1 'pulsesPerQuarterNote ppqn 'mode "deltaTime" 'counterTransposition ct) (MidiTrack (accumulate-right delta-merge-two-lists '() (map (compose no-end-of-track ast-subtrees) track-list)) (Meta 'deltaTime (* ppqn-distance-to-end-of-track ppqn) 'type "47" ""))))))))

(define (recording-to-motif smf-ast) (smf-to-format-0 'top-level (smf-to-ppqn 480 'nested smf-ast))) (define (recording-to-motif-nested smf-ast) (smf-to-format-0 'nested (smf-to-ppqn 480 'nested smf-ast))) ; An function used internally by the step-recording facility. ; It transforms the smf ast to mofif format (a single track, 480 ppqn). ; Quantification q is either 32, 16, 4, 2, or 1 corresponding to 1/q't note. ; Assume deltaTiming. ; NOT USED
(define (as-step-recording-on-motif-nested-fixed-timing smf-ast quantification-str) (let ((quantification (as-number quantification-str))) (let ((ticks (cond ((= quantification 1) (* 4 480)) ((= quantification 2) (* 2 480)) ((= quantification 4) 480) ((= quantification 8) 240) ((= quantification 16) 120) ((= quantification 32) 60) (else (laml-error "as-step-recording-on-motif-nested: Unknown quantification:" quantification))))) (apply-to-tracks-nested (lambda mes-lst (map (lambda (ast) (if (NoteOn? ast) (copy-ast-mutate-attributes ast 'deltaTime ticks 'duration ticks) ast) ) mes-lst)) ; earlier: (filter-messages NoteOn? mes-lst)
() (recording-to-motif-nested smf-ast))))) ; An function used internally by the step-recording facility. ; Assume step recording takes place in channel 1. ; The function transforms the smf ast to mofif format (a single track, 480 ppqn) and it quantizes the notes to 1/16th, 1/8th, 1/4th, 1/2th, or 1/1th notes (durations 120, 240, 480, 960, 1920 resp) ; after having applied legato ; Pauses are restricted to 1/4, 1/2 or 1/1. ; Recording happens at 100 BPM = 100 quarter notes / 60 sek = 100*480 ticks / 60 s = 800 ticks pr. sec with PPQN = 480. ; Assume deltaTiming in this function.
(define (as-step-recording-on-motif-nested-variable-timing smf-ast) (apply-to-tracks-nested (lambda mes-lst (quantize-timing-in-a-step-recording (map (lambda (ast) (if (NoteOn? ast) (quantize-duration-of-note-step-recording ast) ast) ) (legato-in-channel-1 1 10 #t #f 0 mes-lst)))) ; (legato-in-channel-1 1 10 #t #f 0 mes-lst)
() (recording-to-motif-nested smf-ast))) ; Force duration to either 120, 240, 480, 960 or 1920 ticks. ; The forced duration comes from the recorded duration.
(define (quantize-duration-of-note-step-recording note-ast) (let* ((recorded-duration (midi 'duration note-ast)) (forced-duration (cond ((<= recorded-duration 300) 120) ; 1/16th at 480 PPQN
((<= recorded-duration 600) 240) ; 1/8th at 480 PPQN
((<= recorded-duration 1200) 480) ; 1/4th at 480 PPQN
((<= recorded-duration 2400) 960) ; 1/2th at 480 PPQN
(else 1920))) ; 1/1th at 480 PPQN
) (copy-ast-mutate-attributes note-ast 'duration forced-duration))) ; Set the deltaTime based on the duration of the previous note. ; No pauses are introduced.
(define (quantize-timing-in-a-step-recording event-ast-lst) (quantize-timing-step-recording-1 event-ast-lst #f '()) ) (define (quantize-timing-step-recording-1 event-ast-lst prev-duration res-lst) (if (null? event-ast-lst) (reverse res-lst) (let ((mes (car event-ast-lst))) (cond ((and (NoteOn? mes) (not prev-duration)) (quantize-timing-step-recording-1 (cdr event-ast-lst) (midi 'duration mes) (cons (copy-ast-mutate-attributes mes 'deltaTime 480) res-lst))) ((and (NoteOn? mes) prev-duration) (quantize-timing-step-recording-1 (cdr event-ast-lst) (midi 'duration mes) (cons (copy-ast-mutate-attributes mes 'deltaTime prev-duration) res-lst))) ((ast? mes) (quantize-timing-step-recording-1 (cdr event-ast-lst) prev-duration (cons mes res-lst))) (else (quantize-timing-step-recording-1 (cdr event-ast-lst) prev-duration res-lst))))))

(define (rtm smf-ast) (apply-to-tracks-top-level eliminate-channel-key-pressure (list #t) (apply-to-tracks-nested marker-silence (list 2000) (recording-to-motif-nested smf-ast))))

(define (recording-to-tyros smf-ast) (smf-to-format-0 'top-level (smf-to-ppqn 1920 'nested smf-ast)))

(define (apply-to-tracks-nested f f-parameter-list ast) (apply-to-tracks f f-parameter-list ast 'nested) )

(define (apply-to-tracks-top-level f f-parameter-list ast) (apply-to-tracks f f-parameter-list ast 'top-level) ) ; In this function, mode is either top-level or nested (a symbol).
(define (apply-to-tracks f f-parameter-list ast context-mode) (cond ; ast is format 0 StandardMidiFile
((and (equal? "StandardMidiFile" (ast-element-name ast)) (equal? "0" (ast-attribute (ast-subtree ast "MidiHeader") 'format))) (let* ((track-ast (ast-subtree ast "MidiTrack" 1)) (header-ast (ast-subtree ast "MidiHeader")) (track-messages (ast-subtrees track-ast))) (StandardMidiFile (if (eq? context-mode 'nested) (list 'internal:run-action-procedure "false") (list)) header-ast (MidiTrack (apply f (append f-parameter-list track-messages)))))) ; ast is format 1 StandardMidiFile
((and (equal? "StandardMidiFile" (ast-element-name ast)) (equal? "1" (ast-attribute (ast-subtree ast "MidiHeader") 'format))) (let* ((header-ast (ast-subtree ast "MidiHeader")) (track-ast-list (find-asts ast "MidiTrack")) ) (StandardMidiFile (if (eq? context-mode 'nested) (list 'internal:run-action-procedure "false") (list)) header-ast (map (lambda (track-ast) (MidiTrack (apply f (append f-parameter-list (ast-subtrees track-ast))))) track-ast-list)))) ; ast is MidiTrack
((equal? "MidiTrack" (ast-element-name ast)) (let ((track-messages (ast-subtrees ast))) (MidiTrack (apply f (append f-parameter-list track-messages))))) (else (laml-error "Must be called on a StandardMidiFile or MidiTrack ast"))))

;;; .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 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-comment-abs-time (xml-in-laml-positional-abstraction 1 0 (lambda (abs-time contents attr) (Meta 'absTime abs-time 'type 1 contents))))

(define midi-comment-delta-time (xml-in-laml-positional-abstraction 1 0 (lambda (delta-time contents attr) (Meta 'deltaTime delta-time 'type 1 contents))))

(define (midi-marker marker-txt . optional-parameter-list) (let ((marker-number (optional-parameter 1 optional-parameter-list 0)) (marker-letter (optional-parameter 2 optional-parameter-list "M")) ) (Meta 'deltaTime "0" 'type "6" (string-append marker-letter "-" (as-string marker-number) " " marker-txt))))

(define (midi-marker-abs-time abs-time marker-txt . optional-parameter-list) (let ((marker-number (optional-parameter 1 optional-parameter-list 0)) (marker-letter (optional-parameter 2 optional-parameter-list "M")) ) (Meta 'absTime (as-string abs-time) 'type "6" (string-append marker-letter "-" (as-string marker-number) " " marker-txt))))

(define (pan c value) (ControlChange 'deltaTime "0" 'channel c 'control "10" 'value value))

(define (volume c value) (ControlChange 'deltaTime "0" 'channel c 'control "7" 'value value))

(define (reverb c value) (ControlChange 'deltaTime "0" 'channel c 'control "91" 'value value))

(define (chorus c value) (ControlChange 'deltaTime "0" 'channel c 'control "93" '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 (voice-with-mix channel msb lsb program-number v p r c) (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) (volume channel v) (pan channel p) (reverb channel r) (chorus channel c) ) )

(define (gm-voice channel program) (cond ((number? program) (voice channel 0 0 program)) ((string? program) (let* ((gm-data-list (file-read (string-append midi-software-dir "data/general-midi-voices.dat"))) (res (find-in-list (lambda (entry) (equal? (downcase-string program) (downcase-string (get-gm-voice-name entry)))) gm-data-list))) (if res (voice channel 0 0 (get-gm-voice-pc res)) (let ((res (find-in-list (lambda (entry) (substring? (downcase-string (get-gm-voice-name entry)) (downcase-string program))) gm-data-list))) (if res (voice channel 0 0 (get-gm-voice-pc res)) (laml-error "gm-voice: Cannot make sense of program: " program)))))) (else (laml-error "gm-voice: The second parameter must be a pc-number of a voice name (a string)"))))

(define (voices-from-file . optional-parameter-list) (let* ((voice-file (optional-parameter 1 optional-parameter-list (source-filename-without-extension))) ; (string-append (startup-directory) (source-filename-without-extension))
(init-path (file-name-initial-path voice-file)) (voice-file-with-extension (string-append (file-name-proper voice-file) "." "voices")) (file-path (string-append (if (empty-string? init-path) (startup-directory) init-path) voice-file-with-extension)) (get-msb first) (get-lsb second) (get-pc third) (get-vol fifth) (get-pan sixth) (get-reverb seventh) (get-chorus eighth) ; local accessors - only used here, so waste to make them global.
) (if (file-exists? file-path) (let* ((voice-structure (file-read file-path))) (flatten (filter (lambda (x) x) (map2 (lambda (e ch) (if (not (eq? e 'nil)) (if (= (length e) 4) (voice ch (get-msb e) (get-lsb e) (get-pc e)) (voice-with-mix ch (get-msb e) (get-lsb e) (get-pc e) (get-vol e) (get-pan e) (get-reverb e) (get-chorus e))) #f)) (cdr voice-structure) ; first element is dummy
(number-interval 1 16) ; possible channel numbers
)))) (laml-error "voices-from-file: Non-exisisting voice file path: " file-path))))

(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 n0 duration base-tempo scale-fn . optional-parameter-list) (let* ((n (- n0 1)) (last-tempo (optional-parameter 1 optional-parameter-list #f))) (letrec ((make-function-domain-values ; produces length+1 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 n0)) ) (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 n0)) ) (map (lambda (unit-domain-value) (Meta 'deltaTime (as-int-string delta-dur) 'type "81" (tempo= (* base-tempo (scale-fn unit-domain-value)))) ) function-unit-domain-values)) ))))

(define (make-volume-change-list ch n0 duration start-volume scale-fn . optional-parameter-list) (let* ((n (- n0 1)) (end-volume (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 end-volume ; insert a forced end-volume 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 n0)) ) (append (map (lambda (unit-domain-value) (ControlChange 'deltaTime (as-int-string delta-dur) 'channel ch 'control "7" 'value (as-int-string (between 0 127 (* start-volume (scale-fn unit-domain-value))))) ) (butlast function-unit-domain-values)) ; notice butlast
(list ; the last forced volumne control event
(ControlChange 'deltaTime (as-int-string delta-dur) 'channel ch 'control "7" 'value (as-int-string (between 0 127 end-volume)))))) (let ((function-unit-domain-values (make-function-domain-values (+ n 1) (/ 1 n) 0)) (delta-dur (/ duration n0)) ) (map (lambda (unit-domain-value) (ControlChange 'deltaTime (as-int-string delta-dur) 'channel ch 'control "7" 'value (as-int-string (between 0 127 (* start-volume (scale-fn unit-domain-value))))) ) function-unit-domain-values)) )))) ; ---------------------------------------------------------------------------------------------------------------

;;; .section-id channel-repl-join-sel ;;; Channel replication, (copying), rechanneling, 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 replicate-by-predicate (xml-in-laml-positional-abstraction 2 0 (lambda (predicate ch-to cont attr) (replicate-by-predicate-1 predicate ch-to cont)))) (define (replicate-by-predicate-1 predicate ch-to message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if (and channel (predicate mes-ast)) (list ; the replication
mes-ast (copy-ast-mutate-attributes mes-ast 'channel ch-to) ) mes-ast)) mes-ast )) message-list))

(define replicate-by-predicate-and-transformation (xml-in-laml-positional-abstraction 2 0 (lambda (predicate transf cont attr) (replicate-by-predicate-and-transformation-1 predicate transf cont)))) (define (replicate-by-predicate-and-transformation-1 predicate transf message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if (and channel (predicate mes-ast)) (let ((the-transformation (transf mes-ast))) (cond ((ast? the-transformation) (list mes-ast (transf mes-ast))) ((list? the-transformation) (cons mes-ast the-transformation)) (else (laml-error "replicate-by-predicate-1: The transformation must return an AST, or a list of ASTs")))) 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 rechannel (xml-in-laml-positional-abstraction 1 0 (lambda (ch-map cont attr) (rechannel-1 ch-map cont)))) (define (rechannel-1 ch-map message-list) (map (lambda (mes-ast) (if (ast? mes-ast) (let ((channel (ast-attribute mes-ast 'channel #f))) (if channel (if (assoc (as-number channel) ch-map) (copy-ast-mutate-attributes mes-ast 'channel (cdr (assoc (as-number channel) ch-map))) mes-ast) mes-ast)) mes-ast)) message-list))

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

(define split-channel-by-predicate (xml-in-laml-positional-abstraction 4 0 (lambda (channel predicate channel-true channel-false cont attr) (split-channel-by-predicate-1 channel predicate channel-true channel-false cont)))) (define (split-channel-by-predicate-1 channel predicate channel-true channel-false message-list) (split-channel-by-predicate-2 channel predicate channel-true channel-false message-list '()) ) (define (split-channel-by-predicate-2 channel predicate channel-true channel-false message-list res-list) (cond ((null? message-list) (reverse res-list)) (else (let ((mes-ast (first message-list))) (if (ast? mes-ast) (if (and (NoteOn? mes-ast) (= channel (midi 'channel mes-ast))) (if (predicate mes-ast) (split-channel-by-predicate-2 channel predicate channel-true channel-false (cdr message-list) (cons (copy-ast-mutate-attributes mes-ast 'channel channel-true) res-list)) (split-channel-by-predicate-2 channel predicate channel-true channel-false (cdr message-list) (cons (copy-ast-mutate-attributes mes-ast 'channel channel-false) res-list))) (split-channel-by-predicate-2 channel predicate channel-true channel-false (cdr message-list) (cons mes-ast res-list))) (split-channel-by-predicate-2 channel predicate channel-true channel-false (cdr message-list) res-list))))))

(define split-channel-by-contextual-predicate (xml-in-laml-positional-abstraction 4 0 (lambda (channel predicate channel-true channel-false cont attr) (let ((behind-context (as-number (defaulted-get-prop 'behind-context attr 240))) (ahead-context (as-number (defaulted-get-prop 'ahead-context attr 240)))) (split-channel-by-contextual-predicate-1 channel predicate channel-true channel-false behind-context ahead-context cont))))) (define (split-channel-by-contextual-predicate-1 channel predicate channel-true channel-false behind-context ahead-context message-list) (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context message-list '() '()) ) (define (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context message-list past-list res-list) (cond ((null? message-list) (reverse res-list)) (else (let ((mes-ast (first message-list))) (if (ast? mes-ast) (if (and (NoteOn? mes-ast) (= channel (midi 'channel mes-ast))) (let* ((tm (as-number (ast-attribute mes-ast 'absTime))) (past-list (list-prefix-while past-list (lambda (n) (>= (midi 'absTime n) (- tm behind-context))))) (ahead-list (list-prefix-while message-list (lambda (n) (<= (midi 'absTime n) (+ tm ahead-context)))))) (display-message (length past-list) (length ahead-list)) (if (predicate mes-ast (filter (NoteOnCh? (list channel)) (append (reverse past-list) ahead-list))) (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context (cdr message-list) (cons mes-ast past-list) (cons (copy-ast-mutate-attributes mes-ast 'channel channel-true) res-list)) (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context (cdr message-list) (cons mes-ast past-list) (cons (copy-ast-mutate-attributes mes-ast 'channel channel-false) res-list)))) (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context (cdr message-list) (cons mes-ast past-list) (cons mes-ast res-list))) (split-channel-by-contextual-predicate-2 channel predicate channel-true channel-false behind-context ahead-context (cdr message-list) past-list res-list))))))

;;; .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 note phrases. ;;; The functions in this section generate - or help generate - list of notes. ;;; The most sophisticated is the function beat, which - typically, but not necessarily - generates 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 (regular-beats n ch note-value distance) (map (lambda (n) (NoteOn 'deltaTime distance 'channel ch 'note note-value 'velocity 127 'duration 100)) (number-interval 1 n)))

(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 events in the selected 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)))) ; ---------------------------------------------------------------------------------------------------------------

;;; Arpeggio splitting.

(define (split-arpeggio-recording source-file-path start-number target-dir-list . optional-parameter-list) (let* ((expected-length (optional-parameter 1 optional-parameter-list #f)) (given-number-interval (optional-parameter 2 optional-parameter-list #f)) (target-dir (first target-dir-list)) (trimmed-target-dir (second target-dir-list)) (meta-target-dir (third target-dir-list)) (midi-ast (midi-file-to-laml-ast source-file-path 'absTime 0 #f)) (midi-header (ast-subtree midi-ast "MidiHeader")) (track (ast-subtree midi-ast "MidiTrack")) (messages (ast-subtrees track)) (sections (sublist-by-predicate messages (lambda (ast prev-ast n) (ControlChange? ast 0)))) (sections-1 (cdr sections)) (sections-2 (map (lambda (section) (let* ((first-mes (first section)) (first-abs-time (midi 'absTime first-mes))) (time-displace (- first-abs-time) section))) sections-1)) (count (length sections-1)) ) (if (and expected-length (not (= expected-length count))) (laml-error "Expected length: " expected-length " Actual length: " count)) (if (and given-number-interval (not (= expected-length (length given-number-interval)))) (laml-error "The explicitly given list has length" (length given-number-interval) ". The expected length is" expected-length)) (for-each (lambda (section number) (let* ((arp-meta-data (get-arpeggio-meta-info number)) (a-length (arp-length arp-meta-data)) (a-time-sig-str (arp-time-sig arp-meta-data)) (a-time-sig-lst (parse-arp-time-signature a-time-sig-str)) ; to such as the list (4 4)
(nom (first a-time-sig-lst)) (denom (second a-time-sig-lst)) (target-file (string-append target-dir (as-string number) "." "mid")) (trimmed-target-file (string-append trimmed-target-dir (as-string number) "." "mid")) (total-length (total-length-of-message-list section)) (cc-and-pc-section (list-part 1 3 section)) (rest-section (cdr (cdr (cdr section)))) (first-abs-time (if (not (null? rest-section)) (midi 'absTime (first rest-section)) #f)) (time-displaced-rest-section (time-displace-1 (if first-abs-time (- 480 first-abs-time) 480) rest-section )) (trimmed-time-displaced-rest-section (filter (lambda (event-ast) (< (midi 'absTime event-ast) (+ 480 (* a-length nom (cond ((= denom 4) 480) ((= denom 8) 240) (else (laml-error "unsupported time sig"))))))) time-displaced-rest-section)) ) (if (file-exists? target-file) (delete-file target-file)) (if (file-exists? trimmed-target-file) (delete-file trimmed-target-file)) (analyze-arpeggio-for-recording-control! number time-displaced-rest-section arp-meta-data) (analyze-arpeggio-and-write-results! meta-target-dir number cc-and-pc-section trimmed-time-displaced-rest-section time-displaced-rest-section arp-meta-data) (write-text-file (standard-midi-file-ast-to-bin (StandardMidiFile 'internal:run-action-procedure "false" midi-header (MidiTrack (Meta 'absTime "0" 'type "81" (tempo= (arp-tempo arp-meta-data))) (midi-comment-abs-time 0 (string-append "Motif XS Arpeggio number " (as-string number))) cc-and-pc-section time-displaced-rest-section (Meta 'absTime (+ total-length 960) 'type "47" "") ))) target-file) (write-text-file ; Writes the trimmed section
(standard-midi-file-ast-to-bin (StandardMidiFile 'internal:run-action-procedure "false" midi-header (MidiTrack (Meta 'absTime "0" 'type "81" (tempo= (arp-tempo arp-meta-data))) (midi-comment-abs-time 0 (string-append "Motif XS Arpeggio number " (as-string number))) cc-and-pc-section trimmed-time-displaced-rest-section (Meta 'absTime (+ 480 (* a-length nom (cond ((= denom 4) 480) ((= denom 8) 240) (else (laml-error "unsupported time sig"))))) 'type "47" "") ))) trimmed-target-file) ) ) sections-2 (if given-number-interval given-number-interval (number-interval start-number (+ start-number count -1)))) ) )

(define (split-arpeggio-recording-via-pc-recording source-file-path start-number target-dir-list . optional-parameter-list) (let* ((expected-length (optional-parameter 1 optional-parameter-list #f)) (given-number-interval (optional-parameter 2 optional-parameter-list #f)) (target-dir (first target-dir-list)) (trimmed-target-dir (second target-dir-list)) (meta-target-dir (third target-dir-list)) (midi-ast (midi-file-to-laml-ast source-file-path 'absTime 0 #f)) (midi-header (MidiHeader 'format "0" 'numberOfTracks "1" 'pulsesPerQuarterNote "480" 'mode "absTime" 'counterTransposition "0")) (track (ast-subtree midi-ast "MidiTrack" 2)) ; track 2 because the recording happens to be a format 1 midi file.
(messages (ast-subtrees track)) (sections (sublist-by-predicate messages (lambda (ast prev-ast n) (ControlChange? ast 0)))) (sections-1 (cdr sections)) ; drop the first one
(sections-2 (map (lambda (section) (let* ((first-mes (first section)) (first-abs-time (midi 'absTime first-mes))) (time-displace (- first-abs-time) section))) sections-1)) (count (length sections-1)) ) (if (and expected-length (not (= expected-length count))) (laml-error "Expected length: " expected-length " Actual length: " count)) (if (and given-number-interval (not (= expected-length (length given-number-interval)))) (laml-error "The explicitly given list has length" (length given-number-interval) ". The expected length is" expected-length)) (for-each (lambda (section number) ; section is assumed to start with to ControlChange messages and one ProgramChange message.
(let* ((arp-meta-data (get-arpeggio-meta-info number)) (target-file (string-append target-dir (as-string number) "." "mid")) (total-length (total-length-of-message-list section)) (stretched-section (time-stretch-1 0.5 section)) ; go from ppqn 960 to 480
(cc-and-pc-section (list-part 1 3 stretched-section)) (rest-section (cdr (cdr (cdr stretched-section)))) (first-abs-time (if (not (null? rest-section)) (midi 'absTime (first rest-section)) #f)) ) (if (file-exists? target-file) (delete-file target-file)) (analyze-arpeggio-for-recording-control! number rest-section arp-meta-data) (write-text-file ; There are relevant NoteOn events in the selected channels
(standard-midi-file-ast-to-bin (StandardMidiFile 'internal:run-action-procedure "false" midi-header (MidiTrack (Meta 'absTime "0" 'type "81" (tempo= (arp-tempo arp-meta-data))) (midi-comment-abs-time 0 (string-append "Motif XS Arpeggio number " (as-string number))) cc-and-pc-section (time-displace-1 (if first-abs-time (- 480 first-abs-time) 480) rest-section ) (Meta 'absTime (+ total-length 960) 'type "47" "") ))) target-file) ) ) sections-2 (if given-number-interval given-number-interval (number-interval start-number (+ start-number count -1))) ) ) ) (define (analyze-arpeggio-for-recording-control! arp-number midi-event-list arp-meta-data) (let* ((midi-event-list-1 (filter ast? midi-event-list)) (a-length (arp-length arp-meta-data)) (a-time-sig-str (arp-time-sig arp-meta-data)) (a-time-sig-lst (parse-arp-time-signature a-time-sig-str)) ; to such as (4 4)
(nom (first a-time-sig-lst)) (denom (second a-time-sig-lst)) (last-abs-time (ast-attribute (last midi-event-list-1) 'absTime)) (ppqn 480) ) (cond ((= denom 4) (let ((required-length (* nom ppqn a-length)) (actual-length (- (as-number last-abs-time) 480))) (display-message (string-append (as-string arp-number) ": " (if (> required-length actual-length) "!!" " ") "Required length: " a-time-sig-str " " (as-string required-length ) ". " "Actual length: " (as-string actual-length))))) ((= denom 8) (let ((required-length (* nom (/ ppqn 2) a-length)) (actual-length (- (as-number last-abs-time) 480))) (display-message (string-append (as-string arp-number) ": " (if (> required-length actual-length) "!!" " ") "Required length: " "(" a-time-sig-str ")" " " (as-string required-length ) ". " "Actual length: " (as-string actual-length))))) (else (display-message "Non-fit"))))) ; Format of arp analysis meta data: ; (long-enough msb-lsb-pc-voice-info-list number-of-notes number-of-different-notes pc-exprcc-pitchbend-list)
(define (analyze-arpeggio-and-write-results! target-dir arp-number cc-pc-events trimmed-midi-event-list untrimmed-midi-event-list arp-meta-data) (let* ( (nil-if-false (lambda (x) (if (and (boolean? x) (not x)) 'nil 't))) (midi-event-list-1 (filter ast? trimmed-midi-event-list)) (a-length (arp-length arp-meta-data)) (a-time-sig-str (arp-time-sig arp-meta-data)) (a-time-sig-lst (parse-arp-time-signature a-time-sig-str)) ; to such as (4 4)
(nom (first a-time-sig-lst)) (denom (second a-time-sig-lst)) (last-abs-time (ast-attribute (last untrimmed-midi-event-list) 'absTime)) (ppqn 480) (required-length (* nom ppqn a-length)) (actual-length (- (as-number last-abs-time) 480)) (msb-lsb-pc (find-instrument-info-of 1 cc-pc-events)) ; first parameter: channel: all arps are recorded to channel 1.
(number-of-notes (length (filter (lambda (x) (and (ast? x) (equal? "NoteOn" (ast-element-name x)))) midi-event-list-1))) (number-of-different-notes (count-number-of-different-notes midi-event-list-1)) (program-control-changes (program-control-change-info cc-pc-events midi-event-list-1)) ) (let ((result (list (nil-if-false (<= required-length actual-length)) msb-lsb-pc number-of-notes number-of-different-notes program-control-changes ) ) (target-file (string-append target-dir (as-string arp-number) "." "dat")) ) (if (file-exists? target-file) (delete-file target-file)) (file-write result target-file) ) ) ) (define (parse-arp-time-signature time-sig-str) (map as-number (split-string-by-predicate time-sig-str (lambda (ch) (eqv? ch #\/))))) (define cached-arpeggio-list #f) (define (get-arpeggio-meta-info arp-number) (if cached-arpeggio-list (list-ref cached-arpeggio-list (- arp-number 1)) (let ((arp-info-list (file-read (string-append midi-software-dir "data/Motif-xs-arps.dat")))) (set! cached-arpeggio-list arp-info-list) (list-ref arp-info-list (- arp-number 1))))) ; Arp selectors
(define arp-main-cat (make-selector-function 1 "arp-main-cat")) (define arp-sub-cat (make-selector-function 2 "arp-sub-cat")) (define arp-number (make-selector-function 3 "arp-number")) (define arp-role (make-selector-function 4 "arp-role")) (define arp-name (make-selector-function 5 "arp-name")) (define arp-generation (make-selector-function 6 "arp-generation")) (define arp-time-sig (make-selector-function 7 "arp-time-sig")) (define arp-length (make-selector-function 8 "arp-lenght")) (define arp-tempo (make-selector-function 9 "arp-tempo")) (define arp-accent? (make-selector-function 10 "arp-accent?")) (define arp-random-sfx? (make-selector-function 11 "arp-random-sfx?")) (define arp-voice (make-selector-function 12 "arp-voice")) (define arp-voice-specific (make-selector-function 13 "arp-voice-specific")) ; ---------------------------------------------------------------------------------------------------------------

;;; .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) ","))) ; --------------------------------------------------------------------------------------------------------------- ; Drum map - categorization of drum note values.
; Drum map vector, starting at index 13
(define drum-map-vector #(latin-percussion latin-percussion others others others others others ; 13 -19
others others others others others snare-drum snare-drum snare-drum snare-drum snare-drum ; 20 - 29
latin-high-pitch snare-drum others bass-drum snare-drum bass-drum bass-drum snare-drum snare-drum others ; 30 - 39
snare-drum tom hi-hat tom hi-hat tom hi-hat tom tom crash-cymbal ; 40 - 49
tom ride-cymbal cymbal ride-cymbal others cymbal others crash-cymbal others ride-cymbal ; 50 - 59
latin-percussion latin-percussion latin-percussion latin-percussion latin-percussion ; 60 - 64
latin-percussion latin-percussion latin-high-pitch latin-high-pitch latin-high-pitch ; 66 - 69
latin-high-pitch latin-high-pitch latin-high-pitch latin-high-pitch latin-high-pitch ; 70 - 74
latin-high-pitch latin-high-pitch latin-high-pitch latin-high-pitch latin-high-pitch ; 75 - 79
others others latin-high-pitch others others ; 80 - 84
others others others undefined undefined others others ; 85 - 91
) )

(define (drum-category-of-note-value note-value) (if (and (>= note-value 13) (<= note-value 91)) (vector-ref drum-map-vector (- note-value 13)) 'undefined)) ; ---------------------------------------------------------------------------------------------------------------
; A function used internally by a MIDL template, as used by MIDI LAML Emacs list support - for playing including the fixed part.
(define (get-fixed-part-from-to-abstime the-fixed-part-full-path first-abs-time last-abs-time) (let* ((fixed-part-ast-list (map uncompact-midi-laml-entry (file-read the-fixed-part-full-path)))) (filter-messages-1 (lambda (m) (and (>= (midi 'absTime m) first-abs-time) (<= (midi 'absTime m) last-abs-time))) fixed-part-ast-list) ) ) ; Returns the ending part of Emacs MIDI LAML sectional playing. Used in some of the MIDI LAML templates.
(define (end-sectional-playing delta-time) (list (midi-comment-delta-time delta-time "Ending part starts here") ; Reset sustain in all channels
(map (lambda (ch) (ControlChange 'deltaTime "0" 'channel ch 'control "64" 'value "0")) (number-interval 1 16)) ; End of track message
(Meta 'deltaTime "10" 'type "47" "") ) )