From 10cb19a83dbbfc61c6152d8325294bbb63166aba Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Sat, 30 Dec 2023 11:04:47 +0100
Subject: [PATCH] fix(sources): fix avoid-doublings
---
sources/gen-harmonies.lisp | 148 ++++++++++++++++++++++++++-----------------------
1 files changed, 78 insertions(+), 70 deletions(-)
diff --git a/sources/gen-harmonies.lisp b/sources/gen-harmonies.lisp
index d1ba81a..e04fab7 100644
--- a/sources/gen-harmonies.lisp
+++ b/sources/gen-harmonies.lisp
@@ -9,15 +9,84 @@
(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)))
+(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)) (avoid-doublings nil))
: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")
+: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" "if true all chords with the same note in two or more instruments will be avoided")
:numouts 1
:doc "creates a list of chords, that contains all possible transpositions & permutations of the given pitch-sets"
+
+(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))
+
+ (harmon-database (cond
+ (avoid-doublings (remove nil (loop for a in harmon-database
+ collect (if (not (find-dups_oml a)) a nil))))
+ (t harmon-database)
+ ))
+
+
+
+ (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))
+
+ 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))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun circular_oml (items)
@@ -66,14 +135,6 @@
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)
@@ -111,67 +172,14 @@
(liste (make-list pcl :initial-element liste)))
(apply #'alexandria:map-product #'list liste)))
+
+(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)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(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 (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))
-
- 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))
-
-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--
Gitblit v1.9.1