Softwaredesign: Datenmodell und Funktionen
| Softwaredesign: Datenmodell und Funktionen |
|
|
|
1module RadixTree
2where
3
4import Data.Char
5import Data.Maybe
6import qualified Data.List as L
7
8import Data.Map(Map)
9import qualified Data.Map as M
10
11import Data.Set(Set)
12import qualified Data.Set as S
13
14-- ------------------------------------------------------------
15--
16
17type Key = String
18type Attr = Set Int
19
20data Table = Leaf String Attr
21 | Entry Table Attr
22 | Switch ( Map Char Table )
23 | Single Char Table
24 | Empty
25 deriving (Show)
26
27-- ------------------------------------------------------------
28
29emptyTable :: Table
30emptyTable = Empty
31
32-- ------------------------------------------------------------
33--
34-- 11 cases
35
36search :: String -> Table -> Maybe Attr
37
38search k Empty = Nothing
39
40search k (Leaf rest attr)
41 | k == rest = Just attr
42 | otherwise = Nothing
43
44search "" (Entry table attr) = Just attr
45search k (Entry table attr) = search k table
46
47search "" (Switch sw) = Nothing
48search (c:rest) (Switch sw) = switch (M.lookup c sw)
49 where
50 switch Nothing = Nothing
51 switch (Just tab) = search rest tab
52
53search "" (Single c' tab) = Nothing
54search (c:rest) (Single c' tab)
55 | c == c' = search rest tab
56 | otherwise = Nothing
57
58-- ------------------------------------------------------------
59--
60-- very fast
61
62searchPrefix :: String -> Table -> Table
63
64searchPrefix "" tab = tab
65
66searchPrefix k Empty = emptyTable
67
68searchPrefix k (Entry tab' a') = searchPrefix k tab'
69
70searchPrefix k (Leaf k' a')
71 | L.isPrefixOf k k' = Leaf (drop (length k) k') a'
72 | otherwise = emptyTable
73
74searchPrefix (c:rest) (Single c' tab')
75 | c == c' = searchPrefix rest tab'
76 | otherwise = emptyTable
77
78searchPrefix (c:rest) (Switch sw')
79 | M.member c sw' = searchPrefix rest
80 (fromJust $ M.lookup c sw')
81 | otherwise = emptyTable
82
83-- ------------------------------------------------------------
84--
85-- 14 cases: completeness, correctness ???
86
87insert :: String -> Attr -> Table -> Table
88
89insert "" a Empty = Leaf "" a
90insert "" a (Leaf "" a') = Leaf "" (a' `S.union` a)
91insert "" a (Entry tab' a') = Entry tab' (a' `S.union` a)
92insert "" a tab = Entry tab a
93
94insert k a Empty = Leaf k a
95
96insert k a (Leaf k' a')
97 | k == k' = Leaf k' (a' `S.union` a)
98
99insert k a (Leaf "" a') = Entry (insert k a emptyTable) a'
100
101insert (c:rest) a (Leaf (c':rest') a')
102 | c == c' = Single c (insert rest a (insert rest' a' emptyTable))
103 | otherwise = Switch (M.insert c (insert rest a emptyTable)
104 (M.singleton c' (insert rest' a' emptyTable)))
105
106insert k a (Entry tab' a') = Entry (insert k a tab') a'
107
108insert (c:rest) a (Switch sw')
109 | M.member c sw' = Switch (M.adjust (insert rest a) c sw')
110 | otherwise = Switch (M.insert c (insert rest a emptyTable) sw')
111
112insert (c:rest) a (Single c' tab')
113 | c == c' = Single c (insert rest a tab')
114 | otherwise = Switch (M.insert c (insert rest a emptyTable)
115 (M.singleton c' tab'))
116
117-- ------------------------------------------------------------
118
119keys :: Table -> [String]
120
121keys Empty = []
122keys (Leaf w a) = [w]
123keys (Entry tab a) = "" : keys tab
124keys (Single c tab) = [ c : w | w <- keys tab ]
125keys (Switch sw) = [ c : w | c <- M.keys sw
126 , w <- keys (fromJust $ M.lookup c sw)
127 ]
128
129-- ------------------------------------------------------------
130--
131-- invariant: consistency test
132--
133-- complete, o.k., insert correct ???
134--
135-- 1) Empty only legal for empty table
136--
137-- 2) Switch at least with 2 entries
138--
139-- 3) no nested Entry constructors
140--
141-- 4) no Entry with following Leaf with empty string
142--
143-- 5) all subtables consistent
144
145invTable :: Table -> Bool
146invTable Empty = True
147invTable t = invTable' t
148 where
149 invTable' Empty = False
150 invTable' (Switch sw') = M.size sw' >= 2
151 &&
152 all invTable' (M.elems sw')
153 invTable' (Single c t') = invTable' t'
154 invTable' (Entry t' a') = ( case t' of
155 Entry _ _ -> False
156 Leaf "" _ -> False
157 _ -> True
158 )
159 && invTable' t'
160 invTable' (Leaf k' a') = True
161
162-- ------------------------------------------------------------
163
164tableSpace :: Table -> Int
165tableSpace Empty
166 = 0 -- Singleton
167
168tableSpace (Entry t a)
169 = 2 + tableSpace t -- 1 (constructor) + 1 (Table) + 0 (Attr not counted)
170
171tableSpace (Switch m)
172 = 2 + 2 * M.size m -- 1 (constructor) + 1 (Map) + per Entry (Char, Table)
173 + (sum . map tableSpace . M.elems) m
174
175tableSpace (Single c t)
176 = 3 + tableSpace t -- 1 (constructor) + 1 (Char) + 1 (Table)
177
178tableSpace (Leaf s a)
179 = 1 + length s -- 1 (constructor) + length key + 0 (Attr not counted)
180
181
182tableSize :: Table -> (Int, Int)
183tableSize t
184 = (length ks, sum . map length $ ks)
185 where
186 ks = keys t
187
188-- ------------------------------------------------------------
|
|
1module RadixTreeExample1
2
3where
4import Data.Char
5
6import Data.Set(Set)
7import qualified Data.Set as S
8
9
10import RadixTree
11
12import Zitate
13
14scanText :: String -> [String]
15scanText = words . map ( \ c -> if isAlphaNum c then c else ' ')
16
17insDoc :: (Int, String) -> Table -> Table
18insDoc (i, s) tab
19 = foldr (\ w t -> insert w (S.singleton i) t) tab $ wl
20 where
21 wl = scanText s
22
23zitateTabelle :: Table
24zitateTabelle
25 = foldr insDoc emptyTable zitate
26
27alleWoerter :: String -> IO()
28alleWoerter prefix
29 = sequence_ . (map putStrLn)
30 $
31 map (prefix ++ ) . keys . searchPrefix prefix
32 $
33 zitateTabelle
34
35alleWoerterMitFra
36 = alleWoerter "Fra"
37
38platz
39 = putStrLn ("Woerter: " ++ show wc ++ "\tZeichen: " ++ show cc ++ "\tPlatz: " ++ show space)
40 where
41 space = tableSpace zitateTabelle
42 (wc, cc) = tableSize zitateTabelle
|
| Letzte Änderung: 06.12.2016 | © Prof. Dr. Uwe Schmidt |
