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