{-
	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,
-- * Functions
	countTerminalNodes,
	drawTree,
	drawForest,
	traceRoute,
-- ** Mutators
	promote,
	reduce,
	prune,
	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
-}
countTerminalNodes :: Tree a -> nodes
countTerminalNodes = nodes -> Tree a -> nodes
forall b a. Num b => b -> Tree a -> b
go nodes
0 where
	go :: b -> Tree a -> b
go b
acc Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [] }	= b
acc b -> b -> b
forall a. Num a => a -> a -> a
+ b
1
	go b
acc Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [Tree a]
forest }	= (b -> Tree a -> b) -> b -> [Tree a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Data.List.foldl' b -> Tree a -> b
go b
acc [Tree a]
forest

-- | Returns a string which graphically represents the tree.
drawTree :: (a -> String) -> Data.Tree.Tree a -> String
drawTree :: (a -> String) -> Tree a -> String
drawTree a -> String
toString	= Tree String -> String
Data.Tree.drawTree (Tree String -> String)
-> (Tree a -> Tree String) -> Tree a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> Tree a -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
toString

-- | Returns a string which graphically represents the forest.
drawForest :: (a -> String) -> Data.Tree.Forest a -> String
drawForest :: (a -> String) -> Forest a -> String
drawForest a -> String
toString	= Forest String -> String
Data.Tree.drawForest (Forest String -> String)
-> (Forest a -> Forest String) -> Forest a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree a -> Tree String) -> Forest a -> Forest String
forall a b. (a -> b) -> [a] -> [b]
map ((a -> String) -> Tree a -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> String
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 :: (datum -> IsMatch a) -> Tree a -> [datum] -> Maybe [a]
traceRoute datum -> IsMatch a
isMatch	= Forest a -> [datum] -> Maybe [a]
slave (Forest a -> [datum] -> Maybe [a])
-> (Tree a -> Forest a) -> Tree a -> [datum] -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> Forest a
forall a. Tree a -> Forest a
Data.Tree.subForest where
	slave :: Forest a -> [datum] -> Maybe [a]
slave Forest a
forest (datum
datum : [datum]
remainingData)	= (Tree a -> Bool) -> Forest a -> Maybe (Tree a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (
		datum -> IsMatch a
isMatch datum
datum IsMatch a -> (Tree a -> a) -> Tree a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
Data.Tree.rootLabel
	 ) Forest a
forest Maybe (Tree a) -> (Tree a -> Maybe [a]) -> Maybe [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (
		\Data.Tree.Node {
			rootLabel :: forall a. Tree a -> a
Data.Tree.rootLabel	= a
rootLabel,
			subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest	= Forest a
subForest
		} -> (a
rootLabel a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forest a -> [datum] -> Maybe [a]
slave Forest a
subForest [datum]
remainingData {-recurse-}
	 )
	slave Forest a
_ [datum]
_				= [a] -> Maybe [a]
forall a. a -> Maybe a
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 :: (datum -> IsMatch a) -> [datum] -> [Tree a] -> Maybe [Tree a]
promote datum -> IsMatch a
isMatch	= [datum] -> [Tree a] -> Maybe [Tree a]
slave where
	slave :: [datum] -> [Tree a] -> Maybe [Tree a]
slave (datum
datum : [datum]
remainingData) [Tree a]
forest	= case (Tree a -> Bool) -> [Tree a] -> ([Tree a], [Tree a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (datum -> IsMatch a
isMatch datum
datum IsMatch a -> (Tree a -> a) -> Tree a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
Data.Tree.rootLabel) [Tree a]
forest of
		([Tree a]
mismatches, match :: Tree a
match@Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = [Tree a]
forest' } : [Tree a]
remainingNodes)	-> (
			\[Tree a]
forest'' -> Tree a
match {
				subForest :: [Tree a]
Data.Tree.subForest	= [Tree a]
forest''
			} Tree a -> [Tree a] -> [Tree a]
forall a. a -> [a] -> [a]
: [Tree a]
mismatches [Tree a] -> [Tree a] -> [Tree a]
forall a. [a] -> [a] -> [a]
++ [Tree a]
remainingNodes
		 ) ([Tree a] -> [Tree a]) -> Maybe [Tree a] -> Maybe [Tree a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [datum] -> [Tree a] -> Maybe [Tree a]
slave [datum]
remainingData [Tree a]
forest'	-- Recurse.
		([Tree a], [Tree a])
_											-> Maybe [Tree a]
forall a. Maybe a
Nothing	-- Match-failure.
	slave [datum]
_ [Tree a]
forest				= [Tree a] -> Maybe [Tree a]
forall a. a -> Maybe a
Just [Tree a]
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 a -> Tree a -> Maybe (Tree a)
reduce IsMatch a
isMatch Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = Forest a
subForest }	= (Tree a -> Bool) -> Forest a -> Maybe (Tree a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Data.List.find (IsMatch a
isMatch IsMatch a -> (Tree a -> a) -> Tree a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> a
forall a. Tree a -> a
Data.Tree.rootLabel) Forest a
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

-- | Remove branches after the specified depth.
prune :: Int -> Transformation a
prune :: Int -> Transformation a
prune Int
depth tree :: Tree a
tree@Data.Tree.Node { subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest = Forest a
forest }
	| Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0	= String -> Tree a
forall a. HasCallStack => String -> a
error String
"BishBosh.Data.RoseTree.prune:\tdepth can't be negative."
	| Bool
otherwise	= Tree a
tree {
		subForest :: Forest a
Data.Tree.subForest	= if Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
			then []
			else Transformation a -> Forest a -> Forest a
forall a b. (a -> b) -> [a] -> [b]
map (
				Int -> Transformation a
forall a. Int -> Transformation a
prune (Int -> Transformation a) -> Int -> Transformation a
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a. Enum a => a -> a
pred Int
depth	-- Recurse.
			) Forest a
forest
	}

{- |
	* Apply an arbitrary mapping to all subForests; cf. 'fmap' which applies an arbitrary function to all 'Data.Tree.rootLabel's.

	* The mapping is given access to the label at each forest.
-}
mapForest :: (a -> Data.Tree.Forest a -> Data.Tree.Forest a) -> Transformation a
mapForest :: (a -> Forest a -> Forest a) -> Transformation a
mapForest a -> Forest a -> Forest a
f	= Transformation a
slave where
	slave :: Transformation a
slave node :: Tree a
node@Data.Tree.Node {
		rootLabel :: forall a. Tree a -> a
Data.Tree.rootLabel	= a
label,
		subForest :: forall a. Tree a -> Forest a
Data.Tree.subForest	= Forest a
forest
	} = Tree a
node { subForest :: Forest a
Data.Tree.subForest = Transformation a -> Forest a -> Forest a
forall a b. (a -> b) -> [a] -> [b]
map Transformation a
slave {-recurse-} (Forest a -> Forest a) -> Forest a -> Forest a
forall a b. (a -> b) -> a -> b
$ a -> Forest a -> Forest a
f a
label Forest a
forest }