generation in GFCC

3 files changed, 54 insertions, 8 deletions

diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs
index b2f75ce4b..3c298d26d 100644
--- a/src/GF/Canon/GFCC/DataGFCC.hs
+++ b/src/GF/Canon/GFCC/DataGFCC.hs
@@ -2,6 +2,7 @@ module GF.Canon.GFCC.DataGFCC where
 
 import GF.Canon.GFCC.AbsGFCC
 import Data.Map
+import Data.List
 
 data GFCC = GFCC {
   absname   :: CId ,
@@ -10,7 +11,12 @@ data GFCC = GFCC {
   concretes :: Map CId Concr
   }
 
-type Abstr = Map CId Type
+-- redundant double representation for fast lookup
+data Abstr = Abstr {
+  funs :: Map CId Type, -- find the type of a fun
+  cats :: Map CId [CId] -- find the funs giving a cat
+  }
+
 type Concr = Map CId Term
 
 lookMap :: (Show i, Ord i) => i -> Map i a -> a 
@@ -28,7 +34,8 @@ realize trm = case trm of
   S ss     -> unwords $ Prelude.map realize ss
   K (KS s) -> s
   K (KP s _) -> unwords s ---- prefix choice TODO
-  W s t    -> s ++ " " ++ realize t
+  W s t    -> s ++ realize t
+  FV (t:_) -> realize t
   _ -> "ERROR " ++ show trm ---- debug
 
 linExp :: GFCC -> CId -> Exp -> Term
@@ -74,14 +81,20 @@ compute mcfg lang args = compg [] where
     look = lookLin mcfg lang
     idx xs i = 
       if length xs <= i  ---- debug
-      then error (show xs ++ " !! " ++ show i) else
+      then K (KS ("ERROR" ++ show xs ++ " !! " ++ show i)) else
       xs !! i 
 
 mkGFCC :: Grammar -> GFCC
 mkGFCC (Grm (Hdr a cs) ab@(Abs funs) ccs) = GFCC {
   absname = a,
   cncnames = cs,
-  abstract = fromAscList [(fun,typ)    | Fun fun typ _ <- funs] ,
+  abstract = 
+    let
+      fs = fromAscList [(fun,typ)    | Fun fun typ _ <- funs]
+      cats = sort $ nub [c | Fun f (Typ _ c) _ <- funs]
+      cs = fromAscList 
+             [(cat,[f | Fun f (Typ _ c) _ <- funs, c==cat]) | cat <- cats]
+    in Abstr fs cs,
   concretes = fromAscList [(lang, mkCnc lins) | Cnc lang lins <- ccs]
   }
  where
diff --git a/src/GF/Canon/GFCC/GenGFCC.hs b/src/GF/Canon/GFCC/GenGFCC.hs
new file mode 100644
index 000000000..93c226676
--- /dev/null
+++ b/src/GF/Canon/GFCC/GenGFCC.hs
@@ -0,0 +1,26 @@
+module GF.Canon.GFCC.GenGFCC where
+
+import GF.Canon.GFCC.DataGFCC
+import GF.Canon.GFCC.AbsGFCC
+import GF.Data.Operations
+import qualified Data.Map as M
+
+-- generate an infinite list of trees
+generate :: GFCC -> CId -> [Exp]
+generate gfcc cat = concatMap (\i -> gener i cat) [0..]
+ where
+  gener 0 c = [Tr (AC f) [] | (f, Typ [] _) <- fns c]
+  gener i c = [
+    tr | 
+      (f, Typ cs _) <- fns c,
+      let alts = map (gener (i-1)) cs,
+      ts <- combinations alts,
+      let tr = Tr (AC f) ts,
+      depth tr >= i
+    ]
+  fns cat = 
+    let fs = maybe [] id $ M.lookup cat $ cats $ abstract gfcc
+    in [(f,ty) | f <- fs, Just ty <- [M.lookup f $ funs $ abstract gfcc]]
+  depth tr = case tr of
+    Tr _ [] -> 1
+    Tr _ ts -> maximum (map depth ts) + 1
diff --git a/src/GF/Canon/GFCC/RunGFCC.hs b/src/GF/Canon/GFCC/RunGFCC.hs
index be2ed3358..943697dd4 100644
--- a/src/GF/Canon/GFCC/RunGFCC.hs
+++ b/src/GF/Canon/GFCC/RunGFCC.hs
@@ -1,5 +1,6 @@
 module Main where
 
+import GF.Canon.GFCC.GenGFCC
 import GF.Canon.GFCC.DataGFCC
 import GF.Canon.GFCC.AbsGFCC
 import GF.Canon.GFCC.ParGFCC
@@ -24,12 +25,18 @@ loop grammar = do
     loop grammar
 
 treat :: GFCC -> String -> IO ()
-treat grammar s = do 
-  let t = readExp s
-  putStrLn $ printTree $ linExp grammar lang t 
-  putStrLn $ linearize grammar lang t
+treat grammar s = case words s of
+  "gt":cat:n:_ -> do
+    mapM_ prlin $ take (read n) $ generate grammar (CId cat)
+  _ -> lin $ readExp s
  where
   lang = head $ cncnames grammar
+  lin t = do
+    putStrLn $ printTree $ linExp grammar lang t 
+    putStrLn $ linearize grammar lang t
+  prlin t = do
+    putStrLn $ printTree t
+    lin t
 
 --- should be in an API