chore(sources): seperate utilities from defmethods

Lorenz Lehmann

30.12.23 a53ccfa7cc59f72f88c55df3a9b1e5583dd2f8b6

 sources/gen-harmonies.lisp

@@ -9,7 +9,7 @@
(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 nil) (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)))

:icon 030719972
:initvals '('((0)) '(6000 7200) nil nil nil)   
@@ -18,100 +18,7 @@
: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,106 @@
                                                          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
       (instr-list2  (list instr1 instr2 instr3 instr4))
       (harmon-database (remove -1 (loop for a in harmon-database
                              collect (loop for p in a
                                            for count to (1- (length instr-list2))
                                            for c to (1- (length instr-list2))

                                            collect (if (or (< p  (car (nth count instr-list2)))
                                                            (> p (cadr (nth count instr-list2)))) nil p))))
                                            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)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;end;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;