;;********************************************
;;********************************************
;;////////////////////////////////////////////
;;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)
t
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))
t
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))
x
(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))))
(t
(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)
t
nil)))
|#
;; To
allow repetitions on legal melodic-movements:
(defun
legal-melodic-movement-p (melodic-pair)
(if (equal (first melodic-pair) (second
melodic-pair))
t
(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)
t
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)