gt -atoms

6 files changed, 36 insertions, 25 deletions

diff --git a/src/GF/API.hs b/src/GF/API.hs
index d9c9afe49..b0953e083 100644
--- a/src/GF/API.hs
+++ b/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
diff --git a/src/GF/Grammar/PatternMatch.hs b/src/GF/Grammar/PatternMatch.hs
index 79969c2f3..cbf77063d 100644
--- a/src/GF/Grammar/PatternMatch.hs
+++ b/src/GF/Grammar/PatternMatch.hs
@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/04/21 16:22:26 $ 
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
+-- > CVS $Date: 2005/10/12 12:38:29 $ 
+-- > CVS $Author: aarne $
+-- > 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)
 
diff --git a/src/GF/Shell/HelpFile.hs b/src/GF/Shell/HelpFile.hs
index b6c1c9a5e..b139ba647 100644
--- a/src/GF/Shell/HelpFile.hs
+++ b/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" ++
diff --git a/src/GF/Shell/ShellCommands.hs b/src/GF/Shell/ShellCommands.hs
index b41dc0b69..08996fb5c 100644
--- a/src/GF/Shell/ShellCommands.hs
+++ b/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"
diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs
index 8db581d18..ee68c9b3c 100644
--- a/src/GF/UseGrammar/Custom.hs
+++ b/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)))
diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs
index c19435410..941695f8b 100644
--- a/src/GF/UseGrammar/Generate.hs
+++ b/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 gr ifm cat n mn mt = map str2tr $ generate gr' ifm cat' n mn mt'
+generateTrees :: Options -> GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
+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 gr = buildTree [(c,rs) | rs@((_,(_,c)):_) <- rules] where
+gr2sgr :: Maybe Int -> GFCGrammar -> SGrammar
+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)