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
|
----------------------------------------------------------------------
-- |
-- Module : Trie
-- Maintainer : Markus Forsberg
-- Stability : Obsolete
-- Portability : Haskell 98
--
-- > CVS $Date: 2005/04/21 16:22:09 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.6 $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module GF.Data.Trie (
tcompile,
collapse,
Trie,
trieLookup,
decompose,
Attr,
atW, atP, atWP
) where
import GF.Data.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
-}
|
