content: > module Kulitta.Foregrounds.SimplePianoFG(
  >     simplePianoFG1,
  >     simplePianoFG1x,
  >     simplePianoFGMel,
  >     simplePianoFGMelx,
  >     simplePianoFGArp,
  >     simplePianoFGArpx
  >     ) where
  > import Kulitta
  
  > import Data.List
  > import System.Random
  > import Kulitta.EuterpeaSpecial
  > import Kulitta.Grammars.MusicGrammars
  > import Kulitta.Foregrounds.ClassicalFG
  > import Kulitta.ChordSpaces
  
  First, a chorale-like style, but playable on piano.
  
  > smallRange = [absPitch (G,2)..absPitch (G,5)]
  
  
  
  > smallSpace = makeRange2' $ take 4 $ repeat smallRange
  
  > okSpacing1 [l1,l2,r1,r2] = l2 - l1 <= 12 && r2-r1 <= 12
  
  > makeRange2' :: [[PitchNum]] -> [AbsChord]
  > makeRange2' = foldr (\lu xs -> [(a:b) | a<-lu, b<-xs, psort (a:b)]) [[]] where
  >     psort (a:b:t) = a<b
  >     psort _ = True 
  
  > isDim = optcEq [0,3,6] -- for locating diminished triads
  
  > lhTemps = [[0,2,4], [0,4]]
  > rhTemps = [[0,2,4], [0,3], [0,5]]
  
  classicalCS2 :: StdGen -> [TChord] -> Constraints -> (StdGen, [TChord])
  classicalCS2' fFilter ranges g aChords consts
  
  > simplePianoFG1 :: Sentence CType MP -> StdGen -> (Music Pitch, Music Pitch)
  > simplePianoFG1 terms g0 = 
  >     let k = findInds [] terms -- determine what Let constraints exist
  >         triads = toAbsChords terms
  >         lr = (43, 60) -- where the left hand can play
  >         rr = (60, 79) -- where the right hand can play
  >         rans = [lr, lr, rr, rr] -- ranges for each of 4 voices
  >         pianoFilter [a,b,c,d] = b-a <= 12 && d - c <= 8
  >         (g1, newChords) = classicalCS2x pianoFilter rans g0 triads k
  >         (g2, (lhM, rhM)) = classicalFGx g1 newChords
  >     in  (lhM, rhM)
  
  > simplePianoFG1x :: [TChord] -> StdGen -> Constraints -> (Music Pitch, Music Pitch)
  > simplePianoFG1x triads g0 k = 
  >     let lr = (43, 60) -- where the left hand can play
  >         rr = (60, 79) -- where the right hand can play
  >         rans = [lr, lr, rr, rr] -- ranges for each of 4 voices
  >         pianoFilter [a,b,c,d] = b-a <= 12 && d - c <= 8
  >         (g1, newChords) = classicalCS2x pianoFilter rans g0 triads k
  >         (g2, (lhM, rhM)) = classicalFGx g1 newChords
  >     in  (lhM, rhM)
  
  Modification of the classical foreground code to address piano playability.
  
  > classicalCS2x :: Predicate AbsChord -> [(AbsPitch, AbsPitch)] -> StdGen -> [TChord] -> Constraints -> (StdGen, [TChord])
  > classicalCS2x fFilter ranges g aChords consts = 
  >    let justChords = map (\(a,b,c) -> c) aChords
  >        (g1,g2) = split g
  >        satbOPx = filter fFilter (makeRange' ranges) // opcEq
  >        (g3, eqs) = classBass 1.0 g2 $ map (eqClass satbOPx opcEq) justChords
  >        csChords = greedyLet (noCPL 7) nearFall consts eqs g3 
  >        aChords' = zipWith (\(a,b,c) d -> (a,b,d)) aChords csChords
  >    in  (g3, aChords')
  
  > classicalFGx :: StdGen -> [TChord] -> (StdGen, (Music Pitch, Music Pitch))
  > classicalFGx g aChords' = 
  >    let vs = toVoices aChords'
  >        (g1,csFG) = addFG defConsts{rootBassThreshC=1.0} g [vs !! 3]
  >        (g2,csFG2) = addFG defConsts{rootBassThreshC=1.0} g1 [vs !! 0]
  >        rh = csFG ++ [vs !! 2]
  >        lh = [vs !! 1] ++ csFG2
  >    in  if length vs == 4 then (g2, (vsToMusic lh, vsToMusic rh))
  >        else error "classicalFGx only works on chords with 4 voices"
  
  > tieLast2 xs@(v1:v2:v3) = 
  >     let ((k,d,a):(k',d',a'):t) = reverse xs
  >     in  if a==a' then reverse ((k,d+d',a):t) else xs
  > tieLast2 xs = xs
  
  
  ===================================
  
  Scale-based piano pieces with a simple right and left hand.
  
  > simplePianoFGMel :: Sentence CType MP -> StdGen -> (StdGen, (Music Pitch, Music Pitch))
  > simplePianoFGMel terms g0 = 
  >     let aChords = toAbsChords terms -- convert to basic triads
  >         k = findInds [] terms -- find let constraints
  >         (g1, lhPCs) = simpleLH g0 aChords -- simplify lefthand pitch classes
  >         lhSpace = filter (\[a,b] -> b-a <= 12 && a<=b) (makeRange [(40,59),(40,59)]) // opcEq
  >         eqsL = map (eqClass lhSpace opcEq) lhPCs -- locate lefthand equivalence classes
  >         (g2,g3) = split g1 -- get new generators
  >         lhChords = greedyLet (const True) defFall k  eqsL g2 -- lefthand chords in OPC space
  >         lhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords lhChords -- reattach durations
  >         (g4, lh) = lhFG g3 lhTChords -- create lefthand foreground
  >         ----
  >         (g5, rhPCs) = simpleRH g4 aChords -- simplify righthand pitch classes
  >         rhSpace = (filter (\xs -> maximum xs - minimum xs <= 9) (makeRange [(60,80),(60,80)]) // opcEq) ++
  >                   (map (\x -> [[x]]) [60..80])
  >         eqsR = map (eqClass rhSpace opEq) rhPCs -- locate righthand equivalence classes
  >         (g6,g7) = split g5 -- split generator again
  >         rhChords = greedyLet (smoothMel 4) nearestMel k eqsR g6 -- pick righthand chords in OPC space
  >         rhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords rhChords -- reattach durations
  >         (g8, rh) = rhFG g7 rhTChords -- create scale patterns with passing/neighboring tones
  >     in  (g8, (lh, rh)) -- return each hand's part as a separate music value
  
  > simplePianoFGMelx :: [TChord] -> StdGen -> Constraints -> (StdGen, (Music Pitch, Music Pitch))
  > simplePianoFGMelx aChords g0 k = 
  >     let (g1, lhPCs) = simpleLH g0 aChords -- simplify lefthand pitch classes
  >         lhSpace = filter (\[a,b] -> b-a <= 12 && a<=b) (makeRange [(40,59),(40,59)]) // opcEq
  >         eqsL = map (eqClass lhSpace opcEq) lhPCs -- locate lefthand equivalence classes
  >         (g2,g3) = split g1 -- get new generators
  >         lhChords = greedyLet (const True) defFall k  eqsL g2 -- lefthand chords in OPC space
  >         lhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords lhChords -- reattach durations
  >         (g4, lh) = lhFG g3 lhTChords -- create lefthand foreground
  >         ----
  >         (g5, rhPCs) = simpleRH g4 aChords -- simplify righthand pitch classes
  >         rhSpace = (filter (\xs -> maximum xs - minimum xs <= 9) (makeRange [(60,80),(60,80)]) // opcEq) ++
  >                   (map (\x -> [[x]]) [60..80])
  >         eqsR = map (eqClass rhSpace opEq) rhPCs -- locate righthand equivalence classes
  >         (g6,g7) = split g5 -- split generator again
  >         rhChords = greedyLet (smoothMel 4) nearestMel k eqsR g6 -- pick righthand chords in OPC space
  >         rhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords rhChords -- reattach durations
  >         (g8, rh) = rhFG g7 rhTChords -- create scale patterns with passing/neighboring tones
  >     in  (g8, (lh, rh)) -- return each hand's part as a separate music value
  
  > simpleLH :: StdGen -> [TChord] -> (StdGen, [AbsChord])
  > simpleLH g [] = (g, [])
  > simpleLH g [(k,d,[r,t,f])] = 
  >     let (g', x) = choose g [[r,f]] -- , [r,f]]
  >     in  (g', [x])
  > simpleLH g ((k,d,[r,t,f]):xs) = 
  >     let (g', x') = choose g [[r,t], [r,f]] -- [r,t], [r,f]]
  >         (g'', xs') = simpleLH g' xs
  >     in  (g'', x':xs')
  > simpleLH g _ = error "simpleLH only works on 3 note combinations"
  
  > simpleRH :: StdGen -> [TChord] -> (StdGen, [AbsChord])
  > simpleRH g [] = (g, [])
  > simpleRH g [(k,d,[r,t,f])] = -- last one, pick either a root or third
  >     let (g', x') = choose g [[r], [t]]
  >     in  (g', [x'])
  > simpleRH g ((k,d,[r,t,f]):xs) = 
  >     let (g', x') = choose g [[r,t], [t,f]]
  >         (g'', xs') = simpleRH g' xs
  >     in  (g'', x':xs')
  > simpleRH g _ = error "simpleRH only works on 3 note combinations"
  
  > lhFG :: StdGen -> [TChord] -> (StdGen, Music Pitch)
  > lhFG g [] = (g, rest 0)
  > lhFG g [(k,d,c)] = (g, chord $ map (note d . pitch) c)
  > lhFG g ((k,d,c):t) = 
  >     let (g', t') = lhFG g t
  >         (g'', x) = pickPat d c g'
  >     in  (g'', x :+: t') where
  >     pickPat d [a1,a2] g = 
  >         let [p1,p2] = map pitch [a1,a2]
  >             (g', x) = choose g [--note d p1 :=: note d p2] --,
  >                                 note (d/2) p1 :+: note (d/2) p2,
  >                                 note (d/2) p2 :+: note (d/2) p1] 
  >         in  (g', x)
  >     pickPat d x g = error "lhFG only works on 2 note combinations"
  
  
  > rhFG :: StdGen -> [TChord] -> (StdGen, Music Pitch)
  > rhFG g chords = 
  >     let v = makeVoice chords
  >         (g', v') = makeMel g v 
  >         --(g', vs) = addFG defConsts g [v] -- REGULAR CHORALE FG
  >         -- =================== TO DO: PUT PASSING TONE STUFF HERE ==================
  >     in  (g', vsToMusic [v']) where
  >     makeVoice [] = []
  >     makeVoice ((k,d,[x1]):t) = (k,d,x1) : makeVoice t
  >     makeVoice ((k,d,[x1,x2]):t) = (k,d/2,x1) : (k,d/2,x2) : makeVoice t
  >     makeVoice (x:t) = error ("Unsupported structure: "++show x)
  
  Given a voice, add passing and neighboring tones.
  
  > makeMel :: StdGen -> Voice -> (StdGen, Voice)
  > makeMel g [] = (g, [])
  > makeMel g [x] = (g, [x])
  > makeMel g (x1@((k1,m1),d1,p1):x2@((k2,m2),d2,p2):xs) = 
  >     let (g',pt) = pickPT 4 g x1 x2 -- next stochastic choice
  >         (g'', rest) = makeMel g' (x2:xs) --- rest of melody
  >     in  case pt of Nothing -> makeMelNT g'' (x1 : rest) -- passing tone not possible
  >                    Just v -> (g'', ((k1,m1),d1/2,p1) : ((k1,m1),d1/2,v) : rest) 
  >     where
  >     makeMelNT :: StdGen -> Voice -> (StdGen, Voice)
  >     makeMelNT g [] = (g, [])
  >     makeMelNT g [x] = (g, [x])
  >     makeMelNT g (x1@((k1,m1),d1,p1):x2@((k2,m2),d2,p2):xs) = 
  >         let (g',pt) = pickNT 4 g x1 x2 -- next stochastic choice
  >         in  case pt of Nothing -> (g', (x1 : x2: xs)) -- passing tone not possible
  >                        Just v -> (g', ((k1,m1),d1/2,p1) : ((k1,m1),d1/2,v) : x2 :xs)
  
  
  Smoth melody constraint and earest-neighbor fallback for melody construction.
  
  > smoothMel :: AbsPitch -> Predicate (AbsChord, AbsChord)
  > smoothMel thresh ([], c2) = error "Empty chord"
  > smoothMel thresh (c1, []) = error "Empty chord"
  > smoothMel thresh (c1, c2) = abs(last c1-head c2) < thresh
  
  > nearestMel :: Fallback AbsChord
  > nearestMel [] g c = error ("Empty equivalence class for: "++show c)
  > nearestMel e g c = 
  >     let p = last c -- this is the current pitch
  >         ps = map head e -- these are all possible next pitches
  >         dists = map (\x -> abs(p-x)) ps -- all distances
  >         minDist = minimum dists 
  >         (g', i) = choose g (findIndices (\x -> x == minimum dists) dists)
  >     in  (g', e !! i)
  
  ==============================================
  
  Arpeggio-based pieces, playable on piano with pedal. They may not 
  always be best played with the indicated split of right and left hands.
  Sometimes the lowest note of the right-hand part may be better played
  by the left-hand, although it can difficult to automatically represent 
  on a score this way with software such as MuseScore. 
  
  > simplePianoFGArp :: Sentence CType MP -> StdGen -> (StdGen, (Music Pitch, Music Pitch))
  > simplePianoFGArp terms g0 = 
  >     let aChords = toAbsChords terms
  >         k = findInds [] terms
  >         (g1, tcs) = classicalCS2x' g0 aChords k
  >         (tLH, tRH) = splitTChords 1 tcs
  >         rhM = toArpMusic tRH
  >         lhM = vsToMusic $ toVoices tLH
  >     in  (g1, (lhM, rhM))
  
  > simplePianoFGArpx :: [TChord] -> StdGen -> Constraints -> (StdGen, (Music Pitch, Music Pitch))
  > simplePianoFGArpx aChords g0 k = 
  >     let (g1, tcs) = classicalCS2x' g0 aChords k
  >         (tLH, tRH) = splitTChords 1 tcs
  >         rhM = toArpMusic tRH
  >         lhM = vsToMusic $ toVoices tLH
  >     in  (g1, (lhM, rhM))
  
  
  Another redoing of the chorale-inspired chord spaces.
  
  > classicalCS2x' :: StdGen -> [TChord] -> Constraints -> (StdGen, [TChord])
  > classicalCS2x' g aChords consts = 
  >    let justChords = map (\(a,b,c) -> c) aChords
  >        (g1,g2) = split g
  >        (g3, eqs) = classBass2 0.8 g2 $ map (eqClass satbOPx opcEq) justChords
  >        csChords = greedyLet myClass nearFall consts eqs g3 
  >        aChords' = zipWith (\(a,b,c) d -> (a,b,d)) aChords csChords
  >    in  (g3, aChords') where
  >    satbOPx = satbChordsx // opEq 
  >    satbChordsx = filter (\x -> arpFilter x && satbFilter x) (makeRange satbRangesx)
  >    satbRangesx = [(30,60), (47,67), (52,76), (60,81)]
  
  > classBass2 :: Double -> StdGen -> [EqClass AbsChord] -> (StdGen, [EqClass AbsChord])
  > classBass2 thresh g [] = (g, [])
  > classBass2 thresh g [e] = classBass 1.0 g [e]
  > classBass2 thresh g (e:es) = 
  >     let (g',e') = classBass thresh g [e] 
  >         (g'', es') = classBass2 thresh g' es
  >     in  (g'', e' ++ es')
  
  Constraint for appropriate spacings between voices (treated as 4-note chords,
  not yet arpeggiated).
  
  > arpFilter :: Predicate AbsChord
  > arpFilter = arpFilterSub . tail where
  >     arpFilterSub (p1:p2:ps) = p1-p2 <= 6 && arpFilterSub (p2:ps)
  >     arpFilterSub x = True
  
  > myClass (c1,c2) = c1 /= c2 && noCPL 7 (c1,c2)
  
  For splitting a TChord into lefthand and righthand sections by voice
  count. For example, if amt = 1, a single voice will end up in the 
  left hand portion.
  
  > splitTChords :: Int -> [TChord] -> ([TChord], [TChord])
  > splitTChords amt chords = unzip $ map (f amt) chords where
  >     f amt (km, d, x) = ((km, d, take amt x), (km, d, drop amt x))
  
  Arpeggiate a bunch of TChords.
  
  > toArpMusic :: [TChord] -> Music Pitch
  > toArpMusic [] = rest 0
  > toArpMusic [(k,d,aps)] = chord $ map (note d . pitch) aps
  > toArpMusic (x:t) = (rest sn :+: vsToMusic [toArp x]) :+: toArpMusic t
  
  > toArp :: TChord -> [TNote]
  > toArp (km@(k,m), d, aps) = 
  >     let scale = t k (if m==Major then majScale else minScale)
  >         arpNotes = takeDur (d-sn) $ concat $ repeat $ map (\x -> (km,sn,x)) aps
  >     in  if d <= sn then [(km, d, head aps)]
  >         else arpNotes where
  >     takeDur :: Dur -> [TNote] -> [TNote]
  >     takeDur d [] = []
  >     takeDur 0 xs = []
  >     takeDur d (h@(k, d', x):t) =
  >         if d >= d' then h : takeDur (d-d') t else [(k, d, x)]
  
  