;======================================
|
;OM-Lead, 2022-2023
|
;
|
;Library for Rule-based Voice-Leading
|
;Author: Lorenz Lehmann
|
;Supervision: Marlon Schumacher
|
;======================================
|
|
|
|
|
(in-package :omlead)
|
|
(om::defmethod! gen-sequence (harmonies first-harmony number-of-harmonies &key avoid-repetitions voice-tie1 voice-tie2 voice-tie3 voice-tie4 voice-interval1 voice-interval2 voice-interval3 voice-interval4 voice-counter1 counter-interval1 voice-counter2 counter-interval2 voice-counter3 counter-interval3 voice-counter4 counter-interval4 voice-counter5 counter-interval5 voice-counter6 counter-interval6 base-list)
|
|
:icon 030719972
|
|
:numouts 1
|
|
|
|
|
(let* ((harmon-database harmonies)
|
(database (cond (base-list (loop repeat (1- number-of-harmonies)
|
for x in (circular_oml base-list)
|
collect (nth (1- x) harmon-database)))
|
|
(t (loop repeat (1- number-of-harmonies) collect harmon-database))))
|
|
|
|
|
|
(external-list '()))
|
(append (list first-harmony)
|
(loop repeat (- number-of-harmonies 1)
|
for database in database
|
|
for voice-tie1 in (cond ((atom voice-tie1) (loop repeat (1- number-of-harmonies) collect voice-tie1))
|
((< (length voice-tie1) (1- number-of-harmonies))
|
(append voice-tie1 (loop repeat (- (1- number-of-harmonies) (length voice-tie1)) collect (car (reverse voice-tie1)))))
|
(t voice-tie1))
|
for voice-tie2 in (cond ((atom voice-tie2) (loop repeat (1- number-of-harmonies) collect voice-tie2))
|
((< (length voice-tie2) (1- number-of-harmonies))
|
(append voice-tie2 (loop repeat (- (1- number-of-harmonies) (length voice-tie2)) collect (car (reverse voice-tie2)))))
|
(t voice-tie2))
|
for voice-tie3 in (cond ((atom voice-tie3) (loop repeat (1- number-of-harmonies) collect voice-tie3))
|
((< (length voice-tie3) (1- number-of-harmonies))
|
(append voice-tie3 (loop repeat (- (1- number-of-harmonies) (length voice-tie3)) collect (car (reverse voice-tie3)))))
|
(t voice-tie3))
|
for voice-tie4 in (cond ((atom voice-tie4) (loop repeat (1- number-of-harmonies) collect voice-tie4))
|
((< (length voice-tie4) (1- number-of-harmonies))
|
(append voice-tie4 (loop repeat (- (1- number-of-harmonies) (length voice-tie4)) collect (car (reverse voice-tie4)))))
|
(t voice-tie4))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
for voice-interval1 in (cond ((atom (car voice-interval1)) (loop repeat (1- number-of-harmonies) collect voice-interval1))
|
((< (length voice-interval1) (1- number-of-harmonies))
|
(append voice-interval1 (loop repeat (- (1- number-of-harmonies) (length voice-interval1)) collect (car (reverse voice-interval1)))))
|
(t voice-interval1))
|
for voice-interval2 in (cond ((atom (car voice-interval2)) (loop repeat (1- number-of-harmonies) collect voice-interval2))
|
((< (length voice-interval2) (1- number-of-harmonies))
|
(append voice-interval2 (loop repeat (- (1- number-of-harmonies) (length voice-interval2)) collect (car (reverse voice-interval2)))))
|
(t voice-interval2))
|
for voice-interval3 in (cond ((atom (car voice-interval3)) (loop repeat (1- number-of-harmonies) collect voice-interval3))
|
((< (length voice-interval3) (1- number-of-harmonies))
|
(append voice-interval3 (loop repeat (- (1- number-of-harmonies) (length voice-interval3)) collect (car (reverse voice-interval3)))))
|
(t voice-interval3))
|
for voice-interval4 in (cond ((atom (car voice-interval4)) (loop repeat (1- number-of-harmonies) collect voice-interval4))
|
((< (length voice-interval4) (1- number-of-harmonies))
|
(append voice-interval4 (loop repeat (- (1- number-of-harmonies) (length voice-interval4)) collect (car (reverse voice-interval4)))))
|
(t voice-interval4))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
for voice-counter1 in (cond ((atom voice-counter1)
|
(loop repeat (1- number-of-harmonies) collect voice-counter1))
|
((listp (caar voice-counter1))
|
(if (< (length voice-counter1) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter1))
|
voice-counter1))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter1)))
|
|
|
for voice-counter2 in (cond ((atom voice-counter2)
|
(loop repeat (1- number-of-harmonies) collect voice-counter2))
|
((listp (caar voice-counter2))
|
(if (< (length voice-counter2) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter2))
|
voice-counter2))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter2)))
|
|
|
for voice-counter3 in (cond ((atom voice-counter3)
|
(loop repeat (1- number-of-harmonies) collect voice-counter3))
|
((listp (caar voice-counter3))
|
(if (< (length voice-counter3) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter3))
|
voice-counter3))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter3)))
|
|
|
for voice-counter4 in (cond ((atom voice-counter4)
|
(loop repeat (1- number-of-harmonies) collect voice-counter4))
|
((listp (caar voice-counter4))
|
(if (< (length voice-counter4) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter4))
|
voice-counter4))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter4)))
|
|
|
for voice-counter5 in (cond ((atom voice-counter5)
|
(loop repeat (1- number-of-harmonies) collect voice-counter5))
|
((listp (caar voice-counter5))
|
(if (< (length voice-counter5) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter5))
|
voice-counter5))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter5)))
|
|
|
for voice-counter6 in (cond ((atom voice-counter6)
|
(loop repeat (1- number-of-harmonies) collect voice-counter6))
|
((listp (caar voice-counter6))
|
(if (< (length voice-counter6) (1- number-of-harmonies))
|
(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter6))
|
voice-counter6))
|
(t (loop repeat (1- number-of-harmonies) collect voice-counter6)))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
for counter-interval1 in (cond ((atom (car counter-interval1)) (loop repeat (1- number-of-harmonies) collect counter-interval1))
|
((< (length counter-interval1) (1- number-of-harmonies))
|
(append counter-interval1 (loop repeat (- (1- number-of-harmonies) (length counter-interval1)) collect (car (reverse counter-interval1)))))
|
(t counter-interval1))
|
for counter-interval2 in (cond ((atom (car counter-interval2)) (loop repeat (1- number-of-harmonies) collect counter-interval2))
|
((< (length counter-interval2) (1- number-of-harmonies))
|
(append counter-interval2 (loop repeat (- (1- number-of-harmonies) (length counter-interval2)) collect (car (reverse counter-interval2)))))
|
(t counter-interval2))
|
for counter-interval3 in (cond ((atom (car counter-interval3)) (loop repeat (1- number-of-harmonies) collect counter-interval3))
|
((< (length counter-interval3) (1- number-of-harmonies))
|
(append counter-interval3 (loop repeat (- (1- number-of-harmonies) (length counter-interval3)) collect (car (reverse counter-interval3)))))
|
(t counter-interval3))
|
for counter-interval4 in (cond ((atom (car counter-interval4)) (loop repeat (1- number-of-harmonies) collect counter-interval4))
|
((< (length counter-interval4) (1- number-of-harmonies))
|
(append counter-interval4 (loop repeat (- (1- number-of-harmonies) (length counter-interval4)) collect (car (reverse counter-interval4)))))
|
(t counter-interval4))
|
for counter-interval5 in (cond ((atom (car counter-interval5)) (loop repeat (1- number-of-harmonies) collect counter-interval5))
|
((< (length counter-interval5) (1- number-of-harmonies))
|
(append counter-interval5 (loop repeat (- (1- number-of-harmonies) (length counter-interval5)) collect (car (reverse counter-interval5)))))
|
(t counter-interval5))
|
for counter-interval6 in (cond ((atom (car counter-interval6)) (loop repeat (1- number-of-harmonies) collect counter-interval6))
|
((< (length counter-interval6) (1- number-of-harmonies))
|
(append counter-interval6 (loop repeat (- (1- number-of-harmonies) (length counter-interval6)) collect (car (reverse counter-interval6)))))
|
(t counter-interval6))
|
|
|
|
|
|
collect
|
(let* ((second (append (list first-harmony) (reverse external-list)))
|
(first (car (last second)));6000 6700
|
(second (let* ((temp-base database)
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(temp-base (cond (avoid-repetitions (let ((looplist
|
(remove nil (loop for a in temp-base
|
collect (if
|
(car
|
(remove nil
|
(mapcar #'(lambda (l) (eq (car l) (cadr l)))
|
(mat-trans_oml (list first a))))) nil a)))))
|
|
(if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)))
|
(t temp-base)))
|
|
|
(temp-base (cond (voice-tie1
|
(let* ((voice-tie1 (- voice-tie1 1))
|
(looplist (remove nil
|
(loop for a in temp-base
|
collect
|
|
(cond ((eq (nth voice-tie1 a) (nth voice-tie1 first)) a)
|
((eq (nth voice-tie1 first) -1) a)
|
(t nil))))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a voice-tie1 -1))
|
looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-tie2
|
(let* ((voice-tie2 (- voice-tie2 1))
|
(looplist (remove nil
|
(loop for a in temp-base
|
collect
|
|
(cond ((eq (nth voice-tie2 a) (nth voice-tie2 first)) a)
|
((eq (nth voice-tie2 first) -1) a)
|
(t nil))))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a voice-tie2 -1))
|
looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-tie3
|
(let* ((voice-tie3 (- voice-tie3 1))
|
(looplist (remove nil
|
(loop for a in temp-base
|
collect
|
|
(cond ((eq (nth voice-tie3 a) (nth voice-tie3 first)) a)
|
((eq (nth voice-tie3 first) -1) a)
|
(t nil))))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a voice-tie3 -1))
|
looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-tie4
|
(let* ((voice-tie4 (- voice-tie4 1))
|
(looplist (remove nil
|
(loop for a in temp-base
|
collect
|
|
(cond ((eq (nth voice-tie4 a) (nth voice-tie4 first)) a)
|
((eq (nth voice-tie4 first) -1) a)
|
(t nil))))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a voice-tie4 -1))
|
looplist)))
|
(t temp-base)))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(temp-base (cond (voice-interval1
|
(let ((looplist (remove nil (loop for a in temp-base
|
collect
|
(if (or (find (- (nth 0 a) (nth 0 first)) voice-interval1)
|
(eq (nth 0 first) -1)) a)))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a 0 -1)) looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-interval2
|
(let ((looplist (remove nil (loop for a in temp-base
|
collect
|
(if (or (find (- (nth 1 a) (nth 1 first)) voice-interval2)
|
(eq (nth 1 first) -1)) a)))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a 1 -1)) looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-interval3
|
(let ((looplist (remove nil (loop for a in temp-base
|
collect
|
(if (or (find (- (nth 2 a) (nth 2 first)) voice-interval3)
|
(eq (nth 2 first) -1)) a)))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a 2 -1)) looplist)))
|
(t temp-base)))
|
|
(temp-base (cond (voice-interval4
|
(let ((looplist (remove nil (loop for a in temp-base
|
collect
|
(if (or (find (- (nth 3 a) (nth 3 first)) voice-interval4)
|
(eq (nth 3 first) -1)) a)))))
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a 3 -1)) looplist)))
|
(t temp-base)))
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(temp-base (cond (voice-counter1
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter1))) first))
|
(eq -1 (nth (1- (second (car voice-counter1))) first))) counter-interval1)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter1)))) ;0
|
(instr-b (1- (second (car voice-counter1))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval1) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter1))) first))
|
(eq -1 (nth (1- (second (car voice-counter1))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter1)))) ;0
|
(instr-b (1- (second (car voice-counter1)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter1)))
|
(cond
|
|
|
|
|
(counter-interval1
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter1))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
(temp-base (cond (voice-counter2
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter2))) first))
|
(eq -1 (nth (1- (second (car voice-counter2))) first))) counter-interval2)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter2)))) ;0
|
(instr-b (1- (second (car voice-counter2))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval2) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter2))) first))
|
(eq -1 (nth (1- (second (car voice-counter2))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter2)))) ;0
|
(instr-b (1- (second (car voice-counter2)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter2)))
|
(cond
|
|
|
|
|
(counter-interval2
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter2))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
(temp-base (cond (voice-counter3
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter3))) first))
|
(eq -1 (nth (1- (second (car voice-counter3))) first))) counter-interval3)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter3)))) ;0
|
(instr-b (1- (second (car voice-counter3))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval3) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter3))) first))
|
(eq -1 (nth (1- (second (car voice-counter3))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter3)))) ;0
|
(instr-b (1- (second (car voice-counter3)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter3)))
|
(cond
|
|
|
|
|
(counter-interval3
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter3))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
|
(temp-base (cond (voice-counter4
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter4))) first))
|
(eq -1 (nth (1- (second (car voice-counter4))) first))) counter-interval4)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter4)))) ;0
|
(instr-b (1- (second (car voice-counter4))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval4) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter4))) first))
|
(eq -1 (nth (1- (second (car voice-counter4))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter4)))) ;0
|
(instr-b (1- (second (car voice-counter4)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter4)))
|
(cond
|
|
|
|
|
(counter-interval4
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter4))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
|
(temp-base (cond (voice-counter5
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter5))) first))
|
(eq -1 (nth (1- (second (car voice-counter5))) first))) counter-interval5)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter5)))) ;0
|
(instr-b (1- (second (car voice-counter5))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval5) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter5))) first))
|
(eq -1 (nth (1- (second (car voice-counter5))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter5)))) ;0
|
(instr-b (1- (second (car voice-counter5)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter5)))
|
(cond
|
|
|
|
|
(counter-interval5
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter5))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
|
(temp-base (cond (voice-counter6
|
|
(cond ((and (or (eq -1 (nth (1- (first (car voice-counter6))) first))
|
(eq -1 (nth (1- (second (car voice-counter6))) first))) counter-interval6)
|
|
(remove nil (loop for a in temp-base
|
collect (let* ((instr-a (1- (first (car voice-counter6)))) ;0
|
(instr-b (1- (second (car voice-counter6))))
|
(voice-i (- (nth instr-b a) (nth instr-a a))) )
|
(if (find voice-i counter-interval6) a)))))
|
|
((or (eq -1 (nth (1- (first (car voice-counter6))) first))
|
(eq -1 (nth (1- (second (car voice-counter6))) first))) temp-base)
|
|
(t (let ((looplist (remove nil
|
(loop for a in temp-base
|
collect
|
(let* ((instr-a (1- (first (car voice-counter6)))) ;0
|
(instr-b (1- (second (car voice-counter6)))) ;1
|
(delta-a (- (nth instr-a a) (nth instr-a first)))
|
(delta-b (- (nth instr-b a) (nth instr-b first)))
|
(rule (second voice-counter6)))
|
(cond
|
|
|
|
|
(counter-interval6
|
(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'parallel)
|
((and (or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b)))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'contrary)
|
((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
|
(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'seiten)))
|
a))
|
|
|
(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
|
(and (> 0 delta-a) (> 0 delta-b))
|
(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
|
((or (and (< 0 delta-a) (> 0 delta-b))
|
(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
|
((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
|
(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
|
a))))))))
|
|
|
|
(if (null looplist)
|
(loop for a in temp-base
|
collect
|
(subs-posn_oml a (1- (first (car voice-counter6))) -1)) looplist)))))
|
|
|
|
(t temp-base)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(nth (random (length temp-base)) temp-base)
|
)))
|
|
|
|
(push second external-list)
|
(values second))))))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(defun mat-trans_oml (list)
|
(loop for y in (let (count-list)
|
(dotimes (i (length (car list)))
|
(setq count-list (cons i count-list))) (nreverse count-list))
|
collect (loop for x in list collect (nth y x))
|
|
))
|
|
|
(defun posn-match_oml (list positions)
|
(cond ((null positions) '())
|
((atom positions) (nth positions list))
|
(t (append (list (posn-match_oml list (car positions)))
|
(if (posn-match_oml list (cdr positions))
|
(posn-match_oml list (cdr positions))
|
'())))))
|
|
|
(defun subs-posn_oml (list position item)
|
(loop for a from 0
|
for b in list
|
collect (if (= a position) item b)))
|
|
|
(defun oml- (list atom)
|
(mapcar (lambda (it) (- it atom)) list))
|
|
|
(defun find-dups_oml (liste)
|
(car
|
(remove nil
|
(mapcar #'(lambda (l c) (eq l c)) liste (cdr liste)))))
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
