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
|
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
{-
**************************************************************
* Filename : Trie.hs *
* Author : Markus Forsberg *
* markus@cs.chalmers.se *
* Last Modified : 17 December, 2001 *
* Lines : 51 *
**************************************************************
-}
module Trie (
tcompile,
collapse,
Trie,
trieLookup,
decompose,
Attr,
atW, atP, atWP
) where
import Map
--- data Attr = W | P | WP deriving Eq
type Attr = Int
atW, atP, atWP :: Attr
(atW,atP,atWP) = (0,1,2)
newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)])
newtype Trie = Trie (Map Char Trie, [(Attr,String)])
emptyTrie = TrieT ([],[])
optimize :: TrieT -> Trie
optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty,
res)
collapse :: Trie -> [(String,[(Attr,String)])]
collapse trie = collapse' trie []
where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
else (reverse s,(x:xs)):
concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
collapse' (Trie (map,[])) s
= concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
tcompile :: [(String,[(Attr,String)])] -> Trie
tcompile xs = optimize $ build xs emptyTrie
build :: [(String,[(Attr,String)])] -> TrieT -> TrieT
build [] trie = trie
build (x:xs) trie = build xs (insert x trie)
where
insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res)
insert ((s:ss),ys) (TrieT (xs,res))
= case (span (\(s',_) -> s' /= s) xs) of
(xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res)
(xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res)
trieLookup :: Trie -> String -> (String,[(Attr,String)])
trieLookup trie s = apply trie s s
apply :: Trie -> String -> String -> (String,[(Attr,String)])
apply (Trie (_,res)) [] inp = (inp,res)
apply (Trie (map,_)) (s:ss) inp
= case map ! s of
Just trie -> apply trie ss inp
Nothing -> (inp,[])
-- Composite analysis (Huet's unglue algorithm)
-- only legaldecompositions are accepted.
-- With legal means that the composite forms are ordered correctly
-- with respect to the attributes W,P and WP.
-- Composite analysis
testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])]
decompose :: Trie -> String -> [String]
decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie
-- The function legal checks if the decomposition is in fact a possible one.
legal :: Trie -> [String] -> [String]
legal _ [] = []
legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else []
where
test [] = False
test [xs] = elem atW xs || elem atWP xs
test (xs:xss) = (elem atP xs || elem atWP xs) && test xss
react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String]
react input output back occ (Trie (arcs,res)) init =
case res of -- Accept = non-empty res.
[] -> continue back
_ -> let pushout = (occ:output)
in case input of
[] -> reverse $ map reverse pushout
_ -> let pushback = ((input,pushout):back)
in continue pushback
where continue cont = case input of
[] -> backtrack cont init
(l:rest) -> case arcs ! l of
Just trie ->
react rest output cont (l:occ) trie init
Nothing -> backtrack cont init
backtrack :: [(String,[String])] -> Trie -> [String]
backtrack [] _ = []
backtrack ((input,output):back) trie
= react input output back [] trie trie
{-
-- The function legal checks if the decomposition is in fact a possible one.
legal :: Trie -> [String] -> [String]
legal _ [] = []
legal trie input
| test $
map ((map fst).snd.(trieLookup trie)) input = input
| otherwise = []
where -- test checks that the Attrs are in the correct order.
test [] = False -- This case should never happen.
test [xs] = elem W xs || elem WP xs
test (xs:xss) = (elem P xs || elem WP xs) && test xss
-}
|
