; Royal Oak 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")

; PRESETS, INPUT DATA, ETC.
; LOAD FIRST


;; hymn tune as pit/dur pairs within phrases
;; Royal Oak Tune [G4=0]
(define roak
    '(((7 4 5 4 2 0 -1 -3 -5)
       (1 1 1 1 .5 .5 .5 .5 1))
      ((4 5 -3 -1 -3 -1 0)
       (1 1 1 1 .5 .5 4))
      ((7 4 5 4 2 0 -1 -3 -5)
       (1 1 1 1 .5 .5 .5 .5 1))
      ((4 5 -3 -1 -3 -1 0)
       (1 1 1 1 .5 .5 3))
      ((-5 -8 -5 -5 -7 -8 -7 -3)
       (1 1 1 1 .5 .5 1 2))
      ((-7 -3 0 2 -1 0 2 -5)
       (1 .5 .5 1 .5 .5 1 3))
      ((0 2 4 2 0 2 4 5 4 2 4 5 7 -3 -1 -3 -1 0)
       (.5 .5 1 1 1 .5 .5 1 1 1 .5 .5 1 1 1 .5 .5 4))))

;; by phrase
(define roak1 (first roak))
(define roak2 (second roak))
(define roak3 (nth 4 roak))
(define roak4 (nth 5 roak))
(define roak5 (nth 6 roak))

;; complete melody
(define roakmel
    (loop for r in roak append (first r)))
(define roakryt
    (loop for r in roak append (second r)))

; home key
(define gmajor (transpose ionian 'g))

; each phrase presented in motive-form
(define rmotives
    (mapcar 
     (lambda (x) 
       (list (copylist (list 1) (length (second x)))
	     (second x)))
     roak))

;; durs as 's'hort/'m'edium/'l'ong durations 
(define roaklens 
    (loop for x in roakryt collect
	  (cond ((eql x 1) 'm)
		((< x 1) 's)
		(t 'l))))

;; randomized durs, as integers
(define thesedurs
    (loop for r in roaklens collect
	  (case r 
	    (m (pick 3 4))
	    (l (pick 4 5 6))
	    (s 2 3))))


;; FINAL VARIATIONS BELOW

; variation A = 'rescv' then 'bounce'

;; "rescv" = sopr line is placed into regs 2,3,4 by cycle. 
;;   attacks whenever atk-point is a multiple of 3,5,7 

(events
 (splay
  (make-poly
   (placereg
    (mod12 (transp roakmel 67))
    (new cycle :of '(2 3 4)))
   (resclassvec 3 5 7))
  .25)
 "rescv.mid" :play 'nil)

;; "bounce" = every 3 pits of melody are followed by 
;;   list of their best to worst stackings by P4.
;;   transposed to G5 & repeated pits are removed from chds

(events
 (splay
  (smoothlist
   (transp 
    (loop for mp in
	  (make-poly roakmel 3)
	  append (stack-by mp 5))
    67))
  .25)
 "bounce.mid" :play 'nil)

; variation B = 'weave' against 'rkmel'

;; "weave" = 2nd order markov chain of g-major scale degr in soprano line
;;    is doubled at P5 below every 3,4 attacks

(events
 (splay
  (let* ((ipits (play-mode
		 (melint->line 35
			       (next (markov-analyze 
				      (melint (modenums roakmel gmajor)) :order 2) 150))
		 gmajor)))
    (merge-slots
     (list ipits
	   (transp (slowline ipits '(4 3)) -7))))
  .25)
 "weave.mid" :play 'nil)

;; "rkmel" = (bass) sopr line is dim. by .6 and quantized to nearest 16th

(events
 (splay (transp roakmel 43) 
	(quantdurs (transp roakryt .6 #'*) .25))
 "rkmel.mid" :play 'nil)

(events
 (playmids "rkmel.mid" "royaloak/weave.mid")
 "out.mid" :play 'nil)

; variation C = 'pmode'

;; C -- three lines
;; "bline" (bass) = sopr melody, matches every 4 attacks of top line 
;; "tline" (top line)
;;    pitches: each sopr melody pitch is added to 3 randomly-selected pitches
;;        within the octave above it in G major; the result is shuffled and 
;;        flattened, and 'filtered' into D major
;;    rhythm: (poisson vector + 1, prob .4) * 16th note
;; "mline" (middle line)
;;    pitches: every 5,6 pitches in top line is lowered 19 s.t. and filtered
;;        into D major
;;    rhythm: matches every 5,6 attacks in top line

(events
 (let* ((bline (transp (transp roakmel 67) -24))
	(tline  
	 (tintab
	  (play-mode
	   (transp 
	    (flatten
	     (mapcar (lambda (x) (shuffle (heapvec 4 7 (+ x 1))))
		     (modenums (transp roakmel 67) gmajor))
	     )
	    0)
	   gmajor)
	  (transpose gmajor 'a)))
	(tryts (transp (poissonvec .4 (length tline)) 1))
	(bryts (mapcar (lambda (x) (apply #'+ x)) (make-poly tryts 4)))
	(dmajor (transpose gmajor 'd))
	(mline (tintab (transp (norests (slowline tline '(5 6))) -19) dmajor))
	(mryts (mapcar (lambda (x) (apply #'+ x)) (make-poly tryts '(5 6)))))
   (list
    (splay bline (transp bryts .25 #'*))
    (splay tline (transp (flatten tryts) .25 #'*))
    (splay mline (transp (flatten mryts) .25 #'*))))
 "pmode.mid" :play 'nil)

; variation D = 'polylew'

;; D -- three lines
;; middle line = sopr melody w/ randomized hymn durs @ 16th
;; outer parts - pitch: for each sopr note, a 'lewin-ionian' scaledeg trichord in G-major that 
;;    contains the note is selected. the other two members of the chord
;;    are assigned to the top & bottom parts randomly.  
;; outer parts - rhythm: the outer parts are randomly assigned a 16th slot during the middle
;;    pitch's duration, before the next middle pitch (random arpeggiation) 

(events
 (let* ((lewchds (mod12 (transp lewin-ionian 7)))
	(gmaj-mel (mod12 (transp roakmel 7)))
	(outpairs
	 (shuffle-all
	  (loop for gm in gmaj-mel collect
		(pickl
		 (no-nils
		  (mapcar (lambda (x) (if (member gm x) (set-difference x (list gm))))
			  lewchds))))))
	(lopits (placereg (mapcar #'first outpairs) 1))
	(hipits (placereg (mapcar #'second outpairs) 4))
	(loline (loop for n to (- (length lopits) 1) 
		      append (place-slots (random (nth n thesedurs)) (nth n lopits) (nth n thesedurs)))) 
	(hiline (loop for n to (- (length hipits) 1) 
		      append (place-slots (random (nth n thesedurs)) (nth n hipits) (nth n thesedurs))))
	(losd (slots->durs loline))
	(loties (make-ties (first losd)))
	(hisd (slots->durs hiline))
	(hities (make-ties (first hisd))))
   (list
    (splay (transp roakmel 55) (transp thesedurs .25 #'*))
    (splay (first loties) (transp (sum-across (second losd) (second loties)) .25 #'*))
    (splay (first hities) (transp (sum-across (second hisd) (second hities)) .25 #'*))))
 "polylew.mid" :play 'nil)

; variation E = 'slonim2'

;; E -- two lines
;; top line = sopr melody verbatim
;; bottom chords
;;   pitches: 
;; "plcs" = (4 5) interlocked with an interlocked 2,3 list @ 1,9 atx. 
;;     built up as intervals from 0, and cut off at 66.
;; "plcmel" = 'plcs' used as index #s to choose pitches from sopr melody
;; "chds" = accompaniment-only 'slonim' of A3,G4,C5 against 'plcmel', using
;;    'matchreg-chds' for conjunct motion
;; bottom line (summary): does selective coordinated A3,G4,C5 'slonim' against melody
;;    notes chosen with 'plcs'

(events
 (let* ((plcs (filter
	       (lambda (n) (< n 66))
	       (melint->line 0
			     (interlock '(4 5)
					(interlock '(2) '(3) (indices 5) (reverse (indices 3)))
					1 9))))
	(plcmel (loop for n in plcs collect (nth n (transp roakmel 67))))
	(chds (matchreg-chds (second (slonim (transp '(0 10 15) 45) plcmel 'nomrg))))
	(sdchd (slots->durs
		(loop for n to 65 collect
		      (if (member n plcs) (nth (position n plcs) chds) 'r)))))
   (list
    (splay (transp roakmel 67) roakryt)
    (splay (first sdchd) 
	    (sum-across roakryt (second sdchd)))))
   "slonim2.mid" :play 'nil)

; variation F = 'v7alt' [sim. to 'flashort']

;; F PITCHES
;; every other subsequence length 4 is taken from sopr. 
;; each subseq is 'stacked' by P4 & the best 3 are gathered into a list.
;; this list is 'smoothed' & the entire list is flattened and
;;   made polyphonic by poisson-vector (1 or 2, mostly 1, prob .4)
;; F RHYTHM
;; basic rhythm of [8th,16th,16th,8th] is traversed/tied according
;;   to the register of the highest pitch for each attack: 
;;   reg7 = 1, reg6 = 1, reg5 = 2, reg4 = 3

(events
 (let* ((thzpits (loop for n to 62 by 2 collect
		       (subseq roakmel n (+ n 4))))
	(pits  (make-poly
		(flatten
		 (smoothlist
		  (transp 
		   (loop for mp in thzpits
			 append (subseq (stack-by mp 5) 0 3))
		   55)))
		(transp (clip-hi 2 (poissonvec .4 300)) 1))))
   (splay pits 
	  (sum-across
	   '(1/2 1/4 1/4 1/2)
	   (listsub '(1 1 2 3) '(7 6 5 4)
		    (takereg (topline pits)))
	   )))	   
 "v7alt.mid" :play 'nil)

; variation G = 'clouds2'

;; G PITCHES
;; for each pitch in sopr, a vector is made of the other six scaledegs in G major.
;; these vectors are shuffled and 'stacked up' by P5.
;; the entire list is then shuffled internally & flattened, and polyphony is made
;;   with 2,3 heap vector
;; G RHYTHM 
;; 3,4 subdivs of quarter is summed across by: (7 8 9 10 11) interlocked with (8 7 6 5)

(events
 (splay
  (make-poly
   (flatten
    (shuffle-all
     (mapcar
      (lambda (x) (transp (play-mode (stack-up (shuffle x) 7) gmajor) 36))
      (loop for m in 
	    (modenums (transp roakmel 7) gmajor)
	    collect (set-difference (indices 7) 
				    (list (mod m 7)))))))
   (heapvec 200 2 2))
  (sum-across
   (ferncyc '(1) 
	    (randvec 43 2 3))
   (interlock
    (indices 5 7)
    (reverse (indices 4 5))
    '(1) '(1)))
  )
 "clouds2.mid" :play 'nil)

; variation H = 'snappy'

;; H PITCHES
;; sopr line is copied 5 times, then placed in registers 2-4
;;   according to 3,5,7 resclassvec + 2
;; H RHYTHM
;; 8ths divided randomly into 2,3,4 (weighted 8:1 in favor of 2)

(events
 (splay
  (placereg
   (copylist (mod12 roakmel) 5)
   (transp (resclassvec 3 4 7) 2)
   )
  (ferney '(1/2) 
	  (next
	   (new weighting :of '((2 :weight 8) 3 4)) 100)))
 "snappy.mid" :play 'nil)

; variation I = 'noodle'

;; I PITCHES
;; a G major scale of random length (0-6) begins on each note of
;;  the sopr melody.
;; doubling at consonances: 7,11 resclassvec augmentation of
;;  sopr melody (5x)
;; I RHYTHM = motoric 32nds

(events
 (let ((pits
	(loop for mn in
	      (modenums (transp roakmel 55) gmajor)
	      collect 
	      (play-mode (indices (random 7) mn) gmajor)))
       (vc2 (code->slots
	     (copylist 
	      (clip-hi 1
		       (resclassvec 7 11))
	      5)
	     (transp roakmel 67))))
   (splay
    (not-flat
     (consmatch vc2 (flatten pits)))
    .125))
 "noodle.mid" :play 'nil)

; variation J = 'trips1' against 'trips2'

;; J PITCHES
;; "dchdsraw" = takes all combos of 4 scale degrees in G major, and groups them 
;;    into sublists by 'diachrom' factor (most consonant first)
;; "dchds" = removes any group in 'dchdsraw' with fewer than 7 unique pits
;; "cidx" = generates a 0-(len cidx) random # (weighted to low) for each pit in sopr tune 
;; "gmaj-mel" = sopr pits in G major
;; "accompraw" = for each G-major sopr pitch, picks a chd from 'dchds's 'cidx' sublist
;;      that contains that pitch & removes the pitch from it
;; TOP LINE (summary): for each sopr note, randomly picks 4-note chd of G-major scale degr 
;;      that contains it, with 'diachrom' factor random (but mostly consonant).
;;      shuffles & stacks up the remainder (acc). repeats become ties at 16th.
;;      so, btwn 2 voices the full 4-note chd is articulated on each dotted 8th.
;; BOTTOM LINE: soprano line @ dotted 8th

; using diachrom to choose harmonizing chords
(events
 (let* ((dchdsraw (mod12
		   (diachrom-sets
		    (subsets-len
		     (play-mode (indices 7) gmajor)
		     4))))
	(dchds (no-nils 
		(mapcar (lambda (x) (if (< 6 (length (safesort (remove-duplicates (flatten x))))) x))
			dchdsraw)))
	(cidx 
	 (clip-hi (- (length dchds) 1)
		  (loop repeat (length roakmel) collect 
			(floor (* 4 (ran :type :low-pass))))))
	(gmaj-mel (mod12 (transp roakmel 7)))
	(accompraw
	 (loop for n to (- (length roakmel) 1) collect
	       (pickl
		(no-nils 
		 (mapcar (lambda (x) 
			   (if (member (nth n gmaj-mel) x) (set-difference 
							    x
							    (list (nth n gmaj-mel)))))
			 (nth (nth n cidx) dchds))))))
	(hints (hits->ints roakryt))
	) 
   (play-sd
    (make-ties
     (flatten
      (mapcar (lambda (x) (placereg (stack-up (shuffle x)) 4)) 
	      accompraw)))
    .25))
 "trips1.mid" :play 'nil)

;; bass for trips
(events
 (splay (transp roakmel 55) .75)
 "trips2.mid" :play 'nil)

; variation K = 'dupl'

;; K -- three lines
;; BOTTOM LINE = sopr tune, w/ties @ 8th
;; top two lines: extracted from 'diachrom' 4-note chords used in J
;; MIDDLE LINE = first pit from each 4-note chord, using ties @ eighth
;; TOP LINE = remaining two pits in each chd, using ties @ 16th
;; SUMMARY: sim. method to J, only accompaniment is split into two 
;;   upper lines & 4-note chds are articulated @ each 8th

(events
 (let* ((dchdsraw (mod12
		   (diachrom-sets
		    (subsets-len
		     (play-mode (indices 7) gmajor)
		     4))))
	(dchds (no-nils 
		(mapcar (lambda (x) (if (< 6 (length (safesort (remove-duplicates (flatten x))))) x))
			dchdsraw)))
	(cidx 
	 (clip-hi (- (length dchds) 1)
		  (loop repeat (length roakmel) collect 
			(floor (* 4 (ran :type :low-pass))))))
	(gmaj-mel (mod12 (transp roakmel 7)))
	(accompraw
	 (loop for n to (- (length roakmel) 1) collect
	       (pickl
		(no-nils 
		 (mapcar (lambda (x) 
			   (if (member (nth n gmaj-mel) x) (set-difference 
							    x
							    (list (nth n gmaj-mel)))))
			 (nth (nth n cidx) dchds))))))
	(hints (hits->ints roakryt))
	(lines
	 (chds->lines
	  (mapcar (lambda (x) (placereg (stack-up (shuffle x)) 4)) 
		  accompraw)))
	(midties (make-ties (transp (first lines) -12)))
	(topties 
	 (make-ties
	  (flatten
	   (shuffle-all
	    (merge-slots (list (second lines) (third lines)))))))
	)
;   (list
;    (play-sd midties .5)) ; for "midm.mid"
   (play-sd topties .25))
 "midt.mid" :play 'nil)

   (events
    (play-sd (make-ties (transp roakmel 43)) .5)
    "mids2.mid" :play 'nil)

   (events
    (playmids "midm.mid" "midt.mid" "mids2.mid")
    "dupl.mid" :play 'nil)

; variation L = 'arpegg' tweaked into 'v14alt'

;; L -- two lines
;; BOTTOM LINE PITS = sopr melody
;; BOTTOM LINE RHYTHM = 16ths summed by randomized durs ('thesedurs') 
;;   transformed by 'arplens' = [2(x-2)+2] + random(0-1)
;; TOP LINE = for each sopr note, selects major triad containing 
;;   it (weighted) and removing sopr note. resulting dyads
;;   are arpeggiated via 'arplens' above, and 3-note ascending contour
;;   pattern imposed on the entire list. repeats become ties. 

(events
 (let* ((entrop (mod12 (entropy (transp '(0 4 7) 7))))
	(chds
	 (loop for rm in (mod12 (transp roakmel 7)) collect
	       (set-difference
		(nth (floor (* 3 (ran :type :low-pass)))
		     (no-nils
		      (loop for e in entrop collect 
			    (if (member rm e) e))))
		(list rm))))
	(arplens 
	 (mapcar (lambda (x) (+ (random 2) (+ 2 (* 2 (- x 2)))))
		 thesedurs))
	(durs (ferney '(1)
		      (chooser (clip-hi 1 (poissonvec .2 500)) '(4 4))))
	(pits (flatten
	       (mapcar 
		(lambda (x) (give-contour-to-mel '(0 1 2) x))
		(butlast
		 (make-poly	
		  (arpegg (transp (flatten chds) 60) '(2) arplens)
		  3)))))
	(mtpits (make-ties pits)))
   (list
    (splay (transp roakmel 55) (sum-across durs arplens))
    (splay (first mtpits) (sum-across durs (second mtpits)))))
 "arpegg.mid" :play 'nil)

; variation M = 'copline' [uncertain]

;; M -- fast line over G pedal
;; PITCHES = lists of G-major pitches in 'heap' are made, each ending with sopr 
;; hymn pitch (in sequence). repeats become ties.
;; RHYTHM = each pit sublist runs at 32nds, except for final pit (hymn note),
;;   which follows [poisson .2] + 2 + [curved-path timefunc 0->15]
;; SUMMARY -- random G-major pits @ 32nds between lengthening hymn notes

(events
 (let* ((pheap (new heap :of (mod12 (play-mode (indices 8) gmajor))))
	(vecs (no-nils
	       (loop for m in (mod12 roakmel) collect 
		     (end-with pheap m))))
	(durs (loop for n to (- (length vecs) 1) 
		    collect (append (copylist '(1) (- (length (nth n vecs)) 1))
				    (transp (transp (poissonvec .2 1) 2)
					    (floor
					     (timefunc n
						       (curved-path 0 15 .2 (length vecs))))))))
	(cm 
	 (transp (flatten vecs) 79))
	(mties (make-ties cm))
	)
   (list
    (splay '(43) (transp (apply #'+ (flatten durs)) .125 #'*))
    (splay (first mties)
	   (transp (sum-across (flatten durs) (second mties)) .125 #'*))))
 "copline.mid" :play 'nil)