diagrams-core-0.5: src/Graphics/Rendering/Diagrams/UDTree.hs
{-# LANGUAGE DeriveFunctor
, TypeOperators
, FlexibleContexts
#-}
-----------------------------------------------------------------------------
-- |
-- Module : Graphics.Rendering.Diagrams.UDTree
-- Copyright : (c) 2011 diagrams-core team (see LICENSE)
-- License : BSD-style (see LICENSE)
-- Maintainer : diagrams-discuss@googlegroups.com
--
-- Rose (n-way) trees with both upwards- and downwards-traveling
-- monoidal annotations, used as the basis for representing diagrams.
--
-----------------------------------------------------------------------------
module Graphics.Rendering.Diagrams.UDTree
(
-- * UD-trees
UDTree(..)
-- * Constructing UD-trees
, leaf, branchD, branch
-- * Modifying UD-trees
, applyD, applyUpre, applyUpost, mapU
-- * Accessors and destructors
, getU, getU', foldUD, flatten
) where
import Data.Semigroup
import Graphics.Rendering.Diagrams.Monoids
import Graphics.Rendering.Diagrams.MList
-- | Abstractly, a UDTree is a rose (n-way) tree with data at the
-- leaves and two types of monoidal annotations, one (called @u@)
-- travelling \"up\" the tree and one (called @d@) traveling
-- \"down\".
--
-- Specifically, every node (both leaf nodes and internal nodes)
-- has two annotations, one of type @d@ and one of type @u@,
-- subject to the following constraints:
--
-- * The @d@ annotation at a leaf node is equal to the 'mconcat' of
-- all the @d@ annotations along the path from the root to the leaf
-- node.
--
-- * The @u@ annotation at an internal node is equal to @v1
-- ``mappend`` (mconcat us) ``mappend`` v2@ for some values @v1@
-- and @v2@ (possibly 'mempty'), where @us@ is the list (in
-- left-right order) of the @u@ annotations on the immediate child
-- nodes of the given node. Intuitively, we are \"caching\" the
-- @mconcat@ of @u@ annotations from the leaves up, except that at
-- any point we may insert \"extra\" information.
--
-- In addition, @d@ may have an /action/ on @u@ (see the 'Action'
-- type class, defined in "Graphics.Rendering.Diagrams.Monoids"), in
-- which case applying a @d@ annotation to a tree will transform all
-- the @u@ annotations by acting on them. The constraints on @u@
-- annotations are maintained since the action is required to be a
-- monoid homomorphism.
data UDTree u d a
= Leaf u a
| Branch u [d] [UDTree u d a]
deriving (Functor)
-- XXX need to sort out all the semigroup/monoid stuff in here!
instance (Action d u, Monoid u, Monoid d) => Semigroup (UDTree u d a) where
t1 <> t2 = branch [t1,t2]
-- | @UDTree@s form a monoid where @mappend@ corresponds to adjoining
-- two trees under a common parent root. Note that this technically
-- does not satisfy associativity, but it does with respect to
-- 'flatten' which is what we really care about. @mconcat@ is
-- specialized to put all the trees under a single parent.
instance (Action d u, Monoid u, Monoid d) => Monoid (UDTree u d a) where
mempty = Branch mempty mempty []
t1 `mappend` t2 = branch [t1,t2]
mconcat = branch
-- | Construct a leaf node from a @u@ annotation and datum.
leaf :: u -> a -> UDTree u d a
leaf = Leaf
-- | Construct a branch node with an explicit @d@ annotation.
branchD :: (Action d u, Monoid u) => d -> [UDTree u d a] -> UDTree u d a
branchD d ts = Branch (mconcat . map getU $ ts) [d] ts
-- | Construct a branch node with a default (identity) @d@ annotation.
branch :: (Action d u, Monoid u, Monoid d) => [UDTree u d a] -> UDTree u d a
branch ts = Branch (mconcat . map getU $ ts) [] ts
-- | Get the @u@ annotation at the root.
getU :: Action d u => UDTree u d a -> u
getU (Leaf u _) = u
getU (Branch u ds _) = foldr act u ds
-- | Get a particular component from a the @u@ annotation at the root.
-- This method is provided for convenience, since its context only
-- requires an action of @d@ on @u'@, rather than on @u@ in its
-- entirety.
getU' :: (Action d (u' ::: Nil), u :>: u') => UDTree u d a -> u'
getU' (Leaf u _) = get u
getU' (Branch u ds _) = hd $ foldr act (get u ::: Nil) ds
where hd (u' ::: Nil) = u'
hd (Missing _) = error "Impossible case in UDTree.getU' (hd)"
-- | Add a @d@ annotation to the root, combining it (on the left) with
-- any pre-existing @d@ annotation, and transforming all @u@
-- annotations by the action of @d@.
applyD :: Action d u => d -> UDTree u d a -> UDTree u d a
applyD d l@(Leaf {}) = Branch (getU l) [d] [l]
applyD d (Branch u ds ts) = Branch u (d : ds) ts
-- | Add a @u@ annotation to the root, combining it (on the left) with
-- the existing @u@ annotation.
applyUpre :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a
applyUpre u' (Leaf u a) = Leaf (u' <> u) a
applyUpre u' b = Branch (u' <> getU b) [] [b]
-- | Add a @u@ annotation to the root, combining it (on the right) with
-- the existing @u@ annotation.
applyUpost :: (Semigroup u, Action d u) => u -> UDTree u d a -> UDTree u d a
applyUpost u' (Leaf u a) = Leaf (u <> u') a
applyUpost u' b = Branch (getU b <> u') [] [b]
-- | Map a function over all the @u@ annotations. The function must
-- be a monoid homomorphism, and must commute with the action of @d@
-- on @u@. That is, to use @mapU f@ safely it must be the case that
-- @f (act d u) == act d (f u)@.
mapU :: (u -> u') -> UDTree u d a -> UDTree u' d a
mapU f (Leaf u a) = Leaf (f u) a
mapU f (Branch u ds ts) = Branch (f u) ds (map (mapU f) ts)
-- | A fold for UDTrees.
foldUD :: (Monoid r, Semigroup d, Monoid d, Action d u)
=> (u -> d -> a -> r) -- ^ Function for processing leaf nodes.
-- Given the u annotation at this node, the
-- 'mconcat' of all d annotations above, and the
-- leaf value.
-> (u -> d -> r -> r) -- ^ Function for processing internal
-- nodes. Given the u and d
-- annotations at this node and the
-- 'mconcat' of the recursive results.
-> UDTree u d a -> r
foldUD = foldUD' mempty -- Pass along accumulated d value
where foldUD' d l _ (Leaf u a)
= l (act d u) d a
foldUD' d l b (Branch u ds ts)
= b (act (d <> d') u) d' (mconcat $ map (foldUD' (d <> d') l b) ts)
where d' = mconcat ds
-- | A specialized fold provided for convenience: flatten a tree into
-- a list of leaves along with their @d@ annotations.
flatten :: (Semigroup d, Monoid d, Action d u) => UDTree u d a -> [(a,d)]
flatten = foldUD (\_ d a -> [(a,d)]) (\_ _ r -> r)