Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.