| 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)) |
| c38e61 | 104 | |
| LL | 105 | ;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| 106 | ||
| 107 | ) | |
| 108 | ||
| 109 | ||
| 110 | harmonies)) | |
| 111 | ||
| 112 | ||
| 113 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 2b28da | 114 | |
| LL | 115 | |
| 116 | ||
| 71cec5 | 117 | |
| MS | 118 | |
| 119 | ||
| c38e61 | 120 | ;%%%%%%%%%%%%%%%TRANS-SCALE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
| LL | 121 | |
| 122 | ||
| 123 | (om::defmethod! trans-scale (fundamental scale (mode symbol)) | |
| 124 | :icon 0307199714 | |
| 125 | :initvals '(nil nil 'absolute) | |
| 126 | :menuins '((2 (("absolute" 'absolute) ("circular" 'circular) ("hold" 'hold) | |
| 127 | ("circular-mirror" 'circular-mirror) ("hold-mirror" 'hold-mirror)))) | |
| 128 | ||
| 129 | (cond | |
| 130 | ((null scale) | |
| 131 | (list fundamental)) | |
| 132 | ||
| 133 | ((eq 'absolute mode) | |
| 134 | (append (list fundamental) (loop for i in scale | |
| 135 | sum i into total | |
| 136 | collect (+ fundamental total)))) | |
| 137 | ||
| 138 | ((eq 'circular mode) | |
| 139 | (list nil fundamental (reverse scale) scale mode)) | |
| 140 | ||
| 141 | ((eq 'hold mode) | |
| 142 | (list nil fundamental (reverse scale) scale mode)) | |
| 143 | ||
| 144 | ((eq 'circular-mirror mode) | |
| 145 | (list nil fundamental (reverse (reverse scale)) scale mode)) | |
| 146 | ||
| 147 | ((eq 'hold-mirror mode) | |
| 148 | (list nil fundamental (reverse (reverse scale)) scale mode)))) | |
| 149 | ||
| 150 | ||
| 151 | ;#LL: double reverse in is the only way to avoid an endless loop in the main-function | |
| 152 | ||
| 153 | ||
| 154 | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% | |
| 155 | ||
| 156 | ||
| 157 | ||
| 158 | ||
| 159 | ;--------------------------RULES------------------------------------------------------------------------------------------------------------------------------- | |
| 160 | ||
| 161 | ||
| 162 | (om::defmethod! filter-doubles (ids harmony) | |
| 163 | :icon 030719977 | |
| 164 | (if (= (length (remove-duplicates harmony)) (length harmony)) t) | |
| 165 | ) | |
| 166 | ||
| 167 | (om::defmethod! permutations (ids harmony) | |
| 168 | :icon 030719975 | |
| 169 | (let ((ids (list! ids))) | |
| 170 | (mapcar (lambda (x) (subs-posn harmony ids x)) | |
| 171 | (permutations_oml (mapcar (lambda (x) (nth x harmony)) ids)) | |
| 172 | ))) | |
| 173 | ||
| 174 | (om::defmethod! registrations (ids harmony register-list) | |
| 175 | :icon 030719975 | |
| 176 | ||
| 177 | (let ((voices (mapcar (lambda (x) (nth x harmony)) ids))) | |
| 178 | ||
| 179 | (mapcar (lambda (x) (subs-posn harmony ids x)) | |
| 180 | ||
| 181 | (loop for registration in (variations_oml register-list (length ids)) | |
| 182 | collect (mapcar (lambda (x y) (+ x y)) voices registration))))) | |
| 183 | ||
| 184 | ||
| 185 | ;------------------------------------------------------------------------------------------------------------------------------------------------------------------- | |
| 186 | ||
| 187 | ||
| 188 | ||
| 189 | ||
| 190 | ||
| 191 | ||
| 192 | ;:::::::::::::::::::::::::::APPLY-BOXES::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: | |
| 193 | ||
| 194 | (om::defmethod! filter-harmonies (ids rules rule-range) | |
| 195 | :icon 030719976 | |
| 196 | (list (list! ids) (list! rules) rule-range) | |
| 197 | ) | |
| 198 | ||
| 199 | (om::defmethod! expand-harmonies (ids rules rule-range) | |
| 200 | :icon 030719974 | |
| 201 | (list (list! ids) (list! rules) rule-range) | |
| 202 | ) | |
| 203 | ||
| 204 | ;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: | |
| 205 | ||
| 206 | ||
| 207 | ||
| 208 | ||
| 209 | ||
| 210 | ||
| 211 | ||
| 212 | ;;;;;;;;HELPFUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 213 | ||
| 214 | (defun list-max_oml (list) | |
| 215 | (reduce #'max list)) | |
| 216 | ||
| 217 | ||
| 218 | ||
| 219 | (defun list-min_oml (list) | |
| 220 | (reduce #'min list)) | |
| 221 | ||
| 222 | ||
| 223 | ||
| 224 | ||
| 28dae6 | 225 | (defun sum_oml (liste &optional (start 0)) |
| LL | 226 | (cond ((null liste) start) |
| 227 | (t (sum_oml (cdr liste) (+ start (car liste)))))) | |
| 228 | ||
| 229 | ||
| 230 | ||
| 231 | ||
| 232 | ||
| a53ccf | 233 | (defun circular_oml (items) |
| LL | 234 | (setf (cdr (last items)) items) |
| 235 | items) | |
| 236 | ||
| c38e61 | 237 | |
| LL | 238 | |
| 239 | ||
| a53ccf | 240 | |
| LL | 241 | (defun flat_oml (liste) |
| 242 | (cond | |
| 243 | ((null (cdr liste)) | |
| 244 | (if (atom (car liste)) | |
| 245 | liste | |
| 246 | (flat_oml (car liste)))) | |
| 247 | ||
| 248 | ((and (listp (car liste)) (not (listp (cadr liste)))) | |
| 249 | (append (car liste) | |
| 250 | (flat_oml (cdr liste)))) | |
| 251 | ||
| 252 | ((and (not (listp (car liste))) (not (listp (cadr liste)))) | |
| 253 | (append (list (car liste)) | |
| 254 | (flat_oml (cdr liste)))) | |
| 255 | ||
| 256 | ((and (listp (car liste)) (listp (cadr liste))) | |
| 257 | (append (car liste) | |
| 258 | (flat_oml (cdr liste)))) | |
| 259 | ||
| 260 | ((and (not (listp (car liste))) (listp (cadr liste))) | |
| 261 | (append (list (car liste)) | |
| 262 | (flat_oml (cdr liste)))))) | |
| 263 | ||
| c38e61 | 264 | |
| LL | 265 | |
| 266 | ||
| 28dae6 | 267 | |
| LL | 268 | |
| 269 | ||
| 270 | (defun get-pos_oml (positions seq) | |
| 271 | (let ((positions (if (atom positions) (list positions) positions))) | |
| 272 | (mapcar #'(lambda (it) (nth it seq)) seq))) | |
| 273 | ||
| 274 | ||
| 275 | ||
| 276 | ||
| a53ccf | 277 | (defun permutations_oml (bag) |
| LL | 278 | |
| 279 | (if (null bag) | |
| 280 | '(()) | |
| 281 | (mapcan #'(lambda (e) | |
| 282 | (mapcar #' (lambda (p) (cons e p)) | |
| 283 | (permutations_oml (remove e bag :count 1 :test #'eq)))) | |
| 284 | bag))) | |
| 285 | ||
| 286 | ||
| 287 | ||
| 288 | ||
| 28dae6 | 289 | (defun modulo_oml (pos liste) |
| LL | 290 | (append |
| 291 | (nthcdr pos liste) | |
| 292 | (butlast liste (- (length liste) pos)))) | |
| 293 | ||
| 294 | ||
| 295 | ||
| 296 | ||
| 297 | ||
| 298 | (defun register-permut_oml (register-list) | |
| 299 | (remove-duplicates | |
| 300 | (om::flat | |
| 301 | (loop for r in register-list | |
| 302 | collect | |
| 303 | (mapcar #'(lambda (l) (permutations_oml | |
| 304 | (append (make-list l :initial-element r) | |
| 305 | (make-list (- (length register-list) l) :initial-element 0)))) | |
| 306 | (loop for x from 1 to (length register-list) | |
| 307 | collect x))) 2) :test 'equal)) | |
| 308 | ||
| 309 | ||
| 310 | ||
| 311 | ||
| 312 | (defun find-pos_oml (item seq) | |
| 313 | (remove nil (loop for s in seq | |
| 314 | for x | |
| 315 | collect (if (equal item s) x)))) | |
| 316 | ||
| 317 | ||
| 318 | ||
| 319 | ||
| 320 | (defun sum_oml (liste) | |
| 321 | (if (null (cdr liste)) | |
| 322 | (car liste) | |
| 323 | (+ (car liste) | |
| 324 | (sum_oml (cdr liste))))) | |
| 325 | ||
| 326 | ||
| c38e61 | 327 | |
| LL | 328 | |
| a53ccf | 329 | (defun variations_oml (liste pcl) |
| LL | 330 | (let* ((liste (remove-duplicates liste)) |
| 331 | (liste (make-list pcl :initial-element liste))) | |
| 332 | (apply #'alexandria:map-product #'list liste))) | |
| c38e61 | 333 | |
| 28dae6 | 334 | |
| LL | 335 | |
| 336 | ||
| 337 | ||
| 338 | (defun find-dups_oml (lst) | |
| 339 | (cond ((null lst) '()) | |
| 340 | ((member (car lst) (cdr lst)) (cons (car lst) (find-dups_oml (cdr lst)))) | |
| 341 | (t (find-dups_oml (cdr lst))))) | |
| 2b28da | 342 | |
| 71cec5 | 343 | |
| MS | 344 | |
| 345 | ||
| 346 | ||
| c38e61 | 347 | (defun tester_oml (test list) |
| 71cec5 | 348 | |
| c38e61 | 349 | (cond |
| LL | 350 | ((null list) t) |
| 351 | ((funcall test (car list)) (tester_oml test (cdr list))) | |
| 352 | (t nil) | |
| 353 | ||
| 354 | )) | |
| 355 | ||
| 356 | ||
| 357 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 71cec5 | 358 | |
| 0c8e98 | 359 | |
| LL | 360 | |
| 28dae6 | 361 | (let ((a '(1))) |
| LL | 362 | (delete 1 a)) |
| 363 | ||
