module BishBosh.Data.RoseTree(
IsMatch,
countTerminalNodes,
drawTree,
drawForest,
traceRoute,
promote,
reduce,
mapForest
) where
import qualified Data.List
import qualified Data.Tree
countTerminalNodes :: Num nodes => Data.Tree.Tree a -> nodes
countTerminalNodes Data.Tree.Node { Data.Tree.subForest = [] } = 1
countTerminalNodes Data.Tree.Node { Data.Tree.subForest = forest } = Data.List.foldl' (
\acc -> (+ acc) . countTerminalNodes
) 0 forest
drawTree :: (a -> String) -> Data.Tree.Tree a -> String
drawTree toString = Data.Tree.drawTree . fmap toString
drawForest :: (a -> String) -> Data.Tree.Forest a -> String
drawForest toString = Data.Tree.drawForest . map (fmap toString)
type IsMatch a = a -> Bool
traceRoute
:: (datum -> IsMatch a)
-> Data.Tree.Tree a
-> [datum]
-> Maybe [a]
traceRoute isMatch = slave . Data.Tree.subForest where
slave forest (datum : remainingData) = Data.List.find (
isMatch datum . Data.Tree.rootLabel
) forest >>= (
\Data.Tree.Node {
Data.Tree.rootLabel = rootLabel,
Data.Tree.subForest = subForest
} -> (rootLabel :) `fmap` slave subForest remainingData
)
slave _ _ = Just []
promote
:: (datum -> IsMatch a)
-> [datum]
-> [Data.Tree.Tree a]
-> Maybe [Data.Tree.Tree a]
promote isMatch = slave where
slave (datum : remainingData) forest = case break (isMatch datum . Data.Tree.rootLabel) forest of
(mismatches, match@Data.Tree.Node { Data.Tree.subForest = forest' } : remainingNodes) -> (
\forest'' -> match {
Data.Tree.subForest = forest''
} : mismatches ++ remainingNodes
) `fmap` slave remainingData forest'
_ -> Nothing
slave _ forest = Just forest
reduce
:: IsMatch a
-> Data.Tree.Tree a
-> Maybe (Data.Tree.Tree a)
reduce isMatch Data.Tree.Node { Data.Tree.subForest = subForest } = Data.List.find (isMatch . Data.Tree.rootLabel) subForest
type Transformation a = Data.Tree.Tree a -> Data.Tree.Tree a
mapForest :: (a -> Data.Tree.Forest a -> Data.Tree.Forest a) -> Transformation a
mapForest f = slave where
slave node@Data.Tree.Node {
Data.Tree.rootLabel = label,
Data.Tree.subForest = forest
} = node { Data.Tree.subForest = map slave $ f label forest }