diff options
Diffstat (limited to 'src/GF/UseGrammar')
| -rw-r--r-- | src/GF/UseGrammar/Custom.hs | 12 | ||||
| -rw-r--r-- | src/GF/UseGrammar/Generate.hs | 63 |
2 files changed, 62 insertions, 13 deletions
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index 66ba55934..400b358c7 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -11,6 +11,7 @@ import qualified AbsGF as GF import qualified MMacros as MM import AbsCompute import TypeCheck +import Generate ------import Compile import ShellState import Editing @@ -203,6 +204,14 @@ customTermCommand = (exp2termCommand gr (computeAbsTerm gr) t)) ,(strCI "paraphrase", \g t -> let gr = grammar g in exp2termlistCommand gr (mkParaphrases gr) t) + + ,(strCI "generate", \g t -> let gr = grammar g + cat = actCat $ tree2loc t --- not needed + in + tree2termlistCommand gr + (generateTrees gr cat 2 + Nothing . Just) t) + ,(strCI "typecheck", \g t -> let gr = grammar g in err (const []) (return . const t) (checkIfValidExp gr (tree2exp t))) @@ -219,12 +228,13 @@ customEditCommand = customData "Editor state transformers, selected by option -edit=x" $ [ (strCI "identity", const return) -- DEFAULT - ,(strCI "transfer", const return) --- done ad hoc on top level ,(strCI "typecheck", \g -> reCheckState (grammar g)) ,(strCI "solve", \g -> solveAll (grammar g)) ,(strCI "context", \g -> contextRefinements (grammar g)) ,(strCI "compute", \g -> computeSubTree (grammar g)) ,(strCI "paraphrase", const return) --- done ad hoc on top level + ,(strCI "generate", const return) --- done ad hoc on top level + ,(strCI "transfer", const return) --- done ad hoc on top level -- add your own edit commands here ] ++ moreCustomEditCommand diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs index 9f8fb66d1..94d6a6cfe 100644 --- a/src/GF/UseGrammar/Generate.hs +++ b/src/GF/UseGrammar/Generate.hs @@ -4,8 +4,11 @@ import GFC import LookAbs import PrGrammar import Macros +import Values import Operations +import Zipper + import List -- Generate all trees of given category and depth. AR 30/4/2004 @@ -17,10 +20,14 @@ import List -- the main function takes an abstract syntax and returns a list of trees --- generateTrees :: GFCGrammar -> Cat -> Int -> Maybe Int -> [Exp] -generateTrees gr cat n mn = map str2tr $ generate gr' cat' n mn where - gr' = gr2sgr gr - cat' = prt $ snd cat +--- if type were shown more modules should be imported +-- generateTrees :: +-- GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp] +generateTrees gr cat n mn mt = map str2tr $ generate gr' cat' n mn mt' + where + gr' = gr2sgr gr + cat' = prt $ snd cat + mt' = maybe Nothing (return . tr2str) mt ------------------------------------------ -- translate grammar to simpler form and generated trees back @@ -34,28 +41,49 @@ gr2sgr gr = [(trId f, ty') | (f,ty) <- funRulesOf gr, ty' <- trTy ty] where trCat (m,c) = prt c --- -- str2tr :: STree -> Exp -str2tr (STr (f,ts)) = mkApp (trId f) (map str2tr ts) where - trId = cn . zIdent +str2tr t = case t of + SApp (f,ts) -> mkApp (trId f) (map str2tr ts) + + where + trId = cn . zIdent + +-- tr2str :: Tree -> STree +tr2str (Tr (N (_,at,val,_,_),ts)) = case (at,val) of + (AtC (_,f), _) -> SApp (prt_ f,map tr2str ts) + (AtM _, VCn (_,c)) -> SMeta (prt_ c) + (AtL s, _) -> SString s + (AtI i, _) -> SInt i + _ -> SMeta "FAILED_TO_GENERATE" ---- err monad! ------------------------------------------ -- do the main thing with a simpler data structure -- the first Int gives tree depth, the second constrains subtrees -- chosen for each branch. A small number, such as 2, is a good choice -- if the depth is large (more than 3) +-- If a tree is given as argument, generation concerns its metavariables. + +generate :: SGrammar -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree] +generate gr cat i mn mt = case mt of + Nothing -> [t | (c,t) <- gen 0 [], c == cat] + Just t -> genM t -generate :: SGrammar -> SCat -> Int -> Maybe Int -> [STree] -generate gr cat i mn = [t | (c,t) <- gen 0 [], c == cat] where + where gen :: Int -> [(SCat,STree)] -> [(SCat,STree)] gen n cts = if n==i then cts else - gen (n+1) (nub [(c,STr (f, xs)) | (f,(cs,c)) <- gr, xs <- args cs cts] ++ cts) + gen (n+1) (nub [(c,SApp (f, xs)) | (f,(cs,c)) <- gr, xs <- args cs cts] ++ cts) args :: [SCat] -> [(SCat,STree)] -> [[STree]] args cs cts = combinations [constr [t | (k,t) <- cts, k == c] | c <- cs] constr = maybe id take mn + genM t = case t of + SApp (f,ts) -> [SApp (f,ts') | ts' <- combinations (map genM ts)] + SMeta k -> [t | (c,t) <- gen 0 [], c == k] + _ -> [t] + type SGrammar = [SRule] type SIdent = String type SRule = (SFun,SType) @@ -63,13 +91,24 @@ type SType = ([SCat],SCat) type SCat = SIdent type SFun = SIdent -newtype STree = STr (SFun,[STree]) deriving (Show,Eq) +data STree = + SApp (SFun,[STree]) + | SMeta SCat + | SString String + | SInt Int + deriving (Show,Eq) ------------------------------------------ -- to test -prSTree (STr (f,ts)) = f ++ concat (map pr1 ts) where - pr1 t@(STr (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) +prSTree t = case t of + SApp (f,ts) -> f ++ concat (map pr1 ts) + SMeta c -> '?':c + SString s -> prQuotedString s + SInt i -> show i + where + pr1 t@(SApp (_,ts)) = ' ' : (if null ts then id else prParenth) (prSTree t) + pr1 t = prSTree t pSRule :: String -> SRule pSRule s = case words s of |