From d593dc211d019f10df8c7bd9069b4134c8d399b8 Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Wed, 27 Mar 2024 22:53:12 +0100
Subject: [PATCH] feat(source)!: restructure gen-sequence
---
sources/gen-harmonies.lisp | 346 +++++++++++++++++++++++++++++++++++++++------------------
1 files changed, 238 insertions(+), 108 deletions(-)
diff --git a/sources/gen-harmonies.lisp b/sources/gen-harmonies.lisp
index 869a5d7..7308bc5 100644
--- a/sources/gen-harmonies.lisp
+++ b/sources/gen-harmonies.lisp
@@ -1,28 +1,246 @@
+
;======================================
-;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 t) (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)
@@ -32,11 +250,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,130 +266,44 @@
(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)
+
+))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--
Gitblit v1.9.1