| 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 | |
| 22fa58 | 159 | (let* ((second (nconc (list first-harmony) external-list)) |
| 71cec5 | 160 | (first (car (last second)));6000 6700 |
| MS | 161 | (second (let* ((temp-base database) |
| 162 | ||
| 163 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 164 | ||
| 165 | (temp-base (cond (avoid-repetitions (setq looplist | |
| 166 | (remove nil (loop for a in temp-base | |
| 167 | collect (if | |
| 168 | (car | |
| 169 | (remove nil | |
| 170 | (mapcar #'(lambda (l) (eq (car l) (cadr l))) | |
| 171 | (mat-trans_oml (list first a))))) nil a)))) | |
| 172 | ||
| 173 | (if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)) | |
| 174 | (t temp-base))) | |
| 175 | ||
| 176 | ||
| 177 | (temp-base (cond (voice-tie1 | |
| 178 | (let ((voice-tie1 (- voice-tie1 1))) | |
| 179 | (setq looplist (remove nil | |
| 180 | (loop for a in temp-base | |
| 181 | collect | |
| 182 | ||
| 183 | (cond ((eq (nth voice-tie1 a) (nth voice-tie1 first)) a) | |
| 184 | ((eq (nth voice-tie1 a) -1) a) | |
| 185 | (t nil))))) | |
| 186 | (if (null looplist) | |
| 187 | (loop for a in temp-base | |
| 188 | collect | |
| 189 | (subs-posn_oml a voice-tie1 -1)) | |
| 190 | looplist))) | |
| 191 | (t temp-base))) | |
| 192 | ||
| 193 | (temp-base (cond (voice-tie2 | |
| 194 | (let ((voice-tie2 (- voice-tie2 1))) | |
| 195 | (setq looplist (remove nil | |
| 196 | (loop for a in temp-base | |
| 197 | collect | |
| 198 | ||
| 199 | (cond ((eq (nth voice-tie2 a) (nth voice-tie2 first)) a) | |
| 200 | ((eq (nth voice-tie2 a) -1) a) | |
| 201 | (t nil))))) | |
| 202 | (if (null looplist) | |
| 203 | (loop for a in temp-base | |
| 204 | collect | |
| 205 | (subs-posn_oml a voice-tie2 -1)) | |
| 206 | looplist))) | |
| 207 | (t temp-base))) | |
| 208 | ||
| 209 | (temp-base (cond (voice-tie3 | |
| 210 | (let ((voice-tie3 (- voice-tie3 1))) | |
| 211 | (setq looplist (remove nil | |
| 212 | (loop for a in temp-base | |
| 213 | collect | |
| 214 | ||
| 215 | (cond ((eq (nth voice-tie3 a) (nth voice-tie3 first)) a) | |
| 216 | ((eq (nth voice-tie3 a) -1) a) | |
| 217 | (t nil))))) | |
| 218 | (if (null looplist) | |
| 219 | (loop for a in temp-base | |
| 220 | collect | |
| 221 | (subs-posn_oml a voice-tie3 -1)) | |
| 222 | looplist))) | |
| 223 | (t temp-base))) | |
| 224 | ||
| 225 | (temp-base (cond (voice-tie4 | |
| 226 | (let ((voice-tie4 (- voice-tie4 1))) | |
| 227 | (setq looplist (remove nil | |
| 228 | (loop for a in temp-base | |
| 229 | collect | |
| 230 | ||
| 231 | (cond ((eq (nth voice-tie4 a) (nth voice-tie4 first)) a) | |
| 232 | ((eq (nth voice-tie4 a) -1) a) | |
| 233 | (t nil))))) | |
| 234 | (if (null looplist) | |
| 235 | (loop for a in temp-base | |
| 236 | collect | |
| 237 | (subs-posn_oml a voice-tie4 -1)) | |
| 238 | looplist))) | |
| 239 | (t temp-base))) | |
| 240 | ||
| 241 | ||
| 242 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 243 | (temp-base (cond (voice-interval1 | |
| 244 | (setq looplist (remove nil (loop for a in temp-base | |
| 245 | collect | |
| 246 | (if (or (find (- (nth 0 a) (nth 0 first)) voice-interval1) | |
| 247 | (eq (nth 0 first) -1)) a)))) | |
| 248 | (if (null looplist) | |
| 249 | (loop for a in temp-base | |
| 250 | collect | |
| 251 | (subs-posn_oml a 0 -1)) looplist)) | |
| 252 | (t temp-base))) | |
| 253 | ||
| 254 | (temp-base (cond (voice-interval2 | |
| 255 | (setq looplist (remove nil (loop for a in temp-base | |
| 256 | collect | |
| 257 | (if (or (find (- (nth 1 a) (nth 1 first)) voice-interval2) | |
| 258 | (eq (nth 1 first) -1)) a)))) | |
| 259 | (if (null looplist) | |
| 260 | (loop for a in temp-base | |
| 261 | collect | |
| 262 | (subs-posn_oml a 1 -1)) looplist)) | |
| 263 | (t temp-base))) | |
| 264 | ||
| 265 | (temp-base (cond (voice-interval3 | |
| 266 | (setq looplist (remove nil (loop for a in temp-base | |
| 267 | collect | |
| 268 | (if (or (find (- (nth 2 a) (nth 2 first)) voice-interval3) | |
| 269 | (eq (nth 2 first) -1)) a)))) | |
| 270 | (if (null looplist) | |
| 271 | (loop for a in temp-base | |
| 272 | collect | |
| 273 | (subs-posn_oml a 2 -1)) looplist)) | |
| 274 | (t temp-base))) | |
| 275 | ||
| 276 | (temp-base (cond (voice-interval4 | |
| 277 | (setq looplist (remove nil (loop for a in temp-base | |
| 278 | collect | |
| 279 | (if (or (find (- (nth 3 a) (nth 3 first)) voice-interval4) | |
| 280 | (eq (nth 3 first) -1)) a)))) | |
| 281 | (if (null looplist) | |
| 282 | (loop for a in temp-base | |
| 283 | collect | |
| 284 | (subs-posn_oml a 3 -1)) looplist)) | |
| 285 | (t temp-base))) | |
| 286 | ||
| 287 | ||
| 288 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 289 | (temp-base (cond (voice-counter1 | |
| 290 | (setq looplist (remove nil | |
| 291 | (loop for a in temp-base | |
| 292 | collect | |
| 293 | (let* ((instr-a (1- (first (car voice-counter1)))) ;0 | |
| 294 | (instr-b (1- (second (car voice-counter1)))) ;1 | |
| 295 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 296 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 297 | (rule (second voice-counter1))) | |
| 298 | (cond (counter-interval1 | |
| 299 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 300 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 301 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 302 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'parallel) | |
| 303 | ((and (or (and (< 0 delta-a) (> 0 delta-b)) | |
| 304 | (and (> 0 delta-a) (< 0 delta-b))) | |
| 305 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'contrary) | |
| 306 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 307 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 308 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval1)) 'seiten))) | |
| 309 | a)) | |
| 310 | ||
| 311 | ||
| 312 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 313 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 314 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 315 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 316 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 317 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 318 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 319 | a))))))) | |
| 320 | ||
| 321 | ||
| 322 | ||
| 323 | (if (null looplist) | |
| 324 | (loop for a in temp-base | |
| 325 | collect | |
| 326 | (subs-posn_oml a (1- (first (car voice-counter1))) -1)) looplist)) | |
| 327 | ||
| 328 | ||
| 329 | ||
| 330 | (t temp-base))) | |
| 331 | ||
| 332 | (temp-base (cond (voice-counter2 | |
| 333 | (setq looplist (remove nil | |
| 334 | (loop for a in temp-base | |
| 335 | collect | |
| 336 | (let* ((instr-a (1- (first (car voice-counter2)))) ;0 | |
| 337 | (instr-b (1- (second (car voice-counter2)))) ;1 | |
| 338 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 339 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 340 | (rule (second voice-counter2))) | |
| 341 | (cond (counter-interval2 | |
| 342 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 343 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 344 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 345 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'parallel) | |
| 346 | ((and (or (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-interval2)) 'contrary) | |
| 349 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 350 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 351 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval2)) 'seiten))) | |
| 352 | a)) | |
| 353 | ||
| 354 | ||
| 355 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 356 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 357 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 358 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 359 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 360 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 361 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 362 | a))))))) | |
| 363 | ||
| 364 | ||
| 365 | ||
| 366 | (if (null looplist) | |
| 367 | (loop for a in temp-base | |
| 368 | collect | |
| 369 | (subs-posn_oml a (1- (first (car voice-counter2))) -1)) looplist)) | |
| 370 | ||
| 371 | ||
| 372 | ||
| 373 | (t temp-base))) | |
| 374 | ||
| 375 | (temp-base (cond (voice-counter3 | |
| 376 | (setq looplist (remove nil | |
| 377 | (loop for a in temp-base | |
| 378 | collect | |
| 379 | (let* ((instr-a (1- (first (car voice-counter3)))) ;0 | |
| 380 | (instr-b (1- (second (car voice-counter3)))) ;1 | |
| 381 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 382 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 383 | (rule (second voice-counter3))) | |
| 384 | (cond (counter-interval3 | |
| 385 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 386 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 387 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 388 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'parallel) | |
| 389 | ((and (or (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-interval3)) 'contrary) | |
| 392 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 393 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 394 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval3)) 'seiten))) | |
| 395 | a)) | |
| 396 | ||
| 397 | ||
| 398 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 399 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 400 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 401 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 402 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 403 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 404 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 405 | a))))))) | |
| 406 | ||
| 407 | ||
| 408 | ||
| 409 | (if (null looplist) | |
| 410 | (loop for a in temp-base | |
| 411 | collect | |
| 412 | (subs-posn_oml a (1- (first (car voice-counter3))) -1)) looplist)) | |
| 413 | ||
| 414 | ||
| 415 | ||
| 416 | (t temp-base))) | |
| 417 | ||
| 418 | ||
| 419 | (temp-base (cond (voice-counter4 | |
| 420 | (setq looplist (remove nil | |
| 421 | (loop for a in temp-base | |
| 422 | collect | |
| 423 | (let* ((instr-a (1- (first (car voice-counter4)))) ;0 | |
| 424 | (instr-b (1- (second (car voice-counter4)))) ;1 | |
| 425 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 426 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 427 | (rule (second voice-counter4))) | |
| 428 | (cond (counter-interval4 | |
| 429 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 430 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 431 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 432 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'parallel) | |
| 433 | ((and (or (and (< 0 delta-a) (> 0 delta-b)) | |
| 434 | (and (> 0 delta-a) (< 0 delta-b))) | |
| 435 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'contrary) | |
| 436 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 437 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 438 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval4)) 'seiten))) | |
| 439 | a)) | |
| 440 | ||
| 441 | ||
| 442 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 443 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 444 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 445 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 446 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 447 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 448 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 449 | a))))))) | |
| 450 | ||
| 451 | ||
| 452 | ||
| 453 | (if (null looplist) | |
| 454 | (loop for a in temp-base | |
| 455 | collect | |
| 456 | (subs-posn_oml a (1- (first (car voice-counter4))) -1)) looplist)) | |
| 457 | ||
| 458 | ||
| 459 | ||
| 460 | (t temp-base))) | |
| 461 | ||
| 462 | ||
| 463 | (temp-base (cond (voice-counter5 | |
| 464 | (setq looplist (remove nil | |
| 465 | (loop for a in temp-base | |
| 466 | collect | |
| 467 | (let* ((instr-a (1- (first (car voice-counter5)))) ;0 | |
| 468 | (instr-b (1- (second (car voice-counter5)))) ;1 | |
| 469 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 470 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 471 | (rule (second voice-counter5))) | |
| 472 | (cond (counter-interval5 | |
| 473 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 474 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 475 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 476 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'parallel) | |
| 477 | ((and (or (and (< 0 delta-a) (> 0 delta-b)) | |
| 478 | (and (> 0 delta-a) (< 0 delta-b))) | |
| 479 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'contrary) | |
| 480 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 481 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 482 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval5)) 'seiten))) | |
| 483 | a)) | |
| 484 | ||
| 485 | ||
| 486 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 487 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 488 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 489 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 490 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 491 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 492 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 493 | a))))))) | |
| 494 | ||
| 495 | ||
| 496 | ||
| 497 | (if (null looplist) | |
| 498 | (loop for a in temp-base | |
| 499 | collect | |
| 500 | (subs-posn_oml a (1- (first (car voice-counter5))) -1)) looplist)) | |
| 501 | ||
| 502 | ||
| 503 | ||
| 504 | (t temp-base))) | |
| 505 | ||
| 506 | ||
| 507 | (temp-base (cond (voice-counter6 | |
| 508 | (setq looplist (remove nil | |
| 509 | (loop for a in temp-base | |
| 510 | collect | |
| 511 | (let* ((instr-a (1- (first (car voice-counter6)))) ;0 | |
| 512 | (instr-b (1- (second (car voice-counter6)))) ;1 | |
| 513 | (delta-a (- (nth instr-a a) (nth instr-a first))) | |
| 514 | (delta-b (- (nth instr-b a) (nth instr-b first))) | |
| 515 | (rule (second voice-counter6))) | |
| 516 | (cond (counter-interval6 | |
| 517 | (if (eq rule (cond ((and (or (and (< 0 delta-a) (< 0 delta-b)) | |
| 518 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 519 | (and (= 0 delta-a) (= 0 delta-b))) | |
| 520 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'parallel) | |
| 521 | ((and (or (and (< 0 delta-a) (> 0 delta-b)) | |
| 522 | (and (> 0 delta-a) (< 0 delta-b))) | |
| 523 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'contrary) | |
| 524 | ((and (or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 525 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) | |
| 526 | (find (- (nth instr-b a) (nth instr-a a)) counter-interval6)) 'seiten))) | |
| 527 | a)) | |
| 528 | ||
| 529 | ||
| 530 | (t (if (equal rule (cond ((or (and (< 0 delta-a) (< 0 delta-b)) | |
| 531 | (and (> 0 delta-a) (> 0 delta-b)) | |
| 532 | (and (= 0 delta-a) (= 0 delta-b))) 'parallel) | |
| 533 | ((or (and (< 0 delta-a) (> 0 delta-b)) | |
| 534 | (and (> 0 delta-a) (< 0 delta-b))) 'contrary) | |
| 535 | ((or (and (or (< 0 delta-a) (> 0 delta-a)) (= 0 delta-b)) | |
| 536 | (and (= 0 delta-a) (or (< 0 delta-b) (> 0 delta-b)))) 'seiten))) | |
| 537 | a))))))) | |
| 538 | ||
| 539 | ||
| 540 | ||
| 541 | (if (null looplist) | |
| 542 | (loop for a in temp-base | |
| 543 | collect | |
| 544 | (subs-posn_oml a (1- (first (car voice-counter6))) -1)) looplist)) | |
| 545 | ||
| 546 | ||
| 547 | ||
| 548 | (t temp-base))) | |
| 549 | ||
| 550 | ||
| 551 | ||
| 552 | ||
| 553 | ||
| 554 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 555 | ||
| 556 | ) | |
| 557 | ||
| 558 | ||
| 559 | ||
| 560 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 561 | ||
| 562 | (nth (random (length temp-base)) temp-base) | |
| 563 | ))) | |
| 564 | ||
| 565 | ||
| 566 | ||
| 567 | (nreverse (push second external-list)) | |
| 568 | (values second)))))) | |
| 569 | ||
| a53ccf | 570 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| LL | 571 | |
| 572 | (defun mat-trans_oml (list) | |
| 573 | (loop for y in (let (count-list) | |
| 574 | (dotimes (i (length (car list))) | |
| 575 | (setq count-list (cons i count-list))) (nreverse count-list)) | |
| 576 | collect (loop for x in list collect (nth y x)) | |
| 577 | ||
| 578 | )) | |
| 579 | ||
| 580 | ||
| 581 | (defun posn-match_oml (list positions) | |
| 582 | (cond ((null positions) '()) | |
| 583 | ((atom positions) (nth positions list)) | |
| 584 | (t (append (list (posn-match_oml list (car positions))) | |
| 585 | (if (posn-match_oml list (cdr positions)) | |
| 586 | (posn-match_oml list (cdr positions)) | |
| 587 | '()))))) | |
| 588 | ||
| 589 | ||
| 590 | (defun subs-posn_oml (list position item) | |
| 591 | (loop for a from 0 | |
| 592 | for b in list | |
| 593 | collect (if (= a position) item b))) | |
| 594 | ||
| 595 | ||
| 596 | (defun oml- (list atom) | |
| 597 | (mapcar (lambda (it) (- it atom)) list)) | |
| 598 | ||
| 599 | ||
| 600 | (defun find-dups_oml (liste) | |
| 601 | (car | |
| 602 | (remove nil | |
| 603 | (mapcar #'(lambda (l c) (eq l c)) liste (cdr liste))))) | |
| 604 | ||
| 605 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 71cec5 | 606 | |
| MS | 607 | ;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 608 | ||
| 609 | ||
| 610 | ||
| 611 | ||
| 612 | ||
| 613 | ||
| 614 | ||
| 615 | ||
| 616 | ||
| 617 | ||
