{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE 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, frame
       , extrudeEnvelope, intrudeEnvelope

         -- * Binary operations
       , atop
       , beneath
       , beside
       , atDirection

         -- * n-ary operations
       , appends
       , position, atPoints
       , cat, cat'
       , CatOpts(_catMethod, _sep), catMethod, sep
       , CatMethod(..)
       , composeAligned

       ) where

import           Control.Lens          hiding (beside, ( # ))
import           Data.Default.Class
import           Data.Maybe            (fromJust)
import           Data.Monoid.Deletable (toDeletable)
import           Data.Monoid.MList     (inj)
import           Data.Proxy
import           Data.Semigroup
import qualified Data.Tree.DUAL        as D

import           Diagrams.Core
import           Diagrams.Core.Types   (QDiagram (QD))
import           Diagrams.Direction
import           Diagrams.Names        (named)
import           Diagrams.Segment      (straight)
import           Diagrams.Util

import           Linear.Affine
import           Linear.Metric
import           Linear.Vector

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

-- | Use the envelope from some object as the envelope for a
--   diagram, in place of the diagram's default envelope.
--
--   <<diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg#diagram=withEnvelopeEx&width=300>>
--
--   > sqNewEnv =
--   >     circle 1 # fc green
--   >     |||
--   >     (    c # dashingG [0.1,0.1] 0 # lc white
--   >       <> square 2 # withEnvelope (c :: D V2 Double) # fc blue
--   >     )
--   > c = circle 0.8
--   > withEnvelopeEx = sqNewEnv # centerXY # pad 1.5
withEnvelope :: (InSpace v n a, Monoid' m, Enveloped a)
           => a -> QDiagram b v n m -> QDiagram b v n m
withEnvelope :: forall (v :: * -> *) n a m b.
(InSpace v n a, Monoid' m, Enveloped a) =>
a -> QDiagram b v n m -> QDiagram b v n m
withEnvelope = Envelope v n -> QDiagram b v n m -> QDiagram b v n m
forall b (v :: * -> *) n m.
(OrderedField n, Metric v, Monoid' m) =>
Envelope v n -> QDiagram b v n m -> QDiagram b v n m
setEnvelope (Envelope v n -> QDiagram b v n m -> QDiagram b v n m)
-> (a -> Envelope v n) -> a -> QDiagram b v n m -> QDiagram b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Envelope v n
a -> Envelope (V a) (N a)
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope

-- | Use the trace from some object as the trace for a diagram, in
--   place of the diagram's default trace.
withTrace :: (InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a)
          => a -> QDiagram b v n m -> QDiagram b v n m
withTrace :: forall (v :: * -> *) n a m b.
(InSpace v n a, Metric v, OrderedField n, Monoid' m, Traced a) =>
a -> QDiagram b v n m -> QDiagram b v n m
withTrace = Trace v n -> QDiagram b v n m -> QDiagram b v n m
forall b (v :: * -> *) n m.
(OrderedField n, Metric v, Semigroup m) =>
Trace v n -> QDiagram b v n m -> QDiagram b v n m
setTrace (Trace v n -> QDiagram b v n m -> QDiagram b v n m)
-> (a -> Trace v n) -> a -> QDiagram b v n m -> QDiagram b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Trace v n
a -> Trace (V a) (N a)
forall a. Traced a => a -> Trace (V a) (N a)
getTrace

-- | @phantom x@ produces a \"phantom\" diagram, which has the same
--   envelope and trace as @x@ but produces no output.
phantom :: (InSpace v n a, Monoid' m, Enveloped a, Traced a) => a -> QDiagram b v n m
phantom :: forall (v :: * -> *) n a m b.
(InSpace v n a, Monoid' m, Enveloped a, Traced a) =>
a -> QDiagram b v n m
phantom a
a = DUALTree
  (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
forall b (v :: * -> *) n m.
DUALTree
  (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
QD (DUALTree
   (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
 -> QDiagram b v n m)
-> DUALTree
     (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
forall a b. (a -> b) -> a -> b
$ UpAnnots b v n m
-> DUALTree
     (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
forall u d a l. u -> DUALTree d u a l
D.leafU ((Deletable (Envelope v n) -> UpAnnots b v n m
forall l a. (l :>: a) => a -> l
inj (Deletable (Envelope v n) -> UpAnnots b v n m)
-> (a -> Deletable (Envelope v n)) -> a -> UpAnnots b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope v n -> Deletable (Envelope v n)
forall m. m -> Deletable m
toDeletable (Envelope v n -> Deletable (Envelope v n))
-> (a -> Envelope v n) -> a -> Deletable (Envelope v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Envelope v n
a -> Envelope (V a) (N a)
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope (a -> UpAnnots b v n m) -> a -> UpAnnots b v n m
forall a b. (a -> b) -> a -> b
$ a
a) UpAnnots b v n m -> UpAnnots b v n m -> UpAnnots b v n m
forall a. Semigroup a => a -> a -> a
<> (Deletable (Trace v n) -> UpAnnots b v n m
forall l a. (l :>: a) => a -> l
inj (Deletable (Trace v n) -> UpAnnots b v n m)
-> (a -> Deletable (Trace v n)) -> a -> UpAnnots b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace v n -> Deletable (Trace v n)
forall m. m -> Deletable m
toDeletable (Trace v n -> Deletable (Trace v n))
-> (a -> Trace v n) -> a -> Deletable (Trace v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Trace v n
a -> Trace (V a) (N a)
forall a. Traced a => a -> Trace (V a) (N a)
getTrace (a -> UpAnnots b v n m) -> a -> UpAnnots b v n m
forall a b. (a -> b) -> a -> b
$ a
a))

-- | @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 :: (Metric v, OrderedField n, Monoid' m)
    => n -> QDiagram b v n m -> QDiagram b v n m
pad :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
pad n
s QDiagram b v n m
d = QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
forall (v :: * -> *) n a m b.
(InSpace v n a, Monoid' m, Enveloped a) =>
a -> QDiagram b v n m -> QDiagram b v n m
withEnvelope (QDiagram b v n m
d QDiagram b v n m
-> (QDiagram b v n m -> QDiagram b v n m) -> QDiagram b v n m
forall a b. a -> (a -> b) -> b
# n -> QDiagram b v n m -> QDiagram b v n m
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
s) QDiagram b v n m
d

-- | @frame s@ increases the envelope of a diagram by and absolute amount @s@,
--   s is in the local units of the diagram. This function is similar to @pad@,
--   only it takes an absolute quantity and pre-centering should not be
--   necessary.
frame :: (Metric v, OrderedField n, Monoid' m)
        => n -> QDiagram b v n m -> QDiagram b v n m
frame :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> QDiagram b v n m -> QDiagram b v n m
frame n
s = ASetter
  (QDiagram b v n m) (QDiagram b v n m) (Envelope v n) (Envelope v n)
-> (Envelope v n -> Envelope v n)
-> QDiagram b v n m
-> QDiagram b v n m
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (QDiagram b v n m) (QDiagram b v n m) (Envelope v n) (Envelope v n)
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Monoid' m) =>
Lens' (QDiagram b v n m) (Envelope v n)
Lens' (QDiagram b v n m) (Envelope v n)
envelope (((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n
forall (v :: * -> *) n.
((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n
onEnvelope (((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n)
-> ((v n -> n) -> v n -> n) -> Envelope v n -> Envelope v n
forall a b. (a -> b) -> a -> b
$ \v n -> n
f v n
x -> v n -> n
f v n
x n -> n -> n
forall a. Num a => a -> a -> a
+ n
s)

-- | @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' from
--   "Diagrams.TwoD.Combinators".) Useful for manually creating
--   separation between two diagrams.
--
--   <<diagrams/src_Diagrams_Combinators_strutEx.svg#diagram=strutEx&width=300>>
--
--   > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1
strut :: (Metric v, OrderedField n)
      => v n -> QDiagram b v n m
strut :: forall (v :: * -> *) n b m.
(Metric v, OrderedField n) =>
v n -> QDiagram b v n m
strut v n
v = DUALTree
  (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
forall b (v :: * -> *) n m.
DUALTree
  (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
QD (DUALTree
   (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
 -> QDiagram b v n m)
-> DUALTree
     (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> QDiagram b v n m
forall a b. (a -> b) -> a -> b
$ UpAnnots b v n m
-> DUALTree
     (DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
forall u d a l. u -> DUALTree d u a l
D.leafU (Deletable (Envelope v n) -> UpAnnots b v n m
forall l a. (l :>: a) => a -> l
inj (Deletable (Envelope v n) -> UpAnnots b v n m)
-> (Envelope v n -> Deletable (Envelope v n))
-> Envelope v n
-> UpAnnots b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Envelope v n -> Deletable (Envelope v n)
forall m. m -> Deletable m
toDeletable (Envelope v n -> UpAnnots b v n m)
-> Envelope v n -> UpAnnots b v n m
forall a b. (a -> b) -> a -> b
$ Envelope v n
env)
  where env :: Envelope v n
env = Vn (Envelope v n) -> Envelope v n -> Envelope v n
forall t. Transformable t => Vn t -> t -> t
translate ((-n
0.5) n -> v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n
v) (Envelope v n -> Envelope v n)
-> (Segment Closed v n -> Envelope v n)
-> Segment Closed v n
-> Envelope v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Segment Closed v n -> Envelope v n
Segment Closed v n
-> Envelope (V (Segment Closed v n)) (N (Segment Closed v n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope (Segment Closed v n -> Envelope v n)
-> Segment Closed v n -> Envelope v n
forall a b. (a -> b) -> a -> b
$ v n -> Segment Closed v n
forall (v :: * -> *) n. v n -> Segment Closed v n
straight v n
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
  :: (Metric v, OrderedField n, Monoid' m)
  => v n -> QDiagram b v n m -> QDiagram b v n m
extrudeEnvelope :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
v n -> QDiagram b v n m -> QDiagram b v n m
extrudeEnvelope = n -> v n -> QDiagram b v n m -> QDiagram b v n m
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> v n -> QDiagram b v n m -> QDiagram b v n m
deformEnvelope n
1

-- | @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
  :: (Metric v, OrderedField n, Monoid' m)
  => v n -> QDiagram b v n m -> QDiagram b v n m
intrudeEnvelope :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
v n -> QDiagram b v n m -> QDiagram b v n m
intrudeEnvelope = n -> v n -> QDiagram b v n m -> QDiagram b v n m
forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> v n -> QDiagram b v n m -> QDiagram b v n m
deformEnvelope (-n
1)

-- Utility for extrudeEnvelope / intrudeEnvelope
deformEnvelope
  :: (Metric v, OrderedField n, Monoid' m)
  => n -> v n -> QDiagram b v n m -> QDiagram b v n m
deformEnvelope :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
n -> v n -> QDiagram b v n m -> QDiagram b v n m
deformEnvelope n
s v n
v = ASetter
  (QDiagram b v n m)
  (QDiagram b v n m)
  (Maybe (v n -> Max n))
  (Maybe (v n -> Max n))
-> (Maybe (v n -> Max n) -> Maybe (v n -> Max n))
-> QDiagram b v n m
-> QDiagram b v n m
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Envelope v n -> Identity (Envelope v n))
-> QDiagram b v n m -> Identity (QDiagram b v n m)
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Monoid' m) =>
Lens' (QDiagram b v n m) (Envelope v n)
Lens' (QDiagram b v n m) (Envelope v n)
envelope ((Envelope v n -> Identity (Envelope v n))
 -> QDiagram b v n m -> Identity (QDiagram b v n m))
-> ((Maybe (v n -> Max n) -> Identity (Maybe (v n -> Max n)))
    -> Envelope v n -> Identity (Envelope v n))
-> ASetter
     (QDiagram b v n m)
     (QDiagram b v n m)
     (Maybe (v n -> Max n))
     (Maybe (v n -> Max n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (Envelope v n) -> Envelope v n)
-> Iso
     (Envelope v n)
     (Envelope v n)
     (Unwrapped (Envelope v n))
     (Unwrapped (Envelope v n))
forall s t.
Rewrapping s t =>
(Unwrapped s -> s) -> Iso s t (Unwrapped s) (Unwrapped t)
_Wrapping Maybe (v n -> Max n) -> Envelope v n
Unwrapped (Envelope v n) -> Envelope v n
forall (v :: * -> *) n. Maybe (v n -> Max n) -> Envelope v n
Envelope) Maybe (v n -> Max n) -> Maybe (v n -> Max n)
deformE
  where
    deformE :: Maybe (v n -> Max n) -> Maybe (v n -> Max n)
deformE = ((v n -> Max n) -> v n -> Max n)
-> Maybe (v n -> Max n) -> Maybe (v n -> Max n)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (v n -> Max n) -> v n -> Max n
deformE'
    deformE' :: (v n -> Max n) -> v n -> Max n
deformE' v n -> Max n
env v n
v'
        | n
dp n -> n -> Bool
forall a. Ord a => a -> a -> Bool
> n
0    = n -> Max n
forall a. a -> Max a
Max (n -> Max n) -> n -> Max n
forall a b. (a -> b) -> a -> b
$ Max n -> n
forall a. Max a -> a
getMax (v n -> Max n
env v n
v') n -> n -> n
forall a. Num a => a -> a -> a
+ (n
dp n -> n -> n
forall a. Num a => a -> a -> a
* n
s) n -> n -> n
forall a. Fractional a => a -> a -> a
/ v n -> n
forall a. Num a => v a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance v n
v'
        | Bool
otherwise = v n -> Max n
env v n
v'
      where
        dp :: n
dp = v n
v' v n -> v n -> n
forall a. Num a => v a -> v a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` v n
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 :: (Metric v, OrderedField n, Monoid' m)
     => QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
beneath :: forall (v :: * -> *) n m b.
(Metric v, OrderedField n, Monoid' m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
beneath = (QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m)
-> QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
forall a b c. (a -> b -> c) -> b -> a -> c
flip QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
forall n (v :: * -> *) m b.
(OrderedField n, Metric v, Semigroup m) =>
QDiagram b v n m -> QDiagram b v n m -> QDiagram b v n m
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 (unless the first object is the
--   identity element, in which case the second object is returned
--   unchanged).
--
--   <<diagrams/src_Diagrams_Combinators_besideEx.svg#diagram=besideEx&height=200>>
--
--   > besideEx = beside (r2 (20,30))
--   >                   (circle 1 # fc orange)
--   >                   (circle 1.5 # fc purple)
--   >            # showOrigin
--   >            # centerXY # pad 1.1
--
--   Note that @beside v@ is associative, so objects under @beside v@
--   form a semigroup for any given vector @v@.  In fact, they also
--   form a monoid: 'mempty' is clearly a right identity (@beside v d1
--   mempty === d1@), and there should also be a special case to make
--   it a left identity, as described above.
--
--   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) => Vn a -> a -> a -> a
beside :: forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside Vn a
v a
d1 a
d2 = a
d1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> Vn a -> a -> a -> a
forall a. Juxtaposable a => Vn a -> a -> a -> a
juxtapose Vn a
v a
d1 a
d2

-- | Place two diagrams (or other juxtaposable objects) adjacent to
--   one another, with the second diagram placed in the direction 'd'
--   from the first.  The local origin of the resulting combined
--   diagram is the same as the local origin of the first.  See the
--   documentation of 'beside' for more information.
atDirection :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Semigroup a)
            => Direction v n -> a -> a -> a
atDirection :: forall (v :: * -> *) n a.
(InSpace v n a, Metric v, Floating n, Juxtaposable a,
 Semigroup a) =>
Direction v n -> a -> a -> a
atDirection = v n -> a -> a -> a
Vn a -> a -> a -> a
forall a. (Juxtaposable a, Semigroup a) => Vn a -> a -> a -> a
beside (v n -> a -> a -> a)
-> (Direction v n -> v n) -> Direction v n -> a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction v n -> v n
forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection

------------------------------------------------------------
-- 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'.
--
--   <<diagrams/src_Diagrams_Combinators_appendsEx.svg#diagram=appendsEx&width=200>>
--
--   > appendsEx = appends c (zip (iterateN 6 (rotateBy (1/6)) unitX) (repeat c))
--   >             # centerXY # pad 1.1
--   >   where c = circle 1
appends :: (Juxtaposable a, Monoid' a) => a -> [(Vn a,a)] -> a
appends :: forall a. (Juxtaposable a, Monoid' a) => a -> [(Vn a, a)] -> a
appends a
d1 [(Vn a, a)]
apps = a
d1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> [a] -> a
forall a. Monoid a => [a] -> a
mconcat (((Vn a, a) -> a) -> [(Vn a, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\(Vn a
v,a
d) -> Vn a -> a -> a -> a
forall a. Juxtaposable a => Vn a -> a -> a -> a
juxtapose Vn a
v a
d1 a
d) [(Vn a, a)]
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.
--
--   <<diagrams/src_Diagrams_Combinators_positionEx.svg#diagram=positionEx&height=300>>
--
--   > positionEx = position (zip (map mkPoint [-3, -2.8 .. 3]) (repeat spot))
--   >   where spot      = circle 0.2 # fc black
--   >         mkPoint :: Double -> P2 Double
--   >         mkPoint x = p2 (x,x*x)
position :: (InSpace v n a, HasOrigin a, Monoid' a) => [(Point v n, a)] -> a
position :: forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[(Point v n, a)] -> a
position = [a] -> a
forall a. Monoid a => [a] -> a
mconcat ([a] -> a) -> ([(Point v n, a)] -> [a]) -> [(Point v n, a)] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Point v n, a) -> a) -> [(Point v n, a)] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map ((Point v n -> a -> a) -> (Point v n, a) -> a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Point v n -> a -> a
forall (v :: * -> *) n t.
(InSpace v n t, HasOrigin t) =>
Point v n -> t -> t
moveTo)

-- | Curried version of @position@, takes a list of points and a list of
--   objects.
atPoints :: (InSpace v n a, HasOrigin a, Monoid' a) => [Point v n] -> [a] -> a
atPoints :: forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[Point v n] -> [a] -> a
atPoints [Point v n]
ps [a]
as = [(Point v n, a)] -> a
forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[(Point v n, a)] -> a
position ([(Point v n, a)] -> a) -> [(Point v n, a)] -> a
forall a b. (a -> b) -> a -> b
$ [Point v n] -> [a] -> [(Point v n, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Point v n]
ps [a]
as

-- | 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 n = CatOpts { forall n. CatOpts n -> CatMethod
_catMethod    :: CatMethod
                         , forall n. CatOpts n -> n
_sep          :: n
                         , forall n. CatOpts n -> Proxy n
catOptsvProxy :: Proxy n
                         }

-- 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 using record update, as
-- in @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.  Note
-- this is not a problem when using the 'sep' lens, as its type is
-- more restricted.

makeLensesWith (lensRules & generateSignatures .~ False) ''CatOpts

-- | Which 'CatMethod' should be used:
--   normal catenation (default), or distribution?
catMethod :: Lens' (CatOpts n) CatMethod

-- | 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/.
sep :: Lens' (CatOpts n) n

instance Num n => Default (CatOpts n) where
  def :: CatOpts n
def = CatOpts { _catMethod :: CatMethod
_catMethod    = CatMethod
Cat
                , _sep :: n
_sep          = n
0
                , catOptsvProxy :: Proxy n
catOptsvProxy = Proxy n
forall {k} (t :: k). Proxy t
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 :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a)
       => v n -> [a] -> a
cat :: forall (v :: * -> *) n a.
(InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a,
 HasOrigin a) =>
v n -> [a] -> a
cat v n
v = v n -> CatOpts n -> [a] -> a
forall (v :: * -> *) n a.
(InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a,
 HasOrigin a) =>
v n -> CatOpts n -> [a] -> a
cat' v n
v CatOpts n
forall a. Default a => a
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' :: (InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a, HasOrigin a)
     => v n -> CatOpts n -> [a] -> a
cat' :: forall (v :: * -> *) n a.
(InSpace v n a, Metric v, Floating n, Juxtaposable a, Monoid' a,
 HasOrigin a) =>
v n -> CatOpts n -> [a] -> a
cat' v n
v (CatOpts { _catMethod :: forall n. CatOpts n -> CatMethod
_catMethod = CatMethod
Cat, _sep :: forall n. CatOpts n -> n
_sep = n
s }) = (a -> a -> a) -> a -> [a] -> a
forall a. (a -> a -> a) -> a -> [a] -> a
foldB a -> a -> a
comb a
forall a. Monoid a => a
mempty
  where comb :: a -> a -> a
comb a
d1 a
d2 = a
d1 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> (Vn a -> a -> a -> a
forall a. Juxtaposable a => Vn a -> a -> a -> a
juxtapose v n
Vn a
v a
d1 a
d2 a -> (a -> a) -> a
forall a b. a -> (a -> b) -> b
# v n -> a -> a
forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy v n
vs)
        vs :: v n
vs = n
s n -> v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n -> v n
forall a. Floating a => v a -> v a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm (v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated v n
v)

cat' v n
v (CatOpts { _catMethod :: forall n. CatOpts n -> CatMethod
_catMethod = CatMethod
Distrib, _sep :: forall n. CatOpts n -> n
_sep = n
s }) =
  [(Point v n, a)] -> a
forall (v :: * -> *) n a.
(InSpace v n a, HasOrigin a, Monoid' a) =>
[(Point v n, a)] -> a
position ([(Point v n, a)] -> a) -> ([a] -> [(Point v n, a)]) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point v n] -> [a] -> [(Point v n, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((Point v n -> Point v n) -> Point v n -> [Point v n]
forall a. (a -> a) -> a -> [a]
iterate (Point v n -> Diff (Point v) n -> Point v n
forall a. Num a => Point v a -> Diff (Point v) a -> Point v a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (n
s n -> v n -> v n
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ v n -> v n
forall a. Floating a => v a -> v a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm v n
v)) Point v n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin)

-- | Compose a list of diagrams using the given composition function,
--   first aligning them all according to the given alignment, /but/
--   retain the local origin of the first diagram, as it would be if
--   the composition function were applied directly.  That is,
--   @composeAligned algn comp@ is equivalent to @translate v . comp
--   . map algn@ for some appropriate translation vector @v@.
--
--   Unfortunately, this only works for diagrams (and not, say, paths)
--   because there is no most general type for alignment functions,
--   and no generic way to find out what an alignment function does to
--   the origin of things.  (However, it should be possible to make a
--   version of this function that works /specifically/ on paths, if
--   such a thing were deemed useful.)
--
--   <<diagrams/src_Diagrams_Combinators_alignedEx1.svg#diagram=alignedEx1&width=400>>
--
--   > alignedEx1 = (hsep 2 # composeAligned alignT) (map circle [1,3,5,2])
--   >            # showOrigin
--   >            # frame 0.5
--
--   <<diagrams/src_Diagrams_Combinators_alignedEx2.svg#diagram=alignedEx2&width=400>>
--
--   > alignedEx2 = (mconcat # composeAligned alignTL) [circle 1, square 1, triangle 1, pentagon 1]
--   >            # showOrigin
--   >            # frame 0.1
composeAligned
  :: (Monoid' m, Floating n, Ord n, Metric v)
  => (QDiagram b v n m -> QDiagram b v n m)    -- ^ Alignment function
  -> ([QDiagram b v n m] -> QDiagram b v n m)  -- ^ Composition function
  -> ([QDiagram b v n m] -> QDiagram b v n m)
composeAligned :: forall m n (v :: * -> *) b.
(Monoid' m, Floating n, Ord n, Metric v) =>
(QDiagram b v n m -> QDiagram b v n m)
-> ([QDiagram b v n m] -> QDiagram b v n m)
-> [QDiagram b v n m]
-> QDiagram b v n m
composeAligned QDiagram b v n m -> QDiagram b v n m
_ [QDiagram b v n m] -> QDiagram b v n m
combine [] = [QDiagram b v n m] -> QDiagram b v n m
combine []
composeAligned QDiagram b v n m -> QDiagram b v n m
algn [QDiagram b v n m] -> QDiagram b v n m
comb (QDiagram b v n m
d:[QDiagram b v n m]
ds) = ([QDiagram b v n m] -> QDiagram b v n m
comb ([QDiagram b v n m] -> QDiagram b v n m)
-> [QDiagram b v n m] -> QDiagram b v n m
forall a b. (a -> b) -> a -> b
$ (QDiagram b v n m -> QDiagram b v n m)
-> [QDiagram b v n m] -> [QDiagram b v n m]
forall a b. (a -> b) -> [a] -> [b]
map QDiagram b v n m -> QDiagram b v n m
algn (QDiagram b v n m
dQDiagram b v n m -> [QDiagram b v n m] -> [QDiagram b v n m]
forall a. a -> [a] -> [a]
:[QDiagram b v n m]
ds)) QDiagram b v n m
-> (QDiagram b v n m -> QDiagram b v n m) -> QDiagram b v n m
forall a b. a -> (a -> b) -> b
# Point (V (QDiagram b v n m)) (N (QDiagram b v n m))
-> QDiagram b v n m -> QDiagram b v n m
forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point v n
Point (V (QDiagram b v n m)) (N (QDiagram b v n m))
l
  where
    mss :: Maybe [Subdiagram b v n m]
mss = ( (() () -> QDiagram b v n m -> QDiagram b v n m
forall q a. (Qualifiable q, IsName a) => a -> q -> q
forall a. IsName a => a -> QDiagram b v n m -> QDiagram b v n m
.>> QDiagram b v n m
d)   -- qualify first to avoid stomping on an existing () name
          # named ()     -- Mark the origin
          # algn         -- Apply the alignment function
          )
          -- then find out what happened to the origin
        QDiagram b v n m
-> Getting
     (Maybe [Subdiagram b v n m])
     (QDiagram b v n m)
     (Maybe [Subdiagram b v n m])
-> Maybe [Subdiagram b v n m]
forall s a. s -> Getting a s a -> a
^. (SubMap b v n m
 -> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m))
-> QDiagram b v n m
-> Const (Maybe [Subdiagram b v n m]) (QDiagram b v n m)
Lens' (QDiagram b v n m) (SubMap b v n m)
forall (v :: * -> *) m n b.
(Metric v, Semigroup m, OrderedField n) =>
Lens' (QDiagram b v n m) (SubMap b v n m)
subMap ((SubMap b v n m
  -> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m))
 -> QDiagram b v n m
 -> Const (Maybe [Subdiagram b v n m]) (QDiagram b v n m))
-> ((Maybe [Subdiagram b v n m]
     -> Const (Maybe [Subdiagram b v n m]) (Maybe [Subdiagram b v n m]))
    -> SubMap b v n m
    -> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m))
-> Getting
     (Maybe [Subdiagram b v n m])
     (QDiagram b v n m)
     (Maybe [Subdiagram b v n m])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Unwrapped (SubMap b v n m)
 -> Const (Maybe [Subdiagram b v n m]) (Unwrapped (SubMap b v n m)))
-> SubMap b v n m
-> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m)
forall s t. Rewrapping s t => Iso s t (Unwrapped s) (Unwrapped t)
Iso
  (SubMap b v n m)
  (SubMap b v n m)
  (Unwrapped (SubMap b v n m))
  (Unwrapped (SubMap b v n m))
_Wrapped ((Unwrapped (SubMap b v n m)
  -> Const (Maybe [Subdiagram b v n m]) (Unwrapped (SubMap b v n m)))
 -> SubMap b v n m
 -> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m))
-> ((Maybe [Subdiagram b v n m]
     -> Const (Maybe [Subdiagram b v n m]) (Maybe [Subdiagram b v n m]))
    -> Unwrapped (SubMap b v n m)
    -> Const (Maybe [Subdiagram b v n m]) (Unwrapped (SubMap b v n m)))
-> (Maybe [Subdiagram b v n m]
    -> Const (Maybe [Subdiagram b v n m]) (Maybe [Subdiagram b v n m]))
-> SubMap b v n m
-> Const (Maybe [Subdiagram b v n m]) (SubMap b v n m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Unwrapped (SubMap b v n m))
-> Lens'
     (Unwrapped (SubMap b v n m))
     (Maybe (IxValue (Unwrapped (SubMap b v n m))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Control.Lens.at (() -> Name
forall a. IsName a => a -> Name
toName ())
    l :: Point v n
l   = Subdiagram b v n m -> Point v n
forall (v :: * -> *) n b m.
(Additive v, Num n) =>
Subdiagram b v n m -> Point v n
location (Subdiagram b v n m -> Point v n)
-> (Maybe [Subdiagram b v n m] -> Subdiagram b v n m)
-> Maybe [Subdiagram b v n m]
-> Point v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Subdiagram b v n m] -> Subdiagram b v n m
forall a. HasCallStack => [a] -> a
head ([Subdiagram b v n m] -> Subdiagram b v n m)
-> (Maybe [Subdiagram b v n m] -> [Subdiagram b v n m])
-> Maybe [Subdiagram b v n m]
-> Subdiagram b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [Subdiagram b v n m] -> [Subdiagram b v n m]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [Subdiagram b v n m] -> Point v n)
-> Maybe [Subdiagram b v n m] -> Point v n
forall a b. (a -> b) -> a -> b
$ Maybe [Subdiagram b v n m]
mss
          -- the fromJust is Justified since we put the () name in