(load "nudruz.lisp")
(load "selfsim.lisp")
(load "rewrite.lisp")
(load "graphs.lisp")
(load "modes.lisp")
(load "tiling.lisp")
(load "tonnetz.lisp")
(load "spacegrp.lisp")

;;;;;;;;

(defun sbsq-ctr (alist)
  (let* ((sr (stravrot alist))
         (ctr (take-contour alist))
         (sbq (subsequences sr (length alist))))
    (loop for x in sbq collect
          (give-contour-to-mel ctr x))))

; (define myvec (heapvec 5 12))
(define myvec '(3 5 9 1 6))

(define sums11 (eql-summer 11 '(2 3 4)))

(defun sanums1 () 
    (loop repeat 7 append
          (shuffle (pickl sums11)))))

(define nbfern (ferney '(1) '(4 3 3)))


(defun stax ()
  (process
    for dur in (sum-across nbfern (sanums1))
    for x in (transp (flatten (matchreg-chds (sbsq-ctr (heapvec 5 12)))) 60)
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (stax) (stax)) "stax.midi")


;;;;;
(define ebtbass
  (midi-in "quadrille/ebt-bass.mid"))

(define ebttop
  (midi-in "quadrille/ebt-top.mid"))

(define ebtpits (first ebtbass))
(define ebtdurs (second ebtbass))

(defun ebmodes (amode tlevel)
  (process
    for dur in ebtdurs
    for x in (play-mode ebtpits amode tlevel)
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(defun straitin (pits durs)
  (process
    for dur in durs
    for x in pits
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (ebmodes stravmode -10)
              (ebmodes ionian -5)
              (ebmodes hyperlydian 0)
              (straitin (first ebtbass) (second ebtbass))
              (straitin (transp (first ebttop) 12) (second ebttop)))
        "ebmodes.midi")


;;;;;;;;;

(define xdurs (loop repeat 70 collect (transp (random 4) 10)))

(define sum10s (eql-summer 10 '(2 3 4)))
(define sum11s (eql-summer 11 '(2 3 4)))
(define sum12s (eql-summer 12 '(2 3 4)))
(define sum13s (eql-summer 13 '(2 3 4)))

(defun sanums ()
  (loop for x in xdurs append
        (case x 
          (10 (shuffle (pickl sum10s)))
          (11 (shuffle (pickl sum11s)))
          (12 (shuffle (pickl sum12s)))
          (13 (shuffle (pickl sum13s))))))

(define sfern (ferney '(1) (strums 100 4 4 3 7 5)))

(defun het (amode tlevel)
  (process
    for dur in (transp (sanums) .25 #'*)
    for x in (play-mode (heapvec 300 5) amode tlevel)
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (het stravmode 30)
              (het pentatonic 34)
              (het ionian 40)
              (het wholetone 20)) 
        "het.midi")


;; 
(defun mychds (pitvec) 
  (loop for x in (heapvec 30 7) collect 
        (chd-inversion pitvec x)))

(defun myc (pitvec tlevel)
  (process
    for dur in (copylist (ferney '(1) '(4 6)) 100)
    for x in (norpt (flatten (transp (mychds pitvec) tlevel)))
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (myc '(0 2 4 5 7) 70)
              (myc '(0 3 5) 55)
              (het pentatonic 15)
              (het ionian 28))
 "myc.midi")


(defun myc2 (pitvec tlevel)
  (process
    for dur in (sum-across (copylist (ferney '(1) '(4 6)) 100) 
                           (transp (heapvec 30 7) 5))
    for x in (norpt (flatten (transp (mychds pitvec) tlevel)))
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (myc2 '(0 2 4 5 7) 68)
              (myc2 '(0 3 5) 53)
              (het octatonic 52)
              (het pentatonic 15)
              (het ionian 28))
 "myc2.midi")

;;

(define vline
  (transp (flatten (sort-every (embell-triad '(0 4 7) 4))) 72))

(define longline
  (flatten
  (loop for x in (heapvec 12 10) collect (transp vline x))))


(defun vlnline ()
  (process
    for dur = .125
    for x in longline
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (vlnline)
              (het octatonic 20)
              (het ionian 30))
        "vlnline.midi")


;;; 
(define longline2
  (make-poly (subseq longline 0 89) 5))

(define long2 
  (flatten
  (loop for x in longline2 append
        (pickl (reorder-by-melint (remove-duplicates x) 5)))))

(define llfern (ferney '(1) (strums 50 4 4 3 6 6)))

(defun vlnline2 (pits)
  (process
    for dur in llfern
    for x in pits
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(define sfern2 (ferney '(1) (strums 100 4 4 3 7 5)))

(defun het2 (amode tlevel)
  (process
    for dur in (sum-across llfern (sanums))
    for x in (play-mode (heapvec 300 5) amode tlevel)
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :channel 2
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (vlnline2 long2)
              (vlnline2 (layout .2 (tintab (transp long2 -10) stravmode)))
              (het2 octatonic 20)
              (het2 ionian 35)
              (het2 ionian 30))
        "vlnline2.midi")

;;;;;;;;;


(play-mode (transp (snake 17 40) 20) octatonic)

(defun modesnake (amode tlevel hgt)
  (process
    for dur in (ferney '(1) '(4 4 4 4 5) (strums 50 2 3 3 5))
    for x in (play-mode (transp (snake hgt 400) tlevel) amode)
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (list (modesnake ionian 37 11)
              (modesnake ionian 30 7)
              (modesnake octatonic 23 15)
)
        "modesnake.midi")

;;;;;;;


(define tinytimes (ferney '(1) '(4 4 4 4 3) (strums 10 2 2 3 5)))

(define slotimes (sum-across tinytimes (transp (heapvec 300 4) 10)))

(define modelist
  (loop for x in (subsequences (random-indices 12) 6) collect
        (new mode degrees (safesort x))))

(define opits
  (make-poly 
   (transp (placereg (heapvec 5000 6) middleweight-5 6) 20)
   (loop repeat 100 collect (odds .8 1 2))))

(define omodes 
  (valbytime slotimes modelist tinytimes))

(define plamodz 
  (loop for x to (- (length opits) 1) collect
        (play-mode (nth x opits) (eval (nth x omodes)))))

(defun straits (pits durs)
  (process
    for dur in durs
    for x in pits
    when (or (numberp x) (listp x));; needed for rests
    output (multievent 'midi :keynum
                       :keynum x
                       :time (now)
                       :duration dur)
    wait dur))

(events (straits plamodz tinytimes) "pmodes.midi")

;;;;;;;;;

(define ttimes (ferney '(1) '(4 4 4 4 3) (strums 10 2 2 3 5)))

(define m5row (shufflebymod (indices 12) 5 12))
(define m7row (shufflebymod (indices 12) 7 12))


(events (straits 
         (make-poly 
          (transp (placereg 
                   (flatten (subsequences (copylist m5row 4) 5)) middleweight-5) 24)
          (strums 10 2 4 2 4))
          ttimes) "m5s.midi")


(events (straits 
         (make-poly 
          (transp (placereg 
                   (flatten (subsequences (copylist m7row 4) 5)) middleweight-5) 24)
          (strums 10 2 4 2 4))
          ttimes) "m7s.midi")


;;;

(define ypol
  (make-poly 
   (heapvec 300 12) '(5)))

; (first ypol) = (6 11 3 9 2)

(define fypol '(6 11 3 9 2))

(define yp5 (reorder-by-melint fypol 5))

(define ypits
  (transp (loop for x in yp5 collect (stack-up x)) 48))

(define fyperms (permutations fypol))

(define ypits2
  (make-poly
  (flatten
  (transp (loop for x in fyperms collect (stack-up x)) 48))
  (strums 30 2 2 3 7)))


(events (straits ypits (copylist '(1 1.25) 300)) "ypits.midi")

(define ypho (holes fypol))

(define hopits
  (loop for x in (shuffle (permutations ypho)) collect (stack-up x)))

(events (straits (transp (flatten hopits) 60) (copylist '(.125) 800)) "hopits.midi")


(define hferns (ferney '(1) (strums 50 6 6 2 4 4)))

(events (list
         (straits (transp (flatten hopits) 60) (copylist '(.125) 800))
         (straits ypits (sum-across hferns (heapvec 100 4)))
         ) "hocombo.midi")

(define hferns2 (ferney '(1) (strums 15 3 3 1 6 4) (transp (heapvec 12 5) 3)))

(events (straits ypits hferns2) "hopits2.midi")
(events (straits ypits2 hferns) "ypits2.midi")

(define midho (first (midi-in "quadrille/new4/hocombo.midi")))

(define endho
  (thinout (subseq midho 560 609)))

(define hferns2 (ferney '(1) (strums 50 8 8 2 4 6)))

(events (straits endho hferns2) "endho.midi")

;;;
(defun qmetro ()
  (process repeat 640
    output (new midi
                       :keynum 36
                       :time (now)
                       :duration 1.0)
    wait 1.0))


(events (qmetro) "qmetro.midi")


(define p2o (midi-in "p2o.mid"))

(define p2v (midi-in "p2v.mid"))

(events (straits (first p2o) (transp (second p2o) 2 #'*)) "p2o2.mid")

(events (straits (first p2v) (transp (second p2v) 2 #'*)) "p2v2.mid")

;;;
(define mo2a (midi-in "mo2a.mid"))

(events (straits (first mo2a) (transp (second mo2a) 2 #'*)) "mo2a2.mid")

(define mo2b (midi-in "mo2b.mid"))

(events (straits (first mo2b) (transp (second mo2b) 2 #'*)) "mo2b2.mid")

(define mo2c (midi-in "mo2c.mid"))

(events (straits (first mo2c) (transp (second mo2c) 2 #'*)) "mo2c2.mid")