random generation in GFCC

src/GF/Canon/GFCC/DataGFCC.hs

@@ -17,6 +17,14 @@ data Abstr = Abstr {
   cats :: Map CId [CId] -- find the funs giving a cat
   }
 
+statGFCC :: GFCC -> String
+statGFCC gfcc = unlines [
+  "Abstract\t" ++ pr (absname gfcc), 
+  "Concretes\t" ++ unwords (Prelude.map pr (cncnames gfcc)), 
+  "Categories\t" ++ unwords (Prelude.map pr (keys (cats (abstract gfcc)))) 
+  ]
+ where pr (CId s) = s
+
 type Concr = Map CId Term
 
 lookMap :: (Show i, Ord i) => i -> Map i a -> a 
@@ -55,6 +63,7 @@ kks = K . KS
 compute :: GFCC -> CId -> [Term] -> Term -> Term
 compute mcfg lang args = compg [] where
   compg g trm = case trm of
+    P r (FV ts) -> FV $ Prelude.map (comp . P r) ts
 
     -- for the abstraction optimization
     P (A x t) p -> compg ((x,comp p):g) t 
@@ -73,7 +82,7 @@ compute mcfg lang args = compg [] where
     R ts  -> R $ Prelude.map comp ts
     V i   -> idx args (fromInteger i)  -- already computed
     S ts  -> S (Prelude.map comp ts)
-    F c   -> comp $ look c  -- global const: not yet comp'd (if contains argvar)
+    F c   -> comp $ look c  -- global const: not comp'd (if contains argvar)
     FV ts -> FV $ Prelude.map comp ts
     _ -> trm
    where

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]]

src/GF/Canon/GFCC/RunGFCC.hs

@@ -7,6 +7,7 @@ import GF.Canon.GFCC.ParGFCC
 import GF.Canon.GFCC.PrintGFCC
 import GF.Data.Operations
 import Data.Map
+import System.Random (newStdGen)
 import System
 
 -- Simple translation application built on GFCC. AR 7/9/2006
@@ -15,6 +16,7 @@ main :: IO ()
 main = do
   file  <- getLine ----getArgs
   grammar <- file2gfcc file
+  putStrLn $ statGFCC grammar
   loop grammar
 
 loop :: GFCC -> IO ()
@@ -27,16 +29,19 @@ loop grammar = do
 treat :: GFCC -> String -> IO ()
 treat grammar s = case words s of
   "gt":cat:n:_ -> do
-    mapM_ prlin $ take (read n) $ generate grammar (CId cat)
+    mapM_ prlins $ take (read n) $ generate grammar (CId cat)
-  _ -> lin $ readExp s
+  "gr":cat:n:_ -> do
+    gen <- newStdGen
+    mapM_ prlins $ take (read n) $ generateRandom gen grammar (CId cat)
+  _ -> lins $ readExp s
  where
-  lang = head $ cncnames grammar
+  lins t = mapM_ (lin t) $ cncnames grammar
-  lin t = do
+  lin t lang = do
-    putStrLn $ printTree $ linExp grammar lang t 
+    -- putStrLn $ printTree $ linExp grammar lang t 
     putStrLn $ linearize grammar lang t
-  prlin t = do
+  prlins t = do
     putStrLn $ printTree t
-    lin t
+    lins t
 
 --- should be in an API