;; NUDRUZ.LISP
;; utilities etc. for working with Common Music

;; Drew Krause, 2004
;; drkrause@mindspring.com
;; www.wordecho.org

;; include cllib, screamer etc. -- see file
(load "cminit.lisp")


(in-package :cm)
;; first, some needed basic stuff

;; FLATTEN -- removes all nesting in list
;; "thank you Paul Graham!"
(defun flatten (x)
  (labels ((rec (x acc)
             (cond ((null x) acc)
                   ((atom x) (cons x acc))
                   (t (rec (car x) (rec (cdr x) acc))))))
    (rec x nil)))

;; FLATTER -- removes one level of tree (preserves sublists)
(defun flatter (alist)
  (loop for a in alist append a))

;; LIKE-FLAT -- converts all 1-lists to atoms; leaves the rest alone
;; August 2006
(defun like-flat (alist)
  (mapcar (lambda (x) (if (and (listp x) (eql 1 (length x))) 
			  (car x)
			  x))
	  alist))

;; NOT-FLAT -- makes everything into a list; leaves lists alone
;; (not-flat '(2 4 (3 4) 2 (2 1 4))) = ((2) (4) (3 4) (2) (2 1 4))
;; removing rests in chords (May 2007) 
(defun not-flat (alist)
  (mapcar (lambda (x) (if (listp x) (norests x) (list x)))
	  alist))

;; DEEPFUNC -- applies function across all members of a tree
;; added June 2007
(defun deepfunc (func alist)
  (if (> (apply #'max (take-poly alist)) 1)
      (mapcar (lambda (x) (deepfunc func x)) (not-flat alist))
      (mapcar func alist)))

;; ARRAY->LIST -- converts array to list (of lists)
(defun array->list (ary)
  (loop for x to (- (nth 0 (array-dimensions ary)) 1)
        collect
        (loop for y to (- (nth 1 (array-dimensions ary)) 1)
              collect (aref ary x y))))

;; VEC->LIST -- converts simple vector to a list
;; added July 2005
(defun vec->list (avec)
    (loop for x to (- (array-total-size avec) 1) collect
          (svref avec x)))

;; CONVERT-INTO-PATT -- make everything into a pattern (for velocity)
(defun convert-into-patt (avalue)
  (if (pattern? avalue) avalue
      (makecyc 
      (if (listp avalue) avalue (list avalue)))))

;; CONVERT-INTO-RANDPATT -- make everything into a nonrepeating 'weighting' 
(defun convert-into-randpatt (avalue)
  (if (pattern? avalue) avalue
      (new weighting :of 
	   (norpt-rand (if (listp avalue) avalue (list avalue))))))

;;; LIST-EQL: whether two lists have equal contents, irrespective of order
;; (list-eql '(1 2 3) '(1 3 2)) = T
(defun list-eql (list1 list2)
  (and (subsetp list1 list2) 
       (subsetp list2 list1)
       (= (length list1) (length list2))))

;; SEQ-EQL: whether two lists are identical
;; (seq-eql '(1 2 3) '(1 3 2)) = nil
;; (seq-eql '(1 2) '(1 2)) = T
(defun seq-eql (list1 list2)
  (not (mismatch list1 list2)))

;; NOT-MEL -- slotwise melodic complement
;; returns slots of 'bigmel' that don't include 'smallmel'
;; (not-mel '(0 1 (2 5) 3 (4 6)) (indices 5)) = (R R (5) R (6))
(defun not-mel (bigmel smallmel)
  (map 'list
       (lambda (a b)
	 (let ((ndiff (set-difference a b)))
	   (if ndiff ndiff 'r)))
       (not-flat bigmel)
       (not-flat smallmel)))

;; TRANSPOSE-MATX -- simple matrix transposition
; (transpose-matx '((1 2 3) (4 5 6))) = ((1 4) (2 5) (3 6))
(defun transpose-matx (matx)
  (loop for n to (- (length (car matx)) 1) collect
	(mapcar (lambda (x) (nth n x)) matx)))

;; IS-PALINDROME: tests a list
;; (is-palindrome '(1 2 3 2 1)) = T
(defun is-palindrome (alist)
  (seq-eql alist (reverse alist)))

;; SAFESORT -- non-destructive sort
(defun safesort (a-list)
  (let ((templist (loop for a in a-list collect a)))
    (sort templist #'<)))

;; SORT-EVERY -- sort every entry in a list of lists
(defun sort-every (alist)
  (loop for x in alist collect
        (cond ((listp x) (safesort x))
              (t x))))

;; NO-NILS -- removes all instances of 'nil from a list
;; fixed 'reverse' bug April 2006
(defun no-nils (a-list)
  (reverse
   (set-difference a-list '(nil))))

;; NORESTS -- removes rests
(defun norests (alist)
   (no-nils (loop for x in alist collect
                  (if (not (eql x 'r)) x))))

; SUM -- add all in list
(defun sum (x)
  (apply #'+ x))

;; PRIME-FACTORS -- nonrepeating list of all prime factors
(defun prime-factors (n)
  (rsm.mod:factors n))

;; MULTIEVENT -- LETS YOU WRITE OUT POLYPHONY
(defun multievent (class arg &rest args)
  (let ((vals (getf args arg)))
    (if (listp vals)
      (loop for k in vals
            collect
            (apply #'make-instance class arg k args))
      (apply #'make-instance class arg vals args))))

;; multievent example
;(define multithing
;  (process repeat 20
;        output (multievent 'midi :keynum
;                             :keynum (next pcycle)
;                             :time (now)
;                             :duration 1)
;        wait 1))

;; MIDI-IN -- creates (pits durs) two-element list of lists from midifile
;; note: gives same duration to simultaneous atx (legato to next atk)
(defun midi-in (midifile)
  (let ((mytracks (import-events midifile :meta-exclude t))
        (pits '())
        (starts '()))
    (map-objects #'(lambda (x) (push x pits)) mytracks 
                 :slot 'keynum :class 'midi)
    (map-objects #'(lambda (x) (push x starts)) mytracks 
                 :slot 'time :class 'midi)
    (list 
     (first (combine-pits (nreverse pits) (reverse starts)))
     (append    
      (melint (reverse (remove-duplicates starts))) (list 1.0)))))

;; MIDI-TOTALEN -- midifile length in minutes 
(defun midi-totalen (mfile)
  (round
   (/ 
    (apply #'+ (second (midi-in mfile)))
    60)))

;; PLAYMIDS -- combine midi files
(defun playmids (&rest names)
  (loop for nam in names collect
	(splay (first (midi-in nam)) (second (midi-in nam)))))

;; CSOUND -- defining basic event
(defobject i1 (i)
  (amp
   freq)
  (:parameters time dur amp freq))

;; SIMPL4SCO -- generic playback routine
(define (simpl4sco pits durs atkpts)
  (process for x in pits
           for dur in durs
           for atk in atkpts
           when (or (numberp x) (listp x))
           output (multievent 'i1 :freq
                              :freq (hertz x)
                              :time (float atk)
                              :amp (between .15 .2)
                              :dur (float dur))))

;; MULTIPLE-ASSOC -- utility for 'combine-pits'
;; Bob Coyne contributes:
(defun multiple-assoc (thing alist)
  (loop for i in alist
        when (eql (first i) thing)
        append (cdr i)))

;; COMBINE-PITS -- coalesce polyphony into sublists & sort timepoints
;; (combine-pits '(10 20 30 40 50 60) '(6 2 3 2 1 2))
;; = ((50 (20 40 60) 30 10) (1 2 3 6))
(defun combine-pits (pitlist tplist)
  (let* ((combo-list (loop for tp in tplist
                           for val in pitlist
                           collect (list tp val)))
         (processed-list 
          (sort (loop for i in (remove-duplicates tplist)
                      collect (cons i (multiple-assoc i combo-list)))
                #'< :key #'first)))
    (list (mapcar #'(lambda (list) 
                      (if (= (length list) 2)
                        (second list) (rest list)))
                  processed-list)
          (mapcar #'first processed-list))))

;;; general combinatorics

;; PROPER-SUBSETS
;; power set of a list, minus trivial (empty & complete) sets
(defun proper-subsets (a-list)
    (butlast 
     (set-difference (cllib:subsets a-list) (list a-list 'nil))))

;; SUBSETS-LEN
;; all subsets of specified size
;; (subsets-len '(1 2 3 4) 2) = ((3 4) (2 4) (2 3) (1 4) (1 3) (1 2))
;; now takes lists of lengths [Nov. 2005]
(defun subsets-len (a-list len)
  (if (numberp len)
      (set-difference
       (mapcar (lambda (x) (if (= (length x) len) x)) 
               (cllib:subsets (remove-duplicates a-list)))
       (list 'nil))
      (loop while len append (subsets-len a-list (pop len)))))

;; SUBSEQUENCES -- returns list of 
;; all subsequences with length 'subseqlen' 
;; (subsequences '(1 2 3 4) 2) = ((1 2) (2 3) (3 4))
;; now takes lists of lengths [Nov. 2005]
(defun subsequences (a-list subseqlen)
  (if (numberp subseqlen) 
      (if (< subseqlen (length a-list))
          (loop for n to (- (length a-list) subseqlen)
                collect 
                (loop for y from n to (+ n (- subseqlen 1))
                      collect (nth y a-list)))
          a-list)
      (loop while subseqlen append (subsequences a-list (pop subseqlen)))))

;; ALL-SUBSEQUENCES
;; returns list of all but trivial (complete & atomic) subsequences 
(defun all-subsequences (a-list)
  (loop for n from 2 to (- (length a-list) 1)
        append (subsequences a-list n)))

;; PERMUTATIONS --  returns all permutations of a list
(defun permutations (a-list)
  (loop for x in 
        (cllib:permutations-list (make-array (length a-list) 
                                             :initial-contents a-list))
        collect (coerce x 'list)))

;; PERMUTELIST -- permutes a-list by 'aperm' list of indices
;; ;; (permutelist '(3 1 2 0) '(7 8 9 10)) = (10 8 9 7)
(defun permutelist (aperm amel)
  (map 'list (lambda (x) (nth x amel)) aperm))

;; ROTATE-LIST -- rotates list by "factor"
(defun rotate-list  (alist &optional (factor 1))
  (append (subseq alist factor (length alist))
	  (subseq alist 0 factor)))

;; ALLROTS -- returns list of all rotations of list
;; (allrots '(58 60 54)) = ((58 60 54) (60 54 58) (54 58 60))
(defun allrots (alist)
  (let ((listrot (new rotation of alist)))
    (loop repeat (length alist) collect (next listrot t))))

;; HOLES -- gaps in list of integers
(defun holes (alist)
  (no-nils
  (loop for x from (reduce #'min alist) to (reduce #'max alist) collect
        (if (not (member x alist)) x))))

;; serial list utilities

;; LISTINV -- inverse of a list, by sort order
(defun listinv (a-list)
  (let ((slist (safesort a-list)))
    (loop for x in a-list collect
          (nth (- (- (length slist) 1) (position x slist)) slist))))

;; ALLROWS-BYTYPE -- returns list of inverted transformed lists
;; trtype can be 'p, 'i, 'r, or 'ri
;; 'transposes' elements by sorted level (with wraparound)
;; returns list of lists
;; note: inversion is a peculiar (rotational) application
;; use 'invert' for classical inversion function
(defun allrows-bytype (a-list trtype)
  (let ((slist (safesort (remove-duplicates a-list))))
    (loop for y to (- (length slist) 1) collect
          (loop for x in 
                (case trtype 
                  (p a-list)
                  (i (listinv a-list))
                  (r (reverse a-list))
                  (ri (reverse (listinv a-list))))
                collect 
                (nth (mod (+ y (position x slist)) (length slist)) slist)))))

;; ROWPERMS-BYTYPE -- list 'boulez-style' permutations of a list 
;; (list of lists)
;; returning indices of original list
(defun rowperms-bytype (a-list trtype)
  (loop for tlist in (allrow-bytype a-list trtype) collect
        (loop for y in tlist collect (position y a-list)))) 

;; ALLROWS -- returns shuffled no-dupe list of all (p,i,r,ri) transforms
(defun allrows (a-list)
  (shuffle
   (remove-duplicates
    (loop for x in '(p i ri r) append 
          (allrows-bytype a-list x))
    :test (lambda (x y) (not (mismatch x y))))))

;; ALLROWPERMS -- returns shuffled no-dupe list of all (p,i,r,ri) permutations
;; returning indices of original list
(defun allrowperms (a-list)
  (shuffle
   (remove-duplicates
    (loop for x in '(p i ri r) append 
          (rowperms-bytype a-list x))
    :test (lambda (x y) (not (mismatch x y))))))

;; APPLY-PERM -- apply position-ordered permutation
;; (apply-perm '(1 3 0 2 0) '(35 51 2 .5)) =  (51 0.5 35 2 35)
(defun apply-perm (permlist a-list)
  (loop for x in permlist collect (nth x a-list)))

;; texture stuff

;; MAKE-POLY -- distributes line according to texture vector
;; (make-poly '(1 2 3 4 5 6) '(1 0 2)) = ((1) (R) (2 3) (4) (R) (5 6))
;; changed June 2005
;; Nov. 2005: added 0->R functionality
;; Aug. 2006: using 'likeflat' for better output
(defun make-poly (mel texture)
  (like-flat
   (let ((txtcyc (new cycle of texture)))
     (loop while mel 
       collect (no-nils 
		(let ((nxt-txt (next txtcyc)))
		  (if (eql nxt-txt 0) (list 'r)
		      (loop repeat nxt-txt collect (pop mel)))))))))

;; TAKE-POLY -- gives length of each event in list
;; (take-poly '((55 4 6) 2 (R) 43 (2 1) 23)) =  (3 1 0 1 2 1)
;; Nov. 2005: added R->0 functionality
(defun take-poly (a-list)
  (loop for x in a-list collect
        (cond ((or (eql x 'r) (and (listp x) (member 'r x))) 0)
              ((numberp x) 1)
              (t (length x)))))

; MERGE-POLY -- use poly vector to merge melodies [Aug. 2006]
;; 'mels' is a list of lists [melodies]
(defun merge-poly (mels texture)
  (like-flat
   (let ((melcycs (mapcar (lambda (x) (makecyc x)) mels))
	 (txtcyc (new cycle of texture)))
     (loop until (some #'eop? melcycs) 
       collect (no-nils 
		(let ((nxt-txt (next txtcyc)))
		  (if (eql nxt-txt 0) (list 'r)
		      (loop for n in (indices nxt-txt) collect 
			    (next (nth n melcycs))))))))))

;; MOD12 -- returns number or list, mod 12 [old function]
;; (mod12 '(23 36)) = (11 0)
(defun mod12 (input)
  (cond ((eql input 'r) 'r)
        ((numberp input) (mod input 12))
	(t (mapcar #'mod12 input))))

;; MODLIST -- returns number or list, mod N [preferred]
(defun modlist (input &optional (modlen 12))
  (cond ((eql input 'r) 'r)
        ((numberp input) (mod input modlen))
	(t (mapcar #'(lambda (x) (modlist x modlen)) input))))

;;INTV -- interval between two notes (simple difference)
;; can be positive or negative
;; (intv 11 17) = 6
(defun intv (x y)
	(- y x))

;;ABS-INTV -- absolute mod-x difference between 2 notes
;; (abs-intv 20 4) = 4
(defun abs-intv (x y &optional (modlen 12))
	(mod (abs (- y x)) modlen))

;;MOD-INTV -- *closest* mod-x difference between 2 notes
;; (mod-intv 11 0) = 1
(defun mod-intv (x y &optional (ordflag nil) (modlen 12))
  (let ((x-near-y (car (matchreg (list x) (list y) ordflag modlen))))
    (min (mod (- y x-near-y) modlen)
         (mod (- x-near-y y) modlen))))

;; moved from tonnetz.lisp
;; INVERSE-IDX = 1 if a transposition, -1 if an inversion
;; (inverse-idx '(2 9 6)) = -1
(defun inverse-idx (a-chd &optional (modlen 12))
  (let* ((mulprim (multiple-value-list (prime-form a-chd)))
	 (pform (car mulprim))
	 (tlevel (cadr mulprim))
         (transp-p (transp pform tlevel))
         (mmsorted (safesort (modmult transp-p 1 modlen))))
    (if (find-if 
         (lambda (x) (equal x mmsorted))
         (permutations (modmult a-chd 1 modlen)))
      1 -1)))

;; TRANSPLEVEL -- transposition level (unique) of a chord relative to its prime-form 
(defun transplevel (a-chord)
  (second
   (multiple-value-list
       (prime-form a-chord))))

;; INVERT-CHD -- pc-set inversion of a chord
;; (invert-chd '(0 2 5)) = (0 3 5)
(defun invert-chd (chd)
  (let* ((mi (melint chd))
         (imi (reverse mi)))
    (melint->line (first chd) imi)))

;; NORMAL-FORM of a chord
(defun normal-form (chd)
  (let* ((pf (multiple-value-list (prime-form chd)))
         (primeform (first pf))
         (tlevel (second pf))
         (inv-idx (inverse-idx chd)))
    (if (eql inv-idx 1) 
        (mod12 (transp-to tlevel primeform))
        (mod12 (transp-to tlevel (invert-chd primeform))))))

;; TN-TYPE of a chord
(defun tn-type (chd)
  (let* ((pf (multiple-value-list (prime-form chd)))
         (primeform (first pf))
         (inv-idx (inverse-idx chd)))
    (if (eql inv-idx 1) 
        (mod12 primeform)
        (mod12 (invert-chd primeform)))))

;; SIS -- step-inverval series of a chord
;; (sis '(3 7 10)) = (3 4 5)
;; generalized to any size chord, Apr. 2007 
(defun sis (a-chd &optional (modlen 12))
  (let* ((pform (prime-form a-chd))
	 (apform (append pform
			 (list (+ (car pform) modlen)))))
    (mapcar (lambda (x) (mod x modlen))
	    (melint apform))))

;;; OIS -- ordered pitch-class intervallic structure
;; from Heinemann diss. (1993)
(defun ois (chd)
  (cond ((listp chd) (loop for x in chd collect (- x (first chd))))
         ((numberp chd) (list 0))))

;; BZMULT-SIMPLE -- non-commutative simple multiplication
;; returns rest if either input is a rest
(defun bzmult-simple (chd1 chd2)
  (let* ((ois1 (if (listp chd1) (ois (safesort chd1)) (ois chd1))))
    (if (or (eql 'r chd1) (eql 'r chd2))
        'r
        (if (numberp chd2)
            (transp-to chd2 ois1)
    (safesort 
     (reduce #'union
             (loop for c2 in chd2 collect 
                   (transp-to c2 ois1))))))))

;; BZMS-SHADOW
;; new set-difference from bzmult-simple
;; returns rest if empty, or if either input is a rest
(defun bzms-shadow (chd1 chd2)
  (let* ((bzms (bzmult-simple chd1 chd2))
         (shad (if (eql bzms 'r) 'r
                   (set-difference bzms (union chd1 chd2)))))
    (if shad 
        (if (eql 'r shad) 'r (safesort shad))
        'r)))

;; BZMS-CHAIN -- chain of "bzms-shadow"s
(defun bzms-chain (chd1 chd2 &optional (chainlen 2))
  (cond ((eql chainlen 1) nil)
        ((eql chainlen 2) (list chd1 chd2))
        (t (let* ((prevchain (bzms-chain chd1 chd2 (- chainlen 1)))
                  (lastpair (last prevchain 2)))
             (append prevchain 
                     (list
                      (bzms-shadow (first lastpair) (second lastpair))))))))

;;; NEAREST-MULT -- nearest multiple of modnum to input
(defun nearest-mult (input modnum)
  (cond ((eql input 'r) 'r)
        ((listp input) (map 'list (lambda (x) (nearest-mult x modnum)) input))
        (t (- input (mod input modnum)))))

;; SHUFFLEBYMOD -- shuffles list by modmult indices
(defun shufflebymod (alist factor &optional (modlen 12))
  (loop for x to (- (length alist) 1) collect
        (nth 
         (+ 
          (nearest-mult x modlen)
          (mod (* factor x) modlen))
        alist)))

;; HEAPVEC -- list of 'heaped' mod-x integers
;; as (heapvec len &optional (modlen 12))
;; (heapvec 5 3) = (1 2 0 2 0)
(defun heapvec (len &optional (modlen 12) (transplevel 0))
  (let ((randpitheap (new heap of 
                          (loop for x from 0 to (- modlen 1) collect x))))
    (transp (loop repeat len collect (next randpitheap)) transplevel)))

;; RANDVEC -- list of random mod-x integers (could include repeats)
;; as (random len &optional (modlen 12))
;; (randvec 5 3) = (2 1 2 0 0)
;; added Nov. 2005 
(defun randvec (len &optional (modlen 12) (transplevel 0))
  (let ((randpitrand (new weighting :of 
                          (loop for x from 0 to (- modlen 1) collect x))))
    (transp (loop repeat len collect (next randpitrand)) transplevel)))

;; COPYLIST -- make copies of list
; (copylist '(3 4 5) 3) = (3 4 5 3 4 5 3 4 5)
(defun copylist (a-list mult)
  (loop repeat mult append a-list))

;; CONSN-P -- interval consonance test 
(defun consn-p (x y &optional (consnlist '(3 4 8 9)))
  (or (eql x 'r) 
      (eql y 'r) 
      (member (abs-intv x y) consnlist)))

;; TRICP -- interval + pit trichord test (duos only)
;; (tricp '(0 3) 8 '(0 3 7)) = T
(defun tricp (duo pit trich)
  (not
   (set-difference
    (car (multiple-value-list (prime-form (append duo (list pit)))))
    (car (multiple-value-list (prime-form trich))))))

;; TRICHORD-P -- generalized tricp
;; (trichord-p '(0 7 10) 4 '(0 4 7)) = T
(defun trichord-p (a-list pit trich)
  (cond ((or (not (listp a-list)) (< (length a-list) 2)) 'nil)
        ((= (length a-list) 2) (tricp a-list pit trich))
        ((> (length a-list) 2) 
         (car (member 't (mapcar (lambda (x) (tricp x pit trich))
                            (subsets-len a-list 2)))))))

;; MELINT -- list of melodic intervals within a list
;; "thanks Kenny Tilton!"
;; enhanced Feb. 2006 to also measure non-adjacent skips
;; example: (melint '(8 5 10 2)) = (-3 5 -8)
(defun melint (list &optional (skip 1))
  (mapcar #'intv list (nthcdr skip list)))

;; MELINT-COUNT -- returns # of melodic interval 
;; (up or down) in a melody
(defun melint-count (a-melody intv)
  (loop for a in (melint a-melody) count (= (abs a) intv)))

;; LINE-FROM-MELS -- builds a line from starting pitch & melint
;; --> adds all intervals to the starting point
;; "thanks Kenny Tilton!"
;; example: (line-from-mels 7 '(2 8 0 1)) =  (7 9 15 7 8)
(defun line-from-mels (offset ints)
  (cons offset (mapcar (lambda (int) (+ int offset)) ints)))

;; MELINT->LINE -- builds a line from starting pitch & melint
;; --> adds intervals from the previous pitch
;; (melint->line 50 '(1 2 4)) = (50 51 53 57)
(defun melint->line (startnum int-vector)
  (cons startnum
        (when int-vector
          (melint->line (+ (first int-vector) startnum)
                        (cdr int-vector)))))

;; REPLACE-INTV: replace melodic intervals (singly or in lists)
;; examples:
;; (replace-intv '(4 3 4 7 6) '(1 3) '(2 5)) = (4 2 4 9 7)
;; (replace-intv '(4 3 4 7 6) '(1 3) 2) =  (4 2 4 6 4)
;; (replace-intv '(4 3 4 7 6) 1 2) = (4 2 4 7 5)
(defun replace-intv (a-list a-int rplc-int)
  (let* ((mels (melint a-list))
         (rplcd-mels 
          (loop for x in mels collect
                (if (cond ((numberp a-int) (= (abs x) a-int))
                          (t (member (abs x) a-int)))
                  (* (cond ((numberp rplc-int) rplc-int)
                           (t (nth (position (abs x) a-int) rplc-int)))
                     (if (plusp x) 1 -1))
                  x))))
    (melint->line (first a-list) rplcd-mels)))

;; REVOICE -- shift smaller intervals up an octave
(defun revoice (chd toosmalls &optional (octsize 12))
  (if (numberp (car chd))
      (let ((sschd (safesort chd)))
	(replace-intv  sschd toosmalls (transp toosmalls octsize)))
      (loop for c in chd collect (revoice c toosmalls octsize))))

;; REORDER-BY-MELINT -- returns a melody permuted with the 
;; most frequent instance of a melint (as list of instances)
;; example: (reorder-by-melint '(1 2 3 4) 2) = 
;;  ((1 3 2 4) (1 3 4 2) (2 4 1 3) (2 4 3 1) (3 1 2 4) 
;;   (3 1 4 2) (4 2 1 3) (4 2 3 1))
(defun reorder-by-melint (a-list mel-intv)
  (let* ((aperms (permutations a-list))
         (maxmel (loop for x in aperms
                       maximize (melint-count x mel-intv))))
    (no-nils (loop for p in aperms collect 
                   (if (= (melint-count p mel-intv) maxmel) p)))))

;; STACK-UP 'voices' a melody from bottom to top 
;; example: (stack-up '(5 6 1 3 2)) = (5 6 13 15 26)
(defun stack-up (a-list &optional (oct-size 12))
  (let ((newmels (loop for x in (melint a-list) 
                       collect (mod x oct-size))))
    (melint->line (first a-list) newmels)))

;; STACK-DOWN 'voices' a melody from top to bottom
;; example: (stack-down '(72 5 1 3 2)) = (72 65 61 51 50)
(defun stack-down (a-list &optional (oct-size 12))
  (let ((newmels (loop for x in (melint a-list) 
                       collect (* -1 (- oct-size (mod x oct-size))))))
    (melint->line (first a-list) newmels)))

;; MINMAX-FILT -- returns only those ints between range
(defun minmax-filt (a-list &optional (filtmin 21) (filtmax 108))
  (set-difference (loop for x in a-list collect 
        (if (and (>= x filtmin) (<= x filtmax)) x)) '(nil)))

;; TOPLINE -- takes top line from a poly or mono list
;; (topline '(5 2 (7 1) 4)) =  (5 2 7 4)
(defun topline (a-list)
  (loop for x in a-list collect
        (cond ((eql x 'r) 'r)
        ((numberp x) x)
           (t (apply #'max x)))))

;; BOTTOMLINE -- takes lowest line from a poly or mono list
;; (bottomline '(5 2 (7 1) 4)) =  (5 2 1 4)
(defun bottomline (a-list)
  (loop for x in a-list collect
        (cond ((eql x 'r) 'r)
        ((numberp x) x)
           (t (apply #'min x)))))

;; MIDLINE -- takes all pits btwn. topline & bottomline
(defun midline (a-list)
  (let ((tops (topline a-list))
        (bottoms (bottomline a-list)))
    (loop for x from 0 to (- (length a-list) 1) collect
          (car (if (numberp (nth x a-list)) (nth x a-list)
              (set-difference (nth x a-list)
                              (list (nth x tops) (nth x bottoms))))))))

;; MAKECYC -- a quick helpful macro
(defmacro makecyc (a-list)
  `(new cycle of ,a-list))

; MAKEPAT - a generalized 'makecyc'
; added August 2005
; (next (makepat (indices 4) random) 10) = (0 0 2 0 0 3 0 1 2 3)
(defmacro makepat (a-list &optional (pat-type 'cycle))
  `(new ,pat-type of ,a-list))

;; MINTPROBS -- uses ivec to generate related melint weights
; use with (new weighting :of (mintprobs chd))
(defun mintprobs (chd)
  (let ((chdivec (ivec chd)))
	 (loop for n to 5 append
	       (list
		(list (+ n 1) :weight (nth n chdivec))
		(list (* -1 (+ n 1)) :weight (nth n chdivec))))))

;; MINTWGT -- melint weighting based on chd's ivec
(defun mintwgt (chd)
  (let ((mp (mintprobs chd)))
    (new weighting of mp)))

;; WIGGLE -- builds a random line with specified intervals
;; (wiggle 50 6 '(1 -2)) = (50 48 46 44 42 43)
(defun wiggle (startnum len allowed-ints)
  (let ((wiggle-ints
         (loop repeat (- len 1) collect (pickl allowed-ints))))
    (melint->line startnum wiggle-ints)))

;; TRANSP -- applying 'op' of 'level' to number or list
(defun transp (input level &optional (op #'+))
  (cond
    ((eql input 'r) 'r)
    ((numberp input) (funcall op input level))
    (t (mapcar (lambda (x) (transp x level op)) input)))) 

;; DOUBLER -- doubles the whole list using 'transp'
(defun doubler (alist tlevel &optional (op #'+))
  (loop for x in alist collect 
        (list x (transp x tlevel op))))

;; TAKE-CONTOUR
;; extracts contour vector from a list
;; (take-contour '(55 16 25 90 55)) = (2 0 1 3 2)
(defun take-contour (a-list)
  (let ((sortedlist 
         (safesort (remove-duplicates a-list))))
    (loop for n in a-list 
          collect (position n sortedlist))))

;; GIVE-CONTOUR-TO-SET
;; (give-contour-to-set contourlist setlist)
;; applies contour vector to a list regardless of initial positions
;; starts at the bottom of the sorted input list
;; 1. if (max contourlist) > (length sorted inputlist),
;;      all higher contour indices are stripped out
;; 2. if (max contourlist) < (length sorted inputlist),
;;      contour is applied from the bottom of the inputlist
;; (give-contour-to-set '(2 0 1 3 2) '(3 4 5 6 7)) = (5 3 4 6 5)
(defun give-contour-to-set (contourlist a-list)
  (let* ((sortedinput 
          (safesort (remove-duplicates a-list)))
         (ctrlist (if (> (apply #'max contourlist)
                         (- (length sortedinput) 1))
                    (intersection contourlist
                                   (loop for x to
                                         (- (length sortedinput) 1)
                                         collect x))
                    contourlist)))
    (loop for n in ctrlist
          collect (nth n sortedinput))))

;; ALL-CONTOURS-IN-SET -- returns each mel from 'a-list' that obeys contour
(defun all-contours-in-set (contourlist a-list)
  (let* ((sortedinput 
          (safesort (remove-duplicates a-list)))
         (ctrlist (if (> (apply #'max contourlist)
                         (- (length sortedinput) 1))
		      (intersection contourlist
				    (loop for x to
					  (- (length sortedinput) 1)
					  collect x))
		      contourlist))
	 (ctrspan (+ 1 (- (apply #'max ctrlist) 
			  (apply #'min ctrlist))))
	 (zero-ctour (transp ctrlist (* -1 (apply #'min ctrlist)))))
    (loop for trp to (- (length sortedinput) ctrspan) collect
	  (loop for n in (transp zero-ctour trp) 
		collect (nth n sortedinput)))))

;; PREBUMP
;; utility for give-contour-to-mel
;; (prebump '(2 3 1 0) '(9 6 8 10)) = (10 8 9 6) 
(defun prebump (contour melody)
  (let* ((nodupecnt (remove-duplicates contour :from-end t))
         (bumperpair (pairlis melody nodupecnt)))
    (no-nils (loop for x to (- (length contour) 1) collect
          (car (rassoc x bumperpair))))))

;; BUMPUP -- utility for give-contour-to-mel
;; (bumpup '(10 8 9 7) 12) =  (10 20 21 31)
(defun bumpup (alist &optional (octsize 12))
  (if (cadr alist)
    (cons (car alist)
          (if (< (cadr alist) (car alist))
            (bumpup (transp (cdr alist) octsize) octsize)
            (bumpup (cdr alist) octsize)))
    alist))

;; GIVE-CONTOUR-TO-MEL -- shapes mel to contour
;; keeps pc order of mel, uses octave displacement
;; (give-contour-to-mel '(3 2 1 0 1) '(5 6 7 8)) = (41 30 19 8 19)
(defun give-contour-to-mel (contour mel)
  (permutelist contour (bumpup (prebump contour mel))))

;; TRANSP-TO: moves a list to start at a designated level
;; (transp-to 50 '(3 4 7)) = (50 51 54)
(defun transp-to (level input)
    (if (numberp input) level
	(mapcar (lambda (y) (- y (- (car input) level))) input)))

;; TR-BY-GRP -- transposing members of list by groups
;; example: (tr-by-grp '(1 2 3 4) '(1 2) '(40 50)) =
;; (41 52 53 44 51 52 43 54 51 42 53 54)
(defun tr-by-grp (a-list nums levels &optional (op #'+))
  (let ((listcyc (new cycle of a-list))
	(numcyc (new cycle of nums))
	(levelcyc (new cycle of levels)))
	(flatten (loop
	  until (and (eop? listcyc) (eop? levelcyc))
	  collect (transp (next listcyc (next numcyc))
		(next levelcyc) op)))))
	
;; INTERLOCK -- interlocking 2 lists
;; example: (interlock '(1 2 3) '(33 44 55) '(1 2) '(2 3)) = 
;; (1 33 44 2 3 55 33 44 1 55 33 2 3 44 55 33 1 44 55 2 3 33 44 55)
;; Sept. 2006: 'notfullcyc' flag stops evaluation when one list is exhausted
;; 'notfullcyc' functionality is not perfect
(defun interlock (list1 list2 num1 num2 &optional (notfullcyc nil))
  (let ((list1cyc (new cycle of list1))
	(list2cyc (new cycle of list2))
	(num1cyc (new cycle of num1))
	(num2cyc (new cycle of num2)))
    (flatten (loop
		 until (if notfullcyc (or (eop? list1cyc) (eop? list2cyc))
			   (and (eop? list1cyc) (eop? list2cyc)
				(eop? num1cyc) (eop? num2cyc)))
	       collect (next list1cyc (next num1cyc))
	       collect (next list2cyc (next num2cyc))))))

;; TR-INSERT  -- after each item, insert the same item transposed 
;;	according to list of factors
;; example: (tr-insert '(1 2 3 4) '(0 20 50) #'+) =
;; (1 1 2 22 3 53 4 4 1 21 2 52 3 3 4 24 1 51 2 2 3 23 4 54)
(defun tr-insert (alist levels op)
  (let ((alistcyc (new cycle of alist))
	(levelcyc (new cycle of levels)))
    (flatten (loop 
		 until (and (eop? alistcyc) (eop? levelcyc))
	       for x = (next alistcyc)
	       collect x
	       collect (transp x (next levelcyc) op)))))

;; INTERSECTION (standard lib) -- including only selected list items 
;; example: (intersection '(1 2 3 4 5 6 5 4 3 2 1) '(2 3 4)) = 
;; (2 3 4 4 3 2)

;; SCF -- to substitute members of a list
;; Thanks Bob Coyne!
;; used with 'cyclops.lisp'
;; example: (scf '(10 14 15) '(a b b c b c c)) = (10 14 14 15 14 15 15)

(defun scf (newbies target-list)
  (let ((oldies nil))
    ;; first extract the unique ordered elements from orig. list
    (loop for i in target-list
	  do (pushnew i oldies))
    (setq oldies (reverse oldies))
    ;; if wrong number of new elements, signal an error
    (when (not (= (length oldies) (length newbies)))
      (error "Length mismatch ~a with ~a" newbies oldies))
    (loop for old in oldies
	  for new in newbies
	  do (setq target-list (substitute new old target-list)))
    target-list))

;; STRAVROT -- cycles thru list with Stravinsky-style rotation
;; example: (stravrot '(4 7 2)) = (4 7 2 4 11 1 4 6 9)
;; April 2006: nested list option
(defun stravrot (alist &optional (nestp 'nil))
  (let* ((beglevel (car alist))
         (alistrot (new rotation of alist))
         (rots
          (loop for i in alist
                collect (mod12 
                         (transp-to beglevel 
                                    (next alistrot (length alist)))))))
    (if nestp rots (flatten rots))))

;; CHDHEIGHT -- a way of computing height of chords
(defun chdheight (achord)
  (let ((schd (safesort achord)))
    (loop for x to (- (length schd) 1) sum
          (* (+ x 1) (nth x schd)))))

;; CHORDINTS -- all intervals between members of a chord
(defun chordints (alist)
  (remove-duplicates 
   (safesort
    (loop for x in (subsets-len alist 2) collect 
          (mod-intv (car x) (cadr x))))))

;; LOWERCHORD -- binary (<) comparator by height
(defun lowerchord (chd1 chd2)
  (< (chdheight chd1) (chdheight chd2)))

;; HIGHERCHORD -- binary (>) comparator by height
(defun higherchord (chd1 chd2)
  (> (chdheight chd1) (chdheight chd2)))

;; CHDINV-UP -- next inversion of a chord (bottom member + oct-size)
;; oct-size will traditionally be 12
;; (chdinv-up '(2 5 9)) = (5 9 14)
(defun chdinv-up (alist &optional (oct-size 12))
  (flatten (append (cdr alist) (+ (car alist) oct-size))))

;; CHDINV-DOWN -- 'previous' inversion of a chord (top member - oct-size)
;; oct-size will traditionally be 12
;; (chdinv-down '(9 12 13) 5) = (8 9 12)
(defun chdinv-down (alist &optional (oct-size 12))
  (cons (- (car (last alist)) oct-size) (butlast alist)))

;; CHD-INVERSION -- returns numbered inversion of a chord (up or down)
;; rewritten March 2008
(defun chd-inversion (achd in-idx &optional (octsize 12))
  (if (eql 0 in-idx) achd
      (let* ((inidx-minus (if (minusp in-idx) -1 1))
	     (idx (abs in-idx))
	     (orig-ctr (take-contour achd))
	     (sorted-chd (safesort achd))
	     (chdlen (length achd))
	     (octfact (floor (/ idx chdlen)))
	     (remfact (rem idx chdlen))
	     (octvect (copylist (list octfact) (length achd)))
	     (remvect (append (copylist (list 1) remfact)
			      (copylist (list 0) (- chdlen remfact))))
	     (transpvect (transp (map 'list #'+ octvect remvect) inidx-minus #'*)))
	(give-contour-to-set 
	 orig-ctr
	 (map 'list 
	      (lambda (a b) (+ a (* octsize b)))
	      (if (eql -1 inidx-minus) (reverse sorted-chd) sorted-chd)
	      transpvect)))))

;; NEIGHBOR -- finds the closest member to a number
;; example: (neighbor 7 '(2 4 6 8 9)) = 6
(defun neighbor (num alist)
  (let ((mindist
	 (loop for i in alist minimize (abs (- num i)))))
    (car (member-if
	  (lambda (x) (= (abs (- num x)) mindist)) alist))))

;; NEIGHBOR-COMPL -- finds closest member, returns rest of list
;; example: (neighbor-compl 7 '(2 4 6 8 9)) = (2 4 8 9)
(defun neighbor-compl (num alist)
  (set-difference alist (list (neighbor num alist))))

;; STACK-BY -- 'voice' chords to favor an interval
;; returns list of chords
(defun stack-by (a-list intv &optional (oct-size 12))
  (let* ((stax (loop for x in 
		     (reorder-by-melint a-list intv)
		     collect (stack-up x oct-size)))
	 (maxstax (loop for y in stax
			maximize (melint-count y intv))))
    (no-nils (loop for s in stax collect
                   (if (= (melint-count s intv) maxstax) s)))))

;; SCRUNCH -- change measure length by adjusting downbeat duration
;; returns downbeat alone if (new meas length < upbeats) 
;; example: (scrunch '(3.5 .25 .25 .5) 2.75) = (1.75 0.25 0.25 0.5)
(defun scrunch (alist newlen)
  (if (< newlen (apply #'+ (cdr alist))) (list newlen)
  (cons (- newlen (apply #'+ (cdr alist))) (cdr alist))))

;; ARPEGG -- arpeggiate dyads and chords
;; pitnums = number of pitches in each arpeggiation
;; atknums = number of attacks before moving to next pit group
;; notflat = flag to include sublists, otherwise flat
;; June 2007: 'alist-only' flag will stop at end of 'alist'
;; example: (arpegg '(1 2 3 4) '(2 3) '(4 3)) = 
;; (1 2 1 2 3 4 1 2 3 2 3 4 1 2 3 4 3 4 1 2 3 4 1 4 1 2 3 4)
(defun arpegg (alist pitnums atknums &optional (alist-only 'nil) (notflat 'nil)) 
  (let* ((listcyc (new cycle of alist))
	 (pitcyc (new cycle of pitnums))
	 (atkcyc (new cycle of atknums))
	 (nlist (patt-to-sum pitcyc (length alist)))
	 (arpeglist 
	  (if alist-only
	      (loop for nl in nlist 
		    collect (next (new cycle of (next listcyc nl))
				  (next atkcyc)))
	      (loop until (and (eop? listcyc) (eop? pitcyc) (eop? atkcyc))
		collect (next (new cycle of (next listcyc (next pitcyc)))
			      (next atkcyc))))))
    (if notflat arpeglist (flatten arpeglist))))

;; MODMULT -- multiplies & mods (number or list)
;; example: (modmult '(1 2 3) 3 4) = (3 2 1)
(defun modmult (input multnum modnum)
  (if (number? input) 
    (mod (* multnum input) modnum)
    (mapcar (lambda (x) (mod (* multnum x) modnum)) input)))

;; CLIP-HI -- returns list <= a given value
;; example: (clip-hi 10 '(8 9 10 11 12)) = (8 9 10 10 10)
(defun clip-hi (num a-list)
  (mapcar (lambda (x) (min x num)) a-list))

;; CLIP-LO -- returns list >= a given value
;; example: (clip-lo 5 '(7 6 5 4 3)) = (7 6 5 5 5)
(defun clip-lo (num a-list)
  (mapcar (lambda (x) (max x num)) a-list))

;; CONSMATCH -- put a line against another, match where it can
;; example: (consmatch '(9 8 7 6) '(1 (2 6) r 3 (1 5) r 2 3 (1 4) 2 3) 'nil)
;; ((1 9) (2 6) R 3 (8 1 5) R 2 (3 7) (1 4) (2 6) 3)
(defun consmatch (blist alist &optional (fill-rests 't) (consvec '(3 4 8 9)))
  (let ((alistcyc (new cycle of alist))
	(blister blist))
    (loop 
        until (and (eop? alistcyc) 
                   (or (null? blister)
                       (not (member-if
                             (lambda (x) (consn-p x (car blister) consvec)) 
                             (flatten alist)))))
      for next-a = (next alistcyc)
      collect 
      (cond ((numberp next-a)
             (cond ((null? blister) next-a)
                   ((consn-p next-a (car blister) consvec) 
                    (list next-a (pop blister)))
                   (t next-a)))
            ((listp next-a)
             (cond ((null? blister) next-a)
                   ((member-if (lambda (x)
                                 (consn-p x (car blister) consvec))
                               next-a)
                    (push (pop blister) next-a))
                   (t next-a)))
            ((eql next-a 'r)
             (if fill-rests
               (if (null? blister) 'r (pop blister)) 'r))))))

;; SELF-STRETTO -- recursive self-consmatch
;; added February 2006
(defun self-stretto (mel vcs intvl &optional (waitlen 1))
  (if (eql vcs 1) mel
      (consmatch 
       (append (copylist '(r) (* waitlen (- vcs 1)))
               (transp mel (* (- vcs 1) intvl)))
       (self-stretto mel (- vcs 1) intvl waitlen))))

;; TRIMATCH -- match line to another by assembled trichords
; (trimatch '(1 2 3 4) '((4 8) 10 (2 3) r (0 7)) '(0 4 7))
; = ((1 4 8) 10 (2 3) 2 (3 0 7))
(defun trimatch (blist alist trich &optional (fill-rests 't))
  (let ((alistcyc (new cycle of alist))
	(blister blist))
    (loop 
        until (eop? alistcyc)
      for next-a = (next alistcyc)
      collect 
      (cond 
        ((eql next-a 'r)
         (if fill-rests
           (if (null? blister) 'r (pop blister)) 'r))
        ((trichord-p next-a (car blister) trich)
         (push (pop blister) next-a))
        (t next-a)))))

;; MYHAND -- doubles melody whenever an interval occurs
;; a-list = melody, an-intvl = melodic interval to find
;; dblint = doubling interval when an-intvl occurs
;; dbltype = where to double: can be 'start or 'end (of the melodic interval)
;; (myhand '((10 2) 5 6 (9 20) 4 3) -5 11 'end) = ((10 2) (16 5) 6 (9 20) 4 3)
(defun myhand (a-list an-intvl dblint &optional (dbltype 'start))
  (let* ((monoline (topline a-list))
         (a-melint (melint monoline))
         (typid (if (equal dbltype 'start) 0 1))
         (dbld-line 
          (loop for n to (- (length a-melint) 1) collect
                (if (= (nth n a-melint) an-intvl)
                  (if (numberp (nth (+ n typid) a-list)) 
                    (list (+ (nth (+ n typid) a-list) dblint)
                          (nth (+ n typid) a-list))
                    (cons (+ (nth (+ n typid) monoline) dblint) 
                          (nth (+ n typid) a-list)))
                  (nth (+ n typid) a-list))))
         (cleanup (loop for x in dbld-line collect
                        (if (numberp x) x
                            (remove-duplicates x)))))
    (if (equal dbltype 'start)
      (append cleanup (if (listp (last a-list)) 
                        (last a-list) (list (last a-list))))
      (append (list (first a-list)) cleanup))))

;; THINOUT -- removes each instance of members in list, from the beginning
;; (thinout '(1 43 9 3 1 4 3 9 2 1 9)) = 
;; (1 43 9 3 1 4 3 9 2 1 9 43 9 3 4 3 9 2 9 9 3 4 3 9 2 9 3 4 3 2 4 2)
(defun thinout (alist)
  (butlast (flatten (append alist 
                   (loop with nodupes = (remove-duplicates alist :from-end t)
                         for nd in nodupes
                         for excluded = (append excluded (list nd))
                         collect (set-difference alist excluded))))))

;; FILLIN -- builds up to entire list from repeated starts
;; (fillin '(1 2 3)) = (1 1 2 1 2 3)
(defun fillin (alist)
  (let ((myaccum (new accumulation :of alist)))
    (loop until (eop? myaccum) collect (next myaccum))))

;; INDICES -- get a quick list of integers
;; (indices 4) = (0 1 2 3)
;; enhanced June 2005
(defun indices (len &optional (base 0))
  (transp (loop for n to (- len 1) collect n) base))

;; SCALEY -- quick & dirty macro
(defmacro scaley (min max len)
  `(next (new range from ,min to ,max) ,len))

;; RANDSCALEY -- generate a 'totalen' chain of random-length indices 
;; each sub-chain of length btwn/incl. 'minindex' & 'topindex' 
;; [fixed June 2005 to avoid repeated 'minindex']
(defun randscaley (minindex topindex totalen)
  (let ((rawlist (loop repeat totalen append
        (transp (indices (+ 2 (random (- topindex minindex)))) minindex))))
    (subseq rawlist 0 totalen)))

;; RANDOM-INDICES -- returns shuffled indices
;; (random-indices 7) = (3 0 4 1 5 2 6)
(defun random-indices (len)
  (shuffle (indices len)))

;; RANDMEL -- random indices using modlen; no repeated entries
;; (randmel 10 4) =  (3 2 0 2 0 1 3 2 1 3)
(defun randmel (list-len &optional (modlen 12))
  (let ((melgen (new weighting :of
                     (loop for x in (indices modlen)
                           collect (list x :max 1)))))
    (loop repeat list-len collect (next melgen))))

;; SNAKE -- oscillating among indices
;; (snake 5 10 'down) =  (4 3 2 1 0 1 2 3 4 3)
(defun snake (height len &optional (direction 'up))
  (let* ((baselist (if (eql direction 'up) (indices height)
                      (reverse (indices height))))
        (snakepal (new palindrome :of baselist :elide true)))
    (next snakepal len)))

;; EXPAND -- revised Feb. 2006 (see below)

;; WRAPPERS FOR NONDETERMINISTIC STUFF

;; WIGGLE-TO -- all paths from startnum to endnum 
;; by combination of allowed-ints
;; if fails, returns startnum
(defun wiggle-to (startnum endnum steps allowed-ints)
  (if (or (eql startnum 'r) (eql endnum 'r))
      startnum
      (let ((wt (screamer-user::wigto startnum endnum steps allowed-ints)))
	(if wt (no-nils wt) startnum))))

;; WIGLINE -- builds a line of wiggle-to's by durlist 
;; returns ((pits-with-wiggles) (durs-with-wiggles))
;; (wigline '(45 55 51) '(10 12 8) '(2 -3)) = 
;; ((45 47 49 51 53 55 57 54 51) (6 1 1 1 1 10 1 1 8))
(defun wigline (a-line durlist intvs &optional (treeflag nil))
  (let* ((proper-durlist (if (listp durlist) durlist (list durlist)))
         (durs (next (new cycle of proper-durlist) (length a-line)))
         (wigler (loop for x to (- (length a-line) 2) collect
                       (wiggle-to (nth x a-line) (nth (+ x 1) a-line)
                                  (nth x durs) intvs)))
         (wigpits (loop for x to (- (length wigler) 1) collect
                        (if (atom (nth x wigler))
			    (nth x a-line)
			    (butlast (melint->line (nth x a-line)
						   (shuffle 
						    (pickl (nth x wigler))))))))
         (wigdurs (loop for x to (- (length wigler) 1) collect
                        (if (atom (nth x wigler))
			    (nth x durs)
			    (cons (+ (- (nth x durs) 
					(length (nth x wigpits))) 1)
				  (loop repeat 
				      (- (length (nth x wigpits)) 1) 
				    collect 1))))))
    (if treeflag
	(list (append wigpits (list (last a-line)))
	      (append wigdurs (list (last durs))))
	(list (append (flatten wigpits) (last a-line))
	      (append (flatten wigdurs) (last durs))))))

;; EQL-SUMMER -- all ways to sum componentnums to targetnum
;; if fails, returns targetnum
(defun eql-summer (targetnum componentnums)
  (let ((es (screamer-user::eqlsum targetnum componentnums)))
    (if es es (list targetnum))))

;; EMBELL-TRIAD -- list of random 'neighbor' triads to triad 
;; with largest leap of 'span' and same sum
;; example: (embelltriad '(3 5 6) 1) = ((2 5 7) (3 4 7))
(defun embell-triad (triad &optional (steps 3) (sumspan 5))
  (screamer-user::near-ebt triad sumspan steps))

;;

;; NTN->CLISTS -- wrapper for "ntn-to-clists" nondet function
;; returns all contours in binsize that correspond to 
;; ntn (note-to-note) contour
;; (ntn->clists '(-1 1) 3) = ((1 0 1) (2 0 1) (1 0 2) (2 0 2) (2 1 2))
(defun ntn->clists (antn binsize)
  (screamer-user::ntn-to-clists antn binsize))

;; REGISTER STUFF

;; AVG-CHDPIT -- 'average' of an integer list 
;; returns integer
(defun avg-chdpit (chd)
  (car (multiple-value-list (floor (/ (apply #'+ chd) (length chd))))))

;; OCTAVESPREAD -- make list of any pitch in all octaves
(defun octavespread (pit &optional (spreadmin 21) (spreadmax 108) (modlen 12))
  (minmax-filt (loop for x in (indices (+ 1 (floor (/ spreadmax modlen)))) 
                     collect
                     (+ (mod pit modlen) (* x modlen)))
               spreadmin spreadmax))

;; MATCHREG -- change register to minimize leaps
;;  .. in list case, bring all members of list1 closest to
;; corresponding members of list2 by shifting octaves
;; July 2006: ordered or unordered match, lists of unequal size

(defun mr (a b &optional (modlen 12))
  (let* ((atransp (loop for z from 0 to (floor (/ 90 modlen))
		       collect (+ (* z modlen) (mod a modlen))))
	(smalldiff (loop for x in atransp minimize (abs (- x b)))))
    (car (member-if (lambda (q) (= (abs (- q b)) smalldiff)) atransp))))

(defun matchreg (thing1 thing2 &optional (ordflag nil) (mlen 12))
  (let ((adjthing1 (closest (mod12 thing2) (mod12 thing1))))
    (cond ((and (numberp thing1) (numberp thing2))
           (mr thing1 thing2 mlen))
          ((and (listp thing1) (listp thing2))
           (cond ((= (length thing1) (length thing2))
                  (map 'list 
                       (lambda (a b) (mr a b mlen))
                       (if ordflag thing1 adjthing1) thing2))
                 ((< (length thing1) (length thing2))
                  (matchreg thing1
                            (subseq thing2 0 (length thing1))))
                 ((> (length thing1) (length thing2))
                  (append (matchreg (subseq thing1 0 (length thing2))
                                    thing2 ordflag)
                          (matchreg (subseq thing1 (length thing2))
                                    thing2 ordflag)))))
          ((and (listp thing1) (numberp thing2))
           (mapcar (lambda (x) (mr x thing2 mlen)) thing1))
          ((eql 'r thing1) 'r)
          ((eql 'r thing2) thing1)
          ('t (error 
               "Type or length mismatch ~a with ~a" thing1 thing2)))))

;; MATCHREG-CHDS -- does consecutive chdmatch for list 
;; list of equal length chords
;; output length fixed Sept. 2006
(defun matchreg-chds (chdlist &optional (ordflag nil))
  (if (eql 2 (length chdlist))
      (list (first chdlist) (matchreg (second chdlist) (first chdlist)))
    (cons (car chdlist)
	  (matchreg-chds 
	   (cons (matchreg (cadr chdlist) (car chdlist) ordflag) 
		 (cddr chdlist))))))

;; TAKEREG -- returns reg of pits (atom or list)
(defun takereg (input &optional (basepit 0) (modlen 12))
  (cond ((numberp input) 
         (car (multiple-value-list (floor (/ (- input basepit) modlen)))))
        ((eql input 'r) 'r)
        (t (mapcar 
	    (lambda (x) (takereg x basepit modlen))
	    input))))

;; PLACEREG -- translates list to registers
;; input = original pitch list
;; regbase = lowest note in output (24 often works for me)
;; modindex = size of 'octave' (usually 12)
;; reg = pattern, list, or scalar governing placement in different octaves
;; (placereg '(1 2 3 4 5 6) (new cycle of '(5 3 4 2))) =  (61 38 51 28 65 42)
(defun placereg (inpits reg &optional (modindex 12) (regbase 0))
  (let* ((input (modlist inpits modindex))
         (incyc (new cycle of input))
         (regpatt (cond ((pattern? reg) reg)
                        ((listp reg) (makecyc reg))
                        (t (makecyc (list reg))))))
    (loop until (eop? incyc)
      collect (transpose (next incyc) 
                         (+ regbase (* modindex (next regpatt)))))))

;; PLACEREG-CHDS -- when chds are all equal length
;; June 2007
(defun placereg-chds (chds reg)
  (let ((regpatt (cond ((pattern? reg) reg)
		       ((listp reg) (makecyc reg))
		       (t (makecyc (list reg))))))
    (make-poly
     (placereg (flatten chds) regpatt)
     (length (car chds)))))

;; TENDREG -- replace registers for smoothest transition from start to end
;; [adjusts register of all chords in the middle]
;; can be ordered or unordered
(defun tendreg (chdlist &optional (ordflag nil) (basepit 0) (modlen 12))
  (case (length chdlist)
    (1 chdlist)
    (2 chdlist)
    (t
     (let* ((startreg (takereg (car chdlist) basepit modlen))
	    (endreg (takereg (car (last chdlist)) basepit modlen))
	    (basereg (union startreg endreg))
	    (loreg (apply #'min basereg))
	    (hireg (apply #'max basereg))
	    (allreg (indices (+ 1 (- hireg loreg)) loreg))
	    (mid-baselist (mapcar #'mod12 (butlast (cdr chdlist))))
	    (midregs (loop for mb in mid-baselist collect
			   (loop for b in mb collect 
				 (loop for r in allreg append
				       (placereg b r modlen basepit)))))
	    (posschds (loop for m in midregs collect (all-combos m 'flat)))
	    (posspaths (if (eql 3 (length chdlist))
			   (loop for p in (first posschds) collect
				 (list p))
			   (all-combos posschds)))
	    (complete-posspaths 
	     (mapcar (lambda (x) 
		       (append (list (car chdlist)) x (last chdlist)))
		     posspaths))
	    (bestdist
	     (apply #'min
		    (mapcar 
		     (lambda (x) (total-distances x ordflag)) 
		     complete-posspaths)))
	    (shortpaths 
	     (no-nils
	      (loop for x in complete-posspaths collect
		    (if (eql bestdist (total-distances x)) x))))
	    (spleaps (mapcar #'each-distance shortpaths))
	    (bestleaps (car (list<sort spleaps))))
    (car
     (member-if 
      (lambda (x)
        (seq-eql bestleaps (each-distance x)))
      shortpaths))))))

;; some handy graphs for registers

;; MIDDLEWEIGHT-5 -- tends to bounce back to 3 of 5
(define middleweight-5 
  (new graph of 
       `((1 :id A :to ,(new weighting of '(C D)))
	 (2 :id B :to C)
	 (3 :id C :to ,(new weighting of '(A B C D)))
	 (4 :id D :to ,(new weighting of '(C E)))
	 (5 :id E :to D))))

;; FOLLOWING-5 -- tends to move gradually from one area to another
(define following-5 
      (new graph of 
	   `((1 :id A :to B)
	     (2 :id B :to ,(new weighting of '(A B C)))
	     (3 :id C :to ,(new weighting of '(B C D)))
	     (4 :id D :to ,(new weighting of '(C D E)))
	     (5 :id E :to D))))

;;; RHYTHM STUFF

;; INBETWEEN -- utility for 'valbytime'
(defun inbetween (anumber alist)
  (let ((mins (mapcar (lambda (x) (> x anumber)) alist)))
    (cond ((eql 't (car mins)) 0)
          ((not (member 't mins)) (- (length alist) 1))
          (t (- (position t mins) 1)))))

;; VALBYTIME -- changes value according to 'changedurs'
;; returns list of vals matching 'durs' 
;; (valbytime '(3 3 3 3) '(s n p j q) '(2 2 2 2 2 2 2)) = (s s n p p j q q)
(defun valbytime (changedurs vals durs)
  (let* ((changeatx (melint->line 0 changedurs))
         (duratx (melint->line 0 durs))
         (changeidx (loop for x in duratx collect
                          (inbetween x changeatx))))
    (loop for y in changeidx collect (nth y vals))))


;; DURS->SLOTS -- makes placeholders between attacks
;; 'durs' should be integers
;; (durs->slots '(55 52 54) '(2 3 2)) = (55 R 52 R R 54 R)
;; note: must use (if (numberp a-pit)) clause in playback!
;; Dec. 2007: now treats chords properly
(defun durs->slots (pits durs)
   (loop for n to (- (length pits) 1) append
         (cons (nth n pits) 
               (loop repeat (- (nth n durs) 1) collect 'r))))

;; MERGE-SLOTS -- combines all pits slot-by-slot
;; [fixed Nov. 2005]
;; makes use of rest placeholder 'r
;; (merge-slots '((2 3 r r 5 6) (r (4 5) r 1 1 r) (44 10 r))) 
;; = ((2 44) (3 4 5 10) R 1 (5 1) 6)
(defun merge-slots (&rest lists)
  (let* ((plists (car lists))
         (maxlen (apply #'max 
                        (mapcar #'length plists)))
         (rufflist
          (loop for n to (- maxlen 1) collect
                (loop for x in plists collect
                      (if (< n (length x)) (nth n x) 'r))))
         (rawlist
          (loop for ruffslot in rufflist collect
                (if (or (some #'listp ruffslot) (some #'numberp ruffslot))
		    (remove-duplicates 
		     (flatten 
		      (set-difference ruffslot '(r))))
		    'r))))
    (not-flat
     (loop for x in rawlist collect
	   (cond ((and (listp x) (> (length x) 1)) x)
		 ((listp x) (first x))
		 (t x))))))

;; STARTINGRESTNUM -- utility for slots->durs (May 2005)
;; counts the number of starting rests
;; returns 'nil' if not applicable
(defun startingrestnum (alist)
  (let ((restlist (loop repeat (length alist) collect 'r)))
  (if (eql (first alist) 'r) (mismatch alist restlist))))

;; SLOTS->DURS -- takes slotlist; makes pitlist & durlist (integers)
;; completely rewritten Sept. 2006
;; fixed 'r as list - Feb. 2008
(defun slots->durs (inmel)
  (let* ((melody 
	  (mapcar (lambda (x) (if (and (listp x) (list-eql x (list 'r))) 'r x))
		  inmel))
	 (gathered-mel (loop with fragment
			 for (note next-note) on melody
			 do (push note fragment)
			 unless next-note
			 collect (nreverse fragment) into result
			 and do (loop-finish)
			 when 
			 (not (eql 'r next-note))
			 collect (nreverse fragment) into result
			 and do (setf fragment nil)
			 finally (return result))))
    (list (mapcar #'car gathered-mel)
	  (mapcar #'length gathered-mel))))

;; STRUMS -- creates downbeat followed by upbeats
;; integer list for use in 'ferney' etc.
;; (strums 3 3 6 2 7) = (3 1 1 6 1 1 1 1 4 1 1 1)
(defun strums (iters min-db max-db min-upatx max-upatx &optional (mval 1))
  (flatten (loop repeat iters
             collect
             (append (list (between min-db (+ max-db 1)))
                     (loop repeat (between min-upatx
                                           (+ max-upatx 1))
                       collect mval)))))

;; DNBEATS -- takes pits & durs,
;; makes vectors of long downbeat + 1's (like strums)
;; (dnbeats '(50 43 56 78 43) 9) = (5 1 1 1 1)
(defun dnbeats (pits durs &optional (treeflag nil))
  (if (numberp (car pits))
      (if (> durs (length pits))
	  (cons (+ 1 (- durs (length pits))) (copylist '(1) (- (length pits) 1))))
      (if (eql (length pits) (length durs))
	  (let ((final
		 (map 'list (lambda (x y) (dnbeats x y)) pits durs)))
	    (if treeflag final (flatten final))))))

;; LAYOUT -- insert random rests in melody
;; (layout .5 '(50 40 30 20 10)) =  (R 40 30 R R)
(defun layout (factor pitlist)
        (loop for x in pitlist collect
              (odds factor x 'r)))

;; MENSES -- mensuration by inserting rests btwn members
;; (menses '(1 2 3 4) 3) = (1 R R 2 R R 3 R R 4 R R)
(defun menses (a-list rate)
  (flatten 
   (loop for x in a-list collect 
         (append (list x)
               (loop repeat (- rate 1) collect 'r)))))

;; POPULATE -- randomly add a list to a list (both in sequence)
;; (populate '(2 3 4 5) '(10 20 30 40 50 60 70 80))
;; (10 20 2 30 40 3 50 4 5 60 70 80)
(defun populate (nuthings oldthings)
  (let* ((totlen (+ (length nuthings) (length oldthings)))
         (pushidx (heapvec (length nuthings) totlen))
         (nucopy nuthings)
         (oldcopy oldthings))
    (loop for x from 0 to (- totlen 1) collect
          (if (member x pushidx) (pop nucopy) (pop oldcopy)))))

;; RANDRESTS -- randomly add rests
;; (randrests '(1 2 3 4 5) 10) = (1 R 2 R R R 3 4 5 R)
(defun randrests (inlist totalen)
  (let ((restvec (loop repeat (- totalen (length inlist)) collect 'r)))
    (populate restvec inlist)))

;; RANDURS -- quantized ransegs
;; density = avg # atx per beat 
(defun randurs (totalen &optional (density 1) (qlevels '(3 4)))
  (quantdurs
   (melint
    (rescale-all (ransegs (round (* totalen density))) 0 1 0 totalen))
   (ferney '(1) (next (new weighting :of qlevels) totalen))))


;; DIVVY-UP -- simple utility used in 'ferney'
(defun divvy-up (mlen subdiv &optional (numtype 'float))
  (loop repeat subdiv collect 
        (if (eql numtype 'float) 
          (float (/ mlen subdiv))
          (/ mlen subdiv))))

;; FERNEY -- build list from mlens, subdivs, durs
;; now using modified 'ferneyrat' [Jan. 2006]
;; may specify rats or floats
;; cycling through everything
;; omitting durations will yield 'basic' mlens/subdivs list
;; (ferney '(2 3) '(1 2 4) '(2 4) 'float) = 
;; (3.5 3.0 3.5 3.5 1.5 5.5 1.0 5.5 1.5 5.0 2.0 4.5 2.0 3.0)
(defun ferney (mlens subdivs &optional (durs '(1)) (numtype 'rat))
  (let* ((mlens-cyc (new cycle of mlens))
         (subdivs-cyc (new cycle of subdivs))
         (durs-cyc (new cycle of durs))
         (flatcyc 
          (new cycle of
               (flatten (loop until (and (eop? mlens-cyc)
                                         (eop? subdivs-cyc))
                          collect (divvy-up (next mlens-cyc) 
                                            (next subdivs-cyc)
                                            numtype))))))
    (loop until (and (eop? flatcyc) (eop? durs-cyc))
      collect (apply #'+ (next flatcyc (next durs-cyc))))))

;; FERNCYC -- making a cycle of ferney
(defun ferncyc (mlens subdivs &optional (durs '(1)))
  (makecyc (ferney mlens subdivs durs)))

;; FERNEYS -- list of (nonrepeating) ferneys -- flat (default) or not flat!
(defun ferneys (len &optional (divs '(3 4)) (width 1) (treeflag nil))
  (let* ((divpatt (new weighting :of (norpt-rand divs)))
	 (rawout
	  (loop repeat len collect 
		(ferney width (next divpatt)))))
    (if treeflag rawout (flatten rawout))))

;; FERNLIST -- building list of ferneys from div list
(defun fernlist (alist &optional (width 1))
  (mapcar (lambda (div) (ferney width div))
	  alist))

;; SUM-ACROSS -- adds up members of baselist according to durlist
;; note: throws away any remainder of baselist
;; (sum-across '(1 2 1 2 1 2) '(2 3)) = (3 4)
(defun sum-across (baselist durlist)
  (let ((base-cyc (if (pattern? baselist) baselist (new cycle of baselist))))
    (loop for x in durlist collect
          (apply #'+ (next base-cyc x)))))

;; SUM-ACROSS-ALL -- adds up members of baselist according to durlist
;; note: uses all of baselist
;; Added September 2005
;; (sum-across-all '(1 2 1 2 1 2) '(2 3)) = (3 4 2)
(defun sum-across-all (baselist durlist)
  (let* ((mp (not-flat (make-poly baselist durlist))))
    (mapcar (lambda (x) (apply #'+ x)) mp)))

;; STRUMFIT -- provides upbeats for existing durlist
;; --> need to deal correctly with shorter durs in durlist
(defun strumfit (durlist max-upatx)
  (flatten (loop for dur in durlist
                 for chop = (min (+ 1 (random max-upatx)) (- dur 1))
                 collect
                 (if (> dur (+ chop 1))
                   (append (list (- dur chop))
                           (loop repeat chop collect 1))
                   dur))))

;; examples of possible rhyt-pairs
(define updur (pairlis '(0 1 2 3 4 5 6 7 8 9 10 11)
			'(1 1 1 2 2 2 3 3 3 4 4 4)))

(define downdur (pairlis '(0 1 2 3 4 5 6 7 8 9 10 11)
			'(4 4 4 3 3 3 2 2 2 1 1 1)))

(define shuffdur (pairlis '(0 1 2 3 4 5 6 7 8 9 10 11)
			(shuffle '(1 2 3 4 5 6 7 8 9 10 11 12))))

(defun randdur (maxdur)
  (let ((randloop (loop repeat 12 collect (+ 1 (random maxdur)))))
    (pairlis '(0 1 2 3 4 5 6 7 8 9 10 11) randloop)))

;; FIXRHYTHM -- set durations according to size of melodic interval
;; example: (melrhythm '(0 9 7 2 3 5) pitdur) = 
;; (0.75 0.25 0.5 0.25 0.25 1.0)
;; see also "leapdur" for a more probabalistic approach
(defun fixrhythm (a-melody rhyt-pairs)
  (let ((thismel (melint a-melody)))
    (append (loop for i in thismel
		  collect (cdr (assoc (mod12 (abs i)) rhyt-pairs)))
	    (list 1))))


;; midi example: random durations fixed by melodic interval
;(define fixed-mel
;  (let* ((a-mel (randmel 100))
;	(a-rhylist (fixrhythm a-mel downdur)))
;  (process for i below (length a-mel)
;        output (new midi :time (now)
;                     :keynum (+ 60 (nth i a-mel)) 
;                     :duration (* .125 (nth i a-rhylist)))
;	wait (* .125 (nth i a-rhylist)))))

; (events fixed-mel "fixedmel.midi")

;; midi example: random durations fixed by pitch class
;(define fixed-pc
;  (loop for key from 60 to 72 
;        for beg from 0 by .1
;        collect (new midi :time beg
;                     :keynum (
;                     :duration 1)))
;
;; store them in a midi file
; (events fixed-pc "fixedpc.midi")

;; FAST-TACT -- find fastest tactus from list of durations
;; i.e. rational gcd of rationals (not always the minimum)
;;;; (fast-tact '(1.2 1.1 1/2 5 2.9)) = 0.1
;;;; ...but also: (fast-tact '(10 15 30)) = 5
;; fixed June 2005 & Sept 2005
(defun fast-tact (a-list)
  (let* ((rats (loop for x in a-list collect (rationalize x)))
	 (denoms (loop for x in rats collect (denominator x)))
	 (maxden (apply #'lcm denoms)))
    (if (member-if-not (lambda (x) (= (floor x) x)) a-list)
      (/ 1 maxden)
      (apply #'gcd a-list))))

;; HITS->INTS -- takes rhythms (reals), 
;; converts to integers according to fastest-tact
;;;; (hits->ints '(.25 1.125 .5)) = (2 9 4)

(defun hits->ints (a-list)
  (loop for x in a-list collect (floor (/ x (fast-tact a-list)))))

;; SIFTOUT -- returns only those members in 'place mod'
;; (siftout '(1 2 3 4 5 6) 3 '(1 2)) = (1 2 4 5)

(defun siftout (a-list modlen places)
  (if (numberp places) 
    (loop for x in a-list 
	  if (= (mod x modlen) places) collect x)
      (flatten (loop for x in a-list collect
	    (loop for y in places
		  if (= (mod x modlen) y) collect x)))))

;; utilities for 'closest'

;; PAD-PITCHES -- utility for 'listdist'
;; returns 'padded' smaller chord in relation to larger chord
;; [pads with pitch in smallchd that's closest to avg in largechd]
(defun pad-pitches (smallchd largechd)
    (append smallchd
            (loop repeat (- (length largechd) (length smallchd))
              collect (neighbor (avg-chdpit largechd) smallchd))))

;; LISTDIST -- sum of distance between 2 lists
;; "city blocks" measurement if ordered, otherwise closest match
;; (listdist '(4 5 6) '(5 10 1)) = 7
;; (listdist '(4 5 6) '(5 10 1) 'ordered) = 11
;; can be different lengths, but best when unordered in that case
(defun listdist (pits1 pits2 &optional (ordered-flag nil))
  (let* ((inchd1 (if (listp pits1) pits1 (list pits1)))
         (inchd2 (if (listp pits2) pits2 (list pits2)))
         (chds (cond ((< (length inchd1) (length inchd2))
                      (list (pad-pitches inchd1 inchd2) inchd2))
                     ((> (length inchd1) (length inchd2))
                      (list inchd1 (pad-pitches inchd2 inchd1)))
                     (t (list inchd1 inchd2))))
         (list1 (first chds))
         (list2 (second chds)))
    (if ordered-flag
        (loop for n to (- (length list1) 1) sum
              (abs (- (nth n list1) (nth n list2))))
        (let* ((clperms (permutations list2)))
          (loop for p in clperms minimize
                (loop for n to (- (length list1) 1) sum
                      (abs (- (nth n list1) (nth n p)))))))))

;; LISTDIST-MOD -- sum of mod-intv distance 
;; ordered or unordered (June 2007)
(defun listdist-mod (lst1 lst2 &optional (ordered-flag nil) (modlen 12))
  (if ordered-flag
      (apply #'+ (map 'list (lambda (x y) (mod-intv x y modlen)) lst1 lst2))
      (apply #'min 
	     (mapcar
	      (lambda (r) (listdist-mod r lst2 'ordered modlen))
	      (permutations lst1)))))

;; CLOSEST -- orders list2 as the minimum total distance from list1
;; (closest '(4 5 6) '(5 10 1)) = (1 5 10)
(defun closest (list1 list2)
  (let* ((clperms (permutations list2))
	 (cldist (loop for x in clperms collect (listdist list1 x 'ordered))))
    (nth (position (apply #'min cldist) cldist) clperms)))

;; CLOSEST-MOD -- orders list2 as the minimum modlen distance from list1
;; (closest-mod '(11 7 4) '(7 4 0)) = (0 7 4)
(defun closest-mod (list1 list2 &optional (modlen 12))
  (let* ((clperms (permutations list2))
	 (cldist (loop for x in clperms collect 
                       (listdist-mod list1 x 'ord modlen))))
    (nth (position (apply #'min cldist) cldist) clperms)))

;; CLOSEST-MOD-LIST -- 'closest-mod' applied to entire list
(defun closest-mod-list (chdlist &optional (modlen 12))
  (if (eql 2 (length chdlist))
      (list (first chdlist) (closest-mod (first chdlist) (second chdlist) modlen))
    (cons (car chdlist)
	  (closest-mod-list
	   (cons (closest-mod (car chdlist) (cadr chdlist) modlen) 
		 (cddr chdlist))
	   modlen))))

;; NEXTCONS -- finds next consonance with y from x
;; in direction 'movement' (1=up,-1=down)
;; [changed June 2005]
;; (nextcons 8 10 1) = 11
(defun nextcons (y x movement &optional (oblq nil) (consvec '(3 4 8 9)))
  (let ((startx (+ x movement)))
    (if (and oblq (consn-p x y consvec)) x
    (if (consn-p y startx consvec) startx
      (nextcons y (+ x movement) movement oblq consvec)))))

;; NORPT -- removes repeated entries in flat list
;; (norpt '(2 3 3 4 3 5 5)) = (2 3 4 3 5)
;; now includes rests [January 2006]
(defun norpt (melody &optional (test #'eql))
  (loop with fragment
    for (note next-note) on melody
    do (setf fragment note)

    unless next-note
    collect fragment into result
    and do (loop-finish)

    when (not (funcall test next-note note))
    collect fragment into result
    and do (setf fragment nil)

    finally (return result)))

;; TIEVEC -- number of immediate repeats
;; for use with 'norpt' and 'sum-across'
; (tievec '(3 3 2 2 1 0 3 2 3 1)) = (2 2 1 1 1 1 1 1)
(defun tievec (alist)
  (let* ((eqlsubs (not-flat (conjunct-fragments alist 0))))
    (loop for x in eqlsubs collect
          (length x))))

; MAKE-TIES -- converting all repeats to ties
;; makes mel+dur pair .. feed into 'play-sd' to play
(defun make-ties (mel)
  (list (norpt mel)
	(tievec mel)))

;; CHDS->TIES -- takes chords; returns tievecs for each line
;; chords must all be the same length
(defun chds->ties (chdlist)
  (mapcar #'make-ties
	  (make-poly (alternate (mapcar #'safesort chdlist))
		     (list (length chdlist)))))
      
;; PLAY-TIES -- plays list of ties w/duration vec.
;; e.g. (play-ties '(((60 70) (2 1)) ((63 54) (1 4))) .5)
(defun play-ties (tlist indurs)
  (let* ((tilens (mapcar (lambda (x) (apply #'+ (second x))) tlist))
	 (maxlen (apply #'max tilens))
	 (durs (cond ((pattern? indurs) (next indurs maxlen))
		     ((listp indurs) (next (makecyc indurs) maxlen))
		     (t (copylist (list indurs) maxlen)))))
    (loop for tl in tlist collect
	  (splay (first tl)
		 (sum-across durs (second tl))))))

;; PLAYCHDS->LINES -- chds->lines->ties
(defun playchds->lines (chds durs)
  (play-ties
   (mapcar #'make-ties 
	   (chds->lines chds))
   durs))

;; REMOVE-RPTS
;; convert repeated notes to rests
;; (remove-rpts '((50 30) 30 (21 30 70) 21 40 40))
;; ((50 30) R (21 70) R (40) R)
(defun remove-rpts (inlist)
  (let ((a-list (mapcar (lambda (x) (if (listp x) x (list x))) inlist)))
    (cons (nth 0 a-list)
          (loop for r from 1 to (- (length a-list) 1)
                collect 
                (if 
                    (set-difference (nth r a-list) (nth (- r 1) a-list))
                  (set-difference (nth r a-list) (nth (- r 1) a-list))
                  'r)))))

;; STUTTER -- convert a note to repeats of same length
;; uses "endlen" to determine if last note should be the remainder ("short")
;; or added to the previous note ("long")
;; (stutter 65 3.5 1.0 'short) = ((65 65 65 65) (1.0 1.0 1.0 .5))
;; (stutter 65 3.5 1.0 'long) = ((65 65 65) (1.0 1.0 1.5))
(defun stutter (pit len stutlen &optional (endlen 'long))
  (if (>= stutlen len) 
    (list (list pit) (list len))
    (let* ((divs (mapcar #'float (multiple-value-list (floor len stutlen))))
           (divlist (loop repeat (car divs) collect (float stutlen)))
           (lenlist (if (eql endlen 'long) 
                      (append (butlast divlist) (list (+ stutlen (cadr divs))))
                      (if (= 0 (cadr divs))
                        divlist
                        (append divlist (cdr divs)))
                      )))
      (list (loop repeat (length lenlist) collect pit)
            lenlist))))

;; STUTLIST -- stutters all notes by single value or cycled list
;; input 'pitsndurs' = list of (pitslist durslist)
(defun stutlist (pitsndurs stutlen &optional (endtype 'long))
  (let* ((pits (first pitsndurs))
         (durs (second pitsndurs))
         (stutcyc (new cycle of stutlen))
         (pitcyc (new cycle of pits))
         (durcyc (new cycle of durs))
         (bigstut (loop repeat (length pits) collect
                        (stutter (next pitcyc) (next durcyc) (next stutcyc) 
                                 endtype))))
    (list (loop for x in bigstut append (first x))
          (loop for y in bigstut append (second y)))))


;; ------------ added since May 2005 ------------------

; IVEC -- construct interval vector
; example: (ivec '(0 1 2 3 5 6 7 9 10)) =  (6 6 7 7 7 3)
(defun ivec (alist)
  (let* ((pform (prime-form alist))
         (pairs (subsets-len pform 2))
         (intlist (loop for x in pairs
                        collect (mod-intv (first x) (second x)))))
    (cdr (loop for y to 6 collect (count y intlist)))))

;; TRANSPVEC -- returns list of all local transpositions
;; ordered from most to least invariant w/chord
;; 'subl' optional arg breaks into sublists by invariance
(defun transpvec (chd &optional (wsubl nil))
  (let* ((cvec (ivec chd))
         (maxi (apply #'max cvec))
         (mini (apply #'min cvec))
         (tvec (no-nils 
                (loop 
                    for x from maxi downto mini collect
                    (if (member x cvec)
                      (no-nils (flatten
                                (loop for y to 5 collect 
                                      (if (eql (nth y cvec) x)
                                        (list (+ y 1) (* -1 (+ y 1))))))))))))
    (if wsubl
      (loop for x in tvec collect
            (loop for y in x collect (transp chd y)))
      (loop for x in tvec append
            (loop for y in x collect (transp chd y))))))

;; MODSUM -- computing a mod sum
(defun modsum (x y &optional (modlen 12))
  (mod (+ x y) modlen))

;; SUMVEC -- interval sum vector of a chord
(defun sumvec (alist &optional (modlen 12))
  (let* ((pairs (append (copylist (subsets-len alist 2) 2)
                        (loop for x in alist collect (list x x))))
         (intlist (loop for x in pairs collect 
                        (modsum (first x) (second x) modlen))))
     (loop for y to (- modlen 1) 
           collect (count y intlist))))

;; ITRANSPVEC -- returns list of all local inversion transp
;; ordered from most to least invariant w/chord
;; 'subl' optional arg breaks into sublists by invariance
(defun itranspvec (chd &optional (wsubl nil))
  (let* ((cvec (sumvec chd))
         (maxi (apply #'max cvec))
         (mini (apply #'min cvec))
         (tvec (no-nils 
                (loop 
                    for x from maxi downto mini collect
                    (if (member x cvec)
                      (no-nils (flatten
                                (loop for y to 11 collect 
                                      (if (eql (nth y cvec) x) y)))))))))
    (if wsubl
      (loop for x in tvec collect
            (loop for y in x collect (transp (invert chd) y)))
      (loop for x in tvec append
            (loop for y in x collect (transp (invert chd) y))))))

;; ENTROPY
;; returns shuffled transpvec or itranspvec
;; can work nicely with 'smoothlist', 'make-poly', etc.
(defun entropy (vec &optional (iflag nil))
  (cons (shuffle vec)
          (loop for x in 
                (mapcar #'shuffle 
                        (if iflag 
                          (itranspvec vec 'subl)
                          (transpvec vec 'subl)))
                append (loop for y in x collect (shuffle y)))))


; TPOINTS
; place (pitch) VEC into PLACES within tp of length TPLEN
; exits at end of PLACES (PLACES count from 0, not 1)
; (tpoints '(.3 .4 .5 .6) '(3 2 4 1) 4) 
;    = (R R R 0.3 R R 0.4 R 0.5 0.6 R R)
(defun tpoints (vec places &optional (tplen 12))
  (let ((indcyc (makecyc (indices tplen)))
        (modplaces (mapcar (lambda (y) (mod y tplen)) places)))
    (append 
     (loop for x in modplaces append
           (loop until (eql (next indcyc) x)
             collect 'r)
           collect (pop vec))
     (loop repeat (- tplen (+ 1 (car (last modplaces))))
       collect 'r))))

;; PLACE-SLOTS -- placing into indexed slots [rests otherwise] 
(defun place-slots (idx val &optional (len 12))
  (loop for n to (- len 1) collect (if (eql idx n) val 'r)))

;; DURS->TPVEC -- takes durations (integers), produces positions mod 'tplen'
;; 'startplace' = offset from 0 mod tplen
;; (durs->tpvec '(3 6 4 9)) = (0 3 9 1 10)
(defun durs->tpvec (int-list &optional (startplace 0) (tplen 12))
  (mapcar (lambda (y) (mod (+ y startplace) tplen)) (melint->line 0 int-list)))

;; SLOTS->TPOINTS -- returns tpoint positions from slotlist
; (slots->tpoints '(r r 3 r r 1 r 2 r 0 0 1 r) 3) = (2 2 1 0 1 2)
(defun slots->tpoints (slotvec &optional (modlen 12))
  (no-nils
   (loop for x to (- (length slotvec) 1) collect
         (if (not (eql 'r (nth x slotvec))) (mod x modlen)))))

;; CONJUNCT-FRAGMENTS -- makes sublists of conjunct elements, 
;; separated by leaps larger than 'jumpsize'
;; thanks Kenny Tilton!
;; can work with rests [January 2006]
(defun conjunct-fragments (melody &optional (jumpsize 12))
  (like-flat
   (loop with fragment
     for (note next-note) on melody
     do (push note fragment)
     unless next-note
     collect (nreverse fragment) into result
     and do (loop-finish)
     when 
     (or
      (flet ((stake (x)		; end frag when changing to/from rests
	       (if (listp (type-of x)) (car (type-of x)) (type-of x))))
	(not (eql (stake next-note) (stake note))))
      (and (numberp note) (numberp next-note)
	   (> (abs (- next-note note)) jumpsize)));end when exceeding jump size
     collect (nreverse fragment) into result
     and do (setf fragment nil)
     finally (return result))))

;; GATHER-PITS -- makes sublists 'gathered' by binary function
;; can work with rests
(defun gather-pits (binaryfunc melody)
  (like-flat
   (loop with fragment
     for (note next-note) on melody
     do (push note fragment)
     unless next-note
     collect (nreverse fragment) into result
     and do (loop-finish)
     when 
     (or
      (flet ((stake (x)		; end frag when changing to/from rests
	       (if (listp (type-of x)) (car (type-of x)) (type-of x))))
	(not (eql (stake next-note) (stake note))))
      (and (numberp note) (numberp next-note)
	   (not (funcall binaryfunc note next-note))))
     collect (nreverse fragment) into result
     and do (setf fragment nil)
     finally (return result))))

;; PARSE-BY-REG -- splitting melody into slotlist by register
;; arbitrary range divisions (octsize)
;; June 2007: melody can include rests
;; (parse-by-reg '(60 2 30 31 61 62)) 
; = ((R 2 R R R R) (R R 30 31 R R) (60 R R R 61 62))
(defun parse-by-reg (melody &optional (octsize 12) (base 0))
  (let* ((mel-octs 
          (mapcar 
	   (lambda (x) (if (eql x 'r) 'r (floor (/ (- x base) octsize)))) 
	   melody))
         (allocts (remove-duplicates (safesort (norests mel-octs)))))
    (loop for x in allocts collect
          (loop for y to (- (length mel-octs) 1) collect
                (if (and (numberp (nth y melody)) 
			 (eql (nth y mel-octs) x)) 
		    (nth y melody) 'r)))))

; RANDSTEPS -- random melody from "startpit" of "length", stepsizes 1 & 2
(defun randsteps (startpit length &optional (lobound 0) (highbound 128))
  (let ((steprange (new range :from startpit :to highbound :downto lobound
                        :stepping (new weighting :of '(-2 -1 1 2)))))
    (next steprange length)))

; RANDSTEPS-SINGLE -- random melody from "startpit" of "length", 
; stepsize 1 only
(defun randsteps-single (startpit length &optional (lobound 0) (highbound 128))
  (let ((steprange (new range :from startpit :to highbound :downto lobound
                        :stepping (new weighting :of '(-1 1)))))
    (next steprange length)))

;; SECTIONS -- breaks up vals into sublists by 'slower' duration cycle
;; inserts 'nil' for sections without attacks
(defun sections (vals durs changedurs)
  (let* ((changeatx (melint->line 0 changedurs))
         (duratx (melint->line 0 durs))
         (changeidx (loop for x in duratx collect
                          (inbetween x changeatx)))
         (rdcd (remove-duplicates changeidx))
         (sec-count (loop for idx to (- (length changedurs) 1) collect 
                          (if (member idx rdcd) (count idx changeidx) 0))))
    (make-poly vals sec-count)))

;; SMOOTH -- takes two lists, makes three
;; by set difference w/ intersection in middle 
;; if no intersection, just returns the two lists
;; (smooth '(1 2 3 4) '(3 4 5 6)) = ((1 2) (3 4) (5 6))
(defun smooth (list1 list2)
  (no-nils  (list (set-difference list1 list2)
                  (intersection list1 list2)
                  (set-difference list2 list1))))

;; SMOOTHLIST -- smooth applied to all successive members
;; of a list
(defun smoothlist (alist)
  (case (length alist) 
    (1 alist)
    (2 (smooth (first (last alist 2)) (car (last alist))))
    (t
     (let ((smb (smoothlist (butlast alist))))
       (append (butlast smb) 
	       (smooth (car (last smb)) 
		       (car (last alist))))))))

;; ALLTRANSP -- all transpositions of a vector within mod
;; returns list of lists
(defun alltransp (alist &optional (modlen 12))
  (loop for x to (- modlen 1) collect
        (mapcar (lambda (s) (mod s modlen)) (transp alist x))))


;; ALTERNATE -- alternate among members of list of lists
;; arbitrary number of lists
;; terminates with shortest list
(defun alternate (lists)
  (let ((minlen 
         (reduce #'min
                 (mapcar #'length lists))))
    (loop for x to (- minlen 1) append
          (loop for st in lists collect (nth x st)))))

;; CHAIN-CONTOUR-UTIL -- enjambs & starts list2 where list1 ends
(defun chain-contour-util (list1 list2)
  (append (butlast list1) (transp-to (car (last list1)) list2)))

;; CONTOUR-CHAIN -- makes one big contour from list
;; resets to 0 as min
(defun contour-chain (contourlist)
  (let ((rawlist 
   (if (eql (length contourlist) 2)
     (chain-contour-util (first contourlist) (second contourlist))
     (chain-contour-util (contour-chain (butlast contourlist))
                         (car (last contourlist))))))
    (transp rawlist (* -1 (apply #'min rawlist)))))

;; DIRECTIONS -- returns 1/-1 indices for melodic up/down
;(directions '(2 3 9 6 1 3)) = (1 1 -1 -1 1)
(defun directions (melody)
  (let ((mymelint (melint melody)))
    (loop for x in mymelint collect
          (if (eq x (abs x)) 1 -1))))

;; AU-CONTRAIRE -- makes consonant contrary-motion counterline 
;; uses oblique & consvec options, passed to "consn-p" utility
(defun au-contraire (melody duxpoint &optional 
                            (oblq nil) (consvec '(3 4 8 9)))
  (let* ((mdirections
          (mapcar (lambda (x) (* x -1)) (directions melody)))
         (meltop (first melody))
         (starter (if (consn-p meltop duxpoint consvec)
                    duxpoint
                    (nextcons meltop duxpoint (pick 1 -1) oblq consvec))))
    (if (eql (length melody) 2)
      (cons starter 
            (list (nextcons (second melody) starter 
                            (car mdirections) oblq consvec)))
      (let ((last-ac (au-contraire (butlast melody)
                                   starter oblq consvec)))
        (append last-ac
                (list (nextcons (car (last melody))
                                (car (last last-ac))
                                (car (last mdirections))
                                oblq consvec)))))))

;;;;;;;;;; working with processes & sprouts

;; LEN-EQL -- simple utility
;; returns two lists, each of min length btwn the two
;; returns 'nil' if either is not a list
(defun len-eql (list1 list2)
  (if (and (listp list1) (listp list2))
    (let ((minlen (min (length list1) (length list2))))
      (list (subseq list1 0 minlen)
            (subseq list2 0 minlen)))))

;; PLISTS -- utility to get pits & durs to match
;; returns list: (pits durs sum-of-durs) 
(defun plists (inpits indurs)
  (let* ((minlists (len-eql inpits indurs))
         (pitlen (length inpits))
         (pits (if minlists (first minlists) inpits))
         (durs (cond (minlists (second minlists))
                     ((pattern? indurs) (next indurs pitlen))
                     (t (copylist (list indurs) pitlen)))))
    (list pits durs (apply #'+ durs))))

;; SPLAY -- the simplest: plays pits/durs
;; durs may be list, pattern, or simple value
;; added optional channel argument Nov. 2005
(defun splay (inpits indurs &optional (chan 0))
  (let* ((pl (plists inpits indurs))
         (pits (first pl))
         (durs (second pl)))
    (process for x in pits
             for dur in durs
             output (multievent 'midi :keynum
                                :channel chan
                                :keynum x
                                :time (now)
                                :duration dur)
             wait dur)))

;; PLAY-SD -- quick way to play output from slots->durs
(defun play-sd (slotsdurs basedur)
  (splay (first slotsdurs)
	 (sum-across basedur (second slotsdurs))))

;; NOTE: pass "-E 'I'patchno/[chan+1]" to timidity to get polyphony

;; PITSEQ -- a separate utility for pits only
(defun pitseq (pits levels)
  (loop for x in levels append
        (transp pits x)))

;; SPSEQUENCE -- returns pits/durs at various transp levels (in order)
(defun spsequence (inpits indurs levels)
  (let* ((pl (plists inpits indurs))
         (pits (first pl))
         (durs (second pl))
         (seqlen (third pl)))
    (process for level in levels
             sprout (splay (transp pits level) durs)
             wait seqlen)))

;; SQUEEZEDURS -- truncates & otherwise adjusts "durs" to sum to "len"
(defun squeezedurs (durs len)
  (let* ((sublens (cdr (melint->line 0 durs)))
         (shortlist (loop for x to (- (length durs) 1)
                          until (>= (nth x sublens)
                                    len)
                          collect (nth x durs)))
         (durlen (car (last sublens))))
    (cond 
      ((not shortlist) (list len));; len shorter than first duration
      ((>= len durlen);; len after last attack  
       (append (butlast durs) 
               (list (+ (car (last durs)) (- len durlen)))))
      (t (append shortlist
                 (list (- len (apply #'+ shortlist))))))))

;; PATT-TO-SUM -- return sequence of pattern's "next"s that sum to len
; (patt-to-sum (makecyc '(2 3)) 9) = (2 3 2 2)
;; added Oct. 2006
(defun patt-to-sum (patt len)
  (let ((rawvec
	 (loop 
	     for dur = (next patt)
	     collect dur into durvec
	     sum dur into dursum
	     while (< dursum len)
	     finally (return durvec))))
    (squeezedurs rawvec len)))

;;; FRAG -- returns a fragment
(defun frag (pits durs len)
  (let* ((sdurs (squeezedurs durs len))
         (spits (subseq pits 0 (length sdurs))))
    (process for x in spits
             for dur in sdurs
             until (= (now) len)
             output (multievent 'midi :keynum
                                :keynum x
                                :time (now)
                                :duration dur)
             wait dur)))

; FRAGS -- the main process (calls fragments)
(defun frags (pits durs lengths)
  (process for len in lengths
           sprout (frag pits durs len)
           wait len))

;; ISO -- returns pits/durs in isorhythm
(defun iso (pits durs)
  (process 
    with pitcyc = (makecyc pits)
    for dur in (copylist durs
                         (/ (lcm (length pits) (length durs))
                            (length durs)))
    output (multievent 'midi :keynum
                       :keynum (next pitcyc)
                       :time (now)
                       :duration dur)
    wait dur))

;; TROPE -- interrupts process to insert trope on "test"
;; trope begins simultaneously with 'passed' test
;; "testpd" defaults to testing on current pit [otherwise dur]
(defun trope (inpits indurs tropits trodurs test &optional (testpd nil))
  (let* ((pl (plists inpits indurs))
         (pits (first pl))
         (durs (second pl)))
    (process for pit in pits
             for dur in durs
             if (funcall test (if testpd dur pit)) 
             sprout (splay (list pit) dur)
             and sprout (splay tropits trodurs)
             and wait (- (max dur (apply #'+ trodurs)) dur)
             else
             sprout (splay (list pit) dur)
             wait dur)))

;; DURWEIGHT -- making durvec from pitvec (chords last longer)
(defun durweight (pitvec &optional (basedur 1))
  (if (pattern? basedur)
    (loop for x in pitvec collect
          (apply #'+ (next basedur (if (listp x) (length x) 1))))
    (loop for x in pitvec collect
          (* (if (listp x) (length x) 1) basedur))))

;; LEAPDUR -- making durvec from pitvec (leaps last longer)
;; added January 2006
(defun leapdur (pitvec &optional (basedur 1) (melscale 1))
  (let* ((melin (mapcar #'abs (melint pitvec)))
         (mults
          (loop for m in melin collect 
                (cond ((< m (* melscale 3)) 1)
                      ((< m (* melscale 5)) (pick 1 2))
                      (t (pick 2 3))))))
    (if (pattern? basedur)
        (loop for x in mults collect
              (apply #'+ (next basedur x)))
        (transp mults basedur #'*))))

;; FILTER -- returns list according to "test"
;; failed entries removed
(defun filter (etest alist)
  (no-nils (loop for n in alist collect
        (if (funcall etest n) n))))

;; EXTRACT -- returns slotlist according to "test"
;; failed entries return 'r
(defun extract (etest alist)
  (loop for n in alist collect
        (if (funcall etest n) n 'r)))

;; EXTRACT-PAIRS -- returns slotlist according to "test"
;; failed entries return 'r
(defun extract-pairs (etest alist)
  (let ((places
	 (remove-duplicates
	  (loop for n to (- (length alist) 2) append
		(if (funcall etest (nth n alist) (nth (+ n 1) alist)) 
		    (list n (+ n 1)))))))
    (loop for n to (- (length alist) 1) collect 
	  (if (member n places) (nth n alist) 'r))))

;; SLOWLINE -- returns slotlist from list by cycled durvec
;; ['1' now allowed in 'durvec' - Aug. 2007]
(defun slowline (alist durvec &optional (offset 0))
  (let* ((shortlist (subseq alist offset (length alist)))
         (prefix (loop repeat offset collect 'r))
         (mp (not-flat (make-poly shortlist durvec))))
    (no-nils (append prefix
                     (loop for x in mp 
                           collect (car x)
                           append (fill (cdr x) 'r))))))

;; SUBLINEPITS -- ez macro for extract/slowline
(defmacro sublinepits (extracted) 
  `(first (slots->durs ,extracted)))

;; SUBLINEDURS -- ez macro for extract/slowline
(defmacro sublinedurs (extracted) 
  `(second (slots->durs ,extracted)))

;; APPLY-ACROSS -- apply to corresponding members of two lists
(defun apply-across (op list1 list2)
  (let* ((leneq (len-eql list1 list2))
         (leneq1 (first leneq))
         (leneq2 (second leneq)))
    (loop for x to (- (length leneq1) 1) collect
          (funcall op (nth x leneq1) (nth x leneq2)))))

;; ORNADURS -- divides (accelerates) durations for all sublists
;; June 2007: 'treeflag' added
(defun ornadurs (inpits indurs &optional (treeflag nil))
  (let* ((pl (plists inpits indurs))
         (pits (first pl))
         (durs (second pl)))
    (if treeflag
	(loop for n to (- (length pits) 1) collect
	      (let* ((nthpit (nth n pits))
		     (nthdur (nth n durs))
		     (nlen (if (listp nthpit) (length nthpit) 1)))
		(loop repeat nlen collect (/ nthdur nlen))))
	(loop for n to (- (length pits) 1) append
	      (let* ((nthpit (nth n pits))
		     (nthdur (nth n durs))
		     (nlen (if (listp nthpit) (length nthpit) 1)))
		(loop repeat nlen collect (/ nthdur nlen)))))))

;; some stepwise-chordal stuff

;; TRAVERSE-PTS -- utility for "fromto"
(defun traverse-pts (list1 list2)
  (loop for x to (- (length list1) 1) collect
        (screamer-user::all-btwn (nth x list1) (nth x list2))))

;; MATCH2LISTS -- returns all bipartite matches btwn 2 lists
; (match2lists '(1 (2 3)) '(5 6)) = ((1 5) (1 6) ((2 3) 5) ((2 3) 6))
;; added Feb. 2006
;; June 2006: "flatflag" combines sublists
;; [default = preserves sublists]
(defun match2lists (inlist1 inlist2 &optional (flatflag nil))
  (loop for x in inlist1 append
        (loop for y in inlist2 collect
              (if flatflag
                  (cond ((and (listp x) (listp y)) (append x y))
                        ((listp x) (append x (list y)))
                        ((listp y) (cons x y))
                        (t (list x y)))
                  (list x y)))))

;; ALL-COMBOS -- bipart-matches a series of lists
;; added Feb. 2006
; (all-combos '((9 2 3) (10 30) (5 6)) 'flat) = 
; ((9 10 5) (9 10 6) (9 30 5) (9 30 6) 
;  (2 10 5) (2 10 6) (2 30 5) (2 30 6)
;  (3 10 5) (3 10 6) (3 30 5) (3 30 6))
;; June 2006: added "flatflag"
(defun all-combos (inlists &optional (flatflag nil))
  (cond ((eql 1 (length inlists))
         inlists)
        ((eql 2 (length inlists))
         (match2lists (first inlists) (second inlists) flatflag))
        (t (match2lists 
            (if flatflag (car inlists)
                (loop for c in (car inlists) collect (list c)))
            (all-combos (cdr inlists) flatflag) 
            'flat))))

;; FROMTO -- all intermediate lists (btwn & incl) two lists of equal length
;; order is important! -- each member moves to the corresponding member
;; fixed Feb. 2006 to use 'all-combos' instead of 'do-iter'
(defun fromto (list1 list2)
  (all-combos
   (traverse-pts list1 list2)
   'flat))

;; STEP-INCREM -- single move between lists
;; utility for 'fromto-stepper'
(defun step-increm (slist elist)
  (let* ((listdiffs (map 'list #'- elist slist))
         (onlydiffidx (no-nils (loop for n to (- (length listdiffs) 1) collect
                  (if (not (eql 0 (nth n listdiffs))) n))))
         (stepidx (pickl onlydiffidx)))
    (loop for n to (- (length slist) 1) collect
          (if (eql n stepidx) (+ (nth n slist) (/ (nth n listdiffs)
                                                 (abs (nth n listdiffs))))
                                 (nth n slist)))))

; FROMTO-STEPPER -- more refined 'fromto'
; avoids retracing steps from 'slist' to 'elist'
; [randomly selected set of steps] 
; (fromto-stepper '(0 9) '(5 6)) 
;  = ((0 9) (1 9) (2 9) (3 9) (4 9) (4 8) (5 8) (5 7) (5 6))
(defun fromto-stepper (slist elist)
  (let* ((listdiffs (map 'list #'- elist slist))
         (absdiffs (loop for x in listdiffs collect (abs x)))
         (totdiff (apply #'+ absdiffs)))
    (cons slist
          (when (plusp totdiff)
            (fromto-stepper (step-increm slist elist) elist)))))

;; EACH-DISTANCE -- list of distances btwn each member
(defun each-distance (list &optional (ordered-flag nil))
         (mapcar (lambda (x y) (listdist x y ordered-flag))
                 list (rest list)))

;; TOTAL-DISTANCES -- total distance btwn each successive member of a list
;; formerly 'city-blocks' - ordered or unordered
(defun total-distances (list &optional (ordered-flag nil))
  (apply #'+ (each-distance list ordered-flag)))

;; REPLACED BY 'EACH-DISTANCE' ABOVE
;; CITY-BLOCKS -- measure of difference btwn lists
;; returns a list of step-by-step differences
;; (defun city-blocks (list)
;;   (mapcar #'listdist list (rest list)))

;; BESTPATH -- finds permutation of a list with 
;; smoothest (city-block/stepwise) path from first to last entry
;; solved by brute force -- very slow for > 9 chords (10 chds = 30 min.)
;; note: this is a Traveling Salesman Problem (TSP) with
;; "city-blocks" as distance
(defun bestpath (alist &optional (ordered-flag nil))
  (let* ((list1 (first alist))
         (list2 (car (last alist)))
         (ftperms (loop for x in 
                        (permutations (butlast (cdr alist))) collect
                        (append (list list1) x (list list2)))))
    (first
     (sort ftperms
           (lambda (x y) (< (total-distances x ordered-flag)
                            (total-distances y ordered-flag)))))))

;; CONCORDE-EDGEWEIGHTS
;; returns edgeweight matrix -- for large TSP problems 
;; paste to a file and call it with "concorde.pl" to get best path
;; ["concorde.pl" returns list of indices in best order]
(defun concorde-edgeweights (chdlist)
  (loop for c in chdlist collect
        (loop for d in chdlist collect (listdist c d))))

;; POPOUT -- removes random items from a list
;; utility for 'lenfit'
(defun popout (alist &optional (holes 1))
  (let ((noluck (random (length alist))))
    (if (eql holes 1)
      (no-nils (loop for n to (- (length alist) 1) collect
                     (if (eql n noluck) 'nil (nth n alist))))
      (popout (popout alist (- holes 1))))))

;; POPIN -- adds random repeat to a list
;; utility for 'lenfit'
(defun popin (alist &optional (fills 1))
  (let ((goodluck (random (length alist))))
    (if (eql fills 1)
      (loop for n to (- (length alist) 1) append
            (if (eql n goodluck)  
              (loop repeat 2 collect (nth n alist))
              (list (nth n alist))))
      (popin (popin alist (- fills 1))))))

;; LENFIT -- randomly truncate or repeat entries to match len
;; note: first & last entries stay the same
(defun lenfit (alist len)
  (let ((innerlist (butlast (cdr alist)))
        (list-s (list (first alist)))
        (list-e (last alist))
        (lendiff (- len (length alist))))
    (cond ((minusp lendiff) 
           (append list-s (popout innerlist (- (length alist) len)) list-e))
          ((plusp lendiff)
           (append list-s (popin innerlist (- len (length alist))) list-e))
          (t alist))))

;; CONTAINSV -- T if chord contains subset of given prime-form 
;; "prime-only-flag" looks for only strict transpositions, not inversions
(defun containsv (chd tstform &optional (prime-only-flag nil))
  (let* ((ssets (subsets-len chd (length tstform))))
    (if prime-only-flag
      (intersection (alltransp tstform) 
                    (loop for x in ssets collect (mod12 x))
                    :test #'list-eql)
      (member (prime-form tstform) (mapcar #'prime-form ssets) 
              :test #'list-eql))))

;; PRIMEFILT -- filters list for pc vector
;; [vector may be smaller than matched chord]
;; "prime-only-flag"= T returns only strict transpositions, not inversions 
(defun primefilt (alist pcvec &optional (prime-only-flag nil))
  (no-nils (loop for chd in alist collect
                 (if (containsv chd pcvec prime-only-flag)
                   chd))))

;; REPEATER -- repeats each entry cyclically
;; (repeater (indices 5) '(2 3)) = (0 0 1 1 1 2 2 3 3 3 4 4)
(defun repeater (inlist rpter)
  (let* ((adj-rpter (if (and (listp rpter)
                             (< (length rpter) (length inlist)))
                      (makecyc rpter) rpter))
         (pl (plists inlist adj-rpter))
         (ins (first pl))
         (rps (second pl)))
    (loop for n to (- (length ins) 1) append
          (loop repeat (nth n rps) collect (nth n ins)))))


;; ------------ added since August 2005 ------------------

;; LISTSUB -- replaces 'olds' with 'news' in 'inlist' 
(defun listsub (news olds inlist)
  (sublis (pairlis olds news) inlist))

;; SHUFFLE-ALL -- shuffles all lists in 'alist'
(defun shuffle-all (alist)
  (mapcar #'shuffle (not-flat alist)))

;; RARPEGG -- play members of list w/no immediate repeats
(defun rarpegg (alist len)
  (let* ((idxheap (new heap of (indices (length alist))))
        (idxlist (next idxheap len)))
    (loop for x in idxlist collect (nth x alist))))

;; RAND-ARPEGG -- apply 'rarpegg' to all sublists
;; similar to 'arpegg' but selects randomly from sublists
;; 'lens' can be integer, list, or pattern
(defun rand-arpegg (alist lens)
  (let ((listvec (if (listp lens) (makecyc lens))))
    (loop for x in alist collect
          (rarpegg x (cond  
                       ((pattern? lens) (next lens))
                       ((listp lens) (next listvec))
                       (t lens))))))

;; SUMSORT -- sorts list of lists by sum
;; non-destructive
(defun sumsort (alist)
  (let ((pholder (loop for x in alist collect x)))
    (sort pholder (lambda (x y) 
                    (< (apply #'+ x) (apply #'+ y))))))

;; SUMSORT-DN -- descending 'sumsort'
;; non-destructive
(defun sumsort-dn (alist)
  (let ((pholder (loop for x in alist collect x)))
    (sort pholder (lambda (x y) 
                    (and (> (apply #'+ x) (apply #'+ y)))))))

;; TOPSORT -- sorts list of lists by highest member
;; non-destructive
(defun topsort (alist)
  (let ((pholder (loop for x in alist collect x)))
    (sort pholder (lambda (x y) 
                         (< (apply #'max x) (apply #'max y))))))

;; TOPSORT-DN -- descending 'topsort'
;; non-destructive
(defun topsort-dn (alist)
  (let ((pholder (loop for x in alist collect x)))
    (sort pholder (lambda (x y) 
                         (> (apply #'max x) (apply #'max y))))))

;; TOPSUMSORT -- sorts sums within each max [ascending]
(defun topsumsort (alist)
  (let* ((tsort (topsort alist))
         (maxies (remove-duplicates 
                  (loop for x in tsort collect (apply #'max x))))
         (tsubs (loop for x in maxies collect
                      (filter (lambda (lst) 
				(eql x (apply #'max lst)))
			      tsort))))
    (loop for ts in tsubs append (sumsort ts))))

;; TOPSUMSORT-DN -- sorts sums within each max [descending]
(defun topsumsort-dn (alist)
  (let* ((tsort (topsort-dn alist))
         (maxies (remove-duplicates 
                  (loop for x in tsort collect (apply #'max x))))
         (tsubs (loop for x in maxies collect
                      (filter (lambda (lst) 
				(eql x (apply #'max lst)))
			      tsort))))
    (loop for ts in tsubs append (sumsort-dn ts))))

;; --- MTSPACE -- 
;; rhythmic method for transitioning between subdivisions

;; building a graph as a function -- returns letters
;; initval = starting index as it appears in the graph (A=0, etc.)
(defun mtspacef (&optional (initval 0))
  (new graph :of                                   ; for 2&3:  initval
       `((A :id A :to ,(new weighting of '(B F H K))) ; 1          0
         (B :id B :to ,(new weighting of '(A C E)))   ; 2          1
         (C :id C :to ,(new weighting of '(B D)))     ; 4          2
         (D :id D :to ,(new weighting of '(C)))       ; 8          3
         (E :id E :to ,(new weighting of '(B F)))     ; 6          4

         (F :id F :to ,(new weighting of '(A E G)))   ; 3          5
         (G :id G :to ,(new weighting of '(F)))       ; 9          6

         (H :id H :to ,(new weighting of '(A I L)))   ; 1/2        7
         (I :id I :to ,(new weighting of '(J H)))     ; 1/4        8
         (J :id J :to ,(new weighting of '(I)))       ; 1/8        9

         (K :id K :to ,(new weighting of '(A L)))     ; 1/3        10
         (L :id L :to ,(new weighting of '(H K))))    ; 1/6        11
       :starting-node-index initval))

;; fast 'mtspace' only
;; initval = starting index as it appears in the graph (A=0, etc.)
(defun fastspace (&optional (initval 0))
  (new graph :of                                   ; for 2&3:  initval
       `((A :id A :to ,(new weighting of '(H K))) ; 1              0
         (H :id H :to ,(new weighting of '(I L)))   ; 1/2          1
         (I :id I :to ,(new weighting of '(J H)))     ; 1/4        2
         (J :id J :to ,(new weighting of '(I)))       ; 1/8        3
         (K :id K :to ,(new weighting of '(A L)))     ; 1/3        4
         (L :id L :to ,(new weighting of '(H K))))    ; 1/6        5
       :starting-node-index initval))

;; RHYTPAIRVEC -- constructions lookup vector for two subdivs
;; note: subdivs should be relatively prime
(defun rhytpairvec (int1 int2)
  (let ((num1 (min int1 int2))
        (num2 (max int1 int2)))
  (list 1 num1 (* num1 num1) (* num1 num1 num1) (* num1 num2)
        num2 (* num2 num2)
        (/ num1) (/ (* num1 num1)) (/ (* num1 num1 num1))
        (/ num2) (/ (* num1 num2)))))

;; MTRPTLEN -- multiplier for a fast subdivision
(defun mtrptlen (tactlen int1 int2)
  (let ((rpvec (rhytpairvec int1 int2)))
    (case (position tactlen rpvec) 
      (0 1)
      (1 1)
      (2 1)
      (3 1)
      (4 1)
      (5 1)
      (6 1)
      (7 int1)
      (8 int1)
      (9 int1)
      (10 int2)
      (11 (pick int1 int2)))))

;; MTS-SUBS -- makes vector of rhythms
(defun mts-subs (inlist rpvec)
  (listsub rpvec '(A B C D E F G H I J K L) inlist))

;; MT-RHYVEC -- constructs rhythm vector with random-length tactus areas
(defun mt-rhyvec (int1 int2 len &optional (mtinit 0))
  (let ((subs (mts-subs 
               (next (fastspace mtinit) len)
               (rhytpairvec int1 int2))))
    (loop for sub in subs append
          (loop repeat (* (mtrptlen sub int1 int2)
                          (+ 3 (random 5)))
            collect sub))))

;; MT-RHYAREAS -- constructs rhythm vector according to 
;; 'lens' = lengths of each section (integers)
(defun mt-rhyareas (int1 int2 lens &optional (mtinit 0))
  (let* ((lenslen (length lens))
         (subs (mts-subs
                (next (fastspace mtinit) lenslen)
                (rhytpairvec int1 int2))))
    (loop for n to (- lenslen 1) append
          (loop repeat (/ (nth n lens)
                          (nth n subs))
            collect (nth n subs)))))

;; 

;; EMBED --- transform each point into a transposed figure
;; adjusted Feb. 2006
; (embed '(2 1) '(4 3 2)) = ((6 5 4) (5 4 3))
(defun embed (targetmel figure &optional (flatp nil))
  (let ((raw (loop for x in targetmel collect (transp figure x))))
    (if flatp (flatten raw) raw)))

;; EXPAND -- uses any # of embedded figures
;; revised Feb. 2006
;;   (expand '((2 1) (5 6) (4 3 2))) 
;; = (((11 10 9) (12 11 10)) ((10 9 8) (11 10 9)))
(defun expand (lists &optional (flatp nil))
  (cond ((eql 1 (list-length lists)) (car lists))
        ((eql 2 (list-length lists)) (embed (car lists) (cadr lists) flatp))
        (t (embed (car lists) 
                  (expand (cdr lists)) 
                  flatp))))

;; SELF-EXPAND -- self-embeds melody by a 'factor' [idx]
;; fixed June 2007
(defun self-expand (mel indx &optional (flatp nil))
  (deepfunc (lambda (x) (transp x (* -1 (- indx 1) (car mel))))
	    (expand (loop repeat indx collect mel) flatp)))

;; contour stuff

;; LISTMEAN -- quick mean
(defun listmean (alist)
  (round (/ (apply #'+ alist) (length alist))))

;; CONTOUR-EQUIV -- determining equivalent contour 
;; by converting large durations into repeats
; (contour-equiv '(60 67 62) '(2 9 4)) = (60 67 67 62)
(defun contour-equiv (inpits inlens)
  (let* ((rptindx (hits->ints inlens))
         (lm (listmean rptindx))
         (lens (loop for x in rptindx collect
                     (+ 1 (floor (/ x lm))))))
    (loop for n to (- (length inpits) 1) append
          (loop repeat (nth n lens) collect (nth n inpits)))))

;; TAKE-SUBCONTOURS
;; returns two lists:
;; 1. contours of each selected sublist
;; 2. 'slower' contour of subcontour initval sequence
;(take-subcontours '(51 50 52 54 54 54 54 57 56 55) '(3))
; =  (((1 0 2) (0 0 0) (0 2 1) (0)) (0 1 1 2))
(defun take-subcontours (alist clens)
  (let* ((mp (make-poly alist clens))
         (minics (loop for x in mp collect
                       (take-contour x)))
         (minics-inits (loop for m in mp collect 
                             (car m))))
    (list minics (take-contour minics-inits))))

;; TAKE-NTN-CONTOUR
;; note-to-note "up/down" contour [M. Friedmann's CAS]
;; (take-ntn-contour '(5 4 9 2)) = (-1 1 -1)
(defun take-ntn-contour (alist)
  (let* ((mi (melint alist)))
    (loop for x in mi collect
          (cond ((plusp x) 1)
                ((minusp x) -1)
                (t 0)))))

;; GIVE-NTN-CONTOUR -- gives contour to melody
(defun give-ntn-contour (melody ntn-ctr &optional (modlen 12))
  (if (eql (length ntn-ctr) (- (length melody) 1))
      (let ((melt (mapcar (lambda (x) (mod x modlen)) (melint melody))))
	(melint->line (car melody)
		      (map 'list
			   (lambda (m c) (if (plusp c)
					     m
					     (* -1 (- modlen m))))
			   melt
			   ntn-ctr)))))

;; note -- smooth transitions btwn contours:
;(bestpath
; (fromto '(-1 1 -1) '(1 1 0)))
;; OR
; (fromto-stepper '(-1 1 -1) '(1 1 0))

;; ntn->clist
;; [unique solution, but not the only possibility]
;; (ntn->clist '(-1 -1 -1 0 1 -1)) = (3 2 1 0 0 1 0)
(defun ntn->clist (antn)
  (take-contour (melint->line 0 antn)))

;; see NTN->CLISTS above [nondeterministic; returns all clists]

;; SAME-SHAPE
;; replicates the contour of "frag" in the domain of "alist"
;; returns list of lists
(defun same-shape (frag alist)
  (let* ((antn (take-ntn-contour frag))
         (srtdlist (remove-duplicates (safesort alist)))
         (binsize (length srtdlist))
         (all-clists (ntn->clists antn binsize)))
    (loop for cl in all-clists collect
          (listsub srtdlist (indices binsize) cl))))

;; C-HEIGHT -- height of a contour = highest index
(defun c-height (acontour)
  (+ 1 (apply #'max acontour)))

;; C-WIDTH -- width of a contour = (max)-(min)+1
;; (c-width '(5 3 4))
(defun c-width (acontour)
  (+ 1 (- (apply #'max acontour)
          (apply #'min acontour))))

;; C-DISTANCE -- total # of steps in a contour
; (c-distance '(5 2 3)) = 4
(defun c-distance (acontour)
    (apply #'+ (mapcar #'abs (melint acontour))))

;; SMOOTH->JUMPY
;; sorts contour list by ascending c-distance
(defun smooth->jumpy (cntrlist)
  (let ((pholder (loop for x in cntrlist collect x)))
    (sort pholder #'< :key #'c-distance)))

;; JUMPY->SMOOTH
;; sorts contour list by descending c-distance
(defun jumpy->smooth (cntrlist)
  (let ((pholder (loop for x in cntrlist collect x)))
    (sort pholder #'> :key #'c-distance)))

;; SORT-BY-WIDTH
;; sorts contour list by width
(defun sort-by-width (cntrlist)
  (let ((pholder (loop for x in cntrlist collect x)))
    (sort pholder #'< :key #'c-width)))

;; SORT-BY-START
;; sorts list of lists by first member
(defun sort-by-start (listlist)
  (let ((pholder (loop for x in listlist collect x)))
    (sort pholder #'< :key #'car)))

;; TEMPO-SHAPE -- returns 'mini' duration list
;; 'totlen' is assumed to be an integer
;; any remainder is given to the last div
(defun tempo-shape (divlist totlen)
  (let* ((divmult (floor (/ totlen (length divlist)))))
    (loop for x in divlist append
          (loop repeat divmult append
                (ferney '(1) (list x))))))

;; RESCLASSVEC -- building texture/stress vector from resclasses
;; (resclassvec 3 5)=(2 0 0 1 0 1 1 0 0 1 1 0 1 0 0)
(defun resclassvec (&rest rclasses)
  (let* ((rlcm (apply #'lcm rclasses))
         (lcmidcs (cdr (indices rlcm)))
         (rcvecs 
          (loop for rc in rclasses collect
                (cons 1
                      (loop for n in lcmidcs collect
                            (if (eql 0 (mod n rc)) 1 0))))))
    (loop for n to (- rlcm 1) collect
          (loop for rcv in rcvecs sum (nth n rcv)))))

;; MEL-STRESS -- uses 'stresslist' to determine whether to attack
;; makes slot list w/rests
;; "skewfactor" = 0 to 10; default 8 (rescales to .1--.9 spct)
;; *Note* stress 0 always becomes a rest
(defun mel-stress (mel stresslist &optional (skewfactor 8))
  (let* ((smax (apply #'max stresslist))
         (smin (apply #'min stresslist))
         (skewspread (* .05 skewfactor))
         (spctvec (loop for x in stresslist 
                        collect 
                        (if (eql x 0) 0
			    (rescale x smin smax
				     (- .5 skewspread)
				     (+ .5 skewspread)))))
         (spctcyc (new cycle of spctvec)))
    (no-nils
     (loop while mel collect
	   (if (odds (next spctcyc)) (pop mel) 'r)))))

;; PICK-STRESS -- uses 'stresslist' to determine whether to attack
;; makes slot list w/rests; picks from list for each attack
;; numvec = list of lists, picked numbers [high to low stress]
;; length of numvec should equal the number of different entries in list 
;;    (excluding zero)
;; "skewfactor" = 0 to 10; default 8 (rescales to .1--.9 spct)
;; *Note* stress 0 always becomes a rest
;; Aug. 2006: fixed 'numvec' stress order
(defun pick-stress (len numvec stresslist &optional (skewfactor 8))
  (let* ((smax (apply #'max stresslist))
         (smin (apply #'min stresslist))
         (skewspread (* .05 skewfactor))
         (srtedstress (safesort (remove-duplicates stresslist)))
         (non0srtedstress (remove-if #'zerop srtedstress))
         (rawspctvec 
          (loop for x in srtedstress
                collect (if (eql x 0) 0
                            (rescale x smin smax
                                     (- .5 skewspread)
                                     (+ .5 skewspread)))))
         (spctvec (if (eql (length non0srtedstress)
                           (length srtedstress))
                      (cons 0 rawspctvec)
                      rawspctvec))
         (stresscyc (new cycle of stresslist)))
    (loop for nxtcyc in (next stresscyc len) collect
          (if (odds (nth nxtcyc spctvec))
              (pickl (nth (position nxtcyc non0srtedstress) numvec))
              'r))))

;; POLY-STRESS -- uses 'stresslist' to determine size of chord
;; returns texture vector
;; "skewfactor" = 0 to 10; default 8 (rescales to .1--.9 spct)
;; *Note* stress 0 always becomes a rest
(defun poly-stress (mel stresslist &optional (skewfactor 8))
  (let* ((smax (apply #'max stresslist))
         (smin (apply #'min stresslist))
         (skewspread (* .05 skewfactor))
         (mellen (length mel))
         (spctvec (loop for x in stresslist 
                        collect 
                        (if (eql x 0) 0
                            (rescale x smin smax
                                     (- .5 skewspread)
                                     (+ .5 skewspread)))))
         (spctcyc (new cycle of spctvec))
         (polyvec (loop for nxtsp = (next spctcyc)
                        for sp = (if (odds nxtsp) 
                                     (round (random (+ nxtsp 2))) 
                                     0)
                        collect sp
                        sum sp into sum
                        until (>= sum mellen))))
    (make-poly mel polyvec)))

;;; Viertu's "Diachro-measure"

;; CHROM -- returns a list's chromatic factor
(defun chrom (alist)
  (let* ((srtdlist (safesort (remove-duplicates (mod12 alist))))
         (adjlist (append srtdlist (list (+ 12 (first srtdlist))))))
    (length (remove 1 (melint adjlist)))))

;; DIA -- returns a list's diatonic factor
(defun dia (alist)
  (let* ((srtdlist (safesort (remove-duplicates (mod12 (modmult alist 7 12)))))
         (adjlist (append srtdlist (list (+ 12 (first srtdlist))))))
    (length (remove 1 (melint adjlist)))))

;; DIACHROM -- returns a list's "diachromatic" ratio
(defun diachrom (alist)
  (/ (dia alist) (chrom alist)))

;; DIACHROM-FILT -- returns sublist of vectors that have "diachromval"
(defun diachrom-filt (alist diachromval)
  (let ((rawlist
	 (filter
	  (lambda (x) (eql (diachrom x) diachromval))
	  alist)))
    (if rawlist rawlist (list 'r))))

;; SAME-DIACHRON -- returns all vectors with same diachrom factor 
;; can choose lengths of output [defaults to same length]
(defun same-diachrom (alist &optional (lens (length alist)))
  (diachrom-filt (subsets-len (indices 12) lens) (diachrom alist)))

;; DIACHROM-SETS -- makes sublists based on equal diachrom factors
;; -> most consonant *first*!
(defun diachrom-sets (alist)
  (let* ((dcs (safesort (remove-duplicates (mapcar #'diachrom alist)))))
    (loop for dc in dcs collect
	  (no-nils (loop for a in alist collect (if (eql (diachrom a) dc) a))))))

;;; misc. utilities

;; NORPT-RAND -- constructs nonrepeating vector
;; for use with 'weighting' e.g., "(new weighting of (norpt-rand (indices 10)))"
(defun norpt-rand (alist)
  (loop for x in alist collect
        (list x :max 1)))

;; plotter stuff

;; CORRECT-PITLIST -- utility; converts 1-lists into nums
(defun correct-pitlist (pits)
  (loop for x in pits collect
        (if (or (numberp x) (eql x 'r)) 
            x
            (if (eql 1 (length x)) (car x) x))))

;; SPLOTTER -- simple plot of pits/durs
(defun splotter (inpits indurs)
  (let* ((plst (plists inpits indurs))
         (outpits (correct-pitlist (first plst)))
         (outdurs (second plst))
         (plotpits (flatten outpits))
         (plotatx (repeater 
                    (butlast (melint->line 0 outdurs))
                    (take-poly outpits))))
    (plotter :view :point 
             :y-axis :keynum 
             :x-axis (axis :seconds :increment 4)
             (loop for p in plotpits
                   for a in plotatx
                   collect a collect p))))

;;; QUANTRANPLOT -- places pattern-pits into plot
(defun quantranplot (input-pits rsegs quants &optional (flat-output nil))
  (let* ((qd-out (quantran rsegs quants 'rp))
         (qdurs (first qd-out))
         (qpoly (second qd-out))
         (inpits (if (pattern? input-pits) 
                     (if flat-output
                         (next input-pits (- (length rsegs) 1))
                         (next input-pits (apply #'+ qpoly)))
                     input-pits))
         (cpits (if flat-output 
                    inpits
                    (make-poly inpits qpoly)))
         (outplist (plists cpits qdurs))
         (outdurs (squeezedurs (second outplist) (car (last rsegs))))
         (outpits (correct-pitlist (first outplist)))
         (plotpits (flatten outpits))
         (plotatx (repeater 
                    (butlast (melint->line 0 outdurs))
                    (take-poly outpits))))
    (plotter :view :point 
             :y-axis :keynum 
             :x-axis (axis :seconds :increment 4)
             (loop for p in plotpits
                   for a in plotatx
                   collect a collect p))))

;; PLOT1D -- plotting atk points (useful for randsegs)
(defun plot1d (indata)
  (plotter :view :point :x-axis :seconds
           (loop for d in indata 
                 collect d collect .1)))

;; HISTPLOT -- quick bar graph of a histogram
(defun histplot (histog)
  (let ((hlen (length histog)))
    (plotter :view :bar-and-point
    (loop for n to (- hlen 1)
          collect n
          collect (nth n histog)))))

;; GET-X -- lists x-values in a plotter instance
(defun get-x (aplot)
  (let* ((plotdata (plotter-data aplot)))
    (no-nils
    (loop for n to (- (length plotdata) 1) collect
          (if (eql 0 (mod n 2)) (nth n plotdata))))))

;; GET-Y -- lists y-values in a plotter instance
(defun get-y (aplot)
  (let* ((plotdata (plotter-data aplot)))
    (no-nils
    (loop for n to (- (length plotdata) 1) collect
          (if (eql 1 (mod n 2)) (nth n plotdata))))))

;; more utilities

;; SUMPATT -- returns all "(next patt)"s that sum up to len
;; Sept. 2006: added 'nosqueeze' flag
(defun sumpatt (len patt &optional (nosqueeze nil))
  (loop until (> sumval len)
    for nxtval = (next patt) 
    collect nxtval into cycval
    sum nxtval into sumval
    finally (return (if nosqueeze cycval
			(squeezedurs cycval len)))))

;; DURFUNC -- generic linear function, for writing curves etc.
;; duration input: can take number, list, or pattern
;; (durfunc 4 1 '(* 20 (sin x))) 
;; = (0.0 16.829418 18.185947 2.8224 -15.13605)
(defun durfunc (totalen points funct)
  (let ((atx (typecase points 
               (pattern (sumpatt totalen points))
               (list (sumpatt totalen (makecyc points))))))
    (if (numberp points)
        (loop for p to totalen by points collect
              (eval `((lambda (x) ,funct) ,p)))
        (loop for p in (melint->line 0 atx) collect
              (eval `((lambda (x) ,funct) ,p))))))

;; TIMEFUNC -- computes funct at single point, or set of points
(defun timefunc (points funct)
  (if (numberp points)
      (eval `((lambda (x) ,funct) ,points))
      (loop for p in points collect (timefunc p funct))))

;; CURVED-PATH -- path from 'start' to 'end' over 'len' with 'curve-idx' steepness
;; curve-idx -> negative=curved from below; positive=curved from above
;; returns expression; used in conjunction with "timefunc" 
(defun curved-path (start end curve-idx totalen)
  (let ((cindx (if (plusp curve-idx) curve-idx (/ 1 (* -1 curve-idx)))))
    (if (> start end)
	`(- ,start
	  (* 
	   ,(- start end)
	   (expt (/ x ,totalen) ,cindx)))
	`(+ ,start 
	  (* 
	   ,(- end start)
	   (expt (/ x ,totalen) (/ 1 ,cindx)))))))

;; some quantizing & other rhythmic functions

;; FLOATS->RATS -- utility; converts floats to rats
;; takes input as scalar, list, or pattern
(defun floats->rats (input)
  (cond ((pattern? input)
         (progn
           (setf
            (first
             (pattern-data input)) 
            (mapcar #'rationalize (first (pattern-data input))))
           input))
        ((listp input) (mapcar #'rationalize input))
        (t (rationalize input))))

;; QUANTDURS -- quantizes durs by additive rhythms
;; returns list: ((quantized durations) (poly vector))
;; takes quantizer 'qval-in' as pattern, list, or scalar
;; NOTE: rounds up sum-of-durs to next integer to avoid floating-pt problems!
;; "give-polyvec" flag added Sept. 2006
;; more fixes Sept. 2006
;; nasty fractions eliminated February 2008
(defun quantdurs (indurs qval-in &optional (give-polyvec nil))
  (let* ((qval (floats->rats qval-in))
         (durs (floats->rats indurs))
         (qpatt (cond ((pattern? qval) qval)
                      ((listp qval) (makecyc qval))
                      (t (makecyc (list qval)))))
         (totdurs (ceiling (apply #'+ (floats->rats durs))))
         (pattdurs (sumpatt totdurs qpatt 'nosqueeze))
         (atx (butlast (melint->line 0 durs)))
         (pattatx (set-difference (butlast (melint->line 0 pattdurs)) (list totdurs)))
         (qatx (loop for x in atx collect 
                     (neighbor x pattatx)))
         (qatx-norpt (norpt qatx))
	 (qdurs (melint (append qatx-norpt (list totdurs)))))
    (if give-polyvec
	(list qdurs (tievec qatx))
	qdurs)))

;; QUANTDURS-PATT -- quantizes each dur separately
;; akin to 'sampling with replacement' [each time different]
;; takes pattern or list [list becomes cycle]
;; returns list: ((quantized durations) (poly vector))
;; [some occasional funniness at the end ..] 
(defun quantdurs-patt (durlist qlev-in)
  (let* ((qlev (floats->rats qlev-in))
         (alist (butlast (melint->line 0 durlist)))
         (qlevel (if (listp qlev) (new cycle :of qlev) qlev))
         (qatx
          (safesort
           (loop for x in alist collect (quantize x (next qlevel))))))
    (list
     (melint (norpt qatx))
     (tievec qatx))))

;; DIVVER -- simple utility, used in 'multquant'
;; all atx to 1 for a divnum
(defun divver (divnum &optional (bignum 1))
  (loop repeat divnum collect (/ bignum divnum)))

;; MULTQUANT -- quantize among multiple subdivs
;; returns durations ...simply builds resultant of total length 'bignum'
;; accepts atoms for 'divlist' [Aug. 2006]
;; (multquant '(2 3) 4) = (4/3 2/3 2/3 4/3)
(defun multquant (divlist &optional (bignum 1))
  (if (numberp divlist) 
      (divver divlist bignum)
      (let ((divs (mapcar (lambda (x) (divver x bignum)) divlist)))
	(resultant divs))))

;; MULTQUANT-ATX -- presents 'multquant' as atk-points
;; (multquant-atx '(2 3)) = (0 1/3 1/2 2/3 1)
(defun multquant-atx (divs &optional (bignum 1))
  (melint->line 0 (multquant divs bignum)))

;; QUANTRAN -- quantizing ranseg/explseg data
;; returns (durs poly) list 
(defun quantran (rsegs quants &optional (returnpoly nil))
  (let ((qtran (quantdurs (melint (floats->rats rsegs)) quants 'rp)))
    (if returnpoly qtran (first qtran))))

;;; QUANTRANPLAY -- places pattern-pits into poly
(defun quantranplay (input-pits rsegs quants &optional (flat-output nil))
  (let* ((qd-out (quantran rsegs quants 'rp))
         (qdurs (first qd-out))
         (qpoly (second qd-out))
         (inpits (if (pattern? input-pits) 
                     (if flat-output
                         (next input-pits (- (length rsegs) 1))
                         (next input-pits (apply #'+ qpoly)))
                     input-pits))
         (cpits (if flat-output 
                    inpits
                    (make-poly inpits qpoly)))
         (outplist (plists cpits qdurs))
         (outdurs (squeezedurs (second outplist) (car (last rsegs)))))
    (splay (first outplist) outdurs)))

;; ATKPTS -- build atkptlist from list, scalar, or pattern
;; includes optional initial offset
(defun atkpts (totalen indurs &optional (offset 0))
  (let* ((durpatt (cond ((pattern? indurs) indurs)
                        ((listp indurs) (makecyc indurs))
                        (t (makecyc (list indurs)))))
         (nuatk nil)
         (rawdurs (squeezedurs
                   (cons offset
                         (loop while (< lastatk totalen) do
                               (setf nuatk (next durpatt))
                               collect nuatk into outvec
                               sum nuatk into lastatk
                               finally (return outvec)))
                   totalen)))
    (butlast
     (melint->line 0 (if (> offset 0) rawdurs (cdr rawdurs))))))

;; ANY-LCM -- computes lcm for non-integer types
(defun any-lcm (&rest nums)
  (* (reduce #'lcm (hits->ints nums))
     (fast-tact nums)))

;; PREP-RHYTHMS -- utility to add an offset if omitted
;; also build in rationalize
(defun prep-rhythms (dlist)
  (let ((durlist (loop for x in dlist collect
                       (if (listp x) (mapcar #'rationalize x)
                           (rationalize x)))))
    (if (member-if #'listp durlist) 
        durlist
        (list durlist 0))))

;; RESULTANT -- resultant of arbitrary # of rhythms (w/offsets)
;; input durations *must* be lists! but may include only one value
(defun resultant (durlist)
  (let* ((adjlists (loop for dlist in durlist collect (prep-rhythms dlist)))
         (lens (mapcar (lambda (x) (apply #'+ (first x))) adjlists))
         (totoffset (reduce #'+ (mapcar #'second adjlists)))
         (totalen (rationalize (+ totoffset (reduce #'any-lcm lens))))
         (atx 
          (safesort (remove-duplicates
                     (loop for alist in adjlists append
                           (atkpts totalen (first alist) (second alist)))))))
    (melint (append atx (list totalen)))))

;; GENERIC-CHAIN -- interposes binary func btwn members of a list
(defun generic-chain (funcname alist)
  (let ((results (map 'list (lambda (a b) (funcall funcname a b))
		      alist (cdr alist))))
    (append
     (loop for n to (- (length results) 1)
	   collect (nth n alist)
	   collect (nth n results))
     (last alist))))

;; GENERIC-LINKS -- result of func btwn consec pairs in list
(defun generic-links (funcname alist)
  (map 'list (lambda (a b) (funcall funcname a b))
       alist (cdr alist)))

;; PAIR-RESULTANT -- convenience for 'resultant-chain'
(defun pair-resultant (a b)
  (resultant (list a b)))

;; RESULTANT-CHAIN -- resultant interposed between rhythms 
;; [not flat! - employ repeater for extended use]
(defun resultant-chain (durlist-list)
  (generic-chain #'pair-resultant durlist-list))

; ERASEDURS -- removes durs from a rhythm
(defun erasedurs (edurs basedurs &optional (use-lcm nil))
  (let* ((ed (prep-rhythms edurs))
         (bd (prep-rhythms basedurs))
         (dlens (if use-lcm 
                    (any-lcm (apply #'+ (first ed))
                             (apply #'+ (first bd)))
                    (apply #'+ (first bd))))
         (totoff (if use-lcm 
                     (+ (second ed) (second bd))
                     (second bd)))
         (bdlen (+ dlens totoff)))
    (melint
     (append (list 0)
             (safesort
              (set-difference
               (atkpts bdlen (first bd) (second bd))
               (atkpts bdlen (first ed) (second ed))))
             (list bdlen)))))

;; EXTRACTDURS -- extracts 'edurs' from 'basedurs' [intersection]
(defun extractdurs (edurs basedurs &optional (use-lcm nil))
  (let* ((ed (prep-rhythms edurs))
         (bd (prep-rhythms basedurs))
         (dlens (if use-lcm 
                    (any-lcm (apply #'+ (first ed))
                             (apply #'+ (first bd)))
                    (apply #'+ (first bd))))
         (totoff (if use-lcm 
                     (+ (second ed) (second bd))
                     (second bd)))
         (bdlen (+ dlens totoff)))
    (melint
     (append
      (safesort
       (intersection
        (atkpts bdlen (first bd) (second bd))
        (atkpts bdlen (first ed) (second ed))))
      (list bdlen)))))

;; AVOIDURS -- avoid common attacks
(defun avoidurs (pladur backdur &optional (use-lcm nil))
  (erasedurs backdur (resultant (list pladur backdur)) use-lcm))

;; RYTE -- playing percussion rhythms
(defun ryte (pits durs &optional (atx 100) (chan 9))
  (let ((properpits (if (listp pits) pits (list pits))))
    (splay (next (makecyc properpits) atx)
           (makecyc durs)
           chan)))


;; some others

;; CHDS->LINES -- changes chords to lines
;; note: all chords in 'chdlist' must be the same length
(defun chds->lines (chdlist)
        (let ((slist (mapcar #'safesort chdlist)))
          (loop for n to (- (length (car slist)) 1) collect
                (loop for chd in slist collect (nth n chd))))) 

;; FILT-BY-MELINT -- extracts only specified intervals from a melody
;; returns slotlist
(defun filt-by-melint (amel intvs)
  (let* ((mlints 
          (mapcar #'mod-intv amel (nthcdr 1 amel)))
         (ints (if (listp intvs) intvs (list intvs)))
         (melintpos
          (reverse
           (no-nils
            (loop for n to (- (length mlints) 1) collect 
                  (if (member (nth n mlints) ints) n)))))
         (mplaces
           (safesort
            (remove-duplicates
             (loop for x in melintpos append (list x (+ x 1)))))))
    (loop for n to (- (length amel) 1) collect
          (if (member n mplaces) (nth n amel) 'r))))


;;; CHOOSER -- returns members of 'alist' from list of indices 'idxs'
;; now treats rests -- Jan. 2008
(defun chooser (idxs alist)
  (loop for n in idxs collect
	(if (eql n 'r) 'r
        (nth n alist))))

;; POSITIONS -- returns indices in list where 'num' occurs
;; e.g. (positions 2 '(3 2 2 1 2 2 4 3 2)) = (1 2 4 5 8)
;; added Sept. 2006
(defun positions (num alist)
  (no-nils
   (loop for n to (- (length alist) 1) collect 
	 (if (eql num (nth n alist)) n))))

;; DRUNKVEC -- quick 'drunk' vector
(defun drunkvec (startpit len &optional (stepsize 1))
  (loop repeat len
    for r = startpit then (drunk r stepsize)
    collect r))

;; AARON4PT -- builds 4pt texture using 'au-contraire'
;; based on Pietro Aaron's construction method
;; returns each voice [dux, super, bassus, altus] as (pits tievec)
(defun aaron4pt (dux b-pit a-pit s-pit &optional (consvec '(0 3 4 7 8 9)))
  (let* ((superius (au-contraire dux s-pit 'oblq consvec))
         (bassus (au-contraire superius b-pit 'oblq consvec))
         (altus (au-contraire bassus a-pit 'oblq consvec)))
    (loop for v in (list dux superius bassus altus)
          collect (list (norpt v) (tievec v)))))

;; AARON3PT -- builds 3pt texture using 'au-contraire'
;; based on Pietro Aaron's construction method
;; returns each voice [dux, super, bassus] as (pits tievec)
(defun aaron3pt (dux b-pit s-pit &optional (consvec '(0 3 4 7 8 9)))
  (let* ((superius (au-contraire dux s-pit 'oblq consvec))
         (bassus (au-contraire superius b-pit 'oblq consvec)))
    (loop for v in (list dux superius bassus)
          collect (list (norpt v) (tievec v)))))

;; "list>" - another way to sort lists (useful for leaps etc.)

;; LIST>PLACE -- utility for 'LIST>'
(defun list>place (list1 list2)
  (let ((lu (list>-util list1 list2)))
    (if lu 
        (if (> lu -1)
            lu
            (list>place (butlast list1) (butlast list2)))
        0)))

;; LIST>-UTIL -- utility for 'LIST>'
(defun list>-util (list1 list2)
  (if (and list1 list2)
      (let* ((slist1 (safesort list1))
             (slist2 (safesort list2))
             (last1 (car (last slist1)))
             (last2 (car (last slist2))))
        (cond ((> last1 last2) 0)
              ((< last1 last2) 1)
              (t -1)))))

;; LIST> -- comparing two lists -- predicate!
;; compares max, then each internal max, etc.
(defun list> (list1 list2)
      (eql 0 (list>place list1 list2)))

;; LIST<SORT -- lists sorted from small to large, as per 'list>'
(defun list<sort (lists)
  (reverse
   (sort lists #'list>)))

;; EVERY-PCTRANSP -- returns all pc-transp (& inversions) of a chd
(defun every-pctransp (chd)
  (let ((nf (normal-form (mod12 chd))))
    (remove-duplicates
    (mod12 (append (loop for x to 11 collect (transp nf x))
            (loop for x to 11 collect (transp (invert-chd nf) x))))
    :test #'list-eql)))

;; PCSUBSET -- flag
;;  1 = chd1 is contained in chd2
;; -1 = (invert-chd chd1) is contained in chd2
;; nil = chd1 not in chd2 
(defun pcsubset (chd1 chd2)
  (let* ((invidx (inverse-idx chd1))
         (int1 (melint (prime-form chd1)))
         (int1i (reverse int1))
         (int2 (melint (prime-form chd2)))
         (subs2 (subsequences int2 (length int1))))
    (cond ((member int1 subs2 :test #'seq-eql) (if (eql invidx 1) 1 -1))
          ((member int1i subs2 :test #'seq-eql) (if (eql invidx 1) -1 1))
          (t nil))))

;; NEAREST-PCFORM -- nearest pctransp to a given chd, regardless of length
;; (nearest-pcform '(60 63 65 66) '(0 1 4)) = (62 65 66)
(defun nearest-pcform (chd pcform &optional (ordflag nil))
  (let* ((nchd (normal-form (mod12 chd)))
         (every-pcform (every-pctransp pcform))
         (mindist
          (loop for epc in every-pcform minimize (listdist nchd epc))))
    (matchreg
     (car (member-if 
           (lambda (x) (eql (listdist nchd x) mindist))
           every-pcform))
     chd ordflag)))

;; POISSONVEC -- creates n-trials list for probability p
(defun poissonvec (p n)
  (loop repeat n collect
	(cllib:gen-poisson-variate (coerce p 'double-float))))

;; POISSON->CODE -- creates 0-1 codeword from poisson
;; for use with 'code->slots' for pits/rests etc.
(defun poisson->code (fact len &optional (div 1) (treeflag nil))
  (let* ((pvec (clip-hi div (poissonvec fact len)))
	 (pcode (loop for p in pvec collect
		      (shuffle (append (copyli