;======================================
|
;OM-Lead, 2022-2023
|
;
|
;Library for Rule-based Voice-Leading
|
;Author: Lorenz Lehmann
|
;Supervision: Marlon Schumacher
|
;======================================
|
|
|
|
|
(in-package :omlead)
|
|
(om::defmethod! gen-sequence (harmonies first-harmony number-of-harmonies error-out single-voice-progress voice-pair-progress)
|
|
:icon 030719979
|
|
:numouts 1
|
|
|
|
(let ((external-list (list first-harmony))
|
(harmonies (if (atom (caar harmonies)) (list (list harmonies) 'hold) harmonies))
|
(error-out (if (or (find 'hold error-out) (find 'circular error-out)) error-out (list (list error-out) 'hold)))
|
(single-voice-progress (cond ((null single-voice-progress) nil)
|
((atom (caar single-voice-progress)) (list single-voice-progress))
|
(t single-voice-progress)))
|
(voice-pair-progress (cond ((null voice-pair-progress) nil)
|
((atom (caaar voice-pair-progress)) (list voice-pair-progress))
|
(t voice-pair-progress))))
|
|
|
|
(loop for counter to (- number-of-harmonies 2)
|
do (let* ((first (car external-list))
|
(temp-harmonies (cond ((eq 'circular (car (last harmonies))) (circular-list (car harmonies) counter))
|
(t (hold-list (car harmonies) counter))))
|
(temp-error (cond ((eq 'circular (car (last error-out))) (circular-list (car error-out) counter))
|
(t (hold-list (car error-out) counter))))
|
(temp-harmonies (if single-voice-progress (remove nil (loop for voice-box in single-voice-progress
|
append (loop for second in temp-harmonies
|
collect (if (funcall (if (eq 'circular (third voice-box))
|
(circular-list (second voice-box) counter)
|
(hold-list (second voice-box) counter))
|
(first voice-box) first second) second) )) ) temp-harmonies))
|
(temp-harmonies (if voice-pair-progress (remove nil (loop for pair-box in voice-pair-progress
|
append (loop for second in temp-harmonies
|
collect (if (funcall (if (eq 'circular (third pair-box))
|
(circular-list (second pair-box) counter)
|
(hold-list (second pair-box) counter))
|
(first pair-box) first second) second) )) ) temp-harmonies )))
|
|
|
|
(if (null temp-harmonies)
|
(push temp-error external-list) (push (nth-random temp-harmonies) external-list))))
|
|
(reverse external-list)))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;apply-boxes;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(om::defmethod! single-voice-progress (ids rules (mode symbol))
|
:icon 0307199710
|
:initvals '(nil nil 'circular)
|
:menuins '((2 (("circular" 'circular) ("hold" 'hold))))
|
(list (list! ids)
|
(list! rules)
|
mode))
|
|
(om::defmethod! voice-pair-progress (ids rules (mode symbol))
|
:icon 0307199712
|
:initvals '(nil nil 'circular)
|
:menuins '((2 (("circular" 'circular) ("hold" 'hold))))
|
(list (if (atom (car ids)) (list ids) ids)
|
(list! rules)
|
mode))
|
|
(om::defmethod! choose-error-out (error-value (mode symbol))
|
:icon 0307199715
|
:initvals '(nil 'hold)
|
:menuins '((1 (("circular" 'circular) ("hold" 'hold))))
|
(list (if (atom (car error-value)) (list error-value) error-value) mode))
|
|
(om::defmethod! choose-harmonies (harmonies (mode symbol))
|
:icon 0307199715
|
:initvals '(nil 'hold)
|
:menuins '((1 (("circular" 'circular) ("hold" 'hold))))
|
(list (if (atom (car harmonies)) (list harmonies) harmonies) mode))
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;svp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(om::defmethod! avoid-interval (voice first second)
|
:icon 0307199711
|
(cond ((or (equal (nth voice first) choose-error-out) (equal (nth voice second) choose-error-out)) t)
|
((equal (nth voice first) (nth voice second)) nil)
|
(t t)))
|
|
|
|
|
|
|
(om::defmethod! voice-interval (ids first second intervals (mode symbol))
|
:icon 0307199711
|
:menuins '((4 (("only" 'only) ("except" 'except))))
|
|
(if (eq mode 'only) (tester_oml
|
(lambda (y) (find y intervals))
|
(mapcar (lambda (x) (nth x (mapcar '- second first))) ids))
|
(tester_oml
|
(lambda (y) (not (find y intervals)))
|
(mapcar (lambda (x) (nth x (mapcar '- second first))) ids))))
|
|
|
|
|
|
|
|
|
(defun find_oml (item liste &optional (start 0))
|
|
(cond ((null liste) start)
|
((eq (car liste) item) (find_oml item (cdr liste) (1+ start)))
|
(t (find_oml item (cdr liste) start))))
|
|
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;vpp-rules;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
(om::defmethod! oblique-motion (ids first second)
|
:icon 0307199713
|
(tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
|
collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
|
voice-pair)))
|
|
(and (condition_oml (lambda (x) (= x 0)) deltas)
|
(condition_oml (lambda (x) (/= x 0)) deltas))))))
|
|
|
(om::defmethod! contrary-motion (ids first second)
|
:icon 0307199713
|
(tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
|
collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
|
voice-pair)))
|
|
(eq (condition_oml (lambda (x) (> x 0)) deltas)
|
(condition_oml (lambda (x) (< x 0)) deltas))))))
|
|
|
|
(om::defmethod! similar-motion (ids first second)
|
:icon 0307199713
|
(tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
|
collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
|
voice-pair)))
|
|
(or (tester_oml (lambda (x) (> x 0)) deltas)
|
(tester_oml (lambda (x) (< x 0)) deltas))))))
|
|
(om::defmethod! parallel-motion (ids first second)
|
:icon 0307199713
|
(tester_oml (lambda (x) (eq t x)) (loop for voice-pair in ids
|
collect (let ((deltas (mapcar (lambda (x) (nth x (mapcar '- second first)))
|
voice-pair)))
|
(reduce '= deltas)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;;;;;;;;;;;;end ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;Hilfsfunktionen;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(defun condition_oml (test liste)
|
(cond ((null liste) nil)
|
((funcall test (car liste)) t)
|
(t (condition_oml test (cdr liste)))
|
))
|
|
(defun list! (item)
|
(cond ((atom item) (list item))
|
(t item)))
|
|
|
(defun apply-rule_oml (harmonies rule first choose-error-out)
|
(let ((database harmonies))
|
|
(loop for function in rule
|
do (loop for harmony in database
|
do (if (funcall (cadr function) (car function) first harmony choose-error-out) nil (setf database (delete harmony database)))))
|
|
(if (null database) choose-error-out
|
(nth (random (length database)) database))))
|
|
(defun hold_oml (items)
|
(append (butlast items) (setf (cdr (last items)) (last items))))
|
|
|
(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 my-recursive-fun (dur-list minimum divisor-list)
|
|
(let ((divisor (om::nth-random (car divisor-list))))
|
(cond
|
((null dur-list) dur-list)
|
((>= (/ (car dur-list) divisor) minimum)
|
|
(append (my-recursive-fun (om::repeat-n (/ (car dur-list) divisor) divisor) minimum (om::repeat-n (car divisor-list) divisor))
|
(my-recursive-fun (cdr dur-list) minimum (cdr divisor-list))))
|
(t (append (list (car dur-list)) (my-recursive-fun (cdr dur-list) minimum (cdr divisor-list)))))))
|
|
|
|
(defun posn-match_oml (list positions)
|
(cond ((null positions) '())
|
((atom positions) (nth positions list))
|
(t (append (list (posn-match_oml list (car positions)))
|
(if (posn-match_oml list (cdr positions))
|
(posn-match_oml list (cdr positions))
|
'())))))
|
|
|
(defun subs-posn_oml (list position item)
|
(loop for a from 0
|
for b in list
|
collect (if (= a position) item b)))
|
|
|
(defun subs-posn (lis1 posn val)
|
|
(let ((copy (copy-list lis1)))
|
(if (listp posn)
|
(loop for item in posn
|
for i = 0 then (+ i 1) do
|
(setf (nth item copy) (if (listp val) (nth i val) val)))
|
(setf (nth posn copy) val))
|
copy))
|
|
|
(defun oml- (list atom)
|
(mapcar (lambda (it) (- it atom)) list))
|
|
|
(defun find-dups_oml (liste)
|
(car
|
(remove nil
|
(mapcar #'(lambda (l c) (eq l c)) liste (cdr liste)))))
|
|
(defun nth-random (list)
|
(nth (random (length list)) list))
|
|
|
|
(defun circular-list (liste counter &key (start 0))
|
|
(cond
|
((= counter 0) (nth start liste))
|
((< start (1- (length liste))) (circular-list liste (1- counter) :start (1+ start)))
|
(t (circular-list liste (1- counter) :start 0))))
|
|
|
|
(defun hold-list (liste counter)
|
(if (> counter (1- (length liste)))
|
(car (last liste))
|
(nth counter liste)))
|
