module Data.PathTree
( PathTree
, LCRSTree(..)
, insert
, insertWith
, insertReplace
, fromPath
, fromPaths
, fromPathsWith
, fromPathsReplace
, toPaths
, pathExists
) where
import Data.List (foldl')
import Data.LCRSTree
type PathTree n = LCRSTree n
insert :: (Eq n) => [n] -> PathTree n -> PathTree n
insert t Empty = fromPath t
insert [] t = t
insert [a] t =
case t of
Empty -> Leaf a Empty
Leaf a' s -> Leaf a (Leaf a' s)
Node n c s -> Node n c (insert [a] s)
insert (h:t) l@(Leaf _ _) = Node h (insert t Empty) l
insert (h:t) (Node n c s)
| h == n = Node n (insert t c) s
| otherwise = Node n c (insert (h:t) s)
insertWith :: (Eq n) => (n -> n -> n) -> [n] -> PathTree n -> PathTree n
insertWith _ t Empty = fromPath t
insertWith _ [] t = t
insertWith f [a] t =
case t of
Empty -> Leaf a Empty
Leaf a' s -> if a == a'
then Leaf (f a' a) s
else Leaf a (insertWith f [a] s)
Node n c s -> if n == a
then Node (f n a) c s
else Node n c (insertWith f [a] s)
insertWith f (h:t) l@(Leaf _ _) = Node h (insertWith f t Empty) l
insertWith f (h:t) (Node n c s)
| h == n = Node n (insertWith f t c) s
| otherwise = Node n c (insertWith f (h:t) s)
insertReplace :: (Eq n) => [n] -> PathTree n -> PathTree n
insertReplace = insertWith const
fromPath :: [n] -> PathTree n
fromPath [] = Empty
fromPath [a] = Leaf a Empty
fromPath (h:t) = Node h (fromPath t) Empty
fromPaths :: Eq n => [[n]] -> PathTree n
fromPaths [] = Empty
fromPaths (h:t) = foldl' (flip insert) (fromPath h) t
fromPathsWith :: Eq n => (n -> n -> n) -> [[n]] -> PathTree n
fromPathsWith _ [] = Empty
fromPathsWith f (h:t) = foldl' (flip (insertWith f)) (fromPath h) t
fromPathsReplace :: Eq n => [[n]] -> PathTree n
fromPathsReplace = fromPathsWith const
toPaths :: PathTree n -> [[n]]
toPaths = trackPath []
where
trackPath _ Empty = []
trackPath ns (Leaf a sib) = (ns ++ [a]) : trackPath ns sib
trackPath ns (Node n' c' s') =
let newPath = ns ++ [n']
in trackPath newPath c' ++ trackPath ns s'
pathExists :: Eq n => [n] -> LCRSTree n -> Bool
pathExists _ Empty = False
pathExists paths (Leaf n s) =
case paths of
[] -> False
[p] -> if n == p then True
else pathExists [p] s
(p:ps) -> if p == n then pathExists ps s
else pathExists (p:ps) s
pathExists paths (Node n c s) =
case paths of
[] -> False
[p] -> pathExists [p] s
(p:ps) -> if p == n then pathExists ps c
else pathExists (p:ps) s