RTM-Quantizer

;;********************************************

;;////////////////////////////////////////////

;;Quantize Time-Onsets into RTM

;;////////////////////////////////////////////

;;Mauricio Rodriguez - 2007

;;////////////////////////////////////////////

;;marod@ccrma.stanford.edu

;;////////////////////////////////////////////

;;********************************************

******************************

Use and copying of this software and preparation of derivative works

based upon this software are prohibited unless permission of the author.

Suggestions, comments and bug reports are welcome. Please address email to:

marod@ccrma.stanford.edu

******************************

;;Main:

;; quantize-to-pwgl [beats-per-measure rhythmic-pattern]

;;(quantize-to-pwgl '(4) '(0.0 0.6 1.0 2.2))

;;Code:

(defun subdivision-list (n)

(let ((ratio (/ 1.0 n)))

(loop for x from 0 to n collect (* x ratio))))

;;(subdivision-list 16)

(defun absolute-difference (value list)

(mapcar #'(lambda (x) (abs (- value x))) list))

(defun absolute-difference (value list)

(apply #'min (mapcar #'(lambda (x) (abs (- value x)))

list)))

(defun absolute-difference-in-lists (rhythmic-list subdivision-list)

(loop for x in rhythmic-list collect (absolute-difference x subdivision-list)))

(defun minimal-deviation-sieve* (rhythmic-pattern-list)

(do ((current-subdivision

(loop for x from 8 to 16 collect x)

(rest current-subdivision))

(output nil (cons

(list (first current-subdivision)

(apply #'+ (absolute-difference-in-lists

rhythmic-pattern-list

(subdivision-list

(first current-subdivision)))))

output)))

((endp current-subdivision) (reverse output))))

(defun minimal-deviation-sieve* (rhythmic-pattern-list)

(do ((current-subdivision

(loop for x from 1 to 100 collect x)

(rest current-subdivision))

(output nil (cons

(list (first current-subdivision)

(apply #'+ (absolute-difference-in-lists

rhythmic-pattern-list

(subdivision-list

(first current-subdivision)))))

output)))

((endp current-subdivision) (reverse output))))

(defun minimal-deviation-sieve (rhythmic-pattern-list)

(do ((current-subdivision

(loop for x from 1 to 100 collect x)

(rest current-subdivision))

(output nil (cons

(apply #'+ (absolute-difference-in-lists

rhythmic-pattern-list

(subdivision-list

(first current-subdivision))))

output)))

((endp current-subdivision) (reverse output))))

(defun minimal-deviation-sieve* (rhythmic-pattern-list)

(do ((current-subdivision

(loop for x from 1 to 16 collect x)

(rest current-subdivision))

(output nil (cons

(list (first current-subdivision)

(apply #'+ (absolute-difference-in-lists

rhythmic-pattern-list

(subdivision-list

(first current-subdivision)))))

output)))

((endp current-subdivision) (reverse output))))

(defun minimal-deviation-sieve (rhythmic-pattern-list)

(do ((current-subdivision

(loop for x from 1 to 16 collect x)

(rest current-subdivision))

(output nil (cons

(apply #'+ (absolute-difference-in-lists

rhythmic-pattern-list

(subdivision-list

(first current-subdivision))))

output)))

((endp current-subdivision) (reverse output))))

;;////////////////////////////////////////////

;; To add fitting function:

;;////////////////////////////////////////////

(defun fitting-function (n)

(loop for x from 1 to n collect (/ .25 x)))

(defun fitting-function (n)

(loop for x from 2 to n collect (/ 2.0 x)))

(defun fitting-deviation-difference (rhythmic-pattern-list)

(do ((index

(loop for x from 1 to 100

collect x)

(rest index))

(fitting

(fitting-function 100)

(rest fitting))

(deviation

(minimal-deviation-sieve rhythmic-pattern-list)

(rest deviation))

(output

nil

(cons (list (first index)

(- (first fitting) (first deviation)))

output)))

((or (endp index)

(endp fitting)

(endp deviation))

(reverse output))))

(defun fitting-deviation-difference (rhythmic-pattern-list)

(do ((index

(loop for x from 1 to 100

collect x)

(rest index))

(fitting

(loop for x from 1 to 100 collect (/ (/ (- (length rhythmic-pattern-list) 2) 4.0) x))

(rest fitting))

(deviation

(minimal-deviation-sieve rhythmic-pattern-list)

(rest deviation))

(output

nil

(cons (list (first index)

(- (first fitting) (first deviation)))

output)))

((or (endp index)

(endp fitting)

(endp deviation))

(reverse output))))

(defun fitting-deviation-difference (rhythmic-pattern-list)

(do ((index

(loop for x from 1 to 16

collect x)

(rest index))

(fitting

(loop for x from 1 to 16 collect (/ (/ (- (length rhythmic-pattern-list) 2) 4.0) x))

(rest fitting))

(deviation

(minimal-deviation-sieve rhythmic-pattern-list)

(rest deviation))

(output

nil

(cons (list (first index)

(- (first fitting) (first deviation)))

output)))

((or (endp index)

(endp fitting)

(endp deviation))

(reverse output))))

(defun search-max-in-compound-list (max list)

(loop for x in list

for y = (second x)

when (= max y )

return (first x)))

(defun search-max-in-compound-list (list)

(let ((maxima

(apply #'max (loop for z in list

collect (second z)))))

(loop for x in list

for y = (second x)

when (= maxima y )

return (first x))))

(defun offset-list (list offset-value)

(mapcar #'(lambda (x) (+ x offset-value))

list))

(defun quantize-rhythm* (event-list)

(search-max-in-compound-list

(mapcar #'list

(loop for x from 1 to 100

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference event-list)

collect (second x))

(offset-list (minimal-deviation-sieve event-list) 0.005)))))

(defun quantize-rhythm* (event-list)

(search-max-in-compound-list

(rest (mapcar #'list

(loop for x from 1 to 100

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference event-list)

collect (second x))

(offset-list (minimal-deviation-sieve event-list) 0.005))))))

(defun quantize-rhythm* (event-list)

(if (equal event-list '(0.0 1.0))

(search-max-in-compound-list

(rest (mapcar #'list

(loop for x from 1 to 100

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference event-list)

collect (second x))

(offset-list (minimal-deviation-sieve event-list) 0.005)))))))

(defun quantize-rhythm* (event-list)

(if (equal event-list '(0.0 1.0))

(search-max-in-compound-list

(rest (mapcar #'list

(loop for x from 1 to 16

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference event-list)

collect (second x))

(offset-list (minimal-deviation-sieve event-list) 0.005)))))))

(search-max-in-compound-list

(rest (mapcar #'list

(loop for x from 1 to 100

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference '(0.0 0.063 1.0))

collect (second x))

(offset-list (minimal-deviation-sieve '(0.0 0.063 1.0)) 0.005)))))

(search-max-in-compound-list

(rest (mapcar #'list

(loop for x from 1 to 100

collect x)

(mapcar #'/

(loop for x in (fitting-deviation-difference '(0.0 0.05 1.0))

collect (second x))

(offset-list (minimal-deviation-sieve '(0.0 0.05 1.0)) 0.005)))))

;;////////////////////////////////////////////

;;Quantify and get beat proportions:

;;////////////////////////////////////////////

(defun build-difference (value list)

(mapcar #'(lambda (x) (list x (abs (- value x)))) list))

(defun search-min-in-compound-list (list)

(let ((minima

(apply #'min (loop for z in list

collect (second z)))))

(loop for x in list

for y = (second x)

when (= minima y )

return (first x))))

(defun rhythmic-approximation* (rhythmic-pattern rhythmic-reservoir)

(if (endp rhythmic-pattern)

nil

(cons

(search-min-in-compound-list

(build-difference

(first rhythmic-pattern)

rhythmic-reservoir))

(rhythmic-approximation* (rest rhythmic-pattern) rhythmic-reservoir))))

(defun rhythmic-approximation (rhythmic-pattern)

(rhythmic-approximation*

rhythmic-pattern

(subdivision-list

(search-max-in-compound-list

(rest (fitting-deviation-difference rhythmic-pattern))))))

(defun rhythmic-approximation (rhythmic-pattern)

(rhythmic-approximation*

rhythmic-pattern

(subdivision-list

(quantize-rhythm* rhythmic-pattern))))

;;(rhythmic-approximation '(0.0 0.21 0.42 1.0))

;;(rhythmic-approximation '(0.0 0.21 0.42 0.6 1.0))

;;(rhythmic-approximation '(0.0 0.1429 1.0))

(defun make-pairs* (list)

(if (endp list)

nil

(cons (List (first list) (second list))

(make-pairs* (rest list)))))

(defun make-pairs (list)

(let ((current-list (make-pairs* list)))

(loop for x in current-list

when (not (equal (second x) nil))

collect x)))

(defun pair-difference (x y)

(abs (- x y)))

(defun list-difference (list)

(mapcar #'(lambda (x) (pair-difference (first x) (second x))) (make-pairs list)))

(defun beat-approximation* (pattern subdivision-ratio)

(let ((current-pattern (list-difference pattern)))

(loop for x in current-pattern

collect (round (/ x subdivision-ratio)))))

(defun beat-approximation (pattern subdivision-ratio)

(let ((check-beat-approximation (beat-approximation* pattern subdivision-ratio)))

(loop for x in check-beat-approximation

when (/= 0 x)

collect x)))

(defun quantize-pattern (rhythmic-pattern)

(beat-approximation

(rhythmic-approximation

rhythmic-pattern)

(/ 1.0

(search-max-in-compound-list

(rest (fitting-deviation-difference rhythmic-pattern))))))

(defun quantize-pattern (rhythmic-pattern)

(beat-approximation

(rhythmic-approximation

rhythmic-pattern)

(/ 1.0 (quantize-rhythm* rhythmic-pattern))))

;;////////////////////////////////////////////

;; To build RTM:

;;////////////////////////////////////////////

(defun events-and-markers (event-list)

(let* ((markers (loop for x from 0.0 to (ceiling (first (last event-list)))

collect (float x)))

(compound-list (remove-duplicates (sort (append event-list markers) #'<))))

compound-list))

(defun mark-events* (event-list)

(let* ((markers (loop for x from 0.0 to (ceiling (first (last event-list)))

collect (float x)))

(compound-list (remove-duplicates (sort (append event-list markers) #'<))))

(do ((current-compound-list compound-list (rest current-compound-list))

(output nil (if (find (first current-compound-list) event-list)

(cons (list (first current-compound-list) 0)

output)

(cons (list (first current-compound-list) 1)

output))))

((endp current-compound-list) (reverse output)))))

(defun mark-events (event-list)

(mark-events* (append event-list (list (float (ceiling (first (last event-list))))))))

(defun get-tied-beats* (marked-events)

(let ((beats (loop for x from 0.0 to (first (first (last marked-events)))

collect x)))

(loop for alpha in (loop for x in beats

collect (loop for y in marked-events

when (equal x (first y))

collect (second y)))

append alpha)))

(defun tie-indexing (rhythmic-pattern)

(butlast

(get-tied-beats*

(mark-events rhythmic-pattern))))

(defun pseudo-integer-p (number)

(if (= (- number (truncate number)) 0)

nil))

(defun gather-until-pseudo-integer (list)

(if (or (endp list) (pseudo-integer-p (first list)))

nil

(cons (first list)

(gather-until-pseudo-integer (rest list)))))

(defun collect-within-range (low high list)

(loop for x in list

when (and (>= x low)

(<= x high))

collect x))

(defun split-by-beats (list)

(do ((low -1.0 (incf low))

(high 0.0 (incf high))

(output nil (cons (collect-within-range low high list)

output)))

((equal high (first (last list))) (reverse output))))

(defun normalize-list-member (list)

(if (= (apply #'max list) 1.0)

list

(mapcar #'(lambda (x) (- x (- (apply #'max list) 1.0)))

list)))

(defun normalize-list (list)

(loop for x in list

collect (normalize-list-member x)))

(defun normalize-rhtyhm (rhythmic-pattern)

(normalize-list

(split-by-beats

(events-and-markers rhythmic-pattern))))

(defun quantizer* (rhythmic-pattern)

(let ((ties (tie-indexing rhythmic-pattern)))

(list (loop for x in (normalize-rhtyhm rhythmic-pattern)

collect (quantize-pattern x))

ties)))

(defun quantizer** (rhythmic-pattern)

(let ((ties (tie-indexing rhythmic-pattern)))

(list (loop for x in (normalize-rhtyhm rhythmic-pattern)

collect (quantize-pattern x))

ties)))

(defun quantizer* (list)

(if (= 0 (- (first (last list)) (ceiling (first (last list)))))

(quantizer** (append list (list (+ 1.0 (first (last list))))))

(quantizer** list)))

(defun convert-to-tied (list index)

(if (= index 0)

list

(cons (* (first list) 1.0) (rest list))))

(defun quantize-to-simple-rtm (rhythmic-pattern)

(let ((rtm-and-ties (quantizer* rhythmic-pattern)))

(do ((current-rtm-cells (first rtm-and-ties) (rest current-rtm-cells))

(current-tie-indexing (second rtm-and-ties) (rest current-tie-indexing))

(output nil (cons (convert-to-tied (first current-rtm-cells)

(first current-tie-indexing))

output)))

((endp current-rtm-cells) (reverse output)))))

;;(quantize-to-simple-rtm '(0.0 0.6 1.0 2.2))

(defun take-n (n list)

(if (or (= n 0) (endp list))

nil

(cons (first list) (take-n (1- n) (rest list)))))

(defun clon-n (n element)

(if (= n 0)

nil

(cons element (clon-n (decf n) element))))

(defun chain-rest (n list)

(let ((difference-value (- n (length list))))

(append list (clon-n difference-value '(-1)))))

(defun group-measures* (beats-per-measure-list list)

(do ((current-beat-list

beats-per-measure-list

(if (= (length current-beat-list) 1)

beats-per-measure-list

(rest current-beat-list)))

(current-list

list

(nthcdr (first current-beat-list) current-list))

(output

nil

(cons (take-n (first current-beat-list) current-list) output)))

((endp current-list) (reverse output))))

(defun group-measures (beats-per-measure-list list)

(let ((group-list (group-measures* beats-per-measure-list list)))

(do ((current-beat-list

beats-per-measure-list

(if (= (length current-beat-list) 1)

beats-per-measure-list

(rest current-beat-list)))

(current-list

group-list

(rest current-list))

(output

nil

(cons (chain-rest (first current-beat-list) (first current-list)) output)))

((endp current-list) (reverse output)))))

(defun make-rtm-beat (list)

(if (endp list)

nil

(cons (list 1 (first list))

(make-rtm-beat (rest list)))))

(defun make-rtm-measure (list)

(mapcar #'(lambda (x) (make-rtm-beat x))

list))

(defun quantize-to-pwgl (beats-per-measure rhythmic-pattern)

(make-rtm-measure

(group-measures

beats-per-measure

(quantize-to-simple-rtm rhythmic-pattern))))

;;(quantize-to-pwgl '(4) '(0.0 0.6 1.0 2.2))

(quantize-to-pwgl '(4)

0.0

1.615487528

1.766258503

2.284195011

2.887165532

4.676689342

4.84340136

4.994217687

5.311337868

5.613673469

5.947256235

6.414693877

6.900521541

7.439387755

8.289863945

9.359183673

9.476984126

9.861405895

))

;;To load delta time in LispWorks

(defun choose-file-dialog (&key (prompt "Open file") (operation :open))

(let ((screen (capi:convert-to-screen)))

(capi:screen-width screen)

(capi:screen-height screen)

(capi:prompt-for-file prompt

:operation operation

:owner screen

:filters '("All Files" "*.*"))))

(defvar *time-points* nil)

(defun load-delta-time ()

(setf *time-points* (fibo-process-starting-at-zero

(with-open-file (input (choose-file-dialog)

:direction :input)

(read-from input)))))

(defun read-from (stream)

(let ((this-object (read stream nil)))

(unless (not this-object)

(cons this-object

(read-from stream)))))

(defun fibo-process-starting-at-zero (list)

(let ((fibo-process (do ((sum (first list) (+ sum (first local-list)))

(local-list (rest list) (rest local-list))

(output-list nil (cons sum output-list)))

((not local-list)

(reverse (cons (+ (first (last list))

(first output-list))

output-list))))))

(cons 0.0 (butlast fibo-process))))

(defun cleaning-taps (tap-list)

(if (endp tap-list)

nil

(cons (first tap-list)

(cleaning-taps (rest tap-list)))))

;;(load-delta-time)

(defun current-delta-time ()

*time-points*)

(defun tolerance-check (value reference tolerance)

(if (>= (abs (- value reference)) tolerance)

value

reference))

(defun tolerance-check-in-list (value-list reference-list tolerance)

(loop for x in value-list

collect (loop for y in reference-list

collect (tolerance-check x y tolerance))))

;;(tolerance-check-in-list '(0.0 0.52 0.99 1.0 1.019 2.9719) '(0.0 1.0 2.0 3.0) 0.05)

(defun member-check (element list)

(let ((current-list list))

(if (equal 'nil (remove element current-list))

element

(first (remove element current-list)))))

(defun normalize-list-to-tolerance* (list tolerance)

(let ((markers (loop for x from (floor (first list)) to (ceiling (first (last list)))

collect (float x))))

(do ((current-list

list

(rest current-list))

(tolerance-list

(tolerance-check-in-list

list

markers

tolerance)

(rest tolerance-list))

(current-markers

markers

(rest current-markers))

(output

nil

(cons (member-check (first current-list)

(first tolerance-list))

output)))

((endp current-list) (reverse output)))))

;;(normalize-list-to-tolerance* '(0.0 0.52 0.99 1.0 1.019 2.9719) 0.05)

(defun normalize-list-to-tolerance (list tolerance)

(remove-duplicates (normalize-list-to-tolerance* list tolerance)))

;;(normalize-list-to-tolerance '(0.0 0.52 0.99 1.0 1.019 2.9719) 0.05)