module HarmTrace.HAnTree.Tree where
import Data.Maybe
import qualified Data.Binary as B
import Control.Monad.State
import Data.List (maximumBy, genericLength)
import Control.DeepSeq
data Tree a = Node { getLabel :: !a, getChild :: ![Tree a], getPn :: !(Maybe Int) }
deriving Eq
instance (Show a) => Show (Tree a) where
show (Node a children _) =
desc where
desc = ('[' : show a) ++ concatMap show children ++ "]"
instance (NFData a) => NFData (Tree a) where
rnf (Node l c p) = rnf l `seq` rnf c `seq` rnf p
instance (B.Binary a) => B.Binary (Tree a) where
put (Node l c p) = B.put l >> B.put c >> B.put p
get = liftM3 Node B.get B.get B.get
strTree :: String -> Tree String
strTree = head . strTree' where
strTree' [] = []
strTree' (c:cs)
| c == '[' = Node lab (strTree' a) Nothing : strTree' b
| c == ']' = strTree' cs
| otherwise = error ("cannot parse, not well formed tree description: "
++ [c]) where
(x ,b) = splitAt (findClose cs) cs
(lab,a) = span (\y -> (y /= '[') && (y /= ']')) x
findClose :: String -> Int
findClose s = findClose' s 1 0
findClose' :: String -> Int -> Int -> Int
findClose' [] b ix
| b == 0 = ix1
| otherwise = error
"not well formed tree description: cannot find closing bracket"
findClose' (c : cs) b ix
| b == 0 = ix1
| c == '[' = findClose' cs (b+1) (ix+1)
| c == ']' = findClose' cs (b1) (ix+1)
| otherwise = findClose' cs b (ix+1)
getPns :: [Tree t] -> [Int]
getPns = map (fromJust . getPn)
getChildPns :: Tree a -> [Int]
getChildPns (Node _lab children _pn) = map (fromJust . getPn) children
getSubTree :: Tree t -> Int -> Tree t
getSubTree t pn = pot t!!pn
isLf :: (Eq t) => Tree t -> Bool
isLf t = getChild t == []
collectLeafs :: Tree t -> [Tree t]
collectLeafs t@(Node _ [] _) = [t]
collectLeafs (Node _ cn _) = concatMap collectLeafs cn
size, depth :: Tree t -> Int
size (Node _ [] _) = 1
size (Node _ children _ ) = foldr ((+) . size ) 1 children
sizeF, depthF :: [Tree t] -> Int
sizeF treeList = foldr ((+) . size ) 0 treeList
avgDepth :: Tree t -> Float
avgDepth t = fromIntegral (sum dep) / (genericLength dep) where
dep = depth' 1 t
avgDepthF :: [Tree t] -> Float
avgDepthF t = let l = map avgDepth t in sum l / genericLength l
depth t = maximumBy compare (depth' 1 t)
depthF treeList = maximumBy compare (concatMap (depth' 1) treeList)
depth' :: Int -> Tree t -> [Int]
depth' x (Node _ [] _ ) = [x]
depth' x (Node _ c _ ) = x : concatMap (depth' (x+1)) c
remove :: (Eq t) => t -> Tree t -> Tree t
remove x = removeBy (== x)
removeBy :: (t -> Bool) -> Tree t -> Tree t
removeBy f t = head (removeBy' f t)
removeBy' :: (t -> Bool) -> Tree t -> [Tree t]
removeBy' f (Node l c pn)
| f l = concatMap (removeBy' f) c
| otherwise = [(Node l (concatMap (removeBy' f) c) pn)]
pot, pot', pret, pret',potPret :: Tree t -> [Tree t]
potPret t = pot' (setPre t)
pot t = pot' (setPost t)
pot' t@(Node _ [] _) = [t]
pot' t@(Node _ children _) = concatMap pot' children ++ [t]
pret t = pret' (setPre t)
pret' t@(Node _ [] _) = [t]
pret' t@(Node _ children _) = t : concatMap pret' children
preToPost :: Tree t -> Int -> Int
preToPost t pn = fromJust . getPn $ pret' (setPost t) !! pn
setPost, setPre :: Tree t -> Tree t
setPost t = evalState (stm t) 0 where
stm :: Tree t -> State Int (Tree t)
stm (Node a cs _) = do cs' <- mapM stm cs
pn <- get
modify (+1)
return (Node a cs' (Just pn))
setPre t = evalState (stm t) 0 where
stm :: Tree t -> State Int (Tree t)
stm (Node a cs _) = do pn <- get
modify (+1)
cs' <- mapM stm cs
return (Node a cs' (Just pn))
matchToTree :: Tree t -> [Int] -> [Tree t]
matchToTree t@(Node _ _ Nothing ) k = matchToTree (setPost t) k
matchToTree (Node a cn (Just pn)) k =
let cs = concatMap (`matchToTree` k) cn
in if pn `elem` k then [Node a cs (Just pn)] else cs