Atonal-Melodic-Expectation

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

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

;;Atonal Melodic expectation model

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

;;Mauricio Rodriguez - 2009

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

;;marod@stanford.edu

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

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

;;============================================

;; Shared file: Tonal-Key-Finder.lisp

;;============================================

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

;;Pearson Correlation Algorithm to find Tonal Key

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

;;Mauricio Rodriguez - 2009

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

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

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:

;;atonal-melodic-expectancy-random-generation [n harmonic-seed interval-reservoir &optional starting-note]

;;(atonal-melodic-expectancy-random-generation 8 '(48 59 63 74) '(1 2 3 4 10 11))

;;Code:

(defun average-value (list)

(let ((current-list (remove-if #'(lambda (x) (= 0 x)) list)))

(float (/ (apply #'+ current-list) (length current-list)))))

(defun average-value (list)

(float (/ (apply #'+ list) (length list))))

(defun pearson-correlation* (average-x average-y pitch-list weight-list)

(if (or (endp pitch-list) (endp weight-list))

nil

(cons (list (- (first pitch-list) average-x)

(- (first weight-list) average-y))

(pearson-correlation*

average-x

average-y

(rest pitch-list)

(rest weight-list)))))

(defun pearson-correlation** (average-x average-y pitch-list weight-list)

(let* ((correlation (pearson-correlation* average-x average-y pitch-list weight-list))

(part-a (apply #'+ (loop for x in correlation

collect (* (first x) (second x)))))

(part-b (apply #'+ (loop for x in correlation

collect (expt (first x) 2))))

(part-c (apply #'+ (loop for x in correlation

collect (expt (second x) 2)))))

(/ part-a (sqrt (* part-b part-c)))))

(defun pearson-correlation*** (pitch-list weight-list)

(pearson-correlation** (average-value pitch-list)

(average-value weight-list)

pitch-list

weight-list))

(defun rotate-list (list)

(do ((count (length list) (- count 1))

(current-list list (append (last current-list) (butlast current-list)))

(output nil (cons current-list output)))

((= count 0) (reverse output))))

(defun pearson-correlation**** (pitch-list weight-list)

(let ((rotation (rotate-list weight-list)))

(loop for x in rotation

collect (pearson-correlation*** pitch-list x))))

(defun major-key-label (list)

(loop for x in '(C-Major

Db-Major

D-Major

Eb-Major

E-Major

F-Major

F#-Major

G-Major

Ab-Major

A-Major

Bb-Major

B-Major)

for y in list

collect (list x y)))

(defun minor-key-label (list)

(loop for x in '(C-Minor

C#-Minor

D-Minor

Eb-Minor

E-Minor

F-Minor

F#-Minor

G-Minor

G#-Minor

A-Minor

Bb-Minor

B-Minor)

for y in list

collect (list x y)))

(defun key-finder* (pitch-list major-weight minor-weight)

(append

(major-key-label (pearson-correlation**** pitch-list major-weight))

(minor-key-label (pearson-correlation**** pitch-list minor-weight))))

(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 key-finder (pitch-list major-weight minor-weight)

(search-max-in-compound-list

(key-finder* pitch-list major-weight minor-weight)))

;;Krumhansl-Kessler probe-tone profiles:

(key-finder

'(8 0 0 0 2 11 0 5 7 0 5 2)

'(6.35 2.23 3.48 2.33 4.38 4.09 2.52 5.19 2.39 3.66 2.29 2.88)

'(6.33 2.68 3.52 5.38 2.60 3.53 2.54 4.75 3.98 2.69 3.34 3.17))

;;============================================

;;Aarden-Essen continuity profiles:

(key-finder

'(8 0 0 0 2 11 0 5 7 0 5 2)

'(17.7661 0.145624 14.9265 0.160186 19.8049 11.3587 0.291248 22.062 0.145624 8.15494 0.232998 4.95122)

'(18.2648 0.737619 14.0499 16.8599 0.702494 14.4362 0.702494 18.6161 4.56621 1.93186 7.37619 1.75623))

;;============================================

;;Temperley-Kostka-Payne chord-based profiles:

(key-finder

'(8 0 0 0 2 11 0 5 7 0 5 2)

'(0.748 0.060 0.488 0.082 0.670 0.460 0.096 0.715 0.104 0.366 0.057 0.400)

'(0.712 0.084 0.474 0.618 0.049 0.460 0.105 0.747 0.404 0.067 0.133 0.330))

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

;;============================================

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

(defun key-map (key)

(case key

(C-Major '(0 2 4 5 7 9 11))

(Db-Major '(1 3 5 6 8 10 0))

(D-Major '(2 4 6 7 9 11 1))

(Eb-Major '(3 5 7 8 10 0 2))

(E-Major '(4 6 8 9 11 1 3))

(F-Major '(5 7 9 10 0 2 4))

(F#-Major '(6 8 10 11 1 3 5))

(G-Major '(7 9 11 0 2 4 6))

(Ab-Major '(8 10 0 1 3 5 7))

(A-Major '(9 11 1 2 4 6 8))

(Bb-Major '(10 0 2 3 5 7 9))

(B-Major '(11 1 3 4 6 8 10))

(C-Minor '(0 2 3 5 7 8 10))

(C#-Minor '(1 3 4 6 8 9 11))

(D-Minor '(2 4 5 7 9 10 0))

(Eb-Minor '(3 5 6 8 10 11 1))

(E-Minor '(4 6 7 9 11 0 2))

(F-Minor '(5 7 8 10 0 1 3))

(F#-Minor '(6 8 9 11 1 2 4))

(G-Minor '(7 9 10 0 2 3 5))

(G#-Minor '(8 10 11 1 3 4 6))

(A-Minor '(9 11 0 2 4 5 7))

(Bb-Minor '(10 0 1 3 5 6 8))

(B-Minor '(11 1 2 4 6 7 9))))

(defun tag-key-map (key)

(loop for x in (key-map key)

for y in '(1 2 3 4 5 6 7)

collect (list x y)))

(defun get-modulo (midi-note-value)

(mod midi-note-value 12))

(defun search-for-modulo (key midi-note-value)

(loop for x in (tag-key-map key)

when (= (first x) (get-modulo midi-note-value))

return (second x)))

(defun get-stability (key midi-note-value)

(let ((current-value (search-for-modulo key midi-note-value)))

(case current-value

(1 6)

(3 5)

(5 5)

(2 4)

(4 4)

(6 4)

(7 4)

('nil 2))))

(defun absolute-difference (x y)

(abs (- x y)))

(defun get-proximity (note-value-1 note-value-2)

(let ((current-difference (absolute-difference note-value-1 note-value-2)))

(case current-difference

(0 36)

(1 36)

(2 32)

(3 25)

(4 20)

(5 16)

(6 12)

(7 9)

(8 6)

(9 4)

(10 2)

(11 1)

(12 0.25)

(13 0.02)

(14 0.01)

(t 0.01))))

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

;;Direction results are ordered by continuation, reversal and repetition weightings

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

(defun get-direction (note-value-1 note-value-2)

(let ((current-difference (absolute-difference note-value-1 note-value-2)))

(case current-difference

(0 '(6 0 2))

(1 '(20 0 7))

(2 '(12 0 4))

(3 '(6 0 2))

(4 '(0 0 0))

(5 '(0 6 2))

(6 '(0 12 4))

(7 '(0 25 8))

(8 '(0 36 12))

(9 '(0 52 17))

(10 '(0 75 25))

(t '(0 75 25)))))

(defun get-mobility (note-value-1 note-value-2)

(if (= (absolute-difference note-value-1 note-value-2) 0)

(/ 2.0 3.0)

1.0))

(defun interval-direction (note-value-1 note-value-2)

(let ((current-difference (- note-value-1 note-value-2)))

(cond ((< current-difference 0) '>)

((> current-difference 0) '<)

((= current-difference 0) '=))))

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

(defun take-by-number (n list)

(unless (< (length list) n)

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

(result nil (cons (first input-list) result))

(counter n (- counter 1)))

((= counter 0) result)))))

(defun filtering-by-number (number list)

(if (< (length list) number)

nil

(cons (take-by-number number list) (filtering-by-number number (rest list)))))

(defun get-logic-direction (filtered-melodic-cell)

(let ((direction-list (get-direction (first filtered-melodic-cell) (second filtered-melodic-cell)))

(first-interval (interval-direction (first filtered-melodic-cell)

(second filtered-melodic-cell)))

(second-interval (interval-direction (second filtered-melodic-cell)

(third filtered-melodic-cell))))

(cond ((or (and (equal first-interval second-interval)

(not (equal '= first-interval))

(not (equal '= second-interval)))

(and (equal '= first-interval)

(or (equal '> second-interval)

(equal '< second-interval))))

(first direction-list))

((and (not (equal first-interval second-interval))

(or (equal '= first-interval)

(and (or (equal '> second-interval)

(equal '< second-interval)))))

(second direction-list))

((or (and (equal first-interval second-interval)

(equal '= first-interval)

(equal '= second-interval))

(and (or (equal '> first-interval)

(equal '< first-interval))

(equal '= second-interval)))

(third direction-list)))))

(defun melodic-expectancy (key melodic-cell)

(+ (* (get-stability key (third melodic-cell))

(get-proximity (second melodic-cell) (third melodic-cell))

(get-mobility (second melodic-cell) (third melodic-cell)))

(get-logic-direction melodic-cell)))

;;============================================

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

;;============================================

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

(defun note-name* (note-number)

(list (elt '(c c# d d# e f f# g g# a a# b)

(rem note-number 12))

(- (truncate (/ note-number 12)) 1)))

(defun note-name (note-number)

(first

(read-from-string

(remove #\space

(write-to-string

(note-name* note-number))))))

;;============================================

(defun melodic-expectancy-values (key melody)

(loop for x in (filtering-by-number 3 melody)

collect (list (third x)

(note-name (third x))

(melodic-expectancy key x))))

;;============================================

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

(defun get-up-down-octave (note-value)

(loop for x in '(-12 -11 -10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 10 11 12)

collect (+ note-value x)))

(defun build-test-melodic-cells (interval)

(let ((up-down-octave (get-up-down-octave (second interval))))

(loop for x in up-down-octave

collect (append interval (list x)))))

(defun melodic-expectancy-test-values (key test-cells)

(loop for x in test-cells

collect (list (third x)

(note-name (third x))

(melodic-expectancy key x))))

(defun sorting (input-list)

(if (< (length input-list) 2)

input-list

(append (sorting (remove-if-not #'(lambda (x)

(<= x (first input-list)))

(rest input-list)))

(list (first input-list))

(sorting (remove-if #'(lambda (x)

(<= x (first input-list)))

(rest input-list))))))

(defun order-expectany-values (list)

(reverse

(sorting

(loop for x in list

collect (third x)))))

(defun order-expectancy-melodic-cells (compound-list)

(do ((sort-values

(order-expectany-values compound-list)

(rest sort-values))

(current-list

compound-list

(remove-if #'(lambda (x) (= (first sort-values) (third x))) current-list :count 1))

(output

nil

(cons (loop for x in current-list

for y = (first sort-values)

when (= y (third x))

return x)

output)))

((endp sort-values) (reverse output))))

(defun generate-and-order-expectancy-values (key interval)

(order-expectancy-melodic-cells

(melodic-expectancy-test-values

key

(build-test-melodic-cells interval))))

(loop for x in (generate-and-order-expectancy-values 'c-major '(60 69))

collect (third x))

(defun test-melodic-expectancy-cells-ordered (key interval)

(let* ((ordered-expectancy-values (generate-and-order-expectancy-values key interval))

(expectancy-values (loop for x in ordered-expectancy-values

collect (first x))))

(loop for y in expectancy-values

collect (append interval (list y)))))

;;============================================

;;(test-melodic-expectancy-cells-ordered 'c-major '(60 69))

;;(test-melodic-expectancy-cells-ordered 'c-major '(61 70))

;;============================================

(defun implicative-denial (key interval)

(let* ((expectancy-list (generate-and-order-expectancy-values key interval))

(high-expectancy-value (third (first expectancy-list)))

(denial-value (loop for x in expectancy-list

collect (- high-expectancy-value (third x)))))

(loop for y in expectancy-list

for z in denial-value

collect (append (butlast y) (list z)))))

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

(defun get-ordered-expectancy-values (key interval)

(let ((expectancy-values (test-melodic-expectancy-cells-ordered key interval)))

(loop for x in expectancy-values

collect (third x))))

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

;; Shared functions:

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

(defun integers-down (number)

(reverse (loop for x from 1 to number collect x)))

(defun sum-list (list)

(do ((sum 0 (+ sum (first local-list)))

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

((not local-list) sum)))

(defun fibo-process* (list)

(if (= (length list) 1) 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 weight-for-list (list)

(let ((pure-weight (/ 1.0 (sum-list (integers-down (length list))))))

(mapcar #'list list (fibo-process* (mapcar #'(lambda (x) (* x pure-weight)) (integers-down (length list)))))))

(defun uniform-random-weight (table)

(let ((x (random 1.0)))

(loop for d in table

for p = (second d)

when (<= x p )

return (first d))))

(loop repeat 100

collect

(uniform-random-weight

'((11 0.25) (10 0.46428573) (9 0.6428572) (8 0.7857143) (6 0.8928572) (3 0.9642858) (1 1.0000001))))

(defun linear-random-weight (table)

(let ((x (/ (+ (random 1.0) (random 1.0)) 2.0)))

(loop for d in table

for p = (second d)

when (<= x p )

return (first d))))

(loop repeat 100

collect

(uniform-random-weight

'((11 0.25) (10 0.46428573) (9 0.6428572) (8 0.7857143) (6 0.8928572) (3 0.9642858) (1 1.0000001))))

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

;; Melodic Generation on Expectancy Values - Tonal Context

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

(defun melodic-generation-by-high-expectancy-value (n key interval-seed)

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

(current-interval-reference interval-seed (list (second output) (first output)))

(output (cons (first (get-ordered-expectancy-values key current-interval-reference))

(reverse interval-seed))

(cons

(first

(get-ordered-expectancy-values key current-interval-reference))

output)))

((= 0 counter) (reverse output))))

;;Weighted random selection

;;Uniform

(defun melodic-expectancy-random-generation (n key interval-seed)

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

(current-interval-reference interval-seed (list (second output) (first output)))

(output (cons

(uniform-random-weight

(weight-for-list

(get-ordered-expectancy-values key current-interval-reference)))

(reverse interval-seed))

(cons

(uniform-random-weight

(weight-for-list

(get-ordered-expectancy-values key current-interval-reference)))

output)))

((= 0 counter) (reverse output))))

;;============================================

;;(melodic-expectancy-random-generation 10 'c-major '(60 69))

;;============================================

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

;; Melodic Expectancy - Atonal Context

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

;;============================================

;; Shared file: melodic-generation-harmony.lisp

;;============================================

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

;; Melodic generation by harmonization

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

;; Mauricio Rodriguez 2009

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

;; marod@stanford.edu

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

(defun invert-interval-list (reservoir)

(loop for x in reservoir

collect (* x -1)))

(defun build-melodic-intervals* (reference-note reservoir)

(let ((interval-reservoir (append (reverse reservoir)

(invert-interval-list reservoir))))

(loop for x in interval-reservoir

collect (+ reference-note x))))

(defun build-melodic-intervals** (chord reservoir)

(loop for x in chord

append (build-melodic-intervals* x reservoir)))

(defun build-melodic-intervals (chord reservoir)

(sort (remove-duplicates (append chord (build-melodic-intervals** chord reservoir))) #'>))

;;///Shared function(s): sorting///

(defun sorting (input-list)

(if (< (length input-list) 2)

input-list

(append (sorting (remove-if-not #'(lambda (x)

(<= x (first input-list)))

(rest input-list)))

(list (first input-list))

(sorting (remove-if #'(lambda (x)

(<= x (first input-list)))

(rest input-list))))))

(defun build-harmonic-entities-with-melodic-intervals (chord reservoir)

(let ((built-melodic-patterns (build-melodic-intervals chord reservoir)))

(loop for x in built-melodic-patterns

collect (sorting (cons x chord)))))

;;///Shared function(s): reduce-to-modulo, make-pairs*, make-pairs, absolute-difference,

;;intervalic-difference, all-members-in-list-p*, nil-as-member-p, all-members-in-list-p,

;;equal-to-threshold-p, check-for-repeated-arguments-p, check-interval-content-and-non-repetition-modulo,

;;filter-repeated-arguments, flat-list, take-by-number, filtering-by-number, chord-interval-relations///

(defun reduce-to-modulo (harmonic-entiity)

(loop for x in harmonic-entiity

collect (mod x 12)))

(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 absolute-difference (x y)

(abs (- x y)))

(defun intervalic-difference (list)

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

(defun all-members-in-list-p* (members list)

(mapcar #'(lambda (x) (find x list)) members))

(defun nil-as-member-p (list)

(cond ((endp list) t)

((equal (first list) 'nil) nil)

(t (nil-as-member-p (rest list)))))

(defun all-members-in-list-p (members list)

(nil-as-member-p (all-members-in-list-p* members list)))

(defun equal-to-threshold-p (number)

(if (>= number 2)

nil))

(defun check-for-repeated-arguments-p (list)

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

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

((endp current-list) (some #'equal-to-threshold-p (reverse output)))))

(defun check-interval-content-and-non-repetition-modulo (harmonic-entity interval-reservoir)

(if (and (not (check-for-repeated-arguments-p (reduce-to-modulo harmonic-entity)))

(all-members-in-list-p (intervalic-difference harmonic-entity) interval-reservoir))

nil))

(defun filter-repeated-arguments (list)

(cond ((endp list)

nil)

((check-for-repeated-arguments-p (first list))

(filter-repeated-arguments (rest list)))

(t (cons (first list)

(filter-repeated-arguments (rest list))))))

(defun flat-list (list)

(loop for x in list

append x))

(defun take-by-number (n list)

(unless (< (length list) n)

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

(result nil (cons (first input-list) result))

(counter n (- counter 1)))

((= counter 0) result)))))

(defun filtering-by-number (number list)

(if (< (length list) number)

nil

(cons (take-by-number number list) (filtering-by-number number (rest list)))))

(defun chord-interval-relations* (list)

(filter-repeated-arguments

(remove-duplicates

(mapcar #'(lambda (z) (sort z '<))

(flat-list (loop for x in (filtering-by-number 1 list)

collect (mapcar #'(lambda (y) (append x (list y)))

list))))

:test #'equal)))

(defun chord-interval-relations (list)

(remove-duplicates

(sort (loop for x in (chord-interval-relations* list)

append (intervalic-difference x)) #'<)))

(defun reduce-to-modulo-with-reservoir (harmonic-entiity reservoir)

(loop for x in harmonic-entiity

collect (if (<= x (apply #'max reservoir))

(mod x 12))))

(defun check-chord-interval-relations-with-reservoir** (chord-list reservoir)

(all-members-in-list-p

(reduce-to-modulo (chord-interval-relations chord-list))

reservoir))

(defun check-chord-interval-relations-in-harmony-list* (list reservoir-list)

(cond ((endp list)

nil)

((check-for-repeated-arguments-p (first list))

(cons (first list)

(check-chord-interval-relations-in-harmony-list* (rest list) reservoir-list)))

((check-chord-interval-relations-with-reservoir** (first list) reservoir-list)

(cons (first list)

(check-chord-interval-relations-in-harmony-list* (rest list) reservoir-list)))

(t (check-chord-interval-relations-in-harmony-list* (rest list) reservoir-list))))

(defun check-chord-harmony-list-with-melodic-pattern (chord reservoir-interval-list)

(check-chord-interval-relations-in-harmony-list*

(build-harmonic-entities-with-melodic-intervals chord reservoir-interval-list)

reservoir-interval-list))

(defun get-melody-from-harmony (chord-reference harmony-list)

(loop for x in harmony-list

collect (set-difference x chord-reference)))

(defun get-repeated-argument* (chord chord-clon)

(cond ((endp chord) nil)

((= 2 (count (first chord) chord-clon)) (list (first chord)))

(t (get-repeated-argument* (rest chord) chord-clon))))

(defun get-repeated-argument (chord)

(get-repeated-argument* chord chord))

(defun get-melody-from-harmony (chord-reference harmony-list)

(cond ((endp harmony-list)

nil)

((get-repeated-argument (first harmony-list))

(cons (get-repeated-argument (first harmony-list))

(get-melody-from-harmony chord-reference (rest harmony-list))))

(cons (set-difference (first harmony-list) chord-reference)

(get-melody-from-harmony chord-reference (rest harmony-list))))))

(defun melodic-interval-relations* (list)

(filter-repeated-arguments

(flat-list (loop for x in (filtering-by-number 1 list)

collect (mapcar #'(lambda (y) (append x (list y)))

list)))))

(defun check-melodic-interval-relations-in-harmony-list* (list reservoir-list)

(cond ((endp list)

nil)

((check-for-repeated-arguments-p (first list))

(cons (first list)

(check-melodic-interval-relations-in-harmony-list* (rest list) reservoir-list)))

((check-chord-interval-relations-with-reservoir** (first list) reservoir-list)

(cons (first list)

(check-melodic-interval-relations-in-harmony-list* (rest list) reservoir-list)))

(t (check-melodic-interval-relations-in-harmony-list* (rest list) reservoir-list))))

(defun melodic-interval-relations** (list)

(loop for x in list

collect (list x list)))

(defun expand-and-filter-melodic-relations* (index-list)

(filter-repeated-arguments

(loop for x in (second index-list)

collect (cons (first index-list) (list x)))))

(defun get-melodic-net (chord-reference interval-reservoir)

(let* ((melodic-reservoir

(flat-list (get-melody-from-harmony

chord-reference

(check-chord-harmony-list-with-melodic-pattern chord-reference interval-reservoir))))

(interval-relations

(melodic-interval-relations** melodic-reservoir)))

(loop for x in interval-relations

append (check-melodic-interval-relations-in-harmony-list*

(expand-and-filter-melodic-relations* x)

interval-reservoir))))

(defun build-node-and-paths (list)

(if (equal 'nil list)

nil

(list (first (first list))

(loop for x in list

collect (second x)))))

(defun get-melodic-net (chord-reference interval-reservoir)

(let* ((melodic-reservoir

(flat-list (get-melody-from-harmony

chord-reference

(check-chord-harmony-list-with-melodic-pattern chord-reference interval-reservoir))))

(interval-relations

(melodic-interval-relations** melodic-reservoir)))

(loop for x in interval-relations

collect (build-node-and-paths

(check-melodic-interval-relations-in-harmony-list*

(expand-and-filter-melodic-relations* x)

interval-reservoir)))))

;;============================================

;;(get-melodic-net '(59 60 63) '(1 2 3 4 10 11 13 14))

;;(get-melodic-net '(48 59 63 76) '(1 2 3 4 10 11 13 14))

;;(get-melodic-net '(48 59 63 74) '(1 2 3 4 10 11 13 14))

;;============================================

(loop for x in (get-melodic-net '(48 59 63 74) '(1 2 3 4 10 11 13 14))

do (print x))

(defun get-melodic-field (harmonic-seed interval-reservoir)

(reverse

(flat-list (get-melody-from-harmony

harmonic-seed

(check-chord-harmony-list-with-melodic-pattern harmonic-seed interval-reservoir)))))

;;============================================

;;(get-melodic-field '(48 59 63 76) '(1 2 3 4 10 11 13 14))

;;(get-melodic-field '(48 59 63 74) '(1 2 3 4 10 11 13 14))

;;(get-melodic-field '(48 59 63 74) '(1 2 3 4 5 10 11 13 14))

;;============================================

(defun check-generated-chords-in-modulo-reduction (harmonic-seed interval-reservoir)

(loop for x in (build-harmonic-entities-with-melodic-intervals harmonic-seed interval-reservoir)

collect (chord-interval-relations (reduce-to-modulo x))))

(defvar *melodic-net* nil)

*melodic-net*

(defun define-net (harmonic-seed interval-reservoir)

(setf *melodic-net* nil)

(setf *melodic-net* (get-melodic-net harmonic-seed interval-reservoir)))

(defun legal-melodic-movement-p (melodic-pair)

(let* ((melodic-net *melodic-net*)

(current-inspection (loop for x in melodic-net

when (= (first x) (first melodic-pair))

return (second x))))

(if (member (second melodic-pair) current-inspection)

nil)))

;; To allow repetitions on legal melodic-movements:

(defun legal-melodic-movement-p (melodic-pair)

(if (equal (first melodic-pair) (second melodic-pair))

(let* ((melodic-net *melodic-net*)

(current-inspection (loop for x in melodic-net

when (= (first x) (first melodic-pair))

return (second x))))

(if (member (second melodic-pair) current-inspection)

nil))))

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

;;============================================

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

(defun atonal-melodic-expectancy (melodic-cell)

(+ (* (get-proximity (second melodic-cell) (third melodic-cell))

(get-mobility (second melodic-cell) (third melodic-cell)))

(get-logic-direction melodic-cell)))

;;============================================

;;(atonal-melodic-expectancy '(48 59 60))

;;============================================

(defun get-up-down-from-interval-reservoir (note-value interval-reservoir)

(let ((negative-reservoir (reverse (loop for alpha in interval-reservoir

collect (* alpha -1)))))

(loop for x in (append negative-reservoir (list 0) interval-reservoir)

collect (+ note-value x))))

(defun build-melodic-cells-from-interval-reservoir (interval-reference interval-reservoir)

(let ((up-down-reservoir

(get-up-down-from-interval-reservoir (second interval-reference) interval-reservoir)))

(loop for x in up-down-reservoir

collect (append interval-reference (list x)))))

(defun melodic-expectancy-with-interval-reservoir (melodic-cells)

(loop for x in melodic-cells

collect (list (third x)

(note-name (third x))

(atonal-melodic-expectancy x))))

(melodic-expectancy-with-interval-reservoir

(build-melodic-cells-from-interval-reservoir '(48 60) '(1 2 3 4 10 11 13 14)))

(defun generate-and-order-expectancy-values-with-reservoir (interval-reference interval-reservoir)

(order-expectancy-melodic-cells

(melodic-expectancy-with-interval-reservoir

(build-melodic-cells-from-interval-reservoir interval-reference interval-reservoir))))

(defun melodic-expectancy-cells-ordered-with-reservoir (interval-reference interval-reservoir)

(let* ((ordered-expectancy-values

(generate-and-order-expectancy-values-with-reservoir interval-reference interval-reservoir))

(expectancy-values (loop for x in ordered-expectancy-values

collect (first x))))

(loop for y in expectancy-values

collect (append interval-reference (list y)))))

(defun get-ordered-expectancy-values-with-reservoir (interval-reference interval-reservoir)

(let ((expectancy-values

(melodic-expectancy-cells-ordered-with-reservoir interval-reference interval-reservoir)))

(loop for x in expectancy-values

collect (third x))))

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

;; Atonal Melodic Generation

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

(defun compare-values (reference list)

(cond ((endp list) nil)

((equal (first (first list)) reference) (first list))

(t (compare-values reference (rest list)))))

(defun check-expectancy-values-in-melodic-net (interval-reference interval-reservoir)

(loop for x in (get-ordered-expectancy-values-with-reservoir interval-reference interval-reservoir)

when (compare-values x *melodic-net*)

collect (compare-values x *melodic-net*)))

(defun get-expectancy-values-from-ordered-net (interval-reference interval-reservoir)

(loop for x in (check-expectancy-values-in-melodic-net interval-reference interval-reservoir)

collect (first x)))

(defun check-and-get-legal-movements-in-ordered-net (interval-reference interval-reservoir)

(let ((ordered-net (get-expectancy-values-from-ordered-net interval-reference interval-reservoir)))

(loop for x in ordered-net

when (legal-melodic-movement-p (list (second interval-reference) x))

collect x)))

(weight-for-list

(check-and-get-legal-movements-in-ordered-net '(59 60) '(1 2 3 4 10 11 13 14)))

(uniform-random-weight

(weight-for-list

(check-and-get-legal-movements-in-ordered-net '(59 60) '(1 2 3 4 10 11 13 14))))

(weight-for-list

(check-and-get-legal-movements-in-ordered-net '(59 59) '(1 2 3 4 10 11 13 14)))

(uniform-random-weight

(weight-for-list

(check-and-get-legal-movements-in-ordered-net '(59 59) '(1 2 3 4 10 11 13 14))))

(defun melodic-start (harmonic-seed)

(elt harmonic-seed (random (length harmonic-seed))))

(defun starting-interval (harmonic-seed)

(let ((start (melodic-start harmonic-seed)))

(list start start)))

(defun starting-interval (harmonic-seed &optional starting-note)

(if starting-note

(list starting-note starting-note)

(let ((start (melodic-start harmonic-seed)))

(list start start))))

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

;; Random Generation

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

(defun atonal-melodic-expectancy-random-generation (n harmonic-seed interval-reservoir &optional starting-note)

(define-net harmonic-seed interval-reservoir)

(let ((interval-seed (if starting-note

(starting-interval harmonic-seed starting-note)

(starting-interval harmonic-seed))))

(do* ((counter

(- n 2)

(decf counter))

(current-interval-reference

interval-seed

(list (second output) (first output)))

(output (cons

(uniform-random-weight

(weight-for-list

(check-and-get-legal-movements-in-ordered-net

current-interval-reference

interval-reservoir)))

(list (second interval-seed)))

(cons

(uniform-random-weight

(weight-for-list

(check-and-get-legal-movements-in-ordered-net

current-interval-reference

interval-reservoir)))

output)))

((= 0 counter) (reverse output)))))

;;(atonal-melodic-expectancy-random-generation 4 '(48 59 63 74) '(1 2 3 4 10 11 13 14))

;;(atonal-melodic-expectancy-random-generation 4 '(48 59 63 74) '(1 2 3 4 10 11 13 14) 74)

;;(atonal-melodic-expectancy-random-generation 4 '(48 57 59 60) '(1 2 3 4 10 11 13 14))

;;(atonal-melodic-expectancy-random-generation 4 '(48 57 59 60) '(1 2 3 4 10 11 13 14) 59)

;;(atonal-melodic-expectancy-random-generation 4 '(48 57 59 60) '(1 2 3 4 5 7 10 11 13 14) 59)

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

;; Melodic Net Printing

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

(defun print-melodic-net* (harmonic-seed interval-reservoir)

(let ((melodic-net (get-melodic-net harmonic-seed interval-reservoir)))

(loop for x in melodic-net

collect (list (first x) (sort (cons (first x) (second x)) #'<)))))

;;(print-melodic-net* '(48 59 63 74) '(1 2 3 4 10 11))

(defun print-melodic-net (harmonic-seed interval-reservoir)

(loop for x in (print-melodic-net* harmonic-seed interval-reservoir)

do (print x))

(format t "~&~a" "====================")

(loop for x in (print-melodic-net* harmonic-seed interval-reservoir)

collect (first x)))

;;(print-melodic-net '(48 59 63 74) '(1 2 3 4 10 11))

;;(print-melodic-net '(48 59 63 74) '(1 2 3 4 5 10 11))

;;(atonal-melodic-expectancy-random-generation 8 '(48 59 63 74) '(1 2 3 4 10 11))

;;(atonal-melodic-expectancy-random-generation 8 '(48 59 63 74) '(1 2 3 4 5 10 11) 74)