msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

refactor the API for random generation again. Now PGF contains probabilities in the abstract syntax

Browse Source
This commit is contained in:
krasimir
2010-10-02 13:03:57 +00:00
parent 72cc4ddb59
commit cb8795c222
23 changed files with 177 additions and 194 deletions
Download Patch File Download Diff File Expand all files Collapse all files

59
src/compiler/GF/Command/Commands.hs
View File

@@ -278,8 +278,8 @@ allCommands env@(pgf, mos) = Map.fromList [
],
exec = \opts _ -> do
let file = optFile opts
mprobs <- optProbs opts pgf
let conf = configureExBased pgf (optMorpho opts) mprobs (optLang opts)
pgf <- optProbs opts pgf
let conf = configureExBased pgf (optMorpho opts) (optLang opts)
(file',ws) <- parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')),
@@ -309,15 +309,11 @@ allCommands env@(pgf, mos) = Map.fromList [
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
],
exec = \opts xs -> do
let pgfr = optRestricted opts
pgf <- optProbs opts (optRestricted opts)
gen <- newStdGen
mprobs <- optProbs opts pgfr
let sel = case mprobs of
Just probs -> WeightSel gen probs
Nothing -> RandSel gen
let ts = case mexp xs of
Just ex -> generateRandomFrom sel pgfr ex
Nothing -> generateRandom sel pgfr (optType opts)
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf (optType opts)
returnFromExprs $ take (optNum opts) ts
}),
("gt", emptyCommandInfo {
@@ -389,8 +385,11 @@ allCommands env@(pgf, mos) = Map.fromList [
" .gfo compiled GF source",
" .pgf precompiled grammar in Portable Grammar Format"
],
flags = [
("probs","file with biased probabilities for generation")
],
options = [
-- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
-- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
("retain","retain operations (used for cc command)"),
("src", "force compilation from source"),
("v", "be verbose - show intermediate status information")
@@ -461,9 +460,9 @@ allCommands env@(pgf, mos) = Map.fromList [
exec = \opts xs -> do
let lang = optLang opts
let typ = optType opts
mprobs <- optProbs opts pgf
pgf <- optProbs opts pgf
let mt = mexp xs
morphologyQuiz mt mprobs pgf lang typ
morphologyQuiz mt pgf lang typ
return void,
flags = [
("lang","language of the quiz"),
@@ -639,9 +638,8 @@ allCommands env@(pgf, mos) = Map.fromList [
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = \opts ts -> do
mprobs <- optProbs opts pgf
let probs = maybe (defaultProbabilities pgf) id mprobs
let tds = rankTreesByProbs probs ts
pgf <- optProbs opts pgf
let tds = rankTreesByProbs pgf ts
if isOpt "v" opts
then putStrLn $
unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds]
@@ -667,8 +665,8 @@ allCommands env@(pgf, mos) = Map.fromList [
let to = valCIdOpts "to" (optLang opts) opts
let typ = optType opts
let mt = mexp xs
mprobs <- optProbs opts pgf
translationQuiz mt mprobs pgf from to typ
pgf <- optProbs opts pgf
translationQuiz mt pgf from to typ
return void,
flags = [
("from","translate from this language"),
@@ -887,7 +885,7 @@ allCommands env@(pgf, mos) = Map.fromList [
if null (functionsToCat pgf id)
then empty
else space $$
vcat [ppFun fid (ty,0,Just []) | (fid,ty) <- functionsToCat pgf id])
vcat [ppFun fid (ty,0,Just [],0) | (fid,ty) <- functionsToCat pgf id])
Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void
[e] -> case inferExpr pgf e of
@@ -979,12 +977,11 @@ allCommands env@(pgf, mos) = Map.fromList [
"" -> []
cats -> mapMaybe readType (chunks ',' cats)
optProbs opts pgfr = case valStrOpts "probs" "" opts of
"" -> return Nothing
optProbs opts pgf = case valStrOpts "probs" "" opts of
"" -> return pgf
file -> do
ps <- readProbabilitiesFromFile file pgf ---- pgfr!
-- putStrLn $ showProbabilities ps
return $ Just ps
probs <- readProbabilitiesFromFile file pgf
return (setProbabilities probs pgf)
optFile opts = valStrOpts "file" "_gftmp" opts
@@ -1038,7 +1035,7 @@ allCommands env@(pgf, mos) = Map.fromList [
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf
funsigs pgf = [(f,ty) | (f,(ty,_,_)) <- Map.assocs (funs (abstract pgf))]
funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (funs (abstract pgf))]
showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
morphos opts s =
@@ -1096,16 +1093,14 @@ stringOpOptions = sort $ [
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe Expr -> Maybe Probabilities ->
PGF -> Language -> Language -> Type -> IO ()
translationQuiz mex mprobs pgf ig og typ = do
tts <- translationList mex mprobs pgf ig og typ infinity
translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO ()
translationQuiz mex pgf ig og typ = do
tts <- translationList mex pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe Expr -> Maybe Probabilities ->
PGF -> Language -> Type -> IO ()
morphologyQuiz mex mprobs pgf ig typ = do
tts <- morphologyList mex mprobs pgf ig typ infinity
morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO ()
morphologyQuiz mex pgf ig typ = do
tts <- morphologyList mex pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems

11
src/compiler/GF/Compile.hs
View File

@@ -42,6 +42,7 @@ import PGF.CId
import PGF.Data
import PGF.Macros
import PGF.Optimize
import PGF.Probabilistic
-- | Compiles a number of source files and builds a 'PGF' structure for them.
@@ -55,9 +56,13 @@ link :: Options -> Ident -> SourceGrammar -> IOE PGF
link opts cnc gr = do
let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do
gc <- ioeIO (mkCanon2pgf opts cnc gr)
ioeIO $ putStrLn "OK"
return $ if flag optOptimizePGF opts then optimizePGF gc else gc
pgf <- ioeIO (mkCanon2pgf opts cnc gr)
probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
ioeIO $ putStrLn "OK"
pgf <- return $ setProbabilities probs
$ if flag optOptimizePGF opts then optimizePGF pgf else pgf
ioeIO $ putStrLn (showProbabilities (getProbabilities pgf))
return pgf
batchCompile :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do

9
src/compiler/GF/Compile/ExampleBased.hs
View File

@@ -59,9 +59,7 @@ convertFile conf src file = do
appn t >> mapM_ (appn . (" --- " ++)) tt >> return []
appn ")"
return ws
rank ts = case probs conf of
Just probs -> [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs probs ts]
_ -> map (showExpr []) ts
rank ts = [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
appf = appendFile file
appn s = appf s >> appf "\n"
appv s = appn ("--- " ++ s) >> putStrLn s
@@ -69,11 +67,10 @@ convertFile conf src file = do
data ExConfiguration = ExConf {
resource_pgf :: PGF,
resource_morpho :: Morpho,
probs :: Maybe Probabilities,
verbose :: Bool,
language :: Language
}
configureExBased :: PGF -> Morpho -> Maybe Probabilities -> Language -> ExConfiguration
configureExBased pgf morpho mprobs lang = ExConf pgf morpho mprobs False lang
configureExBased :: PGF -> Morpho -> Language -> ExConfiguration
configureExBased pgf morpho lang = ExConf pgf morpho False lang

4
src/compiler/GF/Compile/GrammarToPGF.hs
View File

@@ -57,14 +57,14 @@ canon2pgf opts gr cgr@(M.MGrammar (am:cms)) = do
where
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)]
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty)) |
funs = Map.fromAscList [(i2i f, (mkType [] ty, mkArrity ma, mkDef pty, 0)) |
(f,AbsFun (Just (L _ ty)) ma pty) <- Map.toAscList (M.jments abm)]
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
(c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)]
catfuns cat =
(map snd . sortBy (compare `on` fst))
(map (\x -> (0,snd x)) . sortBy (compare `on` fst))
[(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
mkConcr am cm@(lang,mo) = do

2
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -200,7 +200,7 @@ hSkeleton gr =
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
jty (f,(ty,_,_)) = (f,catSkeleton ty)
jty (f,(ty,_,_,_)) = (f,catSkeleton ty)
updateSkeleton :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule =

4
src/compiler/GF/Compile/PGFtoJS.hs
View File

@@ -33,8 +33,8 @@ pgf2js pgf =
abstract2js :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))]
absdef2js :: (CId,(Type,Int,Maybe [Equation])) -> JS.Property
absdef2js (f,(typ,_,_)) =
absdef2js :: (CId,(Type,Int,Maybe [Equation],Double)) -> JS.Property
absdef2js (f,(typ,_,_,_)) =
let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])

16
src/compiler/GF/Compile/PGFtoLProlog.hs
View File

@@ -13,13 +13,13 @@ grammar2lambdaprolog_mod pgf = render $
text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$
vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)),
let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | f <- fs]]
let fns = [(f,fromJust (Map.lookup f (funs (abstract pgf)))) | (_,f) <- fs]]
where
ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing)) <- fns] $$
vcat [snd (ppClause (abstract pgf) 0 1 [] f ty) <> dot | (f,(ty,_,Nothing,_)) <- fns] $$
space $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs)) <- fns] $$
vcat [vcat (map (\eq -> equation2clause (abstract pgf) f eq <> dot) eqs) | (f,(_,_,Just eqs,_)) <- fns] $$
space
grammar2lambdaprolog_sig pgf = render $
@@ -27,10 +27,10 @@ grammar2lambdaprolog_sig pgf = render $
space $$
vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
space $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing)) <- Map.toList (funs (abstract pgf))] $$
vcat [ppFun f ty <> dot | (f,(ty,_,Nothing,_)) <- Map.toList (funs (abstract pgf))] $$
space $$
vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _)) <- Map.toList (funs (abstract pgf))]
vcat [ppFunPred f (hyps ++ [(Explicit,wildCId,DTyp [] c es)]) <> dot | (f,(DTyp hyps c es,_,Just _,_)) <- Map.toList (funs (abstract pgf))]
ppCat :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type"
@@ -157,8 +157,8 @@ expr2goal abstr scope goals i (EApp e1 e2) args =
in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of
Just (_,_,Just _) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
Just (_,_,Just _,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args =
(goals,i,foldl EApp (EVar j) args)

12
src/compiler/GF/Compile/PGFtoProlog.hs
View File

@@ -62,22 +62,22 @@ plAbstract (name, Abstr aflags funs cats) =
clauseHeader "%% def(?Fun, ?Expr)"
(concatMap plFundef (Map.assocs funs))
plCat :: (CId, ([Hypo],[CId])) -> String
plCat :: (CId, ([Hypo],[(Double,CId)])) -> String
plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ)
where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos
args = reverse [EFun x | (_,x) <- subst]
typ = DTyp hypos' cat args
plFun :: (CId, (Type, Int, Maybe [Equation])) -> String
plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
plFun :: (CId, (Type, Int, Maybe [Equation], Double)) -> String
plFun (fun, (typ,_,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
where typ' = snd $ alphaConvert emptyEnv typ
plTypeWithHypos :: Type -> [String]
plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)]
plFundef :: (CId, (Type,Int,Maybe [Equation])) -> [String]
plFundef (fun, (_,_,Nothing )) = []
plFundef (fun, (_,_,Just eqs)) = [plFact "def" [plp fun, plp fundef']]
plFundef :: (CId, (Type,Int,Maybe [Equation],Double)) -> [String]
plFundef (fun, (_,_,Nothing ,_)) = []
plFundef (fun, (_,_,Just eqs,_)) = [plFact "def" [plp fun, plp fundef']]
where fundef' = snd $ alphaConvert emptyEnv eqs

8
src/compiler/GF/Infra/Option.hs
View File

@@ -155,7 +155,7 @@ data Flags = Flags {
optGFLibPath :: Maybe FilePath,
optRecomp :: Recomp,
optPrinter :: [Printer],
optProb :: Bool,
optProbsFile :: Maybe FilePath,
optRetainResource :: Bool,
optName :: Maybe String,
optAbsName :: Maybe String,
@@ -255,7 +255,7 @@ defaultFlags = Flags {
optGFLibPath = Nothing,
optRecomp = RecompIfNewer,
optPrinter = [],
optProb = False,
optProbsFile = Nothing,
optRetainResource = False,
optName = Nothing,
@@ -329,7 +329,7 @@ optDescr =
Option [] ["strip"] (NoArg (printer PrinterStrip))
"Remove name qualifiers when pretty-printing.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ",
@@ -399,7 +399,7 @@ optDescr =
gfLibPath x = set $ \o -> o { optGFLibPath = Just x }
recomp x = set $ \o -> o { optRecomp = x }
printer x = set $ \o -> o { optPrinter = x : optPrinter o }
prob x = set $ \o -> o { optProb = x }
probsFile x = set $ \o -> o { optProbsFile = Just x }
name x = set $ \o -> o { optName = Just x }
absName x = set $ \o -> o { optAbsName = Just x }

28
src/compiler/GF/Quiz.hs
View File

@@ -38,32 +38,24 @@ mkQuiz msg tts = do
teachDialogue qas msg
translationList ::
Maybe Expr -> Maybe Probabilities ->
PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
translationList mex mprobs pgf ig og typ number = do
Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
translationList mex pgf ig og typ number = do
gen <- newStdGen
let sel = case mprobs of
Just probs -> WeightSel gen probs
Nothing -> RandSel gen
let ts = take number $ case mex of
Just ex -> generateRandomFrom sel pgf ex
Nothing -> generateRandom sel pgf typ
let ts = take number $ case mex of
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf typ
return $ map mkOne $ ts
where
mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t))
homonyms = parse pgf ig typ . linearize pgf ig
morphologyList ::
Maybe Expr -> Maybe Probabilities ->
PGF -> Language -> Type -> Int -> IO [(String,[String])]
morphologyList mex mprobs pgf ig typ number = do
Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])]
morphologyList mex pgf ig typ number = do
gen <- newStdGen
let sel = case mprobs of
Just probs -> WeightSel gen probs
Nothing -> RandSel gen
let ts = take (max 1 number) $ case mex of
Just ex -> generateRandomFrom sel pgf ex
Nothing -> generateRandom sel pgf typ
let ts = take (max 1 number) $ case mex of
Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom gen pgf typ
let ss = map (tabularLinearizes pgf ig) ts
let size = length (head (head ss))
let forms = take number $ randomRs (0,size-1) gen

2
src/compiler/GF/Speech/VoiceXML.hs
View File

@@ -39,7 +39,7 @@ grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | f <- fs])
pgfSkeleton pgf = [(c,[(f,fst (catSkeleton (lookType pgf f))) | (_,f) <- fs])
| (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
--

22
src/runtime/haskell/PGF.hs
View File

@@ -105,8 +105,6 @@ module PGF(
generateFrom, generateFromDepth,
generateRandom, generateRandomDepth,
generateRandomFrom, generateRandomFromDepth,
RandomSelector(..),
-- ** Morphological Analysis
Lemma, Analysis, Morpho,
@@ -269,8 +267,8 @@ functions pgf = Map.keys (funs (abstract pgf))
functionType pgf fun =
case Map.lookup fun (funs (abstract pgf)) of
Just (ty,_,_) -> Just ty
Nothing -> Nothing
Just (ty,_,_,_) -> Just ty
Nothing -> Nothing
-- | Converts an expression to normal form
compute :: PGF -> Expr -> Expr
@@ -280,20 +278,20 @@ browse :: PGF -> CId -> Maybe (String,[CId],[CId])
browse pgf id = fmap (\def -> (def,producers,consumers)) definition
where
definition = case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,Just eqs) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
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)
Just (ty,_,Just eqs,_) -> Just $ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
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
(producers,consumers) = Map.foldWithKey accum ([],[]) (funs (abstract pgf))
where
accum f (ty,_,_) (plist,clist) =
accum f (ty,_,_,_) (plist,clist) =
let !plist' = if id `elem` ps then f : plist else plist
!clist' = if id `elem` cs then f : clist else clist
in (plist',clist')

4
src/runtime/haskell/PGF/Data.hs
View File

@@ -25,8 +25,8 @@ data PGF = PGF {
data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation]), -- ^ type, arrity and definition of function
cats :: Map.Map CId ([Hypo],[CId]) -- ^ 1. context of a category
funs :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[(Double, CId)]) -- ^ 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.

32
src/runtime/haskell/PGF/Expr.hs
View File

@@ -318,22 +318,22 @@ data Value
| VClosure Env Expr
| VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation]) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables
)
type Env = [Value]
eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of
Just (_,a,meqs) -> case meqs of
Just eqs -> if a == 0
then case eqs of
Equ [] e : _ -> eval sig [] e
_ -> VConst f []
else VApp f []
Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
Just (_,a,meqs,_) -> case meqs of
Just eqs -> if a == 0
then case eqs of
Equ [] e : _ -> eval sig [] e
_ -> VConst f []
else VApp f []
Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2]
eval sig env (EAbs b x e) = VClosure env (EAbs b x e)
eval sig env (EMeta i) = case snd sig i of
@@ -347,12 +347,12 @@ apply :: Sig -> Env -> Expr -> [Value] -> Value
apply sig env e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
Just (_,a,meqs) -> case meqs of
Just eqs -> if a <= length vs
then match sig f eqs vs
else VApp f vs
Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
Just (_,a,meqs,_) -> case meqs of
Just eqs -> if a <= length vs
then match sig f eqs vs
else VApp f vs
Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f)
apply sig env (EApp e1 e2) vs = apply sig env e1 (eval sig env e2 : vs)
apply sig env (EAbs _ x e) (v:vs) = apply sig (v:env) e vs
apply sig env (EMeta i) vs = case snd sig i of

2
src/runtime/haskell/PGF/Forest.hs
View File

@@ -72,7 +72,7 @@ bracketedTokn f@(Forest abs cnc forest root) =
cat = case isLindefCId fun of
Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of
Just (DTyp _ cat _,_,_) -> cat
Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable)

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

@@ -3,8 +3,6 @@ module PGF.Generate
, generateFrom, generateFromDepth
, generateRandom, generateRandomDepth
, generateRandomFrom, generateRandomFromDepth
, RandomSelector(..)
) where
import PGF.CId
@@ -17,6 +15,7 @@ import PGF.Probabilistic
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Control.Monad
import Control.Monad.Identity
import System.Random
-- | Generates an exhaustive possibly infinite list of
@@ -44,24 +43,24 @@ generateFromDepth pgf e dp = generateForMetas False pgf (\ty -> generateAllDepth
-- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used
-- for grammar testing.
generateRandom :: RandomGen g => RandomSelector g -> PGF -> Type -> [Expr]
generateRandom sel pgf ty =
generate sel pgf ty Nothing
generateRandom :: RandomGen g => g -> PGF -> Type -> [Expr]
generateRandom g pgf ty =
generate (Identity g) pgf ty Nothing
-- | A variant of 'generateRandom' which also takes as argument
-- the upper limit of the depth of the generated expression.
generateRandomDepth :: RandomGen g => RandomSelector g -> PGF -> Type -> Maybe Int -> [Expr]
generateRandomDepth sel pgf ty dp = generate sel pgf ty dp
generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr]
generateRandomDepth g pgf ty dp = generate (Identity g) pgf ty dp
-- | Random generation based on template
generateRandomFrom :: RandomGen g => RandomSelector g -> PGF -> Expr -> [Expr]
generateRandomFrom sel pgf e =
generateForMetas True pgf (\ty -> generate sel pgf ty Nothing) e
generateRandomFrom :: RandomGen g => g -> PGF -> Expr -> [Expr]
generateRandomFrom g pgf e =
generateForMetas True pgf (\ty -> generate (Identity g) pgf ty Nothing) e
-- | Random generation based on template with a limitation in the depth.
generateRandomFromDepth :: RandomGen g => RandomSelector g -> PGF -> Expr -> Maybe Int -> [Expr]
generateRandomFromDepth sel pgf e dp =
generateForMetas True pgf (\ty -> generate sel pgf ty dp) e
generateRandomFromDepth :: RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr]
generateRandomFromDepth g pgf e dp =
generateForMetas True pgf (\ty -> generate (Identity g) pgf ty dp) e
@@ -103,8 +102,8 @@ prove abs scope tty@(TTyp env (DTyp [] cat es)) dp = do
clauses cat =
do fn <- select abs cat
case Map.lookup fn (funs abs) of
Just (ty,_,_) -> return (fn,ty)
Nothing -> mzero
Just (ty,_,_,_) -> return (fn,ty)
Nothing -> mzero
mkEnv env [] = return (env,[])
mkEnv env ((bt,x,ty):hypos) = do
@@ -175,46 +174,23 @@ instance Selector () where
Just (_,fns) -> iter s fns
Nothing -> CFail)
where
iter s [] = CFail
iter s (fn:fns) = CBranch (COk () s fn) (iter s fns)
iter s [] = CFail
iter s ((_,fn):fns) = CBranch (COk () s fn) (iter s fns)
-- | The random selector data type is used to specify the random number generator
-- and the distribution among the functions with the same result category.
-- The distribution is even for 'RandSel' and weighted for 'WeightSel'.
data RandomSelector g = RandSel g
| WeightSel g Probabilities
instance RandomGen g => Selector (Identity g) where
splitSelector (Identity g) = let (g1,g2) = split g
in (Identity g1, Identity g2)
instance RandomGen g => Selector (RandomSelector g) where
splitSelector (RandSel g) = let (g1,g2) = split g
in (RandSel g1, RandSel g2)
splitSelector (WeightSel g probs) = let (g1,g2) = split g
in (WeightSel g1 probs, WeightSel g2 probs)
select abs cat = GenM (\sel s -> case sel of
RandSel g -> case Map.lookup cat (cats abs) of
Just (_,fns) -> do_rand g s (length fns) fns
Nothing -> CFail
WeightSel g probs -> case Map.lookup cat (catProbs probs) of
Just fns -> do_weight g s 1.0 fns
Nothing -> CFail)
select abs cat = GenM (\(Identity g) s ->
case Map.lookup cat (cats abs) of
Just (_,fns) -> do_rand g s 1.0 fns
Nothing -> CFail)
where
do_rand g s n [] = CFail
do_rand g s n fns = let n' = n-1
(i,g') = randomR (0,n') g
do_rand g s p [] = CFail
do_rand g s p fns = let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(fn,fns') = pick i fns
in CBranch (COk (RandSel g1) s fn) (do_rand g2 s n' fns')
do_weight g s p [] = CFail
do_weight g s p fns = let (d,g') = randomR (0.0,p) g
(g1,g2) = split g'
(p',fn,fns') = hit d fns
in CBranch (COk (RandSel g1) s fn) (do_weight g2 s (p-p') fns')
pick :: Int -> [a] -> (a,[a])
pick 0 (x:xs) = (x,xs)
pick n (x:xs) = let (x',xs') = pick (n-1) xs
in (x',x:xs')
(p',fn,fns') = hit d fns
in CBranch (COk (Identity g1) s fn) (do_rand g2 s (p-p') fns')
hit :: Double -> [(Double,a)] -> (Double,a,[(Double,a)])
hit d (px@(p,x):xs)

2
src/runtime/haskell/PGF/Linearize.hs
View File

@@ -96,7 +96,7 @@ linTree pgf lang e =
Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where
toApp fid (PApply funid pargs) =
let Just (ty,_,_) = Map.lookup f (funs (abstract pgf))
let Just (ty,_,_,_) = Map.lookup f (funs (abstract pgf))
(args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) =

12
src/runtime/haskell/PGF/Macros.hs
View File

@@ -21,18 +21,18 @@ mapConcretes f pgf = pgf { concretes = Map.map f (concretes pgf) }
lookType :: PGF -> CId -> Type
lookType pgf f =
case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of
(ty,_,_) -> ty
(ty,_,_,_) -> ty
lookDef :: PGF -> CId -> Maybe [Equation]
lookDef pgf f =
case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of
(_,a,eqs) -> eqs
(_,a,eqs,_) -> eqs
isData :: PGF -> CId -> Bool
isData pgf f =
case Map.lookup f (funs (abstract pgf)) of
Just (_,_,Nothing) -> True -- the encoding of data constrs
_ -> False
Just (_,_,Nothing,_) -> True -- the encoding of data constrs
_ -> False
lookValCat :: PGF -> CId -> CId
lookValCat pgf = valCat . lookType pgf
@@ -65,7 +65,7 @@ lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
functionsToCat :: PGF -> CId -> [(CId,Type)]
functionsToCat pgf cat =
[(f,ty) | f <- fs, Just (ty,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
[(f,ty) | (_,f) <- fs, Just (ty,_,_,_) <- [Map.lookup f $ funs $ abstract pgf]]
where
(_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf
@@ -81,7 +81,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) -> (hyps,filter cond fs)) (cats abstr)
cats = Map.map (\(hyps,fs) -> (hyps,filter (cond . snd) fs)) (cats abstr)
}
} ---- restrict concrs also, might be needed
where

2
src/runtime/haskell/PGF/Paraphrase.hs
View File

@@ -53,7 +53,7 @@ fromDef pgf t@(Fun f ts) = defDown t ++ defUp t where
isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) |
(f,(_,_,Just eqs)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
(f,(_,_,Just eqs,_)) <- Map.assocs (funs (abstract pgf)), not (null eqs)]
trequ s f e = True ----trace (s ++ ": " ++ show f ++ " " ++ show e) True

18
src/runtime/haskell/PGF/Printer.hs
View File

@@ -28,17 +28,17 @@ 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],[CId]) -> Doc
ppCat :: CId -> ([Hypo],[(Double,CId)]) -> Doc
ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc
ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
ppFun f (t,_,Nothing) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc
ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
if null eqs
then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs]
ppFun f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc
ppCnc name cnc =

38
src/runtime/haskell/PGF/Probabilistic.hs
View File

@@ -2,6 +2,8 @@ module PGF.Probabilistic
( Probabilities(..)
, mkProbabilities -- :: PGF -> M.Map CId Double -> Probabilities
, defaultProbabilities -- :: PGF -> Probabilities
, getProbabilities
, setProbabilities
, showProbabilities -- :: Probabilities -> String
, readProbabilitiesFromFile -- :: FilePath -> PGF -> IO Probabilities
@@ -15,7 +17,7 @@ import PGF.Macros
import qualified Data.Map as Map
import Data.List (sortBy,partition)
import Data.Maybe (fromMaybe)
import Data.Maybe (fromMaybe, fromJust)
-- | An abstract data structure which represents
-- the probabilities for the different functions in a grammar.
@@ -51,7 +53,7 @@ mkProbabilities pgf probs =
cats1 = Map.map (\(_,fs) -> fill fs) (cats (abstract pgf))
in Probs funs1 cats1
where
fill fs = pad [(Map.lookup f probs,f) | f <- fs]
fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
where
pad :: [(Maybe Double,a)] -> [(Double,a)]
pad pfs = [(fromMaybe deflt mb_p,f) | (mb_p,f) <- pfs]
@@ -64,16 +66,34 @@ mkProbabilities pgf probs =
defaultProbabilities :: PGF -> Probabilities
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))
}
setProbabilities :: Probabilities -> PGF -> PGF
setProbabilities probs pgf = pgf {
abstract = (abstract pgf) {
funs = mapUnionWith (\(ty,a,df,_) p -> (ty,a,df,p)) (funs (abstract pgf)) (funProbs probs),
cats = mapUnionWith (\(hypos,_) fns -> (hypos,fns)) (cats (abstract pgf)) (catProbs probs)
}}
where
mapUnionWith f map1 map2 =
Map.mapWithKey (\k v -> f v (fromJust (Map.lookup k map2))) map1
-- | compute the probability of a given tree
probTree :: Probabilities -> Expr -> Double
probTree probs t = case t of
EApp f e -> probTree probs f * probTree probs e
EFun f -> maybe 1 id $ Map.lookup f (funProbs probs)
probTree :: PGF -> Expr -> Double
probTree pgf t = case t of
EApp f e -> probTree pgf f * probTree pgf e
EFun f -> case Map.lookup f (funs (abstract pgf)) of
Just (_,_,_,p) -> p
Nothing -> 1
_ -> 1
-- | rank from highest to lowest probability
rankTreesByProbs :: Probabilities -> [Expr] -> [(Expr,Double)]
rankTreesByProbs probs ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, probTree probs t) | t <- ts]
rankTreesByProbs :: PGF -> [Expr] -> [(Expr,Double)]
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, probTree pgf t) | t <- ts]

4
src/runtime/haskell/PGF/TypeCheck.hs
View File

@@ -101,8 +101,8 @@ lookupCatHyps cat = TcM (\abstr ms -> case Map.lookup cat (cats abstr) of
lookupFunType :: CId -> TcM TType
lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of
Just (ty,_,_) -> Ok ms (TTyp [] ty)
Nothing -> Fail (UnknownFun fun))
Just (ty,_,_,_) -> Ok ms (TTyp [] ty)
Nothing -> Fail (UnknownFun fun))
newMeta :: Scope -> TType -> TcM MetaId
newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1

2
src/server/PGFService.hs
View File

@@ -469,7 +469,7 @@ linearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- linearize' pgf mto t]
random' :: PGF -> Maybe PGF.Type -> IO [PGF.Tree]
random' pgf mcat = do
g <- newStdGen
return $ PGF.generateRandom (PGF.RandSel g) pgf (fromMaybe (PGF.startCat pgf) mcat)
return $ PGF.generateRandom g pgf (fromMaybe (PGF.startCat pgf) mcat)
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage pgf macc = case acceptable of