; Hesperus 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")

; PRESETS, INPUT DATA, ETC.
; LOAD FIRST

(define hespmid
    (midi-in "Hesperus-0.mid"))

;; 4pt version of hymn
(define hespits
    (mapcar #'safesort
	    '((65 69 53 60) (65 69 53 60) (65 69 53 60) (65 72 45 60) (65 65 45 60)
	      (65 67 46 62) (64 67 48 60) (65 69 53 60) (65 72 57 60) (65 72 57 60)
	      (65 72 57 60) (62 70 55 62) (64 67 48 60) (65 69 53 60) (67 70 46 62)
	      (64 67 48 60) (64 67 48 60) (64 67 48 60) (64 67 48 60) (65 67 47 62)
	      (65 67 47 62) (65 71 43 62) (65 67 55 59) (64 72 48 60) (65 69 53 60)
	      (64 69 53 60) (63 69 53 60) (62 69 46 58) (62 67 46 58) (62 65 47 57) (60 65 48 55)
	      (60 64 48 58) (60 65 53 57))))

;; hymn pits including n.h. tones
(define alt-hespits 
    (mapcar #'safesort
	    (not-flat
	    (first hespmid))))

;; non-repeating normal forms in hymn
(define hespnorms
    (norpt
     (mapcar #'normal-form hespits)
     #'list-eql))

;; integer durs corresp. to hespits
(define hespdurs
    '(1 1 1 2 1 2 1 3 1 1 1 2 1 2 1 3 1 1 1 2 1 2 1 3 1 1 1 1 1 1 2 1 3))

;; phrase lengths for hespdurs
(define hesphrases '(8 8 8 9))

; Boulez-ian 'demultiplication' of first phrase durs (as integers, length 64)
(define hesp-demult
    (hits->ints
     (motive->durs
      (demultiplied-motive
       (durs->motive
	(first (make-poly hespdurs hesphrases)))))))

; Boulez-ian 'multiplication' of first phrase durs (as integers, length 64)
(define hesp-mult
    (motive->durs
     (multiplied-motive
      (durs->motive
       (first (make-poly hespdurs hesphrases))))))

(define hesplines
    (chds->lines hespits))

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

(define fmajor (transp-mode ionian 5))

;; randomized durs (as integers)
(defun theselens (factor)
  (loop for d in (hits->ints hespdurs) collect
	(floor (vary (* d factor) .3))))

;; FINAL VARIATIONS BELOW

; variation A = 'bright'

;; A PITCHES
;; "rbranch" = Reger-transformation paths between the hymn's normal forms (in sequence)
;; -- each chd in 'rbranch' is shuffled internally, then 1-3 versions of the chd 
;;      'stacked by' P5 are gathered & all transposed to C4. Each chd is shuffled,
;;      the list is flattened, & repeats are removed.
;; A RHYTHM
;; motoric 16ths. Whenever an F occurs, it & the pitch following appear as
;;    a pair of 32nds. A triplet happens whenever 2 F's appear together, etc.

; (define rbranch
;    (generic-branch #'rgr-alldim1 hespnorms))

(define rbranch
    '(((5 9 0)) ((2 5 7 10)) ((0 4 7) (0 4 9)) ((5 9 0) (5 9 2) (5 10 2) (7 10 2))
      ((7 11 2) (7 11 4) (12 7 4)) ((0 4 7) (0 4 9))
      ((5 9 0) (5 9 2) (5 10 2) (7 10 2)) ((7 11 2) (7 11 4) (12 7 4)) ((0 4 7))
      ((11 2 5 7)) ((5 9 11)) ((0 4)) ((5 9 0)) ((4 5 9 0)) ((9 0 3 5)) ((9 1 2))
      ((7 11 2)) ((9 11 2 5)) ((5 10 0)) ((10 2 4)) ((5 9 0))))

(events
 (let ((pits
	(gather-pits 
	 (lambda (a b) (eql 5 (mod12 a)))
	 (norpt
	  (flatten
	   (shuffle-all
	    (transp 
	     (loop for x in 
		   (shuffle-all
		    (flatter rbranch))
		   append (subseq (stack-by x 7) 0 (+ 1 (random 3))))
	     48)))))))
   (splay (flatten pits) (ornadurs pits .25)))
 "bright.mid" :play 'nil)

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

;; B -- two lines
;; TOP LINE = SAB chords are repeated according to hymn durations, then 6 pits from
;;      each 3-note chd are selected in seq by index according to 5th-gen 'sfree3rules'.
;;      monophic 16ths [repeats @ ties]
;; BOTTOM LINE = hymn bass w/ repeats @ ties
;; [var2b = triplets become straight 16ths]

(events
 (let* ((scyc (makecyc (rwgen sfree3rules '(0) 5)))
	(mties
	 (make-ties
	  (loop for chd in 
		(repeater
		 (map 'list #'append (not-flat sopr) (not-flat alto) (not-flat tenor)) 
		 hespdurs)
		append (chooser (next scyc 6) chd)))))
   (list
    (splay (first mties) (transp (second mties) 1/6 #'*))
    (splay (first (make-ties bass))
	   (sum-across hespdurs (second (make-ties bass))))))
   "arpg.mid" :play 'nil)

; variation C = 'mule1'

;; C -- process sim. to Verlaine settings
;; PITCHES
;; four parts in 'hyperlydian' mode; each a random non-repeating melody of ambitus 4
;; RHYTHM
;; each part uses its own 'poetmult' (based on randomized hymn durs)
;;   summed across 'fernbase' (half-notes div by 5 then 3-7 4s)

;; generalized dur structure of hymn:
;; U=short, S=sustained, E=end, FIN=final end
(define hesp-vers '(((U U U S U S U E) 
		     (U U U S U S U E) 
		     (U U U S U S U E) 
		     (U U U U U U S U FIN))))

;; converts U,S,E,FIN to randomized integer durations
(defun poetmult (x)
  (if (listp x) (loop for y in x collect (poetmult y))
  (case x 
    (u 1)
    (e (+ 5 (random 5)))
    (fin 10)
    (s (+ 2 (random 2))))))

;; 5's interspersed with 3-7 4's
(define strummer (transp (strums 100 2 2 3 7) 3))

;; strummer div across half-notes
(define fernbase (ferney '(2) strummer))

(define (mulebyvers versenum basepit modename)
    (let* ((tlevel 0)
	   (thisvers (flatten (nth versenum hesp-vers)))
	   (verselen (length thisvers)))
      (process 
	for x in 
	(transp (play-mode 
		 (transp 
		  (randmel (length thisvers) 4) basepit) modename) tlevel)
	for dur in (sum-across fernbase (poetmult thisvers))
	when (or (numberp x) (listp x))	;; needed for rests
	output (multievent 'midi :keynum
			   :keynum x
			   :time (now)
			   :duration dur)
	wait dur)))

(events (list
         (mulebyvers 0 25 hyperlydian)
         (mulebyvers 0 30 hyperlydian)
         (mulebyvers 0 35 hyperlydian)
         (mulebyvers 0 40 hyperlydian)) "mule1.mid")

; variation D = 'srot' into 'var4b'

;; D PITCHES
;; each phrase in sopr: rpts removed & then 2nd-deg stravrot recurz
;;   flattened list collected into 3s, then 'smoothed' (rpted pitches removed)
;;   each pit then transposes (C4 G4 C5), each is shuffled, then all flattened 
;; D RHYTHM = 16th triplets
;; ["var4b" = triplets become straight 16ths]

(events
 (splay
  (flatten
   (shuffle-all
    (mapcar (lambda (x) (transp '(60 55 48) x))
	    (flatten
	     (smoothlist
	      (make-poly 
	       (flatten
		(mapcar (lambda (x) (last (recurz #'stravrot x 2)))
			(mapcar #'norpt (make-poly sopr hesphrases))))
	       3))))))
  1/6)
 "srot.mid" :play 'nil)

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

; variation E = 'outside'

;; E PITCHES
;; "mypairs" = sopr + bass lines, 1 to 1 match
;; "mpoly" = 'bzms-chain' length 4 is made from each 2 consec 'mpairs', 
;;              then mod12'ed, regrouped into sublists len 3 & smoothed.
;;              repeats removed, then gathered into 1 & 2-length lists 
;;              by 7-length 'interlock'.
;; "pits" = 'mpoly' pits are placed (indiv.) by heap into octaves 3-6,
;;              then re-assembled into poly
;; E RHYTHM
;; polyphony vec of 'pits' (1 2 etc.) is used to choose base: divs of quarter by 3 or 4
;;  resclassvec of 2,3,7 + 1 determines ties over base rhythm

(events
 (let* ((mypairs
	 (map 'list #'append (not-flat sopr) (not-flat bass)))
	(mpoly
	 (make-poly
	  (norpt (flatten
		  (smoothlist
		   (make-poly
		    (mod12
		     (flatten
		      (map 'list (lambda (a b) (bzms-chain a b 4))  mypairs (cdr mypairs))))
		    3))))
	  (interlock '(1) 
		     '(2)
		     (randvec 7 2 1)
		     '(1))))
	(tpoly (take-poly mpoly))
	(pits
	 (make-poly 
	  (placereg (flatten mpoly) (new heap :of '(3 4 5 6)))
	  tpoly)))
   (splay pits
	  (sum-across
	   (ferney '(1) (chooser (transp tpoly -1) '(3 4)))
	   (copylist
	    (transp (resclassvec 2 3 7) 1)
	    10))))
 "outside.mid" :play 'nil) 

; variation F = 'runny'

;; F PITCHES
;; each phrase of sopr+12 is presented, followed by its 4vc self-stretto at P5 below.
;;   repeats are removed.
;; F RHYTHM = motoric 32nds

(events
 (let ((pits
	(gather-pits #'eql
		     (flatten
		      (not-flat
		       (loop for m in (make-poly (transp sopr 12) hesphrases) append
			     (self-stretto m 4 -7)))))))
   (splay 
    (norpt (flatten pits)) .125))
 "runny.mid" :play 'nil)

; variation G = 'lazy'

;; G PITCHES
;; each chord in orig. hymn is shuffled & flattened
;; G RHYTHM
;; 'hesp-demult' + its retrograde (@ cycle) determines ties across
;;      3,4,5-divs of quarter note (selected as heap)

(events
 (let* ((pits
	 (flatten
	  (shuffle-all alt-hespits))))
   (play-sd
    (make-ties pits)
    (sum-across
     (ferney '(1) (heapvec 150 3 3))
     (next 
      (makecyc
       (append
	hesp-demult
	(butlast
	 (cdr
	  (reverse hesp-demult)))))
      (length (flatten alt-hespits))))))
 "lazy.mid" :play 'nil)

; variation H = 'susp'

;; H PITCHES
;; 4pt hymn made into ties
;; H RHYTHM
;; base durs: 3 randomly-selected rotations of 1st phrase durs, followed by 
;;   1 randomly-selected rotation of final phrase dur, all summing
;;   across poisson-vector of dotted-quarter & higher.
;; 4pt ties are taken across base durs above

(events
 (let ((durpatt
	(new heap :of
	     (allrots (first
		       (make-poly hespdurs hesphrases)))))
       (durpatt2
	(new heap :of
	     (allrots (car (last
			    (make-poly hespdurs hesphrases)))))))
   (loop for vc in (list sopr alto tenor bass)
	 collect
	 (let ((mtie (make-ties vc)))
	   (splay 
	    (first mtie)
	    (sum-across
	     (sum-across 
	      (transp (transp (poissonvec .2 150) 3) .5 #'*)
	      (flatten (append (next durpatt 3) (next durpatt2))))
	     (second mtie))))))
 "susp.mid" :play 'nil)