OpenMusic-Library zur regelbasierten Harmonie und Stimmführung.
view | history | commit | commitdiff
Lorenz Lehmann
12.02.24 e292a63e3e70d3757d7316df3403efd81da68b26
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
e292a6 165                           (temp-base (cond (avoid-repetitions 
LL 166                                             (let* ((tie-list (mapcar '1- (remove nil (list voice-tie1 voice-tie2 voice-tie3 voice-tie4))))
167                                                     (sub-list (cond
168                                                                (tie-list (flat_oml (mapcar #'(lambda (l) (subs-posn_oml (loop repeat (length first) collect -2) l -1)) tie-list)))
169                                                                (t '(-2 -2 -2 -2))))
170                                                     
171                                                     
172                                                     (looplist
173                                                      (remove nil (loop for a in temp-base
174                                                                        collect (let ((harmony
175                                                                                       (remove nil (loop for i in sub-list
176                                                                                                         for n1 in first
177                                                                                                         for n2 in a
178                                                                                                         collect (if (cond ((eq i -1) (eq n1 n2))
179                                                                                                                           (t (not (eq n1 n2))))
180                                                                                                                     
181                                                                                                                     n2))))) 
182                                                                                  
183                                                                                  (if (eq (length first) (length harmony)) harmony))))))
184                                               
185                                               (if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)))
186                                             (t temp-base)))  
71cec5 187
MS 188
189                          (temp-base (cond (voice-tie1 
4e5eed 190                                            (let* ((voice-tie1 (- voice-tie1 1))
LL 191                                                   (looplist (remove nil
71cec5 192                                            (loop for a in temp-base 
MS 193                                                  collect 
4e5eed 194
71cec5 195                                                  (cond ((eq (nth voice-tie1 a) (nth voice-tie1 first)) a)
4e5eed 196                                                        ((eq (nth voice-tie1 first) -1) a)
LL 197                                                        (t nil))))))
71cec5 198                                            (if (null looplist)
MS 199                                                (loop for a in temp-base
200                                                      collect
201                                                      (subs-posn_oml a voice-tie1 -1))
202                                              looplist)))
203                                           (t temp-base)))
204
205                          (temp-base (cond (voice-tie2 
4e5eed 206                                            (let* ((voice-tie2 (- voice-tie2 1))
LL 207                                                   (looplist (remove nil
71cec5 208                                            (loop for a in temp-base 
MS 209                                                  collect 
210                                                  
211                                                  (cond ((eq (nth voice-tie2 a) (nth voice-tie2 first)) a)
4e5eed 212                                                        ((eq (nth voice-tie2 first) -1) a)
LL 213                                                        (t nil))))))
71cec5 214                                            (if (null looplist)
MS 215                                                (loop for a in temp-base
216                                                      collect
217                                                      (subs-posn_oml a voice-tie2 -1))
218                                              looplist)))
219                                           (t temp-base)))
220
221                          (temp-base (cond (voice-tie3 
4e5eed 222                                            (let* ((voice-tie3 (- voice-tie3 1))
LL 223                                                   (looplist (remove nil
71cec5 224                                            (loop for a in temp-base 
MS 225                                                  collect 
226                                                  
227                                                  (cond ((eq (nth voice-tie3 a) (nth voice-tie3 first)) a)
4e5eed 228                                                        ((eq (nth voice-tie3 first) -1) a)
LL 229                                                        (t nil))))))
71cec5 230                                            (if (null looplist)
MS 231                                                (loop for a in temp-base
232                                                      collect
233                                                      (subs-posn_oml a voice-tie3 -1))
234                                              looplist)))
235                                           (t temp-base)))
236
237                          (temp-base (cond (voice-tie4 
4e5eed 238                                            (let* ((voice-tie4 (- voice-tie4 1))
LL 239                                                   (looplist (remove nil
71cec5 240                                            (loop for a in temp-base 
MS 241                                                  collect 
242                                                  
243                                                  (cond ((eq (nth voice-tie4 a) (nth voice-tie4 first)) a)
4e5eed 244                                                        ((eq (nth voice-tie4 first) -1) a)
LL 245                                                        (t nil))))))
71cec5 246                                            (if (null looplist)
MS 247                                                (loop for a in temp-base
248                                                      collect
249                                                      (subs-posn_oml a voice-tie4 -1))
250                                              looplist)))
251                                           (t temp-base)))
252
253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
254                          (temp-base (cond (voice-interval1 
4e5eed 255                                           (let ((looplist (remove nil (loop for a in temp-base
71cec5 256                                                                            collect
MS 257                                                                                  (if (or (find (- (nth 0 a) (nth 0 first)) voice-interval1)
4e5eed 258                                                                                            (eq (nth 0 first) -1)) a)))))
71cec5 259                                           (if (null looplist)
MS 260                                               (loop for a in temp-base
261                                                     collect
4e5eed 262                                                     (subs-posn_oml a 0 -1)) looplist)))
71cec5 263                                     (t temp-base)))
MS 264
265                          (temp-base (cond (voice-interval2 
4e5eed 266                                            (let ((looplist (remove nil (loop for a in temp-base
71cec5 267                                                                             collect
MS 268                                                                             (if (or (find (- (nth 1 a) (nth 1 first)) voice-interval2)
4e5eed 269                                                                                     (eq (nth 1 first) -1)) a)))))
71cec5 270                                            (if (null looplist)
MS 271                                                (loop for a in temp-base
272                                                      collect
4e5eed 273                                                      (subs-posn_oml a 1 -1)) looplist)))
71cec5 274                                           (t temp-base)))
MS 275                          
276                          (temp-base (cond (voice-interval3 
4e5eed 277                                            (let ((looplist (remove nil (loop for a in temp-base
71cec5 278                                                                             collect
MS 279                                                                             (if (or (find (- (nth 2 a) (nth 2 first)) voice-interval3)
4e5eed 280                                                                                     (eq (nth 2 first) -1)) a)))))
71cec5 281                                            (if (null looplist)
MS 282                                                (loop for a in temp-base
283                                                      collect
4e5eed 284                                                      (subs-posn_oml a 2 -1)) looplist)))
71cec5 285                                           (t temp-base)))
MS 286
287                          (temp-base (cond (voice-interval4 
4e5eed 288                                            (let ((looplist (remove nil (loop for a in temp-base
71cec5 289                                                                             collect
MS 290                                                                             (if (or (find (- (nth 3 a) (nth 3 first)) voice-interval4)
4e5eed 291                                                                                     (eq (nth 3 first) -1)) a)))))
71cec5 292                                            (if (null looplist)
MS 293                                                (loop for a in temp-base
294                                                      collect
4e5eed 295                                                      (subs-posn_oml a 3 -1)) looplist)))
71cec5 296                                           (t temp-base)))
MS 297
298
299 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                           
300                          (temp-base (cond (voice-counter1
301
4e5eed 302                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter1))) first))
LL 303                                                            (eq -1 (nth (1- (second (car voice-counter1))) first))) counter-interval1) 
71cec5 304
4e5eed 305                                                   (remove nil (loop for a in temp-base
LL 306                                                                     collect (let* ((instr-a (1- (first (car voice-counter1)))) ;0
307                                                                                    (instr-b (1- (second (car voice-counter1))))
308                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
309                                                                               (if (find voice-i counter-interval1) a)))))
71cec5 310
4e5eed 311                                                  ((or (eq -1 (nth (1- (first (car voice-counter1))) first))
LL 312                                                       (eq -1 (nth (1- (second (car voice-counter1))) first))) temp-base)
313                                                                               
314                                                  (t  (let ((looplist (remove nil
315                                                                             (loop for a in temp-base 
316                                                                                   collect
317                                                                                     (let* ((instr-a (1- (first (car voice-counter1)))) ;0
318                                                                                            (instr-b (1- (second (car voice-counter1)))) ;1
319                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
320                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
321                                                                                            (rule (second voice-counter1)))
322                                                                                       (cond 
323                                                                                        
324                                                                                        
325                                                                                        
326                                                                                        
327                                                                                        (counter-interval1 
328                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
329                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
330                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
331                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'parallel)
332                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
333                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
334                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'contrary)
335                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
336                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
337                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'seiten)))
338                                                                                             a))
339                                                                                        
340                                                                                        
341                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
342                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
343                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
344                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
345                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
346                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
347                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
348                                                                                               a))))))))
349                                                      
350                                                      
351                                                      
352                                                      (if (null looplist)
353                                                          (loop for a in temp-base 
354                                                                collect 
355                                                                  (subs-posn_oml a (1- (first (car voice-counter1))) -1)) looplist)))))
71cec5 356                                           
MS 357                                           
358                                           
359                                           (t temp-base)))
360                          
4e5eed 361 (temp-base (cond (voice-counter2
71cec5 362
4e5eed 363                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter2))) first))
LL 364                                                            (eq -1 (nth (1- (second (car voice-counter2))) first))) counter-interval2) 
365
366                                                   (remove nil (loop for a in temp-base
367                                                                     collect (let* ((instr-a (1- (first (car voice-counter2)))) ;0
368                                                                                    (instr-b (1- (second (car voice-counter2))))
369                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
370                                                                               (if (find voice-i counter-interval2) a)))))
371
372                                                  ((or (eq -1 (nth (1- (first (car voice-counter2))) first))
373                                                       (eq -1 (nth (1- (second (car voice-counter2))) first))) temp-base)
374                                                                               
375                                                  (t  (let ((looplist (remove nil
376                                                                             (loop for a in temp-base 
377                                                                                   collect
378                                                                                     (let* ((instr-a (1- (first (car voice-counter2)))) ;0
379                                                                                            (instr-b (1- (second (car voice-counter2)))) ;1
380                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
381                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
382                                                                                            (rule (second voice-counter2)))
383                                                                                       (cond 
384                                                                                        
385                                                                                        
386                                                                                        
387                                                                                        
388                                                                                        (counter-interval2 
389                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
390                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
391                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
392                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'parallel)
393                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
394                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
395                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'contrary)
396                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
397                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
398                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'seiten)))
399                                                                                             a))
400                                                                                        
401                                                                                        
402                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
403                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
404                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
405                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
406                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
407                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
408                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
409                                                                                               a))))))))
410                                                      
411                                                      
412                                                      
413                                                      (if (null looplist)
414                                                          (loop for a in temp-base 
415                                                                collect 
416                                                                  (subs-posn_oml a (1- (first (car voice-counter2))) -1)) looplist)))))
71cec5 417                                           
MS 418                                           
4e5eed 419                                           
LL 420                                           (t temp-base)))
421                          
422  (temp-base (cond (voice-counter3
71cec5 423
4e5eed 424                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter3))) first))
LL 425                                                            (eq -1 (nth (1- (second (car voice-counter3))) first))) counter-interval3) 
71cec5 426
4e5eed 427                                                   (remove nil (loop for a in temp-base
LL 428                                                                     collect (let* ((instr-a (1- (first (car voice-counter3)))) ;0
429                                                                                    (instr-b (1- (second (car voice-counter3))))
430                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
431                                                                               (if (find voice-i counter-interval3) a)))))
71cec5 432
4e5eed 433                                                  ((or (eq -1 (nth (1- (first (car voice-counter3))) first))
LL 434                                                       (eq -1 (nth (1- (second (car voice-counter3))) first))) temp-base)
435                                                                               
436                                                  (t  (let ((looplist (remove nil
437                                                                             (loop for a in temp-base 
438                                                                                   collect
439                                                                                     (let* ((instr-a (1- (first (car voice-counter3)))) ;0
440                                                                                            (instr-b (1- (second (car voice-counter3)))) ;1
441                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
442                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
443                                                                                            (rule (second voice-counter3)))
444                                                                                       (cond 
445                                                                                        
446                                                                                        
447                                                                                        
448                                                                                        
449                                                                                        (counter-interval3 
450                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
451                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
452                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
453                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'parallel)
454                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
455                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
456                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'contrary)
457                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
458                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
459                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'seiten)))
460                                                                                             a))
461                                                                                        
462                                                                                        
463                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
464                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
465                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
466                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
467                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
468                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
469                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
470                                                                                               a))))))))
471                                                      
472                                                      
473                                                      
474                                                      (if (null looplist)
475                                                          (loop for a in temp-base 
476                                                                collect 
477                                                                  (subs-posn_oml a (1- (first (car voice-counter3))) -1)) looplist)))))
71cec5 478                                           
MS 479                                           
4e5eed 480                                           
LL 481                                           (t temp-base)))
71cec5 482
MS 483
4e5eed 484  (temp-base (cond (voice-counter4
71cec5 485
4e5eed 486                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter4))) first))
LL 487                                                            (eq -1 (nth (1- (second (car voice-counter4))) first))) counter-interval4) 
488
489                                                   (remove nil (loop for a in temp-base
490                                                                     collect (let* ((instr-a (1- (first (car voice-counter4)))) ;0
491                                                                                    (instr-b (1- (second (car voice-counter4))))
492                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
493                                                                               (if (find voice-i counter-interval4) a)))))
494
495                                                  ((or (eq -1 (nth (1- (first (car voice-counter4))) first))
496                                                       (eq -1 (nth (1- (second (car voice-counter4))) first))) temp-base)
497                                                                               
498                                                  (t  (let ((looplist (remove nil
499                                                                             (loop for a in temp-base 
500                                                                                   collect
501                                                                                     (let* ((instr-a (1- (first (car voice-counter4)))) ;0
502                                                                                            (instr-b (1- (second (car voice-counter4)))) ;1
503                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
504                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
505                                                                                            (rule (second voice-counter4)))
506                                                                                       (cond 
507                                                                                        
508                                                                                        
509                                                                                        
510                                                                                        
511                                                                                        (counter-interval4 
512                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
513                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
514                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
515                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'parallel)
516                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
517                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
518                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'contrary)
519                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
520                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
521                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'seiten)))
522                                                                                             a))
523                                                                                        
524                                                                                        
525                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
526                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
527                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
528                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
529                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
530                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
531                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
532                                                                                               a))))))))
533                                                      
534                                                      
535                                                      
536                                                      (if (null looplist)
537                                                          (loop for a in temp-base 
538                                                                collect 
539                                                                  (subs-posn_oml a (1- (first (car voice-counter4))) -1)) looplist)))))
71cec5 540                                           
MS 541                                           
4e5eed 542                                           
LL 543                                           (t temp-base)))
71cec5 544
MS 545
4e5eed 546  (temp-base (cond (voice-counter5
71cec5 547
4e5eed 548                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter5))) first))
LL 549                                                            (eq -1 (nth (1- (second (car voice-counter5))) first))) counter-interval5) 
550
551                                                   (remove nil (loop for a in temp-base
552                                                                     collect (let* ((instr-a (1- (first (car voice-counter5)))) ;0
553                                                                                    (instr-b (1- (second (car voice-counter5))))
554                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
555                                                                               (if (find voice-i counter-interval5) a)))))
556
557                                                  ((or (eq -1 (nth (1- (first (car voice-counter5))) first))
558                                                       (eq -1 (nth (1- (second (car voice-counter5))) first))) temp-base)
559                                                                               
560                                                  (t  (let ((looplist (remove nil
561                                                                             (loop for a in temp-base 
562                                                                                   collect
563                                                                                     (let* ((instr-a (1- (first (car voice-counter5)))) ;0
564                                                                                            (instr-b (1- (second (car voice-counter5)))) ;1
565                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
566                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
567                                                                                            (rule (second voice-counter5)))
568                                                                                       (cond 
569                                                                                        
570                                                                                        
571                                                                                        
572                                                                                        
573                                                                                        (counter-interval5 
574                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
575                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
576                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
577                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'parallel)
578                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
579                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
580                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'contrary)
581                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
582                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
583                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'seiten)))
584                                                                                             a))
585                                                                                        
586                                                                                        
587                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
588                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
589                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
590                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
591                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
592                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
593                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
594                                                                                               a))))))))
595                                                      
596                                                      
597                                                      
598                                                      (if (null looplist)
599                                                          (loop for a in temp-base 
600                                                                collect 
601                                                                  (subs-posn_oml a (1- (first (car voice-counter5))) -1)) looplist)))))
71cec5 602                                           
MS 603                                           
4e5eed 604                                           
LL 605                                           (t temp-base)))
606
607
608 (temp-base (cond (voice-counter6
609
610                                            (cond ((and (or (eq -1 (nth (1- (first (car voice-counter6))) first))
611                                                            (eq -1 (nth (1- (second (car voice-counter6))) first))) counter-interval6) 
612
613                                                   (remove nil (loop for a in temp-base
614                                                                     collect (let* ((instr-a (1- (first (car voice-counter6)))) ;0
615                                                                                    (instr-b (1- (second (car voice-counter6))))
616                                                                                    (voice-i (- (nth instr-b a) (nth instr-a a))) ) 
617                                                                               (if (find voice-i counter-interval6) a)))))
618
619                                                  ((or (eq -1 (nth (1- (first (car voice-counter6))) first))
620                                                       (eq -1 (nth (1- (second (car voice-counter6))) first))) temp-base)
621                                                                               
622                                                  (t  (let ((looplist (remove nil
623                                                                             (loop for a in temp-base 
624                                                                                   collect
625                                                                                     (let* ((instr-a (1- (first (car voice-counter6)))) ;0
626                                                                                            (instr-b (1- (second (car voice-counter6)))) ;1
627                                                                                            (delta-a (- (nth instr-a a) (nth instr-a first)))
628                                                                                            (delta-b (- (nth instr-b a) (nth instr-b first)))
629                                                                                            (rule (second voice-counter6)))
630                                                                                       (cond 
631                                                                                        
632                                                                                        
633                                                                                        
634                                                                                        
635                                                                                        (counter-interval6 
636                                                                                         (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) 
637                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
638                                                                                                                      (and (= 0 delta-a) (= 0 delta-b)))
639                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'parallel)
640                                                                                                            ((and (or (and (< 0 delta-a) (> 0 delta-b)) 
641                                                                                                                      (and (> 0 delta-a) (< 0 delta-b)))
642                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'contrary)
643                                                                                                            ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
644                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b))))
645                                                                                                                  (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'seiten)))
646                                                                                             a))
647                                                                                        
648                                                                                        
649                                                                                        (t (if (eq rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) 
650                                                                                                                      (and (> 0 delta-a) (> 0 delta-b)) 
651                                                                                                                      (and (= 0 delta-a) (= 0 delta-b))) 'parallel)
652                                                                                                                 ((or (and (< 0 delta-a) (> 0 delta-b)) 
653                                                                                                                      (and (> 0 delta-a) (< 0 delta-b))) 'contrary)
654                                                                                                                 ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b))
655                                                                                                                      (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten)))
656                                                                                               a))))))))
657                                                      
658                                                      
659                                                      
660                                                      (if (null looplist)
661                                                          (loop for a in temp-base 
662                                                                collect 
663                                                                  (subs-posn_oml a (1- (first (car voice-counter6))) -1)) looplist)))))
664                                           
665                                           
666                                           
667                                           (t temp-base)))
71cec5 668
MS 669
670                                             
671
672
673 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  
674
675 )
676
677
678
679 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;                                      
680
681 (nth (random (length temp-base)) temp-base)
682      )))
683                   
684                   
685                   
f3e3b2 686                   (push second external-list)
71cec5 687                   (values second))))))
MS 688                
a53ccf 689 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
LL 690
691 (defun mat-trans_oml (list)
692 (loop for y in (let (count-list)
693                  (dotimes (i (length (car list))) 
694                    (setq count-list (cons i count-list))) (nreverse count-list))
695 collect (loop for x in list collect (nth y x)) 
696
697 ))
698
699
700 (defun posn-match_oml (list positions)
701   (cond ((null positions) '())
702         ((atom positions) (nth positions list))
703         (t (append (list (posn-match_oml list (car positions)))
704                    (if (posn-match_oml list (cdr positions))
705                        (posn-match_oml list (cdr positions))
706                      '())))))
707
708
709 (defun subs-posn_oml (list position item)
710   (loop for a from 0 
711         for b in list 
712         collect (if (= a position) item b)))
713
714
715 (defun oml- (list atom)
716 (mapcar (lambda (it) (- it atom)) list))
717
718
719 (defun find-dups_oml (liste)
720 (car 
721 (remove nil
722 (mapcar #'(lambda (l c) (eq l c)) liste  (cdr liste)))))
723
724 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71cec5 725
MS 726 ;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
727
728
729
730
731
732
733
734
735
736