| 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 | ||
| 2b28da | 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)) (avoid-doublings nil)) |
| 71cec5 | 13 | |
| MS | 14 | :icon 030719972 |
| b2f2a3 | 15 | :initvals '('((0)) '(6000 7200) nil nil nil) |
| 2b28da | 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" "if true all chords with the same note in two or more instruments will be avoided") |
| 71cec5 | 17 | |
| MS | 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)) | |
| 2b28da | 68 | |
| LL | 69 | (harmon-database (cond |
| 10cb19 | 70 | (avoid-doublings (remove nil (loop for a in harmon-database |
| 2b28da | 71 | collect (if (not (find-dups_oml a)) a nil)))) |
| LL | 72 | (t harmon-database) |
| 73 | )) | |
| 74 | ||
| 75 | ||
| 76 | ||
| 8e1e11 | 77 | (instr-list2 (list instr1 instr2 instr3 instr4)) |
| LL | 78 | (harmon-database (remove -1 (loop for a in harmon-database |
| 71cec5 | 79 | collect (loop for p in a |
| 8e1e11 | 80 | for c to (1- (length instr-list2)) |
| 71cec5 | 81 | |
| 8e1e11 | 82 | collect (if (nth c instr-list2) (if (or (< p (car (nth c instr-list2))) |
| LL | 83 | (> p (cadr (nth c instr-list2)))) nil p) -1)) ))) |
| 71cec5 | 84 | (harmon-database (remove nil (loop for a in harmon-database |
| 8e1e11 | 85 | collect (if (> (count nil a) 0) nil a)))) |
| 71cec5 | 86 | |
| c11544 | 87 | (harmon-database (if avoid-empty-voices (mapcar (lambda (x) (remove -1 x)) harmon-database) harmon-database))) |
| 8e1e11 | 88 | harmon-database)) |
| 71cec5 | 89 | |
| a53ccf | 90 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 71cec5 | 91 | |
| a53ccf | 92 | (defun circular_oml (items) |
| LL | 93 | (setf (cdr (last items)) items) |
| 94 | items) | |
| 95 | ||
| 96 | ||
| 97 | (defun flat_oml (liste) | |
| 98 | (cond | |
| 99 | ((null (cdr liste)) | |
| 100 | (if (atom (car liste)) | |
| 101 | liste | |
| 102 | (flat_oml (car liste)))) | |
| 103 | ||
| 104 | ||
| 105 | ((and (listp (car liste)) (not (listp (cadr liste)))) | |
| 106 | (append (car liste) | |
| 107 | (flat_oml (cdr liste)))) | |
| 108 | ||
| 109 | ||
| 110 | ((and (not (listp (car liste))) (not (listp (cadr liste)))) | |
| 111 | (append (list (car liste)) | |
| 112 | (flat_oml (cdr liste)))) | |
| 113 | ||
| 114 | ((and (listp (car liste)) (listp (cadr liste))) | |
| 115 | (append (car liste) | |
| 116 | (flat_oml (cdr liste)))) | |
| 117 | ||
| 118 | ((and (not (listp (car liste))) (listp (cadr liste))) | |
| 119 | (append (list (car liste)) | |
| 120 | (flat_oml (cdr liste)))))) | |
| 121 | ||
| 122 | (defun get-pos_oml (positions seq) | |
| 123 | (let ((positions (if (atom positions) (list positions) positions))) | |
| 124 | (mapcar #'(lambda (it) (nth it seq)) seq))) | |
| 125 | ||
| 126 | ||
| 127 | (defun permutations_oml (bag) | |
| 128 | ||
| 129 | (if (null bag) | |
| 130 | '(()) | |
| 131 | ||
| 132 | (mapcan #'(lambda (e) | |
| 133 | (mapcar #' (lambda (p) (cons e p)) | |
| 134 | (permutations_oml (remove e bag :count 1 :test #'eq)))) | |
| 135 | bag))) | |
| 136 | ||
| 137 | ||
| 138 | ||
| 139 | ||
| 140 | (defun modulo_oml (pos liste) | |
| 141 | (append | |
| 142 | (nthcdr pos liste) | |
| 143 | (butlast liste (- (length liste) pos)))) | |
| 144 | ||
| 145 | ||
| 146 | (defun register-permut_oml (register-list) | |
| 147 | (remove-duplicates | |
| 148 | (om::flat | |
| 149 | (loop for r in register-list | |
| 150 | collect | |
| 151 | (mapcar #'(lambda (l) (permutations_oml | |
| 152 | (append (make-list l :initial-element r) | |
| 153 | (make-list (- (length register-list) l) :initial-element 0)))) | |
| 154 | (loop for x from 1 to (length register-list) | |
| 155 | collect x))) 2) :test 'equal)) | |
| 156 | ||
| 157 | ||
| 158 | (defun find-pos_oml (item seq) | |
| 159 | (remove nil (loop for s in seq | |
| 160 | for x | |
| 161 | collect (if (equal item s) x)))) | |
| 162 | ||
| 163 | ||
| 164 | (defun sum_oml (liste) | |
| 165 | (if (null (cdr liste)) | |
| 166 | (car liste) | |
| 167 | (+ (car liste) | |
| 168 | (sum_oml (cdr liste))))) | |
| 169 | ||
| 170 | (defun variations_oml (liste pcl) | |
| 171 | (let* ((liste (remove-duplicates liste)) | |
| 172 | (liste (make-list pcl :initial-element liste))) | |
| 173 | (apply #'alexandria:map-product #'list liste))) | |
| 174 | ||
| 2b28da | 175 | |
| LL | 176 | (defun find-dups_oml (lst) |
| 177 | (cond ((null lst) '()) | |
| 178 | ((member (car lst) (cdr lst)) (cons (car lst) (find-dups_oml (cdr lst)))) | |
| 179 | (t (find-dups_oml (cdr lst))))) | |
| 180 | ||
| a53ccf | 181 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| LL | 182 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 71cec5 | 183 | |
| MS | 184 | |
| 185 | ||
| 186 | ||
| 187 | ||
| 188 | ||
