Advertisement
NLinker

RB tree insert only (debug)

Jul 9th, 2017
429
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. {-# LANGUAGE DeriveGeneric #-}
  2.  
  3. module Tree where
  4.  
  5. import Debug.Trace
  6. import Control.Monad (foldM)
  7. import GHC.Generics (Generic)
  8. import Control.DeepSeq (NFData, force)
  9.  
  10. data Color = R | B
  11.   deriving (Show, Eq, Generic)
  12. data Tree a = E | T Color (Tree a) a (Tree a)
  13.   deriving (Show, Eq, Generic)
  14.  
  15. instance NFData Color
  16. instance (NFData a) => NFData (Tree a)
  17.  
  18. insert :: (NFData a, Show a, Ord a) => a -> Tree a -> Tree a
  19. insert x t =
  20.   let T _ a y b = ins 0 t
  21.   in T B (force a) y (force b)
  22.   where
  23.     ins i u
  24.       | trace (indent i ++ "[ins " ++ show x ++ " " ++ desc u ++ "]") False = undefined
  25.     ins _ E = T R E x E
  26.     ins i s@(T col a y b)
  27.       | x < y =
  28.         let bt = balance (i + 1) col (ins (i + 1) a) y b
  29.         in trace (indent (i + 1) ++ "   => " ++ desc bt) bt
  30.       | x > y =
  31.         let bt = balance (i + 1) col a y (ins (i + 1) b)
  32.         in trace (indent (i + 1) ++ "   => " ++ desc bt) bt
  33.       | otherwise = s
  34.  
  35. desc :: Show a => Tree a -> String
  36. desc E = "E"
  37. desc t = "(" ++ show t ++ ")"
  38.  
  39. indent :: Int -> String
  40. indent i = concat $ replicate i "  "
  41.  
  42. balance :: Show a => Int -> Color -> Tree a -> a -> Tree a -> Tree a
  43. balance i c t1 x t2 | trace (indent i ++ "[balance " ++ show c ++ " " ++ desc t1 ++ " " ++ show x ++ " " ++ desc t2 ++ "]") False = undefined
  44. balance _ B (T R (T R a x b) y c ) z d = T R (T B a x b) y (T B c z d)
  45. balance _ B (T R a x (T R b y c)) z d  = T R (T B a x b) y (T B c z d)
  46. balance _ B a x (T R (T R b y c) z d ) = T R (T B a x b) y (T B c z d)
  47. balance _ B a x (T R b y (T R c z d))  = T R (T B a x b) y (T B c z d)
  48. balance _ col a x b = T col a x b
  49.  
  50. test :: IO ()
  51. test = do
  52.   let xs = [1..7] :: [Integer]
  53.   ts <- foldM doStuff E xs :: IO (Tree Integer)
  54.   putStrLn $ ">>> final = " ++ show ts
  55.   where
  56.     doStuff t x = do
  57.       let t' = insert x t
  58.      putStrLn $ ">>> insert x t = " ++ show t'
  59.       return t'
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement