# HG changeset patch
# User Daichi TOMA <toma@cr.ie.u-ryukyu.ac.jp>
# Date 1390511190 -32400
# Node ID 97d1e67aef157ca002f3c329e883e064377e2bb6
# Parent  824543aea6fca1bc3c073ff4528ae6be1943679c
add STM in Jungle map

diff -r 824543aea6fc -r 97d1e67aef15 Jungle.hs
--- a/Jungle.hs	Fri Jan 24 00:15:31 2014 +0900
+++ b/Jungle.hs	Fri Jan 24 06:06:30 2014 +0900
@@ -28,7 +28,7 @@
 import Control.Concurrent.STM
 import Data.Maybe (fromJust)
 
-data Jungle = Jungle { getJungleMap :: (M.Map String Tree) } 
+data Jungle = Jungle { getJungleMap :: (TVar (M.Map String Tree)) } 
 
 data Tree = Tree
           { rootNode :: (TVar Node)
@@ -41,15 +41,18 @@
 type Path = [Int]
 type Position = Int
 
-createJungle :: Jungle
-createJungle = Jungle M.empty
+createJungle :: IO Jungle
+createJungle = atomically $ do
+    map <- newTVar M.empty
+    return (Jungle map)
 
 -- 同じ名前のTreeが存在する場合、上書きする
 -- Eitherなどで失敗させるほうがいいかもしれない
-createTree :: Jungle -> String -> IO Jungle
-createTree (Jungle map) tree_name = atomically $ do
+createTree :: Jungle -> String -> IO ()
+createTree (Jungle tmap) tree_name = atomically $ do
+    map <- readTVar tmap
     tree <- emptyTree tree_name
-    return (Jungle (M.insert tree_name tree map))
+    writeTVar tmap (M.insert tree_name tree map)
 
 emptyTree :: String -> STM Tree
 emptyTree tree_name = do
@@ -59,31 +62,33 @@
 emptyNode :: Node
 emptyNode = Node (M.empty) (M.empty)
 
--- getRootNodeやupdateRootNodeをJungleとTree名を取るようにしたため不要
-getTreeByName :: Jungle -> String -> Maybe Tree
-getTreeByName (Jungle map) tree_name = M.lookup tree_name map
-
 getRootNode :: Jungle -> String -> IO Node
-getRootNode (Jungle map) tree_name = atomically $ readTVar root_node
-  where
-    root_node = case M.lookup tree_name map of
-             Just x -> rootNode x
+getRootNode (Jungle tmap) tree_name = atomically $ do 
+    map <- readTVar tmap
+    readTVar (root_node map)
+    where
+      root_node map = case M.lookup tree_name map of
+                        Just x -> rootNode x
 
 -- ルートノードを更新する
 updateRootNode :: Jungle -> String -> Node -> IO ()
-updateRootNode (Jungle map) tree_name node = atomically $ writeTVar root_node node
+updateRootNode (Jungle tmap) tree_name node = 
+  atomically $ do 
+    map <- readTVar tmap
+    writeTVar (root_node map) node
   where
-    root_node = case M.lookup tree_name map of
-             Just x -> rootNode x
+    root_node map = case M.lookup tree_name map of
+                      Just x -> rootNode x
 
 updateRootNodeWith :: (Node -> Node) -> Jungle -> String -> IO ()
-updateRootNodeWith f (Jungle map) tree_name = 
+updateRootNodeWith f (Jungle tmap) tree_name = 
   atomically $ do
-    n <- readTVar root_node
-    writeTVar root_node (f n)
+    map <- readTVar tmap
+    n <- readTVar (root_node map)
+    writeTVar (root_node map) (f n)
   where
-    root_node = case M.lookup tree_name map of
-             Just x -> rootNode x
+    root_node map = case M.lookup tree_name map of
+                      Just x -> rootNode x
 
 -- 新しい木構造を作成し、最新のルートノードとなるNodeを返す
 -- Pathの位置にNodeが存在しない場合どうするか？
diff -r 824543aea6fc -r 97d1e67aef15 test/ParRead.hs
--- a/test/ParRead.hs	Fri Jan 24 00:15:31 2014 +0900
+++ b/test/ParRead.hs	Fri Jan 24 06:06:30 2014 +0900
@@ -13,13 +13,14 @@
 
 
 main = do
-  new_jungle <- createTree createJungle "test_tree"
-  node <- getRootNode new_jungle "test_tree"
+  jungle <- createJungle
+  createTree jungle "test_tree"
+  node <- getRootNode jungle "test_tree"
   let
-    x = testTree node 7
+    x = testTree node 8
   putStrLn $ show $ size x
-  updateRootNode new_jungle "test_tree" x
-  node2 <- getRootNode new_jungle "test_tree"
+  updateRootNode jungle "test_tree" x
+  node2 <- getRootNode jungle "test_tree"
   t0 <- getCurrentTime
   printTimeSince t0
   r <- evaluate (runEval $ test node2)
@@ -28,30 +29,35 @@
 
 
 test node = do
-    x <- rpar (func node)
-    y <- rpar (func2 node)
-    return (x,y)
+    a <- rpar (func node)
+    b <- rpar (func node)
+    c <- rpar (func node)
+    d <- rpar (func node)
+    e <- rpar (func node)
+    f <- rpar (func node)
+    g <- rpar (func node)
+    h <- rpar (func node)
+    i <- rpar (func node)
+    j <- rpar (func node)
+    k <- rpar (func node)
+    l <- rpar (func node)
+    return (a,b,c,d,e,f,g,h,i,j,k,l)
 
 func :: Node -> Int
 func node = size node
 
-func2 :: Node -> Int
-func2 node = size node2
-  where
-    node2 = addNewChildAt node [0,0] 0
-
 
 -- ある程度の大きさの木を作れる
--- size $ testTree y 1 = 10
--- size $ testTree y 5 = 11742
--- size $ testTree y 7 = 876808
-testTree node h = foldl' (add h) node (concatMap permutations . subsequences $ [0..h])
+-- size $ testTree y 2 = 10
+-- size $ testTree y 6 = 11742
+-- size $ testTree y 8 = 876808
+testTree node h = foldl' (add (h-1)) node (concatMap permutations . subsequences $ [1..h])
   where
-    add w node h = addc node h w
+    add x node h = addc x node h
 
-addc node h w = foldl' (add h) node [0..w] 
-  where
-    add h node pos = addNewChildAt node h pos
+-- x回addNewChildAtする
+addc 0 node h = addNewChildAt node h
+addc x node h = addNewChildAt (addc (x-1) node h) h
   
 printTimeSince t0 = do
   t1 <- getCurrentTime
diff -r 824543aea6fc -r 97d1e67aef15 test/test.hs
--- a/test/test.hs	Fri Jan 24 00:15:31 2014 +0900
+++ b/test/test.hs	Fri Jan 24 06:06:30 2014 +0900
@@ -5,7 +5,8 @@
 import qualified Data.ByteString.Lazy.Char8 as B
 
 tree = do
-    jungle <- createTree createJungle "test"
+    jungle <- createJungle
+    createTree jungle "test"
     node <- getRootNode jungle "test"
     return (add node)