(in-package :omlead)
|
|
|
|
;;;;;;GEN-HARMONIES;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(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 counter
|
for i = (if (or (eq 'hold mode) (eq 'hold-mirror mode))
|
(hold-list negativ counter) (circular-list negativ counter)) ;;endless down-list
|
sum i into total
|
until (> range-min (- fundamental total))
|
collect (- fundamental total)
|
))
|
|
(list fundamental)
|
|
;;;;;;;;;;;;;;;;;;positiv
|
|
(loop for counter
|
for i = (if (or (eq 'hold mode) (eq 'hold-mirror mode))
|
(hold-list positiv counter) (circular-list positiv counter)) ;;endless up-list
|
sum i into total
|
until (< range-max (+ fundamental total))
|
collect (+ fundamental total)))))))
|
|
(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)
|
(remove nil (loop for filter-box in filter-harmonies
|
append (loop for rule in (second filter-box)
|
append (loop for harmony in harmonies
|
collect (if (tester_oml
|
(lambda (x) (and (<= (list-min_oml (third filter-box)) x) (>= (list-max_oml (third filter-box)) x)))
|
harmony)
|
(if (funcall rule (first filter-box) harmony) harmony) harmony)))))
|
|
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 sum_oml (liste &optional (start 0))
|
(cond ((null liste) start)
|
(t (sum_oml (cdr liste) (+ start (car liste))))))
|
|
|
|
|
|
(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)))))
|
|
|
|
|
|
(defun tester_oml (test list)
|
|
(cond
|
((null list) t)
|
((funcall test (car list)) (tester_oml test (cdr list)))
|
(t nil)
|
|
))
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(let ((a '(1)))
|
(delete 1 a))
|
|
