From 3aae4ab2c334a2df7772480e74950b15758904cd Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Thu, 28 Mar 2024 22:51:02 +0100
Subject: [PATCH] fix(source): fix voice-range in gen-harmonies
---
sources/gen-harmonies.lisp | 339 ++++++++++++++++++++++++++++++++++++++++++++------------
1 files changed, 265 insertions(+), 74 deletions(-)
diff --git a/sources/gen-harmonies.lisp b/sources/gen-harmonies.lisp
index 8b1a64e..6ced843 100644
--- a/sources/gen-harmonies.lisp
+++ b/sources/gen-harmonies.lisp
@@ -1,89 +1,246 @@
-;======================================
-;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 (avoid-empty-voices nil) (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))))
-(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)))
+;++++++++++++++++ adapt-collection-to-voice-ranges ++++++++++++++++++++++++++++++++++++++++++++++++++++
- (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 (list instr1 instr2 instr3 instr4))
- (harmon-database (remove -1 (loop for a in harmon-database
- collect (loop for p in a
- for c to (1- (length instr-list2))
+ (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))))
- collect (if (nth c instr-list2) (if (or (< p (car (nth c instr-list2)))
- (> p (cadr (nth c instr-list2)))) nil p) -1)) )))
- (harmon-database (remove nil (loop for a in harmon-database
- collect (if (> (count nil a) 0) nil a))))
- (harmon-database (if avoid-empty-voices (mapcar (lambda (x) (remove -1 x)) harmon-database) harmon-database)))
-harmon-database))
+;++++++++++++++++ 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 (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))))
+
+;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
+
+)
+
+
+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)
(cond
@@ -92,11 +249,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))
@@ -110,16 +265,23 @@
(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))))
@@ -134,6 +296,9 @@
(butlast liste (- (length liste) pos))))
+
+
+
(defun register-permut_oml (register-list)
(remove-duplicates
(om::flat
@@ -146,10 +311,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)
@@ -158,16 +327,38 @@
(+ (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)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
+
+(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)
+
+))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+
+
\ No newline at end of file
--
Gitblit v1.9.1