;======================================
;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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;