module A2 where
import Data.IORef
-- A few simple Haskell exercises...
-------------------------------------------------------------------------------
-- Binary trees
data Tree a = Leaf a | Branch a (Tree a) (Tree a)
t1 = Leaf 1
t2 = Leaf 2
t3 = Branch 3 t1 t2
t4 = Branch 4 t3 t3
t5 = Leaf "one"
t6 = Leaf "two"
t7 = Branch "three" t5 t6
t8 = Branch "four" t7 t7
preorder, inorder, postorder :: Tree a -> [a]
preorder (Leaf a) = [a]
preorder (Branch a t1 t2) = [a] ++ preorder t1 ++ preorder t2
inorder (Leaf a) = [a]
inorder (Branch a t1 t2) = inorder t1 ++ [a] ++ inorder t2
postorder (Leaf a) = [a]
postorder (Branch a t1 t2) = postorder t1 ++ postorder t2 ++ [a]
-------------------------------------------------------------------------------
-- Reversing a list using append
rev :: [a] -> [a]
rev [] = []
rev (x:xs) = rev xs ++ [x]
-------------------------------------------------------------------------------
-- Higher-order functions
mirror :: ([a] -> [b]) -> [a] -> [b]
mirror f = rev . f . rev
takeRight, dropRight :: Int -> [a] -> [a]
takeRight = mirror . take
dropRight = mirror . drop
-------------------------------------------------------------------------------
-- More higher-order functions
generate :: (Int -> Int) -> [(Int,Int)]
generate f = [ (n, f n) | n <- nats ]
where nats = [0..]
-------------------------------------------------------------------------------
-- In-place list reversal
data RList a = Nil | Cons a (IORef (RList a))
{--
We are usually given a pointer A to an RList. We maintain the invariant that
our lists are sorted. Our data typically looks like:
A --> Cons 1 (Pointer B)
B --> Cons 2 (Pointer C)
C --> Cons 4 (Pointer D)
D --> Nil
To get back a regular list, we simply chase the pointers.
--}
readRList :: IORef (RList a) -> IO [a]
readRList pxs =
do xs <- readIORef pxs
case xs of
Nil -> return []
Cons y pys -> do ys <- readRList pys
return (y:ys)
{--
To insert an element 3 in the list above, we scan the list as long as 3 is
bigger than the current element. When 3 is smaller (or equal) than the
current element (or we reach the end of the list), we insert 3 in front of
the current element.
A --> Cons 1 (Pointer B)
B --> Cons 2 (Pointer C)
C --> Cons 4 (Pointer D)
-- stop when you read the contents of C and
-- update the contents of pointer C with
-- (Cons 3 (newRef (oldcontents of C)))
D --> Nil
i.e. the new list becomes:
A --> Cons 1 (Pointer B)
B --> Cons 2 (Pointer C)
C --> Cons 3 (Pointer X)
X --> Cons 4 (Pointer D)
D --> Nil
--}
insertRList :: Ord a => a -> IORef (RList a) -> IO ()
insertRList x pxs =
do xs <- readIORef pxs
case xs of
Nil -> insertInFrontOf x pxs
Cons y pys | x <= y -> insertInFrontOf x pxs
| x > y -> insertRList x pys
insertInFrontOf :: a -> IORef (RList a) -> IO ()
insertInFrontOf x pxs =
do xs <- readIORef pxs
npxs <- newIORef xs
writeIORef pxs (Cons x npxs)
{--
To reverse a list in place. Consider the list pointed to by A:
A --> Cons 1 (Pointer B)
B --> Cons 2 (Pointer C)
C --> Cons 3 (Pointer D)
D --> Nil
we would like to change the pointers as shown below and return D:
A --> Nil
B --> Cons 1 (Pointer A)
C --> Cons 2 (Pointer B)
D --> Cons 3 (Pointer C)
--}
revR :: IORef (RList a) -> IO (IORef (RList a))
revR pxs =
do xs <- readIORef pxs
case xs of
-- we are given an empty list; nothing to do
Nil -> return pxs
-- we are given a non-empty list; set the first pointer to Nil;
-- start a loop which always maintains:
-- the (old) previous pointer (pxs) which must become the next pointer
-- after reversing
-- the contents of the current cell (y)
-- the current next pointer (pys) which allows to advance the loop
-- to the next iteration
Cons y pys -> do writeIORef pxs Nil; loop pxs y pys
where loop pxs y pys =
do ys <- readIORef pys
writeIORef pys (Cons y pxs)
case ys of
Nil -> return pys
Cons z pzs -> loop pys z pzs
-- A simple test case
test = do pxs <- newIORef Nil
insertRList 8 pxs
insertRList 9 pxs
insertRList 10 pxs
insertRList 1 pxs
insertRList 2 pxs
insertRList 3 pxs
insertRList 4 pxs
insertRList 5 pxs
insertRList 6 pxs
insertRList 7 pxs
ys <- readRList pxs
pzs <- revR pxs
zs <- readRList pzs
print (ys,zs)