added timeout to gr -cf

lib/resource-1.0/Makefile

@@ -1,7 +1,7 @@
 all: langs test
 
 test:
-	echo "gr -cat=S -tr -number=11 | l -multi gf" | gf langs.gfcm
+	echo "gr -cat=S -number=11 -cf | tb" | gf langs.gfcm
 langs:
 	echo "s ;; pm | wf langs.gfcm" | gf -src */Lang??*.gf english/LangEng.gf
 

src/GF/Compile/ShellState.hs

@@ -339,7 +339,10 @@ qualifTop :: StateGrammar -> G.QIdent -> G.QIdent
 qualifTop gr (_,c) = (absId gr,c)
 
 stateGrammarOfLang :: ShellState -> Language -> StateGrammar
-stateGrammarOfLang st0 l = StGr {
+stateGrammarOfLang = stateGrammarOfLangOpt True
+
+stateGrammarOfLangOpt :: Bool -> ShellState -> Language -> StateGrammar
+stateGrammarOfLangOpt purg st0 l = StGr {
   absId    = err (const (identC "Abs")) id  $ M.abstractOfConcrete allCan l, ---
   cncId    = l,
   grammar  = allCan,
@@ -352,7 +355,7 @@ stateGrammarOfLang st0 l = StGr {
   loptions = errVal noOptions $ lookupOptionsCan allCan
   }
  where
-   st = purgeShellState $ errVal st0 $ changeMain (Just l) st0
+   st = (if purg then purgeShellState else id) $ errVal st0 $ changeMain (Just l) st0
    allCan = canModules st
 
 grammarOfLang :: ShellState -> Language -> CanonGrammar

src/GF/Probabilistic/Probabilistic.hs

@@ -46,6 +46,9 @@ import Data.List
 import Control.Monad
 import System.Random
 
+-- | this parameter tells how many constructors at most are generated in a tree
+timeout :: Int
+timeout = 99
 
 -- | generate an infinite list of trees, with their probabilities
 generateRandomTreesProb :: Options -> StdGen -> GFCGrammar -> Probs -> Cat -> [Exp]
@@ -159,12 +162,15 @@ randomTrees :: StdGen -> SGrammar -> SCat -> [STree]
 randomTrees gen = genTrees (randomRs (0.0, 1.0) gen)
 
 genTrees :: [Double] -> SGrammar -> SCat -> [STree]
-genTrees ds gr cat = 
-  let (t,k) = genTree ds gr cat 
-  in t : genTrees (drop k ds) gr cat
+genTrees ds0 gr cat = 
+  let (ds,ds2) = splitAt (timeout+1) ds0  -- for time out, else ds
+      (t,k) = genTree ds gr cat      
+  in (if k>timeout then id else (t:))     -- don't accept with metas
+           (genTrees ds2 gr cat)          -- else (drop k ds)
 
 genTree :: [Double] -> SGrammar -> SCat -> (STree,Int)
 genTree rs gr = gett rs where
+  gett [] cat = (SMeta cat,1) -- time-out case
   gett ds "String" = (SString "foo",1)
   gett ds "Int" = (SInt 1978,1)
   gett ds "Float" = (SFloat 3.1415926, 1)

src/GF/UseGrammar/Treebank.hs

@@ -108,7 +108,7 @@ linearize mgr lang =
   untok .
   linTree2string noMark (canModules mgr) (zIdent lang) 
  where
-   sgr   = stateGrammarOfLang mgr (zIdent lang)
+   sgr   = stateGrammarOfLangOpt False mgr (zIdent lang)
    untok = customOrDefault noOptions useUntokenizer customUntokenizer sgr
 
 showTree t = prt_ $ tree2exp t