1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
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) ;
-}
|
