SymProg/OM-Lead.git

Lorenz Lehmann

12.02.24 f3e3b20c9bce4a635d3b7a99bc1f02e4310e516b

commit \| author \| age
71cec5	1	;======================================
MS	2	;OM-Lead, 2022-2023
	3	;
	4	;Library for Rule-based Voice-Leading
	5	;Author: Lorenz Lehmann
	6	;Supervision: Marlon Schumacher
	7	;======================================
	8
a53ccf	9
LL	10
	11
71cec5	12	(in-package :omlead)
MS	13
22fa58	14	(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)
71cec5	15
MS	16	:icon 030719972
	17
	18	:numouts 1
	19
	20
	21
	22
22fa58	23	(let* ((harmon-database harmonies)
LL	24	(database (cond (base-list (loop repeat (1- number-of-harmonies)
71cec5	25	for x in (circular_oml base-list)
MS	26	collect (nth (1- x) harmon-database)))
	27
22fa58	28	(t (loop repeat (1- number-of-harmonies) collect harmon-database))))
71cec5	29
MS	30
	31
	32
	33
	34	(external-list '()))
22fa58	35	(append (list first-harmony)
LL	36	(loop repeat (- number-of-harmonies 1)
71cec5	37	for database in database
MS	38
814320	39	for voice-tie1 in (cond ((atom voice-tie1) (loop repeat (1- number-of-harmonies) collect voice-tie1))
LL	40	((< (length voice-tie1) (1- number-of-harmonies))
	41	(append voice-tie1 (loop repeat (- (1- number-of-harmonies) (length voice-tie1)) collect (car (reverse voice-tie1)))))
71cec5	42	(t voice-tie1))
814320	43	for voice-tie2 in (cond ((atom voice-tie2) (loop repeat (1- number-of-harmonies) collect voice-tie2))
LL	44	((< (length voice-tie2) (1- number-of-harmonies))
	45	(append voice-tie2 (loop repeat (- (1- number-of-harmonies) (length voice-tie2)) collect (car (reverse voice-tie2)))))
71cec5	46	(t voice-tie2))
814320	47	for voice-tie3 in (cond ((atom voice-tie3) (loop repeat (1- number-of-harmonies) collect voice-tie3))
LL	48	((< (length voice-tie3) (1- number-of-harmonies))
	49	(append voice-tie3 (loop repeat (- (1- number-of-harmonies) (length voice-tie3)) collect (car (reverse voice-tie3)))))
71cec5	50	(t voice-tie3))
814320	51	for voice-tie4 in (cond ((atom voice-tie4) (loop repeat (1- number-of-harmonies) collect voice-tie4))
LL	52	((< (length voice-tie4) (1- number-of-harmonies))
	53	(append voice-tie4 (loop repeat (- (1- number-of-harmonies) (length voice-tie4)) collect (car (reverse voice-tie4)))))
71cec5	54	(t voice-tie4))
MS	55
	56	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
814320	57	for voice-interval1 in (cond ((atom (car voice-interval1)) (loop repeat (1- number-of-harmonies) collect voice-interval1))
LL	58	((< (length voice-interval1) (1- number-of-harmonies))
	59	(append voice-interval1 (loop repeat (- (1- number-of-harmonies) (length voice-interval1)) collect (car (reverse voice-interval1)))))
71cec5	60	(t voice-interval1))
814320	61	for voice-interval2 in (cond ((atom (car voice-interval2)) (loop repeat (1- number-of-harmonies) collect voice-interval2))
LL	62	((< (length voice-interval2) (1- number-of-harmonies))
	63	(append voice-interval2 (loop repeat (- (1- number-of-harmonies) (length voice-interval2)) collect (car (reverse voice-interval2)))))
71cec5	64	(t voice-interval2))
814320	65	for voice-interval3 in (cond ((atom (car voice-interval3)) (loop repeat (1- number-of-harmonies) collect voice-interval3))
LL	66	((< (length voice-interval3) (1- number-of-harmonies))
	67	(append voice-interval3 (loop repeat (- (1- number-of-harmonies) (length voice-interval3)) collect (car (reverse voice-interval3)))))
71cec5	68	(t voice-interval3))
814320	69	for voice-interval4 in (cond ((atom (car voice-interval4)) (loop repeat (1- number-of-harmonies) collect voice-interval4))
LL	70	((< (length voice-interval4) (1- number-of-harmonies))
	71	(append voice-interval4 (loop repeat (- (1- number-of-harmonies) (length voice-interval4)) collect (car (reverse voice-interval4)))))
71cec5	72	(t voice-interval4))
MS	73
	74	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
814320	75	for voice-counter1 in (cond ((atom voice-counter1)
LL	76	(loop repeat (1- number-of-harmonies) collect voice-counter1))
	77	((listp (caar voice-counter1))
	78	(if (< (length voice-counter1) (1- number-of-harmonies))
	79	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter1))
	80	voice-counter1))
	81	(t (loop repeat (1- number-of-harmonies) collect voice-counter1)))
	82
	83
	84	for voice-counter2 in (cond ((atom voice-counter2)
	85	(loop repeat (1- number-of-harmonies) collect voice-counter2))
	86	((listp (caar voice-counter2))
	87	(if (< (length voice-counter2) (1- number-of-harmonies))
	88	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter2))
	89	voice-counter2))
	90	(t (loop repeat (1- number-of-harmonies) collect voice-counter2)))
	91
	92
	93	for voice-counter3 in (cond ((atom voice-counter3)
	94	(loop repeat (1- number-of-harmonies) collect voice-counter3))
	95	((listp (caar voice-counter3))
	96	(if (< (length voice-counter3) (1- number-of-harmonies))
	97	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter3))
	98	voice-counter3))
	99	(t (loop repeat (1- number-of-harmonies) collect voice-counter3)))
	100
	101
	102	for voice-counter4 in (cond ((atom voice-counter4)
	103	(loop repeat (1- number-of-harmonies) collect voice-counter4))
	104	((listp (caar voice-counter4))
	105	(if (< (length voice-counter4) (1- number-of-harmonies))
	106	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter4))
	107	voice-counter4))
	108	(t (loop repeat (1- number-of-harmonies) collect voice-counter4)))
	109
	110
	111	for voice-counter5 in (cond ((atom voice-counter5)
	112	(loop repeat (1- number-of-harmonies) collect voice-counter5))
	113	((listp (caar voice-counter5))
	114	(if (< (length voice-counter5) (1- number-of-harmonies))
	115	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter5))
	116	voice-counter5))
	117	(t (loop repeat (1- number-of-harmonies) collect voice-counter5)))
	118
	119
	120	for voice-counter6 in (cond ((atom voice-counter6)
	121	(loop repeat (1- number-of-harmonies) collect voice-counter6))
	122	((listp (caar voice-counter6))
	123	(if (< (length voice-counter6) (1- number-of-harmonies))
	124	(loop repeat (- (1- number-of-harmonies) (length voice)) collect (car voice-counter6))
	125	voice-counter6))
	126	(t (loop repeat (1- number-of-harmonies) collect voice-counter6)))
71cec5	127
MS	128	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
814320	129	for counter-interval1 in (cond ((atom (car counter-interval1)) (loop repeat (1- number-of-harmonies) collect counter-interval1))
LL	130	((< (length counter-interval1) (1- number-of-harmonies))
	131	(append counter-interval1 (loop repeat (- (1- number-of-harmonies) (length counter-interval1)) collect (car (reverse counter-interval1)))))
71cec5	132	(t counter-interval1))
814320	133	for counter-interval2 in (cond ((atom (car counter-interval2)) (loop repeat (1- number-of-harmonies) collect counter-interval2))
LL	134	((< (length counter-interval2) (1- number-of-harmonies))
	135	(append counter-interval2 (loop repeat (- (1- number-of-harmonies) (length counter-interval2)) collect (car (reverse counter-interval2)))))
71cec5	136	(t counter-interval2))
814320	137	for counter-interval3 in (cond ((atom (car counter-interval3)) (loop repeat (1- number-of-harmonies) collect counter-interval3))
LL	138	((< (length counter-interval3) (1- number-of-harmonies))
	139	(append counter-interval3 (loop repeat (- (1- number-of-harmonies) (length counter-interval3)) collect (car (reverse counter-interval3)))))
71cec5	140	(t counter-interval3))
814320	141	for counter-interval4 in (cond ((atom (car counter-interval4)) (loop repeat (1- number-of-harmonies) collect counter-interval4))
LL	142	((< (length counter-interval4) (1- number-of-harmonies))
	143	(append counter-interval4 (loop repeat (- (1- number-of-harmonies) (length counter-interval4)) collect (car (reverse counter-interval4)))))
71cec5	144	(t counter-interval4))
814320	145	for counter-interval5 in (cond ((atom (car counter-interval5)) (loop repeat (1- number-of-harmonies) collect counter-interval5))
LL	146	((< (length counter-interval5) (1- number-of-harmonies))
	147	(append counter-interval5 (loop repeat (- (1- number-of-harmonies) (length counter-interval5)) collect (car (reverse counter-interval5)))))
71cec5	148	(t counter-interval5))
814320	149	for counter-interval6 in (cond ((atom (car counter-interval6)) (loop repeat (1- number-of-harmonies) collect counter-interval6))
LL	150	((< (length counter-interval6) (1- number-of-harmonies))
	151	(append counter-interval6 (loop repeat (- (1- number-of-harmonies) (length counter-interval6)) collect (car (reverse counter-interval6)))))
71cec5	152	(t counter-interval6))
MS	153
	154
	155
	156
	157
	158	collect
f3e3b2	159	(let* ((second (append (list first-harmony) (reverse external-list)))
71cec5	160	(first (car (last second)));6000 6700
MS	161	(second (let* ((temp-base database)
	162
	163	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	164
4e5eed	165	(temp-base (cond (avoid-repetitions (let ((looplist
71cec5	166	(remove nil (loop for a in temp-base
MS	167	collect (if
	168	(car
	169	(remove nil
	170	(mapcar #'(lambda (l) (eq (car l) (cadr l)))
4e5eed	171	(mat-trans_oml (list first a))))) nil a)))))
71cec5	172
4e5eed	173	(if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)))
71cec5	174	(t temp-base)))
MS	175
	176
	177	(temp-base (cond (voice-tie1
4e5eed	178	(let* ((voice-tie1 (- voice-tie1 1))
LL	179	(looplist (remove nil
71cec5	180	(loop for a in temp-base
MS	181	collect
4e5eed	182
71cec5	183	(cond ((eq (nth voice-tie1 a) (nth voice-tie1 first)) a)
4e5eed	184	((eq (nth voice-tie1 first) -1) a)
LL	185	(t nil))))))
71cec5	186	(if (null looplist)
MS	187	(loop for a in temp-base
	188	collect
	189	(subs-posn_oml a voice-tie1 -1))
	190	looplist)))
	191	(t temp-base)))
	192
	193	(temp-base (cond (voice-tie2
4e5eed	194	(let* ((voice-tie2 (- voice-tie2 1))
LL	195	(looplist (remove nil
71cec5	196	(loop for a in temp-base
MS	197	collect
	198
	199	(cond ((eq (nth voice-tie2 a) (nth voice-tie2 first)) a)
4e5eed	200	((eq (nth voice-tie2 first) -1) a)
LL	201	(t nil))))))
71cec5	202	(if (null looplist)
MS	203	(loop for a in temp-base
	204	collect
	205	(subs-posn_oml a voice-tie2 -1))
	206	looplist)))
	207	(t temp-base)))
	208
	209	(temp-base (cond (voice-tie3
4e5eed	210	(let* ((voice-tie3 (- voice-tie3 1))
LL	211	(looplist (remove nil
71cec5	212	(loop for a in temp-base
MS	213	collect
	214
	215	(cond ((eq (nth voice-tie3 a) (nth voice-tie3 first)) a)
4e5eed	216	((eq (nth voice-tie3 first) -1) a)
LL	217	(t nil))))))
71cec5	218	(if (null looplist)
MS	219	(loop for a in temp-base
	220	collect
	221	(subs-posn_oml a voice-tie3 -1))
	222	looplist)))
	223	(t temp-base)))
	224
	225	(temp-base (cond (voice-tie4
4e5eed	226	(let* ((voice-tie4 (- voice-tie4 1))
LL	227	(looplist (remove nil
71cec5	228	(loop for a in temp-base
MS	229	collect
	230
	231	(cond ((eq (nth voice-tie4 a) (nth voice-tie4 first)) a)
4e5eed	232	((eq (nth voice-tie4 first) -1) a)
LL	233	(t nil))))))
71cec5	234	(if (null looplist)
MS	235	(loop for a in temp-base
	236	collect
	237	(subs-posn_oml a voice-tie4 -1))
	238	looplist)))
	239	(t temp-base)))
	240
	241	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	242	(temp-base (cond (voice-interval1
4e5eed	243	(let ((looplist (remove nil (loop for a in temp-base
71cec5	244	collect
MS	245	(if (or (find (- (nth 0 a) (nth 0 first)) voice-interval1)
4e5eed	246	(eq (nth 0 first) -1)) a)))))
71cec5	247	(if (null looplist)
MS	248	(loop for a in temp-base
	249	collect
4e5eed	250	(subs-posn_oml a 0 -1)) looplist)))
71cec5	251	(t temp-base)))
MS	252
	253	(temp-base (cond (voice-interval2
4e5eed	254	(let ((looplist (remove nil (loop for a in temp-base
71cec5	255	collect
MS	256	(if (or (find (- (nth 1 a) (nth 1 first)) voice-interval2)
4e5eed	257	(eq (nth 1 first) -1)) a)))))
71cec5	258	(if (null looplist)
MS	259	(loop for a in temp-base
	260	collect
4e5eed	261	(subs-posn_oml a 1 -1)) looplist)))
71cec5	262	(t temp-base)))
MS	263
	264	(temp-base (cond (voice-interval3
4e5eed	265	(let ((looplist (remove nil (loop for a in temp-base
71cec5	266	collect
MS	267	(if (or (find (- (nth 2 a) (nth 2 first)) voice-interval3)
4e5eed	268	(eq (nth 2 first) -1)) a)))))
71cec5	269	(if (null looplist)
MS	270	(loop for a in temp-base
	271	collect
4e5eed	272	(subs-posn_oml a 2 -1)) looplist)))
71cec5	273	(t temp-base)))
MS	274
	275	(temp-base (cond (voice-interval4
4e5eed	276	(let ((looplist (remove nil (loop for a in temp-base
71cec5	277	collect
MS	278	(if (or (find (- (nth 3 a) (nth 3 first)) voice-interval4)
4e5eed	279	(eq (nth 3 first) -1)) a)))))
71cec5	280	(if (null looplist)
MS	281	(loop for a in temp-base
	282	collect
4e5eed	283	(subs-posn_oml a 3 -1)) looplist)))
71cec5	284	(t temp-base)))
MS	285
	286
	287	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	288	(temp-base (cond (voice-counter1
	289
4e5eed	290	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter1))) first))
LL	291	(eq -1 (nth (1- (second (car voice-counter1))) first))) counter-interval1)
71cec5	292
4e5eed	293	(remove nil (loop for a in temp-base
LL	294	collect (let* ((instr-a (1- (first (car voice-counter1)))) ;0
	295	(instr-b (1- (second (car voice-counter1))))
	296	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	297	(if (find voice-i counter-interval1) a)))))
71cec5	298
4e5eed	299	((or (eq -1 (nth (1- (first (car voice-counter1))) first))
LL	300	(eq -1 (nth (1- (second (car voice-counter1))) first))) temp-base)
	301
	302	(t (let ((looplist (remove nil
	303	(loop for a in temp-base
	304	collect
	305	(let* ((instr-a (1- (first (car voice-counter1)))) ;0
	306	(instr-b (1- (second (car voice-counter1)))) ;1
	307	(delta-a (- (nth instr-a a) (nth instr-a first)))
	308	(delta-b (- (nth instr-b a) (nth instr-b first)))
	309	(rule (second voice-counter1)))
	310	(cond
	311
	312
	313
	314
	315	(counter-interval1
	316	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	317	(and (> 0 delta-a) (> 0 delta-b))
	318	(and (= 0 delta-a) (= 0 delta-b)))
	319	(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'parallel)
	320	((and (or (and (< 0 delta-a) (> 0 delta-b))
	321	(and (> 0 delta-a) (< 0 delta-b)))
	322	(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'contrary)
	323	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	324	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	325	(find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'seiten)))
	326	a))
	327
	328
	329	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	330	(and (> 0 delta-a) (> 0 delta-b))
	331	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	332	((or (and (< 0 delta-a) (> 0 delta-b))
	333	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	334	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	335	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	336	a))))))))
	337
	338
	339
	340	(if (null looplist)
	341	(loop for a in temp-base
	342	collect
	343	(subs-posn_oml a (1- (first (car voice-counter1))) -1)) looplist)))))
71cec5	344
MS	345
	346
	347	(t temp-base)))
	348
4e5eed	349	(temp-base (cond (voice-counter2
71cec5	350
4e5eed	351	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter2))) first))
LL	352	(eq -1 (nth (1- (second (car voice-counter2))) first))) counter-interval2)
	353
	354	(remove nil (loop for a in temp-base
	355	collect (let* ((instr-a (1- (first (car voice-counter2)))) ;0
	356	(instr-b (1- (second (car voice-counter2))))
	357	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	358	(if (find voice-i counter-interval2) a)))))
	359
	360	((or (eq -1 (nth (1- (first (car voice-counter2))) first))
	361	(eq -1 (nth (1- (second (car voice-counter2))) first))) temp-base)
	362
	363	(t (let ((looplist (remove nil
	364	(loop for a in temp-base
	365	collect
	366	(let* ((instr-a (1- (first (car voice-counter2)))) ;0
	367	(instr-b (1- (second (car voice-counter2)))) ;1
	368	(delta-a (- (nth instr-a a) (nth instr-a first)))
	369	(delta-b (- (nth instr-b a) (nth instr-b first)))
	370	(rule (second voice-counter2)))
	371	(cond
	372
	373
	374
	375
	376	(counter-interval2
	377	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	378	(and (> 0 delta-a) (> 0 delta-b))
	379	(and (= 0 delta-a) (= 0 delta-b)))
	380	(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'parallel)
	381	((and (or (and (< 0 delta-a) (> 0 delta-b))
	382	(and (> 0 delta-a) (< 0 delta-b)))
	383	(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'contrary)
	384	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	385	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	386	(find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'seiten)))
	387	a))
	388
	389
	390	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	391	(and (> 0 delta-a) (> 0 delta-b))
	392	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	393	((or (and (< 0 delta-a) (> 0 delta-b))
	394	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	395	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	396	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	397	a))))))))
	398
	399
	400
	401	(if (null looplist)
	402	(loop for a in temp-base
	403	collect
	404	(subs-posn_oml a (1- (first (car voice-counter2))) -1)) looplist)))))
71cec5	405
MS	406
4e5eed	407
LL	408	(t temp-base)))
	409
	410	(temp-base (cond (voice-counter3
71cec5	411
4e5eed	412	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter3))) first))
LL	413	(eq -1 (nth (1- (second (car voice-counter3))) first))) counter-interval3)
71cec5	414
4e5eed	415	(remove nil (loop for a in temp-base
LL	416	collect (let* ((instr-a (1- (first (car voice-counter3)))) ;0
	417	(instr-b (1- (second (car voice-counter3))))
	418	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	419	(if (find voice-i counter-interval3) a)))))
71cec5	420
4e5eed	421	((or (eq -1 (nth (1- (first (car voice-counter3))) first))
LL	422	(eq -1 (nth (1- (second (car voice-counter3))) first))) temp-base)
	423
	424	(t (let ((looplist (remove nil
	425	(loop for a in temp-base
	426	collect
	427	(let* ((instr-a (1- (first (car voice-counter3)))) ;0
	428	(instr-b (1- (second (car voice-counter3)))) ;1
	429	(delta-a (- (nth instr-a a) (nth instr-a first)))
	430	(delta-b (- (nth instr-b a) (nth instr-b first)))
	431	(rule (second voice-counter3)))
	432	(cond
	433
	434
	435
	436
	437	(counter-interval3
	438	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	439	(and (> 0 delta-a) (> 0 delta-b))
	440	(and (= 0 delta-a) (= 0 delta-b)))
	441	(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'parallel)
	442	((and (or (and (< 0 delta-a) (> 0 delta-b))
	443	(and (> 0 delta-a) (< 0 delta-b)))
	444	(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'contrary)
	445	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	446	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	447	(find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'seiten)))
	448	a))
	449
	450
	451	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	452	(and (> 0 delta-a) (> 0 delta-b))
	453	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	454	((or (and (< 0 delta-a) (> 0 delta-b))
	455	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	456	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	457	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	458	a))))))))
	459
	460
	461
	462	(if (null looplist)
	463	(loop for a in temp-base
	464	collect
	465	(subs-posn_oml a (1- (first (car voice-counter3))) -1)) looplist)))))
71cec5	466
MS	467
4e5eed	468
LL	469	(t temp-base)))
71cec5	470
MS	471
4e5eed	472	(temp-base (cond (voice-counter4
71cec5	473
4e5eed	474	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter4))) first))
LL	475	(eq -1 (nth (1- (second (car voice-counter4))) first))) counter-interval4)
	476
	477	(remove nil (loop for a in temp-base
	478	collect (let* ((instr-a (1- (first (car voice-counter4)))) ;0
	479	(instr-b (1- (second (car voice-counter4))))
	480	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	481	(if (find voice-i counter-interval4) a)))))
	482
	483	((or (eq -1 (nth (1- (first (car voice-counter4))) first))
	484	(eq -1 (nth (1- (second (car voice-counter4))) first))) temp-base)
	485
	486	(t (let ((looplist (remove nil
	487	(loop for a in temp-base
	488	collect
	489	(let* ((instr-a (1- (first (car voice-counter4)))) ;0
	490	(instr-b (1- (second (car voice-counter4)))) ;1
	491	(delta-a (- (nth instr-a a) (nth instr-a first)))
	492	(delta-b (- (nth instr-b a) (nth instr-b first)))
	493	(rule (second voice-counter4)))
	494	(cond
	495
	496
	497
	498
	499	(counter-interval4
	500	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	501	(and (> 0 delta-a) (> 0 delta-b))
	502	(and (= 0 delta-a) (= 0 delta-b)))
	503	(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'parallel)
	504	((and (or (and (< 0 delta-a) (> 0 delta-b))
	505	(and (> 0 delta-a) (< 0 delta-b)))
	506	(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'contrary)
	507	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	508	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	509	(find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'seiten)))
	510	a))
	511
	512
	513	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	514	(and (> 0 delta-a) (> 0 delta-b))
	515	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	516	((or (and (< 0 delta-a) (> 0 delta-b))
	517	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	518	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	519	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	520	a))))))))
	521
	522
	523
	524	(if (null looplist)
	525	(loop for a in temp-base
	526	collect
	527	(subs-posn_oml a (1- (first (car voice-counter4))) -1)) looplist)))))
71cec5	528
MS	529
4e5eed	530
LL	531	(t temp-base)))
71cec5	532
MS	533
4e5eed	534	(temp-base (cond (voice-counter5
71cec5	535
4e5eed	536	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter5))) first))
LL	537	(eq -1 (nth (1- (second (car voice-counter5))) first))) counter-interval5)
	538
	539	(remove nil (loop for a in temp-base
	540	collect (let* ((instr-a (1- (first (car voice-counter5)))) ;0
	541	(instr-b (1- (second (car voice-counter5))))
	542	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	543	(if (find voice-i counter-interval5) a)))))
	544
	545	((or (eq -1 (nth (1- (first (car voice-counter5))) first))
	546	(eq -1 (nth (1- (second (car voice-counter5))) first))) temp-base)
	547
	548	(t (let ((looplist (remove nil
	549	(loop for a in temp-base
	550	collect
	551	(let* ((instr-a (1- (first (car voice-counter5)))) ;0
	552	(instr-b (1- (second (car voice-counter5)))) ;1
	553	(delta-a (- (nth instr-a a) (nth instr-a first)))
	554	(delta-b (- (nth instr-b a) (nth instr-b first)))
	555	(rule (second voice-counter5)))
	556	(cond
	557
	558
	559
	560
	561	(counter-interval5
	562	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	563	(and (> 0 delta-a) (> 0 delta-b))
	564	(and (= 0 delta-a) (= 0 delta-b)))
	565	(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'parallel)
	566	((and (or (and (< 0 delta-a) (> 0 delta-b))
	567	(and (> 0 delta-a) (< 0 delta-b)))
	568	(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'contrary)
	569	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	570	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	571	(find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'seiten)))
	572	a))
	573
	574
	575	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	576	(and (> 0 delta-a) (> 0 delta-b))
	577	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	578	((or (and (< 0 delta-a) (> 0 delta-b))
	579	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	580	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	581	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	582	a))))))))
	583
	584
	585
	586	(if (null looplist)
	587	(loop for a in temp-base
	588	collect
	589	(subs-posn_oml a (1- (first (car voice-counter5))) -1)) looplist)))))
71cec5	590
MS	591
4e5eed	592
LL	593	(t temp-base)))
	594
	595
	596	(temp-base (cond (voice-counter6
	597
	598	(cond ((and (or (eq -1 (nth (1- (first (car voice-counter6))) first))
	599	(eq -1 (nth (1- (second (car voice-counter6))) first))) counter-interval6)
	600
	601	(remove nil (loop for a in temp-base
	602	collect (let* ((instr-a (1- (first (car voice-counter6)))) ;0
	603	(instr-b (1- (second (car voice-counter6))))
	604	(voice-i (- (nth instr-b a) (nth instr-a a))) )
	605	(if (find voice-i counter-interval6) a)))))
	606
	607	((or (eq -1 (nth (1- (first (car voice-counter6))) first))
	608	(eq -1 (nth (1- (second (car voice-counter6))) first))) temp-base)
	609
	610	(t (let ((looplist (remove nil
	611	(loop for a in temp-base
	612	collect
	613	(let* ((instr-a (1- (first (car voice-counter6)))) ;0
	614	(instr-b (1- (second (car voice-counter6)))) ;1
	615	(delta-a (- (nth instr-a a) (nth instr-a first)))
	616	(delta-b (- (nth instr-b a) (nth instr-b first)))
	617	(rule (second voice-counter6)))
	618	(cond
	619
	620
	621
	622
	623	(counter-interval6
	624	(if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b))
	625	(and (> 0 delta-a) (> 0 delta-b))
	626	(and (= 0 delta-a) (= 0 delta-b)))
	627	(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'parallel)
	628	((and (or (and (< 0 delta-a) (> 0 delta-b))
	629	(and (> 0 delta-a) (< 0 delta-b)))
	630	(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'contrary)
	631	((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	632	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
	633	(find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'seiten)))
	634	a))
	635
	636
	637	(t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b))
	638	(and (> 0 delta-a) (> 0 delta-b))
	639	(and (= 0 delta-a) (= 0 delta-b))) 'parallel)
	640	((or (and (< 0 delta-a) (> 0 delta-b))
	641	(and (> 0 delta-a) (< 0 delta-b))) 'contrary)
	642	((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
	643	(and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
	644	a))))))))
	645
	646
	647
	648	(if (null looplist)
	649	(loop for a in temp-base
	650	collect
	651	(subs-posn_oml a (1- (first (car voice-counter6))) -1)) looplist)))))
	652
	653
	654
	655	(t temp-base)))
71cec5	656
MS	657
	658
	659
	660
	661	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	662
	663	)
	664
	665
	666
	667	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	668
	669	(nth (random (length temp-base)) temp-base)
	670	)))
	671
	672
	673
f3e3b2	674	(push second external-list)
71cec5	675	(values second))))))
MS	676
a53ccf	677	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
LL	678
	679	(defun mat-trans_oml (list)
	680	(loop for y in (let (count-list)
	681	(dotimes (i (length (car list)))
	682	(setq count-list (cons i count-list))) (nreverse count-list))
	683	collect (loop for x in list collect (nth y x))
	684
	685	))
	686
	687
	688	(defun posn-match_oml (list positions)
	689	(cond ((null positions) '())
	690	((atom positions) (nth positions list))
	691	(t (append (list (posn-match_oml list (car positions)))
	692	(if (posn-match_oml list (cdr positions))
	693	(posn-match_oml list (cdr positions))
	694	'())))))
	695
	696
	697	(defun subs-posn_oml (list position item)
	698	(loop for a from 0
	699	for b in list
	700	collect (if (= a position) item b)))
	701
	702
	703	(defun oml- (list atom)
	704	(mapcar (lambda (it) (- it atom)) list))
	705
	706
	707	(defun find-dups_oml (liste)
	708	(car
	709	(remove nil
	710	(mapcar #'(lambda (l c) (eq l c)) liste (cdr liste)))))
	711
	712	;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71cec5	713
MS	714	;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	715
	716
	717
	718
	719
	720
	721
	722
	723
	724