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