SymProg/OM-Lead.git

			@@ -1,28 +1,241 @@
			;======================================
			;OM-Lead, 2022-2023
			;
			;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 counter
			for i = (if (or (eq 'hold mode) (eq 'hold-mirror mode))
			(hold-list negativ counter) (circular-list negativ counter)) ;;endless down-list
			sum i into total
			until (> range-min (- fundamental total))
			collect (- fundamental total)
			))

			(list fundamental)

			;;;;;;;;;;;;;;;;;;positiv

			(loop for counter
			for i = (if (or (eq 'hold mode) (eq 'hold-mirror mode))
			(hold-list positiv counter) (circular-list positiv counter)) ;;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)
			(remove nil (loop for filter-box in filter-harmonies
			append (loop for rule in (second filter-box)
			append (loop for harmony in harmonies
			collect (if (tester_oml
			(lambda (x) (and (<= (list-min_oml (third filter-box)) x) (>= (list-max_oml (third filter-box)) x)))
			harmony)
			(if (funcall rule (first filter-box) harmony) harmony) harmony)))))

			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 sum_oml (liste &optional (start 0))
			(cond ((null liste) start)
			(t (sum_oml (cdr liste) (+ start (car liste))))))





			(defun circular_oml (items)
			(setf (cdr (last items)) items)
			items)





			(defun flat_oml (liste)
			@@ -32,11 +245,9 @@
			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))
			@@ -50,29 +261,28 @@
			(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))

			))



			@@ -80,6 +290,9 @@
			(append
			(nthcdr pos liste)
			(butlast liste (- (length liste) pos))))





			(defun register-permut_oml (register-list)
			@@ -94,10 +307,14 @@
			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)
			@@ -106,74 +323,41 @@
			(+ (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 find-dups_oml (lst)
			(cond ((null lst) '())
			((member (car lst) (cdr lst)) (cons (car lst) (find-dups_oml (cdr lst))))
			(t (find-dups_oml (cdr lst)))))





			(defun tester_oml (test list)

			(cond
			((null list) t)
			((funcall test (car list)) (tester_oml test (cdr list)))
			(t nil)

			))


			;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;




			(let ((a '(1)))
			(delete 1 a))