| 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 | ||
| dec6d6 | 12 | (om::defmethod! gen-harmonies ((pitch-set-list list) (instr1 list) (instr2 list) (instr3 list) (instr4 list) &key (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 | ||
| 23 | (defun circular_oml (items) | |
| 24 | (setf (cdr (last items)) items) | |
| 25 | items) | |
| 26 | ||
| 27 | ||
| 28 | (defun flat_oml (liste) | |
| 29 | (cond | |
| 30 | ((null (cdr liste)) | |
| 31 | (if (atom (car liste)) | |
| 32 | liste | |
| 33 | (flat_oml (car liste)))) | |
| 34 | ||
| 35 | ||
| 36 | ((and (listp (car liste)) (not (listp (cadr liste)))) | |
| 37 | (append (car liste) | |
| 38 | (flat_oml (cdr liste)))) | |
| 39 | ||
| 40 | ||
| 41 | ((and (not (listp (car liste))) (not (listp (cadr liste)))) | |
| 42 | (append (list (car liste)) | |
| 43 | (flat_oml (cdr liste)))) | |
| 44 | ||
| 45 | ((and (listp (car liste)) (listp (cadr liste))) | |
| 46 | (append (car liste) | |
| 47 | (flat_oml (cdr liste)))) | |
| 48 | ||
| 49 | ((and (not (listp (car liste))) (listp (cadr liste))) | |
| 50 | (append (list (car liste)) | |
| 51 | (flat_oml (cdr liste)))))) | |
| 52 | ||
| 53 | (defun get-pos_oml (positions seq) | |
| 54 | (let ((positions (if (atom positions) (list positions) positions))) | |
| 55 | (mapcar #'(lambda (it) (nth it seq)) seq))) | |
| 56 | ||
| 57 | ||
| 58 | (defun permutations_oml (bag) | |
| 59 | ||
| 60 | (if (null bag) | |
| 61 | '(()) | |
| 62 | ||
| 63 | (mapcan #'(lambda (e) | |
| 64 | (mapcar #' (lambda (p) (cons e p)) | |
| 65 | (permutations_oml (remove e bag :count 1 :test #'eq)))) | |
| 66 | bag))) | |
| 67 | ||
| 68 | ||
| 69 | (defun mat-trans_oml (list) | |
| 70 | (loop for y in (let (count-list) | |
| 71 | (dotimes (i (length (car list))) | |
| 72 | (setq count-list (cons i count-list))) (nreverse count-list)) | |
| 73 | collect (loop for x in list collect (nth y x)) | |
| 74 | ||
| 75 | )) | |
| 76 | ||
| 77 | ||
| 78 | ||
| 79 | (defun modulo_oml (pos liste) | |
| 80 | (append | |
| 81 | (nthcdr pos liste) | |
| 82 | (butlast liste (- (length liste) pos)))) | |
| 83 | ||
| 84 | ||
| 85 | (defun register-permut_oml (register-list) | |
| 86 | (remove-duplicates | |
| 87 | (om::flat | |
| 88 | (loop for r in register-list | |
| 89 | collect | |
| 90 | (mapcar #'(lambda (l) (permutations_oml | |
| 91 | (append (make-list l :initial-element r) | |
| 92 | (make-list (- (length register-list) l) :initial-element 0)))) | |
| 93 | (loop for x from 1 to (length register-list) | |
| 94 | collect x))) 2) :test 'equal)) | |
| 95 | ||
| 96 | ||
| 97 | (defun find-pos_oml (item seq) | |
| 98 | (remove nil (loop for s in seq | |
| 99 | for x | |
| 100 | collect (if (equal item s) x)))) | |
| 101 | ||
| 102 | ||
| 103 | (defun sum_oml (liste) | |
| 104 | (if (null (cdr liste)) | |
| 105 | (car liste) | |
| 106 | (+ (car liste) | |
| 107 | (sum_oml (cdr liste))))) | |
| 108 | ||
| 109 | (defun variations_oml (liste pcl) | |
| 110 | (let* ((liste (remove-duplicates liste)) | |
| 111 | (liste (make-list pcl :initial-element liste))) | |
| 112 | (apply #'alexandria:map-product #'list liste))) | |
| 113 | ||
| 114 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; | |
| 115 | (let* ( | |
| 116 | ||
| 117 | (instr-list (sort (flat_oml (remove nil (list instr1 instr2 instr3 instr4))) '<)) | |
| 118 | (total-range (cons (car instr-list) (last instr-list))) | |
| 119 | (trans-skala (let* ((grundton fundamental) | |
| 120 | (tief (car total-range)) | |
| 121 | (hoch (cadr total-range)) | |
| 122 | (skala-up skala) | |
| 123 | (skala-down (reverse skala-up)) | |
| 124 | (endless-up (circular_oml skala-up)) | |
| 125 | (endless-down (circular_oml skala-down)) | |
| 126 | (skala-up (loop for i in endless-up | |
| 127 | sum i into delta | |
| 128 | until (> (+ delta grundton) hoch) | |
| 129 | collect i)) | |
| 130 | (skala-down (loop for i in endless-down | |
| 131 | sum i into delta | |
| 132 | until (< (- grundton delta) tief) | |
| 133 | collect i)) | |
| 134 | (transpositionsliste-up (list grundton)) | |
| 135 | (transpositionsliste-down (list grundton))) | |
| 136 | ||
| 137 | (loop for i in skala-up | |
| 138 | do (push (+ (car transpositionsliste-up) i) transpositionsliste-up)) | |
| 139 | (loop for i in skala-down | |
| 140 | do (push (- (car transpositionsliste-down) i) transpositionsliste-down)) | |
| 141 | ||
| 142 | (append (butlast transpositionsliste-down) (reverse transpositionsliste-up)) | |
| 143 | )) | |
| 144 | ||
| 145 | (harmon-database (om::flat | |
| 146 | (loop for pitch in trans-skala | |
| 147 | collect | |
| 148 | (loop for set in pitch-set-list | |
| 149 | collect | |
| 150 | (mapcar #'(lambda (l) (+ pitch l)) set))) 1)) | |
| 151 | ||
| 152 | (harmon-database (cond (permutations (om::flat (loop for l in harmon-database | |
| 153 | collect (permutations_oml l)) 1)) | |
| 154 | (t harmon-database))) | |
| 155 | ||
| 156 | ||
| 157 | (harmon-database (remove-duplicates (om::flat (loop for a in harmon-database | |
| 158 | collect | |
| 159 | (loop for reg in (variations_oml register-list (length a)) | |
| 160 | collect (mapcar #'(lambda (r p) (+ r p)) reg a))) 1) :test 'equal)) | |
| 161 | (instr-list2 (remove nil (list instr1 instr2 instr3 instr4))) | |
| 8e1e11 | 162 | (instr-list2 (list instr1 instr2 instr3 instr4)) |
| LL | 163 | (harmon-database (remove -1 (loop for a in harmon-database |
| 71cec5 | 164 | collect (loop for p in a |
| 8e1e11 | 165 | for c to (1- (length instr-list2)) |
| 71cec5 | 166 | |
| 8e1e11 | 167 | collect (if (nth c instr-list2) (if (or (< p (car (nth c instr-list2))) |
| LL | 168 | (> p (cadr (nth c instr-list2)))) nil p) -1)) ))) |
| 71cec5 | 169 | (harmon-database (remove nil (loop for a in harmon-database |
| 8e1e11 | 170 | collect (if (> (count nil a) 0) nil a)))) |
| 71cec5 | 171 | |
| 8e1e11 | 172 | harmon-database)) |
| 71cec5 | 173 | |
| MS | 174 | |
| 175 | ||
| 176 | ||
| 177 | ||
| 178 | ||
| 179 | ||
| 180 | ||
