150fp-practice.cabal

@@ -16,7 +16,7 @@ build-type:          Simple cabal-version:       >=1.8  library-  exposed-modules:     Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Q, QC.PQueue, QC.QueueProps, QC.Heap+  exposed-modules:     Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Q, QC.PQueue, QC.Heap, QC.HeapProps   -- other-modules:          build-depends:       base ==4.6.*, random ==1.0.*, QuickCheck ==2.6.* 

Makefile

@@ -2,11 +2,20 @@ build: 	cabal build 	cp ./dist/build/heapvis/heapvis ./bin/ +clean:+	rm -rf dist+	cabal configure+ docs: 	cabal haddock --hyperlink-source --executables+	rscp ./dist/doc/html/150fp-practice Geils:~/www/burntsushi.net/public_html/docs/haddock  dot-heap:-	bash -c 'imgv <(./bin/heapvis heap | dot -Tpng)'+	bash -c 'imgv -increment 100 <(./bin/heapvis heap | dot -Tpng)'  dot-skew:-	bash -c 'imgv <(./bin/heapvis skew | dot -Tpng)'+	bash -c 'imgv -increment 100 <(./bin/heapvis skew | dot -Tpng)'++push:+	git push origin master+	git push github master

Monads/Dot.hs

@@ -13,8 +13,12 @@ import Text.Printf (printf)  -- | @Node@ corresponds to any value representable as a Dot node. class Node a where+  -- | A uniquely identifying string for this node.   name :: a -> String-  label :: a -> Maybe String -- labels may not contain double quotes++  -- | Labels cannot contain double quotes. If no label is specified,+  -- then `name` will be used instead.+  label :: a -> Maybe String  -- | Every edge is a directed edge from one node to another. data Edge a = Edge { from :: a, to :: a, elabel :: Maybe String }@@ -26,9 +30,21 @@ instance Node SimpleNode where   name = sname   label = slabel +-- | Create a new @SimpleNode@ with a name.+simpleNode :: String -- ^ The name of the node.+              -> SimpleNode+simpleNode name = SimpleNode name Nothing +-- | Same as `simpleNode`, but allows a label independent of the name.+simpleNodeLabel :: String -- ^ The name of the node.+                   -> String -- ^ The label of the node.+                   -> SimpleNode+simpleNodeLabel name label = SimpleNode name (Just label)++-- | @Graph@ corresponds to a graph expressible in the Dot language. data Graph a = Graph { nodes :: [a], edges :: [Edge a] } +-- | Converts a graph to its Dot representation. dot :: Node a => Graph a -> String dot (Graph ns es) = printf "digraph G {\n\t%s\n\t%s\n}" nodes edges   where nodes = intercalate "\n\t" $ map dnode ns@@ -44,6 +60,7 @@ instance Monoid (Graph a) where   mempty = Graph [] []   (Graph ns1 es1) `mappend` (Graph ns2 es2) = Graph (ns1 ++ ns2) (es1 ++ es2) +-- | A monad that constructs values representable in the Dot language. newtype Dotter n a = Dotter { runDotter :: (a, Graph n) }  instance Monad (Dotter n) where@@ -51,30 +68,25 @@ instance Monad (Dotter n) where   Dotter (a, g) >>= f = Dotter (a', g `mappend` g')     where (a', g') = runDotter (f a) -simpleNode :: String -> SimpleNode-simpleNode name = SimpleNode name Nothing--simpleNodeLabel :: String -> String -> SimpleNode-simpleNodeLabel name label = SimpleNode name (Just label)-+-- | Adds a node to the current graph. addNode :: Node a => a -> Dotter a () addNode node = Dotter ((), Graph [node] []) -addEdge :: Node a => a -> a -> Dotter a ()+-- | Adds a directed edge to the current graph.+addEdge :: Node a+           => a -- ^ The "from" node.+           -> a -- ^ The "to" node.+           -> Dotter a () addEdge n1 n2 = Dotter ((), Graph [] [Edge n1 n2 Nothing]) -addEdgeLabel :: Node a => a -> a -> String -> Dotter a ()+-- | Same as `addEdge`, but with an edge label.+addEdgeLabel :: Node a+                => a -- ^ The "from" node.+                -> a -- ^ The "to" node.+                -> String -- ^ The edge label.+                -> Dotter a () addEdgeLabel n1 n2 label = Dotter ((), Graph [] [Edge n1 n2 (Just label)]) +-- | Evaluate an instance of the `Dotter` monad to its Dot representation. eval :: Node a => Dotter a () -> String eval = dot . snd . runDotter--testGraph :: Dotter SimpleNode ()-testGraph = do-  let (n1, n2) = (simpleNode "A", simpleNode "B")-  addNode n1-  addNode n2-  addEdge n1 n2--main :: IO ()-main = putStrLn $ eval testGraph

Monads/MRand.hs

@@ -6,6 +6,7 @@ where  import qualified System.Random as R +-- | A random monad that works with any generator satisfying `RandomGen`. newtype MRand g a = MRand (g -> (a, g))  instance R.RandomGen g => Monad (MRand g) where@@ -14,21 +15,31 @@ instance R.RandomGen g => Monad (MRand g) where                                     MRand m1 = f a                                  in m1 g') +-- | Evaluate an instance of the `MRand` monad with a source of randomness. eval :: R.RandomGen g => MRand g a -> g -> a eval (MRand f) g = fst (f g) +-- | Provides a random value. random :: (R.RandomGen g, R.Random a) => MRand g a random = MRand R.random -randomR :: (R.RandomGen g, R.Random a) => (a, a) -> MRand g a+-- | Provides a random value in a range.+randomR :: (R.RandomGen g, R.Random a)+           => (a, a) -- ^ An inclusive range [lo, hi].+           -> MRand g a randomR r = MRand (R.randomR r) +-- | Provides an infinite list of random values. randoms :: (R.RandomGen g, R.Random a) => MRand g [a] randoms = MRand (\g -> let (g', g'') = R.split g in (R.randoms g', g'')) -randomRs :: (R.RandomGen g, R.Random a) => (a, a) -> MRand g [a]+-- | Provides an infinite list of random values in a range.+randomRs :: (R.RandomGen g, R.Random a)+            => (a, a) -- ^ An inclusive range [lo, hi].+            -> MRand g [a] randomRs r = MRand (\g -> let (g', g'') = R.split g in (R.randomRs r g', g'')) +-- Demonstrates two infinite, independent sources of integers. two :: R.RandomGen g => MRand g ([Int], [Int]) two = do   xs <- randomRs (1, 10)@@ -40,4 +51,3 @@ main = do   let (xs, ys) = eval two g   print $ take 10 xs   print $ take 10 ys-

QC/Heap.hs

@@ -4,16 +4,13 @@ module QC.Heap   ) where -import Control.Monad (liftM)-import Data.List (sort) import Data.Monoid (Monoid, mappend, mempty)-import Test.QuickCheck import Text.Printf (printf) +-- | A boring functional min-heap. data Heap a = Nil             | Node { left :: Heap a, right :: Heap a, value :: a }             deriving Eq-            -- a min-heap  instance Ord a => Monoid (Heap a) where   mempty = empty@@ -28,21 +25,16 @@ instance Show a => Show (Heap a) where           indent d = concat $ replicate d "  "  empty :: Ord a => Heap a-isEmpty :: Ord a => Heap a -> Bool-single :: Ord a => a -> Heap a-insert :: Ord a => Heap a -> a -> Heap a-merge :: Ord a => Heap a -> Heap a -> Heap a-peek :: Ord a => Heap a -> a-delete :: Ord a => Heap a -> Heap a-heapify :: Ord a => [a] -> Heap a- empty = Nil +isEmpty :: Ord a => Heap a -> Bool isEmpty Nil = True isEmpty _   = False +single :: Ord a => a -> Heap a single = Node Nil Nil +insert :: Ord a => Heap a -> a -> Heap a insert Nil x = single x insert n@(Node l r v) x =   if x <= v then Node n Nil x else@@ -53,64 +45,17 @@ insert n@(Node l r v) x =       (Node _ _ lv, Node _ _ rv) ->         if lv <= rv then Node (insert l x) r v else Node l (insert r x) v -merge h Nil = h-merge h (Node l r v) = insert (merge (merge h l) r) v-+peek :: Ord a => Heap a -> a peek Nil = error "cannot peek empty heap" peek (Node _ _ v) = v +delete :: Ord a => Heap a -> Heap a delete Nil = Nil delete (Node l r v) = merge l r +heapify :: Ord a => [a] -> Heap a heapify = foldl insert empty ---- random testing--instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where-  arbitrary = liftM heapify arbitrary--  shrink Nil = []-  shrink h = [delete h]---- peek (insert empty x) == x-prop_single :: Int -> Bool-prop_single x = peek (insert empty x) == x---- peek (heapify xs) == minimum xs-prop_heapify :: [Int] -> Property-prop_heapify xs = not (null xs) ==> peek (heapify xs) == minimum xs---- peek (delete (heapify xs)) == head (tail (sort xs))-prop_delete :: [Int] -> Property-prop_delete xs =-  length xs >= 2 ==> peek (delete (heapify xs)) == head (tail (sort xs))---- peek (foldl merge empty heaps) == minimum (map peek heaps)-prop_merge :: [Heap Int] -> Property-prop_merge heaps =-  not (null heaps) && all (not . isEmpty) heaps-  ==> peek (foldl merge empty heaps) == minimum (map peek heaps)---- forall n . n <= left n && n <= right n-prop_heap :: Heap Int -> Bool-prop_heap Nil = True-prop_heap (Node Nil Nil _) = True-prop_heap (Node (Node _ _ lv) Nil v) = v <= lv-prop_heap (Node Nil (Node _ _ rv) v) = v <= rv-prop_heap (Node (Node _ _ lv) (Node _ _ rv) v) = v <= lv && v <= rv--tests :: [(String, Property)]-tests = [ ("peek (insert empty x) == x", property prop_single)-        , ("peek (heapify xs) == minimum xs", property prop_heapify)-        , ( "peek (delete (heapify xs)) == head (tail (sort xs))"-          , property prop_delete-          )-        , ( "peek (foldl merge empty heaps) == minimum (map peek heaps)"-          , property prop_merge-          )-        , ("forall n . n <= left n && n <= right n", property prop_heap)-        ]--main :: IO ()-main = mapM_ (\(s, p) -> do { putStrLn s; quickCheck p}) tests+merge :: Ord a => Heap a -> Heap a -> Heap a+merge h Nil = h+merge h (Node l r v) = insert (merge (merge h l) r) v

QC/HeapProps.hs

new file mode 100644@@ -0,0 +1,56 @@+module QC.HeapProps where++import Data.List (sort)+import Control.Monad (liftM)+import Test.QuickCheck++-- import QC.Heap +import QC.SkewHeap++instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where+  arbitrary = liftM heapify arbitrary++  shrink Nil = []+  shrink h = [delete h]++-- peek (insert empty x) == x+prop_single :: Int -> Bool+prop_single x = peek (insert empty x) == x++-- peek (heapify xs) == minimum xs+prop_heapify :: [Int] -> Property+prop_heapify xs = not (null xs) ==> peek (heapify xs) == minimum xs++-- peek (delete (heapify xs)) == head (tail (sort xs))+prop_delete :: [Int] -> Property+prop_delete xs =+  length xs >= 2 ==> peek (delete (heapify xs)) == head (tail (sort xs))++-- peek (foldl merge empty heaps) == minimum (map peek heaps)+prop_merge :: [Heap Int] -> Property+prop_merge heaps =+  not (null heaps) && all (not . isEmpty) heaps+  ==> peek (foldl merge empty heaps) == minimum (map peek heaps)++-- forall n . n <= left n && n <= right n+prop_heap :: Heap Int -> Bool+prop_heap Nil = True+prop_heap (Node Nil Nil _) = True+prop_heap (Node (Node _ _ lv) Nil v) = v <= lv+prop_heap (Node Nil (Node _ _ rv) v) = v <= rv+prop_heap (Node (Node _ _ lv) (Node _ _ rv) v) = v <= lv && v <= rv++tests :: [(String, Property)]+tests = [ ("peek (insert empty x) == x", property prop_single)+        , ("peek (heapify xs) == minimum xs", property prop_heapify)+        , ( "peek (delete (heapify xs)) == head (tail (sort xs))"+          , property prop_delete+          )+        , ( "peek (foldl merge empty heaps) == minimum (map peek heaps)"+          , property prop_merge+          )+        , ("forall n . n <= left n && n <= right n", property prop_heap)+        ]++main :: IO ()+main = mapM_ (\(s, p) -> do { putStrLn s; quickCheck p}) tests

QC/PQueue.hs

@@ -34,9 +34,9 @@ put (Q heap clock) x = Q (H.insert heap (Clocked clock x)) (clock + 1) get = value . H.peek . elems rest (Q heap clock) = Q (H.delete heap) clock -instance (Arbitrary a, Ord a) => Arbitrary (Q a) where-  arbitrary = liftM2 Q arbitrary arbitrary--instance Arbitrary a => Arbitrary (Clocked a) where-  arbitrary = liftM2 Clocked arbitrary arbitrary+-- instance (Arbitrary a, Ord a) => Arbitrary (Q a) where +  -- arbitrary = liftM2 Q arbitrary arbitrary +--  +-- instance Arbitrary a => Arbitrary (Clocked a) where +  -- arbitrary = liftM2 Clocked arbitrary arbitrary  

QC/Q.hs

@@ -6,6 +6,7 @@ import Control.Monad (liftM2) import Test.QuickCheck import Text.Printf (printf)   +-- | A queue with O(1) `put` and amortized O(1) `get` operations. data Q a = Q { front :: [a], back :: [a] }            -- corresponds to front ++ reverse back @@ -13,39 +14,50 @@ instance Show a => Show (Q a) where   show (Q xs ys) = printf "(F: %s, B: %s)" (show xs) (show ys)  empty :: Q a-isEmpty :: Q a -> Bool-put  :: Q a -> a -> Q a-get  :: Q a -> a  -- defined on nonempty queue only-rest :: Q a -> Q a -- defined on nonempty queue only- empty = Q [] [] +isEmpty :: Q a -> Bool isEmpty q = null (front q) && null (back q) --- put q a = Q [] (a : back q) +-- | Adds an element to the back of the queue.+put  :: Q a -> a -> Q a put q a = Q (front q) (a : back q)+-- put q a = Q [] (a : back q) -- nr's error #1 +-- | Returns an element from the top of the queue.+-- Calling @get@ on an empty queue results in a runtime error.+get  :: Q a -> a  -- defined on nonempty queue only get (Q [] [])    = error "get from empty queue" get (Q [] as)    = get (Q (reverse as) []) get (Q (a:as) _) = a +-- | Returns the given queue with the top of the queue removed.+-- Calling @rest@ on an empty queue results in a runtime error.+rest :: Q a -> Q a -- defined on nonempty queue only rest (Q [] [])    = error "rest from empty queue" rest (Q [] as)    = rest (Q (reverse as) []) rest (Q (a:as) bs) = Q as bs--- rest (Q (a:as) _) = Q as [] +-- rest (Q (a:as) _) = Q as [] -- nr's error #2   -- random testing +-- | QTerms represents a series of *valid* combinations of queue constructors. data QTerms = Empty             | Rest QTerms             | Put QTerms             deriving Show --- max # of queue terms -> all valid combos -enumerate :: Int -> [QTerms]+-- | Enumerates all valid queues up to a certain number of constructor+-- applications.+enumerate :: Int -- ^ Maximum number of queue terms to enumerate.+             -> [QTerms] -- ^ All valid permutations of queue constructors. enumerate = e [] Empty 0-  where e :: [QTerms] -> QTerms -> Int -> Int -> [QTerms]+  where e :: [QTerms] -- ^ Accumulated permutations.+             -> QTerms -- ^ Initial set of queue terms.+             -> Int -- ^ Number of items in the queue.+             -> Int -- ^ Number of queue terms left to generate.+             -> [QTerms]         e perms _ _ 0 = perms         e perms ts 0 n = e (next:perms) next 1 (n-1)           where next = Put ts@@ -56,21 +68,28 @@ enumerate = e [] Empty 0 instance Arbitrary QTerms where   arbitrary = elements $ enumerate 15 +  -- Removing the outer most constructor application always results+  -- in a valid queue.   shrink Empty = []   shrink (Rest ts) = [ts]   shrink (Put ts) = [ts] +-- | Constructs a queue given a list of values and a construction of+-- a queue via `QTerms`. asQ :: [a] -> QTerms -> Q a asQ _ Empty = empty asQ as (Rest ts) = rest $ asQ as ts asQ (a:as) (Put ts) = put (asQ as ts) a +-- | Convenience function for building a queue of integers. intQ :: QTerms -> Q Int intQ = asQ [1..] +-- | Returns the last item in a queue. lastItem :: Ord a => Q a -> a lastItem q = if isEmpty (rest q) then get q else lastItem (rest q) +-- | Drains all of the items in the queue and returns the empty queue. drain :: Ord a => Q a -> Q a drain q   | isEmpty q = empty

QC/QueueProps.hs

deleted file mode 100644@@ -1,47 +0,0 @@-module QC.QueueProps where--import Test.QuickCheck (Property, property, quickCheck)---- import Q -import QC.PQueue--lastItem :: Ord a => Q a -> a-lastItem q = if isEmpty (rest q) then get q else lastItem (rest q)--drain :: Ord a => Q a -> Q a-drain q-  | isEmpty q = empty-  | otherwise = drain (rest q)---- get (put empty x) == x-prop_empty :: Int -> Bool-prop_empty x = get (put empty x) == x---- lastItem (put queue x) == x--- This is not true for priority queues!-prop_last :: Q Int -> Int -> Bool-prop_last q x = lastItem (put q x) == x---- isEmpty (drain q) == true-prop_drainable :: Q Int -> Bool-prop_drainable q = isEmpty (drain q)---- get (rest (put (put empty x) y)) == y-prop_puts :: (Int, Int) -> Bool-prop_puts (x, y) = get (rest (put (put empty x) y)) == y---- get (put (rest (put (put empty x) y)) z) == y-prop_restPuts :: (Int, Int, Int) -> Bool-prop_restPuts (x, y, z) = get (put (rest (put (put empty x) y)) z) == y--tests :: [(String, Property)]-tests = [ ("empty", property prop_empty)-        , ("last", property prop_last)-        , ("drainable", property prop_drainable)-        , ("puts", property prop_puts)-        , ("restPuts", property prop_restPuts)-        ]--main :: IO ()-main = mapM_ (\(s, p) -> do { putStrLn s; quickCheck p}) tests-

QC/SkewHeap.hs

@@ -4,16 +4,13 @@ module QC.SkewHeap   ) where -import Control.Monad (liftM)-import Data.List (sort) import Data.Monoid (Monoid, mappend, mempty)-import Test.QuickCheck import Text.Printf (printf) +-- | A skew min-heap. data Heap a = Nil             | Node { left :: Heap a, right :: Heap a, value :: a }             deriving Eq-            -- a min-heap  instance Ord a => Monoid (Heap a) where   mempty = empty@@ -28,85 +25,33 @@ instance Show a => Show (Heap a) where           indent d = concat $ replicate d "  "  empty :: Ord a => Heap a-isEmpty :: Ord a => Heap a -> Bool-single :: Ord a => a -> Heap a-insert :: Ord a => Heap a -> a -> Heap a-merge :: Ord a => Heap a -> Heap a -> Heap a-peek :: Ord a => Heap a -> a-delete :: Ord a => Heap a -> Heap a-heapify :: Ord a => [a] -> Heap a- empty = Nil +isEmpty :: Ord a => Heap a -> Bool isEmpty Nil = True isEmpty _   = False +single :: Ord a => a -> Heap a single = Node Nil Nil +insert :: Ord a => Heap a -> a -> Heap a insert h = merge h . single +peek :: Ord a => Heap a -> a peek Nil = error "cannot peek empty heap" peek (Node _ _ v) = v +delete :: Ord a => Heap a -> Heap a delete Nil = Nil delete (Node l r v) = merge l r +heapify :: Ord a => [a] -> Heap a heapify = foldl insert empty  -- | Implements the alternating left/right subtree merge which makes -- this a skew tree.+merge :: Ord a => Heap a -> Heap a -> Heap a merge Nil h = h merge h Nil = h merge n1 n2 = Node (merge (right s) b) (left s) (value s)   where (s, b) = if value n1 <= value n2 then (n1, n2) else (n2, n1)----- random testing--instance (Arbitrary a, Ord a) => Arbitrary (Heap a) where-  arbitrary = liftM heapify arbitrary--  shrink Nil = []-  shrink h = [delete h]---- peek (insert empty x) == x-prop_single :: Int -> Bool-prop_single x = peek (insert empty x) == x---- peek (heapify xs) == minimum xs-prop_heapify :: [Int] -> Property-prop_heapify xs = not (null xs) ==> peek (heapify xs) == minimum xs---- peek (delete (heapify xs)) == head (tail (sort xs))-prop_delete :: [Int] -> Property-prop_delete xs =-  length xs >= 2 ==> peek (delete (heapify xs)) == head (tail (sort xs))---- peek (foldl merge empty heaps) == minimum (map peek heaps)-prop_merge :: [Heap Int] -> Property-prop_merge heaps =-  not (null heaps) && all (not . isEmpty) heaps-  ==> peek (foldl merge empty heaps) == minimum (map peek heaps)---- forall n . n <= left n && n <= right n-prop_heap :: Heap Int -> Bool-prop_heap Nil = True-prop_heap (Node Nil Nil _) = True-prop_heap (Node (Node _ _ lv) Nil v) = v <= lv-prop_heap (Node Nil (Node _ _ rv) v) = v <= rv-prop_heap (Node (Node _ _ lv) (Node _ _ rv) v) = v <= lv && v <= rv--tests :: [(String, Property)]-tests = [ ("peek (insert empty x) == x", property prop_single)-        , ("peek (heapify xs) == minimum xs", property prop_heapify)-        , ( "peek (delete (heapify xs)) == head (tail (sort xs))"-          , property prop_delete-          )-        , ( "peek (foldl merge empty heaps) == minimum (map peek heaps)"-          , property prop_merge-          )-        , ("forall n . n <= left n && n <= right n", property prop_heap)-        ]--main :: IO ()-main = mapM_ (\(s, p) -> do { putStrLn s; quickCheck p}) tests