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
|
module Main where
import System
import Char
-- generate Finnish lexicon implementations with 1 or more
-- characteristic arguments
-- usage: runghc MkLex.hs 3 cat name
main = do
i:cat:tgt:_ <- getArgs
let src = "correct-" ++ tgt ++ ".txt"
ss <- readFile src >>= return . filter (not . (all isSpace)) . lines
initiate tgt cat i
mapM_ (mkLex cat (read i) . uncurry (++)) (zip nums ss)
putStrLn "}"
initiate tgt cat i = mapM_ putStrLn [
"--# -path=.:alltenses",
"",
header i,
""
]
where
header i = case i of
"0" -> unlines [
"abstract " ++ tgt ++ "Abs = Cat ** {",
"fun testN : N -> Utt ;",
"fun testV : V -> Utt ;"
]
_ -> unlines [
"concrete " ++ tgt ++ i ++
" of " ++ tgt ++
"Abs = CatFin ** open Nominal, Verbal, ResFin, Prelude in {",
"",
"lin testN = showN ;",
"lin testV = showV ;"
]
nums = map prt [10001 ..] where
---- prt i = (if i < 10 then "0" else "") ++ show i ++ ". "
prt i = show i ++ ". "
-- W is the flag for mixed-class word lists
mkLex "W" 0 line = case words line of
num:cat:sana:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "fun " ++ nimi ++ "_" ++ cat ++ " : " ++ cat ++ " ;"
_ -> return ()
mkLex "W" 1 line = case words line of
num:cat:sanat@(sana:_) -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_" ++ cat ++ " = mk" ++ cat ++ " " ++
unwords (map prQuoted sanat) ++" ;"
_ -> return ()
mkLex cat 0 line = case words line of
num:sana:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "fun " ++ nimi ++ "_" ++ cat ++ " : " ++ cat ++ " ;"
_ -> return ()
mkLex cat 1 line = case words line of
num:sana:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_" ++ cat ++ " = mk" ++ cat ++ " \"" ++ sana ++ "\" ;"
_ -> return ()
mkLex "V" _ line = case words line of
num:sana:_:_:_:_:_:_:sanan:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_V = mkV \"" ++ sana ++ "\" \"" ++ sanan ++ "\" ;"
_ -> return ()
mkLex "N" 2 line = case words line of
-- num:sana:sanan:_ -> do
num:sana:_:_:_:_:_:sanan:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++ "\" ;"
_ -> return ()
mkLex "N" 3 line = case words line of
---- num:sana:sanan:sanoja:_ -> do
num:sana:sanan:_:_:_:_:sanoja:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++ "\" \"" ++ sanoja ++ "\" ;"
_ -> return ()
mkLex "N" 4 line = case words line of
num:sana:sanan:sanaa:_:_:_:sanoja:_ -> do
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "lin " ++ nimi ++
"_N = mkN \"" ++ sana ++ "\" \"" ++ sanan ++
"\" \"" ++ sanoja ++ "\" \"" ++ sanaa ++ "\" ;"
_ -> return ()
-- to initiate from a noun list that has compounds
mkLex "N" 11 line = case words line of
_:"--":_ -> return ()
num:sana0:_ -> do
let sana = uncompound sana0
let nimi = "n" ++ init num ++ "_" ++ sana
putStrLn $ "fun " ++ nimi ++ "_N : N ;"
putStrLn $ "lin " ++ nimi ++ "_N = mkN \"" ++ sana ++ "\" ;"
_ -> return ()
prQuoted s = concat ["\"",s,"\""]
-- from sora+tie to tie
uncompound = reverse . takeWhile (/= '+') . reverse
|
