From 2483dc772897eb0909664f1a88cc7f8ec50ebd5b Mon Sep 17 00:00:00 2001 From: "kr.angelov" Date: Wed, 6 Nov 2013 10:21:46 +0000 Subject: the content of ParseEngAbs3.probs is now merged with ParseEngAbs.probs. The later is now retrained. Once the grammar is compiled with the .probs file now it doesn't need anything more to do robust parsing. The robustness itself is controlled by the flags 'heuristic_search_factor', 'meta_prob' and 'meta_token_prob' in ParseEngAbs.gf --- src/runtime/haskell/PGF.hs | 12 ++++++------ src/runtime/haskell/PGF/Binary.hs | 4 ++-- src/runtime/haskell/PGF/Data.hs | 8 ++++---- src/runtime/haskell/PGF/Macros.hs | 4 ++-- src/runtime/haskell/PGF/Printer.hs | 4 ++-- src/runtime/haskell/PGF/Probabilistic.hs | 25 +++++++++++++++---------- src/runtime/haskell/PGF/TypeCheck.hs | 8 ++++---- 7 files changed, 35 insertions(+), 30 deletions(-) (limited to 'src/runtime/haskell') diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index e7e5c53c5..0e3c79f40 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -292,8 +292,8 @@ categories pgf = [c | (c,hs) <- Map.toList (cats (abstract pgf))] categoryContext pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (hypos,_,_) -> Just hypos - Nothing -> Nothing + Just (hypos,_,_,_) -> Just hypos + Nothing -> Nothing startCat pgf = DTyp [] (lookStartCat pgf) [] @@ -301,8 +301,8 @@ functions pgf = Map.keys (funs (abstract pgf)) functionsByCat pgf cat = case Map.lookup cat (cats (abstract pgf)) of - Just (_,fns,_) -> map snd fns - Nothing -> [] + Just (_,fns,_,_) -> map snd fns + Nothing -> [] functionType pgf fun = case Map.lookup fun (funs (abstract pgf)) of @@ -325,8 +325,8 @@ browse pgf id = fmap (\def -> (def,producers,consumers)) definition in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs]) Just (ty,_,Nothing, _,_) -> Just $ render (text "data" <+> ppCId id <+> colon <+> ppType 0 [] ty) Nothing -> case Map.lookup id (cats (abstract pgf)) of - Just (hyps,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) - Nothing -> Nothing + Just (hyps,_,_,_) -> Just $ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps))) + Nothing -> Nothing (producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf)) where diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs index 202939f04..2debcf12d 100644 --- a/src/runtime/haskell/PGF/Binary.hs +++ b/src/runtime/haskell/PGF/Binary.hs @@ -40,13 +40,13 @@ instance Binary CId where instance Binary Abstr where put abs = put (aflags abs, fmap (\(w,x,y,z,_) -> (w,x,y,z)) (funs abs), - fmap (\(x,y,_) -> (x,y)) (cats abs)) + fmap (\(x,y,z,_) -> (x,y,z)) (cats abs)) get = do aflags <- get funs <- get cats <- get return (Abstr{ aflags=aflags , funs=fmap (\(w,x,y,z) -> (w,x,y,z,0)) funs - , cats=fmap (\(x,y) -> (x,y,0)) cats + , cats=fmap (\(x,y,z) -> (x,y,z,0)) cats , code=BS.empty }) diff --git a/src/runtime/haskell/PGF/Data.hs b/src/runtime/haskell/PGF/Data.hs index e37b243d0..f5797739f 100644 --- a/src/runtime/haskell/PGF/Data.hs +++ b/src/runtime/haskell/PGF/Data.hs @@ -29,10 +29,10 @@ data PGF = PGF { data Abstr = Abstr { aflags :: Map.Map CId Literal, -- ^ value of a flag funs :: Map.Map CId (Type,Int,Maybe [Equation],Double,BCAddr), -- ^ type, arrity and definition of function + probability - cats :: Map.Map CId ([Hypo],[(Double, CId)],BCAddr), -- ^ 1. context of a category - -- ^ 2. functions of a category. The order in the list is important, - -- this is the order in which the type singatures are given in the source. - -- The termination of the exhaustive generation might depend on this. + cats :: Map.Map CId ([Hypo],[(Double, CId)],Double,BCAddr), -- ^ 1. context of a category + -- 2. functions of a category. The functions are stored + -- in decreasing probability order. + -- 3. probability code :: BS.ByteString } diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index 830a16674..ce75b1c91 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -67,7 +67,7 @@ functionsToCat :: PGF -> CId -> [(CId,Type)] functionsToCat pgf cat = [(f,ty) | (_,f) <- fs, Just (ty,_,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]] where - (_,fs,_) = lookMap ([],[],0) cat $ cats $ abstract pgf + (_,fs,_,_) = lookMap ([],[],0,0) cat $ cats $ abstract pgf -- | List of functions that lack linearizations in the given language. missingLins :: PGF -> Language -> [CId] @@ -82,7 +82,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF restrictPGF cond pgf = pgf { abstract = abstr { funs = Map.filterWithKey (\c _ -> cond c) (funs abstr), - cats = Map.map (\(hyps,fs,addr) -> (hyps,filter (cond . snd) fs,addr)) (cats abstr) + cats = Map.map (\(hyps,fs,p,addr) -> (hyps,filter (cond . snd) fs,p,addr)) (cats abstr) } } ---- restrict concrs also, might be needed where diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 66d8530f0..d3a5ea1d9 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -26,8 +26,8 @@ ppAbs name a = text "abstract" <+> ppCId name <+> char '{' $$ ppFlag :: CId -> Literal -> Doc ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' -ppCat :: CId -> ([Hypo],[(Double,CId)],BCAddr) -> Doc -ppCat c (hyps,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' +ppCat :: CId -> ([Hypo],[(Double,CId)],Double,BCAddr) -> Doc +ppCat c (hyps,_,_,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';' ppFun :: CId -> (Type,Int,Maybe [Equation],Double,BCAddr) -> Doc ppFun f (t,_,Just eqs,_,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ diff --git a/src/runtime/haskell/PGF/Probabilistic.hs b/src/runtime/haskell/PGF/Probabilistic.hs index 7f980254b..095ade022 100644 --- a/src/runtime/haskell/PGF/Probabilistic.hs +++ b/src/runtime/haskell/PGF/Probabilistic.hs @@ -24,13 +24,14 @@ import Data.Maybe (fromMaybe) --, fromJust -- the probabilities for the different functions in a grammar. data Probabilities = Probs { funProbs :: Map.Map CId Double, - catProbs :: Map.Map CId [(Double, CId)] + catProbs :: Map.Map CId (Double, [(Double, CId)]) } -- | Renders the probability structure as string showProbabilities :: Probabilities -> String -showProbabilities = unlines . map pr . Map.toList . funProbs where - pr (f,d) = showCId f ++ "\t" ++ show d +showProbabilities = unlines . concatMap prProb . Map.toList . catProbs where + prProb (c,(p,fns)) = pr (p,c) : map pr fns + pr (p,f) = showCId f ++ "\t" ++ show p -- | Reads the probabilities from a file. -- This should be a text file where on every line @@ -50,8 +51,12 @@ readProbabilitiesFromFile file pgf = do -- for the result category. mkProbabilities :: PGF -> Map.Map CId Double -> Probabilities mkProbabilities pgf probs = - let funs1 = Map.fromList [(f,p) | (_,cf) <- Map.toList cats1, (p,f) <- cf] - cats1 = Map.map (\(_,fs,_) -> sortBy cmpProb (fill fs)) (cats (abstract pgf)) + let funs1 = Map.fromList [(f,p) | (_,(_,fns)) <- Map.toList cats1, (p,f) <- fns] + cats1 = Map.mapWithKey (\c (_,fns,_,_) -> + let p' = fromMaybe 0 (Map.lookup c probs) + fns' = sortBy cmpProb (fill fns) + in (p', fns')) + (cats (abstract pgf)) in Probs funs1 cats1 where cmpProb (p1,_) (p2,_) = compare p2 p1 @@ -71,15 +76,15 @@ defaultProbabilities pgf = mkProbabilities pgf Map.empty getProbabilities :: PGF -> Probabilities getProbabilities pgf = Probs { - funProbs = Map.map (\(_,_,_,p,_) -> p) (funs (abstract pgf)), - catProbs = Map.map (\(_,fns,_) -> fns) (cats (abstract pgf)) + funProbs = Map.map (\(_,_,_,p,_) -> p ) (funs (abstract pgf)), + catProbs = Map.map (\(_,fns,p,_) -> (p,fns)) (cats (abstract pgf)) } setProbabilities :: Probabilities -> PGF -> PGF setProbabilities probs pgf = pgf { abstract = (abstract pgf) { - funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df,p,addr)) (funs (abstract pgf)) (funProbs probs), - cats = mapUnionWith (\(hypos,_,addr) fns -> (hypos,fns,addr)) (cats (abstract pgf)) (catProbs probs) + funs = mapUnionWith (\(ty,a,df,_,addr) p -> (ty,a,df, p,addr)) (funs (abstract pgf)) (funProbs probs), + cats = mapUnionWith (\(hypos,_,_,addr) (p,fns) -> (hypos,fns,p,addr)) (cats (abstract pgf)) (catProbs probs) }} where mapUnionWith f map1 map2 = @@ -102,7 +107,7 @@ rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p) mkProbDefs :: PGF -> ([[CId]],[(CId,Type,[Equation])]) mkProbDefs pgf = - let cs = [(c,hyps,fns) | (c,(hyps0,fs,_)) <- Map.toList (cats (abstract pgf)), + let cs = [(c,hyps,fns) | (c,(hyps0,fs,_,_)) <- Map.toList (cats (abstract pgf)), not (elem c [cidString,cidInt,cidFloat]), let hyps = zipWith (\(bt,_,ty) n -> (bt,mkCId ('v':show n),ty)) hyps0 diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 141189193..e582f97af 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -121,8 +121,8 @@ runTcM abstr f ms s = unTcM f abstr (\x ms s cp b -> let (es,xs) = cp b lookupCatHyps :: CId -> TcM s [Hypo] lookupCatHyps cat = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (hyps,_,_) -> k hyps ms - Nothing -> h (UnknownCat cat)) + Just (hyps,_,_,_) -> k hyps ms + Nothing -> h (UnknownCat cat)) lookupFunType :: CId -> TcM s Type lookupFunType fun = TcM (\abstr k h ms -> case Map.lookup fun (funs abstr) of @@ -143,8 +143,8 @@ typeGenerators scope cat = fmap normalize (liftM2 (++) x y) | cat == cidString = return [(1.0,ELit (LStr "Foo"),TTyp [] (DTyp [] cat []))] | otherwise = TcM (\abstr k h ms -> case Map.lookup cat (cats abstr) of - Just (_,fns,_) -> unTcM (mapM helper fns) abstr k h ms - Nothing -> h (UnknownCat cat)) + Just (_,fns,_,_) -> unTcM (mapM helper fns) abstr k h ms + Nothing -> h (UnknownCat cat)) helper (p,fn) = do ty <- lookupFunType fn -- cgit v1.2.3