random generation in GFCC

1 files changed, 34 insertions, 1 deletions

diff --git a/src/GF/Canon/GFCC/GenGFCC.hs b/src/GF/Canon/GFCC/GenGFCC.hs
index 93c226676..533867d3f 100644
--- a/src/GF/Canon/GFCC/GenGFCC.hs
+++ b/src/GF/Canon/GFCC/GenGFCC.hs
@@ -4,8 +4,9 @@ import GF.Canon.GFCC.DataGFCC
 import GF.Canon.GFCC.AbsGFCC
 import GF.Data.Operations
 import qualified Data.Map as M
+import System.Random
 
--- generate an infinite list of trees
+-- generate an infinite list of trees exhaustively
 generate :: GFCC -> CId -> [Exp]
 generate gfcc cat = concatMap (\i -> gener i cat) [0..]
  where
@@ -24,3 +25,35 @@ generate gfcc cat = concatMap (\i -> gener i cat) [0..]
   depth tr = case tr of
     Tr _ [] -> 1
     Tr _ ts -> maximum (map depth ts) + 1
+
+-- generate an infinite list of trees randomly
+generateRandom :: StdGen -> GFCC -> CId -> [Exp]
+generateRandom gen gfcc cat = genTrees (randomRs (0.0, 1.0) gen) cat where
+
+  timeout = 47 -- give up
+
+  genTrees ds0 cat = 
+    let (ds,ds2) = splitAt (timeout+1) ds0  -- for time out, else ds
+        (t,k) = genTree ds cat      
+    in (if k>timeout then id else (t:))
+                (genTrees ds2 cat)          -- else (drop k ds)
+
+  genTree rs = gett rs where
+    gett ds cat = case fns cat of
+      fs -> let 
+          d:ds2    = ds
+          (f,args) = getf d fs
+          (ts,k)   = getts ds2 args
+        in (Tr (AC f) ts, k+1)
+    getf d fs =  fs !! floor (d * fromIntegral (length fs))
+    getts ds cats = case cats of
+      c:cs -> let 
+          (t, k)  = gett ds c
+          (ts,ks) = getts (drop k ds) cs 
+        in (t:ts, k + ks)
+      _ -> ([],0)
+
+    fns cat = 
+      let fs = maybe [] id $ M.lookup cat $ cats $ abstract gfcc
+      in [(f,cs) | f <- fs, 
+            Just (Typ cs _) <- [M.lookup f $ funs $ abstract gfcc]]