From dec0d1b24b54e7556a5de580a016a0a2e1ed5049 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Wed, 8 Feb 2006 22:43:07 +0000
Subject: [PATCH] added timeout to gr -cf

---
 lib/resource-1.0/Makefile             |  2 +-
 src/GF/Compile/ShellState.hs          |  7 +++++--
 src/GF/Probabilistic/Probabilistic.hs | 12 +++++++++---
 src/GF/UseGrammar/Treebank.hs         |  2 +-
 4 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/lib/resource-1.0/Makefile b/lib/resource-1.0/Makefile
index bb3a3516c..f19c428f6 100644
--- a/lib/resource-1.0/Makefile
+++ b/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
 
diff --git a/src/GF/Compile/ShellState.hs b/src/GF/Compile/ShellState.hs
index 6c281a926..40e91d9ab 100644
--- a/src/GF/Compile/ShellState.hs
+++ b/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
diff --git a/src/GF/Probabilistic/Probabilistic.hs b/src/GF/Probabilistic/Probabilistic.hs
index c9bc1b8b2..9798892e4 100644
--- a/src/GF/Probabilistic/Probabilistic.hs
+++ b/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)
diff --git a/src/GF/UseGrammar/Treebank.hs b/src/GF/UseGrammar/Treebank.hs
index 99f0da281..606d72266 100644
--- a/src/GF/UseGrammar/Treebank.hs
+++ b/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