GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/UseGrammar/Generate.hs

@@ -0,0 +1,116 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Generate
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/10/12 12:38:30 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.16 $
+--
+-- 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.
+-----------------------------------------------------------------------------
+
+module GF.UseGrammar.Generate (generateTrees,generateAll) where
+
+import GF.Canon.GFC
+import GF.Grammar.LookAbs
+import GF.Grammar.PrGrammar
+import GF.Grammar.Macros
+import GF.Grammar.Values
+import GF.Grammar.Grammar (Cat)
+import GF.Grammar.SGrammar
+import GF.Data.Operations
+import GF.Data.Zipper
+import GF.Infra.Option
+import Data.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 :: 
+  Options -> GFCGrammar -> Cat -> Int -> Maybe Int -> Maybe Tree -> [Exp]
+generateTrees opts gr cat n mn mt = map str2tr $ generate gr' opts cat' n mn mt'
+  where
+    gr'  = gr2sgr opts emptyProbs gr
+    cat' = prt $ snd cat
+    mt'  = maybe Nothing (return . tr2str) mt
+---    ifm  = oElem withMetas opts
+    ifm  = oElem showOld opts
+
+generateAll :: Options -> (Exp -> IO ()) -> GFCGrammar -> Cat -> IO ()
+generateAll opts io gr cat = mapM_ (io . str2tr) $ num $ gen cat'
+  where
+    num  = optIntOrAll opts flagNumber
+    gr'  = gr2sgr opts emptyProbs gr
+    cat' = prt $ snd cat
+    gen c = generate gr' opts c 10 Nothing Nothing
+
+
+
+------------------------------------------
+-- do the main thing with a simpler data structure
+-- the first Int gives tree depth, the second constrains subtrees
+-- chosen for each branch. A small number, such as 2, is a good choice
+-- if the depth is large (more than 3)
+-- If a tree is given as argument, generation concerns its metavariables.
+
+generate :: SGrammar -> Options -> SCat -> Int -> Maybe Int -> Maybe STree -> [STree]
+generate gr opts cat i mn mt = case mt of
+  Nothing -> gen opts cat
+  Just t  -> genM t
+ where
+--- now use ifm to choose between two algorithms
+  gen opts cat 
+   | oElem (iOpt "mem") opts   = concat $ errVal [] $ lookupTree id cat $ allTrees -- -old
+   | oElem (iOpt "nonub") opts =       concatMap (\i -> gener i cat) [0..i-1] -- some duplicates
+   | otherwise                 = nub $ concatMap (\i -> gener i cat) [0..i-1] -- new
+
+  gener 0 c = [SApp (f, []) | (f,([],_)) <- funs c]
+  gener i c = [
+    tr | 
+      (f,(cs,_)) <- funs c,
+      let alts = map (gener (i-1)) cs,
+      ts <- combinations alts,
+      let tr = SApp (f, ts)
+--      depth tr >= i -- NO!
+    ]
+
+  allTrees = genAll i
+
+  -- dynamic generation
+  genAll :: Int -> BinTree SCat [[STree]]
+  genAll i = iter i genNext (mapTree (\ (c,_) -> (c,[[]])) gr)
+
+  iter 0 f tr = tr
+  iter n f tr = iter (n-1) f (f tr)
+
+  genNext tr = mapTree (genNew tr) tr
+
+  genNew tr (cat,ts) = let size = length ts in
+    (cat, [SApp (f, xs) | 
+            (f,(cs,_)) <- funs cat, 
+            xs <- combinations (map look cs),
+            let fxs = SApp (f, xs),
+            depth fxs == size]
+         : ts)
+   where
+     look c = concat $ errVal [] $ lookupTree id c tr
+
+  funs cat = maybe id take mn $ errVal [] $ lookupTree id cat gr
+
+  genM t = case t of
+    SApp (f,ts) -> [SApp (f,ts') | ts' <- combinations (map genM ts)]
+    SMeta k     -> gen opts k 
+    _ -> [t]