red-black tree2

import System.IO
--import Data.List as List
import qualified Data.Map as Map
import qualified Data.Set as Set

data Color = Red | Black deriving (Eq)
instance Show(Color) where
    show c
        | c == Red = "0"
        | otherwise = "1"

data BinTree a = Node Color a (BinTree a) (BinTree a) | Leaf deriving (Eq)

instance Show a => Show(BinTree a) where
    show t = show1 t 0 where
        show1 Leaf _ = "\n"
        show1 (Node c x l r) n =
            show1 l (n + 2) ++ (replicate n ' ') ++ (show x)++ show1 r (n + 2)

empty :: BinTree a
empty = Leaf

include :: Ord a => a -> BinTree a -> Bool
include _ Leaf = False
include x (Node _ a left right)
    | x == a = True
    | x > a = include x right
    | otherwise = include x left

insert :: Ord a => BinTree a -> a -> BinTree a
insert tree x = insertOne $ insertLeaf tree x

insertOne :: BinTree a -> BinTree a
insertOne (Node color x left right) = Node Black x left right

insertLeaf :: Ord a => BinTree a -> a -> BinTree a
insertLeaf Leaf x = Node Red x Leaf Leaf
insertLeaf (Node color a left right) x
    | x == a = Node color a left right
    | x > a = balance color a left (insertLeaf right x)
    | otherwise = balance color a (insertLeaf left x) right

find_next (Node _ a left _)
    | left == Leaf = a
    | otherwise = find_next left


delete :: Ord a => a -> BinTree a -> BinTree a
delete x tree = turnB' s
  where
    (s,_) = delete' x tree

delete' :: Ord a => a -> BinTree a -> RBTreeBDel a
delete' _ Leaf = (Leaf, False)
delete' x (Node c y l r) = case compare x y of
    LT -> let (l',d) = delete' x l
              t = Node c y l' r
          in if d then unbalancedR c y l' r else (t, False)
    GT -> let (r',d) = delete' x r
              t = Node c y l r'
          in if d then unbalancedL c y l r' else (t, False)
    EQ -> case r of
        Leaf -> if c == Black then blackify l else (l, False)
        _ -> let next = find_next r
                 (r',d) = delete' next r
                 t = Node c next l r'
             in if d then unbalancedL c next l r' else (t, False)

blackify :: BinTree a -> RBTreeBDel a
blackify s@(Node Red _ _ _) = (turnB s, False)
blackify s = (s, True)

turnR :: BinTree a -> BinTree a
turnR Leaf = error "turnR"
turnR (Node _ x left right) = Node Red x left right

turnB :: BinTree a -> BinTree a
turnB Leaf = error "turnB"
turnB (Node _ x left right) = Node Black x left right

turnB' :: BinTree a -> BinTree a
turnB' Leaf = Leaf
turnB' (Node _ x left right) = Node Black x left right

type RBTreeBDel a = (BinTree a, Bool)

unbalancedL :: Color -> a -> BinTree a -> BinTree a -> RBTreeBDel a
unbalancedL color x left@(Node Black _ _ _) right = (balance Black x (turnR left) right, color == Black)
unbalancedL Black x (Node Red lx ll lr@(Node Black _ _ _)) r = (Node Black lx ll (balance Black x (turnR lr) r), False)

unbalancedR :: Color -> a -> BinTree a -> BinTree a -> (BinTree a, Bool)
unbalancedR color x left right@(Node Black _ _ _) = (balance Black x left (turnR right), color == Black)
unbalancedR Black x l (Node Red rx rl@(Node Black _ _ _) rr) = (Node Black rx (balance Black x l (turnR rl)) rr, False)

balance :: Color -> a -> BinTree a -> BinTree a -> BinTree a
balance Black z (Node Red y (Node Red x a b) c) d = Node Red y (Node Black x a b) (Node Black z c d)
balance Black z (Node Red x a (Node Red y b c)) d = Node Red y (Node Black x a b) (Node Black z c d)
balance Black x a (Node Red y b (Node Red z c d)) = Node Red y (Node Black x a b) (Node Black z c d)
balance Black x a (Node Red z (Node Red y b c) d) = Node Red y (Node Black x a b) (Node Black z c d)
balance color a x b = Node color a x b

listToTree::Ord a => [a] -> BinTree a
listToTree xs = foldl insert Leaf xs

treeToList:: BinTree a -> [a]
treeToList Leaf = []
treeToList (Node _ x l r) = (treeToList l)++[x]++(treeToList r)

treeSort:: Ord a => [a] -> [a]
treeSort = treeToList.listToTree

height:: BinTree a -> Int
height Leaf = 0
height (Node _ _ l r) = 1 + max (height l) (height r)

main = do
    let tree = listToTree [x | x <- [1..13]]
    print $ tree
    --let tree0 = insert tree 18
    --print $ tree0
    let tree1 = delete 10 tree
    print $ tree1
    let tree2 = delete 4 tree1
    print $ tree2
    let tree3 = delete 13 tree2
    print $ tree3
    --let tree4 = insert tree3 10
    --print $ tree4
    --let new_tree = insert tree 7
    --print $ new_tree