mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-11 13:59:31 -06:00
92 lines
2.7 KiB
Haskell
92 lines
2.7 KiB
Haskell
module Flatten where
|
|
|
|
import Data.List
|
|
-- import GF.Data.Operations
|
|
|
|
-- (AR 15/3/2006)
|
|
--
|
|
-- A method for flattening grammars: create many flat rules instead of
|
|
-- a few deep ones. This is generally better for parsins.
|
|
-- The rules are obtained as follows:
|
|
-- 1. write a config file tellinq which constants are variables: format 'c : C'
|
|
-- 2. generate a list of trees with their types: format 't : T'
|
|
-- 3. for each such tree, form a fun rule 'fun fui : X -> Y -> T' and a lin
|
|
-- rule 'lin fui x y = t' where x:X,y:Y is the list of variables in t, as
|
|
-- found in the config file.
|
|
-- 4. You can go on and produce def or transfer rules similar to the lin rules
|
|
-- except for the keyword.
|
|
--
|
|
-- So far this module is used outside gf. You can e.g. generate a list of
|
|
-- trees by 'gt', write it in a file, and then in ghci call
|
|
-- flattenGrammar <Config> <Trees> <OutFile>
|
|
|
|
type Ident = String ---
|
|
type Term = String ---
|
|
type Rule = String ---
|
|
|
|
type Config = [(Ident,Ident)]
|
|
|
|
flattenGrammar :: FilePath -> FilePath -> FilePath -> IO ()
|
|
flattenGrammar conff tf out = do
|
|
conf <- readFile conff >>= return . lines
|
|
ts <- readFile tf >>= return . lines
|
|
writeFile out $ mkFlatten conf ts
|
|
|
|
mkFlatten :: [String] -> [String] -> String
|
|
mkFlatten conff = unlines . concatMap getOne . zip [1..] where
|
|
getOne (k,t) = let (x,y) = mkRules conf ("fu" ++ show k) t in [x,y]
|
|
conf = getConfig conff
|
|
|
|
mkRules :: Config -> Ident -> Term -> (Rule,Rule)
|
|
mkRules conf f t = (fun f ty, lin f (takeWhile (/=':') t)) where
|
|
args = mkArgs conf ts
|
|
ty = concat [a ++ " -> " | a <- map snd args] ++ val
|
|
(ts,val) = let tt = lexTerm t in (init tt,last tt)
|
|
--- f = mkIdent t
|
|
fun c a = unwords [" fun", c, ":",a,";"]
|
|
lin c a = unwords $ [" lin", c] ++ map fst args ++ ["=",a,";"]
|
|
|
|
mkArgs :: Config -> [Ident] -> [(Ident,Ident)]
|
|
mkArgs conf ids = [(x,ty) | x <- ids, Just ty <- [lookup x conf]]
|
|
|
|
mkIdent :: Term -> Ident
|
|
mkIdent = map mkChar where
|
|
mkChar c = case c of
|
|
'(' -> '6'
|
|
')' -> '9'
|
|
' ' -> '_'
|
|
_ -> c
|
|
|
|
-- to get just the identifiers
|
|
lexTerm :: String -> [String]
|
|
lexTerm ss = case lex ss of
|
|
[([c],ws)] | isSpec c -> lexTerm ws
|
|
[(w@(_:_),ws)] -> w : lexTerm ws
|
|
_ -> []
|
|
where
|
|
isSpec = flip elem "();:"
|
|
|
|
|
|
getConfig :: [String] -> Config
|
|
getConfig = map getOne . filter (not . null) where
|
|
getOne line = case lexTerm line of
|
|
v:c:_ -> (v,c)
|
|
|
|
ex = putStrLn fs where
|
|
fs =
|
|
mkFlatten
|
|
["man_N : N",
|
|
"sleep_V : V"
|
|
]
|
|
["PredVP (DefSg man_N) (UseV sleep_V) : Cl",
|
|
"PredVP (DefPl man_N) (UseV sleep_V) : Cl"
|
|
]
|
|
|
|
{-
|
|
-- result of ex
|
|
|
|
fun fu1 : N -> V -> Cl ;
|
|
lin fu1 man_N sleep_V = PredVP (DefSg man_N) (UseV sleep_V) ;
|
|
fun fu2 : N -> V -> Cl ;
|
|
lin fu2 man_N sleep_V = PredVP (DefPl man_N) (UseV sleep_V) ;
|
|
-} |