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