; Duke Street Variations

(load "nudruz.lisp")
(load "beats.lisp")
(load "inflect.lisp")
(load "designs.lisp")
(load "modes.lisp")
(load "diffs.lisp")
(load "rewrite.lisp")
(load "graphs.lisp")
(load "tonnetz.lisp")
(load "selfsim.lisp")
(load "reger.lisp")
; (load "scanons.lisp")
(load "nondet.lisp")
(load "motive.lisp")
(load "lewin.lisp")
(load "slonimsky.lisp")
(load "oddities.lisp")
(load "tiling.lisp")
(load "transforms.lisp")

; PRESETS, INPUT DATA, ETC.
; LOAD FIRST

;; hymn taken from Cyberhymnal
(define dukemid
    (midi-in "DukeSt-0.mid"))

;; simplified hymn (4-note texture only)
(define dukepits
    (mapcar #'safesort
	    '((62 57 50 54) (62 66 50 57) (61 67 52 57) (62 69 54 57) (62 71 55 55) (64 73 52 55)
	      (66 74 50 57) (64 73 52 57) (52 62 71 56) (61 69 45 54) 
	      (62 69 50 54) (62 69 50 54) (62 69 54 57) (62 71 55 55) (62 69 54 57) 
	      (61 67 52 57)(62 66 50 57) (61 64 45 57) 
	      (62 66 50 57) (62 66 50 57) (61 64 45 55) 
	      (57 62 50 54) (50 62 66 57) (62 69 54 57) (62 74 54 57) 
	      (62 71 55 59) (69 54 62 62) (61 67 52 57) (62 66 50 57) (61 64 45 57)
	      (62 69 54 57) (62 71 55 55) (64 73 52 55) (62 74 54 57) 
	      (64 67 55 59) (62 66 57 57)
	      (61 64 45 55) (62 50 54 57))))

;; relative durations for 'dukepits' 
(define dukedurs
    '(2 1 1 2 1 1 2 1 1 4 
      2 1 1 2 2 2 2 4 
      2 1 1 1 1 1 1 1 1 1 1 4 
      2 1 1 3 1 2 2 2))

;; phrase lengths for 'dukepits' & 'dukedurs'
(define dukephrases '(10 8 12 8))

;; pits from Cyberhymnal
(define altpits (first dukemid))

;; quantized rhythms from Cyberhymnal - scaled sim. to 'dukedurs'
(define altdurs
    (mapcar (lambda (x) (quantize x .5))
	    (transp 
	     (second dukemid)
	     (/ 2  .8275) #'*)))

;; non-repeating normal forms in 'dukepits'
(define dukenorms
    (norpt
     (mapcar #'normal-form dukepits)
     #'list-eql))

;; durations in first phrase 'demultiplied', expressed as integer durations
(define duke-demult
    (hits->ints
     (motive->durs
      (demultiplied-motive
       (durs->motive
	(first (make-poly dukedurs dukephrases)))))))

;; durations in first phrase 'multiplied', expressed as integer durations
(define duke-mult
    (motive->durs
     (multiplied-motive
      (durs->motive
       (first (make-poly dukedurs dukephrases))))))

;; 'dukepits' chords split into SATB
(define dukelines
    (chds->lines dukepits))

(define bass (nth 0 dukelines))
(define tenor (nth 1 dukelines))
(define alto (nth 2 dukelines))
(define sopr (nth 3 dukelines))

(define dmajor (transp-mode ionian 2))

;; random variation (integer) of dukedurs 
(defun theselens (factor)
  (loop for d in (hits->ints dukedurs) collect
	(floor (vary (* d factor) .3))))

;; FINAL VARIATIONS BELOW

; variation A = 'sarpg'

;; A PITCHES
;; chords in 'altpits' 4-vc texture are internally shuffled, then flattened, 
;; then combined into 3-note chords.
;; these chords are internally ordered to maximize major 3rds. 
;; This chdlist is then flattened and random
;;   D major pitches are inserted every 6 places. Repeated pitches are removed.
;; A RHYTHM
;; moves at motoric 8th; sixteenths appear with each melodic octave

(events
 (let ((pits
	(gather-pits (lambda (a b) (eql 0 (mod12 (- b a))))
		     (norpt
		      (interlock
		       (flatten
			(mapcar (lambda (x) (car (reorder-by-melint x 4)))
				(make-poly
				 (flatten
				  (shuffle-all (not-flat altpits)))
				 3)))
		       (shuffle
			(play-mode
			 (indices 15 28)
			 dmajor))
		       '(6)
		       '(1)
		       'nfull)))))
   (splay (flatten pits) (ornadurs pits .5)))
 "sarpg.mid" :play 'nil)

; variation B = 'florid'

;; B -- two lines
;; "ctonz" = takes soprano, removes repeats, and makes fauxbourdon: 1st inversion
;;             triads w/sopr pitch on the top. Finds interpolation paths between chds
;;             with 'ctone' transformation (common tone w/shuffled sis)

;; "tritonz" = interpolation paths within "ctonz" using "tritone-func" (one chd-tone
;;               moves a tritone

;; bottom line = soprano transposed down 2 octaves, at 2x speed
;; topline = "tritonz" at motoric 16ths (32nds whenever a step occurs)

;(define ctonz
;    (generic-branch #'ctone
;		    (play-mode
;		     (mapcar (lambda (x) (transp '(0 -3 -5) x)) 
;			     (modenums (norpt sopr) dmajor))
;		     dmajor)))

(define ctonz
    '(((62 57 54) (61 57 54)) ((66 61 57) (66 62 57))
      ((67 62 59) (64 60 55) (64 61 57)) ((69 64 61)) ((71 66 62) (67 64 61))
      ((73 67 64)) ((74 69 66)) ((73 67 64) (74 71 66)) ((71 66 62) (69 66 62))
      ((69 64 61)) ((71 66 62) (69 66 62)) ((69 64 61) (69 66 62) (71 67 62))
      ((67 62 59)) ((66 61 57) (67 64 59)) ((64 59 55) (61 57 54))
      ((66 61 57) (67 64 59)) ((64 59 55) (62 59 55)) ((62 57 54) (61 57 54))
      ((66 61 57) (64 61 57)) ((69 64 61) (69 66 62)) ((74 69 66) (74 71 66))
      ((71 66 62) (69 66 62)) ((69 64 61) (69 66 62) (71 67 62)) ((67 62 59))
      ((66 61 57) (67 64 59)) ((64 59 55) (64 57 49)) ((69 64 61))
      ((71 66 62) (67 64 61)) ((73 67 64)) ((74 69 66) (74 71 67)) ((67 62 59))
      ((66 61 57) (67 64 59)) ((64 59 55) (62 59 55)) ((62 57 54))))

;(define tritonz
;    (generic-branch #'tritone-func (flatter ctonz)))

(define tritonz
    '(((62 57 54)) ((61 57 54) (61 57 54)) ((66 61 57)) ((66 62 57)) ((67 62 59))
      ((64 60 55)) ((64 61 57) (64 61 57)) ((69 64 61)) ((71 66 62))
      ((67 64 61) (67 64 61)) ((73 67 64)) ((74 69 66)) ((73 67 64))
      ((74 71 66) (74 71 66)) ((71 66 62)) ((69 66 62)) ((69 64 61)) ((71 66 62))
      ((69 66 62)) ((69 64 61)) ((69 66 62)) ((71 67 62) (71 67 62)) ((67 62 59))
      ((66 61 57)) ((67 64 59) (67 64 59)) ((64 59 55)) ((61 57 54) (61 57 54))
      ((66 61 57)) ((67 64 59) (67 64 59)) ((64 59 55)) ((62 59 55)) ((62 57 54))
      ((61 57 54) (61 57 54)) ((66 61 57)) ((64 61 57) (64 61 57)) ((69 64 61))
      ((69 66 62) (69 66 62)) ((74 69 66)) ((74 71 66) (74 71 66)) ((71 66 62))
      ((69 66 62)) ((69 64 61)) ((69 66 62)) ((71 67 62) (71 67 62)) ((67 62 59))
      ((66 61 57)) ((67 64 59) (67 64 59)) ((64 59 55)) ((64 57 49) (64 57 49))
      ((69 64 61)) ((71 66 62)) ((67 64 61) (67 64 61)) ((73 67 64)) ((74 69 66))
      ((74 71 67) (74 71 67)) ((67 62 59)) ((66 61 57)) ((67 64 59) (67 64 59))
      ((64 59 55)) ((62 59 55)) ((62 57 54))))

(events
 (let ((pits
	(conjunct-fragments
	 (norpt
	  (flatten
	   (smoothlist
	    (flatter tritonz))))
	 2)))
   (list
    (splay
     (transp sopr -24)
     (transp dukedurs .5 #'*))
    (splay (transp (flatten pits) 12) (ornadurs pits .25))))
 "florid.mid" :play 'nil)

; variation C = 'mash'

;; C PITCHES
;;  "dukepits" 4-pt chords make 2nd-order transition matrix; 50 chords are generated from matrix.
;;     generated chords are gathered into 'strums' sublists, of 4-8 chords followed 
;;     by 2 or 3 single chords. 'smoothlist' (remove repeated pitches) is applied to multichd lists.
;; C RHYTHM
;;  atk points (by 16th) are determined by probability weights (3 1 2 2 2 1) in cycle

(events
 (let ((pits
	(loop for x in 
	      (make-poly 
	       (next (markov-analyze dukepits :order 2) 50)
	       (strums 10 4 8 2 3)
	       )
	      append (if (numberp (car x)) (list x) (smoothlist x)))))
   (play-sd
    (slots->durs
     (mel-stress pits 
		 (transp (resclassvec 2 3) 1)))
    .25))
 "mash.mid" :play 'nil)

; variation D = 'mashout'

;; D PITCHES
;; "ctonz" = takes soprano, removes repeats, and makes fauxbourdon: 1st inversion
;;             triads w/sopr pitch on the top. Finds interpolation paths between chds
;;             with 'ctone' transformation (common tone w/shuffled sis)
;; -- ctonz is 'smoothed' & interlocked w/bass (ctonz more frequent). sublists (chords) are made
;;   whenever consonance occurs btwn consecutive pitches.
;; D RHYTHM = size of chord * 16th note

(events
 (let ((pits
	(gather-pits #'consn-p
		     (interlock
		      (smoothlist
		       (flatter ctonz))
		      bass
		      (heapvec 17 3 1)
		      (transp (poissonvec .2 30) 1)
		      'notfull))))
   (splay pits (durweight pits .25)))
 "mashout.mid" :play 'nil)

; variation E = 'modesteps'

;; E:  scaledeg of 4-pt chds ('dukepits') are interpolated thru 'fromto-stepper', then 
;;        projected as four lines (in effect, SATB are now each connected stepwise)
;; played at the 8th

(events
 (playchds->lines
  (play-mode 
   (flatter
    (let ((mpits 
	   (modenums dukepits dmajor)))
      (map 'list #'fromto-stepper mpits (cdr mpits))))
   dmajor)
  .5)
 "modesteps.mid" :play 'nil)

; variation F = 'sline'

;; F -- two lines
;;   BOTTOM LINE: soprano transposed down octave, durations x 2
;; TOP LINE PITCH
;; each sopr phrases is self-expanded, then resolved to nearest D-major pitch. 
;; repeats removed.
;; TOP LINE RHYTHM: 32nds w/probability of atk in cycle of (4 1 2 1 3 1 2 1)

(events
 (let* ((soprsd
	 (slots->durs
	  (mel-stress
	   (norpt
	    (tintab
	     (flatten
	      (loop for p in (make-poly sopr dukephrases) collect 
		    (self-expand p 2)))
	     dmajor))
	   (transp (resclassvec 2 4 8) 1))))
	(slen
	 (apply #'+ (second soprsd))))
   (list
    (splay (first soprsd)
	   (transp (second soprsd) .125 #'*))
    (splay (transp sopr -12)
	   (transp dukedurs 2 #'*))))
 "sline.mid" :play 'nil)

; variation G = 'susp'

;; G PITCHES
;; nonrepeating normal forms hymn chords ("dukenorms") form transitional matrix.
;;  100 chords generated, flattened & gathered into 4-note lists. these lists are
;;  then internally ordered by 'closest-mod-list' & placed in registers 3-6 for
;;  most conjunct result
;; G RHYTHM
;; 'demultiplied' first-phrase rhythm (+ 1) is repeated at 8th-note over resultant texture

(define cmodlist
    (closest-mod-list
     (make-poly 
      (flatten
       (next
	(markov-analyze dukenorms)
	100))
      4)))

(events
 (playchds->lines
  (placereg
   (subseq cmodlist 0 (length duke-demult))
   '(3 4 5 6))
  (makecyc (transp (transp duke-demult 1) .5 #'*)))
 "susp.mid" :play 'nil)