;; work on canon for Diapason (March 2005)
;; a re-working of "diapcanon.lisp" to produce rational
;; attack points for synchronization among parts

;; NOTE 3/7/05: got attack points for myfern1 and myfernlist2
;; needed: re-configuring "simpl2" and "simpl3" to use attack pts

(load "nudruz.lisp")
(load "tiling.lisp")
(load "selfsim.lisp")
(load "modes.lisp")
(load "spacegrp.lisp")
(load "nondet.lisp")

;; NOTE: use old version 'cm-2.4.0' for "midi2cs.lisp"
 
; (define cyclops3x8 '(a b c b d e c e))
; 5 members

; for testing
; (define ss3x8
;   (selfsim cyclops3x8 '(0 2 4 5 7) '(9 11 19) '(62 54 47) .45))
; (events ss3x8 "ss3x8.midi")
; 
; (define ssvec3x8
;  (selfsimvec cyclops3x8 '(0 2 4 5 7) '(9 11 19) '(62 54 47)))

(define vec3rpts (reduce #'lcm '(9 11 19)))

(define intpick (new random of '(5 7 4 8)))

(defun randdbl (alist rints)
  (loop for x in alist collect
        (if (eql x 'r) 'r (+ x (next rints)))))

(define bscale '(0 1 3 5 7))


;;;;;;;;;;; tonnetz etc.

(load "tonnetz.lisp")

(define tonpits
  (make-poly
   (placereg 
    (loop for x in (tzrandchain '(0 3 7) 100) append (shuffle x))
    (new heap of '(5 4 3 2)))
   (transp (heapvec 100 3) 1)))

;(define myfernlist2 
;  (sum-across 
;   (ferneyrat '(1) (strums 400 2 2 1 3 3))
;   (copylist
;    (shuffle (append '(35) (loop repeat 107 collect (+ 20 (random 5)))))
;    8)))
;(float (reduce #'+ myfernlist2))

;; rational atk points for myfernlist2
;(define myfern2atx (butlast (melint->line 0 myfernlist2)))

;; myfernlist2 & myfern2atx now hardcoded -- 108 atx * 8 sections
(load "myfernlist2.lisp")

; (length myfernlist2) = 864
; (* 8 (reduce #'lcm '(9 11))) = 792


; (define bigfern1 
;   (copylist 
;    (ferneyrat 
;     (shuffle (copylist '(1 1.5) 11))
;     (strums 12 2 2 1 2 3)) 20))

; (length bigfern1)
; (reduce #'+ (subseq bigfern1 0 15049)) = 7199.9395


;; MYFERN1 = base attack points for canon
; (define myfern1 (subseq bigfern1 0 15050))

;(define mf1rat
;  (loop for x in myfern1 collect (rationalize x)))

;; MF1ATX = myfern1 attack points (as rationals)
; (define mf1atx
;   (loop for x to (length mf1rat) collect (reduce #'+ (subseq mf1rat 0 x))))

; "myfern1" and "mf1atx" now hardcoded
(load "myfern1.lisp")

;; tonsembs = tonnetz pitches by section, and 'intpickvc'
(load "tonsembs.lisp")

;; making master tonz file = all pitches in tonnetz
(define tonzlist
  (append tz1 tz2 tz3 tz4 embed027 tz6 embed024 tz8))


;; defining canon strands as pits ,durs, atx

(define bivscale '(0 2 4 6 7))

(define can9pits 
  (first 
   (slots->durs 
    (append (s-sim->slots cyclops3x8 bscale 9 63 (/ vec3rpts 9)) '(63)))))

(define can9durs
  (sum-across myfern1 (copylist '(9) 1673)))

(define can9atx
  (butlast
  (loop for x to (length can9durs) collect 
        (rational (reduce #'+ (subseq can9durs 0 x))))))

(define can11pits 
  (first 
   (slots->durs 
    (append (s-sim->slots cyclops3x8 bivscale 11 55 (/ vec3rpts 11)) '(55)))))

(define can11durs
  (sum-across myfern1 (copylist '(11) 1369)))

(define can11atx
  (butlast
  (loop for x to (length can11durs) collect 
        (rational (reduce #'+ (subseq can11durs 0 x))))))

;; doubling voice
(define dblvc (slots->durs intpickvc))

(define dblpits (first dblvc)) ; 359 

(define dbldurs (sum-across myfern1 (second dblvc)))

(define dblatx
  (butlast
  (loop for x to (length dbldurs) collect 
        (rational (reduce #'+ (subseq dbldurs 0 x))))))



;; CREATING MIDI FILES

;; new & generic playback routine
(define (simpl4 pits durs atkpts)
  (process for x in pits
           for dur in durs
           for atk in atkpts
           when (or (numberp x) (listp x))
           output (multievent 'midi :keynum
                              :keynum x
                              :time atk
                              :amplitude (between .4 .6)
                              :duration dur)))


;; all playback
(events (list
         (simpl4 tonzlist myfernlist2 myfern2atx)
         (simpl4 can9pits can9durs can9atx)
         (simpl4 can11pits can11durs can11atx)
         (simpl4 dblpits dbldurs dblatx)
         ) "diapcanon.mid")
;; tonnetz playback
(events (simpl4 tonzlist myfernlist2 myfern2atx) "tonnetz.mid")
; canon at 9x
(events (list
         (simpl4 can9pits can9durs can9atx)
         ) "canon9.mid")
; canon at 11x
(events (list
         (simpl4 can11pits can11durs can11atx)
         ) "canon11.mid")
; doubling voice
(events (list
         (simpl4 dblpits dbldurs dblatx)
         ) "doubler.mid")
; 2 vc canon + doubling 
(events (list
         (simpl4 can9pits can9durs can9atx)
         (simpl4 can11pits can11durs can11atx)
         (simpl4 dblpits dbldurs dblatx)
         ) "canonall.mid")

;; now finding intersections

(defun mkinsec (pda1 pda2)
  (let* ((p1 (first pda1))
         (d1 (second pda1))
         (a1 (third pda1))
         (p2 (first pda2))
         (d2 (second pda2))
         (a2 (third pda2))
         (a3 (intersection a1 a2)))
    (list
     (loop for x in a3 collect 
           (remove-duplicates
            (flatten 
             (list (nth (position x a1) p1) (nth (position x a2) p2)))))
     (loop for x in a3 collect (nth (position x a1) d1))
     a3)))
    
;; simpl4vec -- like simpl4, but takes pda list & breaks it up
(define (simpl4vec pdalist)
  (let ((pits (first pdalist))
        (durs (second pdalist))
        (atkpts (third pdalist)))
    (process for x in pits
             for dur in durs
             for atk in atkpts
             when (or (numberp x) (listp x))
             output (multievent 'midi :keynum
                                :keynum x
                                :time atk
                                :amplitude (between .4 .6)
                                :duration dur))))

; (length (intersection myfern2atx can9atx)) = 42
; (length (intersection myfern2atx can11atx)) = 23
; (length (intersection myfern2atx dblatx)) = 9
; (length (intersection can9atx can11atx)) = 153
; (length (intersection can9atx dblatx)) = 359 
; (length (intersection can11atx dblatx)) = 51

(define tonzpda (list tonzlist myfernlist2 myfern2atx))
(define can9pda (list can9pits can9durs can9atx))
(define can11pda (list can11pits can11durs can11atx))
(define dblpda (list dblpits dbldurs dblatx))

(events (simpl4vec (mkinsec tonzpda can9pda)) "dton9.mid")
(events (simpl4vec (mkinsec tonzpda can11pda)) "dton11.mid")
(events (simpl4vec (mkinsec tonzpda dblpda)) "dtondbl.mid")
(events (simpl4vec (mkinsec can9pda can11pda)) "dcan911.mid")
(events (simpl4vec (mkinsec can9pda dblpda)) "dcan9dbl.mid")
(events (simpl4vec (mkinsec can11pda dblpda)) "dcan11dbl.mid")

;; coming back from midi
; (define minall (midi-in "diapcanon.mid"))
; hardcoded
(load "minall.lisp")

(define minallpits (first minall))
(define minalldurs (second minall))

; finding chords of a certain size
(define chds5 (loop for x in minallpits collect 
                    (if (and (listp x) (= (length x) 5)) x 'R)))

(define chds4 (loop for x in minallpits collect 
                    (if (and (listp x) (= (length x) 4)) x 'R)))

; get chd-size distribution
(define chdlens
  (reverse 
   (safesort
    (loop for x in minallpits collect (if (listp x) (length x) 1)))))

(define (simpl5 pits durs)
  (process for x in pits
           for dur in durs
           when (or (numberp x) (listp x))
           output (multievent 'midi :keynum
                              :keynum x
                              :time (now)
                              :amplitude (between .4 .6)
                              :duration dur)
           wait dur))

(events (simpl5 chds5 minalldurs) "chds5.mid")
(events (simpl5 chds4 minalldurs) "chds4.mid")

;; now finding all common non-atk rhythms btwn tonnetz & canon
(define commonbase (intersection mf1atx myfern2atx))
; (length commonbase) = 351

(define allatx (union can9atx can11atx))

(define sharedvec
  (let ((sharedatx (set-difference commonbase allatx)))
    (list 
     (loop for x in sharedatx collect 
           (nth (position x myfern2atx) tonzlist))
     (loop for x in sharedatx collect 
           (nth (position x myfern2atx) myfernlist2))
     sharedatx)))


(events (simpl4vec sharedvec) "sharedbase.mid")








;;;;;;;;;;;;; OLD WORK ;;;;;;;;;;;;;;;;;;;;


;; embed etc.
; (embell-triad '(0 2 4)) etc. for the two "others"? (0 2 4) & (0 2 7)

;(define emb024 (copylist 
;                (shuffle (append (embell-triad '(0 2 4) 4) (list '(0 2 4))))
;        10))
;(define emb027 (copylist 
;                (shuffle (append (embell-triad '(0 2 7) 4) (list '(0 2 7))))
;        10))

;; emb024 & emb027 now hardcoded in tonsembs.lisp


;;; constructing sections
; (loop for x from 0 to 8 collect (* 108 x))
; (0 108 216 324 432 540 648 756 864)

(define mflist2p1 (subseq myfernlist2 0 108))
(define mflist2p2 (subseq myfernlist2 108 216))
(define mflist2p3 (subseq myfernlist2 216 324))
(define mflist2p4 (subseq myfernlist2 324 432))
(define mflist2p5 (subseq myfernlist2 432 540))
(define mflist2p6 (subseq myfernlist2 540 648))
(define mflist2p7 (subseq myfernlist2 648 756))
(define mflist2p8 (subseq myfernlist2 756))

;; section lengths
; (loop for x in '(108 216 324 432 540 648 756) collect
;      (reduce #'+ (subseq myfernlist2 0 x)))
(define secstarts 
  '(0 899.00006 1798.0 2698.6667 3599.4993 4498.999 5397.6646 6296.9976))

(define (tonetzpits trich)
  (subseq
   (make-poly
    (placereg 
     (loop for x in (tzrandchain trich 100) append (shuffle x))
     (new heap of '(5 4 3 2)))
    (transp (heapvec 100 3) 1)) 0 108))

(define (embedpits emblist)
  (subseq 
   (make-poly
    (placereg 
     (transp (flatten emblist) 12)
     (new heap of '(5 4 3 2)))
    (transp (heapvec 100 3) 1)) 0 108))

; = (0 1 6) (0 1 5) (0 3 7) (0 2 5) (0 2 7) (0 1 3) (0 2 4) (0 2 6)

;; fix tonz pits for all runs -- now hardcoded in tonsembs.lisp
;(define tz1 (tonetzpits '(0 1 6)))
;(define tz2 (tonetzpits '(0 1 5)))
;(define tz3 (tonetzpits '(0 3 7)))
;(define tz4 (tonetzpits '(0 2 5)))
; (define embed027 (embedpits emb027))
;(define tz6 (tonetzpits '(0 1 3)))
(define embed024 (embedpits emb024))
;(define tz8 (tonetzpits '(0 2 6)))

; canon only
(events
 (list
  (simpl2 (append 
           (s-sim->slots cyclops3x8 bscale 9 63 (/ vec3rpts 9)) '(63)) myfern1)
  (simpl2 intpickvc myfern1)
  (simpl2 (append 
           (s-sim->slots cyclops3x8 bivscale 11 55 (/ vec3rpts 11)) '(55)) myfern1)
  ) "papcan.midi")

; checking
; (reduce #'+ (second (midi-in "papcan.midi")))

; both together
(events 
 (list
  (simpl3 tz1 mflist2p1)
  (simpl3 tz2 mflist2p2)
  (simpl3 tz3 mflist2p3)
  (simpl3 tz4 mflist2p4)
  (simpl3 embed027 mflist2p5)
  (simpl3 tz6 mflist2p6)
  (simpl3 embed024 mflist2p7)
  (simpl3 tz8 mflist2p8)
  (simpl2 (append (s-sim->slots cyclops3x8 bscale 9 63 (/ vec3rpts 9)) '(63)) myfern1)
  (simpl2 intpickvc myfern1)
  (simpl2 (append 
           (s-sim->slots cyclops3x8 bivscale 11 55 (/ vec3rpts 11)) '(55)) myfern1))
 "papboth.midi" (append secstarts '(0 0)))



;; now breaking off into subfiles

(events
 (list
  (simpl2 (append 
           (s-sim->slots cyclops3x8 bscale 9 63 (/ vec3rpts 9)) '(63)) myfern1)
  ) "topcan.midi")

(events
 (list
  (simpl2 intpickvc myfern1)
  ) "candbl.midi")

(events
 (list
  (simpl2 (append 
           (s-sim->slots cyclops3x8 bivscale 11 55 (/ vec3rpts 11)) '(55)) myfern1)
  ) "bcan.midi")






;; some notes

(scf bscale cyclops3x8) = (0 1 3 1 5 7 3 7)

(subsequences (scf bscale cyclops3x8) 3) == (0 1 3) (1 5 7)

(subsets-len (scf bscale cyclops3x8) 3) == 
(define cycsubs '((5 3 7) (1 3 7) (1 5 7) 
(1 5 3) (0 3 7) (0 5 7) (0 5 3) (0 1 7) (0 1 3) (0 1 5)))

(loop for x in cycsubs collect (prime-form x))
; tonnetz-able: (0 2 6) (0 3 7)   (0 2 5) (0 1 6)     (0 1 3) (0 1 5)
; others:                    (0 2 4)            (0 2 7)

(define trichs '((0 2 6) (0 3 7) (0 2 5) (0 1 6) (0 1 3) (0 1 5) (0 2 4) (0 2 7)))
; sum               8       10      7       7       4       6       6       9            
; ints          ((2 4 6) (3 4 5) (2 3 5) (1 5 6) (1 2 3) (1 4 5)  (2 4)   (2 5))

;; sorted by sum = 
(define trichs2 '((0 1 3) (0 1 5) (0 2 4) (0 2 5) (0 1 6) (0 2 6) (0 2 7) (0 3 7)))

;; FINAL best path by common interval content:
;     156  -> 145  -> 345  -> 235  -> 25   -> 123  -> 24   -> 246 
; = (0 1 6) (0 1 5) (0 3 7) (0 2 5) (0 2 7) (0 1 3) (0 2 4) (0 2 6)



;;;;ETC .

; CHECKING CANON LENGTH
(define nontonz-durs
  (sum-across myfern1
              (second (slots->durs 
                       (s-sim->slots cyclops3x8 bscale 11 55 (/ vec3rpts 11))))))
(apply #'+ nontonz-durs)

(define nontonz-durs2
  (sum-across myfern1
              (second (slots->durs (s-sim->slots cyclops3x8 bscale 9 63 (/ vec3rpts 9))))))
(apply #'+ nontonz-durs2)



;;;;;;;; scratch, discarded, etc. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; !!!!
(define cyclops5x12 '(a b c d e b f g e h c g))
; 8 members

(define ss5x12
  (selfsim cyclops5x12 '(0 5 10 3 8 1 6 11) '(5 12 17) '(70 63 56) .6))
(events ss5x12 "ss5x12.midi")

(* 12 (reduce #'lcm '(5 12 17)))



;; problem: atkpoints need to be rational in order to coincide


(define papboth (midi-in "diap-in/papboth2.mid"))

(reduce #'+ (second papboth))

(rationalize 0.333)

(melint->line 0 myfern1)

;;;


;; fixing doubler


(define dblpits2 intpickvc)
(define dbldurs2a (butlast myfern1))

(define dblatx2 (butlast (butlast mf1atx)))

(define dbldurs2
  (let ((atxinter (intersection dblatx2 can9atx)))
  (loop for x in dblatx2 collect
        (if (member x atxinter)
          (nth (position x can9atx) can9durs) 
          (nth (position x dblatx2) dbldurs2a)))))


;; CSOUND
;; setups
(defobject i1 (i)
  (amp
   freq
   (attack :initform .05)
   (release :initform .25))
  (:parameters time dur amp freq attack release))

; (set-sco-output-hook! #'play-sco-file)

(load "diaparts.lisp")

;; new & 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 .4 .6)
                              :dur (float dur))))

;(events (list
;         (simpl4 dblpits dbldurs dblatx)
;         ) "doubler.mid")


;; need this
(define sco-header
	"f 1  0 16384 10    1")

;; now write out to sco and wav
(events (simpl4sco dblpits2 dbldurs2 dblatx2) "doubler2.sco" 0
	:header sco-header
;	:options "-d -m0 -W"
;	:orchestra "sine.orc"
;	:output "blur.wav"
)


;; bringing dbass.mid into cm

(define dbasser (midi-in "dmidiout/dbass.mid"))


(define dbass (list (bottomline (first dbasser)) (second dbasser)))

(reduce #'+ (second dbass))


;; another shot at the bass

(define tonbass
  (loop for x in (bottomline tonzlist) collect
        (if (> x 38) 'R x)))

(length (first (slots->durs tonbass)))

(define tonbass
'(R 25 30 R R 31 R 31 25 R 33 R 27 R R 34 34 R 33 R R R R 37 R R 32 R R 33 33 R
 R 34 35 R R 30 24 R R 30 25 R R 33 32 R 38 R R 31 R 37 R R 32 R R R R 36 R R R
 R R 36 R 35 R R R R 34 R 34 R R R 35 R 36 35 35 R 29 36 37 31 R 24 R 35 R 35 R
 R 33 R R 38 R 38 R 33 R R 24 37 28 R 28 R R 25 R 29 R 28 33 R R 27 32 R R 35
 34 R R 38 R R R R R 27 R 30 R 38 R 29 R R 35 R R 35 R 36 R R 36 R R 38 37 30 R
 R 36 R 37 R 31 R 26 R R R 38 37 32 R R R R 31 28 R R 32 R R R R 30 26 31 R R R
 27 R 37 R 30 R R R R R R R R R R R 29 R R R R 38 R R 28 R 28 R R 30 R 27 34 R
 R R 30 R 38 29 R 26 35 R R 30 30 R 28 R R 25 29 R R 31 24 R 34 R 30 R R 32 32
 R 28 R 34 R R R 34 38 R 34 R 35 R 35 R R R R 37 R 37 R 33 R R R 34 R R R R R R
 R R R 35 R R 36 36 R 36 R R 35 R R R R 37 37 R R R R 38 R R R R R 32 R R 29 38
 34 32 R R 25 32 R 28 37 33 R 28 R R 24 34 36 34 R 25 R 28 R 26 38 R 31 24 R R
 R 31 38 R R 29 29 32 R R 34 24 R 24 R 29 R R 28 31 R R 38 35 30 R 30 29 R R 29
 R R R R 29 R 30 R R R 34 34 R R 36 R R 38 R 29 28 R R 31 26 R 26 R R 33 R 30 R
 34 R 34 R R 35 35 R R R R R R R R R 38 37 R R R R 35 36 R R R R 34 R R R 37 R
 38 37 R R 37 R R R R R R 34 38 R R R R R R R 34 R R R R R 37 34 R R R R R R R
 36 R R 38 R R R R 38 R R R R R R R 36 R R R R R R 38 R R R R R R R R R R R R R
 R R R R R R 37 R R 37 36 R 34 24 R 36 35 R 34 R R 31 29 R 32 R R 33 33 34 R R
 38 38 R 37 R R 37 R 34 29 R R R 29 29 27 R 36 R 24 33 R R 32 R R R 30 R 28 28
 R 38 35 R R 35 24 34 R R R R 26 R R 37 37 R 24 R R 35 R 33 33 R 31 R R 31 R 26
 28 R 25 37 R 24 R R R 31 R 31 28 R R 26 36 R 24 24 33 R 34 R R R R R 34 R R 35
 R 37 R 38 36 R R R R 35 R R R R R 35 R 35 R R R 36 R R 34 R R 37 34 R R R R 36
 R R R R R 36 R R 35 R R 34 R R R R 35 R R R R 37 R R 34 35 R R R 34 R R R R 37
 R R 36 R 36 R 38 R R R 36 R R R R 37 R 38 R R R R R 38 R R 36 R R R R R R 26
 38 32 R 38 26 34 R 36 R 30 38 28 R 34 38 34 R 38 36 28 28 R R R 26 36 38 28 R
 34 R 36 32 32 36 32 R 38 26 R 26 R 36 28 R 28 R 26 R 32 R 28 R R 36 34 R R 26
 30 R R 34 R R R 30 36 R R 26 32 R 28 R R 36 30 R R 28 R 36 R 38 26 R R 24 R 34
 R 30 34 R R 28 R 24 30 R R R 24 R 24 24))