{-# LANGUAGE CPP                       #-}
{-# LANGUAGE DefaultSignatures         #-}
{-# LANGUAGE TemplateHaskell           #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DeriveDataTypeable        #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Anchors
-- Copyright   :  (c) 2016 Bradley Hardy
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  bradleyhardy@live.com
--
-- An /anchor/ is a point on an object which can be used for alignment
-- by naming it, offering easier control over alignment compared to the
-- 'Diagrams.Align' module when aligning many objects.
--
-----------------------------------------------------------------------------

module Diagrams.Anchors
       (
         -- * Anchors
         Anchor
         -- * Anchored objects
       , Anchored
       , withAnchors
       , noAnchors
       , addAnchor
       , deleteAnchor
       , getAnchorOffset
       , alignAnchor
       , hasAnchor
       , unanchor
         -- * Positional anchors
       , PositionalAnchor (..)
       , rotateAnchors
       , rotatePosAnchors
         -- * Easily concatenate many anchored objects
       , anchorMany
       , anchorMany_
         -- * Debugging
       , showAnchor
       , showAnchor_)
       where

import           Diagrams.Names
import           Diagrams.Core
import           Diagrams.Path
import           Diagrams.TwoD.Model

import qualified Control.Lens     as Lens
import           Control.Lens     hiding (transform, (.>))
import           Data.List        (foldl')
import           Data.Map         (Map)
import qualified Data.Map         as Map
import           Data.Maybe       (fromJust, fromMaybe)
import qualified Data.Set         as Set
import           Data.Typeable    (Typeable)
#if !MIN_VERSION_base(4,11,0)
import           Data.Semigroup
#endif

import           Linear.Vector
import           Linear.V2
import           Linear.Affine

--------------------------------------------------------------------------------
--  Anchors
--------------------------------------------------------------------------------

type Anchor = Name

--------------------------------------------------------------------------------
--  Anchored objects
--------------------------------------------------------------------------------

-- | An 'Anchored' object which can be aligned to anchor points before
-- concatenating with other 'Anchored' objects. Note that when concatenating,
-- any anchors with the same names in each of the left and right operands will
-- be retained in the left operand, and lost in the right. To avoid this, qualify
-- anchors in each object using '(\>>/)'.
data Anchored t =
  Anchored
  { forall t. Anchored t -> Maybe Anchor
_currentAnchor :: Maybe Anchor
  , forall t. Anchored t -> Map Anchor (V t (N t))
_anchors :: Map Anchor (V t (N t))
  , forall t. Anchored t -> t
_anchoredObj :: t
  }

makeLenses ''Anchored

type instance N (Anchored t) = N t
type instance V (Anchored t) = V t

instance (HasOrigin t, Additive (V t), Num (N t)) => HasOrigin (Anchored t) where
  moveOriginTo :: Point (V (Anchored t)) (N (Anchored t)) -> Anchored t -> Anchored t
moveOriginTo p :: Point (V (Anchored t)) (N (Anchored t))
p@(P V (Anchored t) (N (Anchored t))
v) =
    (forall t. Lens' (Anchored t) t
anchoredObj forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall t. HasOrigin t => Point (V t) (N t) -> t -> t
moveOriginTo Point (V (Anchored t)) (N (Anchored t))
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
^-^ V (Anchored t) (N (Anchored t))
v))

instance (Transformable t) => Transformable (Anchored t) where
  transform :: Transformation (V (Anchored t)) (N (Anchored t))
-> Anchored t -> Anchored t
transform Transformation (V (Anchored t)) (N (Anchored t))
t =
    (forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (v :: * -> *) n. Transformation v n -> v n -> v n
apply Transformation (V (Anchored t)) (N (Anchored t))
t) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall t. Lens' (Anchored t) t
anchoredObj forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation (V (Anchored t)) (N (Anchored t))
t)

instance (Additive (V t), Num (N t), HasOrigin t, Semigroup t) => Semigroup (Anchored t) where
  Anchored t
o1 <> :: Anchored t -> Anchored t -> Anchored t
<> Anchored t
o2 =
    let updateObj :: Anchored t -> Anchored t
updateObj Anchored t
obj
          | Just Anchor
anchor <- Anchored t
objforall s a. s -> Getting a s a -> a
^.forall t. Lens' (Anchored t) (Maybe Anchor)
currentAnchor
            = forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy (forall t a.
(Num (N t), Additive (V t), IsName a) =>
a -> Anchored t -> V t (N t)
getAnchorOffset Anchor
anchor Anchored t
obj)
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall anchor t.
IsName anchor =>
anchor -> Anchored t -> Anchored t
deleteAnchor Anchor
anchor
            forall a b. (a -> b) -> a -> b
$ Anchored t
obj
          | Bool
otherwise = Anchored t
obj

        Anchored t
a1 <+> :: Anchored t -> Anchored t -> Anchored t
<+> Anchored t
a2 = forall t. Maybe Anchor -> Map Anchor (V t (N t)) -> t -> Anchored t
Anchored forall a. Maybe a
Nothing
                             ((Anchored t
a1 forall s a. s -> Getting a s a -> a
^. forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors) forall a. Semigroup a => a -> a -> a
<> (Anchored t
a2 forall s a. s -> Getting a s a -> a
^. forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors))
                             ((Anchored t
a1 forall s a. s -> Getting a s a -> a
^. forall t. Lens' (Anchored t) t
anchoredObj) forall a. Semigroup a => a -> a -> a
<> (Anchored t
a2 forall s a. s -> Getting a s a -> a
^. forall t. Lens' (Anchored t) t
anchoredObj))
    in forall {t}.
(HasOrigin t, Additive (V t), Num (N t)) =>
Anchored t -> Anchored t
updateObj Anchored t
o1 forall {t}. Semigroup t => Anchored t -> Anchored t -> Anchored t
<+> forall {t}.
(HasOrigin t, Additive (V t), Num (N t)) =>
Anchored t -> Anchored t
updateObj Anchored t
o2

instance (Additive (V t), Num (N t), HasOrigin t, Monoid' t) => Monoid (Anchored t) where
  mempty :: Anchored t
mempty = forall t. Maybe Anchor -> Map Anchor (V t (N t)) -> t -> Anchored t
Anchored forall a. Maybe a
Nothing forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
  mappend :: Anchored t -> Anchored t -> Anchored t
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance (Show (V t (N t)), Show t) => Show (Anchored t) where
  showsPrec :: Int -> Anchored t -> ShowS
showsPrec Int
p Anchored t
anch =
    forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Anchored t
anchforall s a. s -> Getting a s a -> a
^.forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
", " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Anchored t
anchforall s a. s -> Getting a s a -> a
^.forall t. Lens' (Anchored t) t
anchoredObj)

-- | Add another anchor to an already 'Anchored' object.
addAnchor :: IsName anchor => anchor -> V t (N t) -> Anchored t -> Anchored t
addAnchor :: forall anchor t.
IsName anchor =>
anchor -> V t (N t) -> Anchored t -> Anchored t
addAnchor anchor
anchor V t (N t)
val = forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at (forall a. IsName a => a -> Anchor
toName anchor
anchor) forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just V t (N t)
val

-- | Attach a list of anchors to an object, making it 'Anchored'.
withAnchors :: IsName anchor => [(anchor, V t (N t))] -> t -> Anchored t
withAnchors :: forall anchor t.
IsName anchor =>
[(anchor, V t (N t))] -> t -> Anchored t
withAnchors = forall t. Maybe Anchor -> Map Anchor (V t (N t)) -> t -> Anchored t
Anchored forall a. Maybe a
Nothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over (forall s t a b. Each s t a b => Traversal s t a b
each forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) forall a. IsName a => a -> Anchor
toName

-- | Turn an object into a trivial 'Anchored' object with no anchors.
noAnchors :: t -> Anchored t
noAnchors :: forall t. t -> Anchored t
noAnchors = forall t. Maybe Anchor -> Map Anchor (V t (N t)) -> t -> Anchored t
Anchored forall a. Maybe a
Nothing forall a. Monoid a => a
mempty

-- | Delete an anchor from an anchored object. Does nothing if the object does
-- not have the specified anchor.
deleteAnchor :: IsName anchor => anchor -> Anchored t -> Anchored t
deleteAnchor :: forall anchor t.
IsName anchor =>
anchor -> Anchored t -> Anchored t
deleteAnchor anchor
anchor = forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at (forall a. IsName a => a -> Anchor
toName anchor
anchor) forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing

-- | Get the offset from the origin of a particular anchor, or 'zero' if the object
-- does not have the specified anchor.
getAnchorOffset :: (Num (N t), Additive (V t), IsName a) => a -> Anchored t -> V t (N t)
getAnchorOffset :: forall t a.
(Num (N t), Additive (V t), IsName a) =>
a -> Anchored t -> V t (N t)
getAnchorOffset a
anchor = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
Lens.at (forall a. IsName a => a -> Anchor
toName a
anchor) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall a. a -> Maybe a -> a
fromMaybe forall (f :: * -> *) a. (Additive f, Num a) => f a
zero)

-- | Align an anchored object to an anchor. Subsequently concatening with '(<>)'
-- will take this into account.
alignAnchor :: (IsName a) => a -> Anchored t -> Anchored t
alignAnchor :: forall anchor t.
IsName anchor =>
anchor -> Anchored t -> Anchored t
alignAnchor a
anch = forall t. Lens' (Anchored t) (Maybe Anchor)
currentAnchor forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (forall a. IsName a => a -> Anchor
toName a
anch)

-- | Does the given anchored object have the given anchor?
hasAnchor :: (IsName a) => a -> Anchored t -> Bool
hasAnchor :: forall a t. IsName a => a -> Anchored t -> Bool
hasAnchor a
anchor = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall k a. Ord k => k -> Map k a -> Bool
Map.member (forall a. IsName a => a -> Anchor
toName a
anchor))

-- | Throw away anchors and get the underlying object.
unanchor
  :: Anchored t -> t
unanchor :: forall t. Anchored t -> t
unanchor = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. Lens' (Anchored t) t
anchoredObj

--------------------------------------------------------------------------------
--  Positional Anchors
--------------------------------------------------------------------------------

-- | A convenient type of positional anchors.
data PositionalAnchor
  = AnchorL
  | AnchorTL
  | AnchorT
  | AnchorTR
  | AnchorR
  | AnchorBR
  | AnchorB
  | AnchorBL
  deriving (PositionalAnchor -> PositionalAnchor -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PositionalAnchor -> PositionalAnchor -> Bool
$c/= :: PositionalAnchor -> PositionalAnchor -> Bool
== :: PositionalAnchor -> PositionalAnchor -> Bool
$c== :: PositionalAnchor -> PositionalAnchor -> Bool
Eq, Eq PositionalAnchor
PositionalAnchor -> PositionalAnchor -> Bool
PositionalAnchor -> PositionalAnchor -> Ordering
PositionalAnchor -> PositionalAnchor -> PositionalAnchor
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PositionalAnchor -> PositionalAnchor -> PositionalAnchor
$cmin :: PositionalAnchor -> PositionalAnchor -> PositionalAnchor
max :: PositionalAnchor -> PositionalAnchor -> PositionalAnchor
$cmax :: PositionalAnchor -> PositionalAnchor -> PositionalAnchor
>= :: PositionalAnchor -> PositionalAnchor -> Bool
$c>= :: PositionalAnchor -> PositionalAnchor -> Bool
> :: PositionalAnchor -> PositionalAnchor -> Bool
$c> :: PositionalAnchor -> PositionalAnchor -> Bool
<= :: PositionalAnchor -> PositionalAnchor -> Bool
$c<= :: PositionalAnchor -> PositionalAnchor -> Bool
< :: PositionalAnchor -> PositionalAnchor -> Bool
$c< :: PositionalAnchor -> PositionalAnchor -> Bool
compare :: PositionalAnchor -> PositionalAnchor -> Ordering
$ccompare :: PositionalAnchor -> PositionalAnchor -> Ordering
Ord, Int -> PositionalAnchor -> ShowS
[PositionalAnchor] -> ShowS
PositionalAnchor -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PositionalAnchor] -> ShowS
$cshowList :: [PositionalAnchor] -> ShowS
show :: PositionalAnchor -> String
$cshow :: PositionalAnchor -> String
showsPrec :: Int -> PositionalAnchor -> ShowS
$cshowsPrec :: Int -> PositionalAnchor -> ShowS
Show, Typeable, Int -> PositionalAnchor
PositionalAnchor -> Int
PositionalAnchor -> [PositionalAnchor]
PositionalAnchor -> PositionalAnchor
PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
PositionalAnchor
-> PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: PositionalAnchor
-> PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
$cenumFromThenTo :: PositionalAnchor
-> PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
enumFromTo :: PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
$cenumFromTo :: PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
enumFromThen :: PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
$cenumFromThen :: PositionalAnchor -> PositionalAnchor -> [PositionalAnchor]
enumFrom :: PositionalAnchor -> [PositionalAnchor]
$cenumFrom :: PositionalAnchor -> [PositionalAnchor]
fromEnum :: PositionalAnchor -> Int
$cfromEnum :: PositionalAnchor -> Int
toEnum :: Int -> PositionalAnchor
$ctoEnum :: Int -> PositionalAnchor
pred :: PositionalAnchor -> PositionalAnchor
$cpred :: PositionalAnchor -> PositionalAnchor
succ :: PositionalAnchor -> PositionalAnchor
$csucc :: PositionalAnchor -> PositionalAnchor
Enum)

instance IsName PositionalAnchor where

{-|
Given an 'Anchored' object containing the given list of anchors, rotate the
order of the given anchors clockwise by the given number of positions.

For example, given a diagram with positional anchors on it in these positions:

@
TL    T    TR

L          R

BL    B    BR
@

using @'rotatePosAnchors' 1 = 'rotateAnchors' (enumFrom AnchorL) 1@ will move
the anchors to these positions:

@
L     TL   T

BL         TR

B     BR   R
@

Using a parameter @n@ is equivalent to using @1@, @n@ times and a negative
number produces an anticlockwise rotation.

If any of the anchors do not exist, this function skips them.
-}
rotateAnchors :: (IsName anchor) => [anchor] -> Int -> Anchored t -> Anchored t
rotateAnchors :: forall anchor t.
IsName anchor =>
[anchor] -> Int -> Anchored t -> Anchored t
rotateAnchors [anchor]
allAnchorsList Int
n Anchored t
t =
  let allAnchorsSet :: Set Anchor
allAnchorsSet = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. IsName a => a -> Anchor
toName forall a b. (a -> b) -> a -> b
$ [anchor]
allAnchorsList
      allObjAnchors :: Map Anchor (V t (N t))
allObjAnchors = Anchored t
t forall s a. s -> Getting a s a -> a
^. forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors
      presentAnchorsSet :: Set Anchor
presentAnchorsSet = forall k a. Map k a -> Set k
Map.keysSet Map Anchor (V t (N t))
allObjAnchors forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set Anchor
allAnchorsSet
      presentAnchorsList :: [anchor]
presentAnchorsList = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Anchor
presentAnchorsSet) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsName a => a -> Anchor
toName) [anchor]
allAnchorsList
      rotateList :: Int -> [a] -> [a]
rotateList Int
k [a]
xs = forall a. Int -> [a] -> [a]
drop Int
k [a]
xs forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
take Int
k [a]
xs
      rotatedList :: [anchor]
rotatedList = forall a. Int -> [a] -> [a]
rotateList ((-Int
n) forall a. Integral a => a -> a -> a
`mod` forall (t :: * -> *) a. Foldable t => t a -> Int
length [anchor]
presentAnchorsList) [anchor]
presentAnchorsList
      findOriginalPairing :: anchor -> V t (N t)
findOriginalPairing anchor
posAnch = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (forall a. IsName a => a -> Anchor
toName anchor
posAnch) Map Anchor (V t (N t))
allObjAnchors
      originalOffsets :: [V t (N t)]
originalOffsets = forall a b. (a -> b) -> [a] -> [b]
map anchor -> V t (N t)
findOriginalPairing [anchor]
presentAnchorsList
      rotatedOffsets :: [(Anchor, V t (N t))]
rotatedOffsets = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map forall a. IsName a => a -> Anchor
toName [anchor]
rotatedList) [V t (N t)]
originalOffsets
      newObjAnchors :: Map Anchor (V t (N t))
newObjAnchors = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Anchor, V t (N t))]
rotatedOffsets forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Anchor (V t (N t))
allObjAnchors
  in Anchored t
t forall a b. a -> (a -> b) -> b
& forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Anchor (V t (N t))
newObjAnchors

-- | As 'rotateAnchors', but specialised to the list of all 'PositionalAnchor's.
rotatePosAnchors :: Int -> Anchored t -> Anchored t
rotatePosAnchors :: forall t. Int -> Anchored t -> Anchored t
rotatePosAnchors = forall anchor t.
IsName anchor =>
[anchor] -> Int -> Anchored t -> Anchored t
rotateAnchors (forall a. Enum a => a -> [a]
enumFrom PositionalAnchor
AnchorL)

--------------------------------------------------------------------------------
--  Qualifying Anchors
--------------------------------------------------------------------------------

instance Qualifiable t => Qualifiable (Anchored t) where
  .>> :: forall a. IsName a => a -> Anchored t -> Anchored t
(.>>) a
name =
    (forall t. Lens' (Anchored t) (Maybe Anchor)
currentAnchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (a
name forall a1 a2. (IsName a1, IsName a2) => a1 -> a2 -> Anchor
.>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall t. Lens' (Anchored t) (Map Anchor (V t (N t)))
anchors forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (a
name forall a1 a2. (IsName a1, IsName a2) => a1 -> a2 -> Anchor
.>)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall t. Lens' (Anchored t) t
anchoredObj forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (a
name forall q a. (Qualifiable q, IsName a) => a -> q -> q
.>>))

--------------------------------------------------------------------------------
--  Easily concatenate many anchored objects
--------------------------------------------------------------------------------

{-|
Starting from a base anchored object, recursively concatenate more objects to
the structure built up so far. Be sure to qualify anchors in the input so that
names aren't overwritten.

In each @(thatAnchor, thisAnchor, obj)@ triple, @thatAnchor@ refers to the
anchor point in the structure already constructed, and @thisAnchor@ refers to
the anchor point in the new object being added.
-}
anchorMany
  :: (Num (N t), Semigroup t, Additive (V t), HasOrigin t,
      IsName anchor) =>
     Anchored t -> [(anchor, anchor, Anchored t)] -> Anchored t
anchorMany :: forall t anchor.
(Num (N t), Semigroup t, Additive (V t), HasOrigin t,
 IsName anchor) =>
Anchored t -> [(anchor, anchor, Anchored t)] -> Anchored t
anchorMany = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {t} {a} {a}.
(Additive (V t), Num (N t), HasOrigin t, Semigroup t, IsName a,
 IsName a) =>
Anchored t -> (a, a, Anchored t) -> Anchored t
go
  where
    go :: Anchored t -> (a, a, Anchored t) -> Anchored t
go Anchored t
base (a
thatAnch, a
thisAnch, Anchored t
obj)
      = forall anchor t.
IsName anchor =>
anchor -> Anchored t -> Anchored t
alignAnchor a
thatAnch Anchored t
base forall a. Semigroup a => a -> a -> a
<> forall anchor t.
IsName anchor =>
anchor -> Anchored t -> Anchored t
alignAnchor a
thisAnch Anchored t
obj

-- | As 'anchorMany', but call 'unanchor' on the result. Convenient when you're
-- not going to be doing any more alignment using anchors with the result.
anchorMany_
  :: (Num (N c), Semigroup c, Additive (V c), HasOrigin c,
      IsName anchor) =>
     Anchored c -> [(anchor, anchor, Anchored c)] -> c
anchorMany_ :: forall c anchor.
(Num (N c), Semigroup c, Additive (V c), HasOrigin c,
 IsName anchor) =>
Anchored c -> [(anchor, anchor, Anchored c)] -> c
anchorMany_ Anchored c
base = forall t. Anchored t -> t
unanchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t anchor.
(Num (N t), Semigroup t, Additive (V t), HasOrigin t,
 IsName anchor) =>
Anchored t -> [(anchor, anchor, Anchored t)] -> Anchored t
anchorMany Anchored c
base

--------------------------------------------------------------------------------
--  Debugging
--------------------------------------------------------------------------------

-- | Show a particular anchor in the 'Anchored' object.
showAnchor
  :: (RealFloat n, Typeable n, Monoid m, Semigroup m,
      Renderable (Path V2 n) b, IsName a) =>
     a -> Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
showAnchor :: forall n m b a.
(RealFloat n, Typeable n, Monoid m, Semigroup m,
 Renderable (Path V2 n) b, IsName a) =>
a -> Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
showAnchor a
anch = Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
moveFromAnchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall t. Lens' (Anchored t) t
anchoredObj forall n b m.
(TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) =>
QDiagram b V2 n m -> QDiagram b V2 n m
showOrigin forall b c a. (b -> c) -> (a -> b) -> a -> c
. Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
moveToAnchor
  where
    moveToAnchor :: Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
moveToAnchor   Anchored (QDiagram b V2 n m)
t = Anchored (QDiagram b V2 n m)
t forall a b. a -> (a -> b) -> b
& forall t. Lens' (Anchored t) t
anchoredObj forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy ( forall t a.
(Num (N t), Additive (V t), IsName a) =>
a -> Anchored t -> V t (N t)
getAnchorOffset a
anch Anchored (QDiagram b V2 n m)
t)
    moveFromAnchor :: Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
moveFromAnchor Anchored (QDiagram b V2 n m)
t = Anchored (QDiagram b V2 n m)
t forall a b. a -> (a -> b) -> b
& forall t. Lens' (Anchored t) t
anchoredObj forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall t (v :: * -> *) n.
(V t ~ v, N t ~ n, HasOrigin t) =>
v n -> t -> t
moveOriginBy (-forall t a.
(Num (N t), Additive (V t), IsName a) =>
a -> Anchored t -> V t (N t)
getAnchorOffset a
anch Anchored (QDiagram b V2 n m)
t)

-- | Show a particular anchor in the 'Anchored' object, then 'unanchor'.
showAnchor_
  :: (RealFloat n, Typeable n, Monoid m, Semigroup m,
      Renderable (Path V2 n) b, IsName a) =>
     a -> Anchored (QDiagram b V2 n m) -> QDiagram b V2 n m
showAnchor_ :: forall n m b a.
(RealFloat n, Typeable n, Monoid m, Semigroup m,
 Renderable (Path V2 n) b, IsName a) =>
a -> Anchored (QDiagram b V2 n m) -> QDiagram b V2 n m
showAnchor_ a
anch = forall t. Anchored t -> t
unanchor forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n m b a.
(RealFloat n, Typeable n, Monoid m, Semigroup m,
 Renderable (Path V2 n) b, IsName a) =>
a -> Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
showAnchor a
anch