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

         withEnvelope, withTrace
       , phantom, strut
       , pad
       , extrudeEnvelope, intrudeEnvelope

         -- * Binary operations
       , beneath
       , beside

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

       ) where

import Diagrams.Core

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

import Data.AdditiveGroup
import Data.VectorSpace

import Data.Semigroup

import Data.Default

------------------------------------------------------------
-- Working with envelopes
------------------------------------------------------------

-- | Use the envelope from some object as the envelope for a
--   diagram, in place of the diagram's default envelope.
withEnvelope :: (HasLinearMap (V a), Enveloped a, Monoid' m)
           => a -> QDiagram b (V a) m -> QDiagram b (V a) m
withEnvelope = setEnvelope . getEnvelope

-- | Use the trace from some object as the trace for a diagram, in
--   place of the diagram's default trace.
withTrace :: (HasLinearMap (V a), Traced a, OrderedField (Scalar (V a)), InnerSpace (V a), Monoid' m)
          => a -> QDiagram b (V a) m -> QDiagram b (V a) m
withTrace = setTrace . getTrace

-- | @phantom x@ produces a \"phantom\" diagram, which has the same
--   envelope and trace as @x@ but produces no output.
phantom :: (Backend b (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m
phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty

-- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of
--   @s@ (factors between 0 and 1 can be used to shrink the envelope).
--   Note that the envelope 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 -> QDiagram b v m -> QDiagram b v m
pad s d = withEnvelope (d # scale s) d

-- | @strut v@ is a diagram which produces no output, but with respect
--   to alignment and envelope acts like a 1-dimensional segment
--   oriented along the vector @v@, with local origin at its
--   center. (Note, however, that it has an empty trace; for 2D struts
--   with a nonempty trace see 'strutR2', 'strutX', and 'strutY' from
--   "Diagrams.TwoD.Combinators".) Useful for manually creating
--   separation between two diagrams.
strut :: ( Backend b v, InnerSpace v
         , OrderedField (Scalar v)
         , Monoid' m
         )
      => v -> QDiagram b v m
strut v = mkQD nullPrim env mempty mempty mempty
  where env = translate ((-0.5) *^ v) . getEnvelope $ Linear v
  -- note we can't use 'phantom' here because it tries to construct a
  -- trace as well, and segments do not have a trace in general (only
  -- in 2D; see Diagrams.TwoD.Segment).  This is a good reason to have
  -- a special 'strut' combinator (before the introduction of traces
  -- it was mostly just for convenience).
  --
  -- also note that we can't remove the call to getEnvelope, since
  -- translating a segment has no effect.

-- | @extrudeEnvelope v d@ asymmetrically \"extrudes\" the envelope of
--   a diagram in the given direction.  All parts of the envelope
--   within 90 degrees of this direction are modified, offset outwards
--   by the magnitude of the vector.
--
--   This works by offsetting the envelope distance proportionally to
--   the cosine of the difference in angle, and leaving it unchanged
--   when this factor is negative.
extrudeEnvelope
  :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v)
     , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m )
  => v -> QDiagram b v m -> QDiagram b v m
extrudeEnvelope = deformEnvelope 0.5

-- | @intrudeEnvelope v d@ asymmetrically \"intrudes\" the envelope of
--   a diagram away from the given direction.  All parts of the envelope
--   within 90 degrees of this direction are modified, offset inwards
--   by the magnitude of the vector.
--
--   Note that this could create strange inverted envelopes, where
--   @ diameter v d < 0 @.
intrudeEnvelope
  :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v)
     , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m )
  => v -> QDiagram b v m -> QDiagram b v m
intrudeEnvelope = deformEnvelope (-0.5)

-- Utility for extrudeEnvelope / intrudeEnvelope
deformEnvelope
  :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v)
     , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m )
  => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m
deformEnvelope s v d = setEnvelope (inEnvelope deform $ getEnvelope d) d
  where
    deform = Option . fmap deform' . getOption
    deform' env v'
        | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v'
        | otherwise = env v'
      where
        dot = v' <.> v

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

-- | @beneath@ is just a convenient synonym for @'flip' 'atop'@; that is,
--   @d1 \`beneath\` d2@ is the diagram with @d2@ superimposed on top of
--   @d1@.
beneath :: (HasLinearMap v, OrderedField (Scalar v), InnerSpace v, Monoid' m)
     => QDiagram b v m -> QDiagram b v m -> QDiagram b v m
beneath = flip atop

infixl 6 `beneath`

-- | Place two monoidal objects (/i.e./ diagrams, paths,
--   animations...) next to each other along the given vector.  In
--   particular, place the second object so that the vector points
--   from the local origin of the first object to the local origin of
--   the second object, at a distance so that their envelopes are just
--   tangent.  The local origin of the new, combined object is the
--   local origin of the first object.
--
--   Note that @beside v@ is associative, so objects under @beside v@
--   form a semigroup for any given vector @v@.  However, they do
--   /not/ form a monoid, since there is no identity element. 'mempty'
--   is a right identity (@beside v d1 mempty === d1@) but not a left
--   identity (@beside v mempty d1 === d1 # align (negateV v)@).
--
--   In older versions of diagrams, @beside@ put the local origin of
--   the result at the point of tangency between the two inputs.  That
--   semantics can easily be recovered by performing an alignment on
--   the first input before combining.  That is, if @beside'@ denotes
--   the old semantics,
--
--   > beside' v x1 x2 = beside v (x1 # align v) x2
--
--   To get something like @beside v x1 x2@ whose local origin is
--   identified with that of @x2@ instead of @x1@, use @beside
--   (negateV v) x2 x1@.
beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a
beside v d1 d2 = d1 <> juxtapose v d1 d2

-- XXX add picture to above documentation?

------------------------------------------------------------
-- 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 'beside'.
appends :: (Juxtaposable a, Monoid' a) => a -> [(V a,a)] -> a
appends d1 apps = d1 <> mconcat (map (\(v,d) -> juxtapose v d1 d) apps)

-- | 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, Monoid' a) => [(Point (V a), a)] -> a
position = mconcat . 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.  The first vertex of the
--   trail is placed at the origin.  If the trail and list of objects
--   have different lengths, the extra tail of the longer one is
--   ignored.
decorateTrail :: (HasOrigin a, Monoid' a) => Trail (V a) -> [a] -> a
decorateTrail t = position . zip (trailVertices origin t)

-- | Combine a list of diagrams (or paths) by using them to
--   \"decorate\" a path, placing the local origin of one object at
--   each successive vertex of the path.  If the path and list of objects
--   have different lengths, the extra tail of the longer one is
--   ignored.
decoratePath :: (HasOrigin a, Monoid' a) => Path (V a) -> [a] -> a
decoratePath p = position . zip (concat $ pathVertices p)

-- | 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
                         --   /envelopes/ 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 envelopes 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
                             --   /envelopes/; 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 envelopes 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 :: ( Juxtaposable a, Monoid' a, HasOrigin a
       , InnerSpace (V a), Floating (Scalar (V 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
--     envelopes) or distribution (uniform spacing between local
--     origins).  The default is catenation.
--
--   * The amount of separation between successive diagram
--     envelopes/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' :: ( Juxtaposable a, Monoid' a, HasOrigin a
        , InnerSpace (V a), Floating (Scalar (V a))
        )
     => V a -> CatOpts (V a) -> [a] -> a
cat' v (CatOpts { catMethod = Cat, sep = s }) = foldB comb mempty
  where comb d1 d2 = d1 <> (juxtapose v d1 d2 # moveOriginBy vs)
        vs = s *^ normalized (negateV v)

cat' v (CatOpts { catMethod = Distrib, sep = s }) =
  decorateTrail . fromOffsets . repeat $ s *^ normalized v
  -- infinite trail, no problem for Haskell =D