module Data.Tree.AVL.Test.Utils
(
isBalanced,checkHeight,isSorted,isSortedOK,
TestTrees,allAVL, allNonEmptyAVL, numTrees, flatAVL,
exhaustiveTest,
minElements,maxElements,
pathTree,
) where
import Data.Tree.AVL.Types(AVL(..))
import Data.Tree.AVL.List(mapAVL',asTreeLenL,asListL)
#ifdef __GLASGOW_HASKELL__
import GHC.Base
#include "ghcdefs.h"
#else
#include "h98defs.h"
#endif
pathTree :: AVL Int
pathTree = Z l 0 r where
l = mapIt (\n -> 2*n+1) pathTree
r = mapIt (\n -> 2*n+2) pathTree
mapIt f (Z l' n r') = let n'= f n in n' `seq` Z (mapIt f l') n' (mapIt f r')
mapIt _ _ = undefined
isBalanced :: AVL e -> Bool
isBalanced t = not (cH t EQL L(1))
checkHeight :: AVL e -> Maybe Int
checkHeight t = let ht = cH t in if ht EQL L(1) then Nothing else Just ASINT(ht)
cH :: AVL e -> UINT
cH E = L(0)
cH (N l _ r) = cH_ L(1) l r
cH (Z l _ r) = cH_ L(0) l r
cH (P l _ r) = cH_ L(1) r l
cH_ :: UINT -> AVL e -> AVL e -> UINT
cH_ delta l r = let hl = cH l
in if hl EQL L(1) then hl
else let hr = cH r
in if hr EQL L(1) then hr
else if SUBINT(hr,hl) EQL delta then INCINT1(hr)
else L(1)
isSorted :: (e -> e -> Ordering) -> AVL e -> Bool
isSorted c = isSorted' where
isSorted' E = True
isSorted' (N l e r) = isSorted'' l e r
isSorted' (Z l e r) = isSorted'' l e r
isSorted' (P l e r) = isSorted'' l e r
isSorted'' l e r = (isSortedU l e) && (isSortedL e r)
isSortedU E _ = True
isSortedU (N l e r) ul = isSortedU' l e r ul
isSortedU (Z l e r) ul = isSortedU' l e r ul
isSortedU (P l e r) ul = isSortedU' l e r ul
isSortedU' l e r ul = case c e ul of
LT -> (isSortedU l e) && (isSortedLU e r ul)
_ -> False
isSortedL _ E = True
isSortedL ll (N l e r) = isSortedL' ll l e r
isSortedL ll (Z l e r) = isSortedL' ll l e r
isSortedL ll (P l e r) = isSortedL' ll l e r
isSortedL' ll l e r = case c e ll of
GT -> (isSortedLU ll l e) && (isSortedL e r)
_ -> False
isSortedLU _ E _ = True
isSortedLU ll (N l e r) ul = isSortedLU' ll l e r ul
isSortedLU ll (Z l e r) ul = isSortedLU' ll l e r ul
isSortedLU ll (P l e r) ul = isSortedLU' ll l e r ul
isSortedLU' ll l e r ul = case c e ll of
GT -> case c e ul of
LT -> (isSortedLU ll l e) && (isSortedLU e r ul)
_ -> False
_ -> False
isSortedOK :: (e -> e -> Ordering) -> AVL e -> Bool
isSortedOK c t = (isBalanced t) && (isSorted c t)
type TestTrees = [(Int, [(AVL Int, Int)])]
allAVL :: TestTrees
allAVL = p0 : p1 : moreTrees p1 p0 where
p0 = (0, [(E , 0)])
p1 = (1, [(Z E 0 E, 1)])
moreTrees :: (Int, [(AVL Int, Int)]) -> (Int, [(AVL Int, Int)]) -> [(Int, [(AVL Int, Int)])]
moreTrees pN1@(hN1, tpsN1)
(_ , tpsN2) =
let hN0 = hN1 + 1
tsN0 = interleave (interleave [newTree P l r | r <- tpsN2 , l <- tpsN1]
[newTree N l r | l <- tpsN2 , r <- tpsN1])
[newTree Z l r | l <- tpsN1 , r <- tpsN1]
pN0 = (hN0,tsN0)
in hN0 `seq` pN0 : moreTrees pN0 pN1
newTree con (l,sizel) (r,sizer) =
let rootEl = sizel
addRight = sizel+1
newSize = addRight + sizer
r' = mapAVL' (addRight+) r
t = r' `seq` con l rootEl r'
in newSize `seq` t `seq` (t, newSize)
interleave [] ys = ys
interleave xs [] = xs
interleave (x:xs) (y:ys) = (x:y:interleave xs ys)
allNonEmptyAVL :: TestTrees
allNonEmptyAVL = tail allAVL
numTrees :: Int -> Integer
numTrees 0 = 1
numTrees 1 = 1
numTrees n = numTrees' 1 1 n where
numTrees' n1 n2 2 = (2*n2 + n1)*n1
numTrees' n1 n2 m = numTrees' ((2*n2 + n1)*n1) n1 (m1)
exhaustiveTest :: (Int -> Int -> AVL Int -> Bool) -> TestTrees -> IO ()
exhaustiveTest f xs = mapM_ test xs where
test (h,tps) = do putStr "Tree Height : " >> print h
putStr "Number Of Trees: " >> print (numTrees h)
mapM_ test' tps
putStrLn "Done."
where test' (t,s) = if f h s t then return ()
else error $ show $ asListL t
flatAVL :: Int -> AVL Int
flatAVL n = asTreeLenL n [0..n1]
minElements :: Int -> Integer
minElements 0 = 0
minElements 1 = 1
minElements h = minElements' 0 1 h where
minElements' n1 n2 2 = 1 + n1 + n2
minElements' n1 n2 m = minElements' n2 (1 + n1 + n2) (m1)
maxElements :: Int -> Integer
maxElements 0 = 0
maxElements h = maxElements' 0 h where
maxElements' n1 1 = 1 + 2*n1
maxElements' n1 m = maxElements' (1 + 2*n1) (m1)