;====================================== ;OM-Lead, 2022-2024 ; ;Library for Rule-based Voice-Leading ;Author: Lorenz Lehmann ;Supervision: Marlon Schumacher ;====================================== (in-package :omlead) ;;;;;;GEN-HARMONIES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (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))))))) (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) (cond ((null (cdr liste)) (if (atom (car 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)) (flat_oml (cdr liste)))) ((and (listp (car liste)) (listp (cadr liste))) (append (car liste) (flat_oml (cdr liste)))) ((and (not (listp (car liste))) (listp (cadr liste))) (append (list (car liste)) (flat_oml (cdr liste)))))) (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 variations_oml (liste pcl) (let* ((liste (remove-duplicates liste)) (liste (make-list pcl :initial-element liste))) (apply #'alexandria:map-product #'list liste))) (defun tester_oml (test list) (cond ((null list) t) ((funcall test (car list)) (tester_oml test (cdr list))) (t nil) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;