generation command gt n

4 files changed, 105 insertions, 3 deletions

diff --git a/src/GF/API.hs b/src/GF/API.hs
index 7c708c933..15cccde51 100644
--- a/src/GF/API.hs
+++ b/src/GF/API.hs
@@ -23,6 +23,7 @@ import qualified Macros as M
 import TypeCheck
 import CMacros
 import Transfer
+import qualified Generate as Gen
 
 import Option
 import Custom
@@ -156,10 +157,21 @@ randomTreesIO opts gr n = do
    g   = grammar gr
    mx  = optIntOrN opts flagDepth 41
 
+generateTrees :: Options -> GFGrammar -> Int -> [Tree]
+generateTrees opts gr n =
+  optIntOrAll opts flagNumber  
+    [tr | t <- Gen.generateTrees gr' cat n, Ok tr <- [mkTr t]]
+  where
+    mkTr = annotate gr' . qualifTerm (absId gr) 
+    gr' = grammar gr
+    cat = firstAbsCat opts gr
+
+
 speechGenerate :: Options -> String -> IO ()
 speechGenerate opts str = do
   let lan = maybe "" (" --language" +++) $ getOptVal opts speechLanguage
-  system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan)
+  system ("flite" +++ "\" " ++ str ++ "\"")
+---  system ("echo" +++ "\"" ++ str ++ "\" | festival --tts" ++ lan)
   return ()
 
 optLinearizeTreeVal :: Options -> GFGrammar -> Tree -> String
diff --git a/src/GF/Shell.hs b/src/GF/Shell.hs
index 2fdf6dabd..8a0152e10 100644
--- a/src/GF/Shell.hs
+++ b/src/GF/Shell.hs
@@ -54,6 +54,7 @@ data Command =
  | CParse
  | CTranslate Language Language
  | CGenerateRandom Int
+ | CGenerateTrees Int
  | CPutTerm
  | CWrapTerm Ident
  | CMorphoAnalyse
@@ -187,6 +188,8 @@ execC co@(comm, opts0) sa@((st,(h,_)),a) = case comm of
       _ -> do
         ts <- randomTreesIO opts gro (optIntOrN opts flagNumber n)
         returnArg (ATrms ts) sa
+  CGenerateTrees n -> returnArg (ATrms $ generateTrees opts gro n) sa
+
 
   CPutTerm -> changeArg (opTT2CommandArg (optTermCommand opts gro) . s2t) sa
 -----  CWrapTerm f -> changeArg (opTT2CommandArg (return . wrapByFun opts gro f)) sa
diff --git a/src/GF/Shell/PShell.hs b/src/GF/Shell/PShell.hs
index 9a1185032..b4cd335a7 100644
--- a/src/GF/Shell/PShell.hs
+++ b/src/GF/Shell/PShell.hs
@@ -71,8 +71,8 @@ pCommand ws = case ws of
   "p"  : s      -> aString CParse s
   "t"  : i:o: s -> aString (CTranslate (language i) (language o)) s
   "gr" : []     -> aUnit   (CGenerateRandom 1)
-  "gt" : t      -> aTerm   (CGenerateRandom 1) t
----  "gr" : n : [] -> aUnit   (CGenerateRandom (readIntArg n)) -- deprecated 12/5/2001
+  "gr" : t      -> aTerm   (CGenerateRandom 1) t
+  "gt" : n : [] -> aUnit   (CGenerateTrees (readIntArg n))
   "pt" : s      -> aTerm   CPutTerm s
 -----  "wt" : f : s  -> aTerm   (CWrapTerm (string2id f)) s
   "ma" : s      -> aString CMorphoAnalyse s
diff --git a/src/GF/UseGrammar/Generate.hs b/src/GF/UseGrammar/Generate.hs
new file mode 100644
index 000000000..c39153308
--- /dev/null
+++ b/src/GF/UseGrammar/Generate.hs
@@ -0,0 +1,87 @@
+module Generate where
+
+import GFC
+import LookAbs
+import PrGrammar
+import Macros
+
+import Operations
+import List
+
+-- Generate all trees of given category and depth. AR 30/4/2004
+-- (c) Aarne Ranta 2004 under GNU GPL
+--
+-- Purpose: to generate corpora. We use simple types and don't
+-- guarantee the correctness of bindings/dependences.
+
+
+-- the main function takes an abstract syntax and returns a list of trees
+
+-- generateTrees :: GFCGrammar -> Cat -> Int -> [Exp]
+generateTrees gr cat n = map str2tr $ generate gr' cat' n where
+  gr' = gr2sgr gr
+  cat' = prt $ snd cat
+
+------------------------------------------
+-- translate grammar to simpler form and generated trees back
+
+gr2sgr :: GFCGrammar -> SGrammar
+gr2sgr gr = [(trId f, ty') | (f,ty) <- funRulesOf gr, ty' <- trTy ty] where
+  trId = prt . snd
+  trTy ty = case catSkeleton ty of
+    Ok (mcs,mc) -> [(map trCat mcs, trCat mc)]
+    _ -> []
+  trCat (m,c) = prt c ---
+
+-- str2tr :: STree -> Exp
+str2tr (STr (f,ts)) = mkApp (trId f) (map str2tr ts) where
+  trId = cn . zIdent
+
+------------------------------------------
+-- do the main thing with a simpler data structure
+
+generate :: SGrammar -> SCat -> Int -> [STree]
+generate gr cat i = [t | (c,t) <- gen 0 [], c == cat] 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)
+
+  args :: [SCat] -> [(SCat,STree)] -> [[STree]]
+  args cs cts = combinations [[t | (k,t) <- cts, k == c] | c <- cs]
+
+
+type SGrammar = [SRule]
+type SIdent = String
+type SRule = (SFun,SType)
+type SType = ([SCat],SCat)
+type SCat = SIdent
+type SFun = SIdent
+
+newtype STree = STr (SFun,[STree]) 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)
+
+pSRule :: String -> SRule
+pSRule s = case words s of
+  f : _ : cs -> (f,(init cs', last cs')) 
+    where cs' = [cs !! i | i <- [0,2..length cs - 1]]
+  _ -> error $ "not a rule" +++ s
+
+exSgr = map pSRule [
+   "Pred   : NP -> VP -> S"
+  ,"Compl  : TV -> NP -> VP" 
+  ,"PredVV : VV -> VP -> VP"
+  ,"DefCN  : CN -> NP"
+  ,"ModCN  : AP -> CN -> CN" 
+  ,"john   : NP"
+  ,"walk   : VP"
+  ,"love   : TV"
+  ,"try    : VV"
+  ,"girl   : CN"
+  ,"big    : AP"
+  ]