diff --git a/AvlTree.hs b/AvlTree.hs index f04754e..0cf7131 100644 --- a/AvlTree.hs +++ b/AvlTree.hs @@ -1,6 +1,12 @@ {-# OPTIONS -Wall #-} {-# LANGUAGE EmptyDataDecls, FlexibleInstances, GADTs #-} +module AvlTree + ( Tree + , empty, insert + , fromList, toList + ) where + import Data.List (foldl') data Zero @@ -57,15 +63,28 @@ data InsertResultRule new old where InsertHigher :: InsertResultRule (Succ n) n nodeInsert :: Ord a => a -> Node n a -> InsertResult n a -nodeInsert x Nil = InsertResult InsertHigher (Node SameHeight Nil x Nil) +nodeInsert x Nil = InsertResult auto (Node SameHeight Nil x Nil) nodeInsert x node@(Node _ _ mid _) = nodeInsertH (x >= mid) x node +class Auto a where + auto :: a +instance Auto (InsertResultRule n n) where + auto = InsertSame +instance Auto (InsertResultRule (Succ n) n) where + auto = InsertHigher +instance Auto (HeightRule (Succ n) (Succ n) n) where + auto = LeftHigher +instance Auto (HeightRule n n n) where + auto = SameHeight +instance Auto (HeightRule (Succ n) n (Succ n)) where + auto = RightHigher + nodeInsertH :: Ord a => Bool -> a -> Node (Succ n) a -> InsertResult (Succ n) a nodeInsertH isRev x node = case revNode isRev node of Node rule left mid right -> case nodeInsert x left of - InsertResult InsertSame newLeft -> InsertResult InsertSame . revNode isRev $ Node rule newLeft mid right + InsertResult InsertSame newLeft -> InsertResult auto . revNode isRev $ Node rule newLeft mid right InsertResult InsertHigher newLeft -> nodeBalanceH isRev rule newLeft mid right revNode :: Bool -> Node n a -> Node n a @@ -73,43 +92,43 @@ revNode False x = x revNode _ Nil = Nil revNode True (Node rule left mid right) = case rule of - LeftHigher -> go RightHigher - SameHeight -> go SameHeight - RightHigher -> go LeftHigher + LeftHigher -> go auto + SameHeight -> go auto + RightHigher -> go auto where go newRule = Node newRule right mid left nodeBalanceH :: Bool -> HeightRule n l r -> Node (Succ l) a -> a -> Node r a -> InsertResult (Succ n) a nodeBalanceH isRev rule left mid right = case rule of - RightHigher -> go InsertSame SameHeight - SameHeight -> go InsertHigher LeftHigher + RightHigher -> go SameHeight + SameHeight -> go LeftHigher LeftHigher -> rotate isRev left mid right where - go insRule newRule = InsertResult insRule . revNode isRev $ Node newRule left mid right + go newRule = InsertResult auto . revNode isRev $ Node newRule left mid right rotate :: Bool -> Node (Succ (Succ n)) a -> a -> Node n a -> InsertResult (Succ (Succ n)) a rotate isRev l m r = case revNode isRev l of Node lRule ll lm lr -> let - go0 r0 r1 r2 = InsertResult r0 . revNode isRev . Node r1 ll lm . revNode isRev $ Node r2 lr m r + go0 r1 = InsertResult auto . revNode isRev . Node r1 ll lm . revNode isRev $ Node auto lr m r in case lRule of - LeftHigher -> go0 InsertSame SameHeight SameHeight - SameHeight -> go0 InsertHigher RightHigher LeftHigher + LeftHigher -> go0 SameHeight + SameHeight -> go0 RightHigher RightHigher -> case revNode isRev lr of Nil -> undefined -- should never happen Node lrRule lrl lrm lrr -> let - go1 leftRule rightRule = - InsertResult InsertSame . revNode isRev $ Node SameHeight + go1 leftRule = + InsertResult auto . revNode isRev $ Node SameHeight (revNode isRev $ Node leftRule ll lm lrl) lrm - (revNode isRev $ Node rightRule lrr m r) + (revNode isRev $ Node auto lrr m r) in case lrRule of - LeftHigher -> go1 SameHeight RightHigher - SameHeight -> go1 SameHeight SameHeight - RightHigher -> go1 LeftHigher SameHeight + LeftHigher -> go1 SameHeight + SameHeight -> go1 SameHeight + RightHigher -> go1 LeftHigher