| | |
|---|
| | | |
|---|
| | | ;====================================== |
|---|
| | | ;OM-Lead, 2022-2023 |
|---|
| | | ;OM-Lead, 2022-2024 |
|---|
| | | ; |
|---|
| | | ;Library for Rule-based Voice-Leading |
|---|
| | | ;Author: Lorenz Lehmann |
|---|
| | | ;Supervision: Marlon Schumacher |
|---|
| | | ;====================================== |
|---|
| | | |
|---|
| | | |
|---|
| | | (in-package :omlead) |
|---|
| | | |
|---|
| | | |
|---|
| | | (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))) |
|---|
| | | |
|---|
| | | :icon 030719972 |
|---|
| | | :initvals '('((0)) '(6000 7200) nil nil nil) |
|---|
| | | :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") |
|---|
| | | ;;;;;;GEN-HARMONIES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | |
|---|
| | | :numouts 1 |
|---|
| | | (om::defmethod! gen-harmonies (pitch-sets trans-scale ranges expand-harmonies filter-harmonies) |
|---|
| | | :icon 030719978 |
|---|
| | | |
|---|
| | | ;++++++++++++++++++++++ transposition ++++++++++++++++++++++++++++++++++++++++++++++++ |
|---|
| | | (let* ((scale |
|---|
| | | |
|---|
| | | (cond |
|---|
| | | |
|---|
| | | ((numberp (car trans-scale )) |
|---|
| | | trans-scale) |
|---|
| | | |
|---|
| | | |
|---|
| | | (t (let ((fundamental (second trans-scale)) |
|---|
| | | (negativ (third trans-scale)) |
|---|
| | | (positiv (fourth trans-scale)) |
|---|
| | | (mode (fifth trans-scale)) |
|---|
| | | (range-min (list-min_oml (flat_oml ranges))) |
|---|
| | | (range-max (list-max_oml (flat_oml ranges)))) |
|---|
| | | |
|---|
| | | (append |
|---|
| | | |
|---|
| | | |
|---|
| | | ;;;;;;;;;;;;;;;;;;negativ |
|---|
| | | (reverse (loop for i in (if (or (eq 'hold mode) (eq 'hold-mirror mode)) |
|---|
| | | (hold_oml negativ) (circular_oml negativ)) ;;endless down-list |
|---|
| | | sum i into total |
|---|
| | | until (> range-min (- fundamental total)) |
|---|
| | | collect (- fundamental total) |
|---|
| | | )) |
|---|
| | | |
|---|
| | | (list fundamental) |
|---|
| | | |
|---|
| | | ;;;;;;;;;;;;;;;;;;positiv |
|---|
| | | |
|---|
| | | (loop for i in (if (or (eq 'hold mode) (eq 'hold-mirror mode)) |
|---|
| | | (hold_oml positiv) (circular_oml positiv)) ;;endless up-list |
|---|
| | | sum i into total |
|---|
| | | until (< range-max (+ fundamental total)) |
|---|
| | | collect (+ fundamental total))))))) |
|---|
| | | |
|---|
| | | :doc "creates a list of chords, that contains all possible transpositions & permutations of the given pitch-sets" |
|---|
| | | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | (harmonies (loop for pitch-set in pitch-sets |
|---|
| | | append (loop for pitch in scale |
|---|
| | | collect (mapcar (lambda (x) (+ x pitch)) pitch-set)))) |
|---|
| | | |
|---|
| | | ;++++++++++++++++ adapt-collection-to-voice-ranges ++++++++++++++++++++++++++++++++++++++++++++++++++++ |
|---|
| | | |
|---|
| | | |
|---|
| | | (harmonies (remove nil (loop for harmony in (remove-duplicates harmonies :test #'equal) |
|---|
| | | collect (if (find -1 (mapcar (lambda (pitch range) |
|---|
| | | (if (and (<= pitch (list-max_oml range)) (>= pitch (list-min_oml range))) pitch -1)) |
|---|
| | | harmony ranges)) nil harmony)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;++++++++++++++++ expand-harmonies ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
|---|
| | | |
|---|
| | | (expand-harmonies (if (atom (caar expand-harmonies)) (list expand-harmonies) expand-harmonies)) |
|---|
| | | |
|---|
| | | (harmonies |
|---|
| | | (if (car expand-harmonies) |
|---|
| | | (let ((harmony-list (list harmonies))) |
|---|
| | | |
|---|
| | | |
|---|
| | | (loop for expand-box in expand-harmonies |
|---|
| | | do (loop for rule in (second expand-box) |
|---|
| | | do (loop for harmony in (car harmony-list) |
|---|
| | | if (tester_oml |
|---|
| | | (lambda (x) (and (<= (list-min_oml (third expand-box)) x) (>= (list-max_oml (third expand-box)) x))) |
|---|
| | | harmony) |
|---|
| | | append |
|---|
| | | |
|---|
| | | (mapcar (lambda (y) |
|---|
| | | (if (tester_oml (lambda (x) (and (<= (list-min_oml (flat_oml ranges)) x) (>= (list-max_oml (flat_oml ranges)) x))) y) |
|---|
| | | y nil)) |
|---|
| | | (funcall rule (first expand-box) harmony)) into temp-harmonies |
|---|
| | | else append harmony into temp-harmonies |
|---|
| | | finally (fill harmony-list (remove nil temp-harmonies))))) |
|---|
| | | (car harmony-list)) |
|---|
| | | harmonies)) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;++++++++++++++++ filter-harmonies ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
|---|
| | | |
|---|
| | | (filter-harmonies (if (atom (caar filter-harmonies)) (list filter-harmonies) filter-harmonies)) |
|---|
| | | |
|---|
| | | (harmonies |
|---|
| | | (if (car filter-harmonies) |
|---|
| | | (let ((filter-list harmonies)) |
|---|
| | | |
|---|
| | | |
|---|
| | | (loop for filter-box in filter-harmonies |
|---|
| | | do (loop for rule in (second filter-box) |
|---|
| | | |
|---|
| | | do (loop for harmony in filter-list |
|---|
| | | do (if (tester_oml |
|---|
| | | (lambda (x) (and (<= (list-min_oml (third filter-box)) x) (>= (list-max_oml (third filter-box)) x))) |
|---|
| | | harmony) |
|---|
| | | (if (not (funcall rule (first filter-box) harmony)) |
|---|
| | | (delete harmony filter-list)))))) |
|---|
| | | filter-list) |
|---|
| | | harmonies)) |
|---|
| | | |
|---|
| | | ;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
|---|
| | | |
|---|
| | | ) |
|---|
| | | |
|---|
| | | |
|---|
| | | harmonies)) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | ;%%%%%%%%%%%%%%%TRANS-SCALE%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
|---|
| | | |
|---|
| | | |
|---|
| | | (om::defmethod! trans-scale (fundamental scale (mode symbol)) |
|---|
| | | :icon 0307199714 |
|---|
| | | :initvals '(nil nil 'absolute) |
|---|
| | | :menuins '((2 (("absolute" 'absolute) ("circular" 'circular) ("hold" 'hold) |
|---|
| | | ("circular-mirror" 'circular-mirror) ("hold-mirror" 'hold-mirror)))) |
|---|
| | | |
|---|
| | | (cond |
|---|
| | | ((null scale) |
|---|
| | | (list fundamental)) |
|---|
| | | |
|---|
| | | ((eq 'absolute mode) |
|---|
| | | (append (list fundamental) (loop for i in scale |
|---|
| | | sum i into total |
|---|
| | | collect (+ fundamental total)))) |
|---|
| | | |
|---|
| | | ((eq 'circular mode) |
|---|
| | | (list nil fundamental (reverse scale) scale mode)) |
|---|
| | | |
|---|
| | | ((eq 'hold mode) |
|---|
| | | (list nil fundamental (reverse scale) scale mode)) |
|---|
| | | |
|---|
| | | ((eq 'circular-mirror mode) |
|---|
| | | (list nil fundamental (reverse (reverse scale)) scale mode)) |
|---|
| | | |
|---|
| | | ((eq 'hold-mirror mode) |
|---|
| | | (list nil fundamental (reverse (reverse scale)) scale mode)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;#LL: double reverse in is the only way to avoid an endless loop in the main-function |
|---|
| | | |
|---|
| | | |
|---|
| | | ;%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | ;--------------------------RULES------------------------------------------------------------------------------------------------------------------------------- |
|---|
| | | |
|---|
| | | |
|---|
| | | (om::defmethod! filter-doubles (ids harmony) |
|---|
| | | :icon 030719977 |
|---|
| | | (if (= (length (remove-duplicates harmony)) (length harmony)) t) |
|---|
| | | ) |
|---|
| | | |
|---|
| | | (om::defmethod! permutations (ids harmony) |
|---|
| | | :icon 030719975 |
|---|
| | | (let ((ids (list! ids))) |
|---|
| | | (mapcar (lambda (x) (subs-posn harmony ids x)) |
|---|
| | | (permutations_oml (mapcar (lambda (x) (nth x harmony)) ids)) |
|---|
| | | ))) |
|---|
| | | |
|---|
| | | (om::defmethod! registrations (ids harmony register-list) |
|---|
| | | :icon 030719975 |
|---|
| | | |
|---|
| | | (let ((voices (mapcar (lambda (x) (nth x harmony)) ids))) |
|---|
| | | |
|---|
| | | (mapcar (lambda (x) (subs-posn harmony ids x)) |
|---|
| | | |
|---|
| | | (loop for registration in (variations_oml register-list (length ids)) |
|---|
| | | collect (mapcar (lambda (x y) (+ x y)) voices registration))))) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;------------------------------------------------------------------------------------------------------------------------------------------------------------------- |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | ;:::::::::::::::::::::::::::APPLY-BOXES::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: |
|---|
| | | |
|---|
| | | (om::defmethod! filter-harmonies (ids rules rule-range) |
|---|
| | | :icon 030719976 |
|---|
| | | (list (list! ids) (list! rules) rule-range) |
|---|
| | | ) |
|---|
| | | |
|---|
| | | (om::defmethod! expand-harmonies (ids rules rule-range) |
|---|
| | | :icon 030719974 |
|---|
| | | (list (list! ids) (list! rules) rule-range) |
|---|
| | | ) |
|---|
| | | |
|---|
| | | ;::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | ;;;;;;;;HELPFUNCTIONS;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | |
|---|
| | | (defun list-max_oml (list) |
|---|
| | | (reduce #'max list)) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun list-min_oml (list) |
|---|
| | | (reduce #'min list)) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun circular_oml (items) |
|---|
| | | (setf (cdr (last items)) items) |
|---|
| | | items) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun flat_oml (liste) |
|---|
| | |
|---|
| | | liste |
|---|
| | | (flat_oml (car liste)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | ((and (listp (car liste)) (not (listp (cadr liste)))) |
|---|
| | | (append (car liste) |
|---|
| | | (flat_oml (cdr liste)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | ((and (not (listp (car liste))) (not (listp (cadr liste)))) |
|---|
| | | (append (list (car liste)) |
|---|
| | |
|---|
| | | (append (list (car liste)) |
|---|
| | | (flat_oml (cdr liste)))))) |
|---|
| | | |
|---|
| | | (defun get-pos_oml (positions seq) |
|---|
| | | (let ((positions (if (atom positions) (list positions) positions))) |
|---|
| | | (mapcar #'(lambda (it) (nth it seq)) seq))) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun permutations_oml (bag) |
|---|
| | | |
|---|
| | | (if (null bag) |
|---|
| | | '(()) |
|---|
| | | |
|---|
| | | (mapcan #'(lambda (e) |
|---|
| | | (mapcar #' (lambda (p) (cons e p)) |
|---|
| | | (permutations_oml (remove e bag :count 1 :test #'eq)))) |
|---|
| | | bag))) |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun mat-trans_oml (list) |
|---|
| | | (loop for y in (let (count-list) |
|---|
| | | (dotimes (i (length (car list))) |
|---|
| | | (setq count-list (cons i count-list))) (nreverse count-list)) |
|---|
| | | collect (loop for x in list collect (nth y x)) |
|---|
| | | |
|---|
| | | )) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun modulo_oml (pos liste) |
|---|
| | | (append |
|---|
| | | (nthcdr pos liste) |
|---|
| | | (butlast liste (- (length liste) pos)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun register-permut_oml (register-list) |
|---|
| | | (remove-duplicates |
|---|
| | | (om::flat |
|---|
| | | (loop for r in register-list |
|---|
| | | collect |
|---|
| | | (mapcar #'(lambda (l) (permutations_oml |
|---|
| | | (append (make-list l :initial-element r) |
|---|
| | | (make-list (- (length register-list) l) :initial-element 0)))) |
|---|
| | | (loop for x from 1 to (length register-list) |
|---|
| | | collect x))) 2) :test 'equal)) |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun find-pos_oml (item seq) |
|---|
| | | (remove nil (loop for s in seq |
|---|
| | | for x |
|---|
| | | collect (if (equal item s) x)))) |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun sum_oml (liste) |
|---|
| | | (if (null (cdr liste)) |
|---|
| | | (car liste) |
|---|
| | | (+ (car liste) |
|---|
| | | (sum_oml (cdr liste))))) |
|---|
| | | |
|---|
| | | (defun variations_oml (liste pcl) |
|---|
| | | (let* ((liste (remove-duplicates liste)) |
|---|
| | | (liste (make-list pcl :initial-element liste))) |
|---|
| | | (apply #'alexandria:map-product #'list liste))) |
|---|
| | | |
|---|
| | | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | (let* ( |
|---|
| | | |
|---|
| | | (instr-list (sort (flat_oml (remove nil (list instr1 instr2 instr3 instr4))) '<)) |
|---|
| | | (total-range (cons (car instr-list) (last instr-list))) |
|---|
| | | (trans-skala (let* ((grundton fundamental) |
|---|
| | | (tief (car total-range)) |
|---|
| | | (hoch (cadr total-range)) |
|---|
| | | (skala-up skala) |
|---|
| | | (skala-down (reverse skala-up)) |
|---|
| | | (endless-up (circular_oml skala-up)) |
|---|
| | | (endless-down (circular_oml skala-down)) |
|---|
| | | (skala-up (loop for i in endless-up |
|---|
| | | sum i into delta |
|---|
| | | until (> (+ delta grundton) hoch) |
|---|
| | | collect i)) |
|---|
| | | (skala-down (loop for i in endless-down |
|---|
| | | sum i into delta |
|---|
| | | until (< (- grundton delta) tief) |
|---|
| | | collect i)) |
|---|
| | | (transpositionsliste-up (list grundton)) |
|---|
| | | (transpositionsliste-down (list grundton))) |
|---|
| | | |
|---|
| | | (loop for i in skala-up |
|---|
| | | do (push (+ (car transpositionsliste-up) i) transpositionsliste-up)) |
|---|
| | | (loop for i in skala-down |
|---|
| | | do (push (- (car transpositionsliste-down) i) transpositionsliste-down)) |
|---|
| | | |
|---|
| | | (append (butlast transpositionsliste-down) (reverse transpositionsliste-up)) |
|---|
| | | )) |
|---|
| | | |
|---|
| | | (harmon-database (om::flat |
|---|
| | | (loop for pitch in trans-skala |
|---|
| | | collect |
|---|
| | | (loop for set in pitch-set-list |
|---|
| | | collect |
|---|
| | | (mapcar #'(lambda (l) (+ pitch l)) set))) 1)) |
|---|
| | | |
|---|
| | | (harmon-database (cond (permutations (om::flat (loop for l in harmon-database |
|---|
| | | collect (permutations_oml l)) 1)) |
|---|
| | | (t harmon-database))) |
|---|
| | | |
|---|
| | | |
|---|
| | | (harmon-database (remove-duplicates (om::flat (loop for a in harmon-database |
|---|
| | | collect |
|---|
| | | (loop for reg in (variations_oml register-list (length a)) |
|---|
| | | collect (mapcar #'(lambda (r p) (+ r p)) reg a))) 1) :test 'equal)) |
|---|
| | | (instr-list2 (remove nil (list instr1 instr2 instr3 instr4))) |
|---|
| | | (harmon-database (loop for a in harmon-database |
|---|
| | | collect (loop for p in a |
|---|
| | | for count to (1- (length instr-list2)) |
|---|
| | | |
|---|
| | | collect (if (or (< p (car (nth count instr-list2))) |
|---|
| | | (> p (cadr (nth count instr-list2)))) nil p)))) |
|---|
| | | (harmon-database (remove nil (loop for a in harmon-database |
|---|
| | | collect (if (> (count nil a) 0) nil a))))) |
|---|
| | | harmon-database)) |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
| | | (defun tester_oml (test list) |
|---|
| | | |
|---|
| | | (cond |
|---|
| | | ((null list) t) |
|---|
| | | ((funcall test (car list)) (tester_oml test (cdr list))) |
|---|
| | | (t nil) |
|---|
| | | |
|---|
| | | )) |
|---|
| | | |
|---|
| | | |
|---|
| | | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
|---|
| | | |
|---|
| | | |
|---|
| | | |
|---|
