init

1 files changed, 66 insertions, 0 deletions

diff --git a/AATree/AATree.hs b/AATree/AATree.hs
new file mode 100644
index 0000000..72698f7
--- /dev/null
+++ b/AATree/AATree.hs
@@ -0,0 +1,66 @@
+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