150fp-practice.cabal

@@ -1,26 +1,26 @@--- Initial 150fp-practice.cabal generated by cabal init.  For further +-- Initial 150fp-practice.cabal generated by cabal init.  For further -- documentation, see http://haskell.org/cabal/users-guide/  name:                150fp-practice version:             0.1.0.0 synopsis:            Practice problems for Advanced Functional Programming (COMP150FP-FA2013).--- description:         +-- description: homepage:            https://github.com/BurntSushi/150fp-practice license:             PublicDomain license-file:        LICENSE author:              Andrew Gallant maintainer:          jamslam@gmail.com--- copyright:           --- category:            +-- copyright:+-- category: build-type:          Simple cabal-version:       >=1.8  library-  exposed-modules:     Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Q, QC.PQueue, QC.Heap, QC.HeapProps-  -- other-modules:       +  exposed-modules:     Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Q, QC.PQueue, QC.Heap, QC.HeapProps, QC.RBTree+  -- other-modules:   build-depends:       base ==4.6.*, random ==1.0.*, QuickCheck ==2.6.*  executable heapvis   main-is: ./progs/heapvis/Main.hs-  other-modules: Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Heap+  other-modules: Monads.MRand, Monads.Dot, QC.SkewHeap, QC.Heap, QC.RBTree   build-depends: base == 4.6.*, random == 1.0.*, QuickCheck == 2.6.*

QC/RBTree.hs

new file mode 100644@@ -0,0 +1,61 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module QC.RBTree+where++-- much of this code adapted from Functional Pearls+-- Red-Black Trees in a Functional Setting++import Data.Monoid++data Color = Red+           | Black deriving (Eq)++data Ord a => RBTree a = Empty | Node Color (RBTree a) a (RBTree a) deriving+           (Eq, Show)++instance Show Color where+    show Red = "Red"+    show Black = "Black"++instance Ord a => Monoid (RBTree a) where+    mempty = Empty+    mappend = undefined++--this shit is weird+--instance Show a => Show (RBTree a) where+--    show (Node c l v r) = "(" ++ show c ++ show l ++ show v ++ show r ++ ")"+--    show Empty = "Empty"++member :: Ord a => a -> RBTree a -> Bool+member elem Empty = False+member elem (Node _ l x r) | elem < x  = (member elem l)+                           | elem > x  = (member elem r)+                           | elem == x = True++rbify :: Ord a => [a] -> RBTree a+rbify = foldr insert Empty++insert :: Ord a => a -> RBTree a -> RBTree a+insert elem tree = makeBlack (ins tree)+  where ins Empty = Node Red Empty elem Empty+        ins (Node color l val r) | elem < val  = balance color (ins l) val r+                                 | elem == val = Node color l val r+                                 | elem > val  = balance color l val (ins r)++makeBlack :: Ord a => RBTree a -> RBTree a+makeBlack (Node _ l a r) = Node Black l a r++--makeRed :: (Ord a) => RBTree a -> RBTree a+--makeRed (Node _ l a r) = Node Red l a r++balance :: Ord a => Color -> RBTree a -> a -> RBTree a -> RBTree a+balance Black (Node Red (Node Red a x b) y c) z d =+          Node Red (Node Black a x b) y (Node Black c z d)+balance Black (Node Red a x (Node Red b y c)) z d =+          Node Red (Node Black a x b) y (Node Black c z d)+balance Black a x (Node Red (Node Red b y c) z d) =+          Node Red (Node Black a x b) y (Node Black c z d)+balance Black a x (Node Red b y (Node Red c z d)) =+          Node Red (Node Black a x b) y (Node Black c z d)+balance color a x b = Node color a x b

progs/heapvis/Main.hs

@@ -13,6 +13,8 @@ import qualified Monads.Dot as Dot import qualified QC.SkewHeap as SH import qualified QC.Heap as H +import qualified QC.RBTree as RB+ -- | General functions to traverse any heap. class Heapable h where   -- | Returns the "left" node. The left node of a nil node is nil.@@ -28,6 +30,19 @@ class Heapable h where   -- Behavior is undefined if the given heap is empty.   value :: Ord a => h a -> a +instance Heapable RB.RBTree where+    left RB.Empty = RB.Empty+    left (RB.Node _ l x r) = l++    right RB.Empty = RB.Empty+    right (RB.Node _ l x r) = r++    isEmpty RB.Empty = True+    isEmpty _ = False++    value RB.Empty = error "this doesn't make sense"+    value (RB.Node _ _ x _) = x+ instance Heapable SH.Heap where   left SH.Nil = SH.Nil   left n = SH.left n@@ -80,6 +95,7 @@ pickHeap :: [String] -- ^ Command line arguments. pickHeap [] = dotit . SH.heapify pickHeap ["skew"] = dotit . SH.heapify pickHeap ["heap"] = dotit . H.heapify+pickHeap ["rb"] = dotit . RB.rbify pickHeap bunk = error ("unrecognized heap " ++ concat bunk)  -- Outputs a random dot graph using the heap specified.