RTM-Transcriptor

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

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

;;RTM Transcriptor

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

;;Mauricio Rodriguez - 2012

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

;;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:

;;rtm-encoder* [numeric-input]

;;(rtm-encoder* '4--16=5..4=3..2=1//11=7..3=5..4=1/1*4=/3)

;;Code:

(defun expand-symbol (symbol)

(read-from-string

(remove #\#

(remove #\\

(write-to-string

(coerce

(write-to-string symbol)

'list))))))

(defun expand-symbol* (symbol)

(read-from-string (remove #\# (remove #\\ (write-to-string (loop for x across (write-to-string symbol) collect x))))))

(defun collect-until-symbol* (symbol list)

(if (or (equal symbol (first list))

(endp list))

'nil

(cons (first list)

(collect-until-symbol* symbol (rest list)))))

(defun collect-until-symbol (symbol list)

(let ((until-symbol (collect-until-symbol* symbol list)))

(first

(read-from-string

(remove #\space

(write-to-string until-symbol))))))

(defun collect-after-symbol* (symbol list)

(cond ((endp list) 'nil)

((equal symbol (first list)) (rest list))

('t (collect-after-symbol* symbol (rest list)))))

(defun collect-after-symbol (symbol list)

(let ((after-symbol (collect-after-symbol* symbol list)))

(first

(read-from-string

(remove #\space

(write-to-string after-symbol))))))

(defun check-ratio-p (list)

(cond ((= (length list) 1) 'nil)

((and (equal (first list) '#\.) (equal (first list) (first (rest list)))) 't)

('t (check-ratio-p (rest list)))))

(defun split-input (sequence)

(let ((symbol-sequence

(read-from-string

(write-to-string

(coerce

(write-to-string sequence)

'list)))))

(do ((current-sequence symbol-sequence (collect-after-symbol* #\= current-sequence))

(output 'nil (cons (collect-until-symbol* '#\= current-sequence)

output)))

((null current-sequence) (reverse output)))))

(defun add-elements* (input)

(cond ((null input) 'nil)

((listp (first input)) (cons (first (first input)) (add-elements* (rest input))))

('t (cons (first input) (add-elements* (rest input))))))

(defun add-elements (input)

(apply #'+ (add-elements* input)))

(defun ratio-sum* (ratio-list input)

(cond ((null input) 'nil)

((every #'atom (first input)) (append (first input) (ratio-sum* ratio-list (rest input))))

('t (cons (first input) (ratio-sum* ratio-list (rest input))))))

(defun ratio-sum** (ratio-list input)

(let ((sum (ratio-sum* ratio-list input)))

(when (equal (second ratio-list) (add-elements sum))

(list (third ratio-list) sum))))

(defun ratio-sum (list)

(let ((sum (ratio-sum** (first list) (rest list))))

(if sum

sum

list)))

(defun symbol-check (symbol input)

(cond ((listp input) (if (member symbol input :test #'equal)

'nil))

('t (if (equal symbol input)

'nil))))

(defun ratio-split-analysis* (list)

(cond ((null list) 'nil)

((not (some #'(lambda (x) (symbol-check 'ratio x)) (rest list))) (cons (first list) (rest list)))

('t (ratio-split-analysis* (rest list)))))

(defun ratio-split-synthesis* (list)

(cond ((null list) 'nil)

((not (some #'(lambda (x) (symbol-check 'ratio x)) (rest list))) 'nil)

('t (cons (first list) (ratio-split-synthesis* (rest list))))))

(defun ratio-sum-p (list-1 list-2)

(if (equal 'nil list-2)

'nil

(if (and (symbol-check 'ratio list-1) (not (symbol-check 'ratio list-2)) (every #'atom list-2))

(if (equal (second list-1) (apply #'+ list-2))

'nil)

'nil)))

(defun ratio-clean (list)

(cond ((null list) 'nil)

((ratio-sum-p (first list) (second list)) (cons (ratio-sum (list (first list) (second list)))

(ratio-clean (rest (rest list)))))

('t (cons (first list)

(ratio-clean (rest list))))))

(defun ratio-head-list-p (list)

(if (and (symbol-check 'ratio (first list)) (not (some #'(lambda (x) (symbol-check 'ratio x)) (rest list))))

'nil))

(defun ratio-completion* (limit subdivision list)

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

(accumulation 0 (if (every #'atom (first current-list))

(+ accumulation (apply '+ (first current-list)))

(+ accumulation (first (first current-list)))))

(output 'nil (if (every #'atom (first current-list))

(append (first current-list) output)

(cons (first current-list) output))))

((equal accumulation limit) (cons (list subdivision (reverse output)) current-list))))

;;Ratio completion to include grace-note values:

(defun ratio-completion* (limit subdivision list)

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

(accumulation 0 (cond ((every #'atom (first current-list))

(+ accumulation (apply '+ (first current-list))))

((not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(+ accumulation (first (first current-list))))

((and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4))

(+ accumulation (sum-grace-beat (first current-list))))

((and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4))

(+ accumulation (first (first current-list))))))

(output 'nil (cond ((or (every #'atom (first current-list))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4)))

(append (first current-list) output))

((not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(cons (first current-list) output))

((and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4))

(cons (first current-list) output)))))

((equal accumulation limit) (cons (list subdivision (reverse output)) current-list))))

(defun ratio-completion* (limit subdivision list)

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

(accumulation 0 (cond ((every #'atom (first current-list))

(+ accumulation (apply '+ (first current-list))))

((or (not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4)))

(+ accumulation (first (first current-list))))

((and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4))

(+ accumulation (sum-grace-beat (first current-list))))))

(output 'nil (cond ((or (every #'atom (first current-list))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4)))

(append (reverse (first current-list)) output))

((or (not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4)))

(cons (first current-list) output)))))

((equal accumulation limit) (cons (list subdivision (reverse output)) current-list))))

(defun absolute-sum (list)

(apply '+ (loop for x in list

collect (abs x))))

(defun ratio-completion* (limit subdivision list)

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

(accumulation 0 (cond ((every #'atom (first current-list))

(+ accumulation (absolute-sum (first current-list))))

((or (not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4)))

(+ accumulation (first (first current-list))))

((and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4))

(+ accumulation (sum-grace-beat (first current-list))))))

(output 'nil (cond ((or (every #'atom (first current-list))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(equal (n-nested-list* (first current-list)) 4)))

(append (reverse (first current-list)) output))

((or (not (symbol-check-flat-list ':grace-beat (flatten-list (first current-list))))

(and (symbol-check-flat-list ':grace-beat (flatten-list (first current-list)))

(> (n-nested-list* (first current-list)) 4)))

(cons (first current-list) output)))))

((= accumulation limit) (cons (list subdivision (reverse output)) current-list))))

(defun ratio-completion (list)

(ratio-completion* (second (first list)) (third (first list)) (rest list)))

(defun ratio-search-and-clean (list)

(do ((current-list list (if (ratio-head-list-p current-list)

'nil

(rest current-list)))

(output 'nil (if (ratio-head-list-p current-list)

(append (reverse (ratio-completion current-list)) output)

(cons (first current-list) output))))

((null current-list) (reverse output))))

(defun rtm-encoder (input)

(let ((list (clean-input input)))

(do ((current-list list (ratio-search-and-clean current-list)))

((not (some #'(lambda (x) (symbol-check 'ratio x)) current-list)) current-list))))

(defun tie-check* (list)

(cond ((null list) 'nil)

((equal (second list) '#\.) (cons (list (first list) (second list) '#\0) (tie-check* (rest list))))

((equal (first list) '#\.) (tie-check* (rest list)))

('t (cons (list (first list)) (tie-check* (rest list))))))

(defun tie-expander (sequence)

(let* ((splitting

(read-from-string

(write-to-string

(coerce

(write-to-string sequence)

'list))))

(tie-correction (mapcar #'(lambda (x) (read-from-string (remove #\space (remove #\| (remove #\# (remove #\\ (write-to-string x))))))) (tie-check* splitting))))

(loop for x in tie-correction

append x)))

(defun tie-expander (sequence)

(let ((tie-correction (mapcar #'(lambda (x) (read-from-string (remove #\space (remove #\| (remove #\# (remove #\\ (write-to-string x))))))) (tie-check* sequence))))

(loop for x in tie-correction

append x)))

(defun n-iterate (n value)

(loop repeat n

collect value))

(defun repeat-expander (list)

(cond ((null list) 'nil)

((equal (second list) '*) (append (n-iterate (third list) (first list))

(repeat-expander (rest (rest (rest list))))))

('t (cons (first list) (repeat-expander (rest list))))))

(defun gather-tenth* (list)

(if (not (equal '+ (first list)))

'nil

(cons (first list) (gather-tenth* (rest list)))))

(defun gather-tenth** (list)

(if (equal '+ (second list))

(first (read-from-string (remove #\space (write-to-string (list (first list) (length (gather-tenth* (rest list))))))))

list))

(defun remove-tenth* (list)

(if (not (equal (second list) '+))

(rest list)

(remove-tenth* (rest list))))

(defun remove-tenth (list)

(if (equal (second list) '+)

(remove-tenth* list)

list))

(defun gather-tenth (list)

(do ((current-list list (if (equal (second current-list) '+)

(remove-tenth current-list)

(rest current-list)))

(output 'nil (if (equal (second current-list) '+)

(cons (gather-tenth** current-list) output)

(cons (first current-list) output))))

((null current-list) (reverse output))))

(defun clean-zero (list)

(cond ((null list) 'nil)

((equal (second list) 0) (append (read-from-string (remove #\space (write-to-string (list (first list) (second list)))))

(clean-zero (rest (rest list)))))

('t (cons (first list)

(clean-zero (rest list))))))

(defun clean-rest (list)

(cond ((null list) 'nil)

((equal (first list) '-) (append (read-from-string (remove #\space (write-to-string (list (first list) (second list)))))

(clean-rest (rest (rest list)))))

('t (cons (first list)

(clean-rest (rest list))))))

(defun clean-ratio (list)

(cons 'ratio

(clean-zero

(gather-tenth

(repeat-expander

(read-from-string

(remove #\.

(remove #\#

(remove #\\

(write-to-string list))))))))))

(defun clean-input (input)

(let ((split-list (split-input input)))

(do ((current-list split-list (rest current-list))

(output

'nil

(if (check-ratio-p (first current-list))

(cons (clean-ratio (first current-list)) output)

(cons (clean-rest

(clean-zero

(gather-tenth

(repeat-expander

(tie-expander (first current-list)))))) output))))

((null current-list) (reverse output)))))

(defun clean-input* (input)

(let ((split-list (split-input input)))

(do ((current-list split-list (rest current-list))

(output

'nil

(if (check-ratio-p (first current-list))

(cons (clean-ratio (first current-list)) output)

(cons (gather-tenth

(repeat-expander

(clean-rest

(clean-zero

(tie-expander (first current-list)))))) output))))

((null current-list) (reverse output)))))

(defun time-signature-p (list)

(cond ((= (length list) 1) 'nil)

((and (equal (first list) '#\-) (equal (first list) (first (rest list)))) 't)

('t (time-signature-p (rest list)))))

(defun clean-time-signature (list)

(cons 'time-signature

(clean-zero

(gather-tenth

(repeat-expander

(read-from-string

(remove #\-

(remove #\#

(remove #\\

(write-to-string list))))))))))

(defun clean-input (input)

(let ((split-list (split-input input)))

(if (time-signature-p (first split-list))

(cons (clean-time-signature (first split-list))

(do ((current-list (rest split-list) (rest current-list))

(output

'nil

(if (check-ratio-p (first current-list))

(cons (clean-ratio (first current-list)) output)

(cons (gather-tenth

(repeat-expander

(clean-rest

(clean-zero

(tie-expander (first current-list)))))) output))))

((null current-list) (reverse output))))

(do ((current-list split-list (rest current-list))

(output

'nil

(if (check-ratio-p (first current-list))

(cons (clean-ratio (first current-list)) output)

(cons (gather-tenth

(repeat-expander

(clean-rest

(clean-zero

(tie-expander (first current-list)))))) output))))

((null current-list) (reverse output))))))

(defun group-slash (list)

(cond ((null list) 'nil)

((equal '/ (first list)) (cons (first list) (group-slash (rest list))))

('t 'nil)))

(defun group-slash (list)

(cond ((null list) 'nil)

((or (equal '/ (first list)) (equal '/.0 (first list))) (cons (first list) (group-slash (rest list))))

('t 'nil)))

(defun delete-slash (list)

(cond ((null list) 'nil)

((equal '/ (first list)) (delete-slash (rest list)))

('t list)))

(defun delete-slash (list)

(cond ((null list) 'nil)

((equal '/ (first list)) (delete-slash (rest list)))

('t (rest list))))

(defun delete-slash (list)

(cond ((null list) 'nil)

((or (equal '/ (first list)) (equal '/.0 (first list))) (delete-slash (rest list)))

('t (rest list))))

(defun slash-grouping (list)

(cond ((null list) 'nil)

((not (equal '/ (first list))) (cons 'nil (slash-grouping (rest list))))

('t (cons (group-slash list) (slash-grouping (delete-slash list))))))

(defun slash-grouping (list)

(cond ((null list) 'nil)

((and (not (equal '/ (first list))) (not (equal '/.0 (first list)))) (cons 'nil (slash-grouping (rest list))))

('t (cons (group-slash list) (slash-grouping (delete-slash list))))))

(defun clean-slash (list)

(cond ((null list) 'nil)

((not (equal '/ (first list))) (cons (first list) (clean-slash (rest list))))

('t (clean-slash (rest list)))))

(defun clean-slash (list)

(cond ((null list) 'nil)

((and (not (equal '/ (first list))) (not (equal '/.0 (first list)))) (cons (first list) (clean-slash (rest list))))

('t (clean-slash (rest list)))))

(defun slash-count (list)

(cond ((null list) nil)

((equal 'nil (first list)) (cons 0 (slash-count (rest list))))

(t (cons (length (first list)) (slash-count (rest list))))))

(defun grace-group-translator (grace-group)

(cond ((null grace-group) 'nil)

((equal '/ (first grace-group)) (cons 1 (grace-group-translator (rest grace-group))))

((equal '/.0 (first grace-group)) (cons 1.0 (grace-group-translator (rest grace-group))))))

(defun grace-note-structure (index)

(let* ((iteration (truncate index))

(group (loop repeat iteration

with x = 1

collect x)))

(if (floatp index)

(list (list 1 group ':class ':grace-beat) 1.0)

(list (list 1 group ':class ':grace-beat) 1))))

(defun grace-note-structure (grace-group value)

(let ((grouping (grace-group-translator grace-group)))

(if (floatp value)

(list (list 1 grouping ':class ':grace-beat) 1.0)

(list (list 1 grouping ':class ':grace-beat) 1))))

(defun grace-note-constructor* (rhythm-list index-list)

(do ((current-rhythm rhythm-list (rest current-rhythm))

(current-index index-list (rest current-index))

(output nil (cond ((and (> (first current-index) 0) (integerp (first current-rhythm)))

(cons (list (first current-rhythm) (grace-note-structure (first current-index))) output))

((and (> (first current-index) 0) (floatp (first current-rhythm)))

(cons (list (truncate (first current-rhythm)) (grace-note-structure (float (first current-index)))) output))

(t (cons (first current-rhythm) output)))))

((or (endp current-rhythm)

(endp current-index))

(reverse output))))

(defun grace-note-constructor* (rhythm-list index-list)

(do ((current-rhythm rhythm-list (rest current-rhythm))

(current-index index-list (rest current-index))

(output nil (cond ((and (not (equal (first current-index) 'nil)) (integerp (first current-rhythm)))

(cons (list (first current-rhythm) (grace-note-structure (first current-index) (first current-rhythm))) output))

((and (not (equal (first current-index) 'nil)) (floatp (first current-rhythm)))

(cons (list (truncate (first current-rhythm)) (grace-note-structure (first current-index) (first current-rhythm))) output))

(t (cons (first current-rhythm) output)))))

((or (endp current-rhythm)

(endp current-index))

(reverse output))))

(defun grace-note-constructor (list)

(let ((rhythm-list (clean-slash list))

(index-list (slash-count (slash-grouping list))))

(grace-note-constructor* rhythm-list index-list)))

(defun grace-note-constructor (list)

(let ((rhythm-list (clean-slash list))

(index-list (slash-grouping list)))

(grace-note-constructor* rhythm-list index-list)))

(defun slash-check (list)

(some #'(lambda (x) (equal '/ x)) list))

(defun slash-check (list)

(some #'(lambda (x) (or (equal '/ x) (equal '/.0 x))) list))

(defun grace-note-check (list)

(cond ((null list) nil)

((slash-check (first list)) (cons (grace-note-constructor (first list)) (grace-note-check (rest list))))

(t (cons (first list) (grace-note-check (rest list))))))

(defun flatten-list (list)

(cond ((null list) nil)

((listp (first list))

(append (flatten-list (first list))

(flatten-list (rest list))))

(t (cons (first list)

(flatten-list (rest list))))))

(defun symbol-check-flat-list (symbol list)

(if (member symbol list)

nil))

(defun sum-grace-beat* (list)

(cond ((null list) nil)

((atom (first list)) (cons (first list) (sum-grace-beat* (rest list))))

(t (cons (first (first list)) (sum-grace-beat* (rest list))))))

(defun sum-grace-beat (list)

(apply #'+ (sum-grace-beat* list)))

(defun sum-grace-beat (list)

(absolute-sum (sum-grace-beat* list)))

(defun n-nested-list (input)

(if (not (listp input)) nil (n-nested-list* input)))

(defun n-nested-list* (list)

(cond ((endp list) 0)

((listp (first list)) (+ 1 (n-nested-list* (first list))))

(t (n-nested-list* (rest list)))))

(defun n-nested-list-p* (n list)

(if (= n (n-nested-list list)) t nil))

(defun n-nested-list-p (n input)

(if (not (listp input)) nil (n-nested-list-p* n input)))

(defun grace-beat-rest (input)

(list (abs (first input)) (append (butlast (second input)) (list (* (first (last (second input))) -1)))))

(defun recursive-grace-beat (input)

(cond ((null input) 'nil)

((and (atom (first input)) (< (first input) 0) (n-nested-list-p 3 input)) (grace-beat-rest input))

((atom (first input)) (cons (first input) (recursive-grace-beat (rest input))))

((and (listp (first input)) (symbol-check ':grace-beat (flatten-list (first input))) (not (n-nested-list-p 3 (first input)))) (cons (recursive-grace-beat (first input))

(recursive-grace-beat (rest input))))

((and (listp (first input)) (n-nested-list-p 3 (first input)) (> (first (first input)) 0)) (cons (first input) (recursive-grace-beat (rest input))))

((and (listp (first input)) (n-nested-list-p 3 (first input)) (< (first (first input)) 0)) (cons (grace-beat-rest (first input)) (recursive-grace-beat (rest input))))

('t (cons (first input) (recursive-grace-beat (rest input))))))

(defun rtm-encoder* (input)

(let* ((list (grace-note-check (clean-input input))))

(if (symbol-check 'time-signature (first list))

(list (first (do ((current-list (rest list) (ratio-search-and-clean current-list)))

((not (some #'(lambda (x) (symbol-check 'ratio x)) current-list)) current-list)))

':time-signature (list (second (first list)) (third (first list))))

(do ((current-list list (ratio-search-and-clean current-list)))

((not (some #'(lambda (x) (symbol-check 'ratio x)) current-list)) current-list)))))

(defun rtm-encoder* (input)

(let* ((list (recursive-grace-beat (grace-note-check (clean-input input)))))

(if (symbol-check 'time-signature (first list))

(list (first (do ((current-list (rest list) (ratio-search-and-clean current-list)))

((not (some #'(lambda (x) (symbol-check 'ratio x)) current-list)) current-list)))

':time-signature (list (second (first list)) (third (first list))))

(do ((current-list list (ratio-search-and-clean current-list)))

((not (some #'(lambda (x) (symbol-check 'ratio x)) current-list)) current-list)))))

;;(list (list (list (rtm-encoder* '5..4=3..2=111=7..3=5..4=11111=3))))

;;(list (list (list (rtm-encoder* '4..3=3..1=111=1=5..1=21=3..1=111=1=1))))

;;(rtm-encoder* '3..3=2=3..1=111)

;;(rtm-encoder* '4..4=1=2=1)

;;(rtm-encoder* '3..3=2=3..1=1//1/1)

;;(rtm-encoder* '5..4=3..2=1//11=7..3=5..4=1/1*4=/3)

;;(rtm-encoder* '4--16=5..4=3..2=1//11=7..3=5..4=1/1*4=/3)