gt -atoms

doc/gf-history.html

@@ -12,6 +12,14 @@ Changes in functionality since May 17, 2005, release of GF Version 2.2
 
 </center>
 
+12/10 (AR) Flag <tt>-atoms=Int</tt> to the command <tt>gt = generate_trees</tt>
+takes away all zero-argument functions except Int per category. In
+this way, it is possible to generate a corpus illustrating each
+syntactic structure even when the lexicon (which consists of
+zero-argument functions) is large.
+
+<p>
+
 6/10 (AR) New commands <tt>dc = define_command</tt> and
 <tt>dt = define_tree</tt> to define macros in a GF session.
 See <tt>help</tt> for details and examples. 

src/GF/API.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/06/02 17:31:57 $ 
+-- > CVS $Date: 2005/10/12 12:38:29 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.37 $
+-- > CVS $Revision: 1.38 $
 --
 -- Application Programmer's Interface to GF; also used by Shell. AR 10/11/2001
 -----------------------------------------------------------------------------
@@ -189,14 +189,13 @@ randomTreesIO opts gr n = do
 generateTrees :: Options -> GFGrammar -> Maybe Tree -> [Tree]
 generateTrees opts gr mt =
   optIntOrAll opts flagNumber  
-    [tr | t <- Gen.generateTrees gr' ifm cat dpt mn mt, Ok tr <- [mkTr t]]
+    [tr | t <- Gen.generateTrees opts gr' cat dpt mn mt, Ok tr <- [mkTr t]]
   where
     mkTr = annotate gr' . qualifTerm (absId gr) 
     gr' = grammar gr
     cat = firstAbsCat opts gr
     dpt = maybe 3 id $ getOptInt opts flagDepth
     mn  = getOptInt opts flagAlts
-    ifm = oElem withMetas opts
 
 speechGenerate :: Options -> String -> IO ()
 speechGenerate opts str = do

src/GF/Grammar/PatternMatch.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:26 $ 
+-- > CVS $Date: 2005/10/12 12:38:29 $ 
--- > CVS $Author: bringert $
+-- > CVS $Author: aarne $
--- > CVS $Revision: 1.6 $
+-- > CVS $Revision: 1.7 $
 --
 -- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003
 -----------------------------------------------------------------------------
@@ -65,12 +65,14 @@ tryMatch (p,t) = do
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
       (PP q p pp, ([], QC r f, tt)) | 
-            q `eqStrIdent` r && p `eqStrIdent` f && length pp == length tt ->
+            -- q `eqStrIdent` r &&  --- not for inherited AR 10/10/2005
+            p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
       ---- hack for AppPredef bug
       (PP q p pp, ([], Q r f, tt)) | 
-            q `eqStrIdent` r && p `eqStrIdent` f && length pp == length tt ->
+            -- q `eqStrIdent` r && --- 
+            p `eqStrIdent` f && length pp == length tt ->
          do matches <- mapM tryMatch (zip pp tt)
             return (concat matches)
 

src/GF/Shell/HelpFile.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/06 14:21:34 $
+-- > CVS $Date: 2005/10/12 12:38:30 $
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.16 $
+-- > CVS $Revision: 1.17 $
 --
 -- Help on shell commands. Generated from HelpFile by 'make help'.
 -- PLEASE DON'T EDIT THIS FILE.
@@ -289,6 +289,7 @@ txtHelpFile =
   "\n      -metas   also return trees that include metavariables" ++
   "\n  flags:" ++
   "\n      -depth   generate to this depth (default 3)" ++
+  "\n      -atoms   take this number of atomic rules of each category (default unlimited)" ++
   "\n      -alts    take this number of alternatives at each branch (default unlimited)" ++
   "\n      -cat     generate in this category" ++
   "\n      -lang    use the abstract syntax of this grammar" ++

src/GF/Shell/ShellCommands.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/06 10:02:34 $ 
+-- > CVS $Date: 2005/10/12 12:38:30 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.41 $
+-- > CVS $Revision: 1.42 $
 --
 -- The datatype of shell commands and the list of their options.
 -----------------------------------------------------------------------------
@@ -176,7 +176,7 @@ optionsOfCommand co = case co of
   CParse -> both "new newer cfg mcfg n ign raw v lines all" "cat lang lexer parser number rawtrees"
   CTranslate _ _ -> opts "cat lexer parser"
   CGenerateRandom -> flags "cat lang number depth"
-  CGenerateTrees -> both "metas" "depth alts cat lang number"
+  CGenerateTrees -> both "metas one" "depth alts cat lang number"
   CPutTerm -> flags "transform number"
   CWrapTerm _ -> opts "c"
   CMorphoAnalyse -> both "short" "lang"

src/GF/UseGrammar/Custom.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/10/05 20:02:20 $ 
+-- > CVS $Date: 2005/10/12 12:38:30 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.77 $
+-- > CVS $Revision: 1.78 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -344,7 +344,7 @@ customTermCommand =
   ,(strCI "generate",   \g t -> let gr = grammar g
                                     cat = actCat $ tree2loc t --- not needed
                                 in
-                         [tr | t <- generateTrees gr False cat 2 Nothing (Just t), 
+                         [tr | t <- generateTrees noOptions gr cat 2 Nothing (Just t), 
                                Ok tr <- [annotate gr $ MM.qualifTerm (absId g) t]])
   ,(strCI "typecheck",   \g t -> err (const []) (return . loc2tree)
                                     (reCheckStateReject (grammar g) (tree2loc t)))

src/GF/UseGrammar/Generate.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/05/30 18:39:44 $ 
+-- > CVS $Date: 2005/10/12 12:38:30 $ 
 -- > CVS $Author: aarne $
--- > CVS $Revision: 1.15 $
+-- > CVS $Revision: 1.16 $
 --
 -- Generate all trees of given category and depth. AR 30\/4\/2004
 --
@@ -28,6 +28,7 @@ import GF.Grammar.Grammar (Cat)
 
 import GF.Data.Operations
 import GF.Data.Zipper
+import GF.Infra.Option
 
 import Data.List
 
@@ -39,18 +40,20 @@ import Data.List
 
 
 -- | the main function takes an abstract syntax and returns a list of trees
-generateTrees :: GFCGrammar -> Bool -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
+generateTrees :: Options -> GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
-generateTrees gr ifm cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
+generateTrees opts gr cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
   where
-    gr' = gr2sgr gr
+    gr'  = gr2sgr ats gr
     cat' = prt $ snd cat
-    mt' = maybe Nothing (return . tr2str) mt
+    mt'  = maybe Nothing (return . tr2str) mt
+    ifm  = oElem withMetas opts
+    ats  = getOptInt opts (aOpt "atoms")
 
 ------------------------------------------
 -- translate grammar to simpler form and generated trees back
 
-gr2sgr :: GFCGrammar -> SGrammar
+gr2sgr :: Maybe Int -> GFCGrammar -> SGrammar
-gr2sgr gr = buildTree [(c,rs) | rs@((_,(_,c)):_) <- rules] where
+gr2sgr un gr = buildTree [(c,rs) | rs@((_,(_,c)):_) <- prune rules] where
   rules =
     groupBy (\x y -> scat x == scat y) $
       sortBy (\x y -> compare (scat x) (scat y)) 
@@ -62,6 +65,12 @@ gr2sgr gr = buildTree [(c,rs) | rs@((_,(_,c)):_) <- rules] where
   trCat (m,c) = prt c ---
   scat (_,(_,c)) = c
 
+  prune rs = maybe rs (\n -> map (onlyAtoms n) rs) $ un
+  onlyAtoms n rs = 
+    let (rs1,rs2) = partition atom rs 
+    in take n rs1 ++ rs2
+  atom = null . fst . snd
+
 -- str2tr :: STree -> Exp
 str2tr t = case t of
   SApp (f,ts) -> mkApp (trId f) (map str2tr ts) 

src/HelpFile

@@ -260,6 +260,7 @@ gt, generate_trees: gt Tree?
       -metas   also return trees that include metavariables
   flags:
       -depth   generate to this depth (default 3)
+      -atoms   take this number of atomic rules of each category (default unlimited)
       -alts    take this number of alternatives at each branch (default unlimited)
       -cat     generate in this category
       -lang    use the abstract syntax of this grammar