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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
module TransBig where
import AbsLisp
import PrintLisp
import Char
abstrgf = "BigLexEngAbs.gf"
concrgf = "BigLexEng.gf"
transTree :: Prog -> IO ()
transTree (Pro ts) = do
writeFile abstrgf "abstract BigLexEngAbs = Cat **{\n"
writeFile concrgf
"concrete BigLexEng of BigLexEngAbs = CatEng ** open ParadigmsEng, IrregEng in {\n"
mapM_ transRule ts
appendFile abstrgf "}\n"
addOpers
appendFile concrgf "}\n"
transRule :: Exp -> IO ()
transRule e = case e of
App (At f : _ : cat : _) | not (discardCat cat) -> catRule (hyph f) cat
_ -> notConsidered $ "--! " ++ printTree e
where
hyph (Id f) = Id (map unhyph f)
unhyph '-' = '_'
unhyph c = c
discardCat (App cs) = any (flip elem cs) discarded where
discarded = [
App [At (Id "AUX"),Plus],
App [At (Id "PAST"),Plus],
App [At (Id "QUA"),Plus],
App [At (Id "VFORM"),At (Id "EN")],
App [At (Id "AFORM"),At (Id "ER")],
App [At (Id "AFORM"),At (Id "EST")]
]
discardCat _ = False
catRule :: Id -> Exp -> IO ()
catRule (Id f) e = case cleanCat e of
App (App [At (Id "V"), Minus] : App [At (Id "N"), Plus] : more) -> case more of
[App [At (Id "SUBCAT"),sub]] ->
let prep = prepSub sub in
putRule (f ++ "_N2" ++ prep) "N2" "prepN2" [show f, show prep]
[App [At (Id "PLU"),Minus],App [At (Id "SUBCAT"),sub]] ->
let prep = prepSub sub in
putRule (f ++ "_N2" ++ prep) "N2" "irregN2" [show f, show f, show prep]
[App [At (Id "PLU"),Minus]] ->
putRule (f ++ "_N") "N" "irregN" [show f, show f] --- could find the forms
[App [At (Id "PLU"),_]] ->
notConsidered $ "--! " ++ f ++ " " ++ printTree e
(App [At (Id "PRO"),Plus]:_) ->
notConsidered $ "--! " ++ f ++ " " ++ printTree e
[App [At (Id "COUNT"),Minus]] ->
putRule (f ++ "_N") "N" "massN" [show f]
[App [At (Id "PN"),Plus]] ->
putRule (f ++ "_PN") "PN" "regPN" [show f]
[] ->
putRule (f ++ "_N") "N" "regN" [show f]
_ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
App (App [At (Id "V"), Plus] : App [At (Id "N"), Plus] : more) -> case more of
(App [At (Id "ADV"), Plus]:_) ->
putRule (f ++ "_Adv") "Adv" "mkAdv" [show f]
[App [At (Id "SUBCAT"),sub]] ->
let prep = prepSub sub in
putRule (f ++ "_A2" ++ prep) "A2" "regA2" [show f,show prep]
[App [At (Id "AFORM"),At (Id "NONE")],App [At (Id "SUBCAT"),sub]] ->
let prep = prepSub sub in
putRule (f ++ "_A2" ++ prep) "A2" "longA2" [show f,show prep]
[App [At (Id "SUBCAT"),sub],App [At (Id "AFORM"),At (Id "NONE")]] ->
let prep = prepSub sub in
putRule (f ++ "_A2" ++ prep) "A2" "longA2" [show f,show prep]
(App [At (Id "AFORM"),At (Id "NONE")]:_) ->
putRule (f ++ "_A") "A" "longA" [show f]
[] ->
putRule (f ++ "_A") "A" "regA" [show f]
_ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
App (App [At (Id "V"), Plus] : App [At (Id "N"), Minus] : more) -> case more of
App [At (Id "SUBCAT"),At (Id "NP_NP")]:form ->
putRule (f ++ "_V3") "V3" "dirdirV3" [verbForm form f]
App [At (Id "SUBCAT"),At (Id ('N':'P':'_':sub))]:form ->
let prep = map toLower (drop 2 sub) in
putRule (f ++ "_V3" ++ prep) "V3" "dirprepV3" [verbForm form f, show prep]
App [At (Id "SUBCAT"),At (Id "SFIN")]:form ->
putRule (f ++ "_VS") "VS" "mkVS" [verbForm form f]
App [At (Id "SUBCAT"),At (Id "SE1")]:form ->
putRule (f ++ "_VV") "VV" "mkVV" [verbForm form f]
App [At (Id "SUBCAT"),sub]:form ->
let prep = prepSub sub in
putRule (f ++ "_V2" ++ prep) "V2" "prepV2" [verbForm form f, show prep]
form | length form < 2 ->
putRule (f ++ "_V") "V" "useV" [verbForm form f]
_ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
App (App [At (Id "V"), Minus] : App [At (Id "N"), Minus] : more) -> case more of
[App [At (Id "SUBCAT"), At (Id "BARE_S")]] ->
putRule (f ++ "_Subj") "Subj" "mkSubj" [show f]
[App [At (Id "SUBCAT"), At (Id "NP")]] ->
putRule (f ++ "_Prep") "Prep" "mkPrep" [show f]
App [At (Id "PRO"), Plus] : _ ->
putRule (f ++ "_Adv") "Adv" "proAdv" [show f]
_ -> putStrLn $ "---- " ++ f ++ " " ++ printTree e
App (App [At (Id "PRO"), Plus] :
App [At (Id "V"), Minus] : App [At (Id "N"), Minus] :_) ->
putRule (f ++ "_Adv") "Adv" "proAdv" [show f]
_ -> notConsidered $ "--! " ++ f ++ " " ++ printTree e
cleanCat (App es) = App $ filter (not . irrelevant) es where
irrelevant c = elem c [
App [At (Id "SUBCAT"), At (Id "NULL")],
App [At (Id "AT"), Minus], --- ?
App [At (Id "LAT"), Minus],
App [At (Id "LAT"), Plus]
]
cleanCat c = c
notConsidered r = return () --- putStrLn
putRule :: String -> String -> String -> [String] -> IO ()
putRule fun cat oper args = do
appendFile abstrgf $ unwords ["fun",fun,":",cat,";\n"]
appendFile concrgf $ unwords $ ["lin",fun,"=",oper] ++ args ++ [";\n"]
prepSub :: Exp -> String
prepSub s = case s of
At (Id ('P':'P':cs)) -> map toLower cs
_ -> ""
verbForm form f
| elem (App [At (Id "REG"),Minus]) form = "IrregEng." ++ f ++ "_V"
| otherwise = "(regV " ++ show f ++ ")"
addOpers = mapM_ (appendFile concrgf) [
"oper proAdv : Str -> Adv = \\s -> mkAdv s ;\n",
"oper useV : V -> V = \\v -> v ;\n",
"oper massN : Str -> N = \\s -> regN s ;\n",
"longA : Str -> A = \\s -> compoundADeg (regA s) ;\n",
"mkSubj : Str -> Subj = \\s -> {s = s ; lock_Subj = <>} ;\n",
"irregN : Str -> Str -> N = \x,y -> mk2N x y ;\",
"irregN2 : Str -> Str -> Str -> N2 = \x,y,p -> mkN2 (irregN x y) (mkPrep p) ;\n",
"longA2 : Str -> Str -> A2 = \s,p -> mkA2 (compoundADeg (regA s)) (mkPrep p) ;\n",
"regA2 : Str -> Str -> A2 = \s,p -> mkA2 (regA s) (mkPrep p) ;\n",
"prepV2 : V -> Str -> V2 = \s,p -> mkV2 s (mkPrep p) ;\n",
"prepN2 : Str -> Str -> N2 = \s,p -> mkN2 (regN s) (mkPrep p) ;\n",
"dirprepV3 : V -> Str -> V3 = \s,p -> dirV3 s (mkPrep p) ;\n"
]
|
