;====================================== ;OM-Lead, 2022-2023 ; ;Library for Rule-based Voice-Leading ;Author: Lorenz Lehmann ;Supervision: Marlon Schumacher ;====================================== (in-package :omlead) (om::defmethod! harmon-progress (harmon-database first-chord chordnumber &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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (let* ((harmon-database harmon-database) (database (cond (base-list (loop repeat (1- chordnumber) for x in (circular_oml base-list) collect (nth (1- x) harmon-database))) (t (loop repeat (1- chordnumber) collect harmon-database)))) (external-list '())) (append (list first-chord) (loop repeat (- chordnumber 1) for database in database for voice-tie1 in (cond ((atom voice-tie1) (loop repeat chordnumber collect voice-tie1)) ((< (length voice-tie1) chordnumber) (append voice-tie1 (loop repeat (- chordnumber (length voice-tie1)) collect (car (reverse voice-tie1))))) (t voice-tie1)) for voice-tie2 in (cond ((atom voice-tie2) (loop repeat chordnumber collect voice-tie2)) ((< (length voice-tie2) chordnumber) (append voice-tie2 (loop repeat (- chordnumber (length voice-tie2)) collect (car (reverse voice-tie2))))) (t voice-tie2)) for voice-tie3 in (cond ((atom voice-tie3) (loop repeat chordnumber collect voice-tie3)) ((< (length voice-tie3) chordnumber) (append voice-tie3 (loop repeat (- chordnumber (length voice-tie3)) collect (car (reverse voice-tie3))))) (t voice-tie3)) for voice-tie4 in (cond ((atom voice-tie4) (loop repeat chordnumber collect voice-tie4)) ((< (length voice-tie4) chordnumber) (append voice-tie4 (loop repeat (- chordnumber (length voice-tie4)) collect (car (reverse voice-tie4))))) (t voice-tie4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; for voice-interval1 in (cond ((atom (car voice-interval1)) (loop repeat chordnumber collect voice-interval1)) ((< (length voice-interval1) chordnumber) (append voice-interval1 (loop repeat (- chordnumber (length voice-interval1)) collect (car (reverse voice-interval1))))) (t voice-interval1)) for voice-interval2 in (cond ((atom (car voice-interval2)) (loop repeat chordnumber collect voice-interval2)) ((< (length voice-interval2) chordnumber) (append voice-interval2 (loop repeat (- chordnumber (length voice-interval2)) collect (car (reverse voice-interval2))))) (t voice-interval2)) for voice-interval3 in (cond ((atom (car voice-interval3)) (loop repeat chordnumber collect voice-interval3)) ((< (length voice-interval3) chordnumber) (append voice-interval3 (loop repeat (- chordnumber (length voice-interval3)) collect (car (reverse voice-interval3))))) (t voice-interval3)) for voice-interval4 in (cond ((atom (car voice-interval4)) (loop repeat chordnumber collect voice-interval4)) ((< (length voice-interval4) chordnumber) (append voice-interval4 (loop repeat (- chordnumber (length voice-interval4)) collect (car (reverse voice-interval4))))) (t voice-interval4)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; for voice-counter1 in (if (eq nil voice-counter1) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter1))) (loop repeat chordnumber collect (car voice-counter1))) ((< (length (car voice-counter1)) chordnumber) (append (car voice-counter1) (loop repeat (- chordnumber (length (car voice-counter1))) collect (car (reverse (car voice-counter1)))))) (t (car voice-counter1))) (cond ((< (length (cadr voice-counter1)) chordnumber) (append (cadr voice-counter1) (loop repeat (- chordnumber (length (cadr voice-counter1))) collect (car (reverse (cadr voice-counter1)))))) (t (cadr voice-counter1)))))) for voice-counter2 in (if (eq nil voice-counter2) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter2))) (loop repeat chordnumber collect (car voice-counter2))) ((< (length (car voice-counter2)) chordnumber) (append (car voice-counter2) (loop repeat (- chordnumber (length (car voice-counter2))) collect (car (reverse (car voice-counter2)))))) (t (car voice-counter2))) (cond ((< (length (cadr voice-counter2)) chordnumber) (append (cadr voice-counter2) (loop repeat (- chordnumber (length (cadr voice-counter2))) collect (car (reverse (cadr voice-counter2)))))) (t (cadr voice-counter2)))))) for voice-counter3 in (if (eq nil voice-counter3) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter3))) (loop repeat chordnumber collect (car voice-counter3))) ((< (length (car voice-counter3)) chordnumber) (append (car voice-counter3) (loop repeat (- chordnumber (length (car voice-counter3))) collect (car (reverse (car voice-counter3)))))) (t (car voice-counter3))) (cond ((< (length (cadr voice-counter3)) chordnumber) (append (cadr voice-counter3) (loop repeat (- chordnumber (length (cadr voice-counter3))) collect (car (reverse (cadr voice-counter3)))))) (t (cadr voice-counter3)))))) for voice-counter4 in (if (eq nil voice-counter4) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter4))) (loop repeat chordnumber collect (car voice-counter4))) ((< (length (car voice-counter4)) chordnumber) (append (car voice-counter4) (loop repeat (- chordnumber (length (car voice-counter4))) collect (car (reverse (car voice-counter4)))))) (t (car voice-counter4))) (cond ((< (length (cadr voice-counter4)) chordnumber) (append (cadr voice-counter4) (loop repeat (- chordnumber (length (cadr voice-counter4))) collect (car (reverse (cadr voice-counter4)))))) (t (cadr voice-counter4)))))) for voice-counter5 in (if (eq nil voice-counter5) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter5))) (loop repeat chordnumber collect (car voice-counter5))) ((< (length (car voice-counter5)) chordnumber) (append (car voice-counter5) (loop repeat (- chordnumber (length (car voice-counter5))) collect (car (reverse (car voice-counter5)))))) (t (car voice-counter5))) (cond ((< (length (cadr voice-counter5)) chordnumber) (append (cadr voice-counter5) (loop repeat (- chordnumber (length (cadr voice-counter5))) collect (car (reverse (cadr voice-counter5)))))) (t (cadr voice-counter5)))))) for voice-counter6 in (if (eq nil voice-counter6) (loop repeat chordnumber collect nil) (mat-trans_oml (list (cond ((not (listp (caar voice-counter6))) (loop repeat chordnumber collect (car voice-counter6))) ((< (length (car voice-counter6)) chordnumber) (append (car voice-counter6) (loop repeat (- chordnumber (length (car voice-counter6))) collect (car (reverse (car voice-counter6)))))) (t (car voice-counter6))) (cond ((< (length (cadr voice-counter6)) chordnumber) (append (cadr voice-counter6) (loop repeat (- chordnumber (length (cadr voice-counter6))) collect (car (reverse (cadr voice-counter6)))))) (t (cadr voice-counter6)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; for counter-interval1 in (cond ((atom (car counter-interval1)) (loop repeat chordnumber collect counter-interval1)) ((< (length counter-interval1) chordnumber) (append counter-interval1 (loop repeat (- chordnumber (length counter-interval1)) collect (car (reverse counter-interval1))))) (t counter-interval1)) for counter-interval2 in (cond ((atom (car counter-interval2)) (loop repeat chordnumber collect counter-interval2)) ((< (length counter-interval2) chordnumber) (append counter-interval2 (loop repeat (- chordnumber (length counter-interval2)) collect (car (reverse counter-interval2))))) (t counter-interval2)) for counter-interval3 in (cond ((atom (car counter-interval3)) (loop repeat chordnumber collect counter-interval3)) ((< (length counter-interval3) chordnumber) (append counter-interval3 (loop repeat (- chordnumber (length counter-interval3)) collect (car (reverse counter-interval3))))) (t counter-interval3)) for counter-interval4 in (cond ((atom (car counter-interval4)) (loop repeat chordnumber collect counter-interval4)) ((< (length counter-interval4) chordnumber) (append counter-interval4 (loop repeat (- chordnumber (length counter-interval4)) collect (car (reverse counter-interval4))))) (t counter-interval4)) for counter-interval5 in (cond ((atom (car counter-interval5)) (loop repeat chordnumber collect counter-interval5)) ((< (length counter-interval5) chordnumber) (append counter-interval5 (loop repeat (- chordnumber (length counter-interval5)) collect (car (reverse counter-interval5))))) (t counter-interval5)) for counter-interval6 in (cond ((atom (car counter-interval6)) (loop repeat chordnumber collect counter-interval6)) ((< (length counter-interval6) chordnumber) (append counter-interval6 (loop repeat (- chordnumber (length counter-interval6)) collect (car (reverse counter-interval6))))) (t counter-interval6)) collect (let* ((second (nconc (list first-chord) external-list)) (first (car (last second)));6000 6700 (second (let* ((temp-base database) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (temp-base (cond (avoid-repetitions (setq 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))) (setq 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 a) -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))) (setq 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 a) -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))) (setq 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 a) -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))) (setq 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 a) -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 (setq 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 (setq 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 (setq 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 (setq 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 (setq 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 (equal 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 (setq 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 (equal 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 (setq 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 (equal 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 (setq 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 (equal 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 (setq 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 (equal 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 (setq 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 (equal 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) ))) (nreverse (push second external-list)) (values second)))))) ;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;