> 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 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)]