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

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

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

;;Lisp Additive Synthesis Tool - LAST

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

;;Mauricio Rodriguez - 2011

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

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

marod@ccrma.stanford.edu

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

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

|#

(make-package :last)

(in-package :last)

;;Main:

;;spear-formatting [note-sequence(s)] / Note-event=[onset pitch duration channel velocity]

;;(spear-formatting (create-sequence '((0 58.5 20000 7 32) (0 60.5 10000 7 32))))

;;Code:

(defun harmonic-series (partials fundamental)

(do ((counter 0 (incf counter))

(output nil (cons (* counter fundamental) output)))

((= counter partials) (reverse output))))

(defun invert-harmonic-ratio (n)

(let* ((series (loop for x from 1 to n

collect x))

(grouping (reverse (make-pairs series))))

(cons 1.0 (loop for y in grouping

collect (/ (float (second y)) (float (first y)))))))

(defun invert-harmonic-series* (fundamental input)

(if (endp input)

'nil

(cons (* fundamental (first input))

(invert-harmonic-series* (* fundamental (first input)) (rest input)))))

(defun invert-harmonic-series (partials fundamental)

(invert-harmonic-series* fundamental (invert-harmonic-ratio partials)))

(defun distorted-harmonic-series (fundamental n percentage)

(let ((power (if (< percentage 0)

(+ 1 (/ percentage 100.0))

(+ 1 (abs (/ percentage 100.0))))))

(loop for x from 1 to n

collect (* fundamental (expt x power)))))

(defun distort-harmonic-series (fundamental percentage ratio-list)

(let ((power (if (< percentage 0)

(+ 1 (/ percentage 100.0))

(+ 1 (abs (/ percentage 100.0))))))

(loop for x in ratio-list

collect (* fundamental (expt x power)))))

(defun convert-midi-to-frequency (midi-value)

(* 440 (expt 2 (/ (- midi-value 69) 12.0))))

(defun convert-frequency-to-midi (frequency)

(+ 69 (* 12 (/ (log (/ frequency 440.0) 10) (log 2 10)))))

(defun midi-to-frequency (input-list)

(mapcar #'convert-midi-to-frequency input-list))

(defun frequency-to-midi (input-list)

(mapcar #'convert-frequency-to-midi input-list))

(defun partial-index (list index-list)

(cond ((eql index-list :all-partials) list)

((endp index-list) nil)

((endp list) nil)

((> (first index-list) (length list)) nil)

(t (cons (elt list (- (first index-list) 1))

(partial-index list (rest index-list))))))

(defun potentiation-list (n value)

(do* ((counter n (- counter 1))

(exponent -1 (+ exponent 1))

(output nil (cons (expt value exponent) output)))

((zerop counter) (reverse output))))

(defun amplitude-squared-inverse* (n)

(let ((squared-inverse (potentiation-list n 2)))

(loop for x in squared-inverse

collect (/ 1 x))))

(defun amplitude-inverse* (n)

(loop for x from 1 to n

collect (/ 1 x)))

(defun amplitude-squared-inverse (n)

(let ((squared-inverse (potentiation-list n 2)))

(loop for x in squared-inverse

collect (/ 1.0 x))))

(defun amplitude-inverse (n)

(loop for x from 1 to n

collect (/ 1.0 x)))

#|

(defun sieve-duration (duration resolution)

(let ((output (loop for x from 0.0 to (* duration 1000) by 50

collect x)))

(loop for y in output

collect (/ y (* resolution 10000.0)))))

|#

(defun sieve-duration (duration resolution)

(let ((output (loop for x from 0.0 to (* duration 1000) by (* resolution 1000.0)

collect x)))

(loop for y in output

collect (/ y 1000.0))))

(defun scale-milisec-duration (value)

(/ 1000.0 value))

(defun shift-duration (duration-list offset)

(mapcar #'(lambda (x) (+ offset x)) duration-list))

(defun move-onset* (offset input)

(let* ((offsetting (/ offset 1000.0))

(new-first (mapcar #'(lambda (x) (+ offsetting x)) (first input))))

(cons new-first (rest input))))

(defun move-onset (offset list)

(mapcar #'(lambda (x) (move-onset* offset x)) list))

(defun alea (low high)

(+ (min low high)

(if (= high low)

0

(random (+ (abs (- high low ))

(if (or (floatp low) (floatp high))

0

1))))))

(defun deviate (threshold percentage)

(let ((amount (* threshold percentage .01)))

(+ threshold (alea (- amount) amount))))

(defun deviate-percentage (threshold percentage)

(if (= threshold 0)

threshold

(let ((value (+ threshold (* threshold percentage .01))))

(if (> value 127)

127

value))))

(defun permute-list (list)

(let* ((current-list list)

(current-value (unless (endp current-list) (elt current-list (random (length current-list))))))

(if (endp current-list) nil

(cons current-value (permute-list (delete current-value current-list :count 1))))))

(defun normalize-duration (duration)

(defun scale-envelope (duration input)

(let* ((target-duration (normalize-duration duration))

(maximum (first (first (last input))))

(x-values (mapcar #'(lambda (alpha) (normalize alpha 0.0 maximum 0.0 target-duration))

(loop for x in input

collect (first x))))

(y-values (loop for y in input

collect (second y))))

(mapcar #'list x-values y-values)))

(defun normalize-scaling (input)

(if (null input)

'nil

(cons (list (read-from-string (format nil "~,1f" (first (first input))))

(second (first input)))

(normalize-scaling (rest input)))))

(do ((current-n (decf n) (decf current-n))

(times-value 1 (incf times-value))

(output (list ratio) (cons added-ratio output)))

((= current-n 0) (rest (reverse output)))))

(defun partition-list (n segment-value)

(add-ratio n (/ (float segment-value) n)))

(defun segment-interpolation* (segment-1 segment-2 subdivisions)

(let ((segment-difference (abs (- segment-1 segment-2)))

(offset-value (min segment-1 segment-2)))

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

(partition-list subdivisions segment-difference))))

(defun segment-interpolation (segment-1 segment-2 subdivisions)

(let ((interpolation-list (segment-interpolation* segment-1 segment-2 subdivisions)))

(if (or (equal segment-1 segment-2) (< segment-1 segment-2))

interpolation-list

(reverse interpolation-list))))

(defun x-increment (start end)

(append (loop for x from start to end by 0.05

collect x)

(list end)))

#|

(defun x-increment (start end resolution)

(append (loop for x from start to end by resolution

collect x)

(list end)))

|#

(defun inter-break-points (a b)

(if (<= (- (- (first b) (first a)) 0.05) 0.00000001)

(list a b)

(let* ((n (round (/ (- (first b) (first a)) 0.05)))

(interpolation-list (append (list (second a)) (segment-interpolation (second a) (second b) n) (list (second b))))

(x-list (x-increment (first a) (first b))))

(mapcar #'list x-list interpolation-list))))

#|

(defun inter-break-points (a b resolution)

(let* ((n (/ (- (first b) (first a)) resolution))

(interpolation-list (append (list (second a)) (segment-interpolation (second a) (second b) n) (list (second b))))

(x-list (x-increment (first a) (first b) resolution)))

(mapcar #'list x-list interpolation-list)))

|#

(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 sort-index (list)

(sort (loop for x in list

collect (first x)) #'<))

(defun order-index* (index-list list)

(do ((current-index

index-list

(rest current-index))

(current-list

list

(remove

(find-if #'(lambda (x) (= (first current-index) (first x)))

current-list)

current-list :test #'equal))

(output

nil

(cons

(find-if #'(lambda (x) (= (first current-index) (first x)))

current-list)

output)))

((endp current-index) (reverse output))))

(defun order-index (index-list)

(let ((sorting (sort-index index-list)))

(order-index* sorting index-list)))

(defun expand-envelope-coordinates (break-points)

(order-index (remove-duplicates

(loop for x in (make-pairs break-points)

append (inter-break-points (first x) (second x))) :test #'equal)))

#|

(defun expand-envelope-coordinates (break-points resolution)

(order-index (remove-duplicates

(loop for x in (make-pairs break-points)

append (inter-break-points (first x) (second x) resolution)) :test #'equal)))

|#

(defun envelope-values (break-points)

(let ((envelope (expand-envelope-coordinates break-points)))

(loop for x in envelope

collect (second x))))

#|

(defun envelope-values (break-points resolution)

(let ((envelope (expand-envelope-coordinates break-points resolution)))

(loop for x in envelope

collect (second x))))

|#

(defun normalize (x a b c d)

(+ c (* (- x a) (/ (float (- d c)) (- b a)))))

(defun map-freq (x a b c d)

(let ((value (+ c (* (- x a) (/ (float (- d c)) (- b a))))))

(format t "~&~10,6f" value)))

(defun map-amp (x)

(* x (/ 0.100000 1.0)))

(defun fibo-process (list)

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

(defun index-check (index input)

(if (>= (- index 1) (length input))

(reverse input)

input))

(defun index-check-p (index input)

(if (>= (- index 1) (length input))

't

'nil))

(defun gather-from-index (indexing-list input)

(if (null indexing-list)

'nil

(cons (nth (- (first indexing-list) 1) input)

(gather-from-index (rest indexing-list) input))))

(defun all-numbers (n)

(loop for x from 1 to n

collect x))

(defun delete-from-index (index list)

(gather-from-index (remove index (all-numbers (length list))) list))

(defun reverse-rotate (list)

(append (rest (reverse list)) (list (first (reverse list)))))

(defun collect-n (n input)

(do ((counter 0 (+ counter 1))

(current-input input (if (= (length current-input) 1)

input

(rest current-input)))

(output nil (cons (first current-input)

output)))

((= counter n) (reverse output))))

(let* ((additive-list* (loop for alpha in

(reverse (loop for x on (reverse input)

collect (reverse x)))

append alpha))

(defun get-onset (input)

(first input))

(defun get-pitch (input)

(second input))

(defun get-duration (input)

(third input))

(defun get-channel (input)

(fourth input))

(defun get-velocity (input)

(fifth input))

(defun map-onset (input)

(mapcar #'(lambda (x) (get-onset x)) input))

(defun map-pitch (input)

(mapcar #'(lambda (x) (get-pitch x)) input))

(defun map-duration (input)

(mapcar #'(lambda (x) (get-duration x)) input))

(defun map-channel (input)

(mapcar #'(lambda (x) (get-channel x)) input))

(defun map-velocity (input)

(mapcar #'(lambda (x) (get-velocity x)) input))

(defun note-event** (onset pitch duration channel velocity)

(list onset pitch duration channel velocity))

(defun note-event-sequence** (onset-list pitch-list duration-list channel-list velocity-list)

(if (or (null onset-list) (null pitch-list) (null duration-list) (null channel-list) (null velocity-list))

'nil

(cons (note-event** (first onset-list)

(first pitch-list)

(first duration-list)

(first channel-list)

(first velocity-list))

(note-event-sequence** (rest onset-list)

(rest pitch-list)

(rest duration-list)

(rest channel-list)

(rest velocity-list)))))

;;(note-event-sequence** '(0 1000) '(60 64) '(1000 1000) '(1 1) '(64 127))

;;(note-event-sequence** '(0 1000) '(60 64) '(2000 1000) '(1 1) '(32 32))

(defun map-value (x a b c d)

(round (+ c (* (- x a) (/ (- d c) (- b a))))))

(defun map-value-list (list a b c d)

(if (null list)

'nil

(cons (map-value (first list) a b c d)

(map-value-list (rest list) a b c d))))

(defun delta-increment* (list &optional (current-value 0))

(if (null list)

'nil

(cons (+ (first list) current-value)

(delta-increment* (rest list) (setq current-value (+ current-value (first list)))))))

(defun delta-increment (list)

(cons 0 (butlast (delta-increment* list))))

(defun convert-duration-to-onset (list)

(delta-increment list))

;;(note-event-sequence** (delta-increment '(1000 1000)) '(60 64) '(2000 1000) '(1 1) '(32 32))

(defun generate-additive-process* (n onset-list pitch-list duration-list channel-list velocity-list)

(note-event-sequence**

;;(generate-additive-process* 20 '(1000 800 1400 50) '(58.5 78 60) '(2000 1000) '(1) '(32 16))

(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" "*.*"))))

(defun choose-new-file-dialog (&key (prompt "Save File") (operation :save))

(choose-file-dialog :prompt prompt :operation operation))

(defun spear-formatting (input)

(with-open-file (output (choose-new-file-dialog)

:direction :output

:if-exists :supersede)

(do ((input-list input (rest input-list))

(partial-number 0 (+ partial-number 1))

(printing

(progn

(format output "~&~a"  "par-text-partials-format")

(format output "~&~a ~a ~a ~a"  "point-type" "time" "frequency" "amplitude")

(format output "~&~a ~a"  "partials-count" (length input))

(format output "~&~a"  "partials-data"))

(progn

(format output "~&~a ~a ~a ~a"

partial-number

(length (first (first input-list)))

(first (first (first input-list)))

(first (last (first (first input-list)))))

(loop for x in (mapcar #'list (first (first input-list)) (second (first input-list)) (third (first input-list)))

for string = "~&~,6f ~,6f ~,6f" then " ~,6f ~,6f ~,6f"

do (format output string

(float (first x))

(float (second x))

(float (third x)))))))

((endp input-list) 't))))

(defun note-event (n-partials

fundamental

duration

amplitude

&key

(envelope *constant-envelope*)

(distortion 0)

(invert-frequency 'nil)

(invert-amplitude 'nil)

(deviate-frequency 0)

(deviate-amplitude 0)

(partial-indexing :all-partials))

(let* ((total-duration (normalize-duration (/ duration 1000.0)))

(raw-envelope (envelope-values (normalize-scaling (scale-envelope total-duration envelope))))

(ratio-list (if invert-frequency

(invert-harmonic-ratio n-partials)

(loop for ratio from 1.0 to n-partials

collect ratio)))

(partials (partial-index (distort-harmonic-series (convert-midi-to-frequency fundamental) distortion ratio-list) partial-indexing))

(raw-amplitude (partial-index (if invert-amplitude

(let ((amplitude-values (reverse (mapcar #'map-amp (amplitude-squared-inverse n-partials)))))

(append (last amplitude-values) (butlast amplitude-values)))

(mapcar #'map-amp (amplitude-squared-inverse n-partials))) partial-indexing))

(onset (sieve-duration total-duration 0.05))

(expand-partials (loop for x in partials

collect (loop repeat (length onset)

collect (deviate x deviate-frequency))))

(expand-amplitude (loop for y in raw-amplitude

collect (mapcar #'* (loop repeat (length onset)

collect (* (normalize amplitude 0.0 127.0 0.0 1.0)

(deviate y deviate-amplitude))) raw-envelope))))

(loop for alpha in expand-partials

for beta in expand-amplitude

collect (list onset alpha beta))))

#|

(spear-formatting

(note-event 10 60 1000 64

:distortion 10

:envelope *triangle-envelope*

:deviate-frequency 2

:deviate-amplitude 10

:invert-frequency 't))

(spear-formatting

(note-event 20 60 500 64

:distortion 20

:envelope *triangle-envelope*

:deviate-frequency 80

:deviate-amplitude 50

:invert-frequency 't

:invert-amplitude 't))

(spear-formatting

(note-event 10 60 20000 64

:distortion 10

:envelope *triangle-envelope*

:deviate-frequency 2

:deviate-amplitude 10

:invert-frequency 't))

|#

(defmacro define-instrument (instrument-name

n-partials

&key

(envelope *trapezoid-envelope*)

(distortion 0)

(invert-frequency 'nil)

(invert-amplitude 'nil)

(deviate-frequency 0)

(deviate-amplitude 0)

(partial-indexing :all-partials))

`(eval (list 'defun ,instrument-name '(pitch duration velocity)

'(note-event ,n-partials pitch duration velocity

:envelope ,envelope

:distortion ,distortion

:invert-frequency ,invert-frequency

:invert-amplitude ,invert-amplitude

:deviate-frequency ,deviate-frequency

:deviate-amplitude ,deviate-amplitude

:partial-indexing ,partial-indexing))))

;;(define-instrument 'cicada 20 :distortion -10 :invert-amplitude 't)

(defun spear-output (input &optional (counter 0))

(if (endp input)

't

(progn

(with-open-file

(output (make-pathname :directory '(:absolute "users" "home" "directory")

:name (format nil "~a-~a" "spear-format" counter)

:type "txt")

:direction :output

:if-exists :supersede)

(do ((input-list (first input) (rest input-list))

(partial-number 0 (+ partial-number 1))

(printing

(progn

(format output "~&~a"  "par-text-partials-format")

(format output "~&~a ~a ~a ~a"  "point-type" "time" "frequency" "amplitude")

(format output "~&~a ~a"  "partials-count" (length (first input)))

(format output "~&~a"  "partials-data"))

(progn

(format output "~&~a ~a ~a ~a"

partial-number

(length (first (first input-list)))

(first (first (first input-list)))

(first (last (first (first input-list)))))

(loop for x in (mapcar #'list (first (first input-list)) (second (first input-list)) (third (first input-list)))

for string = "~&~,6f ~,6f ~,6f" then " ~,6f ~,6f ~,6f"

do (format output string

(float (first x))

(float (second x))

(float (third x)))))))

((endp input-list) 't)))

(spear-output (rest input) (+ counter 1)))))

(defun create-note-event (input)

(move-onset (first input) (apply (eval (list 'function (instrument-table (fourth input))))

(list (second input) (third input) (fifth input)))))

#|

(defun create-note-event* (input)

(move-onset (first input) (apply (eval (list 'function (instrument-table (fourth input))))

(list (second input) (third input) (fifth input)))))

(defun create-sequence* (&rest input)

input)

(defun create-sequence** (input)

(if (endp input)

'nil

(append (create-note-event (first input))

(create-sequence** (rest input)))))

(defun create-sequence (&rest input)

(create-sequence** (apply #'create-sequence* input)))

|#

(defun create-sequence (input)

(if (endp input)

'nil

(append (create-note-event (first input))

(create-sequence (rest input)))))

;;(create-sequence '((500 69 2000 1 32) (500 69 2000 1 32)))

(defvar *constant-envelope* '((0.0 1.0) (1.0 1.0)))

(defvar *triangle-envelope* '((0.0 0.0) (0.5 1.0) (1.0 -0.5)))

(defvar *trapezoid-envelope* '((0.0 0.0) (0.1 1.0) (0.9 1.0) (1.0 -0.5)))

(defvar *line-down-envelope* '((0.0 0.0) (0.1 1.0) (1.0 -0.5)))

(defvar *line-up-envelope* '((0.0 0.0) (0.9 1.0) (1.0 -0.5)))

(defvar *bell-down-envelope* '((0.0 0.0) (0.1 1.0) (0.3 0.4) (1.0 -0.5)))

(defvar *bell-up-envelope* '((0.0 -0.5) (0.7 0.4) (0.9 1.0) (1.0 -1.0)))

(defvar *gaussian-envelope* '((0.0 0.0) (0.2 0.15) (0.4 0.8) (0.5 1.0) (0.6 0.8) (0.8 0.15) (1.0 -0.5)))

20

:distortion 10

:envelope *trapezoid-envelope*

:deviate-frequency 0.5

:deviate-amplitude 0.5

:invert-amplitude 't

:partial-indexing '(1 3 6 7 8 15 16 17 18 19 20))

(define-instrument 'magnet

6

:distortion 10

:envelope *triangle-envelope*

:deviate-frequency 2

:deviate-amplitude 10

:invert-frequency 't)

(defun bell (pitch duration velocity)

(append (note-event 25 pitch duration velocity

:distortion 10

:envelope *bell-down-envelope*

:deviate-amplitude 0.5

:partial-indexing '(2 3 7 9 11 13 17 19 21 23 25))

(note-event 25 pitch duration velocity

:distortion 12.5

:envelope *bell-down-envelope*

:deviate-amplitude 1

:invert-amplitude 't

:deviate-frequency 5

:partial-indexing '(2 3 7 9 11 13 17 19 21 23 25))

(note-event 25 (+ pitch 0.5) duration velocity

:distortion 10

:envelope *bell-down-envelope*

:deviate-amplitude 0.5

:partial-indexing '(2 3 7 9 11 13 17 19 21 23 25))

(note-event 25 (+ pitch 0.5) duration velocity

:distortion 12.5

:envelope *bell-down-envelope*

:deviate-amplitude 1

:invert-amplitude 't

:deviate-frequency 1

:partial-indexing '(2 3 7 9 11 13 17 19 21 23 25))))

(defun boreal (pitch duration velocity)

(append

(note-event 6 pitch duration velocity

:distortion 5

:envelope *line-up-envelope*

:deviate-frequency 1

:deviate-amplitude 50

:invert-frequency 't

:invert-amplitude 't)

(note-event 6 pitch duration velocity

:distortion 35

:envelope *line-up-envelope*

:deviate-frequency 1.5

:deviate-amplitude 50

:invert-frequency 't)))

(defun crystal (pitch duration velocity)

(append

(note-event 4 pitch duration velocity

:distortion 5

:envelope *gaussian-envelope*

:deviate-frequency 0.1

:deviate-amplitude 10

:invert-amplitude 't

:partial-indexing '(2 3 4))

(note-event 6 pitch duration (deviate-percentage velocity -20)

:envelope *gaussian-envelope*

:deviate-frequency 0.25

:deviate-amplitude 10

:partial-indexing '(2 3 4 5 6))))

(defun spark (pitch duration velocity)

(append

(note-event 20 pitch duration velocity

:distortion 5

:envelope *line-down-envelope*

:deviate-frequency 5

:deviate-amplitude 10

:partial-indexing '(2 3 4 5 6 7 8 9 10))

(move-onset 100

(note-event 20 pitch duration velocity

:distortion 10

:envelope *bell-down-envelope*

:deviate-frequency 10

:deviate-amplitude 50

:partial-indexing '(2 3 4 5 6 7 8 9 10)))

(move-onset 400

(note-event 20 pitch duration velocity

:distortion 20

:envelope *line-down-envelope*

:deviate-frequency 20

:deviate-amplitude 100

:partial-indexing '(2 3 4 5 6 7 8 9 10)))))

(defun soil (pitch duration velocity)

(append

(note-event 10 pitch duration velocity

:distortion 10

:envelope *line-down-envelope*

:deviate-amplitude 0.5

:invert-amplitude 't)

(note-event 10 pitch duration velocity

:distortion 12.5

:envelope *line-down-envelope*

:deviate-amplitude 0.5

:invert-amplitude 't)

(note-event 10 (+ pitch 0.5) duration velocity

:distortion 10

:envelope *bell-up-envelope*

:deviate-amplitude 0.5

:invert-amplitude 't)

(note-event 10 (+ pitch 0.5) duration velocity

:distortion 12.5

:envelope *bell-up-envelope*

:deviate-amplitude 0.5

:invert-amplitude 't)))

(defun instrument-table (instrument-number)

(case instrument-number

(2 'magnet)

(3 'bell)

(4 'boreal)

(5 'crystal)

(6 'spark)

(7 'soil)))

#|

(spear-formatting

(append (create-sequence '((0 58.5 20000 7 32)))

(move-onset 52000 (create-sequence '((0 60.5 10000 7 32))))

'(1000 800 1400 100)

'(48 66.5 59 63.25)

'(2000 1000 3000 500)

'(1 2 3 4 5 6)

'(32 16 32 16 32))))

(permute-list '(1000 800 1400 100))

(permute-list '(48 66.5 59 63.25))

(permute-list '(2000 1000 3000 500))

(permute-list '(1 2 3 4 5 6))

(permute-list '(32 16 32 16 32)))))))

|#