;======================================
|
;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)) (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" "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 '((1 2 3 4) (6 6 7 7) (8 8 8 8) (2 3 4 1))
|
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)
|
(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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
