{-# LANGUAGE DeriveGeneric    #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types       #-}
{-# LANGUAGE TemplateHaskell  #-}
{-# LANGUAGE TupleSections    #-}
{-# LANGUAGE ViewPatterns     #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.TwoD.Layout.Constrained
-- Copyright   :  (c) 2015 Brent Yorgey
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  byorgey@gmail.com
--
-- Lay out diagrams by specifying constraints.  Currently, the API is
-- fairly simple: only equational constraints are supported (not
-- inequalities), and you can only use it to compose a collection of
-- diagrams (and not to, say, compute the position of some point).
-- Future versions may support additional features.
--
-- As a basic example, we can introduce a circle and a square, and
-- constrain them to be next to each other:
--
-- > import Diagrams.TwoD.Layout.Constrained
-- >
-- > constrCircleSq = frame 0.2 $ layout $ do
-- >   c <- newDia (circle 1)
-- >   s <- newDia (square 2)
-- >   constrainWith hcat [c, s]
--
-- We start a block of constraints with 'layout'; introduce new
-- diagrams with 'newDia', and then constrain them, in this case using
-- the 'constrainWith' function.  The result looks like this:
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Constrained_constrCircleSq.svg#diagram=constrCircleSq&width=300>>
--
-- Of course this is no different than just writing @circle 1 |||
-- square 2@. The interest comes when we start constraining things in
-- more interesting ways.
--
-- For example, the following code creates a row of differently-sized
-- circles with a bit of space in between them, and then draws a
-- square which is tangent to the last circle and passes through the
-- center of the third.  Manually computing the size (and position) of
-- this square would be tedious.  Instead, the square is declared to
-- be scalable, meaning it may be uniformly scaled to accomodate
-- constraints.  Then a point on the left side of the square is
-- constrained to be equal to the center of the third circle, and a
-- point on the right side of the square is made equal to a point on
-- the edge of the rightmost circle.  This causes the square to be
-- automatically positioned and scaled appropriately.
--
-- > import Diagrams.TwoD.Layout.Constrained
-- >
-- > circleRow = frame 1 $ layout $ do
-- >   cirs <- newDias (map circle [1..5])
-- >   constrainWith (hsep 1) cirs
-- >   rc <- newPointOn (last cirs) (envelopeP unitX)
-- >
-- >   sq <- newScalableDia (square 1)
-- >   ls <- newPointOn sq (envelopeP unit_X)
-- >   rs <- newPointOn sq (envelopeP unitX)
-- >
-- >   ls =.= centerOf (cirs !! 2)
-- >   rs =.= rc
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Constrained_circleRow.svg#diagram=circleRow&width=300>>
--
-- As a final example, the following code draws a vertical stack of
-- circles, along with an accompanying set of squares, such that (1)
-- each square constrained to lie on the same horizontal line as a
-- circle (using @zipWithM_ 'sameY'@), and (2) the squares all lie on
-- a diagonal line (using 'along').
--
-- > import Diagrams.TwoD.Layout.Constrained
-- > import Control.Monad (zipWithM_)
-- >
-- > diagonalLayout = frame 1 $ layout $ do
-- >   cirs <- newDias (map circle [1..5] # fc blue)
-- >   sqs  <- newDias (replicate 5 (square 2) # fc orange)
-- >   constrainWith vcat cirs
-- >   zipWithM_ sameY cirs sqs
-- >   constrainWith hcat [cirs !! 0, sqs !! 0]
-- >   along (direction (1 ^& (-1))) (map centerOf sqs)
--
-- <<diagrams/src_Diagrams_TwoD_Layout_Constrained_diagonalLayout.svg#diagram=diagonalLayout&width=400>>
--
-- Take a look at the implementations of combinators such as 'sameX',
-- 'allSame', 'constrainDir', and 'along' for ideas on implementing
-- your own constraint combinators.
--
-- Ideas for future versions of this module:
--
-- * Introduce z-index constraints.  Right now the diagrams are just
--   drawn in the order that they are introduced.
--
-- * A way to specify default values --- /i.e./ be able to introduce
--   new point or scalar variables with a specified default value
--   (instead of just defaulting to the origin or to 1).
--
-- * Doing something more reasonable than crashing for overconstrained
--   systems.
--
-- I am also open to other suggestions and/or pull requests!
-----------------------------------------------------------------------------

module Diagrams.TwoD.Layout.Constrained
       ( -- * Basic types
         Expr, mkExpr, Constrained, ConstrainedState, DiaID

         -- * Layout
       , layout
       , runLayout

         -- * Creating constrainable things

         -- | Diagrams, points, /etc./ which will participate in a
         --   system of constraints must first be explicitly
         --   introduced using one of the functions in this section.
       , newDia, newDias, newScalableDia
       , newPoint, newPointOn
       , newScalar

         -- * Diagram accessors

         -- | Combinators for extracting constrainable attributes of
         --   an introduced diagram.
       , centerOf, xOf, yOf, scaleOf

         -- * Constraints
       , (====), (=.=), (=^=)
       , sameX, sameY
       , allSame
       , constrainWith
       , constrainDir
       , along

       )
       where

import qualified Control.Lens         as L
import qualified Control.Lens.Extras  as L
import           Control.Monad.Except
import           Control.Monad.State
import qualified Data.Foldable        as F
import           Data.Hashable
import           Data.List            (sortBy)
import qualified Data.Map             as M
import           Data.Maybe           (fromJust)
import           Data.Ord             (comparing)
import           GHC.Generics

import qualified Math.MFSolve         as MFS

import           Diagrams.Coordinates
import           Diagrams.Prelude

------------------------------------------------------------
-- Variables and expressions
------------------------------------------------------------

-- | An abstract type representing unique IDs for diagrams.  The
--   constructor is not exported, so the only way to obtain a 'DiaID'
--   is by calling 'newDia' or 'newDias'. The phantom type parameter
--   's' ensures that such 'DiaID's can only be used with the
--   constrained system in which they were introduced.
newtype DiaID s = DiaID Int
  deriving (DiaID s -> DiaID s -> Bool
DiaID s -> DiaID s -> Ordering
DiaID s -> DiaID s -> DiaID s
forall {s}. Eq (DiaID s)
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
forall s. DiaID s -> DiaID s -> Bool
forall s. DiaID s -> DiaID s -> Ordering
forall s. DiaID s -> DiaID s -> DiaID s
min :: DiaID s -> DiaID s -> DiaID s
$cmin :: forall s. DiaID s -> DiaID s -> DiaID s
max :: DiaID s -> DiaID s -> DiaID s
$cmax :: forall s. DiaID s -> DiaID s -> DiaID s
>= :: DiaID s -> DiaID s -> Bool
$c>= :: forall s. DiaID s -> DiaID s -> Bool
> :: DiaID s -> DiaID s -> Bool
$c> :: forall s. DiaID s -> DiaID s -> Bool
<= :: DiaID s -> DiaID s -> Bool
$c<= :: forall s. DiaID s -> DiaID s -> Bool
< :: DiaID s -> DiaID s -> Bool
$c< :: forall s. DiaID s -> DiaID s -> Bool
compare :: DiaID s -> DiaID s -> Ordering
$ccompare :: forall s. DiaID s -> DiaID s -> Ordering
Ord, DiaID s -> DiaID s -> Bool
forall s. DiaID s -> DiaID s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DiaID s -> DiaID s -> Bool
$c/= :: forall s. DiaID s -> DiaID s -> Bool
== :: DiaID s -> DiaID s -> Bool
$c== :: forall s. DiaID s -> DiaID s -> Bool
Eq, Int -> DiaID s -> ShowS
forall s. Int -> DiaID s -> ShowS
forall s. [DiaID s] -> ShowS
forall s. DiaID s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DiaID s] -> ShowS
$cshowList :: forall s. [DiaID s] -> ShowS
show :: DiaID s -> String
$cshow :: forall s. DiaID s -> String
showsPrec :: Int -> DiaID s -> ShowS
$cshowsPrec :: forall s. Int -> DiaID s -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (DiaID s) x -> DiaID s
forall s x. DiaID s -> Rep (DiaID s) x
$cto :: forall s x. Rep (DiaID s) x -> DiaID s
$cfrom :: forall s x. DiaID s -> Rep (DiaID s) x
Generic)

-- | Variables can track one of four things: an x-coordinate, a
--   y-coordinate, a scaling factor, or a length.
data VarType = S   -- ^ scaling factor
             | L   -- ^ length
             | X   -- ^ X-coordinate of a point
             | Y   -- ^ Y-coordinate of a point
  deriving (VarType -> VarType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VarType -> VarType -> Bool
$c/= :: VarType -> VarType -> Bool
== :: VarType -> VarType -> Bool
$c== :: VarType -> VarType -> Bool
Eq, Eq VarType
VarType -> VarType -> Bool
VarType -> VarType -> Ordering
VarType -> VarType -> VarType
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 :: VarType -> VarType -> VarType
$cmin :: VarType -> VarType -> VarType
max :: VarType -> VarType -> VarType
$cmax :: VarType -> VarType -> VarType
>= :: VarType -> VarType -> Bool
$c>= :: VarType -> VarType -> Bool
> :: VarType -> VarType -> Bool
$c> :: VarType -> VarType -> Bool
<= :: VarType -> VarType -> Bool
$c<= :: VarType -> VarType -> Bool
< :: VarType -> VarType -> Bool
$c< :: VarType -> VarType -> Bool
compare :: VarType -> VarType -> Ordering
$ccompare :: VarType -> VarType -> Ordering
Ord, ReadPrec [VarType]
ReadPrec VarType
Int -> ReadS VarType
ReadS [VarType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [VarType]
$creadListPrec :: ReadPrec [VarType]
readPrec :: ReadPrec VarType
$creadPrec :: ReadPrec VarType
readList :: ReadS [VarType]
$creadList :: ReadS [VarType]
readsPrec :: Int -> ReadS VarType
$creadsPrec :: Int -> ReadS VarType
Read, Int -> VarType -> ShowS
[VarType] -> ShowS
VarType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VarType] -> ShowS
$cshowList :: [VarType] -> ShowS
show :: VarType -> String
$cshow :: VarType -> String
showsPrec :: Int -> VarType -> ShowS
$cshowsPrec :: Int -> VarType -> ShowS
Show, forall x. Rep VarType x -> VarType
forall x. VarType -> Rep VarType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep VarType x -> VarType
$cfrom :: forall x. VarType -> Rep VarType x
Generic)

-- | A variable has a name and a type, and may optionally be
--   associated to some particular diagram.
data Var s = Var { forall s. Var s -> Maybe (DiaID s)
_varID :: Maybe (DiaID s), forall s. Var s -> String
_varName :: String, forall s. Var s -> VarType
_varType :: VarType }
  deriving (Var s -> Var s -> Bool
forall s. Var s -> Var s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Var s -> Var s -> Bool
$c/= :: forall s. Var s -> Var s -> Bool
== :: Var s -> Var s -> Bool
$c== :: forall s. Var s -> Var s -> Bool
Eq, Var s -> Var s -> Bool
Var s -> Var s -> Ordering
forall s. Eq (Var s)
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
forall s. Var s -> Var s -> Bool
forall s. Var s -> Var s -> Ordering
forall s. Var s -> Var s -> Var s
min :: Var s -> Var s -> Var s
$cmin :: forall s. Var s -> Var s -> Var s
max :: Var s -> Var s -> Var s
$cmax :: forall s. Var s -> Var s -> Var s
>= :: Var s -> Var s -> Bool
$c>= :: forall s. Var s -> Var s -> Bool
> :: Var s -> Var s -> Bool
$c> :: forall s. Var s -> Var s -> Bool
<= :: Var s -> Var s -> Bool
$c<= :: forall s. Var s -> Var s -> Bool
< :: Var s -> Var s -> Bool
$c< :: forall s. Var s -> Var s -> Bool
compare :: Var s -> Var s -> Ordering
$ccompare :: forall s. Var s -> Var s -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall s x. Rep (Var s) x -> Var s
forall s x. Var s -> Rep (Var s) x
$cto :: forall s x. Rep (Var s) x -> Var s
$cfrom :: forall s x. Var s -> Rep (Var s) x
Generic, Int -> Var s -> ShowS
forall s. Int -> Var s -> ShowS
forall s. [Var s] -> ShowS
forall s. Var s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Var s] -> ShowS
$cshowList :: forall s. [Var s] -> ShowS
show :: Var s -> String
$cshow :: forall s. Var s -> String
showsPrec :: Int -> Var s -> ShowS
$cshowsPrec :: forall s. Int -> Var s -> ShowS
Show)

makeLensesWith (lensRulesFor [("_varType", "varType")]) ''Var

-- Auto-derive Hashable instances using Generic
instance Hashable (DiaID s)
instance Hashable VarType
instance Hashable (Var s)

-- | The type of reified expressions over @Vars@, with
--   numeric values taken from the type @n@.  The important point to
--   note is that 'Expr' is an instance of 'Num', 'Fractional', and
--   'Floating', so 'Expr' values can be combined and manipulated as
--   if they were numeric expressions, even when they occur inside
--   other types.  For example, 2D vector values of type @V2 (Expr s
--   n)@ and point values of type @P2 (Expr s n)@ can be combined
--   using operators such as '.+^', '.-.', and so on, in order to
--   express constraints on vectors and points.
--
--   To create literal 'Expr' values, you can use 'mkExpr'.
--   Otherwise, they are introduced by creation functions such as
--   'newPoint', 'newScalar', or diagram accessor functions like
--   'centerOf' or 'xOf'.
type Expr s n = MFS.Expr (Var s) n

-- | Convert a literal numeric value into an 'Expr'.  To convert
--   structured types such as vectors or points, you can use e.g. @fmap
--   mkExpr :: V2 n -> V2 (Expr s n)@.
mkExpr :: n -> Expr s n
mkExpr :: forall n s. n -> Expr s n
mkExpr = forall n v. n -> Expr v n
MFS.makeConstant

------------------------------------------------------------
-- Functions for variable and expression creation
------------------------------------------------------------

-- | Create an internal variable corresponding to a diagram, with
--   the given name and variable type.  Not intended to be called by
--   end users.
diaVar :: DiaID s -> String -> VarType -> Var s
diaVar :: forall s. DiaID s -> String -> VarType -> Var s
diaVar = forall s. Maybe (DiaID s) -> String -> VarType -> Var s
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just

-- | Create an internal variable unattached to any particular diagram, with
--   a given name and variable type. Not intended to be called by end
--   users.
newVar :: String -> VarType -> Var s
newVar :: forall s. String -> VarType -> Var s
newVar = forall s. Maybe (DiaID s) -> String -> VarType -> Var s
Var forall a. Maybe a
Nothing

-- | Create a variable corresponding to a particular diagram, with a
--   given name and type.  Not intended to be called by end users.
mkDVar :: Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar :: forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
s VarType
ty = forall n v. Num n => v -> Expr v n
MFS.makeVariable (forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
s VarType
ty)

-- | Create a variable unattached to any particular diagram, with a
--   a given name and type. Not intended to be called by end users.
mkVar :: Num n => String -> VarType -> Expr s n
mkVar :: forall n s. Num n => String -> VarType -> Expr s n
mkVar String
s VarType
ty = forall n v. Num n => v -> Expr v n
MFS.makeVariable (forall s. String -> VarType -> Var s
newVar String
s VarType
ty)

-- | Make a variable tracking the local origin of a given diagram.
--   Not intended to be called by end users.
mkDPVar :: Num n => DiaID s -> String -> P2 (Expr s n)
mkDPVar :: forall n s. Num n => DiaID s -> String -> P2 (Expr s n)
mkDPVar DiaID s
d String
s = forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
s VarType
X forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
s VarType
Y

-- | Make a variable corresponding to a 2D point.  Not intended to be
--   called by end users.
mkPVar :: Num n => String -> P2 (Expr s n)
mkPVar :: forall n s. Num n => String -> P2 (Expr s n)
mkPVar String
s = forall n s. Num n => String -> VarType -> Expr s n
mkVar String
s VarType
X forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& forall n s. Num n => String -> VarType -> Expr s n
mkVar String
s VarType
Y

------------------------------------------------------------
-- Constraints
------------------------------------------------------------

-- | A set of 'Constraints' is a monadic computation
--   in the 'MFS.MFSolver' monad.  Users need not concern themselves
--   with the details of 'MFS.MFSolver'; it should suffice to think of
--   'Constraints' as an abstract type.
--
--   This type is INTERNAL to the library and should not be exported.
--   There is no need to have two separate layers of combining
--   things---combining Constraints and then also combining
--   Constrained systems, both using a monadic interface.  In the
--   user-facing API, we just immediately turn each Constraints value
--   into a Constrained computation, which can then be combined.
type Constraints s n = MFS.MFSolver (Var s) n ()

-- | The state maintained by the Constrained monad.  Note that @s@
--   is a phantom parameter, used in a similar fashion to the @ST@
--   monad, to ensure that generated diagram IDs do not leak.
data ConstrainedState s b n m = ConstrainedState
  { forall s b n m. ConstrainedState s b n m -> Constraints s n
_equations  :: Constraints s n
                   -- ^ Current set of constraints
  , forall s b n m. ConstrainedState s b n m -> Int
_diaCounter :: Int
                   -- ^ Global counter for unique diagram IDs
  , forall s b n m. ConstrainedState s b n m -> Int
_varCounter :: Int
                   -- ^ Global counter for unique variable IDs
  , forall s b n m.
ConstrainedState s b n m -> Map (DiaID s) (QDiagram b V2 n m)
_diagrams   :: M.Map (DiaID s) (QDiagram b V2 n m)
                   -- ^ Map from diagram IDs to diagrams
  }

makeLenses ''ConstrainedState

-- | The initial ConstrainedState: no equations, no diagrams, and
--   counters at 0.
initConstrainedState :: ConstrainedState s b n m
initConstrainedState :: forall s b n m. ConstrainedState s b n m
initConstrainedState = ConstrainedState
  { _equations :: Constraints s n
_equations  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  , _diaCounter :: Int
_diaCounter = Int
0
  , _varCounter :: Int
_varCounter = Int
0
  , _diagrams :: Map (DiaID s) (QDiagram b V2 n m)
_diagrams   = forall k a. Map k a
M.empty
  }

-- | A monad for constrained systems.  It suffices to think of it as
--   an abstract monadic type; the constructor for the internal state
--   is intentionally not exported.  'Constrained' values can be
--   created using the combinators below; combined using the @Monad@
--   interface; and discharged by the 'layout' function.
--
--   Note that @s@ is a phantom parameter, used in a similar fashion
--   to the 'ST' monad, to ensure that generated diagram IDs cannot be
--   mixed between different 'layout' blocks.
type Constrained s b n m a = State (ConstrainedState s b n m) a

------------------------------------------------------------
-- Constraint DSL
------------------------------------------------------------

--------------------------------------------------
-- Creating constrainable things

-- | Introduce a new diagram into the constrained system.  Returns a
--   unique ID for use in referring to the diagram later.
--
--   The position of the diagram's origin may be constrained.  If
--   unconstrained, the origin will default to (0,0).  For a diagram
--   whose scaling factor may also be constrained, see
--   'newScalableDia'.
newDia
  :: (Hashable n, Floating n, RealFrac n)
  => QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newDia :: forall n b m s.
(Hashable n, Floating n, RealFrac n) =>
QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newDia QDiagram b V2 n m
dia = do
  DiaID s
d <- forall b n m s. QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newScalableDia QDiagram b V2 n m
dia
  forall n s. Num n => DiaID s -> Expr s n
scaleOf DiaID s
d forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
1
  forall (m :: * -> *) a. Monad m => a -> m a
return DiaID s
d

-- | Introduce a new diagram into the constrained system.  Returns a
--   unique ID for use in referring to the diagram later.
--
--   Both the position of the diagram's origin and its scaling factor
--   may be constrained.  If unconstrained, the origin will default to
--   (0,0), and the scaling factor to 1, respectively.
newScalableDia :: QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newScalableDia :: forall b n m s. QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newScalableDia QDiagram b V2 n m
dia = do
  DiaID s
d <- forall s. Int -> DiaID s
DiaID forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s b n m. Lens' (ConstrainedState s b n m) Int
diaCounter forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1)
  forall s b n m b m.
Lens
  (ConstrainedState s b n m)
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
  (Map (DiaID s) (QDiagram b V2 n m))
diagrams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at DiaID s
d forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= QDiagram b V2 n m
dia
  forall (m :: * -> *) a. Monad m => a -> m a
return DiaID s
d

-- | Introduce a list of diagrams into the constrained system.
--   Returns a corresponding list of unique IDs for use in referring
--   to the diagrams later.
newDias
  :: (Hashable n, Floating n, RealFrac n)
  => [QDiagram b V2 n m] -> Constrained s b n m [DiaID s]
newDias :: forall n b m s.
(Hashable n, Floating n, RealFrac n) =>
[QDiagram b V2 n m] -> Constrained s b n m [DiaID s]
newDias = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall n b m s.
(Hashable n, Floating n, RealFrac n) =>
QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newDia

--------------------------------------------------
-- Constrained points etc.

-- | The point at the center (i.e. local origin) of the given
--   diagram.  For example, to constrain the origin of diagram @b@ to
--   be offset from the origin of diagram @a@ by one unit to the right
--   and one unit up, one may write
--
--   @centerOf b =.= centerOf a .+^ (1 ^& 1)@
centerOf :: Num n => DiaID s -> P2 (Expr s n)
centerOf :: forall n s. Num n => DiaID s -> P2 (Expr s n)
centerOf DiaID s
d = forall n s. Num n => DiaID s -> String -> P2 (Expr s n)
mkDPVar DiaID s
d String
"center"

-- | The x-coordinate of the center for the given diagram, which can
--   be used in constraints to determine the x-position of this
--   diagram relative to others.
--
--   For example,
--
--   @xOf d1 + 2 === xOf d2@
--
--   constrains diagram @d2@ to lie 2 units to the right of @d1@ in
--   the horizontal direction, though it does not constrain their
--   relative positioning in the vertical direction.
xOf :: Num n => DiaID s -> Expr s n
xOf :: forall n s. Num n => DiaID s -> Expr s n
xOf DiaID s
d = forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
"center" VarType
X

-- | The y-coordinate of the center for the given diagram, which can
--   be used in constraints to determine the y-position of this
--   diagram relative to others.
--
--   For example,
--
--   @allSame (map yOf ds)@
--
--   constrains the diagrams @ds@ to all lie on the same horizontal
--   line.
yOf :: Num n => DiaID s -> Expr s n
yOf :: forall n s. Num n => DiaID s -> Expr s n
yOf DiaID s
d = forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
"center" VarType
Y

-- | The scaling factor applied to this diagram.
--
--   For example,
--
--   @scaleOf d1 === 2 * scaleOf d2@
--
--   constrains @d1@ to be scaled twice as much as @d2@. (It does not,
--   however, guarantee anything about their actual relative sizes;
--   that depends on their relative size when unscaled.)
--
scaleOf :: Num n => DiaID s -> Expr s n
scaleOf :: forall n s. Num n => DiaID s -> Expr s n
scaleOf DiaID s
d = forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
"scale" VarType
S

-- | Create a new (constrainable) point attached to the given diagram,
--   using a function that picks a point given a diagram.
--
--   For example, to get the point on the right edge of a diagram's
--   envelope, one may write
--
--   @rt <- newPointOn d (envelopeP unitX)@
--
--   To get the point (1,1),
--
--   @one_one <- newPointOn d (const (1 ^& 1))@
--
--   This latter example is far from useless: note that @one_one@ now
--   corresponds not to the absolute coordinates (1,1), but to the
--   point which lies at (1,1) /relative to the unscaled diagram's
--   origin/.  If the diagram is positioned or scaled to satisfy some
--   other constraints, @one_one@ will move right along with it.
--
--   For example, the following code establishes a small circle which
--   is located at a specific point relative to a big circle.  The
--   small circle is carried along with the big circle as it is laid
--   out in between some squares.
--
--   > import Diagrams.TwoD.Layout.Constrained
--   >
--   > circleWithCircle = frame 0.3 $ layout $ do
--   >   c2 <- newScalableDia (circle 2)
--   >   p <- newPointOn c2 (const $ (1 ^& 0) # rotateBy (1/8))
--   >
--   >   c1 <- newDia (circle 1)
--   >   centerOf c1 =.= p
--   >
--   >   [a,b] <- newDias (replicate 2 (square 2))
--   >   constrainWith hcat [a,c2,b]
--
--   <<diagrams/src_Diagrams_TwoD_Layout_Constrained_circleWithCircle.svg#diagram=circleWithCircle&width=300>>

newPointOn
  :: (Hashable n, Floating n, RealFrac n)
  => DiaID s
  -> (QDiagram b V2 n m -> P2 n)
  -> Constrained s b n m (P2 (Expr s n))
newPointOn :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
DiaID s
-> (QDiagram b V2 n m -> P2 n)
-> Constrained s b n m (P2 (Expr s n))
newPointOn DiaID s
d QDiagram b V2 n m -> P2 n
getP = do
  -- the fromJust is justified, because the type discipline on DiaIDs ensures
  -- they will always represent a valid index in the Map.
  QDiagram b V2 n m
dia <- forall a. HasCallStack => Maybe a -> a
fromJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (forall s b n m b m.
Lens
  (ConstrainedState s b n m)
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
  (Map (DiaID s) (QDiagram b V2 n m))
diagrams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at DiaID s
d)
  let p :: P2 n
p = QDiagram b V2 n m -> P2 n
getP QDiagram b V2 n m
dia

  Int
v <- forall s b n m. Lens' (ConstrainedState s b n m) Int
varCounter forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
  let newPt :: P2 (Expr s n)
newPt = forall n s. Num n => DiaID s -> String -> P2 (Expr s n)
mkDPVar DiaID s
d (String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
v)

  -- constrain the new point to move relative to the diagram origin,
  -- taking possible scaling into account
  forall n s. Num n => DiaID s -> P2 (Expr s n)
centerOf DiaID s
d forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (forall n s. Num n => DiaID s -> Expr s n
scaleOf DiaID s
d forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ (forall n s. n -> Expr s n
mkExpr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P2 n
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin))) forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
=.= P2 (Expr s n)
newPt

  forall (m :: * -> *) a. Monad m => a -> m a
return P2 (Expr s n)
newPt

-- | Introduce a new constrainable point, unattached to any particular
--   diagram.  If either of the coordinates are still unconstrained at
--   the end, they will default to zero.
newPoint :: Num n => Constrained s b n m (P2 (Expr s n))
newPoint :: forall n s b m. Num n => Constrained s b n m (P2 (Expr s n))
newPoint = do
  Int
v <- forall s b n m. Lens' (ConstrainedState s b n m) Int
varCounter forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n s. Num n => String -> P2 (Expr s n)
mkPVar (String
"a" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
v)

-- | Introduce a new scalar value which can be constrained.  If still
--   unconstrained at the end, it will default to 1.
newScalar :: Num n => Constrained s b n m (Expr s n)
newScalar :: forall n s b m. Num n => Constrained s b n m (Expr s n)
newScalar = do
  Int
v <- forall s b n m. Lens' (ConstrainedState s b n m) Int
varCounter forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n s. Num n => String -> VarType -> Expr s n
mkVar (String
"s" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
v) VarType
S

--------------------------------------------------
-- Specifying constraints

-- | Apply some constraints.
constrain :: Constraints s n -> Constrained s b n m ()
constrain :: forall s n b m. Constraints s n -> Constrained s b n m ()
constrain Constraints s n
newConstraints = forall s b n m. Lens' (ConstrainedState s b n m) (Constraints s n)
equations forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Constraints s n
newConstraints)
  -- XXX should this be right-nested instead?  Does it matter?

infix 1 =.=, =^=, ====

-- | Constrain two scalar expressions to be equal.
--   Note that you need not worry about introducing redundant
--   constraints; they are ignored.
(====)
  :: (Floating n, RealFrac n, Hashable n)
  => Expr s n -> Expr s n -> Constrained s b n m ()
Expr s n
a ==== :: forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
b = forall s n b m. Constraints s n -> Constrained s b n m ()
constrain forall a b. (a -> b) -> a -> b
$ forall v n (m :: * -> *).
MonadError (DepError v n) m =>
m () -> m ()
MFS.ignore (Expr s n
a forall v n (m :: * -> *).
(MonadState (Dependencies v n) m, MonadError (DepError v n) m,
 Eq v, Hashable v, Hashable n, RealFrac n, Floating n, Ord v) =>
Expr v n -> Expr v n -> m ()
MFS.=== Expr s n
b)

-- | Constrain two points to be equal.
(=.=)
  :: (Hashable n, Floating n, RealFrac n)
  => P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
(forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
px :& Expr s n
py) =.= :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
=.= (forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
qx :& Expr s n
qy) = do
  Expr s n
px forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
qx
  Expr s n
py forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
qy

-- | Constrain two vectors to be equal.
(=^=)
  :: (Hashable n, Floating n, RealFrac n)
  => V2 (Expr s n) -> V2 (Expr s n) -> Constrained s b n m ()
(forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
px :& Expr s n
py) =^= :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
V2 (Expr s n) -> V2 (Expr s n) -> Constrained s b n m ()
=^= (forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
qx :& Expr s n
qy) = do
  Expr s n
px forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
qx
  Expr s n
py forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== Expr s n
qy

-- | Constrain a collection of diagrams to be positioned relative to
--   one another according to a function such as 'hcat', 'vcat', 'hsep',
--   and so on.
--
--   A typical use would be
--
-- @
-- cirs <- newDias (map circle [1..5])
-- constrainWith (hsep 1) cirs
-- @
--
--   which creates five circles and constrains them to be positioned
--   in a row, with one unit of space in between adjacent pairs.
--
--   The funny type signature is something of a hack.  The sorts of
--   functions which should be passed as the first argument to
--   'constrainWith' tend to be highly polymorphic; 'constrainWith'
--   uses a concrete type which it can use to extract relevant
--   information about the function by observing its behavior.  In
--   short, you do not need to know anything about @Located Envelope@s
--   in order to call this function.
constrainWith
  :: (Hashable n, RealFrac n, Floating n, Monoid' m)
  => -- (forall a. (...) => [a] -> a)
     ([[Located (Envelope V2 n)]] -> [Located (Envelope V2 n)])
  -> [DiaID s]
  -> Constrained s b n m ()
constrainWith :: forall n m s b.
(Hashable n, RealFrac n, Floating n, Monoid' m) =>
([[Located (Envelope V2 n)]] -> [Located (Envelope V2 n)])
-> [DiaID s] -> Constrained s b n m ()
constrainWith [[Located (Envelope V2 n)]] -> [Located (Envelope V2 n)]
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
constrainWith [[Located (Envelope V2 n)]] -> [Located (Envelope V2 n)]
f [DiaID s]
hs = do
  Map (DiaID s) (QDiagram b V2 n m)
diaMap <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall s b n m b m.
Lens
  (ConstrainedState s b n m)
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
  (Map (DiaID s) (QDiagram b V2 n m))
diagrams
  let dias :: [QDiagram b V2 n m]
dias  = forall a b. (a -> b) -> [a] -> [b]
map (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (DiaID s) (QDiagram b V2 n m)
diaMap) [DiaID s]
hs
      envs :: [[Located (Envelope V2 n)]]
envs  = forall a b. (a -> b) -> [a] -> [b]
map ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> Point (V a) (N a) -> Located a
`at` forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope) [QDiagram b V2 n m]
dias
      envs' :: [Located (Envelope V2 n)]
envs' = [[Located (Envelope V2 n)]] -> [Located (Envelope V2 n)]
f [[Located (Envelope V2 n)]]
envs
      eCtrs :: [Point V2 n]
eCtrs = forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a -> Point (V a) (N a)
loc [Located (Envelope V2 n)]
envs'
      offs :: [V2 n]
offs  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
(.-.) (forall a. [a] -> [a]
tail [Point V2 n]
eCtrs) [Point V2 n]
eCtrs
      rtps :: [Point V2 n]
rtps  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP             [V2 n]
offs (forall a. [a] -> [a]
init [Located (Envelope V2 n)]
envs')
      ltps :: [Point V2 n]
ltps  = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated) [V2 n]
offs (forall a. [a] -> [a]
tail [Located (Envelope V2 n)]
envs')
      gaps' :: [V2 (Expr s n)]
gaps'  = (forall a b. (a -> b) -> [a] -> [b]
map forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall n s. n -> Expr s n
mkExpr forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
(.-.) [Point V2 n]
ltps [Point V2 n]
rtps
  [P2 (Expr s n)]
rts <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
DiaID s
-> (QDiagram b V2 n m -> P2 n)
-> Constrained s b n m (P2 (Expr s n))
newPointOn (forall a. [a] -> [a]
init [DiaID s]
hs) (forall a b. (a -> b) -> [a] -> [b]
map forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP [V2 n]
offs)
  [P2 (Expr s n)]
lts <- forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
DiaID s
-> (QDiagram b V2 n m -> P2 n)
-> Constrained s b n m (P2 (Expr s n))
newPointOn (forall a. [a] -> [a]
tail [DiaID s]
hs) (forall a b. (a -> b) -> [a] -> [b]
map (forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated) [V2 n]
offs)
  forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWithM3_ (\P2 (Expr s n)
r V2 (Expr s n)
g P2 (Expr s n)
l -> P2 (Expr s n)
r forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 (Expr s n)
g forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
=.= P2 (Expr s n)
l) [P2 (Expr s n)]
rts forall {s}. [V2 (Expr s n)]
gaps' [P2 (Expr s n)]
lts

zipWithM3_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWithM3_ :: forall (m :: * -> *) a b c d.
Monad m =>
(a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWithM3_ a -> b -> c -> m d
f [a]
as [b]
bs [c]
cs = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 a -> b -> c -> m d
f [a]
as [b]
bs [c]
cs

-- | Constrain the origins of two diagrams to have the same
--   x-coordinate.
sameX
  :: (Hashable n, Floating n, RealFrac n)
  => DiaID s -> DiaID s -> Constrained s b n m ()
sameX :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
DiaID s -> DiaID s -> Constrained s b n m ()
sameX DiaID s
h1 DiaID s
h2 = forall n s. Num n => DiaID s -> Expr s n
xOf DiaID s
h1 forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== forall n s. Num n => DiaID s -> Expr s n
xOf DiaID s
h2

-- | Constrain the origins of two diagrams to have the same
--   y-coordinate.
sameY
  :: (Hashable n, Floating n, RealFrac n)
  => DiaID s -> DiaID s -> Constrained s b n m ()
sameY :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
DiaID s -> DiaID s -> Constrained s b n m ()
sameY DiaID s
h1 DiaID s
h2 = forall n s. Num n => DiaID s -> Expr s n
yOf DiaID s
h1 forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== forall n s. Num n => DiaID s -> Expr s n
yOf DiaID s
h2

-- | Constrain a list of scalar expressions to be all equal.
allSame
  :: (Hashable n, Floating n, RealFrac n)
  => [Expr s n] -> Constrained s b n m ()
allSame :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
[Expr s n] -> Constrained s b n m ()
allSame [Expr s n]
as = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
(====) [Expr s n]
as (forall a. [a] -> [a]
tail [Expr s n]
as)

-- | @constrainDir d p q@ constrains the direction from @p@ to @q@ to
--   be @d@.  That is, the direction of the vector @q .-. p@ must be
--   @d@.
constrainDir :: (Hashable n, Floating n, RealFrac n) => Direction V2 (Expr s n) -> P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
constrainDir :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
Direction V2 (Expr s n)
-> P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
constrainDir Direction V2 (Expr s n)
dir P2 (Expr s n)
p P2 (Expr s n)
q = do
  Expr s n
s <- forall n s b m. Num n => Constrained s b n m (Expr s n)
newScalar
  P2 (Expr s n)
p forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (Expr s n
s forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Direction V2 (Expr s n)
dir) forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
=.= P2 (Expr s n)
q

-- | @along d ps@ constrains the points @ps@ to all lie along a ray
--   parallel to the direction @d@.
along :: (Hashable n, Floating n, RealFrac n) => Direction V2 (Expr s n) -> [P2 (Expr s n)] -> Constrained s b n m ()
along :: forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
Direction V2 (Expr s n)
-> [P2 (Expr s n)] -> Constrained s b n m ()
along Direction V2 (Expr s n)
dir [P2 (Expr s n)]
ps = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (forall n s b m.
(Hashable n, Floating n, RealFrac n) =>
Direction V2 (Expr s n)
-> P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
constrainDir Direction V2 (Expr s n)
dir) [P2 (Expr s n)]
ps (forall a. [a] -> [a]
tail [P2 (Expr s n)]
ps)

------------------------------------------------------------
-- Constraint resolution
------------------------------------------------------------

-- | A data type holding a variable together with its resolution
--   status: its solved value, if it exists, or Nothing if the
--   variable is still unresolved.
data VarResolution s n = VR { forall s n. VarResolution s n -> Var s
_resolvedVar :: Var s, forall s n. VarResolution s n -> Maybe n
_resolution :: Maybe n }

makeLenses ''VarResolution

-- | Check whether a variable has been resolved.
isResolved :: VarResolution s n -> Bool
isResolved :: forall s n. VarResolution s n -> Bool
isResolved = forall s t a b. APrism s t a b -> s -> Bool
L.is forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s n n.
Lens (VarResolution s n) (VarResolution s n) (Maybe n) (Maybe n)
resolution

-- | Get the three variables associated with a diagram: X, Y, and
--   Scale.
getDiaVars
  :: MFS.Dependencies (Var s) n -> DiaID s -> M.Map VarType (VarResolution s n)
getDiaVars :: forall s n.
Dependencies (Var s) n
-> DiaID s -> Map VarType (VarResolution s n)
getDiaVars Dependencies (Var s) n
deps DiaID s
d = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
  [ (VarType
X, Var s -> VarResolution s n
getRes (forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
"center" VarType
X))
  , (VarType
Y, Var s -> VarResolution s n
getRes (forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
"center" VarType
Y))
  , (VarType
S, Var s -> VarResolution s n
getRes (forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
"scale"  VarType
S))
  ]
  where
    getRes :: Var s -> VarResolution s n
getRes Var s
v
      = forall s n. Var s -> Maybe n -> VarResolution s n
VR Var s
v (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall v n.
(Eq v, Hashable v) =>
v -> Dependencies v n -> Either [v] n
MFS.getKnown Var s
v Dependencies (Var s) n
deps)

-- | Solve a constrained system, combining the resulting diagrams with
--   'mconcat'.  This is the top-level function for introducing a
--   constrained system, and is the only way to generate an actual
--   diagram.
--
--   Redundant constraints are ignored.  If there are any
--   unconstrained diagram variables remaining, they are given default
--   values one at a time, beginning with defaulting remaining scaling
--   factors to 1, then defaulting x- and y-coordinates to zero.
--
--   An overconstrained system will cause 'layout' to simply crash.
--   This is obviously not ideal.  A future version may do something
--   more reasonable.
layout
  :: (Monoid' m, Hashable n, Floating n, RealFrac n, Show n)
  => (forall s. Constrained s b n m a)
  -> QDiagram b V2 n m
layout :: forall m n b a.
(Monoid' m, Hashable n, Floating n, RealFrac n, Show n) =>
(forall s. Constrained s b n m a) -> QDiagram b V2 n m
layout forall s. Constrained s b n m a
constr = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall m n b a.
(Monoid' m, Hashable n, Floating n, RealFrac n, Show n) =>
(forall s. Constrained s b n m a) -> (a, QDiagram b V2 n m)
runLayout forall s. Constrained s b n m a
constr

-- | Like 'layout', but also allows the caller to retrieve the result of the
--   'Constrained' computation.
runLayout
  :: (Monoid' m, Hashable n, Floating n, RealFrac n, Show n)
  => (forall s. Constrained s b n m a)
  -> (a, QDiagram b V2 n m)
runLayout :: forall m n b a.
(Monoid' m, Hashable n, Floating n, RealFrac n, Show n) =>
(forall s. Constrained s b n m a) -> (a, QDiagram b V2 n m)
runLayout forall s. Constrained s b n m a
constr =
  case forall v n a.
MFSolver v n a
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
MFS.execSolver (forall v n (m :: * -> *).
MonadError (DepError v n) m =>
m () -> m ()
MFS.ignore forall a b. (a -> b) -> a -> b
$ forall {s}. ConstrainedState s b n m
s forall s a. s -> Getting a s a -> a
^. forall s b n m. Lens' (ConstrainedState s b n m) (Constraints s n)
equations) forall v n. Dependencies v n
MFS.noDeps of
    Left DepError (Var Any) n
_depError -> forall a. HasCallStack => String -> a
error String
"overconstrained"
    Right Dependencies (Var Any) n
deps    ->
      let deps' :: Dependencies (Var Any) n
deps' = forall n s.
(Hashable n, RealFrac n, Floating n, Show n) =>
[DiaID s] -> Dependencies (Var s) n -> Dependencies (Var s) n
resolve (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall {s}. [(DiaID s, QDiagram b V2 n m)]
dias) Dependencies (Var Any) n
deps
      in  (a
a, ) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map forall {s}. [(DiaID s, QDiagram b V2 n m)]
dias forall a b. (a -> b) -> a -> b
$ \(DiaID Any
d, QDiagram b V2 n m
dia) ->
        let vars :: Map VarType (VarResolution Any n)
vars = forall s n.
Dependencies (Var s) n
-> DiaID s -> Map VarType (VarResolution s n)
getDiaVars Dependencies (Var Any) n
deps' DiaID Any
d
            expectedRes :: VarType -> n
expectedRes VarType
ty = Map VarType (VarResolution Any n)
vars forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at VarType
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s n n.
Lens (VarResolution s n) (VarResolution s n) (Maybe n) (Maybe n)
resolution forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just
        in
          case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (forall s n. VarResolution s n -> Bool
isResolved) Map VarType (VarResolution Any n)
vars of
            Bool
True -> QDiagram b V2 n m
dia forall a b. a -> (a -> b) -> b
# forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale (VarType -> n
expectedRes VarType
S)
                        # translate (expectedRes X ^& expectedRes Y)
            Bool
_ -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                 [ String
"Diagrams.TwoD.Layout.Constrained.layout: impossible!"
                 , String
"Diagram variables not resolved. Please report this as a bug:"
                 , String
"  https://github.com/diagrams/diagrams-contrib/issues"
                 ]
                 -- 'resolve' should always set the S, X, and Y variables for
                 -- a diagram if they aren't already constrained, so getDiaVars
                 -- should return three resolved variables
  where
    (a
a, ConstrainedState s b n m
s) = forall s a. State s a -> s -> (a, s)
runState forall s. Constrained s b n m a
constr forall s b n m. ConstrainedState s b n m
initConstrainedState
    dias :: [(DiaID s, QDiagram b V2 n m)]
dias = forall k a. Map k a -> [(k, a)]
M.assocs (forall {s}. ConstrainedState s b n m
s forall s a. s -> Getting a s a -> a
^. forall s b n m b m.
Lens
  (ConstrainedState s b n m)
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
  (Map (DiaID s) (QDiagram b V2 n m))
diagrams)

resolve
  :: (Hashable n, RealFrac n, Floating n, Show n)
  => [DiaID s] -> MFS.Dependencies (Var s) n -> MFS.Dependencies (Var s) n
resolve :: forall n s.
(Hashable n, RealFrac n, Floating n, Show n) =>
[DiaID s] -> Dependencies (Var s) n -> Dependencies (Var s) n
resolve [DiaID s]
diaIDs Dependencies (Var s) n
deps =
  case [VarResolution s n]
unresolved of
    [] -> Dependencies (Var s) n
deps
    ((VR Var s
v Maybe n
_) : [VarResolution s n]
_) ->
      let eq :: Expr (Var s) n
eq = forall n v. Num n => v -> Expr v n
MFS.makeVariable Var s
v forall a. Num a => a -> a -> a
- (if Var s
vforall s a. s -> Getting a s a -> a
^.forall s. Lens' (Var s) VarType
varType forall a. Eq a => a -> a -> Bool
== VarType
S then Expr (Var s) n
1 else Expr (Var s) n
0)
      in case forall n v.
(Hashable n, Hashable v, RealFrac n, Ord v, Floating n) =>
Dependencies v n
-> Expr v n -> Either (DepError v n) (Dependencies v n)
MFS.addEquation Dependencies (Var s) n
deps Expr (Var s) n
eq of
               Right Dependencies (Var s) n
deps' -> forall n s.
(Hashable n, RealFrac n, Floating n, Show n) =>
[DiaID s] -> Dependencies (Var s) n -> Dependencies (Var s) n
resolve [DiaID s]
diaIDs Dependencies (Var s) n
deps'
               Left DepError (Var s) n
err    -> forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                 [ String
"Diagrams.TwoD.Layout.Constrained.layout: impossible!"
                 , String
"Adding equation for unconstrained variable produced an error:"
                 , forall a. Show a => a -> String
show DepError (Var s) n
err
                 , String
"Please report this as a bug:"
                 , String
"  https://github.com/diagrams/diagrams-contrib/issues"
                 ]
  where
    diaVars :: [VarResolution s n]
diaVars = [DiaID s]
diaIDs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (forall k a. Map k a -> [a]
M.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s n.
Dependencies (Var s) n
-> DiaID s -> Map VarType (VarResolution s n)
getDiaVars Dependencies (Var s) n
deps)
    unresolved :: [VarResolution s n]
unresolved
      = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall s n s.
Lens (VarResolution s n) (VarResolution s n) (Var s) (Var s)
resolvedVarforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s. Lens' (Var s) VarType
varType)))
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s n. VarResolution s n -> Bool
isResolved)
      forall a b. (a -> b) -> a -> b
$ [VarResolution s n]
diaVars