; St. Frances 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")

; PRESETS, INPUT DATA, ETC.
; LOAD FIRST

(define stfran
    (list
     (list
      (transp
       '((58 67 51 55) (63 68 51 60) (63 67 51 58) (62 65 46 56) (63 63 48 55)
	 (65 70 50 58) (65 68 50 58) (63 67 51 58) (63 67 51 58) (65 65 50 58)
	 (62 70 46 53) (67 72 51 55) (65 72 53 57) (62 70 46 58))
       -1) 
      (append (copylist '(1) 13) (list 3)))
     (list
      (transp
       '((65 70 50 56)
	 (63 75 51 55) (61 67 51 58) (60 68 44 56) (63 72 44 56) (62 70 46 53)
	 (62 68 46 58) (63 67 51 58) (61 67 51 58) (60 68 44 56) (60 65 44 56)
	 (58 63 46 55) (58 62 46 53) (58 63 51 55)) 
       -1)
      (append (copylist '(1) 13) (list 3)))))


(define sfchds (append (first (first stfran))
		       (first (second stfran))))

(define sfryt (append (second (first stfran))
		       (second (second stfran))))

(define sopr (nth 3 (chds->lines sfchds)))
(define alto (nth 2 (chds->lines sfchds)))
(define tenor (nth 1 (chds->lines sfchds)))
(define bass (nth 0 (chds->lines sfchds)))

(define dmajor (transp-mode ionian 2))

;; randomized hymn durations, as integers
(defun theselens (mult)
  (loop for r in sfryt collect (floor (vary (* r mult) .3))))

;; FINAL VARIATIONS BELOW

; variation A = 'tiles'

;; A SUMMARY
;; "tilevec6r" = (1 2 3 4 5 6 3 4 3 4 1 2 7 6 5 1 2 6 7 5 8 7 8 8)
;; -- sopr melody is grouped into list of 3s; each is transposed to 7 different 
;; D-major scale degr  +/- octave and tiled (w/ rests @ 1 group) into 'tilevec6r' @ 16th

(define sop2
    (mapcar (lambda (x) (modenums x dmajor))
	    (butlast
	     (make-poly sopr 3))))

(events
 (let ((pits
	(play-mode
	 (flatten
	  (loop for so in sop2 collect 
		(place-cantiles so (shuffle (cons 'r (heapvec 7 15 -7))) tilevec6r))
	  ) dmajor)))
   (splay pits .25))
 "tiles.mid" :play 'nil)

; variation B = 'rgr'

;; B PITCHES
;; triads are built down from adjusted soprano, 
;;   & paths made via Reger transformation btwn. triads
;; B RHYTHM
;; chords become lines & repeats become ties. 
;; durations at 8th * poisson-vector (prob .4, +1)

;; selection from ATB in each chord to complete triadic normal-form 
(define trdacc
 '((9 2) (2 11) (9 2) (1 9) (6 11) (4 1) (4 1) (9 2) (9 2) (1 9) (4 1) (6 3)
    (8 4) (4 1) (4 1) (9 6) (9 2) (11 2) (2 7) (4 1) (1 11) (9 2) (9 2) (11 2)
    (11 8) (9 6) (4 9) (9 6)))

;; soprano line, adjusted to make all chords triadic e.g. replaced 7th note (67 by 69)
(define sopr-adj
    '(66 67 66 64 62 69 69 66 66 64 69 71 71 69 69 74 66 67 71 69 67 66 66 67 64 62
      61 62))

;(define rgr-chds
;    (let ((chds
;	   (mapcar #'stack-down
;		   (map 'list #'cons sopr-adj (mapcar #'shuffle trdacc)))))
;      (rgr-branch chds nil 'tr)))

(define rgr-chds
    '(((66 62 57) (59 62 66)) ((67 62 59) (59 62 66)) ((66 62 57) (66 57 61))
      ((64 61 57) (54 57 61) (62 54 57)) ((62 54 47) (50 54 69) (54 69 61))
      ((69 64 61)) ((69 64 61) (54 69 61)) ((66 57 50)) ((66 62 57) (66 57 61))
      ((64 61 57)) ((69 64 61) (66 69 61) (62 66 69) (71 62 66))
      ((71 66 63) (56 71 63))
      ((71 64 56) (64 55 71) (55 71 62) (71 62 54) (62 54 69) (54 69 61))
      ((69 64 61)) ((69 64 61) (66 69 61)) ((74 69 66)) ((66 62 57) (59 50 66))
      ((67 59 50)) ((71 62 55) (71 62 54) (62 54 69) (54 69 61)) ((69 61 52))
      ((67 61 59)) ((66 57 50)) ((66 57 50) (59 50 66)) ((67 62 59) (64 55 59))
      ((64 59 56) (64 55 59) (55 59 62) (59 62 54)) ((62 57 54) (54 57 61))
      ((61 57 52) (54 57 61)) ((62 57 54))))

(events
 (play-ties
  (chds->ties
   (loop for chd in rgr-chds append chd))
  (transp (transp (poissonvec .4 200) 1) .5 #'*))
 "rgr.mid" :play 'nil)

; variation C = 'elab'

;; C SUMMARY 
;; slonim-patterns created between sopr's D-major scale degrees. each intervening
;;   pattern runs at 32nds, with hymn pits changing every half-note

(events
 (let ((treepits
	(slonim-expand
	 (modenums sopr dmajor)
	 'fl)))
   (splay (append (play-mode (flatten treepits) dmajor) (list 62))
	  (append
	   (transp (dnbeats treepits (copylist '(16) (length treepits))) .125 #'*)
	   (list 2))))
 "elab.mid" :play 'nil)

; variation D = 'ttduo'

;; D -- two lines
;; TOP LINE PITCHES = hymn soprano
;; TOP LINE RHYTHM = randomized hymn durs applied across total
;;   length of bottom line, summed across 'bdurs' (16th triplets +, 16ths, by poisson) 
;; BOTTOM LINE PITCHES = tenor part, expanded by slonim patterns between notes
;; BOTTOM LINE RHYTHM = 'theselens' across (max sublist length) + 3, across
;;   'bdurs' (16th triplets + 16ths, by poisson)
;; SUMMARY: tenor & soprano move together, with interpolating slonim in tenor

(events
 (let* ((ten (slonim-expand tenor 'g))
	(lens (mapcar #'length ten))
	(baselen (+ 3 (apply #'max lens)))
	(durs (butlast (theselens baselen)))
	(bdurs (ferney '(1) (chooser (clip-hi 1 (poissonvec .4 400)) '(6 4)))))
   (list
    (splay sopr (sum-across bdurs durs))
    (splay (flatten ten) (sum-across bdurs (dnbeats ten durs)))))
 "ttduo.mid" :play 'nil)

; variation E = 'bzrip'

;; E -- two lines
;; TOP LINE PITCHES = S,A,T pitches gathered; bzms-chains of length 2,3,4 are made of each
;;   consecutive pair; these are shuffled internally, flattened, and repeats removed
;; TOP LINE RHYTHM = 'theselens' randomized hymn durs (factor 5) added to length
;;   of each pitch vector. 'dnbeats' with pitch vecs summed across subdivs 4,5,6 of quarter 
;;   (by poisson .4 - weighted as 4,6,5)
;; BOTTOM LINE PITCHES = hymn bass
;; BOTTOM LINE RHYTHM = coordinated with vector in top line 
;;   (dyads always correspond to hymn chords)

(events
 (let* ((pits
	 (not-flat
	  (merge-slots 
	   (list
	    (not-flat tenor)
	    (not-flat sopr) 
	    (not-flat alto)))))
	(treepits
	 (mapcar #'smoothlist
		 (mapcar #'norests
			 (loop for n to (- (length pits) 2) collect
			       (bzms-chain (nth n pits) (nth (+ n 1) pits) (pick 2 3 4))))))
	(flatpits (mapcar (lambda (x) (norpt (flatten (shuffle-all x)))) treepits))
	(lens (map 'list #'+ (theselens 5) (mapcar #'length flatpits)))
	(bdurs (ferney '(1) (chooser (clip-hi 2 (poissonvec .4 300)) '(4 6 5)))))
   (list
    (splay bass (sum-across bdurs lens))
    (splay (flatten flatpits) (sum-across bdurs (dnbeats flatpits lens)))))
 "bzrip.mid" :play 'nil)

; variation F = 'shiftd'

;; F -- quick line + dyad accompaniment
;; FAST LINE PITCHES = 2nd-order markov of soprano
;; FAST LINE RHYTHM = random subdivs 2,3 of 8th
;; ACCOMPANIMENT PITCHES = poisson .4 chooses # of pitches between
;;   extracted pitches in fast-line (hi-to-low probability = 9,8,7,6,5,4).
;;   slonim built from extracted pits w/ chord (0,-15,5 s.t.);
;;   re-voiced ('matchreg') to minimize leaps

(events
 (let* ((pits (norpt (next (markov-analyze sopr :order 2) 300)))
	(idxs (chooser (poissonvec .4 21) '(9 8 7 6 5 4)))
	(startpit (first pits))
	(sloline (slowline pits idxs))
	(slosd (slots->durs sloline))
	(slopits (first slosd))
	(slodurs (second slosd))
	(acc
	 (matchreg-chds
	  (second
	   (slonim 
	    (list (- startpit 15) (+ startpit 5))
	    slopits
	    'nom))))
	(durs (ferney '(.5) (next (new weighting of '(2 3)) 500))))
   (list
    (splay pits durs)
    (splay acc (sum-across durs slodurs))))
 "shiftd.mid" :play 'nil)

; variation G = 'space'

;; G PITCHES
;; slonim (F#5,C#5,G#4 + sopr line) with paths using Reger transformation.
;;   chords become tied lines. 
;; G RHYTHM
;; ties across (8ths * attack pts on multiples of 3 & 7)

(events
 (play-ties
  (chds->ties
   (rgr-branch 
    (slonim '(61 56) sopr) 'flat))
  (transp 
   (second
    (slots->durs
     (code->slots
      (resclassvec 3 7) (copylist '(1) 100))))
   .5 #'*))
 "space.mid" :play 'nil)

; variation H = 'susp'

;; H PITCHES
;; soprano line (2 copies) are placed in reg 3-5 by heap 
;; H RHYTHM
;; sopr pitches articulated, in order, by quarter throughout the 3 registers

(events
 (let* ((sds
	 (mapcar #'slots->durs
		 (parse-by-reg
		  (placereg (copylist sopr 2) (new heap of '(3 4 5))))))
	(mties (loop for s in sds collect (make-ties (first s)))))
   (loop for n to (- (length sds) 1) collect
	 (splay (first (nth n mties)) (sum-across (second (nth n sds))
						  (second (nth n mties))))))
 "susp.mid" :play 'nil)

; variation I = 'blocks'

;; I -- TWO PARTS
;; BASS CHORDS - PITCHES
;; tenor & bass are merged 1-1 and Boulez-multiplication chain, length 2, is made
;;   of each consecutive pair in the list of dyads. results are smoothed (immediate
;;   repeats btwn sublists are removed). resulting chords are stacked by P4 and 
;;   registers adjusted for conjunct motion ('matchreg-chds')
;; BASS CHORDS - RHYTHM
;; randomized hymn durs ('theselens') summed across 8th/triplet poisson alternation.
;;   chord attacks follow soprano by 1 'count' across the basedur.
;; TOP LINE - PITCHES
;; hymn soprano, up P8
;; TOP LINE - RHYTHM
;; randomized hymn durs ('theselens') summed across 8th/triplet poisson alternation.

(events
 (let* ((pits
	 (not-flat
	  (merge-slots 
	   (list
	    (not-flat tenor)
	    (not-flat bass)))))
	(treepits
	 (mapcar #'smoothlist
		 (mapcar #'norests
			 (loop for n to (- (length pits) 2) collect
			       (bzms-chain (nth n pits) (nth (+ n 1) pits) 2)))))
	(tlens (theselens 9))
	(bdurs (ferney '(1) (chooser (clip-hi 1 (poissonvec .4 300)) '(2 3))))
	) 
   (list
    (splay 
     (matchreg-chds
      (mapcar (lambda (x) (car (stack-by (remove-duplicates (flatten x)) 5))) 
	      treepits))
     (sum-across bdurs (cons (+ 1 (car tlens)) (cdr tlens))))
    (splay (transp sopr 12) (sum-across bdurs tlens))))
 "blocks.mid" :play 'nil)