; Hanover 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 "nondet.lisp")
(load "motive.lisp")
(load "lewin.lisp")
(load "slonimsky.lisp")
(load "oddities.lisp")
(load "tiling.lisp")
(load "transforms.lisp")
(load "spacegrp.lisp")

; PRESETS, INPUT DATA, ETC.
; LOAD FIRST

(define hanmid
    (midi-in "Hanover-0.mid"))

; bare 4pt harmonization 
(define hanpits
    (mapcar #'safesort
	    '((60 63 44 56) (63 68 44 60) (63 68 48 56) (63 70 51 55) (63 72 56 56)
	      (63 75 55 58) (65 68 53 60) (65 70 49 61) (63 67 51 58) (63 68 44 60)
	      (63 70 51 55) (63 72 56 56) (63 70 55 58) (62 68 53 58)
	      (63 67 51 58) (63 68 48 60) (63 70 43 58) (63 68 44 60)
	      (62 65 46 56) (63 63 51 55) (64 67 48 60) (65 68 53 60) (67 70 53 61)
	      (67 72 52 60) (65 68 53 60) (65 65 53 56) (63 73 55 58) (63 72 56 56)
	      (63 70 55 58) (62 68 53 58) (63 75 51 55) (63 63 48 60) (63 65 49 60)
	      (61 67 51 58) (62 68 53 56) (63 70 51 55) (63 63 55 58) (63 72 56 56)
	      (61 65 49 56) (65 70 46 61) (61 67 51 58) (60 68 44 56))))

(define handurs
    '(1 1 1 1 2 1 1 1 1 2 
      1 1 1 1 2 1 1 1 1 2 
      1 1 1 1 1 1 1 1 1 1 2 
      1 1 1 1 1 1 1 1 1 1 2))

(define hanphrases '(10 10 11 11))

;; pits w/passing tones etc.
(define altpits (first hanmid))

;; durations 2x, w/passing tones etc.
(define altdurs
    (mapcar (lambda (x) (quantize x .5))
	    (transp 
	     (second hanmid)
	     (/ 2  .521739) #'*)))

;; Boulez 'demultiplication' of first phrase, as integer durations
(define han-demult
    (hits->ints
     (motive->durs
      (demultiplied-motive
       (durs->motive
	(first (make-poly handurs hanphrases)))))))

;; Boulez 'multiplication' of first phrase, as integer durations
(define han-mult
    (motive->durs
     (multiplied-motive
      (durs->motive
       (first (make-poly handurs hanphrases))))))

(define hanlines
    (chds->lines hanpits))

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

(define abmajor (transp-mode ionian 8))

; randomized durations
(defun theselens (factor)
  (loop for d in (hits->ints handurs) collect
	(floor (vary (* d factor) .3))))

;; FINAL VARIATIONS BELOW

; variation A = 'flower'

;; A -- two lines
;; top line = selfsim of scaledegs, by phrase (rpts become ties). 32nd-note rate.
;; bottom line = sopr transposed down, durations 9*32nd

(events
 (let ((qties
	(make-ties
	 (play-mode
	  (flatten
	   (mapcar (lambda (x) (self-expand x 2)) 
		   (make-poly (modenums sopr abmajor) hanphrases)))
	  abmajor))))
   (list 
    (splay (first qties) (transp (second qties) .125 #'*))
    (splay (transp sopr -12) (transp handurs (* 9 .125) #'*))))
 "flower.mid" :play 'nil)

; variation B = 'threeleg' tweaked into 'var2b'

;; B PITCHES
;; sopr + alto combined, each pair shuffled, then flattened & interlocked w/bass.
;;   gathered into sublists with lengths from 'morph12rules'
;; B RHYTHM -- (orig.) 'morph12rules' sublists determine subdivs of 8th
;;   'var2b' = rhythms reworked to 16ths

(events
 (let ((pits
	(make-poly
	 (interlock
	  (flatten
	   (shuffle-all
	    (map 'list #'append (not-flat sopr) (not-flat alto)))) 
	  bass
	  '(2 1)
	  '(1 2))
	  (transp (rwgen morph12rules '(1 0 0) 2) 1))))
       (splay (flatten pits) (ornadurs pits .5)))
   "threeleg.mid" :play 'nil)

; variation C = 'noodlemaj'

;; C -- two parts
;; BOTTOM LINE PITCHES = transposed soprano
;; BOTTOM LINE RHYTHM ("slodurs") = 'handurs' summed across
;;     poissonvec of 16ths w/ quarter-note minimum
;; TOP LINE PITCHES = output of soprano's 2nd-order markov pitch matrix
;; TOP LINE RHYTHM ("quickdurs") = output of hymn's 
;;     2nd-order markov duration matrix, diminuted to 16ths

(events
 (let* ((slodurs
	 (sum-across
	  (transp
	   (transp (poissonvec .5 (* 16 3)) 4)
	   .25 #'*)
	  handurs))
	(quickdurs
	 (patt-to-sum
	  (markov-analyze (transp handurs .25 #'*) :order 2)
	  (apply #'+ slodurs))))
   (list
    (splay (transp sopr -24) slodurs)
    (splay 
     (next (markov-analyze sopr :order 2) (length quickdurs))
     quickdurs)))
 "noodlemaj.mid" :play 'nil)

; variation D = 'jumps' tweaked into 'var4b'

;; D PITCHES
;; Ab scaledeg of soprano + its neighbors are shuffled & 
;;   interlocked 2-1 w/normal form of hanpits placed in tenor range
;; D RHYTHM -- rpts. become ties @ 16th triplet
;;   ['var4b' = durations changed from 16th-triplets to 16ths]

(events
 (play-sd
  (make-ties
   (interlock
    (play-mode
     (flatten
      (shuffle-all
       (mapcar (lambda (x) (transp '(-1 0 1) x))
	       (modenums sopr abmajor))))
     abmajor)
    (transp 
     (smoothlist (mapcar #'normal-form hanpits))
     48)
    2 1))
  1/6)
 "jumps.mid" :play 'nil)

(events
 (let ((min (midi-in "hanover/var4-0.mid")))
   (splay 
    (first min)
    (mapcar (lambda (x) (quantize x .25))
	    (transp (second min) 3/2 #'*))))
 "hanover/var4b.mid" :play 'nil)

; variation E = 'quarters'

;; E PITCHES
;; SATB pitches placed in reg 3-5 by heap, then made into three lines
;; E RHYTHM 
;; ties made of each line, by quarter

(events
 (let* ((rawpits
	 (flatten
	  (append sopr alto tenor bass)))
	(sds
	 (mapcar #'slots->durs
		 (parse-by-reg
		  (placereg rawpits (new heap :of '(3 4 5))))))
	(mties (mapcar (lambda (x) (make-ties (first x))) sds)))
   (loop for n to 2 collect
	 (splay (first (nth n mties))
		(sum-across (second (nth n sds)) (second (nth n mties))))))
 "quarters.mid" :play 'nil)

; variation F = 'warpd'

;; F PITCHES
;; "pits" = 'handurs' are shuffled & combined w/sopr to go thru
;;            five generations of 'ptp->pittz' transformations
;; final pits = sopr transposed down P4, aug. by 3 is 'consmatch'ed with
;;   pits placed (mostly) in reg 4 & above (by poisson)
;; F RHYTHM
;; based on markov matx of demultiplied rhythm @ 16th

(events
 (let ((pits
	(flatten
	 (recurz
	  (lambda (x) 
	    (ptp->pittz (lists->ptp x (shuffle handurs))))
	  sopr
	  5))))
   (splay
    (not-flat
     (consmatch
      (menses (transp sopr -7) 3)
      (placereg pits (transp (poissonvec .06 (length pits)) 4))
      'nr))
    (markov-analyze (transp han-demult .25 #'*))))
 "warpd.mid" :play 'nil)

; variation G = 'stroll'

;; G PITCHES
;; soprano interlocked 2-1 with its au-contraire partner
;; G RHYTHM
;; 1, 2, or 3 even atx per 8th note (heap)

(events
 (let ((pits
	(make-poly 
	 (interlock sopr
		    (au-contraire sopr 56)
		    2 1)
	 (heapvec 45 3 1))))
   (splay (flatten pits)
	  (ornadurs pits .5)))
 "stroll.mid" :play 'nil)

; variation H = 'wilder'

;; H -- two coordinated lines
;; "sments" = 'entropy' applied to normal-form of each chord, 
;;    smoothed & placed into register 5 (depth 2 list)
;; TOP LINE = 'sments' flattened and placed into registers by 'following-5'
;; BOTTOM LINE = soprano tune; note changes at the same time as its 'entropy' vec  

(events
 (let* ((sments
	 (placereg
	  (mapcar #'smoothlist
		  (mapcar #'entropy
			  (mapcar #'normal-form hanpits)))
	  5)))
   (list
    (splay
     (transp (placereg (flatten sments) following-5) 24)
     .125)
    (splay (transp sopr -12) (transp (mapcar (lambda (x) (length (flatten x))) sments) .125 #'*))))
 "wilder.mid" :play 'nil)

; variation I = 'coro'

;; I PITCHES
;; for each soprano pitch, a 'lewin-ionian' vector in Ab is 
;;    randomly selected that contains that pitch.
;;    the sopr pitch is dropped & the vec (now pair) is re-ordered 
;;    by 'closest-mod-list'. Each pair
;;    is placed alternately in reg's 3 & 5, soprano into reg 4.
;; I RHYTHM = hymn durations * 2

(events
 (playchds->lines
  (map 'list #'append (not-flat (transp sopr -12))
       (placereg
	(closest-mod-list
	 (loop for s in (mod12 sopr) collect
	       (set-difference 
		(pickl
		 (filter (lambda (x) (member s x)) 
			 (mod12 (transp lewin-ionian 8))))
		(list s))))
	'(3 5)))
  (transp handurs 2 #'*))
 "coro.mid" :play 'nil)