mvartree.hs

import Control.Monad
import Control.Concurrent.MVar

type TreeRef a = MVar (MutableTree a)
data MutableTree a = Node { value :: a, left :: TreeRef a, right :: TreeRef a, parent :: TreeRef a }
                     | Leaf { value :: a, parent :: TreeRef a}

treeChangeValue :: MutableTree a -> (a -> a) -> MutableTree a
treeChangeValue (Leaf a p) f = Leaf (f a) p
treeChangeValue (Node a l r p) f = Node (f a) l r p

changeValue :: TreeRef a -> (a -> a) -> IO ()
changeValue treeRef f = isEmptyMVar treeRef >>= (\isEmpty -> changeValue' isEmpty)
            where
                changeValue' True = return ()
                changeValue' False = do
                        node <- readMVar treeRef
                        swapMVar treeRef $ treeChangeValue node f
            
changeValuesToTheRoot :: TreeRef a -> (a -> a) -> IO ()
changeValuesToTheRoot treeRef f = isEmptyMVar treeRef >>= (\isEmpty -> changeValuesToTheRoot' isEmpty)
            where
                changeValuesToTheRoot' True = return ()
                changeValuesToTheRoot' False = do
                        node <- readMVar treeRef
                        swapMVar treeRef $ treeChangeValue node f
                        changeValuesToTheRoot (parent node) f
            
swapValues :: TreeRef a -> TreeRef a -> IO ()
swapValues treeRef1 treeRef2 = isEmptyMVar treeRef1 >>= (\isEmpty1 -> isEmptyMVar treeRef2 >>=
                                                        (\isEmpty2 -> swapValues' isEmpty1 isEmpty2))
            where 
                swapValues' True True = return ()
                swapValues' True False = do
                                    node <- takeMVar treeRef2
                                    putMVar treeRef1 node
                swapValues' False True = swapValues treeRef2 treeRef1
                swapValues' False False = do
                                    node1 <- takeMVar treeRef1
                                    node2 <- takeMVar treeRef2
                                    putMVar treeRef2 node1
                                    putMVar treeRef1 node2
            
main = do
    none <- newEmptyMVar
    leftChild <- newEmptyMVar
    rightChild <- newEmptyMVar
    root <- newMVar $ Node 5 leftChild rightChild none
    putMVar leftChild $ Leaf 1 root
    putMVar rightChild $ Leaf 2 root

    changeValue leftChild (+2)
    
    swapValues leftChild rightChild
    
    changeValuesToTheRoot leftChild (*100)
    
    leftValue <- readMVar leftChild
    rightValue <- readMVar rightChild
    rootValue <- readMVar root
    
    putStrLn $ show $ value leftValue
    putStrLn $ show $ value rightValue
    putStrLn $ show $ value rootValue