Generative backend for Kulitta.lhs (the GUI/console program)

> module GUIBackend where
> import Kulitta.EuterpeaSpecial
> import Kulitta.Foregrounds
> import Kulitta
> import Kulitta.Grammars.MusicGrammars
> import System.Random
> import Kulitta.Learning.Learning
> import Kulitta.Learning.PCFGtoPTGG
> import Data.List
> import System.Environment
> import System.IO
> import System.Directory

Data type definitions to allow the user to specify Kulitta's behavior.

> data Style = Chorale | -- in style of JS Bach
>              PianoChorale | 
>              JazzChorale | -- grammar, jazz chords, chorale foreground
>              WeirdChorale | -- grammar through OPT-space
>              JazzChords | -- grammar with jazz foreground
>              BossaNova | -- grammar with bossa foreground
>              PianoEtude1 | 
>              PianoEtude2 
>    deriving (Eq, Show, Ord, Read)
> data Form = Phrase | AABA
>    deriving (Eq, Show, Ord, Read)
> data GramType = HandBuilt | Learned
>    deriving (Eq, Show, Ord, Read)
> data Info = Info {
>     style :: Style, 
>     form :: Form, 
>     gram :: GramType, 
>     mode :: Mode, 
>     lets :: Bool, 
>     randKey :: Bool,
>     probs :: FilePath}


ABSTRACT PHRASE GENERATION

This function creates chorale phrases using a hand-built grammar. 

> makeRPhraseH :: StdGen -> Mode -> (Dur,Dur) -> Bool -> Int -> Dur -> Bool -> IO (Constraints, [RChord])
> makeRPhraseH g m (minD,maxD) lets iters len partB= 
>     let tSeed = [NT (I, MP len m 0 0 4)]
>         tVal = doGen (rRules1 minD lets) iters g m tSeed maxD
>         kVal = findInds [] tVal
>     in  return (kVal, toChords (expand [] tVal))

This files store the results of training Kulitta on a Bach chorale corpus.

> minorProbsFile = "minorProbs.txt"
> majorProbsFile = "majorProbs.txt"
> pcfgFile = "pcfg.txt"

These production probabilities can be used to make other phrases. Since we
require that phrases end on one, phrases will be searched until one is found 
that does end on I (ending on I is not guaranteed by the learned grammar).
 
> makeRPhraseB :: StdGen -> Mode ->(Dur,Dur) -> Int -> Dur -> Bool -> FilePath -> IO (Constraints, [RChord])
> makeRPhraseB g m (minD,maxD) iters len partB pfile = do
>     let [g1, g2, g'] = take 3 $ splitN g
>     (startSym, rulesPCFG) <- readPCFG pcfgFile
>     let theFile = if null pfile then
>                       if m==Major then majorProbsFile else minorProbsFile
>                   else pfile
>     probs <- readProbsFinal theFile
>     let avgProbs = map average probs
>         prules = zip avgProbs rulesPCFG
>         rules = toPTGG3 (<minD) prules
>         tSeed = [NT (I, MP len m 0 0 4)]
>         tPhrase = doGen rules iters g1 m tSeed maxD
>         endsOnI = endingType tPhrase
>         rPhrase = toChords (expand [] $ tPhrase)
>         rPhrase' = expandTSD2 (tsdSpace' m) (okRTrans m) g2 rPhrase
>     --putStrLn ("Probabilities: "++show avgProbs)
>     if endsOnI then return ([], rPhrase') else makeRPhraseB g' m (minD,maxD) iters len partB pfile where
>     endingType = (==I) . last . map (\(a,b,c) -> c) . toChords . expand []

> average xs = sum xs / fromIntegral (length xs)


The doGen function adds a maximum duration constraint to get a more consistent 
distribution of durations. No more than searchLimit generative steps will be tried
to avoid infinite loops caused by generative fixed points.

> searchLimit = 1000

> doGen :: (Eq a) => [Rule a MP] -> Int -> StdGen -> Mode -> Sentence a MP -> Dur -> Sentence a MP
> doGen theRules i g ctxt t maxDur = recCheck i (map snd $ gen theRules (g,t)) where
>     recCheck i ts = let tc = ts !! i in
>         if (goodDurs tc && goodDurs' tc) || i>searchLimit then tc else recCheck (i+1) ts
>     goodDurs [] = True
>     goodDurs (Let x a e : ts) = goodDurs a && goodDurs e && goodDurs ts
>     goodDurs (Var x : ts) = True -- can't tell duration here, so assume ok
>     goodDurs (NT (c,p) : ts) = dur p <= maxDur && goodDurs ts

> goodDurs' :: Predicate (Sentence a MP)
> goodDurs' t = let x = getDurs t in 
>     length (filter (>=hn) x) < length x `div` 2

> getDurs :: Sentence a MP -> [Dur]
> getDurs [] = []
> getDurs (t@(Let x a e):ts) = getDurs (expand [] [t]) ++ getDurs ts
> getDurs (Var x : ts) = error "getDurs can't handle variables."
> getDurs (NT (x,p) :ts) = dur p : getDurs ts

This version of TSD-space is altered from the originally-learned statistics to
improve Kulitta's performance (the analysis had some known problems). 

> tsdSpace' :: Mode -> QSpace CType
> tsdSpace' m = [f I 0 ++ f III 2 ++ f VI 5,
>                f IV 3 ++ f II 1,
>                f V 4 ++ f VII 6] where
>                             --  I   II  III  IV   V   VI  VII
>     rCounts = if m==Major then [34, 13,  4,  11,  25,  7,  3]
>               else             [47,  2,  4,  18,  20,  3,  3]
>     f x i = take (rCounts !! i) $ repeat x


===============================

FOREGROUND GENERATION

The following code configures Kulitta in different ways to generate different 
styles of music according to the user's specifications.

> makePiece g i@(Info s f gr m l k pfile) b = do
>     let [gStruct, gFG] = take 2 $ splitN g
>         genVals = if elem s [BossaNova, PianoEtude1] then (5, wn, wn, 8) else  (5, qn, hn, 4) 
>                   --if chorale s then (5, qn, hn, 4) else (5, wn, wn, 8)
>     absStructs <- makeStructure gStruct i genVals
>     theMusic <- makeMusic gFG i absStructs
>     return (procInstrs b theMusic, absStructs)

> procInstrs :: Bool -> Music a -> Music a
> procInstrs True m = m
> procInstrs False (m1 :=: m2) = procInstrs False m1 :=: procInstrs False m2
> procInstrs False (m1 :+: m2) = procInstrs False m1 :+: procInstrs False m2
> procInstrs False (Modify (Instrument i) m) = procInstrs False m
> procInstrs False m = m

> makeSubStruct gAbs i@(Info s f gr m l k pfile) (iters, minD, maxD, len) partB = do
>    (cons, abs) <- if gr==HandBuilt then makeRPhraseH gAbs m (minD,maxD) l iters len partB else
>                   makeRPhraseB gAbs m (minD,maxD) (iters+1) len partB pfile
>    return (cons, abs)      

> makeStructure gStruct i@(Info s f gr m l k pfile) genVals = do
>     let (g1, g2) = split gStruct
>     structs <- if f==Phrase then sequence [makeSubStruct g1 i genVals False]
>                else sequence [makeSubStruct g1 i genVals False, 
>                               makeSubStruct g2 i genVals True]
>     return structs

> chorale s = elem s [Chorale, JazzChorale, WeirdChorale, PianoChorale]

> makeMusic g i@(Info s f gr m l k1 pfile) absStructs = do
>     let (k2, gFG) = randomR (0,11::Int) g
>         k = if k1 then k2 else 0
>     let fg = case s of 
>                  Chorale -> addVolume 127 $ buildChorale gFG absStructs (k,m)
>                  JazzChorale -> addVolume 127 $ buildJChorale gFG absStructs (k,m)
>                  WeirdChorale -> addVolume 127 $ buildWChorale gFG absStructs (k,m) 
>                  JazzChords -> addVolume 127 $ buildJazzChords gFG absStructs (k,m)
>                  BossaNova -> buildBossaNova gFG absStructs (k,m)
>                  PianoChorale -> addVolume 127 $ buildPianoChorale gFG absStructs (k,m)
>                  PianoEtude1 -> addVolume 127 $ buildPianoEtude1 gFG absStructs (k,m)
>                  PianoEtude2 -> addVolume 127 $ buildPianoEtude2 gFG absStructs (k,m)
>     putStrLn ("Key of piece: "++ showKey k m ++"\n")
>     writeFile "term.txt" (show absStructs)
>     return fg where
>     showKey k m = (["C","C-sharp","D","E-flat","E","F","F-sharp","G",
>                     "A-flat","A","B-flat","B"] !! k) ++ " " ++ show m

A chorale is pretty straightforward, using the ClassicalFG.lhs implementation.

> 
> buildChorale g [(cons, x)] (k,m) = 
>     snd $ snd $ classicalFGR g (ctTrans k x) cons
> buildChorale g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1, g2, g3, g4, g5] = take 5 $ splitN g
>         aChords = snd $ classicalCS g1 (ctTrans k a) cons1
>         bChords = snd $ classicalCS g2 (ctTrans k b) cons2
>         partA = snd $ snd $ classicalFG' g3 aChords
>         partA' = snd $ snd $ classicalFG' g4 aChords
>         partB = snd $ snd $ classicalFG' g5 bChords
>     in  partA :+: partA' :+: partB :+: partA


> buildPianoChorale g [(cons, x)] (k,m) = 
>     let (lh, rh) = simplePianoFG1x (map toAbsChord $ ctTrans k x) g cons
>     in  lh :=: rh
> buildPianoChorale g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1, g2, g3] = take 3 $ splitN g
>         (lhA, rhA) = simplePianoFG1x (map toAbsChord $ ctTrans k a) g1 cons1
>         (lhA', rhA') = simplePianoFG1x (map toAbsChord $ ctTrans k a) g2 cons1
>         (lhB, rhB) = simplePianoFG1x (map toAbsChord $ ctTrans k b) g3 cons2
>         partA = lhA :=: rhA
>         partA' = lhA' :=: rhA'
>         partB = lhB :=: rhB
>     in  partA :+: partA' :+: partB :+: partA

> buildPianoEtude1 g [(cons, x)] (k,m) = 
>     let (lh, rh) = snd $ simplePianoFGMelx (map toAbsChord $ ctTrans k x) g cons
>     in  lh :=: rh
> buildPianoEtude1 g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1, g2, g3] = take 3 $ splitN g
>         (lhA, rhA) = snd $ simplePianoFGMelx (map toAbsChord $ ctTrans k a) g1 cons1
>         (lhA', rhA') = snd $ simplePianoFGMelx (map toAbsChord $ ctTrans k a) g2 cons1
>         (lhB, rhB) = snd $ simplePianoFGMelx (map toAbsChord $ ctTrans k b) g3 cons2
>         partA = lhA :=: rhA
>         partA' = lhA' :=: rhA'
>         partB = lhB :=: rhB
>     in  partA :+: partA' :+: partB :+: partA

> buildPianoEtude2 g [(cons, x)] (k,m) = 
>     let (lh, rh) = snd $ simplePianoFGArpx (map toAbsChord $ ctTrans k x) g cons
>     in  lh :=: rh
> buildPianoEtude2 g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1, g2, g3] = take 3 $ splitN g
>         (lhA, rhA) = snd $ simplePianoFGArpx (map toAbsChord $ ctTrans k a) g1 cons1
>         (lhA', rhA') = snd $ simplePianoFGArpx (map toAbsChord $ ctTrans k a) g2 cons1
>         (lhB, rhB) = snd $ simplePianoFGArpx (map toAbsChord $ ctTrans k b) g3 cons2
>         partA = lhA :=: rhA
>         partA' = lhA' :=: rhA'
>         partB = lhB :=: rhB
>     in  partA :+: partA' :+: partB :+: partA

A "jazz chorale" ads an extra step in the foreground generation, converting 
numerals to jazz chords before running the classical algorithms.

> buildJChorale g [(cons, x)] (k,m) =  
>     let (g1,g2) = split g
>         jChords = atTrans k $ snd $ jazzChords g1 x cons
>     in  snd $ snd $ classicalFG' g2 jChords
> buildJChorale g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1, g2, g3, g4, g5] = take 5 $ splitN g
>         aChords = atTrans k $ snd $ jazzChords g1 a cons1
>         bChords = atTrans k $ snd $ jazzChords g2 b cons2
>         partA = snd $ snd $ classicalFG' g3 aChords
>         partA' = snd $ snd $ classicalFG' g4 aChords
>         partB = snd $ snd $ classicalFG' g5 bChords
>     in  partA :+: partA' :+: partB :+: partA


A "weird chorale" is one where numerals are run through OPTC-space before
applying a classical foreground.

> qOPTC = satbR (mkStdGen 123) satbFilter2 optcEq 

Note: the key will not affect weird chorales due to the use 
of OPTC-equivalence.

> buildWChorale g [(cons, x)] km = 
>     let (g1, g2) = split g
>         optChords = toOPTC g1 x km
>     in  snd $ snd $ classicalFG' g2 optChords
> buildWChorale g [(cons1, a), (cons2, b)] km = 
>     let [g1, g2, g3, g4, g5] = take 5 $ splitN g
>         aChords = toOPTC g1 a km
>         bChords = toOPTC g2 b km
>         partA = snd $ snd $ classicalFG' g3 aChords
>         partA' = snd $ snd $ classicalFG' g4 aChords
>         partB = snd $ snd $ classicalFG' g5 bChords
>     in  partA :+: partA' :+: partB :+: partA

> toOPTC g x (k,m) = 
>     let aChords = atTrans k $ map toAbsChord x
>         es = map (eqClass qOPTC optcEq) $ map thd aChords
>     in  zipWith newP aChords $ greedyProg' vl7 nearFall g es

Jazz foregrounds are created using the two algorithms in JazzFG.lhs.

> buildJazzChords = buildJazz jazzFG1
> buildBossaNova = buildJazz jazzFG2

> buildJazz f g [(cons, x)] (k,m) = snd $ f g (ctTrans k x) []
> buildJazz f g [(cons1, a), (cons2, b)] (k,m) = 
>     let [g1,g2,g3] = take 3 $ splitN g
>         jA = snd $ f g1 (ctTrans k a) []
>         jA' = snd $ f g2 (ctTrans k a) []
>         jB = snd $ f g3 (ctTrans k b) []
>     in  jA :+: jA' :+: jB :+: jA



=======================================

========================

The following filters out chord transitions that were relatively rare
in the data set, based on the suspicion that they might have been due
to noise (mis-labeled chords) or improper identification of phrase 
boundaries in the corpus.

> okRTrans :: Mode -> Predicate (CType, CType)
> okRTrans m x = not $ elem x $ vals m where
>     vals Minor = [(II,VI),   (II,VII),  (III,II), (III,V), 
>                   (III,VI),  (III,VII), (IV,III), (IV,VI),
>                   (V,III),   (V,VII),   (VI,III), (VI,IV), 
>                   (VI,V),    (VI,VII),  (VII,II), (VII,IV),
>                   (VII,VI)]
>     vals Major = [(III,II),  (III,VII), (IV,III), (IV,VI),
>                   (V,VII),   (VI,III),  (VI,VII), (VII,III),
>                   (VII,IV),  (VII,V),   (VII,VI), (VII,VII)]


> tsdSpace :: Mode -> QSpace CType
> tsdSpace m = [f I 0 ++ f III 2 ++ f VI 5,
>                f IV 3 ++ f II 1,
>                f V 4 ++ f VII 6] where
>     rCounts = if m==Major then [7833, 3018, 947, 2576, 5723, 1619, 791]
>               else [4925, 1425, 504, 1113, 2726, 442,  418]
>     f x i = take (rCounts !! i) $ repeat x

       I     II    III  IV    V     VI    VII
Major: 7833, 3018, 947, 2576, 5723, 1619, 791
Minor: 4925, 1425, 504, 1113, 2726, 442,  418


> expandTSD2 :: QSpace CType -> Predicate (CType, CType) -> StdGen -> [(Key, Dur, CType)] -> 
>              [(Key, Dur, CType)]
> expandTSD2 tsdSpace' p g xs = 
>     let xs' = map thd xs
>         n = length xs
>         es = (map (eqClass tsdSpace' tsdEq) $ take (n-1) xs') ++ [[last xs']]
>     in  zipWith (\(a,b,c) d -> (a,b,d)) xs $ greedyProg' p tsdFall g es 

> tsdEq :: EqRel CType
> tsdEq a b = or $ map (\e -> elem a e && elem b e) (tsdSpace Major)

> tsdFall :: Fallback CType
> tsdFall es g x = (g,x)