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