From 28dae6acba357fecd7aca30f025a1d4e626b568c Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Thu, 28 Mar 2024 00:09:22 +0100
Subject: [PATCH] fix (sources): gen-harmonies
---
sources/gen-sequence.lisp | 868 +++++++++++++++------------------------------------------
1 files changed, 225 insertions(+), 643 deletions(-)
diff --git a/sources/gen-sequence.lisp b/sources/gen-sequence.lisp
index 9cf5e47..a111182 100644
--- a/sources/gen-sequence.lisp
+++ b/sources/gen-sequence.lisp
@@ -11,670 +11,218 @@
(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)
+(om::defmethod! gen-sequence (harmonies first-harmony number-of-harmonies error-out single-voice-progress voice-pair-progress)
-:icon 030719972
+:icon 030719979
:numouts 1
+(let ((external-list (list first-harmony))
+ (harmonies (if (atom (caar harmonies)) (list (list harmonies) 'hold) harmonies))
+ (error-out (if (or (find 'hold error-out) (find 'circular error-out)) error-out (list (list error-out) 'hold)))
+ (single-voice-progress (cond ((null single-voice-progress) nil)
+ ((atom (caar single-voice-progress)) (list single-voice-progress))
+ (t single-voice-progress)))
+ (voice-pair-progress (cond ((null voice-pair-progress) nil)
+ ((atom (caaar voice-pair-progress)) (list voice-pair-progress))
+ (t voice-pair-progress))))
-(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))))
+
+(loop for counter to (- number-of-harmonies 2)
+ do (let* ((first (car external-list))
+ (temp-harmonies (cond ((eq 'circular (car (last harmonies))) (circular-list (car harmonies) counter))
+ (t (hold-list (car harmonies) counter))))
+ (temp-error (cond ((eq 'circular (car (last error-out))) (circular-list (car error-out) counter))
+ (t (hold-list (car error-out) counter))))
+ (temp-harmonies (if single-voice-progress (remove nil (loop for voice-box in single-voice-progress
+ append (loop for second in temp-harmonies
+ collect (if (funcall (if (eq 'circular (third voice-box))
+ (circular-list (second voice-box) counter)
+ (hold-list (second voice-box) counter))
+ (first voice-box) first second) second) )) ) temp-harmonies))
+ (temp-harmonies (if voice-pair-progress (remove nil (loop for pair-box in voice-pair-progress
+ append (loop for second in temp-harmonies
+ collect (if (funcall (if (eq 'circular (third pair-box))
+ (circular-list (second pair-box) counter)
+ (hold-list (second pair-box) counter))
+ (first pair-box) first second) second) )) ) temp-harmonies )))
+
+
+
+ (if (null temp-harmonies)
+(push temp-error external-list) (push (nth-random temp-harmonies) external-list))))
+
+ (reverse external-list)))
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+;;;;;;;;;;;;;;;;;;;;;apply-boxes;;;;;;;;;;;;;;;;;;;;;;;;
+
+(om::defmethod! single-voice-progress (ids rules (mode symbol))
+ :icon 0307199710
+ :initvals '(nil nil 'circular)
+ :menuins '((2 (("circular" 'circular) ("hold" 'hold))))
+ (list (list! ids)
+ (list! rules)
+ mode))
+
+(om::defmethod! voice-pair-progress (ids rules (mode symbol))
+ :icon 0307199712
+ :initvals '(nil nil 'circular)
+ :menuins '((2 (("circular" 'circular) ("hold" 'hold))))
+ (list (if (atom (car ids)) (list ids) ids)
+ (list! rules)
+ mode))
+
+(om::defmethod! choose-error-out (error-value (mode symbol))
+ :icon 0307199715
+ :initvals '(nil 'hold)
+ :menuins '((1 (("circular" 'circular) ("hold" 'hold))))
+(list (if (atom (car error-value)) (list error-value) error-value) mode))
+
+(om::defmethod! choose-harmonies (harmonies (mode symbol))
+ :icon 0307199715
+ :initvals '(nil 'hold)
+ :menuins '((1 (("circular" 'circular) ("hold" 'hold))))
+(list (if (atom (car harmonies)) (list harmonies) harmonies) mode))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;svp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(om::defmethod! avoid-interval (voice first second)
+ :icon 0307199711
+ (cond ((or (equal (nth voice first) choose-error-out) (equal (nth voice second) choose-error-out)) t)
+ ((equal (nth voice first) (nth voice second)) nil)
+ (t t)))
- (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))
+(om::defmethod! voice-interval (ids first second intervals (mode symbol))
+ :icon 0307199711
+ :menuins '((4 (("only" 'only) ("except" 'except))))
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- 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))
+ (if (eq mode 'only) (tester_oml
+ (lambda (y) (find y intervals))
+ (mapcar (lambda (x) (nth x (mapcar '- second first))) ids))
+ (tester_oml
+ (lambda (y) (not (find y intervals)))
+ (mapcar (lambda (x) (nth x (mapcar '- second first))) ids))))
- 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)))
-
-
-
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun find_oml (item liste &optional (start 0))
-(nth (random (length temp-base)) temp-base)
- )))
-
-
-
- (push second external-list)
- (values second))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(cond ((null liste) start)
+ ((eq (car liste) item) (find_oml item (cdr liste) (1+ start)))
+ (t (find_oml item (cdr liste) start))))
+
+
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;;;;;;;;;;;vpp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(om::defmethod! oblique-motion (ids first second)
+ :icon 0307199713
+ (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
+ collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
+ voice-pair)))
+
+ (and (condition_oml (lambda (x) (= x 0)) deltas)
+ (condition_oml (lambda (x) (/= x 0)) deltas))))))
+
+
+(om::defmethod! contrary-motion (ids first second)
+ :icon 0307199713
+ (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
+ collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
+ voice-pair)))
+
+ (eq (condition_oml (lambda (x) (> x 0)) deltas)
+ (condition_oml (lambda (x) (< x 0)) deltas))))))
+
+
+
+(om::defmethod! similar-motion (ids first second)
+ :icon 0307199713
+ (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
+ collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
+ voice-pair)))
+
+ (or (tester_oml (lambda (x) (> x 0)) deltas)
+ (tester_oml (lambda (x) (< x 0)) deltas))))))
+
+(om::defmethod! parallel-motion (ids first second)
+ :icon 0307199713
+ (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
+ collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
+ voice-pair)))
+ (reduce '= deltas)))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+
+;;;;;;;;;;;;;;;;;;Hilfsfunktionen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+(defun condition_oml (test liste)
+(cond ((null liste) nil)
+((funcall test (car liste)) t)
+(t (condition_oml test (cdr liste)))
+))
+
+(defun list! (item)
+(cond ((atom item) (list item))
+ (t item)))
+
+
+(defun apply-rule_oml (harmonies rule first choose-error-out)
+(let ((database harmonies))
+
+(loop for function in rule
+ do (loop for harmony in database
+ do (if (funcall (cadr function) (car function) first harmony choose-error-out) nil (setf database (delete harmony database)))))
+
+(if (null database) choose-error-out
+(nth (random (length database)) database))))
+
+(defun hold_oml (items)
+(append (butlast items) (setf (cdr (last items)) (last items))))
+
(defun mat-trans_oml (list)
(loop for y in (let (count-list)
@@ -683,6 +231,19 @@
collect (loop for x in list collect (nth y x))
))
+
+
+(defun my-recursive-fun (dur-list minimum divisor-list)
+
+(let ((divisor (om::nth-random (car divisor-list))))
+(cond
+ ((null dur-list) dur-list)
+ ((>= (/ (car dur-list) divisor) minimum)
+
+ (append (my-recursive-fun (om::repeat-n (/ (car dur-list) divisor) divisor) minimum (om::repeat-n (car divisor-list) divisor))
+ (my-recursive-fun (cdr dur-list) minimum (cdr divisor-list))))
+ (t (append (list (car dur-list)) (my-recursive-fun (cdr dur-list) minimum (cdr divisor-list)))))))
+
(defun posn-match_oml (list positions)
@@ -700,6 +261,17 @@
collect (if (= a position) item b)))
+(defun subs-posn (lis1 posn val)
+
+ (let ((copy (copy-list lis1)))
+ (if (listp posn)
+ (loop for item in posn
+ for i = 0 then (+ i 1) do
+ (setf (nth item copy) (if (listp val) (nth i val) val)))
+ (setf (nth posn copy) val))
+ copy))
+
+
(defun oml- (list atom)
(mapcar (lambda (it) (- it atom)) list))
@@ -709,15 +281,25 @@
(remove nil
(mapcar #'(lambda (l c) (eq l c)) liste (cdr liste)))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun nth-random (list)
+ (nth (random (length list)) list))
+(defun circular-list (liste counter &key (start 0))
+
+(cond
+ ((= counter 0) (nth start liste))
+ ((< start (1- (length liste))) (circular-list liste (1- counter) :start (1+ start)))
+ (t (circular-list liste (1- counter) :start 0))))
+(defun hold-list (liste counter)
+(if (> counter (1- (length liste)))
+ (car (last liste))
+ (nth counter liste)))
+
--
Gitblit v1.9.1