Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 169 lines (141 sloc) 6.588 kb
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
1
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
2 module Roguestar.Lib.HierarchicalDatabase
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
3 (HierarchicalDatabase,
4 HierarchicalRelation(..),
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
5 Roguestar.Lib.HierarchicalDatabase.empty,
6 Roguestar.Lib.HierarchicalDatabase.insert,
7 Roguestar.Lib.HierarchicalDatabase.delete,
8 Roguestar.Lib.HierarchicalDatabase.lookup,
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
9 lookupChildren,
10 lookupParent,
11 parentOf,
12 childrenOf,
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
13 Roguestar.Lib.HierarchicalDatabase.toList,
14 Roguestar.Lib.HierarchicalDatabase.fromList,
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
15 insidenessTests)
16 where
17
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
18 import Prelude hiding (lookup)
19 import qualified Data.Map as Map
20 import qualified Data.List as List
21 import Roguestar.Lib.Tests
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
22 import Data.Maybe as Maybe
23
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
24 -- | A record that can be a component of a 'HierarchicalDatabase'.
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
25 class HierarchicalRelation a where
26 parent :: a -> Integer
27 child :: a -> Integer
28
29 instance (Integral a,Integral b) => HierarchicalRelation (a,b) where
30 parent = toInteger . snd
31 child = toInteger . fst
32
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
33 -- | A tree or hierarchy based on records that represent parent-child relations.
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
34 data HierarchicalDatabase a =
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
35 HierarchicalDatabase {
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
36 hd_children :: (Map.Map Integer [Integer]),
37 hd_parent :: (Map.Map Integer a) }
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
38
39 instance (Show a) => Show (HierarchicalDatabase a) where
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
40 show imap = show $ toList imap
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
41
42 instance (HierarchicalRelation a,Read a) => Read (HierarchicalDatabase a) where
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
43 readsPrec n = \v -> Prelude.map (\(x,y) -> (fromList x,y)) (readsPrec n v)
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
44
45 empty :: HierarchicalDatabase a
46 empty = HierarchicalDatabase (Map.empty) (Map.empty)
47
48 -- |
49 -- O(log n) Inserts the specified (parent,child,user_data) pair into the
50 -- InsidessMap. If the given child already has a parent, that parent is
51 -- replaced by the new one.
52 --
53 insert :: (HierarchicalRelation a) => a -> HierarchicalDatabase a -> HierarchicalDatabase a
54 insert a the_map =
55 HierarchicalDatabase {
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
56 hd_children = Map.alter (Just . maybe [child a] (child a :)) (parent a) $
57 hd_children $ delete (child a) the_map,
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
58 hd_parent = Map.insert (child a) a $ hd_parent the_map }
59
60 -- |
61 -- Deletes the specified object from this insideness map.
62 --
63 delete :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> HierarchicalDatabase a
64 delete x the_map =
65 HierarchicalDatabase {
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
66 hd_children = maybe (hd_children the_map) (\p -> Map.update deleteChildFromList p $ hd_children the_map) xsParent,
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
67 hd_parent = Map.delete x $ hd_parent the_map }
68 where deleteChildFromList l = case List.delete x l of
69 [] -> Nothing
70 l' -> Just l'
71 xsParent = parentOf x the_map
72
73 -- |
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
74 -- Answers the key of the parent of the given key, if any.
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
75 --
76 parentOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe Integer
77 parentOf x the_map = fmap parent $ Map.lookup x $ hd_parent the_map
78
79 -- |
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
80 -- Answers the parent relation and all children relations of a given key.
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
81 --
82 lookup :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> (Maybe a,[a])
83 lookup x the_map = (Map.lookup x $ hd_parent the_map,
84 maybe [] (Maybe.mapMaybe (flip Map.lookup (hd_parent the_map))) $ Map.lookup x $ hd_children the_map)
85
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
86 -- |
87 -- Answers the child relations of a given key.
88 --
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
89 lookupChildren :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [a]
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
90 lookupChildren x the_map = snd $ lookup x the_map
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
91
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
92 -- |
93 -- Answers the parent relation of a given key, if any.
94 --
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
95 lookupParent :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> Maybe a
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
96 lookupParent x the_map = fst $ lookup x the_map
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
97
98 -- |
f49a459 @clanehin Always sort inventory and pickup tables before sending them to the cl…
authored
99 -- Answers the keys of the children for a given key.
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
100 --
101 childrenOf :: (HierarchicalRelation a) => Integer -> HierarchicalDatabase a -> [Integer]
102 childrenOf x the_map = maybe [] id $ Map.lookup x (hd_children the_map)
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
103
104
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
105 -- |
106 -- Converts a HierarchicalDatabase into a list of relations.
107 --
108 toList :: HierarchicalDatabase a -> [a]
109 toList the_map = List.map snd $ Map.toList $ hd_parent the_map
110
111 -- |
112 -- Converts a list of relations into a HierarchicalDatabase.
113 --
114 fromList :: (HierarchicalRelation a) => [a] -> HierarchicalDatabase a
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
115 fromList as = foldr (insert) empty as
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
116
117 data ExampleRelation = ExampleRelation (Integer,Integer,Bool)
118
119 instance HierarchicalRelation ExampleRelation where
120 parent (ExampleRelation (n,_,_)) = n
121 child (ExampleRelation (_,n,_)) = n
122
123 example1 :: HierarchicalDatabase ExampleRelation
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
124 example1 = fromList $ List.map ExampleRelation
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
125 [(1,13,True),
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
126 (1,(-5),True),
127 (1,1,True),
128 (1,7,True),
129 (1,15,True),
130 (2,0,False),
131 (3,12,True),
132 (3,9,False),
133 (3,(-3),True),
134 (4,100,False),
135 (4,(-6),False),
136 (4,14,False)]
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
137
138 testParent :: TestCase
139 testParent = if (parentOf 0 example1) == (Just 2)
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
140 then return (Passed "testParent")
141 else return (Failed "testParent")
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
142
143 testChildren :: TestCase
144 testChildren = if (length $ childrenOf 1 example1) == 5
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
145 then return (Passed "testChildren")
146 else return (Failed "testChildren")
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
147
148 testUserData :: TestCase
149 testUserData = let child_records = lookupChildren 1 example1
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
150 in if (all (\(ExampleRelation (_,_,b)) -> b) child_records)
151 then return (Passed "testUserDatas")
152 else return (Failed "testUserDatas")
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
153
154 testChildrenCorrect :: TestCase
155 testChildrenCorrect = let the_children = childrenOf 4 example1
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
156 in if (all even the_children)
157 then return (Passed "testChildrenCorrect")
158 else return (Failed "testChildrenCorrect")
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
159
160 testDelete :: TestCase
eb4b7b8 @clanehin Package move to Roguestar.Lib.
authored
161 testDelete = let deleted = delete 0 $ delete (-6) $ example1
9195ff6 @clanehin Getting to be a fairly acceptable web game.
authored
162 in if ((length $ childrenOf 4 deleted) == 2 &&
163 (isNothing $ parentOf 0 deleted))
164 then return (Passed "testDelete")
165 else return (Failed "testDelete")
04e38ef @clanehin New Hierarchical location system and read-only database actions.
authored
166
167 insidenessTests :: [TestCase]
164aa68 @clanehin Upgrade license to GPLv3.
authored
168 insidenessTests = [testParent,testChildren,testUserData,testChildrenCorrect,testDelete]
Something went wrong with that request. Please try again.