Mercurial > hg > Members > toma > Jungle-haskell
changeset 1:98e1a35e4ab0
Rewrite almost and Modularization
author | Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Tue, 26 Mar 2013 16:24:20 +0900 |
parents | 329f462d5dad |
children | 392c3f30c076 |
files | Jungle.hs tree.hs |
diffstat | 2 files changed, 124 insertions(+), 71 deletions(-) [+] |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/Jungle.hs Tue Mar 26 16:24:20 2013 +0900 @@ -0,0 +1,124 @@ +module Jungle +( Jungle +, Tree +, Node +, Children +, Attributes +, createJungle +, createTree +, getTreeByName +, getRootNode +, getChildren +, getAttributes +, at +, get +, addNewChildAt +, deleteChildAt +, putAttribute +, deleteAttribute +) where + +import qualified Data.Map as Map +import qualified Data.ByteString as B + +data Children = Children (Map.Map Int Node) deriving (Show) +data Attributes = Attributes (Map.Map String B.ByteString) deriving (Show) + +data Node = Empty + | Node + { children :: Children + , attributes :: Attributes + } deriving (Show) + +data Tree = Tree + { rootNode :: Node + } deriving (Show) + +data Jungle = Jungle (Map.Map String Tree) deriving (Show) + +type Path = [Int] + +createJungle :: Jungle +createJungle = Jungle Map.empty + +createTree :: Jungle -> String -> Jungle +createTree (Jungle map) tree_name = Jungle (Map.insert tree_name emptyTree map) + where + emptyTree = Tree Empty + +getTreeByName :: Jungle -> String -> Tree +getTreeByName (Jungle map) tree_name = Map.findWithDefault emptyTree tree_name map + where + emptyTree = Tree Empty + +getRootNode :: Tree -> Node +getRootNode tree = rootNode tree + +getChildren :: Node -> Children +getChildren node = children node + +getAttributes :: Node -> Attributes +getAttributes node = attributes node + +at :: Children -> Int -> Node +at (Children map) pos = Map.findWithDefault Empty pos map + +get :: Attributes -> String -> B.ByteString +get (Attributes map) key = Map.findWithDefault B.empty key map + +addNewChildAt :: Tree -> Path -> Int -> Node -> Tree +addNewChildAt tree path pos node = Tree $ addNewChildAt' (getRootNode tree) path pos 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) + +-- RootNodeの子が消せない +-- addNewChildAtが下に付け加えることしかできないから +-- RootNodeのこの場合例外処理すればいけるけどスマートな書き方ないか考える +deleteChildAt :: Tree -> Path -> Int -> Tree +deleteChildAt tree path pos = editTree tree path (deleteChild target pos) + where + root = getRootNode tree + target = getNode root path + +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 :: Node -> Path -> Node +getNode node [] = node +getNode node (x:xs) = getNode (child x) xs + where + child = at (getChildren node) + +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) + where + root = getRootNode tree + target = getNode root path + +deleteAttribute :: Tree -> Path -> String -> Tree +deleteAttribute tree path key = editTree tree path (deleteAttribute' target key) + where + root = getRootNode tree + target = getNode root path + +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)) + +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 _ [] node = Tree node +editTree tree path node = addNewChildAt tree (init path) (last path) node +
--- a/tree.hs Tue Mar 12 18:00:51 2013 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -import qualified Data.Map as Map -import Data.Maybe (isNothing, fromJust) - -type Attribute = Map.Map String String -type Children = Map.Map Int Node - -data Node = Empty - | Node { attribute :: Attribute - , children :: Children - } deriving (Show, Eq) - -addChild :: Node -> Node -> Int -> Node -addChild node child pos = Node (attribute node) (Map.insert pos child (children node)) - -getChild :: Node -> Int -> Maybe Node -getChild node pos = Map.lookup pos (children node) - -putAttribute :: Node -> String -> String -> Node -putAttribute node key value = Node (Map.insert key value (attribute node)) (children node) - -getAttribute :: Node -> String -> Maybe String -getAttribute node key = Map.lookup key (attribute node) - -getNode :: [Int] -> Node -> Maybe Node -getNode path node = if null path - then Just node - else (getChild node (head path)) >>= getNode (tail path) - -editNode :: [Int] -> Node -> String -> String -> Maybe Node -editNode path node key value = if isNothing (getNode path node) - then Nothing - else _editNode path node Empty 0 key value - -_editNode :: [Int] -> Node -> Node -> Int -> String -> String -> Maybe Node -_editNode [] node newnode pos _ _ = Just (addChild (fromJust (getNode [] node)) newnode pos) -_editNode (xs) node newnode pos key value = if newnode == Empty - then _editNode (init xs) node (putAttribute (fromJust (getNode xs node)) key value ) (last xs) [] [] - else _editNode (init xs) node (addChild (fromJust (getNode xs node)) newnode pos) (last xs) [] [] - -addChildAt :: [Int] -> Node -> Node -> Int -> Maybe Node -addChildAt path node child pos = if isNothing (getNode (init path) node) - then Nothing - else _addChildAt path node child pos - -_addChildAt :: [Int] -> Node -> Node -> Int -> Maybe Node -_addChildAt [] node child pos = Just (addChild (fromJust (getNode [] node)) child pos) -_addChildAt (xs) node child pos = _addChildAt (init xs) node (addChild (fromJust (getNode xs node)) child pos) (last xs) - --- test 用 -a = Node Map.empty Map.empty -b = Node Map.empty Map.empty -c = Node Map.empty Map.empty -d = Node Map.empty Map.empty -e = Node Map.empty Map.empty -f = Node Map.empty Map.empty -g = Node Map.empty Map.empty - -a2 = putAttribute a "node" "a" -b2 = putAttribute b "node" "b" -c2 = putAttribute c "node" "c" -d2 = putAttribute d "node" "d" -e2 = putAttribute e "node" "e" -f2 = putAttribute f "node" "f" -g2 = putAttribute g "node" "g" - -b3 = addChild (addChild b2 d2 0) e2 1 -c3 = addChild c2 f2 0 -node = addChild g2 (addChild (addChild a2 b3 0) c3 1) 0 - -new = editNode [0,1,0] node "node" "x" -new1 = addChildAt [0,1,0] (fromJust new) z1 5