-- 2-3 trees

data Tree a = Zero a | Succ (Tree (Node a))
  deriving Show
data Node a = Node2 a a | Node3 a a a
  deriving Show

-- finger trees

data FingerTree a = Empty
                  | Single a
                  | Deep (Digit a) (FingerTree (Node a)) (Digit a)
  deriving Show     

type Digit a = [a]

infixr 5 <|
(<|) :: a -> FingerTree a -> FingerTree a
a <| Empty                  = Single a
a <| Single b               = Deep [a] Empty [b]
a <| Deep [b, c, d, e] m sf = Deep [a, b] (Node3 c d e <| m) sf
a <| Deep pr m sf           = Deep ([a] ++ pr) m sf

infixl 5 |>
(|>) :: FingerTree a -> a -> FingerTree a
Empty |> a                  = Single a
Single a |> b               = Deep [a] Empty [b]
Deep pr m [a, b, c, d] |> e = Deep pr (m |> Node3 a b c) [d, e]
Deep pr m sf |> a           = Deep pr m (sf ++ [a])

-- deconstruction

data ViewL s a = NilL | ConsL a (s a) 
  deriving Show 

viewL :: FingerTree a -> ViewL FingerTree a
viewL Empty          = NilL
viewL (Single x)     = ConsL x Empty
viewL (Deep pr m sf) = ConsL (head pr) (deepL (tail pr) m sf)

deepL :: [a] -> FingerTree (Node a) -> Digit a -> FingerTree a
deepL [] m sf = case viewL m of
                  NilL       -> toTree sf
                  ConsL a m' -> Deep (toList a) m' sf
deepL pr m sf = Deep pr m sf

toTree = foldr (<|) Empty
toList (Node2 x y) = [x,y]
toList (Node3 x y z) = [x,y,z]

isEmpty :: FingerTree a -> Bool
isEmpty x = case viewL x of 
              NilL      -> True
              ConsL _ _ -> False

headL :: FingerTree a -> a
headL x = case viewL x of 
            ConsL a _ -> a

tailL :: FingerTree a -> FingerTree a
tailL x = case viewL x of 
            ConsL _ y -> y