From c38e61a5cdef40363917766213f707ada93d765b Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Wed, 20 Mar 2024 18:37:13 +0100
Subject: [PATCH] feat(source)!: restructure gen-harmonies
---
sources/gen-sequence.lisp | 36 ++++++++++++++++++++++++------------
1 files changed, 24 insertions(+), 12 deletions(-)
diff --git a/sources/gen-sequence.lisp b/sources/gen-sequence.lisp
index 716a59b..d8424ff 100644
--- a/sources/gen-sequence.lisp
+++ b/sources/gen-sequence.lisp
@@ -156,22 +156,34 @@
collect
- (let* ((second (nconc (list first-harmony) external-list))
+ (let* ((second (append (list first-harmony) (reverse external-list)))
(first (car (last second)));6000 6700
(second (let* ((temp-base database)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- (temp-base (cond (avoid-repetitions (let ((looplist
- (remove nil (loop for a in temp-base
- collect (if
- (car
- (remove nil
- (mapcar #'(lambda (l) (eq (car l) (cadr l)))
- (mat-trans_oml (list first a))))) nil a)))))
-
- (if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)))
- (t temp-base)))
+ (temp-base (cond (avoid-repetitions
+ (let* ((tie-list (mapcar '1- (remove nil (list voice-tie1 voice-tie2 voice-tie3 voice-tie4))))
+ (sub-list (cond
+ (tie-list (flat_oml (mapcar #'(lambda (l) (subs-posn_oml (loop repeat (length first) collect -2) l -1)) tie-list)))
+ (t '(-2 -2 -2 -2))))
+
+
+ (looplist
+ (remove nil (loop for a in temp-base
+ collect (let ((harmony
+ (remove nil (loop for i in sub-list
+ for n1 in first
+ for n2 in a
+ collect (if (cond ((eq i -1) (eq n1 n2))
+ (t (not (eq n1 n2))))
+
+ n2)))))
+
+ (if (eq (length first) (length harmony)) harmony))))))
+
+ (if (null looplist) (list (loop repeat (length (first temp-base)) collect -1)) looplist)))
+ (t temp-base)))
(temp-base (cond (voice-tie1
@@ -671,7 +683,7 @@
- (nreverse (push second external-list))
+ (push second external-list)
(values second))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--
Gitblit v1.9.1