Skip to content
Newer
Older
100644 70 lines (62 sloc) 2.09 KB
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 19, 2010
1 module GSS
220da11 @adept Exposed costructors of Node to simplify development (see "correct" in…
authored Apr 21, 2010
2 ( GState(yu,curr_u,er), Node(..), create, add, pop, mkGState )
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
3 where
4
5 import Data.Map as M
6 import Data.Set as S
7
8 type Pos = Int
14223c5 @adept Stripped extra tuple from inside Node
authored Apr 21, 2010
9 data Node lab = Root | Node lab Pos deriving (Eq,Ord,Show) -- TODO: remove Show in production
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
10 type R lab = [(lab, Node lab, Pos)]
4cf818d @adept Converted U to the flat Set of triples
authored Apr 21, 2010
11 type U lab = Set (lab,Node lab,Pos)
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
12 type P lab = Set (Node lab, Pos)
13 type G lab = Set (Node lab)
14 type E lab = Map (Node lab) (Set (Node lab)) -- parents
15
16 data GState lab = GState
17 { gee :: G lab
18 , er :: R lab
19 , pe :: P lab
20 , curr_u :: Node lab
21 , parents :: E lab
22 , yu :: U lab
23 }
24
538f7c6 @adept added mkGState - creates new pristine GState
authored Apr 21, 2010
25 mkGState startLabel =
26 GState { gee = S.fromList [ u0, u1 ]
27 , parents = M.singleton u1 (S.singleton u0)
28 , curr_u = u1
29 , pe = S.empty
30 , er = []
4cf818d @adept Converted U to the flat Set of triples
authored Apr 21, 2010
31 , yu = S.empty
538f7c6 @adept added mkGState - creates new pristine GState
authored Apr 20, 2010
32 }
33 where
76c787e @adept Converted Node to "data", implemented explicit Root node
authored Apr 21, 2010
34 u0 = Root
14223c5 @adept Stripped extra tuple from inside Node
authored Apr 21, 2010
35 u1 = Node startLabel 0
538f7c6 @adept added mkGState - creates new pristine GState
authored Apr 20, 2010
36
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
37 create :: (Eq lab, Ord lab) => lab -> Node lab -> Pos -> GState lab
38 -> (GState lab, Node lab)
39 create label u i oldgs =
7300b77 @feuerbach Fix bug in 'create'
feuerbach authored Apr 21, 2010
40 if v `S.member` g && u `S.member` (parents oldgs M.! v)
41 then -- nothing to do
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
42 (oldgs, v)
43 else
44 (add_popped.connect_v.insert_v $ oldgs, v)
45 where
46 g = gee oldgs
fecc1cf @adept 'pee' - это дубликат 'pe', убираю
authored Apr 21, 2010
47 p = pe oldgs
14223c5 @adept Stripped extra tuple from inside Node
authored Apr 21, 2010
48 v = Node label i
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
49 insert_v gstate = gstate { gee = S.insert v g }
50 connect_v gstate = gstate { parents = M.insertWith (S.union) v (S.singleton u) (parents gstate) }
51 add_popped gstate = foldl (\gs j -> add label u j gs) gstate [ j | (x,j) <- S.elems p, x == v ]
52
4cf818d @adept Converted U to the flat Set of triples
authored Apr 21, 2010
53 add :: (Eq lab, Ord lab) => lab -> Node lab -> Pos -> GState lab -> GState lab
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
54 add label u i oldgs =
4cf818d @adept Converted U to the flat Set of triples
authored Apr 21, 2010
55 if not ((label,u,i) `S.member` yu_)
56 then oldgs {er = (label, u, i):r, yu = S.insert (label,u,i) yu_}
37b6c96 @feuerbach Idea of GSS interface
feuerbach authored Apr 18, 2010
57 else oldgs
58 where
59 r = er oldgs
60 yu_ = yu oldgs
61
5096871 @feuerbach Implement pop
feuerbach authored Apr 21, 2010
62 pop :: (Eq lab, Ord lab) => Node lab -> Pos -> GState lab -> GState lab
183994f @adept Proper root processing in "pop"
authored Apr 21, 2010
63 pop u i oldgs = if u == Root then oldgs else newgs
5096871 @feuerbach Implement pop
feuerbach authored Apr 20, 2010
64 where
14223c5 @adept Stripped extra tuple from inside Node
authored Apr 21, 2010
65 Node label _ = u
5096871 @feuerbach Implement pop
feuerbach authored Apr 20, 2010
66 prnts = parents oldgs
67 update_pe gstate = gstate { pe = S.insert (u,i) (pe gstate) }
68 create_descriptors gstate = foldl (\gs parent -> add label parent i gs) gstate (S.elems (prnts!u))
69 newgs = create_descriptors . update_pe $ oldgs
Something went wrong with that request. Please try again.