> 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]
> 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
> triads = toAbsChords terms
> lr = (43, 60)
> rr = (60, 79)
> rans = [lr, lr, rr, rr]
> 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)
> rr = (60, 79)
> rans = [lr, lr, rr, rr]
> 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
> k = findInds [] terms
> (g1, lhPCs) = simpleLH g0 aChords
> lhSpace = filter (\[a,b] -> b-a <= 12 && a<=b) (makeRange [(40,59),(40,59)]) // opcEq
> eqsL = map (eqClass lhSpace opcEq) lhPCs
> (g2,g3) = split g1
> lhChords = greedyLet (const True) defFall k eqsL g2
> lhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords lhChords
> (g4, lh) = lhFG g3 lhTChords
>
> (g5, rhPCs) = simpleRH g4 aChords
> 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
> (g6,g7) = split g5
> rhChords = greedyLet (smoothMel 4) nearestMel k eqsR g6
> rhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords rhChords
> (g8, rh) = rhFG g7 rhTChords
> in (g8, (lh, rh))
> simplePianoFGMelx :: [TChord] -> StdGen -> Constraints -> (StdGen, (Music Pitch, Music Pitch))
> simplePianoFGMelx aChords g0 k =
> let (g1, lhPCs) = simpleLH g0 aChords
> lhSpace = filter (\[a,b] -> b-a <= 12 && a<=b) (makeRange [(40,59),(40,59)]) // opcEq
> eqsL = map (eqClass lhSpace opcEq) lhPCs
> (g2,g3) = split g1
> lhChords = greedyLet (const True) defFall k eqsL g2
> lhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords lhChords
> (g4, lh) = lhFG g3 lhTChords
>
> (g5, rhPCs) = simpleRH g4 aChords
> 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
> (g6,g7) = split g5
> rhChords = greedyLet (smoothMel 4) nearestMel k eqsR g6
> rhTChords = zipWith (\(k,d,_) x -> (k,d,x)) aChords rhChords
> (g8, rh) = rhFG g7 rhTChords
> in (g8, (lh, rh))
> simpleLH :: StdGen -> [TChord] -> (StdGen, [AbsChord])
> simpleLH g [] = (g, [])
> simpleLH g [(k,d,[r,t,f])] =
> let (g', x) = choose g [[r,f]]
> in (g', [x])
> simpleLH g ((k,d,[r,t,f]):xs) =
> let (g', x') = choose g [[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])] =
> 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/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
>
>
> 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
> (g'', rest) = makeMel g' (x2:xs)
> in case pt of Nothing -> makeMelNT g'' (x1 : rest)
> 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
> in case pt of Nothing -> (g', (x1 : x2: xs))
> 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
> ps = map head e
> dists = map (\x -> abs(p-x)) ps
> 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)]