diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/GF/Canon/GFCC/DataGFCC.hs | 11 | ||||
| -rw-r--r-- | src/GF/Canon/GFCC/GenGFCC.hs | 35 | ||||
| -rw-r--r-- | src/GF/Canon/GFCC/RunGFCC.hs | 19 |
3 files changed, 56 insertions, 9 deletions
diff --git a/src/GF/Canon/GFCC/DataGFCC.hs b/src/GF/Canon/GFCC/DataGFCC.hs index 3c298d26d..0c38a3826 100644 --- a/src/GF/Canon/GFCC/DataGFCC.hs +++ b/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 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]] diff --git a/src/GF/Canon/GFCC/RunGFCC.hs b/src/GF/Canon/GFCC/RunGFCC.hs index 943697dd4..704b6ced8 100644 --- a/src/GF/Canon/GFCC/RunGFCC.hs +++ b/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) - _ -> lin $ readExp s + mapM_ prlins $ take (read n) $ generate grammar (CId cat) + "gr":cat:n:_ -> do + gen <- newStdGen + mapM_ prlins $ take (read n) $ generateRandom gen grammar (CId cat) + _ -> lins $ readExp s where - lang = head $ cncnames grammar - lin t = do - putStrLn $ printTree $ linExp grammar lang t + lins t = mapM_ (lin t) $ cncnames grammar + lin t lang = do + -- 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 |