;====================================== ;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))) (defun find-area (value borders &key (start-index 0)) (cond ((null (second borders)) start-index) ((and (>= value (first borders)) (< value (second borders))) start-index) (t (find-area value (cdr borders) :start-index (1+ start-index))))) (defun filter-rests (liste) (cond ((null liste) nil) (t (append (if (>= (car liste) 0) (list (car liste)) nil) (filter-rests (cdr liste))))))