GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-03 00:02:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

change the TcM monad to continuation passing style. The old monad caused stack overflow for large search spaces

Browse Source
This commit is contained in:
krasimir
2010-10-21 15:01:52 +00:00
parent b3165b9eb6
commit 8c751d404f
3 changed files with 93 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/runtime/haskell/PGF/Generate.hs
View File

@@ -47,7 +47,7 @@ generateFromDepth :: PGF -> Expr -> Maybe Int -> [Expr]
generateFromDepth pgf e dp =
[e | (_,_,e) <- snd $ runTcM (abstract pgf)
(generateForMetas (prove dp) e)
() emptyMetaStore]
emptyMetaStore ()]
-- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used
@@ -69,7 +69,7 @@ generateRandomFromDepth :: RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr
generateRandomFromDepth g pgf e dp =
restart g (\g -> [e | (_,ms,e) <- snd $ runTcM (abstract pgf)
(generateForMetas (prove dp) e)
(Identity g) emptyMetaStore])
emptyMetaStore (Identity g)])
------------------------------------------------------------------------------
@@ -79,7 +79,7 @@ generate :: Selector sel => sel -> PGF -> Type -> Maybe Int -> [Expr]
generate sel pgf ty dp =
[e | (_,ms,e) <- snd $ runTcM (abstract pgf)
(prove dp emptyScope (TTyp [] ty) >>= checkResolvedMetaStore emptyScope)
sel emptyMetaStore]
emptyMetaStore sel]
prove :: Selector sel => Maybe Int -> Scope -> TType -> TcM sel Expr
prove dp scope (TTyp env1 (DTyp hypos1 cat es1)) = do
@@ -150,10 +150,10 @@ instance Selector () where
splitSelector s = (s,s)
select cat scope dp = do
gens <- typeGenerators scope cat
TcM (\abstr s ms -> iter ms gens)
TcM (\abstr k h -> iter k gens)
where
iter ms [] = Zero
iter ms ((_,e,tty):fns) = Plus (Ok () ms (e,tty)) (iter ms fns)
iter k [] ms s = id
iter k ((_,e,tty):fns) ms s = k (e,tty) ms s . iter k fns ms s
instance RandomGen g => Selector (Identity g) where
@@ -162,13 +162,13 @@ instance RandomGen g => Selector (Identity g) where
select cat scope dp = do
gens <- typeGenerators scope cat
TcM (\abstr (Identity g) ms -> do_rand abstr g ms 1.0 gens)
TcM (\abstr k h -> iter k 1.0 gens)
where
do_rand abstr g ms p [] = Zero
do_rand abstr g ms p gens = let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(p',e_ty,gens') = hit d gens
in Plus (Ok (Identity g1) ms e_ty) (do_rand abstr g2 ms (p-p') gens')
iter k p [] ms (Identity g) = id
iter k p gens ms (Identity g) = let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(p',e_ty,gens') = hit d gens
in k e_ty ms (Identity g1) . iter k (p-p') gens' ms (Identity g2)
hit :: Double -> [(Double,Expr,TType)] -> (Double,(Expr,TType),[(Double,Expr,TType)])
hit d (gen@(p,e,ty):gens)