| 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 | |
| d593dc | 14 | (om::defmethod! gen-sequence (harmonies first-harmony number-of-harmonies error-out single-voice-progress voice-pair-progress) |
| 71cec5 | 15 | |
| d593dc | 16 | :icon 030719979 |
| 71cec5 | 17 | |
| MS | 18 | :numouts 1 |
| 19 | ||
| 20 | ||
| 21 | ||
| d593dc | 22 | (let ((external-list (list first-harmony)) |
| LL | 23 | (harmonies (if (atom (caar harmonies)) (list (list harmonies) 'hold) harmonies)) |
| 24 | (error-out (if (or (find 'hold error-out) (find 'circular error-out)) error-out (list (list error-out) 'hold))) | |
| 25 | (single-voice-progress (cond ((null single-voice-progress) nil) | |
| 26 | ((atom (caar single-voice-progress)) (list single-voice-progress)) | |
| 27 | (t single-voice-progress))) | |
| 28 | (voice-pair-progress (cond ((null voice-pair-progress) nil) | |
| 29 | ((atom (caaar voice-pair-progress)) (list voice-pair-progress)) | |
| 30 | (t voice-pair-progress)))) | |
| 71cec5 | 31 | |
| MS | 32 | |
| d593dc | 33 | |
| LL | 34 | (loop for counter to (- number-of-harmonies 2) |
| 35 | do (let* ((first (car external-list)) | |
| 36 | (temp-harmonies (cond ((eq 'circular (car (last harmonies))) (circular-list (car harmonies) counter)) | |
| 37 | (t (hold-list (car harmonies) counter)))) | |
| 38 | (temp-error (cond ((eq 'circular (car (last error-out))) (circular-list (car error-out) counter)) | |
| 39 | (t (hold-list (car error-out) counter)))) | |
| 40 | (temp-harmonies (if single-voice-progress (remove nil (loop for voice-box in single-voice-progress | |
| 41 | append (loop for second in temp-harmonies | |
| 42 | collect (if (funcall (if (eq 'circular (third voice-box)) | |
| 43 | (circular-list (second voice-box) counter) | |
| 44 | (hold-list (second voice-box) counter)) | |
| 45 | (first voice-box) first second) second) )) ) temp-harmonies)) | |
| 46 | (temp-harmonies (if voice-pair-progress (remove nil (loop for pair-box in voice-pair-progress | |
| 47 | append (loop for second in temp-harmonies | |
| 48 | collect (if (funcall (if (eq 'circular (third pair-box)) | |
| 49 | (circular-list (second pair-box) counter) | |
| 50 | (hold-list (second pair-box) counter)) | |
| 51 | (first pair-box) first second) second) )) ) temp-harmonies ))) | |
| 52 | ||
| 53 | ||
| 54 | ||
| 55 | (if (null temp-harmonies) | |
| 56 | (push temp-error external-list) (push (nth-random temp-harmonies) external-list)))) | |
| 57 | ||
| 58 | (reverse external-list))) | |
| 59 | ||
| 60 | ||
| 61 | ||
| 62 | ||
| 63 | ||
| 64 | ||
| 65 | ||
| 66 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 67 | ||
| 68 | ||
| 69 | ||
| 70 | ;;;;;;;;;;;;;;;;;;;;;apply-boxes;;;;;;;;;;;;;;;;;;;;;;;; | |
| 71 | ||
| 72 | (om::defmethod! single-voice-progress (ids rules (mode symbol)) | |
| 73 | :icon 0307199710 | |
| 74 | :initvals '(nil nil 'circular) | |
| 75 | :menuins '((2 (("circular" 'circular) ("hold" 'hold)))) | |
| 76 | (list (list! ids) | |
| 77 | (list! rules) | |
| 78 | mode)) | |
| 79 | ||
| 80 | (om::defmethod! voice-pair-progress (ids rules (mode symbol)) | |
| 81 | :icon 0307199712 | |
| 82 | :initvals '(nil nil 'circular) | |
| 83 | :menuins '((2 (("circular" 'circular) ("hold" 'hold)))) | |
| 84 | (list (if (atom (car ids)) (list ids) ids) | |
| 85 | (list! rules) | |
| 86 | mode)) | |
| 87 | ||
| 88 | (om::defmethod! choose-error-out (error-value (mode symbol)) | |
| 89 | :icon 0307199715 | |
| 90 | :initvals '(nil 'hold) | |
| 91 | :menuins '((1 (("circular" 'circular) ("hold" 'hold)))) | |
| 92 | (list (if (atom (car error-value)) (list error-value) error-value) mode)) | |
| 93 | ||
| 94 | (om::defmethod! choose-harmonies (harmonies (mode symbol)) | |
| 95 | :icon 0307199715 | |
| 96 | :initvals '(nil 'hold) | |
| 97 | :menuins '((1 (("circular" 'circular) ("hold" 'hold)))) | |
| 98 | (list (if (atom (car harmonies)) (list harmonies) harmonies) mode)) | |
| 99 | ||
| 100 | ||
| 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 102 | ||
| 103 | ;;;;;;;;;;;;;;;;;;;;;;;;;svp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 104 | ||
| 105 | ||
| 106 | ||
| 107 | (om::defmethod! avoid-interval (voice first second) | |
| 108 | :icon 0307199711 | |
| 109 | (cond ((or (equal (nth voice first) choose-error-out) (equal (nth voice second) choose-error-out)) t) | |
| 110 | ((equal (nth voice first) (nth voice second)) nil) | |
| 111 | (t t))) | |
| 71cec5 | 112 | |
| MS | 113 | |
| 114 | ||
| 115 | ||
| 116 | ||
| 117 | ||
| d593dc | 118 | (om::defmethod! voice-interval (ids first second intervals (mode symbol)) |
| LL | 119 | :icon 0307199711 |
| 120 | :menuins '((4 (("only" 'only) ("except" 'except)))) | |
| 71cec5 | 121 | |
| d593dc | 122 | (if (eq mode 'only) (tester_oml |
| LL | 123 | (lambda (y) (find y intervals)) |
| 124 | (mapcar (lambda (x) (nth x (mapcar '- second first))) ids)) | |
| 125 | (tester_oml | |
| 126 | (lambda (y) (not (find y intervals))) | |
| 127 | (mapcar (lambda (x) (nth x (mapcar '- second first))) ids)))) | |
| 71cec5 | 128 | |
| MS | 129 | |
| 130 | ||
| 131 | ||
| 132 | ||
| 133 | ||
| 134 | ||
| 135 | ||
| d593dc | 136 | (defun find_oml (item liste &optional (start 0)) |
| 71cec5 | 137 | |
| d593dc | 138 | (cond ((null liste) start) |
| LL | 139 | ((eq (car liste) item) (find_oml item (cdr liste) (1+ start))) |
| 140 | (t (find_oml item (cdr liste) start)))) | |
| 141 | ||
| 142 | ||
| 143 | ||
| 144 | ||
| 145 | ||
| 146 | ||
| 147 | ||
| 148 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 149 | ||
| 150 | ;;;;;;;;;;;;;;;;;;;;;;;;;vpp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 151 | (om::defmethod! oblique-motion (ids first second) | |
| 152 | :icon 0307199713 | |
| 153 | (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids | |
| 154 | collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first))) | |
| 155 | voice-pair))) | |
| 156 | ||
| 157 | (and (condition_oml (lambda (x) (= x 0)) deltas) | |
| 158 | (condition_oml (lambda (x) (/= x 0)) deltas)))))) | |
| 159 | ||
| 160 | ||
| 161 | (om::defmethod! contrary-motion (ids first second) | |
| 162 | :icon 0307199713 | |
| 163 | (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids | |
| 164 | collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first))) | |
| 165 | voice-pair))) | |
| 166 | ||
| 167 | (eq (condition_oml (lambda (x) (> x 0)) deltas) | |
| 168 | (condition_oml (lambda (x) (< x 0)) deltas)))))) | |
| 169 | ||
| 170 | ||
| 171 | ||
| 172 | (om::defmethod! similar-motion (ids first second) | |
| 173 | :icon 0307199713 | |
| 174 | (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids | |
| 175 | collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first))) | |
| 176 | voice-pair))) | |
| 177 | ||
| 178 | (or (tester_oml (lambda (x) (> x 0)) deltas) | |
| 179 | (tester_oml (lambda (x) (< x 0)) deltas)))))) | |
| 180 | ||
| 181 | (om::defmethod! parallel-motion (ids first second) | |
| 182 | :icon 0307199713 | |
| 183 | (tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids | |
| 184 | collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first))) | |
| 185 | voice-pair))) | |
| 186 | (reduce '= deltas))))) | |
| 187 | ||
| 188 | ||
| 189 | ||
| 190 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 191 | ||
| 192 | ;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 193 | ||
| 194 | ||
| 195 | ||
| 196 | ||
| 197 | ||
| 198 | ;;;;;;;;;;;;;;;;;;Hilfsfunktionen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 199 | ||
| 200 | ||
| 201 | ||
| 202 | (defun condition_oml (test liste) | |
| 203 | (cond ((null liste) nil) | |
| 204 | ((funcall test (car liste)) t) | |
| 205 | (t (condition_oml test (cdr liste))) | |
| 206 | )) | |
| 207 | ||
| 208 | (defun list! (item) | |
| 209 | (cond ((atom item) (list item)) | |
| 210 | (t item))) | |
| 211 | ||
| 212 | ||
| 213 | (defun apply-rule_oml (harmonies rule first choose-error-out) | |
| 214 | (let ((database harmonies)) | |
| 215 | ||
| 216 | (loop for function in rule | |
| 217 | do (loop for harmony in database | |
| 218 | do (if (funcall (cadr function) (car function) first harmony choose-error-out) nil (setf database (delete harmony database))))) | |
| 219 | ||
| 220 | (if (null database) choose-error-out | |
| 221 | (nth (random (length database)) database)))) | |
| 222 | ||
| 223 | (defun hold_oml (items) | |
| 224 | (append (butlast items) (setf (cdr (last items)) (last items)))) | |
| 225 | ||
| a53ccf | 226 | |
| LL | 227 | (defun mat-trans_oml (list) |
| 228 | (loop for y in (let (count-list) | |
| 229 | (dotimes (i (length (car list))) | |
| 230 | (setq count-list (cons i count-list))) (nreverse count-list)) | |
| 231 | collect (loop for x in list collect (nth y x)) | |
| 232 | ||
| 233 | )) | |
| d593dc | 234 | |
| LL | 235 | |
| 236 | (defun my-recursive-fun (dur-list minimum divisor-list) | |
| 237 | ||
| 238 | (let ((divisor (om::nth-random (car divisor-list)))) | |
| 239 | (cond | |
| 240 | ((null dur-list) dur-list) | |
| 241 | ((>= (/ (car dur-list) divisor) minimum) | |
| 242 | ||
| 243 | (append (my-recursive-fun (om::repeat-n (/ (car dur-list) divisor) divisor) minimum (om::repeat-n (car divisor-list) divisor)) | |
| 244 | (my-recursive-fun (cdr dur-list) minimum (cdr divisor-list)))) | |
| 245 | (t (append (list (car dur-list)) (my-recursive-fun (cdr dur-list) minimum (cdr divisor-list))))))) | |
| 246 | ||
| a53ccf | 247 | |
| LL | 248 | |
| 249 | (defun posn-match_oml (list positions) | |
| 250 | (cond ((null positions) '()) | |
| 251 | ((atom positions) (nth positions list)) | |
| 252 | (t (append (list (posn-match_oml list (car positions))) | |
| 253 | (if (posn-match_oml list (cdr positions)) | |
| 254 | (posn-match_oml list (cdr positions)) | |
| 255 | '()))))) | |
| 256 | ||
| 257 | ||
| 258 | (defun subs-posn_oml (list position item) | |
| 259 | (loop for a from 0 | |
| 260 | for b in list | |
| 261 | collect (if (= a position) item b))) | |
| 262 | ||
| 263 | ||
| d593dc | 264 | (defun subs-posn (lis1 posn val) |
| LL | 265 | |
| 266 | (let ((copy (copy-list lis1))) | |
| 267 | (if (listp posn) | |
| 268 | (loop for item in posn | |
| 269 | for i = 0 then (+ i 1) do | |
| 270 | (setf (nth item copy) (if (listp val) (nth i val) val))) | |
| 271 | (setf (nth posn copy) val)) | |
| 272 | copy)) | |
| 273 | ||
| 274 | ||
| a53ccf | 275 | (defun oml- (list atom) |
| LL | 276 | (mapcar (lambda (it) (- it atom)) list)) |
| 277 | ||
| 278 | ||
| 279 | (defun find-dups_oml (liste) | |
| 280 | (car | |
| 281 | (remove nil | |
| 282 | (mapcar #'(lambda (l c) (eq l c)) liste (cdr liste))))) | |
| 283 | ||
| d593dc | 284 | (defun nth-random (list) |
| LL | 285 | (nth (random (length list)) list)) |
| 71cec5 | 286 | |
| MS | 287 | |
| 288 | ||
| d593dc | 289 | (defun circular-list (liste counter &key (start 0)) |
| LL | 290 | |
| 291 | (cond | |
| 292 | ((= counter 0) (nth start liste)) | |
| 293 | ((< start (1- (length liste))) (circular-list liste (1- counter) :start (1+ start))) | |
| 294 | (t (circular-list liste (1- counter) :start 0)))) | |
| 71cec5 | 295 | |
| MS | 296 | |
| 297 | ||
| d593dc | 298 | (defun hold-list (liste counter) |
| LL | 299 | (if (> counter (1- (length liste))) |
| 300 | (car (last liste)) | |
| 301 | (nth counter liste))) | |
| 302 | ||
| 71cec5 | 303 | |
| 985d3b | 304 | (defun find-area (value borders &key (start-index 0)) |
| LL | 305 | (cond ((null (second borders)) start-index) |
| 306 | ((and (>= value (first borders)) (< value (second borders))) start-index) | |
| 307 | (t (find-area value (cdr borders) :start-index (1+ start-index))))) | |
| 308 | ||
| 309 | (defun filter-rests (liste) | |
| 310 | (cond ((null liste) nil) | |
| 311 | (t (append (if (>= (car liste) 0) (list (car liste)) nil) | |
| 312 | (filter-rests (cdr liste)))))) | |
| 313 | ||
| 71cec5 | 314 | |
| MS | 315 | |
| 316 | ||
