blob: 2542951e7d45de99eef132c72c18ddca8f8a45be (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
|
module AATree.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
|
