fork download
copy 
  1. data Color = Blk | Red
  2.  
  3. data Tree a = Empty | Node Color (Tree a) a (Tree a)
  4.  
  5. instance Show a => Show (Tree a) where
  6.     show Empty = ""
  7.     show (Node Blk nl n nr) = "(" ++ show nl ++ " " ++ show n ++ " " ++ show nr ++ ")"
  8.     show (Node Red nl n nr) = "{" ++ show nl ++ " " ++ show n ++ " " ++ show nr ++ "}"
  9.  
  10. insert :: Ord a => a -> Tree a -> Tree a
  11. insert x y = let (Node _ nl n nr) = insert' x y in Node Blk nl n nr
  12.  
  13. insert' :: Ord a => a -> Tree a -> Tree a
  14. insert' x Empty = Node Red Empty x Empty
  15.  
  16. insert' x y@(Node col nl n nr) = case compare x n of
  17.     LT -> fix (Node col (insert' x nl) n nr)
  18.     GT -> fix (Node col nl n (insert' x nr))
  19.     EQ -> y
  20.  
  21. -- This function has nothing to do with fixed points :)
  22. -- It fixes intermediate trees to maintain the invariants.
  23. fix :: Tree a -> Tree a
  24.  
  25. -- red left left with red uncle
  26. fix (Node Blk (Node Red nn@(Node Red _ _ _) p pr) g (Node Red ul u ur)) =
  27.      Node Red (Node Blk nn                  p pr) g (Node Blk ul u ur) 
  28.  
  29. -- red right left with red uncle
  30. fix (Node Blk (Node Red ul u ur) g (Node Red nn@(Node Red _ _ _) p pr)) =
  31.      Node Red (Node Blk ul u ur) g (Node Blk nn                  p pr)
  32.  
  33. -- red left right with red uncle
  34. fix (Node Blk (Node Red pl p nn@(Node Red _ _ _)) g (Node Red ul u ur)) =
  35.      Node Red (Node Blk pl p nn                 ) g (Node Blk ul u ur) 
  36.  
  37. -- red right right with red uncle
  38. fix (Node Blk (Node Red ul u ur) g (Node Red pl p nn@(Node Red _ _ _))) =
  39.      Node Red (Node Blk ul u ur) g (Node Blk pl p nn                 )
  40.  
  41. -- red left left with black uncle
  42. fix (Node Blk (Node Red nn@(Node Red _ _ _) p           pr) g uu) =
  43.      Node Blk           nn                  p (Node Red pr  g uu)
  44.  
  45. -- red right right with black uncle
  46. fix (Node Blk           uu g (Node Red pl  p nn@(Node Red _ _ _))) =
  47.      Node Blk (Node Red uu g           pl) p nn
  48.  
  49. -- red left right with black uncle
  50. fix (Node Blk (Node Red pl p (Node Red nl  n           nr)) g uu) =
  51.      Node Blk (Node Red pl p           nl) n (Node Red nr   g uu)
  52.  
  53. -- red right left with black uncle
  54. fix (Node Blk           uu g (Node Red (Node Red nl  n           nr) p pr)) =
  55.      Node Blk (Node Red uu g                     nl) n (Node Red nr  p pr)
  56.  
  57. fix t = t
  58.  
  59. tree xs = foldl (flip insert) Empty xs
  60.  
  61. test = [89,32,31,65,20,94,25,45,60,39,60,64,99,69,33]
  62.  
  63. main = print (tree test)
  64.  
Success #stdin #stdout 0s 4560KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
({({ 20 } 25 { 31 }) 32 ({ 33 } 39 { 45 })} 60 {({ 64 } 65 { 69 }) 89 ( 94 { 99 })})
https://ideone.com/cGQNL6
FredOverflow's first attempt at RB trees
language:
Haskell (ghc 8.4.4)
created:
9 years ago
visibility:
secret

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!