| commit | author | age | ||
| c38e61 | 1 | |
| 71cec5 | 2 | ;====================================== |
| c38e61 | 3 | ;OM-Lead, 2022-2024 |
| 71cec5 | 4 | ; |
| MS | 5 | ;Library for Rule-based Voice-Leading |
| 6 | ;Author: Lorenz Lehmann | |
| 7 | ;Supervision: Marlon Schumacher | |
| 8 | ;====================================== | |
| 9 | ||
| c38e61 | 10 | |
| 71cec5 | 11 | (in-package :omlead) |
| MS | 12 | |
| 13 | ||
| 14 | ||
| c38e61 | 15 | ;;;;;;GEN-HARMONIES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 71cec5 | 16 | |
| c38e61 | 17 | (om::defmethod! gen-harmonies (pitch-sets trans-scale ranges expand-harmonies filter-harmonies) |
| LL | 18 | :icon 030719978 |
| 19 | ||
| 20 | ;++++++++++++++++++++++ transposition ++++++++++++++++++++++++++++++++++++++++++++++++ | |
| 21 | (let* ((scale | |
| 22 | ||
| 23 | (cond | |
| 24 | ||
| 25 | ((numberp (car trans-scale )) | |
| 26 | trans-scale) | |
| 27 | ||
| 28 | ||
| 29 | (t (let ((fundamental (second trans-scale)) | |
| 30 | (negativ (third trans-scale)) | |
| 31 | (positiv (fourth trans-scale)) | |
| 32 | (mode (fifth trans-scale)) | |
| 33 | (range-min (list-min_oml (flat_oml ranges))) | |
| 34 | (range-max (list-max_oml (flat_oml ranges)))) | |
| 35 | ||
| 36 | (append | |
| 37 | ||
| 38 | ||
| 39 | ;;;;;;;;;;;;;;;;;;negativ | |
| 40 | (reverse (loop for i in (if (or (eq 'hold mode) (eq 'hold-mirror mode)) | |
| 41 | (hold_oml negativ) (circular_oml negativ)) ;;endless down-list | |
| 42 | sum i into total | |
| 43 | until (> range-min (- fundamental total)) | |
| 44 | collect (- fundamental total) | |
| 45 | )) | |
| 46 | ||
| 47 | (list fundamental) | |
| 48 | ||
| 49 | ;;;;;;;;;;;;;;;;;;positiv | |
| 50 | ||
| 51 | (loop for i in (if (or (eq 'hold mode) (eq 'hold-mirror mode)) | |
| 52 | (hold_oml positiv) (circular_oml positiv)) ;;endless up-list | |
| 53 | sum i into total | |
| 54 | until (< range-max (+ fundamental total)) | |
| 55 | collect (+ fundamental total))))))) | |
| 71cec5 | 56 | |
| c38e61 | 57 | (harmonies (loop for pitch-set in pitch-sets |
| LL | 58 | append (loop for pitch in scale |
| 59 | collect (mapcar (lambda (x) (+ x pitch)) pitch-set)))) | |
| 71cec5 | 60 | |
| c38e61 | 61 | ;++++++++++++++++ adapt-collection-to-voice-ranges ++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 71cec5 | 62 | |
| MS | 63 | |
| c38e61 | 64 | (harmonies (remove nil (loop for harmony in (remove-duplicates harmonies :test #'equal) |
| LL | 65 | collect (if (find -1 (mapcar (lambda (pitch range) |
| 66 | (if (and (<= pitch (list-max_oml range)) (>= pitch (list-min_oml range))) pitch -1)) | |
| 67 | harmony ranges)) nil harmony)))) | |
| 2b28da | 68 | |
| c38e61 | 69 | |
| LL | 70 | ;++++++++++++++++ expand-harmonies ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 71 | ||
| 72 | (expand-harmonies (if (atom (caar expand-harmonies)) (list expand-harmonies) expand-harmonies)) | |
| 73 | ||
| 74 | (harmonies | |
| 75 | (if (car expand-harmonies) | |
| 76 | (let ((harmony-list (list harmonies))) | |
| 77 | ||
| 78 | ||
| 79 | (loop for expand-box in expand-harmonies | |
| 80 | do (loop for rule in (second expand-box) | |
| 81 | do (loop for harmony in (car harmony-list) | |
| 82 | if (tester_oml | |
| 83 | (lambda (x) (and (<= (list-min_oml (third expand-box)) x) (>= (list-max_oml (third expand-box)) x))) | |
| 84 | harmony) | |
| 85 | append | |
| 86 | ||
| 87 | (mapcar (lambda (y) | |
| 88 | (if (tester_oml (lambda (x) (and (<= (list-min_oml (flat_oml ranges)) x) (>= (list-max_oml (flat_oml ranges)) x))) y) | |
| 89 | y nil)) | |
| 90 | (funcall rule (first expand-box) harmony)) into temp-harmonies | |
| 91 | else append harmony into temp-harmonies | |
| 92 | finally (fill harmony-list (remove nil temp-harmonies))))) | |
| 93 | (car harmony-list)) | |
| 94 | harmonies)) | |
| 95 | ||
| 96 | ||
| 97 | ;++++++++++++++++ filter-harmonies ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
| 98 | ||
| 99 | (filter-harmonies (if (atom (caar filter-harmonies)) (list filter-harmonies) filter-harmonies)) | |
| 100 | ||
| 101 | (harmonies | |
| 102 | (if (car filter-harmonies) | |
| 103 | (let ((filter-list harmonies)) | |
| 104 | ||
| 105 | ||
| 106 | (loop for filter-box in filter-harmonies | |
| 107 | do (loop for rule in (second filter-box) | |
| 108 | ||
| 109 | do (loop for harmony in filter-list | |
| 110 | do (if (tester_oml | |
| 111 | (lambda (x) (and (<= (list-min_oml (third filter-box)) x) (>= (list-max_oml (third filter-box)) x))) | |
| 112 | harmony) | |
| 113 | (if (not (funcall rule (first filter-box) harmony)) | |
| 114 | (delete harmony filter-list)))))) | |
| 115 | filter-list) | |
| 116 | harmonies)) | |
| 117 | ||
| 118 | ;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ | |
| 119 | ||
| 120 | ) | |
| 121 | ||
| 122 | ||
| 123 | harmonies)) | |
| 124 | ||
| 125 | ||
| 126 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 2b28da | 127 | |
| LL | 128 | |
| 129 | ||
| 71cec5 | 130 | |
| MS | 131 | |
| 132 | ||
| c38e61 | 133 | ;%%%%%%%%%%%%%%%TRANS-SCALE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| LL | 134 | |
| 135 | ||
| 136 | (om::defmethod! trans-scale (fundamental scale (mode symbol)) | |
| 137 | :icon 0307199714 | |
| 138 | :initvals '(nil nil 'absolute) | |
| 139 | :menuins '((2 (("absolute" 'absolute) ("circular" 'circular) ("hold" 'hold) | |
| 140 | ("circular-mirror" 'circular-mirror) ("hold-mirror" 'hold-mirror)))) | |
| 141 | ||
| 142 | (cond | |
| 143 | ((null scale) | |
| 144 | (list fundamental)) | |
| 145 | ||
| 146 | ((eq 'absolute mode) | |
| 147 | (append (list fundamental) (loop for i in scale | |
| 148 | sum i into total | |
| 149 | collect (+ fundamental total)))) | |
| 150 | ||
| 151 | ((eq 'circular mode) | |
| 152 | (list nil fundamental (reverse scale) scale mode)) | |
| 153 | ||
| 154 | ((eq 'hold mode) | |
| 155 | (list nil fundamental (reverse scale) scale mode)) | |
| 156 | ||
| 157 | ((eq 'circular-mirror mode) | |
| 158 | (list nil fundamental (reverse (reverse scale)) scale mode)) | |
| 159 | ||
| 160 | ((eq 'hold-mirror mode) | |
| 161 | (list nil fundamental (reverse (reverse scale)) scale mode)))) | |
| 162 | ||
| 163 | ||
| 164 | ;#LL: double reverse in is the only way to avoid an endless loop in the main-function | |
| 165 | ||
| 166 | ||
| 167 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 168 | ||
| 169 | ||
| 170 | ||
| 171 | ||
| 172 | ;--------------------------RULES------------------------------------------------------------------------------------------------------------------------------- | |
| 173 | ||
| 174 | ||
| 175 | (om::defmethod! filter-doubles (ids harmony) | |
| 176 | :icon 030719977 | |
| 177 | (if (= (length (remove-duplicates harmony)) (length harmony)) t) | |
| 178 | ) | |
| 179 | ||
| 180 | (om::defmethod! permutations (ids harmony) | |
| 181 | :icon 030719975 | |
| 182 | (let ((ids (list! ids))) | |
| 183 | (mapcar (lambda (x) (subs-posn harmony ids x)) | |
| 184 | (permutations_oml (mapcar (lambda (x) (nth x harmony)) ids)) | |
| 185 | ))) | |
| 186 | ||
| 187 | (om::defmethod! registrations (ids harmony register-list) | |
| 188 | :icon 030719975 | |
| 189 | ||
| 190 | (let ((voices (mapcar (lambda (x) (nth x harmony)) ids))) | |
| 191 | ||
| 192 | (mapcar (lambda (x) (subs-posn harmony ids x)) | |
| 193 | ||
| 194 | (loop for registration in (variations_oml register-list (length ids)) | |
| 195 | collect (mapcar (lambda (x y) (+ x y)) voices registration))))) | |
| 196 | ||
| 197 | ||
| 198 | ;------------------------------------------------------------------------------------------------------------------------------------------------------------------- | |
| 199 | ||
| 200 | ||
| 201 | ||
| 202 | ||
| 203 | ||
| 204 | ||
| 205 | ;:::::::::::::::::::::::::::APPLY-BOXES::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: | |
| 206 | ||
| 207 | (om::defmethod! filter-harmonies (ids rules rule-range) | |
| 208 | :icon 030719976 | |
| 209 | (list (list! ids) (list! rules) rule-range) | |
| 210 | ) | |
| 211 | ||
| 212 | (om::defmethod! expand-harmonies (ids rules rule-range) | |
| 213 | :icon 030719974 | |
| 214 | (list (list! ids) (list! rules) rule-range) | |
| 215 | ) | |
| 216 | ||
| 217 | ;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: | |
| 218 | ||
| 219 | ||
| 220 | ||
| 221 | ||
| 222 | ||
| 223 | ||
| 224 | ||
| 225 | ;;;;;;;;HELPFUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 226 | ||
| 227 | (defun list-max_oml (list) | |
| 228 | (reduce #'max list)) | |
| 229 | ||
| 230 | ||
| 231 | ||
| 232 | (defun list-min_oml (list) | |
| 233 | (reduce #'min list)) | |
| 234 | ||
| 235 | ||
| 236 | ||
| 237 | ||
| a53ccf | 238 | (defun circular_oml (items) |
| LL | 239 | (setf (cdr (last items)) items) |
| 240 | items) | |
| 241 | ||
| c38e61 | 242 | |
| LL | 243 | |
| 244 | ||
| a53ccf | 245 | |
| LL | 246 | (defun flat_oml (liste) |
| 247 | (cond | |
| 248 | ((null (cdr liste)) | |
| 249 | (if (atom (car liste)) | |
| 250 | liste | |
| 251 | (flat_oml (car liste)))) | |
| 252 | ||
| 253 | ((and (listp (car liste)) (not (listp (cadr liste)))) | |
| 254 | (append (car liste) | |
| 255 | (flat_oml (cdr liste)))) | |
| 256 | ||
| 257 | ((and (not (listp (car liste))) (not (listp (cadr liste)))) | |
| 258 | (append (list (car liste)) | |
| 259 | (flat_oml (cdr liste)))) | |
| 260 | ||
| 261 | ((and (listp (car liste)) (listp (cadr liste))) | |
| 262 | (append (car liste) | |
| 263 | (flat_oml (cdr liste)))) | |
| 264 | ||
| 265 | ((and (not (listp (car liste))) (listp (cadr liste))) | |
| 266 | (append (list (car liste)) | |
| 267 | (flat_oml (cdr liste)))))) | |
| 268 | ||
| c38e61 | 269 | |
| LL | 270 | |
| 271 | ||
| a53ccf | 272 | (defun permutations_oml (bag) |
| LL | 273 | |
| 274 | (if (null bag) | |
| 275 | '(()) | |
| 276 | (mapcan #'(lambda (e) | |
| 277 | (mapcar #' (lambda (p) (cons e p)) | |
| 278 | (permutations_oml (remove e bag :count 1 :test #'eq)))) | |
| 279 | bag))) | |
| 280 | ||
| 281 | ||
| 282 | ||
| 283 | ||
| c38e61 | 284 | |
| LL | 285 | |
| a53ccf | 286 | (defun variations_oml (liste pcl) |
| LL | 287 | (let* ((liste (remove-duplicates liste)) |
| 288 | (liste (make-list pcl :initial-element liste))) | |
| 289 | (apply #'alexandria:map-product #'list liste))) | |
| c38e61 | 290 | |
| 2b28da | 291 | |
| 71cec5 | 292 | |
| MS | 293 | |
| 294 | ||
| 295 | ||
| c38e61 | 296 | (defun tester_oml (test list) |
| 71cec5 | 297 | |
| c38e61 | 298 | (cond |
| LL | 299 | ((null list) t) |
| 300 | ((funcall test (car list)) (tester_oml test (cdr list))) | |
| 301 | (t nil) | |
| 302 | ||
| 303 | )) | |
| 304 | ||
| 305 | ||
| 306 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 71cec5 | 307 | |
| 0c8e98 | 308 | |
| LL | 309 | |
