;======================================
;OM-Lead, 2022-2023
;
;Library for Rule-based Voice-Leading
;Author: Lorenz Lehmann
;Supervision: Marlon Schumacher
;======================================

(in-package :omlead)

;;;harmon-database

;keine globalen Variablen mehr

(om::defmethod! harmon-database (pitch-set-list instr1 &key instr2 instr3 instr4 (fundamental 6000) (skala (list 100)) (permutations t) (register-list '(0)))

:icon 030719972
: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")

: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))) '<))
       (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))
       (instr-list2  (remove nil (list instr1 instr2 instr3 instr4)))
       (harmon-database (loop for a in harmon-database
                              collect (loop for p in a
                                            for count to (1- (length instr-list2))

                                            collect (if (or (< p  (car (nth count instr-list2)))
                                                            (> p (cadr (nth count instr-list2)))) nil p))))
       (harmon-database (remove nil (loop for a in harmon-database
                                          collect (if (> (count nil a) 0) nil a)))))
harmon-database))