Mercurial > hg > Members > toma > Jungle-haskell

comparison Jungle.hs @ 19:824543aea6fc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
delete Children and Attributes
author Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
date Fri, 24 Jan 2014 00:15:31 +0900
parents 7360fbfc7e62
children 97d1e67aef15
comparison
equal deleted inserted replaced
18:8d4e37c1a86a 19:824543aea6fc
11 , addNewChildAt 11 , addNewChildAt
12 , deleteChildAt 12 , deleteChildAt
13 , putAttribute 13 , putAttribute
14 , deleteAttribute 14 , deleteAttribute
15 , getAttributes 15 , getAttributes
16 , getChildren
17 , assocs
18 , numOfChild
19 , currentChild
16 , drawNode 20 , drawNode
17 , printAttributes 21 , printAttributes
18 , size 22 , size
19 , attrSize 23 , attrSize
20 ) where 24 ) where
26 30
27 data Jungle = Jungle { getJungleMap :: (M.Map String Tree) } 31 data Jungle = Jungle { getJungleMap :: (M.Map String Tree) }
28 32
29 data Tree = Tree 33 data Tree = Tree
30 { rootNode :: (TVar Node) 34 { rootNode :: (TVar Node)
31 , treeName :: String 35 , treeName :: String }
32 }
33 36
34 data Node = Node 37 data Node = Node
35 { children :: Children 38 { children :: (M.Map Int Node)
36 , attributes :: Attributes 39 , attributes :: (M.Map String B.ByteString) }
37 } deriving (Show)
38
39 -- Mapのkeyやvalueの型は固定しているが、
40 -- jungle作成時、もしくは木作成時に与えるように変更することも容易
41 newtype Children = Children { getChildrenMap :: (M.Map Int Node) } deriving (Show)
42 newtype Attributes = Attributes { getAttributesMap :: (M.Map String B.ByteString) } deriving (Show)
43 40
44 type Path = [Int] 41 type Path = [Int]
45 type Position = Int 42 type Position = Int
46 43
47 createJungle :: Jungle 44 createJungle :: Jungle
58 emptyTree tree_name = do 55 emptyTree tree_name = do
59 node <- newTVar emptyNode 56 node <- newTVar emptyNode
60 return (Tree node tree_name) 57 return (Tree node tree_name)
61 58
62 emptyNode :: Node 59 emptyNode :: Node
63 emptyNode = Node (Children M.empty) (Attributes M.empty) 60 emptyNode = Node (M.empty) (M.empty)
64 61
65 -- getRootNodeやupdateRootNodeをJungleとTree名を取るようにしたため不要 62 -- getRootNodeやupdateRootNodeをJungleとTree名を取るようにしたため不要
66 getTreeByName :: Jungle -> String -> Maybe Tree 63 getTreeByName :: Jungle -> String -> Maybe Tree
67 getTreeByName (Jungle map) tree_name = M.lookup tree_name map 64 getTreeByName (Jungle map) tree_name = M.lookup tree_name map
68 65
88 root_node = case M.lookup tree_name map of 85 root_node = case M.lookup tree_name map of
89 Just x -> rootNode x 86 Just x -> rootNode x
90 87
91 -- 新しい木構造を作成し、最新のルートノードとなるNodeを返す 88 -- 新しい木構造を作成し、最新のルートノードとなるNodeを返す
92 -- Pathの位置にNodeが存在しない場合どうするか？ 89 -- Pathの位置にNodeが存在しない場合どうするか？
93 addNewChildAt :: Node -> Path -> Position -> Node 90 -- 1 -> 2 -> 3と勝手にPositionをインクリメントしながら追加する
94 addNewChildAt parent [] pos = addChild parent pos emptyNode 91 addNewChildAt :: Node -> Path -> Node
95 addNewChildAt parent (x:xs) pos = addChild parent x $ addNewChildAt x_node xs pos 92 addNewChildAt parent [] = addChild' parent emptyNode
96 where 93 addNewChildAt parent (x:xs) = addChild parent x $ addNewChildAt x_node xs
97 map = getChildrenMap $ children parent 94 where
95 map = children parent
98 x_node = case M.lookup x map of 96 x_node = case M.lookup x map of
99 Just x -> x 97 Just x -> x
100 98
101 -- 子を追加したNodeを新しく作成して返す 99 -- 子を追加したNodeを新しく作成して返す
102 -- 同じ位置に既に子がある場合は？ 100 -- 同じ位置に既に子がある場合は？
103 -- 現在はinsertでそのまま上書き 101 -- 現在はinsertでそのまま上書き
104 addChild :: Node -> Position -> Node -> Node 102 addChild :: Node -> Position -> Node -> Node
105 addChild node pos child = Node new_child attr 103 addChild node pos child = Node new_child attr
106 where 104 where
107 map = getChildrenMap $ children node 105 map = children node
108 new_child = Children (M.insert pos child map) 106 new_child = M.insert pos child map
109 attr = attributes node 107 attr = attributes node
110 108
109 -- 自動でPositionをincrementして追加してくれるaddChild
110 addChild' :: Node -> Node -> Node
111 addChild' node child = Node new_child attr
112 where
113 map = children node
114 pos = (M.size map) + 1
115 new_child = M.insert pos child map
116 attr = attributes node
117
111 -- 子を削除した新しいNodeを追加するのに等しい 118 -- 子を削除した新しいNodeを追加するのに等しい
112 -- addNewChildAtのコピペ、一般化して関数に抽出したい
113 -- Nodeを操作してNodeを返す関数を渡せばいけそう
114 deleteChildAt :: Node -> Path -> Position -> Node 119 deleteChildAt :: Node -> Path -> Position -> Node
115 deleteChildAt parent [] pos = deleteChild parent pos 120 deleteChildAt parent [] pos = deleteChild parent pos
116 deleteChildAt parent (x:xs) pos = addChild parent x $ deleteChildAt x_node xs pos 121 deleteChildAt parent (x:xs) pos = addChild parent x $ deleteChildAt x_node xs pos
117 where 122 where
118 map = getChildrenMap $ children parent 123 map = children parent
119 x_node = case M.lookup x map of 124 x_node = case M.lookup x map of
120 Just x -> x 125 Just x -> x
121 126
122 deleteChild :: Node -> Position -> Node 127 deleteChild :: Node -> Position -> Node
123 deleteChild node pos = Node new_child attr 128 deleteChild node pos = Node new_child attr
124 where 129 where
125 map = getChildrenMap $ children node 130 map = children node
126 new_child = Children (M.delete pos map) 131 new_child = M.delete pos map
127 attr = attributes node 132 attr = attributes node
128 133
129 -- attribute関連はaddNewChildAtを利用する 134 -- attribute関連はaddNewChildAtを利用する
130 -- 現在はコピペ、関数に抽出したい 135 -- 現在はコピペ、関数に抽出したい
131 putAttribute :: Node -> Path -> String -> B.ByteString -> Node 136 putAttribute :: Node -> Path -> String -> B.ByteString -> Node
132 putAttribute parent [] key value = putAttr parent key value 137 putAttribute parent [] key value = putAttr parent key value
133 putAttribute parent (x:xs) key value = addChild parent x $ putAttribute x_node xs key value 138 putAttribute parent (x:xs) key value = addChild parent x $ putAttribute x_node xs key value
134 where 139 where
135 map = getChildrenMap $ children parent 140 map = children parent
136 x_node = case M.lookup x map of 141 x_node = case M.lookup x map of
137 Just x -> x 142 Just x -> x
138 143
139 putAttr :: Node -> String -> B.ByteString -> Node 144 putAttr :: Node -> String -> B.ByteString -> Node
140 putAttr node key value = Node child attr 145 putAttr node key value = Node child attr
141 where 146 where
142 map = getAttributesMap $ attributes node 147 map = attributes node
143 attr = Attributes (M.insert key value map) 148 attr = M.insert key value map
144 child = children node 149 child = children node
145 150
146 deleteAttribute :: Node -> Path -> String -> Node 151 deleteAttribute :: Node -> Path -> String -> Node
147 deleteAttribute parent [] key = deleteAttr parent key 152 deleteAttribute parent [] key = deleteAttr parent key
148 deleteAttribute parent (x:xs) key = addChild parent x $ deleteAttribute x_node xs key 153 deleteAttribute parent (x:xs) key = addChild parent x $ deleteAttribute x_node xs key
149 where 154 where
150 map = getChildrenMap $ children parent 155 map = children parent
151 x_node = case M.lookup x map of 156 x_node = case M.lookup x map of
152 Just x -> x 157 Just x -> x
153 158
154 deleteAttr :: Node -> String -> Node 159 deleteAttr :: Node -> String -> Node
155 deleteAttr node key = Node child attr 160 deleteAttr node key = Node child attr
156 where 161 where
157 map = getAttributesMap $ attributes node 162 map = attributes node
158 attr = Attributes (M.delete key map) 163 attr = M.delete key map
159 child = children node 164 child = children node
160 165
161 -- データを取り出す関連の関数 166 -- データを取り出す関連の関数
162 -- getNodeとgetchild, getattributeなど？ 167 -- getNodeとgetchild, getattributeなど？
163 168
164 getNode :: Node -> Path -> Node 169 getNode :: Node -> Path -> Node
165 getNode node [] = node 170 getNode node [] = node
166 getNode node (x:xs) = getNode child xs 171 getNode node (x:xs) = getNode child xs
167 where 172 where
168 map = getChildrenMap $ children node 173 map = children node
169 child = case M.lookup x map of 174 child = case M.lookup x map of
170 Just x -> x 175 Just x -> x
171 176
172 getAttributes :: Node -> Path -> String -> Maybe B.ByteString 177 getAttributes :: Node -> Path -> String -> Maybe B.ByteString
173 getAttributes node path key = M.lookup key map 178 getAttributes node path key = M.lookup key map
174 where 179 where
175 target = getNode node path 180 target = getNode node path
176 map = getAttributesMap $ attributes target 181 map = attributes target
182
183 -- 対象のNodeの全ての子を返す
184 getChildren :: Node -> Path -> [Node]
185 getChildren node path = M.elems map
186 where
187 target = getNode node path
188 map = children target
189
190 -- Attributeの連想リストを返す
191 assocs :: Node -> Path -> [(String, B.ByteString)]
192 assocs node path = M.assocs map
193 where
194 target = getNode node path
195 map = attributes target
196
197 -- 対象のNodeの子供の数を教えてくれる
198 numOfChild :: Node -> Path -> Int
199 numOfChild node path = M.size map
200 where
201 target = getNode node path
202 map = children target
203
204 -- foucus
205 -- 対象のpathのノードの最新の子を返す
206 -- 編集する際に使うのは無理
207 currentChild :: Node -> Path -> Maybe Node
208 currentChild node path = M.lookup pos map
209 where
210 target = getNode node path
211 map = children target
212 pos = M.size map
177 213
178 -- デバッグ用表示関数 214 -- デバッグ用表示関数
179 215
180 -- 現在の木構造を整形して表示 216 -- 現在の木構造を整形して表示
181 drawNode :: Node -> String 217 drawNode :: Node -> String
182 drawNode node = unlines $ draw "root" node 218 drawNode node = unlines $ draw "root" node
183 219
184 draw :: String -> Node -> [String] 220 draw :: String -> Node -> [String]
185 draw string node = string : drawSubTrees keys 221 draw string node = string : drawSubTrees keys
186 where 222 where
187 map = getChildrenMap $ children node 223 map = children node
188 keys = M.keys map 224 keys = M.keys map
189 drawSubTrees [] = [] 225 drawSubTrees [] = []
190 drawSubTrees [t] = 226 drawSubTrees [t] =
191 "|" : shift "`- " " " (draw (show t) (fromJust $ M.lookup t map)) 227 "|" : shift "`- " " " (draw (show t) (fromJust $ M.lookup t map))
192 drawSubTrees (t:ts) = 228 drawSubTrees (t:ts) =
201 printAttr string node = 237 printAttr string node =
202 if not $ M.null attr_map 238 if not $ M.null attr_map
203 then ("Node: " ++ string) : (" " ++ attr) : printSubTrees keys 239 then ("Node: " ++ string) : (" " ++ attr) : printSubTrees keys
204 else printSubTrees keys 240 else printSubTrees keys
205 where 241 where
206 attr_map = getAttributesMap $ attributes node 242 attr_map = attributes node
207 show_attr [] = [] 243 show_attr [] = []
208 show_attr [x] = fst x ++ ": " ++ (B.unpack $ snd x) 244 show_attr [x] = fst x ++ ": " ++ (B.unpack $ snd x)
209 show_attr (x:xs) = fst x ++ ": " ++ (B.unpack $ snd x) ++ "\n " ++ show_attr xs 245 show_attr (x:xs) = fst x ++ ": " ++ (B.unpack $ snd x) ++ "\n " ++ show_attr xs
210 attr = show_attr $ M.assocs attr_map 246 attr = show_attr $ M.assocs attr_map
211 map = getChildrenMap $ children node 247 map = children node
212 keys = M.keys map 248 keys = M.keys map
213 printSubTrees [] = [] 249 printSubTrees [] = []
214 printSubTrees (x:xs) = printAttr (string ++ "-" ++ (show x)) (fromJust $ M.lookup x map) ++ printSubTrees xs 250 printSubTrees (x:xs) = printAttr (string ++ "-" ++ (show x)) (fromJust $ M.lookup x map) ++ printSubTrees xs
215 251
216 -- ルートノードの下にいくつの子があるか数える 252 -- ルートノードの下にいくつの子があるか数える
217 size :: Node -> Int 253 size :: Node -> Int
218 size node = M.size map + subTreesSize keys 254 size node = M.size map + subTreesSize keys
219 where 255 where
220 map = getChildrenMap $ children node 256 map = children node
221 keys = M.keys map 257 keys = M.keys map
222 subTreesSize [] = 0 258 subTreesSize [] = 0
223 subTreesSize (x:xs) = size (getNode x) + subTreesSize xs 259 subTreesSize (x:xs) = size (getNode x) + subTreesSize xs
224 getNode x = fromJust $ M.lookup x map 260 getNode x = fromJust $ M.lookup x map
225 261
226 -- Attributesの数を調べる 262 -- Attributesの数を調べる
227 attrSize :: Node -> Int 263 attrSize :: Node -> Int
228 attrSize node = M.size attr_map + subTreesSize keys 264 attrSize node = M.size attr_map + subTreesSize keys
229 where 265 where
230 attr_map = getAttributesMap $ attributes node 266 attr_map = attributes node
231 map = getChildrenMap $ children node 267 map = children node
232 keys = M.keys map 268 keys = M.keys map
233 subTreesSize [] = 0 269 subTreesSize [] = 0
234 subTreesSize (x:xs) = attrSize (getNode x) + subTreesSize xs 270 subTreesSize (x:xs) = attrSize (getNode x) + subTreesSize xs
235 getNode x = fromJust $ M.lookup x map 271 getNode x = fromJust $ M.lookup x map
236 272