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

the PGF service now can do both random and exhaustive generation. these functions now return both the generated tree and its linearization

Browse Source
This commit is contained in:
krasimir
2010-10-13 12:32:49 +00:00
parent 63ac5f5db6
commit cecf94d729
1 changed files with 29 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

40
src/server/PGFService.hs
View File

@@ -88,7 +88,8 @@ pgfMain pgf command =
"parse" -> outputJSONP =<< doParse pgf `fmap` getText `ap` getCat `ap` getFrom
"complete" -> outputJSONP =<< doComplete pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getLimit
"linearize" -> outputJSONP =<< doLinearize pgf `fmap` getTree `ap` getTo
"random" -> getCat >>= \c -> getLimit >>= liftIO . doRandom pgf c >>= outputJSONP
"random" -> getCat >>= \c -> getDepth >>= \dp -> getLimit >>= \l -> getTo >>= \to -> liftIO (doRandom pgf c dp l to) >>= outputJSONP
"generate" -> outputJSONP =<< doGenerate pgf `fmap` getCat `ap` getDepth `ap` getLimit `ap` getTo
"translate" -> outputJSONP =<< doTranslate pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
"translategroup" -> outputJSONP =<< doTranslateGroup pgf `fmap` getText `ap` getCat `ap` getFrom `ap` getTo
"grammar" -> outputJSONP =<< doGrammar pgf `fmap` requestAcceptLanguage
@@ -144,6 +145,9 @@ pgfMain pgf command =
getLimit :: CGI (Maybe Int)
getLimit = readInput "limit"
getDepth :: CGI (Maybe Int)
getDepth = readInput "depth"
getLang :: String -> CGI (Maybe PGF.Language)
getLang i =
do mlang <- getInput i
@@ -264,11 +268,30 @@ doLinearize :: PGF -> PGF.Tree -> Maybe PGF.Language -> JSValue
doLinearize pgf tree mto = showJSON $ map toJSObject
[[("to", PGF.showLanguage to),("text",text)] | (to,text) <- linearize' pgf mto tree]
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> IO JSValue
doRandom pgf mcat mlimit =
do trees <- random' pgf mcat
return $ showJSON $ map toJSObject [[("tree", PGF.showExpr [] tree)] | tree <- limit trees]
where limit = take (fromMaybe 1 mlimit)
doRandom :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> IO JSValue
doRandom pgf mcat mdepth mlimit mto =
do g <- newStdGen
let trees = PGF.generateRandomDepth g pgf cat (Just depth)
return $ showJSON $
[toJSObject [("tree", showJSON (PGF.showExpr [] tree)),
("linearizations", showJSON [toJSObject [("to", PGF.showLanguage to),("text",text)]
| (to,text) <- linearize' pgf mto tree])]
| tree <- limit trees]
where cat = fromMaybe (PGF.startCat pgf) mcat
limit = take (fromMaybe 1 mlimit)
depth = fromMaybe 4 mdepth
doGenerate :: PGF -> Maybe PGF.Type -> Maybe Int -> Maybe Int -> Maybe PGF.Language -> JSValue
doGenerate pgf mcat mdepth mlimit mto =
let trees = PGF.generateAllDepth pgf cat (Just depth)
in showJSON $
[toJSObject [("tree", showJSON (PGF.showExpr [] tree)),
("linearizations", showJSON [toJSObject [("to", PGF.showLanguage to),("text",text)]
| (to,text) <- linearize' pgf mto tree])]
| tree <- limit trees]
where cat = fromMaybe (PGF.startCat pgf) mcat
limit = take (fromMaybe 1 mlimit)
depth = fromMaybe 4 mdepth
doGrammar :: PGF -> Maybe (Accept Language) -> JSValue
doGrammar pgf macc = showJSON $ toJSObject
@@ -466,11 +489,6 @@ linearizeAndBind pgf mto t = [(la, binds s) | (la,s) <- linearize' pgf mto t]
u:ws2 -> u : bs ws2
_ -> []
random' :: PGF -> Maybe PGF.Type -> IO [PGF.Tree]
random' pgf mcat = do
g <- newStdGen
return $ PGF.generateRandom g pgf (fromMaybe (PGF.startCat pgf) mcat)
selectLanguage :: PGF -> Maybe (Accept Language) -> PGF.Language
selectLanguage pgf macc = case acceptable of
[] -> case PGF.languages pgf of