module AATree where

data AATree a = Node {
    level :: Int,
    val :: a,
    left :: AATree a,
    right :: AATree a
    } | Nil deriving (Show, Eq)

instance Foldable AATree where
    foldMap f Nil = mempty
    foldMap f (Node n v l r) = foldMap f l `mappend` f v `mappend` foldMap f r

skew (Node n v (Node ln lv ll lr) r)
    | ln == n = Node ln lv ll (Node n v lr r)
skew t = t

split (Node n v l (Node rn rv rl rr@(Node rrn _ _ _)))
    | rrn == n = Node (n+1) rv (Node n v l rl) rr
split t = t

insert Nil nv = Node 1 nv Nil Nil
insert t@(Node n v l r) nv
    | nv == v = t
    | nv < v = split.skew $ Node n v (insert l nv) r
    | otherwise = split.skew $ Node n v l (insert r nv)

lvl Nil = 0
lvl (Node n _ _ _) = n

tpred (Node _ v _ Nil) = v
tpred (Node _ v _ r) = tpred r

tsucc (Node _ v Nil _) = v
tsucc (Node _ v l _) = tsucc l

declvl (Node n v l Nil) 
    | s < n = Node s v l Nil
    where s = 1 + lvl l
declvl (Node n v l (Node rn rv rl rr))
    | s < n && s < rn = Node s v l (Node (min rn s) rv rl rr)
    where s = 1 + min (lvl l) rn
declvl t = t

remove (Node n v l r) ov
    | ov > v = Node n v l (delete r ov)
    | ov < v = Node n v (delete l ov) r
remove (Node n v Nil Nil) ov | ov == v = Nil
remove (Node n v Nil r) ov | ov == v = Node n s Nil (delete r s)
    where s = tsucc r
remove (Node n v l r) ov | ov == v = Node n p (delete l p) r
    where p = tpred l
remove t ov = t

delete Nil ov = Nil
delete t ov
    | a == Nil = Nil
    | right a == Nil = let Node n v l r = split a in Node n v l (split r)
    | otherwise = 
        let Node n v l r = a
            Node rn rv rl rr = skew r
            Node b c d e = split $ Node n v l (Node rn rv rl (skew rr))
        in Node b c d (split e)
    where a = skew (declvl (remove t ov))

aasort xs = foldr (:) [] $ foldl insert Nil xs