summaryrefslogtreecommitdiff
path: root/src/GF
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF')
-rw-r--r--src/GF/API.hs6
-rw-r--r--src/GF/Grammar/TypeCheck.hs3
-rw-r--r--src/GF/Shell.hs10
-rw-r--r--src/GF/Shell/Commands.hs2
-rw-r--r--src/GF/Shell/PShell.hs1
-rw-r--r--src/GF/UseGrammar/Custom.hs12
-rw-r--r--src/GF/UseGrammar/Generate.hs63
7 files changed, 80 insertions, 17 deletions
diff --git a/src/GF/API.hs b/src/GF/API.hs
index 49d7fd5a2..d748a5517 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -157,10 +157,10 @@ randomTreesIO opts gr n = do
g = grammar gr
mx = optIntOrN opts flagDepth 41
-generateTrees :: Options -> GFGrammar -> [Tree]
-generateTrees opts gr =
+generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
+generateTrees opts gr mt =
optIntOrAll opts flagNumber
- [tr | t <- Gen.generateTrees gr' cat dpt mn, Ok tr <- [mkTr t]]
+ [tr | t <- Gen.generateTrees gr' cat dpt mn mt, Ok tr <- [mkTr t]]
where
mkTr = annotate gr' . qualifTerm (absId gr)
gr' = grammar gr
diff --git a/src/GF/Grammar/TypeCheck.hs b/src/GF/Grammar/TypeCheck.hs
index 1cc486965..183b0ac12 100644
--- a/src/GF/Grammar/TypeCheck.hs
+++ b/src/GF/Grammar/TypeCheck.hs
@@ -243,3 +243,6 @@ exp2termCommand gr f t = errIn ("modifying term" +++ prt t) $ do
exp2termlistCommand :: GFCGrammar -> (Exp -> [Exp]) -> Tree -> [Tree]
exp2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f . tree2exp
+
+tree2termlistCommand :: GFCGrammar -> (Tree -> [Exp]) -> Tree -> [Tree]
+tree2termlistCommand gr f = err (const []) fst . mapErr (annotate gr) . f
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 66a073ebc..61fa7ce1e 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -188,7 +188,15 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
_ -> do
ts <- randomTreesIO opts gro (optIntOrN opts flagNumber 1)
returnArg (ATrms ts) sa
- CGenerateTrees -> returnArg (ATrms $ generateTrees opts gro) sa
+ CGenerateTrees -> do
+ let
+ a' = case a of
+ ASTrm _ -> s2t a
+ _ -> a
+ mt = case a' of
+ ATrms (tr:_) -> Just tr
+ _ -> Nothing
+ returnArg (ATrms $ generateTrees opts gro mt) sa
CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
diff --git a/src/GF/Shell/Commands.hs b/src/GF/Shell/Commands.hs
index 19148c1bc..678d3d7da 100644
--- a/src/GF/Shell/Commands.hs
+++ b/src/GF/Shell/Commands.hs
@@ -238,6 +238,8 @@ execECommand env c = case c of
replaceByTermCommand der gr c (actTree (stateSState s)) s
---- "transfer" -> action2commandNext $
---- transferSubTree (stateTransferFun sgr) gr
+ "generate" -> \s ->
+ replaceByTermCommand der gr c (actTree (stateSState s)) s
_ -> replaceByEditCommand gr c
CAddOption o -> changeStOptions (addOption o)
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index befdb8ea2..7a7f1e702 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -73,6 +73,7 @@ pCommand ws = case ws of
"gr" : [] -> aUnit CGenerateRandom
"gr" : t -> aTerm CGenerateRandom t
"gt" : [] -> aUnit CGenerateTrees
+ "gt" : t -> aTerm CGenerateTrees t
"pt" : s -> aTerm CPutTerm s
----- "wt" : f : s -> aTerm (CWrapTerm (string2id f)) s
"ma" : s -> aString CMorphoAnalyse s
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 12:27:08 +0000