SymProg/OM-Lead.git

Lorenz Lehmann

30.12.23 2b28dadf2717822f52e944d2b4b4542809281b55

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