SymProg/OM-Lead.git

			@@ -9,109 +9,16 @@
			(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)) (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")
			: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"
			;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

			(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,121 @@
			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 (cond
			(avoid-doublings (remove nil (loop for a in harmon-database
			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)))))
			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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;