Mercurial > hg > Members > toma > Jungle-haskell

--- a/Jungle.hs	Mon Jun 17 18:09:37 2013 +0900
+++ b/Jungle.hs	Mon Jan 13 09:02:37 2014 +0900
@@ -1,135 +1,179 @@
-module Jungle
+module Jungle
 ( Jungle
-, Tree (Tree)
-, Node (Empty)
-, Children
-, Attributes
+, Tree
+, Node
 , Path
 , createJungle
 , createTree
-, createNode
-, updateTree
 , getTreeByName
 , getRootNode
-, getChildren
-, getMap
-, getAttributes
-, at
-, get
+, updateRootNode
 , addNewChildAt
 , deleteChildAt
 , putAttribute
 , deleteAttribute
+, getAttributes
+, drawNode -- デバッグ用
 ) where

-import qualified Data.Map as Map
+import qualified Data.Map as M
 import qualified Data.ByteString.Lazy.Char8 as B
+import Control.Concurrent.STM
+import Data.Maybe (fromJust)
+
+data Jungle = Jungle { getJungleMap :: (M.Map String Tree) }

-data Children   = Children (Map.Map Int Node) deriving (Show)
-data Attributes = Attributes (Map.Map String B.ByteString) deriving (Show)
+data Tree = Tree
+          { rootNode :: (TVar Node)
+          , treeName :: String
+          }

-data Node = Empty
-          | Node
+data Node = Node
           { children   :: Children
           , attributes :: Attributes
           } deriving (Show)

-data Tree = Tree
-          { rootNode :: Node
-          , treeName :: String
-          } deriving (Show)
-
-data Jungle = Jungle (Map.Map String Tree) deriving (Show)
+-- Mapのkeyやvalueの型は固定しているが、
+-- jungle作成時、もしくは木作成時に与えるように変更することも容易
+newtype Children   = Children   { getChildrenMap :: (M.Map Int Node) } deriving (Show)
+newtype Attributes = Attributes { getAttributesMap :: (M.Map String B.ByteString) } deriving (Show)

 type Path = [Int]
+type Position = Int

 createJungle :: Jungle
-createJungle = Jungle Map.empty
+createJungle = Jungle M.empty
+
+-- 同じ名前のTreeが存在する場合、上書きする
+-- Eitherなどで失敗させるほうがいいかもしれない
+createTree :: Jungle -> String -> IO Jungle
+createTree (Jungle map) tree_name = atomically $ do
+    tree <- emptyTree tree_name
+    return (Jungle (M.insert tree_name tree map))

-createTree :: Jungle -> String -> Jungle
-createTree (Jungle map) tree_name = Jungle (Map.insert tree_name emptyTree map)
- where
-   emptyTree = Tree createNode tree_name
+emptyTree :: String -> STM Tree
+emptyTree tree_name = do
+    node <- newTVar emptyNode
+    return (Tree node tree_name)

-createNode :: Node
-createNode = Node (Children Map.empty) (Attributes Map.empty)
+emptyNode :: Node
+emptyNode = Node (Children M.empty) (Attributes M.empty)
+
+getTreeByName :: Jungle -> String -> Maybe Tree
+getTreeByName (Jungle map) tree_name = M.lookup tree_name map

 updateTree :: Jungle -> Tree -> Jungle
-updateTree (Jungle map) tree@(Tree node name) = Jungle (Map.insert name tree map)
+updateTree jungle tree = Jungle (M.insert tree_name tree map)
+  where
+    map = getJungleMap jungle
+    tree_name = treeName tree

-getTreeByName :: Jungle -> String -> Tree
-getTreeByName (Jungle map) tree_name = Map.findWithDefault emptyTree tree_name map
-  where
-    emptyTree = Tree createNode tree_name
+getRootNode :: Tree -> IO Node
+getRootNode tree = atomically $ readTVar (rootNode tree)

-getRootNode :: Tree -> Node
-getRootNode tree = rootNode tree
+-- ルートノードを更新する
+updateRootNode :: Tree -> Node -> IO ()
+updateRootNode tree node = atomically $ writeTVar (rootNode tree) node

-getChildren :: Node -> Children
-getChildren node = children node
-
-getMap :: Children -> Map.Map Int Node
-getMap (Children map) = map
+-- 新しい木構造を作成し、最新のルートノードとなるNodeを返す
+-- Pathの位置にNodeが存在しない場合どうするか？
+addNewChildAt :: Node -> Path -> Position -> Node
+addNewChildAt parent []     pos = addChild parent pos emptyNode
+addNewChildAt parent (x:xs) pos = addChild parent x $ addNewChildAt x_node xs pos
+  where
+    map = getChildrenMap $ children parent
+    x_node = case M.lookup x map of
+               Just x -> x

-getAttributes :: Node -> Attributes
-getAttributes node = attributes node
-
-at :: Children -> Int -> Node
-at (Children map) pos = Map.findWithDefault Empty pos map
+-- 子を追加したNodeを新しく作成して返す
+-- 同じ位置に既に子がある場合は？
+-- 現在はinsertでそのまま上書き
+addChild :: Node -> Position -> Node -> Node
+addChild node pos child = Node new_child attr
+  where
+    map = getChildrenMap $ children node
+    new_child = Children (M.insert pos child map)
+    attr = attributes node

-get :: Attributes -> String -> B.ByteString
-get (Attributes map) key = Map.findWithDefault B.empty key map
+-- 子を削除した新しいNodeを追加するのに等しい
+-- addNewChildAtのコピペ、一般化して関数に抽出したい
+-- Nodeを操作してNodeを返す関数を渡せばいけそう
+deleteChildAt :: Node -> Path -> Position -> Node
+deleteChildAt parent []     pos = deleteChild parent pos
+deleteChildAt parent (x:xs) pos = addChild parent x $ deleteChildAt x_node xs pos
+  where
+    map = getChildrenMap $ children parent
+    x_node = case M.lookup x map of
+               Just x -> x

-addNewChildAt :: Tree -> Path -> Int -> Node -> Tree
-addNewChildAt tree@(Tree root name) path pos node = Tree (addNewChildAt' (getRootNode tree) path pos node) name
+deleteChild :: Node -> Position -> Node
+deleteChild node pos = Node new_child attr
+  where
+    map = getChildrenMap $ children node
+    new_child = Children (M.delete pos map)
+    attr = attributes node

-addNewChildAt' :: Node -> Path -> Int -> Node -> Node
-addNewChildAt' parent []     pos new_child = addChild parent pos new_child
-addNewChildAt' parent (x:xs) pos new_child = addChild parent x (addNewChildAt' (child x) xs pos new_child)
-  where
-    child = at (getChildren parent)
+-- attribute関連はaddNewChildAtを利用する
+-- 現在はコピペ、関数に抽出したい
+putAttribute :: Node -> Path -> String -> B.ByteString -> Node
+putAttribute parent []     key value = putAttr parent key value
+putAttribute parent (x:xs) key value = addChild parent x $ putAttribute x_node xs key value
+  where
+    map = getChildrenMap $ children parent
+    x_node = case M.lookup x map of
+               Just x -> x
+
+putAttr :: Node -> String -> B.ByteString -> Node
+putAttr node key value = Node child attr
+  where
+    map = getAttributesMap $ attributes node
+    attr = Attributes (M.insert key value map)
+    child = children node

-deleteChildAt :: Tree -> Path -> Int -> Tree
-deleteChildAt tree path pos = editTree tree path (deleteChild target pos)
+deleteAttribute :: Node -> Path -> String -> Node
+deleteAttribute parent []     key = deleteAttr parent key
+deleteAttribute parent (x:xs) key = addChild parent x $ deleteAttribute x_node xs key
   where
-    root = getRootNode tree
-    target = getNode root path
+    map = getChildrenMap $ children parent
+    x_node = case M.lookup x map of
+               Just x -> x
+
+deleteAttr :: Node -> String -> Node
+deleteAttr node key = Node child attr
+  where
+    map = getAttributesMap $ attributes node
+    attr = Attributes (M.delete key map)
+    child = children node

-addChild :: Node -> Int -> Node -> Node
-addChild Empty pos child = addChild (Node (Children Map.empty) (Attributes Map.empty)) pos child
-addChild (Node (Children map) attributes) pos child = Node (Children (Map.insert pos child map)) attributes
+-- データを取り出す関連の関数
+-- getNodeとgetchild, getattributeなど？

 getNode :: Node -> Path -> Node
 getNode node []     = node
-getNode node (x:xs) = getNode (child x) xs
+getNode node (x:xs) = getNode child xs
   where
-    child = at (getChildren node)
+    map = getChildrenMap $ children node
+    child = case M.lookup x map of
+              Just x -> x

-deleteChild :: Node -> Int -> Node
-deleteChild Empty _ = Empty
-deleteChild (Node (Children map) attributes) pos = Node (Children (Map.delete pos map)) attributes
-
-putAttribute :: Tree -> Path -> String -> B.ByteString -> Tree
-putAttribute tree path key value = editTree tree path (putAttribute' target key value)
+getAttributes :: Node -> Path -> String -> Maybe B.ByteString
+getAttributes node path key = M.lookup key map
   where
-    root = getRootNode tree
-    target = getNode root path
+    target = getNode node path
+    map = getAttributesMap $ attributes target

-deleteAttribute :: Tree -> Path -> String -> Tree
-deleteAttribute tree path key = editTree tree path (deleteAttribute' target key)
-  where
-    root = getRootNode tree
-    target = getNode root path
+-- デバッグ用表示関数
+drawNode :: Node -> String
+drawNode node = unlines $ draw "root" node

-putAttribute' :: Node -> String -> B.ByteString -> Node
-putAttribute' Empty key value = putAttribute' (Node (Children Map.empty) (Attributes Map.empty)) key value
-putAttribute' (Node children (Attributes map)) key value = Node children (Attributes (Map.insert key value map))
+draw string node = string : drawSubTrees keys
+  where
+    map = getChildrenMap $ children node
+    keys = M.keys map
+    drawSubTrees [] = []
+    drawSubTrees [t] =
+      "|" : shift "`-" " " (draw (show t) (fromJust $ M.lookup t map))
+    drawSubTrees (t:ts) =
+      "|" : shift "+- " "|  " (draw (show t) (fromJust $ M.lookup t map )) ++ drawSubTrees ts
+    shift first other = zipWith (++) (first : repeat other)

-deleteAttribute' :: Node -> String -> Node
-deleteAttribute' Empty _ = Empty
-deleteAttribute' (Node children (Attributes map)) key = Node children (Attributes (Map.delete key map))
-
-editTree :: Tree -> Path -> Node -> Tree
-editTree (Tree root name) [] node = Tree node name
-editTree tree path node = addNewChildAt tree (init path) (last path) node
-
--- a/Main.hs	Mon Jun 17 18:09:37 2013 +0900
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,16 +0,0 @@
-module Main where
-import Jungle
-import qualified Data.ByteString.Char8 as C
-
-
-x = createTree createJungle "new_tree"
-tree = getTreeByName x "new_tree"
-new_tree = addNewChildAt tree [] 0 Empty
-new_tree2 = putAttribute tree [] "key" (C.pack "value")
-
-
-main = do print $ createJungle
-          print x
-          print $ getTreeByName x "new_tree"
-          print new_tree
-          print new_tree2