; Southwell 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

(define southmid
    (midi-in "Southwell-0.mid"))

;; 4pt chords
(define southpits
    (mapcar #'safesort
	    (first southmid)))

;; normal forms, non-repeating
(define southnorms
    '((4 8 11) (0 4 7) (4 6 9 0) (11 3 6) (4 8 11) (7 11 2) (4 7 9 0) (2 6 9)
      (7 11 2) (4 8 11) (7 0 2) (2 6 9) (0 4 7) (6 9 0 2) (7 11 2) (2 6 9)
      (7 11 2) (9 1 4) (4 8 11) (4 9 11) (11 3 6) (4 8 11)))

; hymn durations, as integers
(define southdurs
    '(1 1 1 1 1 3 1 1 1 1 1 3 1 1 1 1 1 1 1 1 1 1 1 1 1 3))

; # notes in each phrase
(define southphrases '(6 6 14))

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

;; Boulez 'multiplication' of first phrase, as integer durations
(define south-mult
    (motive->durs
     (multiplied-motive
      (durs->motive
       (first (make-poly southdurs southphrases))))))

(define southlines
    (chds->lines southpits))

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

(define eminor (transp-mode hminor 4))

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

;; FINAL VARIATIONS BELOW

; variation A = 'simplarpg'

;; A SUMMARY
;; "pitcels" = based on 'southdurs'
;;   if (duration = 1), chd is arpegg w/sopr first, 
;;     lower vcs in random (heap).
;;   if (duration > 1), same as above, except lower vcs
;;     do 4 random arpeggiations & initial sopr attacks
;;     simul w/ next voice

(events
 (let* ((permheap
	 (new heap of
	      (shuffle
	       (permutations (indices 3)))))
	(pitcels
	 (loop for d in southdurs collect
	       (if (eql d 1)
		   (cons 3 (next permheap))
		   (let ((cplist
			  (flatten (next permheap 4))))
		     (cons (list 3 (car cplist)) (cdr cplist)))))))
    (splay
     (loop for n to (- (length pitcels) 1) append
	   (let ((cel (nth n pitcels)))
	     (make-poly
	      (chooser (flatten cel) (nth n southpits))
	      (take-poly cel))))
    .25))
 "simplarpg.mid" :play 'nil)

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

;; B SUMMARY
;; "pitcels" - based on 'southdurs'
;; if (duration = 1), sopr + random ATB seq, 
;;   1st two attacks together (poly 2-1-1) 
;; if (duration > 1), same as above, repeated 3 times
;; 'var2b' = triplets become 16ths in compound meter

(events
 (let* ((permheap
	 (new heap of (indices 3)))
	(pitcels
	 (loop for d in southdurs collect
	       (if (eql d 1) 
		   (make-poly
		    (cons 3 (next permheap 3))
		    '(2 1 1))
		   (copylist 
		    (make-poly
		     (cons 3 (next permheap 3))
		     '(2 1 1))
		    3)))))
   (splay
    (loop for n to (- (length pitcels) 1) append
	  (let ((cel (nth n pitcels)))
	    (make-poly
	     (chooser (flatten cel) (nth n southpits))
	     (take-poly cel))))
    1/6))
 "simplarpg2.mid" :play 'nil)

; variation C = 'sing'

;; C PITCHES
;; "mintlock" = sopr is interlocked w/ itself @ (1 2) pits & (2 3 3) groups
;; "pits" = whenever 'mintlock' pit is repeated, it is transposed
;;   up/down P8 (in heap) 
;; final pitches = 'pits' are simul whenever a minor 3rd apart
;; C RHYTHM
;; motoric 16ths, dyads 8ths

(events
 (let* ((myheap (new heap :of '(12 -12)))
	(mintlock (interlock sopr sopr '(1 2) '(2 3 3)))
	(pits
	 (melint->line (car mintlock)
		       (loop for p in 
			     (melint mintlock)
			     collect (if (eql p 0) (next myheap) p))))
	(gpits
	 (mapcar #'remove-duplicates (not-flat
				(gather-pits (lambda (a b) (eql 3 (mod12 (abs (- b a)))))
					     pits)))))
   (splay gpits
	  (durweight gpits .25)))
 "sing.mid" :play 'nil)

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

;; D PITCHES
;; "southgr-s","southgr-a","southgr-t": S,A,T in slonim w/  
;;    complementary dyad (from E5, B4, G4); chordal paths
;;    via Reger transformation 
;; sopr transposed down P8, aug *12 is 'consmatched' with
;;    descending arpegg SAT rgr vectors (in order).
;; -- entire variation transposed up P8

;(generic-branch #'rgr-alldim1
;  (slonim '(59 55)
;	  (first
;	   (make-ties sopr))))

(define southrgr-s
    '(((59 55 64) (60 55 64) (60 55 63))
      ((63 60 67) (64 60 67) (64 60 69) (64 61 69) (66 61 69))
      ((57 61 66) (57 61 64)) ((56 61 64) (56 61 65) (58 61 65) (58 62 65))
      ((58 62 67) (58 62 65) (57 62 65))
      ((53 62 69) (54 62 69) (54 62 71) (54 63 71))
      ((56 63 71) (56 60 75) (56 60 77) (57 60 77) (57 62 77))
      ((57 65 74) (57 65 72)) ((57 64 72) (55 64 72)) ((55 64 71) (60 64 67))
      ((60 64 69) (60 64 67)) ((55 64 71) (60 64 67)) ((60 64 69) (60 64 67))
      ((59 64 67) (59 62 67)) ((59 62 66) (59 62 67)) ((59 67 64))))

;(generic-branch #'rgr-alldim1
;  (slonim '(64 55)
;	  (first
;	   (make-ties alto))))

(define southrgr-a
    '(((64 55 59) (60 52 55) (60 52 57)) ((60 57 64) (60 55 64))
      ((60 55 63) (60 56 63) (56 59 63) (54 59 63)) ((62 54 59))
      ((59 54 62) (59 55 62) (59 55 64) (60 55 64) (60 57 64))
      ((57 48 64) (57 48 65) (57 50 65) (57 50 66) (59 50 66))
      ((59 42 62) (59 42 63) (59 44 63) (56 48 63) (55 48 63))
      ((63 36 67) (63 31 70) (63 30 70))
      ((63 34 66) (63 34 67) (60 39 67) (60 40 67) (55 40 71))
      ((67 35 64) (67 35 62)) ((67 34 62))
      ((62 34 67) (63 34 67) (60 39 67) (60 40 67) (60 40 69))
      ((60 33 64) (60 31 64))
      ((60 31 63) (60 32 63) (56 35 63) (54 35 63) (54 35 62)) ((62 30 59))))

;(define southgr-t
;    (generic-branch #'rgr-alldim1
;		    (slonim '(59 64)
;			    (first
;			     (make-ties tenor)))))

(define southrgr-t
    '(((59 64 55) (60 64 55)) ((55 63 60) (55 64 60)) ((55 64 59))
      ((59 64 55) (60 64 55) (60 64 57) (61 64 57) (61 66 57))
      ((57 61 54) (57 62 54) (59 62 54) (59 62 55))
      ((59 64 55) (60 64 55) (60 64 57) (60 65 57) (62 65 57))
      ((53 62 57) (53 62 58) (55 62 58) (55 62 59) (55 64 59))
      ((47 64 55) (48 64 55) (48 64 57) (48 65 57) (50 65 57))
      ((41 62 57) (41 62 58) (43 62 58) (43 62 59) (43 64 59))
      ((35 64 55) (36 64 55) (36 64 57) (37 64 57) (37 66 57))
      ((33 61 54) (33 62 54) (35 62 54))
      ((35 66 62) (35 66 63) (35 68 63) (32 72 63) (31 72 63))
      ((31 63 60) (31 64 60)) ((31 64 59) (31 64 59)) ((35 64 55))))

(events
 (splay
  (transp
   (not-flat
    (consmatch
     (durs->slots (transp sopr -12) (transp southdurs 12 #'*))
     (loop for srgr in (list southrgr-s southrgr-a southrgr-t) append
	   (flatten
	    (mapcar (lambda (x) (reverse (safesort x)))
		    (flatter srgr))))
     ))
   12)
  1/6)
 "dance.mid" :play 'nil)

;; "var4b" = triplets become 16ths in compound meter

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

; variation E = 'response3'

;; E PITCHES & RHYTHM
;; "ochds" = each sopr phrase in 'aaron4pt' canon by -P5, -m3, +M3
;;  final version: "ochds" notes/chds take dotted quarter;
;;    rests in "ochds" are replaced with 8 atx from 2nd-order markov of sopr, at 16th

(events
 (let* ((ochds
	 (loop for emel in (make-poly sopr southphrases) append
	       (let* ((aparts
		       (aaron4pt emel (- (car emel) 7) (- (car emel) 3) (+ (car emel) 4))))
		 (merge-slots
		  (mapcar (lambda (x) (durs->slots (first x) (second x))) aparts)))))
	(opoly (take-poly ochds))
	(mark
	 (markov-analyze (transp sopr -12) :order 2))
	(odurs
	 (flatten
	  (mapcar (lambda (x) (case x 
				(0 (copylist '(1) 8))
				(t 6)))
		  opoly)))
	(opits
	 (loop for n to (- (length ochds) 1) append
	       (case (nth n opoly) 
		 (0 (next mark 8))
		 (1 (nth n ochds))
		 (t (list (nth n ochds)))))))
   (splay opits (transp odurs .25 #'*))) 
 "response3.mid" :play 'nil)

; variation F = 'sevchds'

;; F PITCHES
;; "gbranch-ctone" = parallel m7 chords are built w/ non-rpt sopr line as the 7th;
;;    paths found using 'common-tone' transformation
;; "gb2" = paths btwn 'gbranch-ctone' chords using Reger transformation
;; final: "gb2" chords are 'smoothed' (repeated tones removed) 
;; F RHYTHM
;; durations = chord size * 16th

(define gbranch-ctone
    (generic-branch #'ctone
		    (mapcar (lambda (x) (transp '(0 -3 -7 -10) x)) 
			    (norpt sopr))))

(define gb2
    (loop for gbct in gbranch-ctone collect
	  (generic-branch #'rgr-alldim1 gbct)))
(events
 (let ((pits
	(smoothlist
	 (flatter (flatter gb2)))))
   (splay pits (durweight pits .25)))
 "sevchds.mid" :play 'nil)

; variation G = 'run'

;; G SUMMARY
;; "gb2" from variation F: chords are shuffled internally; 
;;    repeats become ties at motoric 32nd

(events
 (play-sd
  (make-ties
   (flatten
    (shuffle-all
     (flatter (flatter gb2)))))
  .125)
 "run.mid" :play 'nil)

; variation H = 'noodler'

;; H -- two lines
;; BOTTOM LINE = sopr melody, verbatim
;; TOP LINE
;; pitch: melodic intervals +/- 1-5 are heap-chosen
;;    and used for scale degrees in e minor.
;; rhythm: 'mel-stress' attack probabilities (2 4 8)
;;    used (@ 32nds) for strong binary metric feel

(events
 (let ((topsd
	(slots->durs
	 (mel-stress
	  (play-mode
	   (melint->line 39
			 (chooser (heapvec 100 10) 
				  (set-difference 
				   (indices 11 -5) 
				   (list 0))))
	   eminor)
	  (transp (resclassvec 2 4 8) 1)))))
   (list
    (splay (first topsd) (transp (second topsd) .125 #'*))
    (splay (transp sopr -24) southdurs)))
 "noodler.mid" :play 'nil)

; variation I = 'rise'

;; I -- two lines
;; TOP LINE PITCHES = parallel 1st-inv major triads w/ nonrpt soprano as bass;
;;   paths found using 'embellpc-func'
;; TOP LINE RHYTHM = random (4-8)* 8th duration
;; BOTTOM LINE PITCHES = random eminor melodic intervals (sim. to variation H)
;; BOTTOM LINE RHYTHM = 'mel-stress' at 8th (sim. to variation H)

;(define embchds
;    (generic-branch #'embellpc-func
;		    (mapcar (lambda (x) (transp '(0 3 8) x)) (norpt sopr))))

(define embchds
    '(((64 67 72) (64 69 72) (66 69 74)) ((67 70 75) (66 70 75))
      ((66 69 74) (67 70 75)) ((64 67 72) (64 69 72) (66 69 74))
      ((67 70 75) (68 71 76) (65 69 72)) ((69 72 77) (69 74 78))
      ((71 74 79) (70 74 79) (70 74 77))
      ((74 77 82) (74 77 81) (73 77 80) (73 76 80))
      ((72 75 80) (72 76 81) (74 78 81) (74 79 83)) ((71 74 79) (71 76 80))
      ((69 72 77) (69 74 78)) ((71 74 79) (71 76 80))
      ((69 72 77) (69 74 78) (70 75 79)) ((67 70 75) (66 70 75))
      ((66 69 74) (67 70 75)) ((64 67 72))))

(events
 (let ((topsd
	(slots->durs
	 (mel-stress
	  (play-mode
	   (melint->line 30
			 (chooser (heapvec 180 10) 
				  (set-difference 
				   (indices 11 -5) 
				   (list 0))))
	   eminor)
	  (transp (resclassvec 2 4 8) 1))))
       (upperpt (flatter embchds)))
   (list
    (splay (first topsd) (transp (second topsd) .25 #'*))
    (splay upperpt (transp (randvec (length upperpt) 5 4) .5 #'*))))
 "rise.mid" :play 'nil)