RoseTree.hs

{-
	Copyright (C) 2018 Dr. Alistair Ward

	This file is part of BishBosh.

	BishBosh is free software: you can redistribute it and/or modify
	it under the terms of the GNU General Public License as published by
	the Free Software Foundation, either version 3 of the License, or
	(at your option) any later version.

	BishBosh is distributed in the hope that it will be useful,
	but WITHOUT ANY WARRANTY; without even the implied warranty of
	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
	GNU General Public License for more details.

	You should have received a copy of the GNU General Public License
	along with BishBosh.  If not, see <http://www.gnu.org/licenses/>.
-}
{- |
 [@AUTHOR@]	Dr. Alistair Ward

 [@DESCRIPTION@]	Defines operations on an arbitrary rose-tree.
-}

module BishBosh.Data.RoseTree(
-- * Types
-- ** Type-synonyms
--	Transformation,
	IsMatch,
-- * Function
	countTerminalNodes,
	drawTree,
	drawForest,
	traceRoute,
-- ** Mutators
	promote,
	reduce,
	mapForest
) where

import qualified	Data.List
import qualified	Data.Tree

-- | Counts the number of terminal nodes.
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 {-recurse-}
 ) 0 forest

-- | Returns a string which graphically represents the tree.
drawTree :: (a -> String) -> Data.Tree.Tree a -> String
drawTree toString	= Data.Tree.drawTree . fmap toString

-- | Returns a string which graphically represents the forest.
drawForest :: (a -> String) -> Data.Tree.Forest a -> String
drawForest toString	= Data.Tree.drawForest . map (fmap toString)

-- | Whether a datum matches.
type IsMatch a	= a -> Bool

-- | Trace a path down the specified tree, of matching nodes.
traceRoute
	:: (datum -> IsMatch a)	-- ^ Whether a datum matches.
	-> Data.Tree.Tree a
	-> [datum]		-- ^ The data against which, nodes from the tree should be matched.
	-> Maybe [a]		-- ^ Returns 'Nothing' on match-failure.
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 {-recurse-}
	 )
	slave _ _				= Just []

{- |
	* Recursively advances the position within the forest, of the first node which matches the next datum, at successively deeper levels.

	* CAVEAT: each datum is expected to match exactly one item from the forest at each level.
-}
promote
	:: (datum -> IsMatch a)		-- ^ Whether a node matches.
	-> [datum]			-- ^ The data against which nodes from the forest should be matched.
	-> [Data.Tree.Tree a]
	-> Maybe [Data.Tree.Tree a]	-- ^ Returns 'Nothing' on match-failure.
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'	-- Recurse.
		_											-> Nothing	-- Match-failure.
	slave _ forest				= Just forest	-- Data exhausted => Terminate normally.

-- | Reduce the tree to the first matching datum in the 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

-- | The type of a function which changes the structure (but not the type) of the specified tree.
type Transformation a	= Data.Tree.Tree a -> Data.Tree.Tree a

{- |
	* Apply an arbitrary mapping to all subForests; cf 'fmap' which applies an arbitrary function to all rootLabels.

	* The mapping is given access to the label at each forest.
-}
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 {-recurse-} $ f label forest }