| 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 | ||
| 9 | (in-package :omlead) | |
| 10 | ||
| 11 | ||
| c11544 | 12 | (om::defmethod! gen-harmonies ((pitch-set-list list) (instr1 list) (instr2 list) (instr3 list) (instr4 list) &key (avoid-empty-voices nil) (fundamental 6000) (skala (list 100)) (permutations nil) (register-list '(0))) |
| 71cec5 | 13 | |
| MS | 14 | :icon 030719972 |
| b2f2a3 | 15 | :initvals '('((0)) '(6000 7200) nil nil nil) |
| 71cec5 | 16 | :indoc '("a list of lists of intervals respective to a base not in midi-cents" "range-list with the lowest and highest note of the instrument in midi-cents" "range-list with the lowest and highest note of the instrument in midi-cents" "range-list with the lowest and highest note of the instrument in midi-cents" "range-list with the lowest and highest note of the instrument in midi-cents" "list of intervals based on the virtual fundamental which defines the <octave> for register-transposition") |
| MS | 17 | |
| 18 | :numouts 1 | |
| 19 | ||
| 20 | :doc "creates a list of chords, that contains all possible transpositions & permutations of the given pitch-sets" | |
| 21 | ||
| 22 | (let* ( | |
| 23 | ||
| 24 | (instr-list (sort (flat_oml (remove nil (list instr1 instr2 instr3 instr4))) '<)) | |
| 25 | (total-range (cons (car instr-list) (last instr-list))) | |
| 26 | (trans-skala (let* ((grundton fundamental) | |
| 27 | (tief (car total-range)) | |
| 28 | (hoch (cadr total-range)) | |
| 29 | (skala-up skala) | |
| 30 | (skala-down (reverse skala-up)) | |
| 31 | (endless-up (circular_oml skala-up)) | |
| 32 | (endless-down (circular_oml skala-down)) | |
| 33 | (skala-up (loop for i in endless-up | |
| 34 | sum i into delta | |
| 35 | until (> (+ delta grundton) hoch) | |
| 36 | collect i)) | |
| 37 | (skala-down (loop for i in endless-down | |
| 38 | sum i into delta | |
| 39 | until (< (- grundton delta) tief) | |
| 40 | collect i)) | |
| 41 | (transpositionsliste-up (list grundton)) | |
| 42 | (transpositionsliste-down (list grundton))) | |
| 43 | ||
| 44 | (loop for i in skala-up | |
| 45 | do (push (+ (car transpositionsliste-up) i) transpositionsliste-up)) | |
| 46 | (loop for i in skala-down | |
| 47 | do (push (- (car transpositionsliste-down) i) transpositionsliste-down)) | |
| 48 | ||
| 49 | (append (butlast transpositionsliste-down) (reverse transpositionsliste-up)) | |
| 50 | )) | |
| 51 | ||
| 52 | (harmon-database (om::flat | |
| 53 | (loop for pitch in trans-skala | |
| 54 | collect | |
| 55 | (loop for set in pitch-set-list | |
| 56 | collect | |
| 57 | (mapcar #'(lambda (l) (+ pitch l)) set))) 1)) | |
| 58 | ||
| 59 | (harmon-database (cond (permutations (om::flat (loop for l in harmon-database | |
| 60 | collect (permutations_oml l)) 1)) | |
| 61 | (t harmon-database))) | |
| 62 | ||
| 63 | ||
| 64 | (harmon-database (remove-duplicates (om::flat (loop for a in harmon-database | |
| 65 | collect | |
| 66 | (loop for reg in (variations_oml register-list (length a)) | |
| 67 | collect (mapcar #'(lambda (r p) (+ r p)) reg a))) 1) :test 'equal)) | |
| 8e1e11 | 68 | (instr-list2 (list instr1 instr2 instr3 instr4)) |
| LL | 69 | (harmon-database (remove -1 (loop for a in harmon-database |
| 71cec5 | 70 | collect (loop for p in a |
| 8e1e11 | 71 | for c to (1- (length instr-list2)) |
| 71cec5 | 72 | |
| 8e1e11 | 73 | collect (if (nth c instr-list2) (if (or (< p (car (nth c instr-list2))) |
| LL | 74 | (> p (cadr (nth c instr-list2)))) nil p) -1)) ))) |
| 71cec5 | 75 | (harmon-database (remove nil (loop for a in harmon-database |
| 8e1e11 | 76 | collect (if (> (count nil a) 0) nil a)))) |
| 71cec5 | 77 | |
| c11544 | 78 | (harmon-database (if avoid-empty-voices (mapcar (lambda (x) (remove -1 x)) harmon-database) harmon-database))) |
| 8e1e11 | 79 | harmon-database)) |
| 71cec5 | 80 | |
| a53ccf | 81 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 71cec5 | 82 | |
| a53ccf | 83 | (defun circular_oml (items) |
| LL | 84 | (setf (cdr (last items)) items) |
| 85 | items) | |
| 86 | ||
| 87 | ||
| 88 | (defun flat_oml (liste) | |
| 89 | (cond | |
| 90 | ((null (cdr liste)) | |
| 91 | (if (atom (car liste)) | |
| 92 | liste | |
| 93 | (flat_oml (car liste)))) | |
| 94 | ||
| 95 | ||
| 96 | ((and (listp (car liste)) (not (listp (cadr liste)))) | |
| 97 | (append (car liste) | |
| 98 | (flat_oml (cdr liste)))) | |
| 99 | ||
| 100 | ||
| 101 | ((and (not (listp (car liste))) (not (listp (cadr liste)))) | |
| 102 | (append (list (car liste)) | |
| 103 | (flat_oml (cdr liste)))) | |
| 104 | ||
| 105 | ((and (listp (car liste)) (listp (cadr liste))) | |
| 106 | (append (car liste) | |
| 107 | (flat_oml (cdr liste)))) | |
| 108 | ||
| 109 | ((and (not (listp (car liste))) (listp (cadr liste))) | |
| 110 | (append (list (car liste)) | |
| 111 | (flat_oml (cdr liste)))))) | |
| 112 | ||
| 113 | (defun get-pos_oml (positions seq) | |
| 114 | (let ((positions (if (atom positions) (list positions) positions))) | |
| 115 | (mapcar #'(lambda (it) (nth it seq)) seq))) | |
| 116 | ||
| 117 | ||
| 118 | (defun permutations_oml (bag) | |
| 119 | ||
| 120 | (if (null bag) | |
| 121 | '(()) | |
| 122 | ||
| 123 | (mapcan #'(lambda (e) | |
| 124 | (mapcar #' (lambda (p) (cons e p)) | |
| 125 | (permutations_oml (remove e bag :count 1 :test #'eq)))) | |
| 126 | bag))) | |
| 127 | ||
| 128 | ||
| 129 | ||
| 130 | ||
| 131 | (defun modulo_oml (pos liste) | |
| 132 | (append | |
| 133 | (nthcdr pos liste) | |
| 134 | (butlast liste (- (length liste) pos)))) | |
| 135 | ||
| 136 | ||
| 137 | (defun register-permut_oml (register-list) | |
| 138 | (remove-duplicates | |
| 139 | (om::flat | |
| 140 | (loop for r in register-list | |
| 141 | collect | |
| 142 | (mapcar #'(lambda (l) (permutations_oml | |
| 143 | (append (make-list l :initial-element r) | |
| 144 | (make-list (- (length register-list) l) :initial-element 0)))) | |
| 145 | (loop for x from 1 to (length register-list) | |
| 146 | collect x))) 2) :test 'equal)) | |
| 147 | ||
| 148 | ||
| 149 | (defun find-pos_oml (item seq) | |
| 150 | (remove nil (loop for s in seq | |
| 151 | for x | |
| 152 | collect (if (equal item s) x)))) | |
| 153 | ||
| 154 | ||
| 155 | (defun sum_oml (liste) | |
| 156 | (if (null (cdr liste)) | |
| 157 | (car liste) | |
| 158 | (+ (car liste) | |
| 159 | (sum_oml (cdr liste))))) | |
| 160 | ||
| 161 | (defun variations_oml (liste pcl) | |
| 162 | (let* ((liste (remove-duplicates liste)) | |
| 163 | (liste (make-list pcl :initial-element liste))) | |
| 164 | (apply #'alexandria:map-product #'list liste))) | |
| 165 | ||
| 166 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 167 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 71cec5 | 168 | |
| MS | 169 | |
| 170 | ||
| 171 | ||
| 172 | ||
| 173 | ||
