Combinators.hs

{-# LANGUAGE TypeFamilies
           , FlexibleContexts
           , UndecidableInstances
  #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Combinators
-- Copyright   :  (c) 2011 diagrams-lib team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Higher-level tools for combining diagrams.
--
-----------------------------------------------------------------------------

module Diagrams.Combinators
       ( -- * Unary operations

         withBounds
       , phantom, strut

       , pad

         -- * Binary operations
       , beside, besideBounds
       , append

         -- * n-ary operations
       , appends
       , position, decorateTrail
       , cat, cat', CatOpts(..), CatMethod(..)

       ) where

import Graphics.Rendering.Diagrams

import Diagrams.Segment (Segment(..))
import Diagrams.Path
import Diagrams.Align
import Diagrams.Util

import Data.AdditiveGroup
import Data.AffineSpace ((.-.))
import Data.VectorSpace

import Data.Monoid
import Data.List

import Data.Default

------------------------------------------------------------
-- Working with bounds
------------------------------------------------------------

-- XXX this isn't quite right!  Need to think about this a bit more...
-- | Use the bounding region from some boundable object as the
--   bounding region for a diagram, in place of the diagram's default
--   bounding region.
withBounds :: (Backend b (V a), Boundable a, Monoid m)
           => a -> AnnDiagram b (V a) m -> AnnDiagram b (V a) m
withBounds b d = d `atop` phantom b

-- | @phantom x@ produces a \"phantom\" diagram, which has the same
--   bounding region as @x@ but produces no output.
phantom :: (Backend b (V a), Boundable a, Monoid m) => a -> AnnDiagram b (V a) m
phantom a = mkAD nullPrim (getBounds a) mempty mempty

-- | @pad s@ \"pads\" a diagram, expanding its bounding region by a
--   factor of @s@.  Note that the bounding region will expand with
--   respect to the local origin, so if the origin is not centered the
--   padding may appear \"uneven\".  If this is not desired, the
--   origin can be centered (using, e.g., 'centerXY' for 2D diagrams)
--   before applying @pad@.
pad :: ( Backend b v
       , InnerSpace v, OrderedField (Scalar v)
       , Monoid m )
    => Scalar v -> AnnDiagram b v m -> AnnDiagram b v m
pad s d = withBounds (d # scale s) d

-- | @strut v@ is a diagram which produces no output, but for the
--   purposes of alignment and bounding regions acts like a
--   1-dimensional segment oriented along the vector @v@.  Useful for
--   manually creating separation between two diagrams.
strut :: ( Backend b v, InnerSpace v
         , OrderedField (Scalar v)
         , Monoid m
         )
      => v -> AnnDiagram b v m
strut v = phantom $ getBounds (Linear v)

------------------------------------------------------------
-- Combining two objects
------------------------------------------------------------

-- | Place two bounded, monoidal objects (i.e. diagrams or paths) next
--   to each other along the given vector.  In particular, place the
--   first object so that the vector points from its local origin to
--   the local origin of the second object, at a distance so that
--   their bounding regions are just tangent.  The local origin of the
--   new, combined object is at the point of tangency, along the line
--   between the old local origins.
--
--   XXX picture
beside :: (HasOrigin a, Boundable a, Monoid a) => V a -> a -> a -> a
beside v d1 d2
  = align v d1 <> align (negateV v) d2

-- Note that sending the origin to the point of tangency like this
-- means that (beside v) is not associative.  We can make it
-- associative if we specify that the origin of the new, composed
-- diagram is the same as the local origin of the first diagram (or,
-- dually, of the second).  But then mempty is only a right identity,
-- not a left identity.  (To be sure, with the current implementation
-- mempty is no identity at all!)  We could make (beside v) a monoidal
-- operation (associative, with mempty as identity) if we always
-- center the origin along v after combining.  That sounds nice from a
-- theoretical point of view but not from a usability point of view...

-- | @besideBounds b v x@ positions @x@ so it is beside the bounding
--   region @b@ in the direction of @v@.  The origin of the new
--   diagram is the origin of the bounding region.
besideBounds :: (HasOrigin a, Boundable a) => Bounds (V a) -> V a -> a -> a
besideBounds b v a
  = moveOriginBy (origin .-. boundary v b) (align (negateV v) a)

-- | Like 'beside', but the origin of the final combined object is the
--   origin of the first object.  See also 'appends'.
append :: (HasOrigin a, Boundable a, Monoid a) => V a -> a -> a -> a
append v d1 d2 = appends d1 [(v,d2)]

------------------------------------------------------------
-- Combining multiple objects
------------------------------------------------------------

-- | @appends x ys@ appends each of the objects in @ys@ to the object
--   @x@ in the corresponding direction.  Note that each object in
--   @ys@ is positioned beside @x@ /without/ reference to the other
--   objects in @ys@, so this is not the same as iterating @append@.
appends :: (HasOrigin a, Boundable a, Monoid a) => a -> [(V a,a)] -> a
appends d1 apps = d1 <> mconcat (map (uncurry (besideBounds b)) apps)
  where b = getBounds d1

-- | Position things absolutely: combine a list of objects
-- (e.g. diagrams or paths) by assigning them absolute positions in
-- the vector space of the combined object.
position :: (HasOrigin a, Qualifiable a, Monoid a) => [(Point (V a), a)] -> a
position = mconcat . zipWith (|>) [1::Integer ..] . map (uncurry moveTo)

-- | Combine a list of diagrams (or paths) by using them to
--   \"decorate\" a trail, placing the local origin of one object at
--   each successive vertex of the trail.  If the trail and list of
--   objects have different lengths, the extra tail of the longer one
--   is ignored.
decorateTrail :: (HasOrigin a, Qualifiable a, Monoid a) => Trail (V a) -> [a] -> a
decorateTrail t = position . zip (trailVertices origin t)

-- | Methods for concatenating diagrams.
data CatMethod = Cat     -- ^ Normal catenation: simply put diagrams
                         --   next to one another (possibly with a
                         --   certain distance in between each). The
                         --   distance between successive diagram
                         --   /boundaries/ will be consistent; the
                         --   distance between /origins/ may vary if
                         --   the diagrams are of different sizes.
               | Distrib -- ^ Distribution: place the local origins of
                         --   diagrams at regular intervals.  With
                         --   this method, the distance between
                         --   successive /origins/ will be consistent
                         --   but the distance between boundaries may
                         --   not be.  Indeed, depending on the amount
                         --   of separation, diagrams may overlap.

-- | Options for 'cat''.
data CatOpts v = CatOpts { catMethod       :: CatMethod
                             -- ^ Which 'CatMethod' should be used:
                             --   normal catenation (default), or
                             --   distribution?
                         , sep             :: Scalar v
                             -- ^ How much separation should be used
                             --   between successive diagrams
                             --   (default: 0)?  When @catMethod =
                             --   Cat@, this is the distance between
                             --   /boundaries/; when @catMethod =
                             --   Distrib@, this is the distance
                             --   between /origins/.
                         , catOptsvProxy__ :: Proxy v
                             -- ^ This field exists solely to aid type inference;
                             --   please ignore it.
                         }

-- The reason the proxy field is necessary is that without it,
-- altering the sep field could theoretically change the type of a
-- CatOpts record.  This causes problems when writing an expression
-- like @with { sep = 10 }@, because knowing the type of the whole
-- expression does not tell us anything about the type of @with@, and
-- therefore the @Num (Scalar v)@ constraint cannot be satisfied.
-- Adding the Proxy field constrains the type of @with@ in @with {sep
-- = 10}@ to be the same as the type of the whole expression.

instance Num (Scalar v) => Default (CatOpts v) where
  def = CatOpts { catMethod       = Cat
                , sep             = 0
                , catOptsvProxy__ = Proxy
                }

-- | @cat v@ positions a list of objects so that their local origins
--   lie along a line in the direction of @v@.  Successive objects
--   will have their bounding regions just touching.  The local origin
--   of the result will be the same as the local origin of the first
--   object.
--
--   See also 'cat'', which takes an extra options record allowing
--   certain aspects of the operation to be tweaked.
cat :: (HasOrigin a, Boundable a, Qualifiable a, Monoid a) => V a -> [a] -> a
cat v = cat' v def

-- | Like 'cat', but taking an extra 'CatOpts' arguments allowing the
--   user to specify
--
--   * The spacing method: catenation (uniform spacing between
--     boundaries) or distribution (uniform spacing between local
--     origins).  The default is catenation.
--
--   * The amount of separation between successive diagram
--     boundaries/origins (depending on the spacing method).  The
--     default is 0.
--
--   'CatOpts' is an instance of 'Default', so 'with' may be used for
--   the second argument, as in @cat' (1,2) with {sep = 2}@.
--
--   Note that @cat' v with {catMethod = Distrib} === mconcat@
--   (distributing with a separation of 0 is the same as
--   superimposing).
cat' :: (HasOrigin a, Boundable a, Qualifiable a, Monoid a)
     => V a -> CatOpts (V a) -> [a] -> a
cat' _ (CatOpts { catMethod = Cat }) []     = mempty
cat' _ (CatOpts { catMethod = Cat }) [d]    = (1::Integer) |> d
cat' v (CatOpts { catMethod = Cat, sep = s }) (d:ds) =
  foldl' (\d1 d2 ->
           d1 <> (moveOriginBy (origin .-. boundary v d1)
                  . moveOriginBy (withLength s (negateV v))
                  . align (negateV v)
                  $ d2)
         )
         ((1::Integer) |> d)
         (zipWith (|>) [2::Integer ..] ds)

cat' v (CatOpts { catMethod = Distrib, sep = s }) ds =
  decorateTrail (fromOffsets (repeat (withLength s v))) ds
  -- infinite trail, no problem for Haskell =D