diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,3 @@ +* 0.1.0.0: 3 September 2012 + + Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011-2012, Brent Yorgey + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brent Yorgey nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/dual-tree.cabal b/dual-tree.cabal new file mode 100644 --- /dev/null +++ b/dual-tree.cabal @@ -0,0 +1,54 @@ +name: dual-tree +version: 0.1.0.0 +synopsis: Rose trees with cached and accumulating monoidal annotations +description: Rose (n-ary) trees with both upwards- (/i.e./ + cached) and downwards-traveling (/i.e./ + accumulating) monoidal annotations. This is used + as the core data structure underlying the + @diagrams@ framework + (), but + potentially has other applications as well. + . + Abstractly, a DUALTree is a rose (n-ary) tree + with data (of type @l@) at leaves, data (of type + @a@) at internal nodes, and two types of monoidal + annotations, one (of type @u@) travelling \"up\" + the tree and one (of type @d@) traveling + \"down\". + . + See "Data.Tree.DUAL" for full documentation. + "Data.Tree.DUAL" provides a public API which + should suffice for most purposes. + "Data.Tree.DUAL.Internal" exports more of the + internal implementation---use it at your own + risk. +license: BSD3 +license-file: LICENSE +extra-source-files: CHANGES +author: Brent Yorgey +maintainer: diagrams-discuss@googlegroups.com +category: Data +build-type: Simple +cabal-version: >=1.10 +bug-reports: https://github.com/diagrams/dual-tree/issues + +source-repository head + type: git + location: https://github.com/diagrams/dual-tree.git + +library + default-language: Haskell2010 + exposed-modules: Data.Tree.DUAL + Data.Tree.DUAL.Internal + build-depends: base >= 4.3 && < 4.7, + semigroups >= 0.8 && < 0.9, + newtype >= 0.2 && < 0.3, + monoid-extras >= 0.2 && < 0.3 + hs-source-dirs: src + other-extensions: GeneralizedNewtypeDeriving, + MultiParamTypeClasses, + FlexibleInstances, + DeriveFunctor, + TypeOperators, + FlexibleContexts, + DeriveDataTypeable diff --git a/src/Data/Tree/DUAL.hs b/src/Data/Tree/DUAL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/DUAL.hs @@ -0,0 +1,88 @@ + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.DUAL +-- Copyright : (c) 2011-2012 Brent Yorgey +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Rose (n-ary) trees with both upwards- (/i.e./ cached) and +-- downwards-traveling (/i.e./ accumulating) monoidal annotations. +-- This is used as the core data structure underlying the @diagrams@ +-- framework (), but potentially +-- has other applications as well. +-- +-- Abstractly, a DUALTree is a rose (n-ary) tree with data (of type +-- @l@) at leaves, data (of type @a@) at internal nodes, and two types +-- of monoidal annotations, one (of type @u@) travelling \"up\" the +-- tree and one (of type @d@) traveling \"down\". +-- +-- Specifically, there are five types of nodes: +-- +-- * Leaf nodes which contain a data value of type @l@ and an +-- annotation of type @u@. The annotation represents information +-- about a tree that should be accumulated (/e.g./ number of +-- leaves, some sort of \"weight\", /etc./). If you are familiar +-- with finger trees +-- (, +-- ), it is the +-- same idea. +-- +-- * There is also a special type of leaf node which contains only a +-- @u@ value, and no data. This allows cached @u@ values to be +-- \"modified\" by inserting extra annotations. +-- +-- * Branch nodes, containing a list of subtrees. +-- +-- * Internal nodes with a value of type @d@. @d@ may have an +-- /action/ on @u@ (see the 'Action' type class, defined in +-- "Data.Monoid.Action" from the @monoid-extras@ package). +-- Semantically speaking, applying a @d@ annotation to a tree +-- transforms all the @u@ annotations below it by acting on them. +-- Operationally, however, since the action must be a monoid +-- homomorphism, applying a @d@ annotation can actually be done in +-- constant time. +-- +-- * Internal nodes with data values of type @a@, possibly of a +-- different type than those in the leaves. These are just \"along +-- for the ride\" and are unaffected by @u@ and @d@ annotations. +-- +-- There are two critical points to note about @u@ and @d@ annotations: +-- +-- * The combined @u@ annotation for an entire tree is always cached +-- at the root and available in constant (amortized) time. +-- +-- * The 'mconcat' of all the @d@ annotations along the path from +-- the root to each leaf is available along with the leaf during a +-- fold operation. +-- +-- A fold over a @DUALTree@ is given access to the internal and leaf +-- data, and the accumulated @d@ values at each leaf. It is also +-- allowed to replace \"@u@-only\" leaves with a constant value. In +-- particular, however, it is /not/ given access to any of the @u@ +-- annotations, the idea being that those are used only for +-- /constructing/ trees. It is also not given access to @d@ values as +-- they occur in the tree, only as they accumulate at leaves. If you +-- do need access to @u@ or @d@ values, you can duplicate the values +-- you need in the internal data nodes. +-- +----------------------------------------------------------------------------- + +module Data.Tree.DUAL + ( + -- * DUAL-trees + DUALTree + + -- * Constructing DUAL-trees + , empty, leaf, leafU, annot, applyD + + -- * Modifying DUAL-trees + , applyUpre, applyUpost + , mapU + + -- * Accessors and eliminators + , getU, foldDUAL, flatten + + ) where + +import Data.Tree.DUAL.Internal diff --git a/src/Data/Tree/DUAL/Internal.hs b/src/Data/Tree/DUAL/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/DUAL/Internal.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Tree.DUAL.Internal +-- Copyright : (c) 2011-2012 Brent Yorgey +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- This module provides access to all of the internals of the +-- DUAL-tree implementation. Depend on the internals at your own +-- risk! For a safe public API (and complete documentation), see +-- "Data.Tree.DUAL". +-- +-- The main things exported by this module which are not exported from +-- "Data.Tree.DUAL" are two extra types used in the implementation of +-- 'DUALTree', along with functions for manipulating them. A type of +-- /non-empty/ trees, 'DUALTreeNE', is defined, as well as the type +-- 'DUALTreeU' which represents a non-empty tree paired with a cached +-- @u@ annotation. 'DUALTreeNE' and 'DUALTreeU' are mutually +-- recursive, so that recursive tree nodes are interleaved with cached +-- @u@ annotations. 'DUALTree' is defined by just wrapping +-- 'DUALTreeU' in 'Option'. This method has the advantage that the +-- type system enforces the invariant that there is only one +-- representation for the empty tree. It also allows us to get away +-- with only 'Semigroup' constraints in many places. +-- +----------------------------------------------------------------------------- + +module Data.Tree.DUAL.Internal + ( + -- * DUAL-trees + DUALTreeNE(..), DUALTreeU(..), DUALTree(..) + + -- * Constructing DUAL-trees + , empty, leaf, leafU, annot, applyD + + -- * Modifying DUAL-trees + , applyUpre, applyUpost + , mapUNE, mapUU, mapU + + -- * Accessors and eliminators + , nonEmpty, getU, foldDUALNE, foldDUAL, flatten + + ) where + +import Control.Arrow ((***)) +import Data.Functor ((<$>)) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Maybe (fromMaybe, catMaybes, mapMaybe) +import Data.Monoid.Action +import Data.Semigroup +import Data.Tuple (swap) +import Data.Typeable + +import Control.Newtype + +------------------------------------------------------------ +-- DUALTreeNE +------------------------------------------------------------ + +-- | /Non-empty/ DUAL-trees. +data DUALTreeNE d u a l + = Leaf u l -- ^ Leaf with data value and @u@ annotation + | LeafU u -- ^ Leaf with only @u@ annotation + | Concat (NonEmpty (DUALTreeU d u a l)) + -- ^ n-way branch, containing a /non-empty/ list + -- of subtrees. + | Act d (DUALTreeU d u a l) + -- ^ @d@ annotation + | Annot a (DUALTreeU d u a l) + -- ^ Internal data value + deriving (Functor, Typeable, Show, Eq) + +instance (Action d u, Semigroup u) => Semigroup (DUALTreeNE d u a l) where + t1 <> t2 = sconcat (NEL.fromList [t1,t2]) + sconcat = Concat . NEL.map pullU + +newtype DAct d = DAct { unDAct :: d } + +instance Newtype (DAct d) d where + pack = DAct + unpack = unDAct + +instance (Semigroup d, Semigroup u, Action d u) + => Action (DAct d) (DUALTreeNE d u a l) where + act (DAct d) (Act d' t) = Act (d <> d') t + act (DAct d) t = Act d (pullU t) + +------------------------------------------------------------ +-- DUALTreeU +------------------------------------------------------------ + +-- | A non-empty DUAL-tree paired with a cached @u@ value. These +-- should never be constructed directly; instead, use 'pullU'. +newtype DUALTreeU d u a l = DUALTreeU { unDUALTreeU :: (u, DUALTreeNE d u a l) } + deriving (Functor, Semigroup, Typeable, Show, Eq) + +instance Newtype (DUALTreeU d u a l) (u, DUALTreeNE d u a l) where + pack = DUALTreeU + unpack = unDUALTreeU + +instance (Semigroup d, Semigroup u, Action d u) + => Action (DAct d) (DUALTreeU d u a l) where + act d = over DUALTreeU (act (unDAct d) *** act d) + +-- | \"Pull\" the root @u@ annotation out into a tuple. +pullU :: (Semigroup u, Action d u) => DUALTreeNE d u a l -> DUALTreeU d u a l +pullU t@(Leaf u _) = pack (u, t) +pullU t@(LeafU u) = pack (u, t) +pullU t@(Concat ts) = pack (sconcat . NEL.map (fst . unpack) $ ts, t) +pullU t@(Act d (DUALTreeU (u,_))) = pack (act d u, t) +pullU t@(Annot _ (DUALTreeU (u, _))) = pack (u, t) + +------------------------------------------------------------ +-- DUALTree +------------------------------------------------------------ + +-- | Rose (n-ary) trees with both upwards- (/i.e./ cached) and +-- downwards-traveling (/i.e./ accumulating) monoidal annotations. +-- Abstractly, a DUALTree is a rose (n-ary) tree with data (of type +-- @l@) at leaves, data (of type @a@) at internal nodes, and two +-- types of monoidal annotations, one (of type @u@) travelling +-- \"up\" the tree and one (of type @d@) traveling \"down\". See +-- the documentation at the top of this file for full details. +-- +-- @DUALTree@ comes with some instances: +-- +-- * 'Functor', for modifying leaf data. Note that 'fmap' of course +-- cannot alter any @u@ annotations. +-- +-- * 'Semigroup'. @DUALTreeNE@s form a semigroup where @(\<\>)@ +-- corresponds to adjoining two trees under a common parent root, +-- with @sconcat@ specialized to put all the trees under a single +-- parent. Note that this does not satisfy associativity up to +-- structural equality, but only up to observational equivalence +-- under 'flatten'. Technically using 'foldDUAL' directly enables +-- one to observe the difference, but it is understood that +-- 'foldDUAL' should be used only in ways such that reassociation +-- of subtrees \"does not matter\". +-- +-- * 'Monoid'. The identity is the empty tree. + +newtype DUALTree d u a l = DUALTree { unDUALTree :: Option (DUALTreeU d u a l) } + deriving ( Functor, Semigroup, Typeable, Show, Eq ) + +instance Newtype (DUALTree d u a l) (Option (DUALTreeU d u a l)) where + pack = DUALTree + unpack = unDUALTree + +instance (Semigroup u, Action d u) => Monoid (DUALTree d u a l) where + mempty = DUALTree mempty + mappend = (<>) + mconcat [] = mempty + mconcat (x:xs) = sconcat (x :| xs) + +-- | Apply a @d@ annotation at the root of a tree. Semantically, all +-- @u@ annotations are transformed by the action of @d@, although +-- operationally @act@ incurs only a constant amount of work. +instance (Semigroup d, Semigroup u, Action d u) + => Action (DAct d) (DUALTree d u a l) where + act = over DUALTree . fmap . act + +------------------------------------------------------------ +-- Convenience methods etc. +------------------------------------------------------------ + +-- | The empty DUAL-tree. This is a synonym for 'mempty', but with a +-- more general type. +empty :: DUALTree d u a l +empty = DUALTree (Option Nothing) + +-- | Construct a leaf node from a @u@ annotation along with a leaf +-- datum. +leaf :: u -> l -> DUALTree d u a l +leaf u l = DUALTree (Option (Just (DUALTreeU (u, Leaf u l)))) + +-- | Construct a leaf node from a @u@ annotation. +leafU :: u -> DUALTree d u a l +leafU u = DUALTree (Option (Just (DUALTreeU (u, LeafU u)))) + +-- | Add a @u@ annotation to the root, combining it (on the left) with +-- the existing cached @u@ annotation. This function is provided +-- just for convenience; @applyUpre u t = 'leafU' u \<\> t@. +applyUpre :: (Semigroup u, Action d u) => u -> DUALTree d u a l -> DUALTree d u a l +applyUpre u t = leafU u <> t + +-- | Add a @u@ annotation to the root, combining it (on the right) with +-- the existing cached @u@ annotation. This function is provided +-- just for convenience; @applyUpost u t = t \<\> 'leafU' u@. +applyUpost :: (Semigroup u, Action d u) => u -> DUALTree d u a l -> DUALTree d u a l +applyUpost u t = t <> leafU u + +-- | Add an internal data value at the root of a tree. Note that this +-- only works on /non-empty/ trees; on empty trees this function is +-- the identity. +annot :: (Semigroup u, Action d u) => a -> DUALTree d u a l -> DUALTree d u a l +annot a = (over DUALTree . fmap) (pullU . Annot a) + +-- | Apply a @d@ annotation at the root of a tree, transforming all +-- @u@ annotations by the action of @d@. +applyD :: (Semigroup d, Semigroup u, Action d u) + => d -> DUALTree d u a l -> DUALTree d u a l +applyD = act . DAct + +-- | Decompose a DUAL-tree into either @Nothing@ (if empty) or a +-- top-level cached @u@ annotation paired with a non-empty +-- DUAL-tree. +nonEmpty :: DUALTree d u a l -> Maybe (u, DUALTreeNE d u a l) +nonEmpty = fmap unpack . getOption . unpack + +-- | Get the @u@ annotation at the root, or @Nothing@ if the tree is +-- empty. +getU :: DUALTree d u a l -> Maybe u +getU = fmap fst . nonEmpty + +------------------------------------------------------------ +-- Maps +------------------------------------------------------------ + +-- XXX todo: try adding Map as a constructor, so we can delay the +-- mapping until the end too? + +-- | Map a function (which must be a monoid homomorphism, and commute +-- with the action of @d@) over all the @u@ annotations in a non-empty +-- DUAL-tree. +mapUNE :: (u -> u') -> DUALTreeNE d u a l -> DUALTreeNE d u' a l +mapUNE f (Leaf u l) = Leaf (f u) l +mapUNE f (LeafU u) = LeafU (f u) +mapUNE f (Concat ts) = Concat ((NEL.map . mapUU) f ts) +mapUNE f (Act d t) = Act d (mapUU f t) +mapUNE f (Annot a t) = Annot a (mapUU f t) + +-- | Map a function (which must be a monoid homomorphism, and commute +-- with the action of @d@) over all the @u@ annotations in a +-- non-empty DUAL-tree paired with its cached @u@ value. +mapUU :: (u -> u') -> DUALTreeU d u a l -> DUALTreeU d u' a l +mapUU f = over DUALTreeU (f *** mapUNE f) + +-- | Map a function over all the @u@ annotations in a DUAL-tree. 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 mempty == mempty@ +-- +-- * @f (u1 \<\> u2) == f u1 \<\> f u2@ +-- +-- * @f (act d u) == act d (f u)@ +-- +mapU :: (u -> u') -> DUALTree d u a l -> DUALTree d u' a l +mapU = over DUALTree . fmap . mapUU + +------------------------------------------------------------ +-- Folds +------------------------------------------------------------ + +-- | Fold for non-empty DUAL-trees. +foldDUALNE :: (Semigroup d, Monoid d) + => (d -> l -> r) -- ^ Process a leaf datum along with the + -- accumulation of @d@ values along the + -- path from the root + -> r -- ^ Replace @LeafU@ nodes + -> (NonEmpty r -> r) -- ^ Combine results at a branch node + -> (a -> r -> r) -- ^ Process an internal datum + -> DUALTreeNE d u a l -> r +foldDUALNE = foldDUALNE' (Option Nothing) + where + foldDUALNE' dacc lf _ _ _ (Leaf _ l) = lf (option mempty id dacc) l + foldDUALNE' _ _ lfU _ _ (LeafU _) = lfU + foldDUALNE' dacc lf lfU con ann (Concat ts) + = con (NEL.map (foldDUALNE' dacc lf lfU con ann . snd . unpack) ts) + foldDUALNE' dacc lf lfU con ann (Act d t) + = foldDUALNE' (dacc <> (Option (Just d))) lf lfU con ann . snd . unpack $ t + foldDUALNE' dacc lf lfU con ann (Annot a t) + = ann a (foldDUALNE' dacc lf lfU con ann . snd . unpack $ t) + +-- | Fold for DUAL-trees. It is given access to the internal and leaf +-- data, and the accumulated @d@ values at each leaf. It is also +-- allowed to replace \"@u@-only\" leaves with a constant value. In +-- particular, however, it is /not/ given access to any of the @u@ +-- annotations, the idea being that those are used only for +-- /constructing/ trees. It is also not given access to @d@ values +-- as they occur in the tree, only as they accumulate at leaves. If +-- you do need access to @u@ or @d@ values, you can duplicate the +-- values you need in the internal data nodes. +-- +-- The result is @Nothing@ if and only if the tree is empty. +foldDUAL :: (Semigroup d, Monoid d) + => (d -> l -> r) -- ^ Process a leaf datum along with the + -- accumulation of @d@ values along the + -- path from the root + -> r -- ^ Replace @u@-only nodes + -> (NonEmpty r -> r) -- ^ Combine results at a branch node + -> (a -> r -> r) -- ^ Process an internal datum + -> DUALTree d u a l -> Maybe r +foldDUAL _ _ _ _ (DUALTree (Option Nothing)) + = Nothing +foldDUAL l u c a (DUALTree (Option (Just (DUALTreeU (_, t))))) + = Just $ foldDUALNE l u c a t + +-- | A specialized fold provided for convenience: flatten a tree into +-- a list of leaves along with their @d@ annotations, ignoring +-- internal data values. +flatten :: (Semigroup d, Monoid d) => DUALTree d u a l -> [(l, d)] +flatten = fromMaybe [] + . foldDUAL + (\d l -> [(l, d)]) + [] + (concat . NEL.toList) + (const id)