gt Term

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

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] 
 
-generate :: SGrammar -> SCat -> Int -> Maybe Int -> [STree]
-generate gr cat i mn = [t | (c,t) <- gen 0 [], c == cat] where
+  Just t -> genM t
+
+ 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