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 exec = \opts _ -> do
let file = optFile opts let file = optFile opts
mprobs <- optProbs opts pgf pgf <- optProbs opts pgf
let conf = configureExBased pgf (optMorpho opts) mprobs (optLang opts) let conf = configureExBased pgf (optMorpho opts) (optLang opts)
(file',ws) <- parseExamplesInGrammar conf file (file',ws) <- parseExamplesInGrammar conf file
if null ws then return () else putStrLn ("unknown words: " ++ unwords ws) if null ws then return () else putStrLn ("unknown words: " ++ unwords ws)
return (fromString ("wrote " ++ file')), 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)") ("probs", "file with biased probabilities (format 'f 0.4' one by line)")
], ],
exec = \opts xs -> do exec = \opts xs -> do
let pgfr = optRestricted opts pgf <- optProbs opts (optRestricted opts)
gen <- newStdGen 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 let ts = case mexp xs of
Just ex -> generateRandomFrom sel pgfr ex Just ex -> generateRandomFrom gen pgf ex
Nothing -> generateRandom sel pgfr (optType opts) Nothing -> generateRandom gen pgf (optType opts)
returnFromExprs $ take (optNum opts) ts returnFromExprs $ take (optNum opts) ts
}), }),
("gt", emptyCommandInfo { ("gt", emptyCommandInfo {
@@ -389,8 +385,11 @@ allCommands env@(pgf, mos) = Map.fromList [
" .gfo compiled GF source", " .gfo compiled GF source",
" .pgf precompiled grammar in Portable Grammar Format" " .pgf precompiled grammar in Portable Grammar Format"
], ],
flags = [
("probs","file with biased probabilities for generation")
],
options = [ options = [
-- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"] -- ["gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
("retain","retain operations (used for cc command)"), ("retain","retain operations (used for cc command)"),
("src", "force compilation from source"), ("src", "force compilation from source"),
("v", "be verbose - show intermediate status information") ("v", "be verbose - show intermediate status information")
@@ -461,9 +460,9 @@ allCommands env@(pgf, mos) = Map.fromList [
exec = \opts xs -> do exec = \opts xs -> do
let lang = optLang opts let lang = optLang opts
let typ = optType opts let typ = optType opts
mprobs <- optProbs opts pgf pgf <- optProbs opts pgf
let mt = mexp xs let mt = mexp xs
morphologyQuiz mt mprobs pgf lang typ morphologyQuiz mt pgf lang typ
return void, return void,
flags = [ flags = [
("lang","language of the quiz"), ("lang","language of the quiz"),
@@ -639,9 +638,8 @@ allCommands env@(pgf, mos) = Map.fromList [
"'function probability', e.g. 'youPol_Pron 0.01'." "'function probability', e.g. 'youPol_Pron 0.01'."
], ],
exec = \opts ts -> do exec = \opts ts -> do
mprobs <- optProbs opts pgf pgf <- optProbs opts pgf
let probs = maybe (defaultProbabilities pgf) id mprobs let tds = rankTreesByProbs pgf ts
let tds = rankTreesByProbs probs ts
if isOpt "v" opts if isOpt "v" opts
then putStrLn $ then putStrLn $
unlines [showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] 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 to = valCIdOpts "to" (optLang opts) opts
let typ = optType opts let typ = optType opts
let mt = mexp xs let mt = mexp xs
mprobs <- optProbs opts pgf pgf <- optProbs opts pgf
translationQuiz mt mprobs pgf from to typ translationQuiz mt pgf from to typ
return void, return void,
flags = [ flags = [
("from","translate from this language"), ("from","translate from this language"),
@@ -887,7 +885,7 @@ allCommands env@(pgf, mos) = Map.fromList [
if null (functionsToCat pgf id) if null (functionsToCat pgf id)
then empty then empty
else space $$ 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) Nothing -> do putStrLn ("unknown category of function identifier "++show id)
return void return void
[e] -> case inferExpr pgf e of [e] -> case inferExpr pgf e of
@@ -979,12 +977,11 @@ allCommands env@(pgf, mos) = Map.fromList [
"" -> [] "" -> []
cats -> mapMaybe readType (chunks ',' cats) cats -> mapMaybe readType (chunks ',' cats)
optProbs opts pgfr = case valStrOpts "probs" "" opts of optProbs opts pgf = case valStrOpts "probs" "" opts of
"" -> return Nothing "" -> return pgf
file -> do file -> do
ps <- readProbabilitiesFromFile file pgf ---- pgfr! probs <- readProbabilitiesFromFile file pgf
-- putStrLn $ showProbabilities ps return (setProbabilities probs pgf)
return $ Just ps
optFile opts = valStrOpts "file" "_gftmp" opts 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) | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf 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 ++ " ;" showFun (f,ty) = showCId f ++ " : " ++ showType [] ty ++ " ;"
morphos opts s = morphos opts s =
@@ -1096,16 +1093,14 @@ stringOpOptions = sort $ [
treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf]
treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf]
translationQuiz :: Maybe Expr -> Maybe Probabilities -> translationQuiz :: Maybe Expr -> PGF -> Language -> Language -> Type -> IO ()
PGF -> Language -> Language -> Type -> IO () translationQuiz mex pgf ig og typ = do
translationQuiz mex mprobs pgf ig og typ = do tts <- translationList mex pgf ig og typ infinity
tts <- translationList mex mprobs pgf ig og typ infinity
mkQuiz "Welcome to GF Translation Quiz." tts mkQuiz "Welcome to GF Translation Quiz." tts
morphologyQuiz :: Maybe Expr -> Maybe Probabilities -> morphologyQuiz :: Maybe Expr -> PGF -> Language -> Type -> IO ()
PGF -> Language -> Type -> IO () morphologyQuiz mex pgf ig typ = do
morphologyQuiz mex mprobs pgf ig typ = do tts <- morphologyList mex pgf ig typ infinity
tts <- morphologyList mex mprobs pgf ig typ infinity
mkQuiz "Welcome to GF Morphology Quiz." tts mkQuiz "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems -- | 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.Data
import PGF.Macros import PGF.Macros
import PGF.Optimize import PGF.Optimize
import PGF.Probabilistic
-- | Compiles a number of source files and builds a 'PGF' structure for them. -- | 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 link opts cnc gr = do
let isv = (verbAtLeast opts Normal) let isv = (verbAtLeast opts Normal)
putPointE Normal opts "linking ... " $ do putPointE Normal opts "linking ... " $ do
gc <- ioeIO (mkCanon2pgf opts cnc gr) pgf <- ioeIO (mkCanon2pgf opts cnc gr)
ioeIO $ putStrLn "OK" probs <- ioeIO (maybe (return . defaultProbabilities) readProbabilitiesFromFile (flag optProbsFile opts) pgf)
return $ if flag optOptimizePGF opts then optimizePGF gc else gc 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 :: Options -> [FilePath] -> IOE SourceGrammar
batchCompile opts files = do 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 t >> mapM_ (appn . (" --- " ++)) tt >> return []
appn ")" appn ")"
return ws return ws
rank ts = case probs conf of rank ts = [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs pgf ts]
Just probs -> [showExpr [] t ++ " -- " ++ show p | (t,p) <- rankTreesByProbs probs ts]
_ -> map (showExpr []) ts
appf = appendFile file appf = appendFile file
appn s = appf s >> appf "\n" appn s = appf s >> appf "\n"
appv s = appn ("--- " ++ s) >> putStrLn s appv s = appn ("--- " ++ s) >> putStrLn s
@@ -69,11 +67,10 @@ convertFile conf src file = do
data ExConfiguration = ExConf { data ExConfiguration = ExConf {
resource_pgf :: PGF, resource_pgf :: PGF,
resource_morpho :: Morpho, resource_morpho :: Morpho,
probs :: Maybe Probabilities,
verbose :: Bool, verbose :: Bool,
language :: Language language :: Language
} }
configureExBased :: PGF -> Morpho -> Maybe Probabilities -> Language -> ExConfiguration configureExBased :: PGF -> Morpho -> Language -> ExConfiguration
configureExBased pgf morpho mprobs lang = ExConf pgf morpho mprobs False lang 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 where
flags = Map.fromList [(mkCId f,C.LStr x) | (f,x) <- optionsPGF (M.flags abm)] 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)] (f,AbsFun (Just (L _ ty)) ma pty) <- Map.toAscList (M.jments abm)]
cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) | cats = Map.fromAscList [(i2i c, (snd (mkContext [] cont),catfuns c)) |
(c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)] (c,AbsCat (Just (L _ cont))) <- Map.toAscList (M.jments abm)]
catfuns cat = 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] [(loc,i2i f) | (f,AbsFun (Just (L loc ty)) _ _) <- tree2list (M.jments abm), snd (GM.valCat ty) == cat]
mkConcr am cm@(lang,mo) = do 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))))) fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = 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 :: OIdent -> HSkeleton -> (OIdent, [OIdent]) -> HSkeleton
updateSkeleton cat skel rule = 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 :: String -> Abstr -> JS.Expr
abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js (Map.assocs (funs ds))] 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 :: (CId,(Type,Int,Maybe [Equation],Double)) -> JS.Property
absdef2js (f,(typ,_,_)) = absdef2js (f,(typ,_,_,_)) =
let (args,cat) = M.catSkeleton typ in 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)]) 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 '.' $$ text "module" <+> ppCId (absname pgf) <> char '.' $$
space $$ space $$
vcat [ppClauses cat fns | (cat,(_,fs)) <- Map.toList (cats (abstract pgf)), 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 where
ppClauses cat fns = ppClauses cat fns =
text "/*" <+> ppCId cat <+> text "*/" $$ 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 $$ 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 space
grammar2lambdaprolog_sig pgf = render $ grammar2lambdaprolog_sig pgf = render $
@@ -27,10 +27,10 @@ grammar2lambdaprolog_sig pgf = render $
space $$ space $$
vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$ vcat [ppCat c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$
space $$ 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 $$ space $$
vcat [ppExport c hyps <> dot | (c,(hyps,_)) <- Map.toList (cats (abstract pgf))] $$ 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 :: CId -> [Hypo] -> Doc
ppCat c hyps = text "kind" <+> ppKind c <+> text "type" 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) in expr2goal abstr scope goals' i' e1 (e2':args)
expr2goal abstr scope goals i (EFun f) args = expr2goal abstr scope goals i (EFun f) args =
case Map.lookup f (funs abstr) of case Map.lookup f (funs abstr) of
Just (_,_,Just _) -> let e = EFun (mkVar i) Just (_,_,Just _,_) -> let e = EFun (mkVar i)
in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e) in (foldl EApp (EFun f) (args++[e]) : goals, i+1, e)
_ -> (goals,i,foldl EApp (EFun f) args) _ -> (goals,i,foldl EApp (EFun f) args)
expr2goal abstr scope goals i (EVar j) args = expr2goal abstr scope goals i (EVar j) args =
(goals,i,foldl EApp (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)" clauseHeader "%% def(?Fun, ?Expr)"
(concatMap plFundef (Map.assocs funs)) (concatMap plFundef (Map.assocs funs))
plCat :: (CId, ([Hypo],[CId])) -> String plCat :: (CId, ([Hypo],[(Double,CId)])) -> String
plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ) plCat (cat, (hypos,_)) = plFact "cat" (plTypeWithHypos typ)
where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos where ((_,subst), hypos') = mapAccumL alphaConvertHypo emptyEnv hypos
args = reverse [EFun x | (_,x) <- subst] args = reverse [EFun x | (_,x) <- subst]
typ = DTyp hypos' cat args typ = DTyp hypos' cat args
plFun :: (CId, (Type, Int, Maybe [Equation])) -> String plFun :: (CId, (Type, Int, Maybe [Equation], Double)) -> String
plFun (fun, (typ,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ') plFun (fun, (typ,_,_,_)) = plFact "fun" (plp fun : plTypeWithHypos typ')
where typ' = snd $ alphaConvert emptyEnv typ where typ' = snd $ alphaConvert emptyEnv typ
plTypeWithHypos :: Type -> [String] plTypeWithHypos :: Type -> [String]
plTypeWithHypos (DTyp hypos cat args) = [plTerm (plp cat) (map plp args), plList (map (\(_,x,ty) -> plOper ":" (plp x) (plp ty)) hypos)] 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 :: (CId, (Type,Int,Maybe [Equation],Double)) -> [String]
plFundef (fun, (_,_,Nothing )) = [] plFundef (fun, (_,_,Nothing ,_)) = []
plFundef (fun, (_,_,Just eqs)) = [plFact "def" [plp fun, plp fundef']] plFundef (fun, (_,_,Just eqs,_)) = [plFact "def" [plp fun, plp fundef']]
where fundef' = snd $ alphaConvert emptyEnv eqs 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, optGFLibPath :: Maybe FilePath,
optRecomp :: Recomp, optRecomp :: Recomp,
optPrinter :: [Printer], optPrinter :: [Printer],
optProb :: Bool, optProbsFile :: Maybe FilePath,
optRetainResource :: Bool, optRetainResource :: Bool,
optName :: Maybe String, optName :: Maybe String,
optAbsName :: Maybe String, optAbsName :: Maybe String,
@@ -255,7 +255,7 @@ defaultFlags = Flags {
optGFLibPath = Nothing, optGFLibPath = Nothing,
optRecomp = RecompIfNewer, optRecomp = RecompIfNewer,
optPrinter = [], optPrinter = [],
optProb = False, optProbsFile = Nothing,
optRetainResource = False, optRetainResource = False,
optName = Nothing, optName = Nothing,
@@ -329,7 +329,7 @@ optDescr =
Option [] ["strip"] (NoArg (printer PrinterStrip)) Option [] ["strip"] (NoArg (printer PrinterStrip))
"Remove name qualifiers when pretty-printing.", "Remove name qualifiers when pretty-printing.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", 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") Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ", (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, ", "with suffixes depending on the formats, and, when relevant, ",
@@ -399,7 +399,7 @@ optDescr =
gfLibPath x = set $ \o -> o { optGFLibPath = Just x } gfLibPath x = set $ \o -> o { optGFLibPath = Just x }
recomp x = set $ \o -> o { optRecomp = x } recomp x = set $ \o -> o { optRecomp = x }
printer x = set $ \o -> o { optPrinter = x : optPrinter o } 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 } name x = set $ \o -> o { optName = Just x }
absName x = set $ \o -> o { optAbsName = 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 teachDialogue qas msg
translationList :: translationList ::
Maybe Expr -> Maybe Probabilities -> Maybe Expr -> PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])] translationList mex pgf ig og typ number = do
translationList mex mprobs pgf ig og typ number = do
gen <- newStdGen gen <- newStdGen
let sel = case mprobs of let ts = take number $ case mex of
Just probs -> WeightSel gen probs Just ex -> generateRandomFrom gen pgf ex
Nothing -> RandSel gen Nothing -> generateRandom gen pgf typ
let ts = take number $ case mex of
Just ex -> generateRandomFrom sel pgf ex
Nothing -> generateRandom sel pgf typ
return $ map mkOne $ ts return $ map mkOne $ ts
where where
mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t)) mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t))
homonyms = parse pgf ig typ . linearize pgf ig homonyms = parse pgf ig typ . linearize pgf ig
morphologyList :: morphologyList ::
Maybe Expr -> Maybe Probabilities -> Maybe Expr -> PGF -> Language -> Type -> Int -> IO [(String,[String])]
PGF -> Language -> Type -> Int -> IO [(String,[String])] morphologyList mex pgf ig typ number = do
morphologyList mex mprobs pgf ig typ number = do
gen <- newStdGen gen <- newStdGen
let sel = case mprobs of let ts = take (max 1 number) $ case mex of
Just probs -> WeightSel gen probs Just ex -> generateRandomFrom gen pgf ex
Nothing -> RandSel gen Nothing -> generateRandom gen pgf typ
let ts = take (max 1 number) $ case mex of
Just ex -> generateRandomFrom sel pgf ex
Nothing -> generateRandom sel pgf typ
let ss = map (tabularLinearizes pgf ig) ts let ss = map (tabularLinearizes pgf ig) ts
let size = length (head (head ss)) let size = length (head (head ss))
let forms = take number $ randomRs (0,size-1) gen 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])])] type Skeleton = [(CId, [(CId, [CId])])]
pgfSkeleton :: PGF -> Skeleton 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))] | (c,(_,fs)) <- Map.toList (cats (abstract pgf))]
-- --

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

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

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

@@ -25,8 +25,8 @@ data PGF = PGF {
data Abstr = Abstr { data Abstr = Abstr {
aflags :: Map.Map CId Literal, -- ^ value of a flag aflags :: Map.Map CId Literal, -- ^ value of a flag
funs :: Map.Map CId (Type,Int,Maybe [Equation]), -- ^ type, arrity and definition of function funs :: Map.Map CId (Type,Int,Maybe [Equation],Double), -- ^ type, arrity and definition of function + probability
cats :: Map.Map CId ([Hypo],[CId]) -- ^ 1. context of a category cats :: Map.Map CId ([Hypo],[(Double, CId)]) -- ^ 1. context of a category
-- ^ 2. functions of a category. The order in the list is important, -- ^ 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. -- this is the order in which the type singatures are given in the source.
-- The termination of the exhaustive generation might depend on this. -- 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 | VClosure Env Expr
| VImplArg Value | VImplArg Value
type Sig = ( Map.Map CId (Type,Int,Maybe [Equation]) -- type and def of a fun type Sig = ( Map.Map CId (Type,Int,Maybe [Equation],Double) -- type and def of a fun
, Int -> Maybe Expr -- lookup for metavariables , Int -> Maybe Expr -- lookup for metavariables
) )
type Env = [Value] type Env = [Value]
eval :: Sig -> Env -> Expr -> Value eval :: Sig -> Env -> Expr -> Value
eval sig env (EVar i) = env !! i eval sig env (EVar i) = env !! i
eval sig env (EFun f) = case Map.lookup f (fst sig) of eval sig env (EFun f) = case Map.lookup f (fst sig) of
Just (_,a,meqs) -> case meqs of Just (_,a,meqs,_) -> case meqs of
Just eqs -> if a == 0 Just eqs -> if a == 0
then case eqs of then case eqs of
Equ [] e : _ -> eval sig [] e Equ [] e : _ -> eval sig [] e
_ -> VConst f [] _ -> VConst f []
else VApp f [] else VApp f []
Nothing -> VApp f [] Nothing -> VApp f []
Nothing -> error ("unknown function "++showCId f) Nothing -> error ("unknown function "++showCId f)
eval sig env (EApp e1 e2) = apply sig env e1 [eval sig env e2] 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 (EAbs b x e) = VClosure env (EAbs b x e)
eval sig env (EMeta i) = case snd sig i of 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 e [] = eval sig env e
apply sig env (EVar i) vs = applyValue sig (env !! i) vs apply sig env (EVar i) vs = applyValue sig (env !! i) vs
apply sig env (EFun f) vs = case Map.lookup f (fst sig) of apply sig env (EFun f) vs = case Map.lookup f (fst sig) of
Just (_,a,meqs) -> case meqs of Just (_,a,meqs,_) -> case meqs of
Just eqs -> if a <= length vs Just eqs -> if a <= length vs
then match sig f eqs vs then match sig f eqs vs
else VApp f vs else VApp f vs
Nothing -> VApp f vs Nothing -> VApp f vs
Nothing -> error ("unknown function "++showCId f) 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 (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 (EAbs _ x e) (v:vs) = apply sig (v:env) e vs
apply sig env (EMeta i) vs = case snd sig i of 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 cat = case isLindefCId fun of
Just cat -> cat Just cat -> cat
Nothing -> case Map.lookup fun (funs abs) of Nothing -> case Map.lookup fun (funs abs) of
Just (DTyp _ cat _,_,_) -> cat Just (DTyp _ cat _,_,_,_) -> cat
largs = map (render forest) args largs = map (render forest) args
ltable = mkLinTable cnc isTrusted [] funid largs ltable = mkLinTable cnc isTrusted [] funid largs
in ((cat,fid),either (const []) id $ getAbsTrees f arg Nothing,ltable) 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 , generateFrom, generateFromDepth
, generateRandom, generateRandomDepth , generateRandom, generateRandomDepth
, generateRandomFrom, generateRandomFromDepth , generateRandomFrom, generateRandomFromDepth
, RandomSelector(..)
) where ) where
import PGF.CId import PGF.CId
@@ -17,6 +15,7 @@ import PGF.Probabilistic
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Control.Monad import Control.Monad
import Control.Monad.Identity
import System.Random import System.Random
-- | Generates an exhaustive possibly infinite list of -- | 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. -- | Generates an infinite list of random abstract syntax expressions.
-- This is usefull for tree bank generation which after that can be used -- This is usefull for tree bank generation which after that can be used
-- for grammar testing. -- for grammar testing.
generateRandom :: RandomGen g => RandomSelector g -> PGF -> Type -> [Expr] generateRandom :: RandomGen g => g -> PGF -> Type -> [Expr]
generateRandom sel pgf ty = generateRandom g pgf ty =
generate sel pgf ty Nothing generate (Identity g) pgf ty Nothing
-- | A variant of 'generateRandom' which also takes as argument -- | A variant of 'generateRandom' which also takes as argument
-- the upper limit of the depth of the generated expression. -- the upper limit of the depth of the generated expression.
generateRandomDepth :: RandomGen g => RandomSelector g -> PGF -> Type -> Maybe Int -> [Expr] generateRandomDepth :: RandomGen g => g -> PGF -> Type -> Maybe Int -> [Expr]
generateRandomDepth sel pgf ty dp = generate sel pgf ty dp generateRandomDepth g pgf ty dp = generate (Identity g) pgf ty dp
-- | Random generation based on template -- | Random generation based on template
generateRandomFrom :: RandomGen g => RandomSelector g -> PGF -> Expr -> [Expr] generateRandomFrom :: RandomGen g => g -> PGF -> Expr -> [Expr]
generateRandomFrom sel pgf e = generateRandomFrom g pgf e =
generateForMetas True pgf (\ty -> generate sel pgf ty Nothing) e generateForMetas True pgf (\ty -> generate (Identity g) pgf ty Nothing) e
-- | Random generation based on template with a limitation in the depth. -- | Random generation based on template with a limitation in the depth.
generateRandomFromDepth :: RandomGen g => RandomSelector g -> PGF -> Expr -> Maybe Int -> [Expr] generateRandomFromDepth :: RandomGen g => g -> PGF -> Expr -> Maybe Int -> [Expr]
generateRandomFromDepth sel pgf e dp = generateRandomFromDepth g pgf e dp =
generateForMetas True pgf (\ty -> generate sel pgf ty dp) e 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 = clauses cat =
do fn <- select abs cat do fn <- select abs cat
case Map.lookup fn (funs abs) of case Map.lookup fn (funs abs) of
Just (ty,_,_) -> return (fn,ty) Just (ty,_,_,_) -> return (fn,ty)
Nothing -> mzero Nothing -> mzero
mkEnv env [] = return (env,[]) mkEnv env [] = return (env,[])
mkEnv env ((bt,x,ty):hypos) = do mkEnv env ((bt,x,ty):hypos) = do
@@ -175,46 +174,23 @@ instance Selector () where
Just (_,fns) -> iter s fns Just (_,fns) -> iter s fns
Nothing -> CFail) Nothing -> CFail)
where where
iter s [] = CFail iter s [] = CFail
iter s (fn:fns) = CBranch (COk () s fn) (iter s fns) iter s ((_,fn):fns) = CBranch (COk () s fn) (iter s fns)
-- | The random selector data type is used to specify the random number generator instance RandomGen g => Selector (Identity g) where
-- and the distribution among the functions with the same result category. splitSelector (Identity g) = let (g1,g2) = split g
-- The distribution is even for 'RandSel' and weighted for 'WeightSel'. in (Identity g1, Identity g2)
data RandomSelector g = RandSel g
| WeightSel g Probabilities
instance RandomGen g => Selector (RandomSelector g) where select abs cat = GenM (\(Identity g) s ->
splitSelector (RandSel g) = let (g1,g2) = split g case Map.lookup cat (cats abs) of
in (RandSel g1, RandSel g2) Just (_,fns) -> do_rand g s 1.0 fns
splitSelector (WeightSel g probs) = let (g1,g2) = split g Nothing -> CFail)
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)
where where
do_rand g s n [] = CFail do_rand g s p [] = CFail
do_rand g s n fns = let n' = n-1 do_rand g s p fns = let (d,g') = randomR (0.0,p) g
(i,g') = randomR (0,n') g
(g1,g2) = split g' (g1,g2) = split g'
(fn,fns') = pick i fns (p',fn,fns') = hit d fns
in CBranch (COk (RandSel g1) s fn) (do_rand g2 s n' fns') in CBranch (COk (Identity g1) s fn) (do_rand g2 s (p-p') 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')
hit :: Double -> [(Double,a)] -> (Double,a,[(Double,a)]) hit :: Double -> [(Double,a)] -> (Double,a,[(Double,a)])
hit d (px@(p,x):xs) 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] Nothing -> concat [toApp fid prod | (fid,set) <- IntMap.toList prods, prod <- Set.toList set]
where where
toApp fid (PApply funid pargs) = 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 (args,res) = catSkeleton ty
in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])] in [(funid,(res,fid),zip args [fid | PArg _ fid <- pargs])]
toApp _ (PCoerce fid) = 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 -> CId -> Type
lookType pgf f = lookType pgf f =
case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of case lookMap (error $ "lookType " ++ show f) f (funs (abstract pgf)) of
(ty,_,_) -> ty (ty,_,_,_) -> ty
lookDef :: PGF -> CId -> Maybe [Equation] lookDef :: PGF -> CId -> Maybe [Equation]
lookDef pgf f = lookDef pgf f =
case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of case lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf)) of
(_,a,eqs) -> eqs (_,a,eqs,_) -> eqs
isData :: PGF -> CId -> Bool isData :: PGF -> CId -> Bool
isData pgf f = isData pgf f =
case Map.lookup f (funs (abstract pgf)) of case Map.lookup f (funs (abstract pgf)) of
Just (_,_,Nothing) -> True -- the encoding of data constrs Just (_,_,Nothing,_) -> True -- the encoding of data constrs
_ -> False _ -> False
lookValCat :: PGF -> CId -> CId lookValCat :: PGF -> CId -> CId
lookValCat pgf = valCat . lookType pgf 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 -> CId -> [(CId,Type)]
functionsToCat pgf cat = 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 where
(_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf (_,fs) = lookMap ([],[]) cat $ cats $ abstract pgf
@@ -81,7 +81,7 @@ restrictPGF :: (CId -> Bool) -> PGF -> PGF
restrictPGF cond pgf = pgf { restrictPGF cond pgf = pgf {
abstract = abstr { abstract = abstr {
funs = Map.filterWithKey (\c _ -> cond c) (funs 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 } ---- restrict concrs also, might be needed
where 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)] isClosed d || (length equs == 1 && isLinear d)]
equss = [(f,[(Fun f (map patt2tree ps), expr2tree d) | (Equ ps d) <- eqs]) | 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 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 :: CId -> Literal -> Doc
ppFlag flag value = text "flag" <+> ppCId flag <+> char '=' <+> ppLit value <+> char ';' 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 ';' ppCat c (hyps,_) = text "cat" <+> ppCId c <+> hsep (snd (mapAccumL (ppHypo 4) [] hyps)) <+> char ';'
ppFun :: CId -> (Type,Int,Maybe [Equation]) -> Doc ppFun :: CId -> (Type,Int,Maybe [Equation],Double) -> Doc
ppFun f (t,_,Just eqs) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$ ppFun f (t,_,Just eqs,_) = text "fun" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';' $$
if null eqs if null eqs
then empty then empty
else text "def" <+> vcat [let scope = foldl pattScope [] patts else text "def" <+> vcat [let scope = foldl pattScope [] patts
ds = map (ppPatt 9 scope) patts ds = map (ppPatt 9 scope) patts
in ppCId f <+> hsep ds <+> char '=' <+> ppExpr 0 scope res <+> char ';' | Equ patts res <- eqs] 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 f (t,_,Nothing,_) = text "data" <+> ppCId f <+> colon <+> ppType 0 [] t <+> char ';'
ppCnc :: Language -> Concr -> Doc ppCnc :: Language -> Concr -> Doc
ppCnc name cnc = ppCnc name cnc =

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

@@ -2,6 +2,8 @@ module PGF.Probabilistic
( Probabilities(..) ( Probabilities(..)
, mkProbabilities -- :: PGF -> M.Map CId Double -> Probabilities , mkProbabilities -- :: PGF -> M.Map CId Double -> Probabilities
, defaultProbabilities -- :: PGF -> Probabilities , defaultProbabilities -- :: PGF -> Probabilities
, getProbabilities
, setProbabilities
, showProbabilities -- :: Probabilities -> String , showProbabilities -- :: Probabilities -> String
, readProbabilitiesFromFile -- :: FilePath -> PGF -> IO Probabilities , readProbabilitiesFromFile -- :: FilePath -> PGF -> IO Probabilities
@@ -15,7 +17,7 @@ import PGF.Macros
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.List (sortBy,partition) import Data.List (sortBy,partition)
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe, fromJust)
-- | An abstract data structure which represents -- | An abstract data structure which represents
-- the probabilities for the different functions in a grammar. -- 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)) cats1 = Map.map (\(_,fs) -> fill fs) (cats (abstract pgf))
in Probs funs1 cats1 in Probs funs1 cats1
where where
fill fs = pad [(Map.lookup f probs,f) | f <- fs] fill fs = pad [(Map.lookup f probs,f) | (_,f) <- fs]
where where
pad :: [(Maybe Double,a)] -> [(Double,a)] pad :: [(Maybe Double,a)] -> [(Double,a)]
pad pfs = [(fromMaybe deflt mb_p,f) | (mb_p,f) <- pfs] pad pfs = [(fromMaybe deflt mb_p,f) | (mb_p,f) <- pfs]
@@ -64,16 +66,34 @@ mkProbabilities pgf probs =
defaultProbabilities :: PGF -> Probabilities defaultProbabilities :: PGF -> Probabilities
defaultProbabilities pgf = mkProbabilities pgf Map.empty 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 -- | compute the probability of a given tree
probTree :: Probabilities -> Expr -> Double probTree :: PGF -> Expr -> Double
probTree probs t = case t of probTree pgf t = case t of
EApp f e -> probTree probs f * probTree probs e EApp f e -> probTree pgf f * probTree pgf e
EFun f -> maybe 1 id $ Map.lookup f (funProbs probs) EFun f -> case Map.lookup f (funs (abstract pgf)) of
Just (_,_,_,p) -> p
Nothing -> 1
_ -> 1 _ -> 1
-- | rank from highest to lowest probability -- | rank from highest to lowest probability
rankTreesByProbs :: Probabilities -> [Expr] -> [(Expr,Double)] rankTreesByProbs :: PGF -> [Expr] -> [(Expr,Double)]
rankTreesByProbs probs ts = sortBy (\ (_,p) (_,q) -> compare q p) rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, probTree probs t) | t <- ts] [(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 :: CId -> TcM TType
lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of lookupFunType fun = TcM (\abstr ms -> case Map.lookup fun (funs abstr) of
Just (ty,_,_) -> Ok ms (TTyp [] ty) Just (ty,_,_,_) -> Ok ms (TTyp [] ty)
Nothing -> Fail (UnknownFun fun)) Nothing -> Fail (UnknownFun fun))
newMeta :: Scope -> TType -> TcM MetaId newMeta :: Scope -> TType -> TcM MetaId
newMeta scope tty = TcM (\abstr ms -> let metaid = IntMap.size ms + 1 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 -> Maybe PGF.Type -> IO [PGF.Tree]
random' pgf mcat = do random' pgf mcat = do
g <- newStdGen 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 -> Maybe (Accept Language) -> PGF.Language
selectLanguage pgf macc = case acceptable of selectLanguage pgf macc = case acceptable of