From 814320124e67ff42cac90084bc873b5c594754b5 Mon Sep 17 00:00:00 2001
From: Lorenz Lehmann <lorenz.lehmann@students.muho-mannheim.de>
Date: Mon, 12 Feb 2024 07:36:52 +0100
Subject: [PATCH] fix (sources): rule lists have the correct length
---
sources/gen-harmonies.lisp | 213 +++++++++++++++++++++++++++-------------------------
1 files changed, 111 insertions(+), 102 deletions(-)
diff --git a/sources/gen-harmonies.lisp b/sources/gen-harmonies.lisp
index 869a5d7..e04fab7 100644
--- a/sources/gen-harmonies.lisp
+++ b/sources/gen-harmonies.lisp
@@ -9,109 +9,16 @@
(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)))
+(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"
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defun circular_oml (items)
-(setf (cdr (last items)) items)
-items)
-
-
-(defun flat_oml (liste)
- (cond
- ((null (cdr liste))
- (if (atom (car liste))
- 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))
- (flat_oml (cdr liste))))
-
- ((and (listp (car liste)) (listp (cadr liste)))
- (append (car liste)
- (flat_oml (cdr liste))))
-
- ((and (not (listp (car liste))) (listp (cadr liste)))
- (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))) '<))
@@ -158,19 +65,121 @@
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 (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)))))
+ 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)
+(setf (cdr (last items)) items)
+items)
+
+
+(defun flat_oml (liste)
+ (cond
+ ((null (cdr liste))
+ (if (atom (car liste))
+ 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))
+ (flat_oml (cdr liste))))
+
+ ((and (listp (car liste)) (listp (cadr liste)))
+ (append (car liste)
+ (flat_oml (cdr liste))))
+
+ ((and (not (listp (car liste))) (listp (cadr liste)))
+ (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 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)))
+
+
+(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)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--
Gitblit v1.9.1