commit 55af38a07988553ffc7709dafe75c3a852ed3523
Author: Jared Tobin <jared@jtobin.ca>
Date: Wed, 19 Nov 2014 22:51:46 +1300
Initial commit.
Diffstat:
| A | Stack.hs | | | 63 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | Tree.hs | | | 114 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
2 files changed, 177 insertions(+), 0 deletions(-)
diff --git a/Stack.hs b/Stack.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module Stack where
+
+import Prelude hiding (head, tail)
+
+data Stack a = Nil | Cons a (Stack a) deriving (Eq, Show)
+
+instance Functor Stack where
+ fmap _ Nil = Nil
+ fmap f (Cons h t) = Cons (f h) (fmap f t)
+
+isEmpty :: Stack a -> Bool
+isEmpty Nil = True
+isEmpty _ = False
+
+empty :: Stack a
+empty = Nil
+
+cons :: a -> Stack a -> Stack a
+cons = Cons
+
+head :: Stack a -> Maybe a
+head Nil = Nothing
+head (Cons h _) = return h
+
+tail :: Stack a -> Maybe (Stack a)
+tail Nil = Nothing
+tail (Cons _ t) = return t
+
+fromList :: [a] -> Stack a
+fromList = foldr Cons Nil
+
+toList :: Stack a -> [a]
+toList Nil = []
+toList (Cons h t) = h : toList t
+
+append :: Stack a -> Maybe (Stack a) -> Maybe (Stack a)
+append xs ys
+ | isEmpty xs = ys
+ | otherwise = do
+ h <- head xs
+ txs <- tail xs
+ t <- append txs ys
+ return (cons h t)
+
+update :: Stack a -> Int -> a -> Maybe (Stack a)
+update Nil _ _ = Nothing
+update (Cons h t) j y
+ | j < 0 = Nothing
+ | j == 0 = return (Cons y t)
+ | otherwise = do
+ nt <- update t (pred j) y
+ return (Cons h nt)
+
+-- exercise 2.1
+suffixes :: Stack a -> Stack (Stack a)
+suffixes Nil = Nil
+suffixes (Cons _ t) = Cons t (suffixes t)
+
+test :: Stack Int
+test = fromList [1..10]
+
diff --git a/Tree.hs b/Tree.hs
@@ -0,0 +1,114 @@
+{-# OPTIONS_GHC -Wall #-}
+
+module Tree where
+
+import Data.Maybe
+import Prelude hiding (lookup)
+
+data Tree a = Leaf | Node (Tree a) a (Tree a) deriving (Eq, Show)
+
+empty :: Tree a
+empty = Leaf
+
+insert :: Ord a => a -> Tree a -> Tree a
+insert x Leaf = Node Leaf x Leaf
+insert x t@(Node l e r) = case compare x e of
+ EQ -> t
+ LT -> Node (insert x l) e r
+ GT -> Node l e (insert x r)
+
+member :: Ord a => a -> Tree a -> Bool
+member _ Leaf = False
+member x (Node l e r) = case compare x e of
+ EQ -> True
+ LT -> member x l
+ GT -> member x r
+
+fromList :: Ord a => [a] -> Tree a
+fromList = foldr insert empty
+
+test :: Tree Int
+test = fromList [5..10]
+
+-- exercise 2.2 (max d + 1 comparisons)
+altMember :: Ord a => a -> Tree a -> Bool
+altMember x t = go t Nothing where
+ go (Node l e r) acc
+ | x < e = go l acc
+ | otherwise = go r (Just e)
+ go Leaf Nothing = False
+ go Leaf (Just e) = e == x
+
+-- exercise 2.3 (no unnecessary copying)
+altInsert :: Ord a => a -> Tree a -> Tree a
+altInsert x t = fromMaybe t (go t) where
+ go Leaf = return (Node Leaf x Leaf)
+ go (Node l e r) = case compare x e of
+ EQ -> Nothing
+ LT -> fmap (\alt -> Node alt e r) (go l)
+ GT -> fmap (\alt -> Node l e alt) (go r)
+
+-- exercise 2.4 (no unnecessary copying, max d + 1 comparisons)
+efficientInsert :: Ord a => a -> Tree a -> Tree a
+efficientInsert x t = fromMaybe t (go t Nothing) where
+ go (Node l e r) acc
+ | x < e = fmap (\alt -> Node alt e r) (go l acc)
+ | otherwise = fmap (\alt -> Node l e alt) (go r (Just e))
+ go Leaf (Just e)
+ | e == x = Nothing
+ | otherwise = go Leaf Nothing
+ go Leaf Nothing = return (Node Leaf x Leaf)
+
+-- exercise 2.5a (balanced binary trees of depth n)
+completeDepth :: Ord a => a -> Int -> Tree a
+completeDepth x n
+ | n <= 0 = Leaf
+ | otherwise =
+ let t = completeDepth x (pred n)
+ in Node t x t
+
+-- exercise 2.5b (mostly-balanced binary trees of size n)
+completeSize :: Ord a => a -> Int -> Tree a
+completeSize x n
+ | n <= 0 = Leaf
+ | odd n =
+ let t = completeSize x (n `quot` 2)
+ in Node t x t
+ | otherwise =
+ let l = completeSize x (n `quot` 2)
+ r = completeSize x (n `quot` 2 - 1)
+ in Node l x r
+
+-- exercise 2.6 (finite map using tree)
+newtype Bin k v = Bin (k, v) deriving Show
+
+instance Eq k => Eq (Bin k v) where
+ Bin (k0, _) == Bin (k1, _) = k0 == k1
+
+instance Ord k => Ord (Bin k v) where
+ compare (Bin (k0, _)) (Bin (k1, _)) = compare k0 k1
+
+newtype FiniteMap k v = FiniteMap (Tree (Bin k v)) deriving (Eq, Show)
+
+emptyMap :: FiniteMap k v
+emptyMap = FiniteMap Leaf
+
+bind :: Ord k => k -> v -> FiniteMap k v -> FiniteMap k v
+bind k v (FiniteMap m) = FiniteMap (insert' (Bin (k, v)) m) where
+ insert' x Leaf = Node Leaf x Leaf
+ insert' x (Node l e r) = case compare x e of
+ EQ -> Node l x r
+ LT -> Node (insert' x l) e r
+ GT -> Node l e (insert' x r)
+
+lookup :: Ord k => k -> FiniteMap k v -> Maybe v
+lookup k (FiniteMap m) = lookup' m where
+ lookup' Leaf = Nothing
+ lookup' (Node l (Bin (key, v)) r) = case compare k key of
+ EQ -> Just v
+ LT -> lookup' l
+ GT -> lookup' r
+
+testMap :: FiniteMap Char Int
+testMap = bind 'b' 2 (bind 'a' 1 emptyMap)
+
