{-# 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        (zipWithM, zipWithM_)
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 (Eq (DiaID s)
Eq (DiaID s) =>
(DiaID s -> DiaID s -> Ordering)
-> (DiaID s -> DiaID s -> Bool)
-> (DiaID s -> DiaID s -> Bool)
-> (DiaID s -> DiaID s -> Bool)
-> (DiaID s -> DiaID s -> Bool)
-> (DiaID s -> DiaID s -> DiaID s)
-> (DiaID s -> DiaID s -> DiaID s)
-> Ord (DiaID s)
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
$ccompare :: forall s. DiaID s -> DiaID s -> Ordering
compare :: DiaID s -> DiaID s -> Ordering
$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
>= :: DiaID s -> DiaID s -> Bool
$cmax :: forall s. DiaID s -> DiaID s -> DiaID s
max :: DiaID s -> DiaID s -> DiaID s
$cmin :: forall s. DiaID s -> DiaID s -> DiaID s
min :: DiaID s -> DiaID s -> DiaID s
Ord, DiaID s -> DiaID s -> Bool
(DiaID s -> DiaID s -> Bool)
-> (DiaID s -> DiaID s -> Bool) -> Eq (DiaID s)
forall s. DiaID s -> DiaID s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
Eq, Int -> DiaID s -> ShowS
[DiaID s] -> ShowS
DiaID s -> String
(Int -> DiaID s -> ShowS)
-> (DiaID s -> String) -> ([DiaID s] -> ShowS) -> Show (DiaID s)
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
$cshowsPrec :: forall s. Int -> DiaID s -> ShowS
showsPrec :: Int -> DiaID s -> ShowS
$cshow :: forall s. DiaID s -> String
show :: DiaID s -> String
$cshowList :: forall s. [DiaID s] -> ShowS
showList :: [DiaID s] -> ShowS
Show, (forall x. DiaID s -> Rep (DiaID s) x)
-> (forall x. Rep (DiaID s) x -> DiaID s) -> Generic (DiaID s)
forall x. Rep (DiaID s) x -> DiaID s
forall x. DiaID s -> Rep (DiaID s) x
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
$cfrom :: forall s x. DiaID s -> Rep (DiaID s) x
from :: forall x. DiaID s -> Rep (DiaID s) x
$cto :: forall s x. Rep (DiaID s) x -> DiaID s
to :: forall x. Rep (DiaID s) x -> DiaID s
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
(VarType -> VarType -> Bool)
-> (VarType -> VarType -> Bool) -> Eq VarType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VarType -> VarType -> Bool
== :: VarType -> VarType -> Bool
$c/= :: VarType -> VarType -> Bool
/= :: VarType -> VarType -> Bool
Eq, Eq VarType
Eq VarType =>
(VarType -> VarType -> Ordering)
-> (VarType -> VarType -> Bool)
-> (VarType -> VarType -> Bool)
-> (VarType -> VarType -> Bool)
-> (VarType -> VarType -> Bool)
-> (VarType -> VarType -> VarType)
-> (VarType -> VarType -> VarType)
-> Ord 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
$ccompare :: VarType -> VarType -> Ordering
compare :: VarType -> VarType -> Ordering
$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
>= :: VarType -> VarType -> Bool
$cmax :: VarType -> VarType -> VarType
max :: VarType -> VarType -> VarType
$cmin :: VarType -> VarType -> VarType
min :: VarType -> VarType -> VarType
Ord, ReadPrec [VarType]
ReadPrec VarType
Int -> ReadS VarType
ReadS [VarType]
(Int -> ReadS VarType)
-> ReadS [VarType]
-> ReadPrec VarType
-> ReadPrec [VarType]
-> Read VarType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS VarType
readsPrec :: Int -> ReadS VarType
$creadList :: ReadS [VarType]
readList :: ReadS [VarType]
$creadPrec :: ReadPrec VarType
readPrec :: ReadPrec VarType
$creadListPrec :: ReadPrec [VarType]
readListPrec :: ReadPrec [VarType]
Read, Int -> VarType -> ShowS
[VarType] -> ShowS
VarType -> String
(Int -> VarType -> ShowS)
-> (VarType -> String) -> ([VarType] -> ShowS) -> Show VarType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VarType -> ShowS
showsPrec :: Int -> VarType -> ShowS
$cshow :: VarType -> String
show :: VarType -> String
$cshowList :: [VarType] -> ShowS
showList :: [VarType] -> ShowS
Show, (forall x. VarType -> Rep VarType x)
-> (forall x. Rep VarType x -> VarType) -> Generic VarType
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
$cfrom :: forall x. VarType -> Rep VarType x
from :: forall x. VarType -> Rep VarType x
$cto :: forall x. Rep VarType x -> VarType
to :: forall x. Rep VarType x -> VarType
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
(Var s -> Var s -> Bool) -> (Var s -> Var s -> Bool) -> Eq (Var s)
forall s. Var s -> Var s -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
Eq, Eq (Var s)
Eq (Var s) =>
(Var s -> Var s -> Ordering)
-> (Var s -> Var s -> Bool)
-> (Var s -> Var s -> Bool)
-> (Var s -> Var s -> Bool)
-> (Var s -> Var s -> Bool)
-> (Var s -> Var s -> Var s)
-> (Var s -> Var s -> Var s)
-> Ord (Var s)
Var s -> Var s -> Bool
Var s -> Var s -> Ordering
Var s -> Var s -> Var s
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
$ccompare :: forall s. Var s -> Var s -> Ordering
compare :: Var s -> Var s -> Ordering
$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
>= :: Var s -> Var s -> Bool
$cmax :: forall s. Var s -> Var s -> Var s
max :: Var s -> Var s -> Var s
$cmin :: forall s. Var s -> Var s -> Var s
min :: Var s -> Var s -> Var s
Ord, (forall x. Var s -> Rep (Var s) x)
-> (forall x. Rep (Var s) x -> Var s) -> Generic (Var s)
forall x. Rep (Var s) x -> Var s
forall x. Var s -> Rep (Var s) x
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
$cfrom :: forall s x. Var s -> Rep (Var s) x
from :: forall x. Var s -> Rep (Var s) x
$cto :: forall s x. Rep (Var s) x -> Var s
to :: forall x. Rep (Var s) x -> Var s
Generic, Int -> Var s -> ShowS
[Var s] -> ShowS
Var s -> String
(Int -> Var s -> ShowS)
-> (Var s -> String) -> ([Var s] -> ShowS) -> Show (Var s)
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
$cshowsPrec :: forall s. Int -> Var s -> ShowS
showsPrec :: Int -> Var s -> ShowS
$cshow :: forall s. Var s -> String
show :: Var s -> String
$cshowList :: forall s. [Var s] -> ShowS
showList :: [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 = n -> Expr (Var s) n
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 = Maybe (DiaID s) -> String -> VarType -> Var s
forall s. Maybe (DiaID s) -> String -> VarType -> Var s
Var (Maybe (DiaID s) -> String -> VarType -> Var s)
-> (DiaID s -> Maybe (DiaID s))
-> DiaID s
-> String
-> VarType
-> Var s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiaID s -> Maybe (DiaID s)
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 = Maybe (DiaID s) -> String -> VarType -> Var s
forall s. Maybe (DiaID s) -> String -> VarType -> Var s
Var Maybe (DiaID s)
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 = Var s -> Expr (Var s) n
forall n v. Num n => v -> Expr v n
MFS.makeVariable (DiaID s -> String -> VarType -> Var s
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 = Var s -> Expr (Var s) n
forall n v. Num n => v -> Expr v n
MFS.makeVariable (String -> VarType -> Var s
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 = DiaID s -> String -> VarType -> Expr s n
forall n s. Num n => DiaID s -> String -> VarType -> Expr s n
mkDVar DiaID s
d String
s VarType
X PrevDim (P2 (Expr s n))
-> FinalCoord (P2 (Expr s n)) -> P2 (Expr s n)
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& DiaID s -> String -> VarType -> Expr s n
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 = String -> VarType -> Expr s n
forall n s. Num n => String -> VarType -> Expr s n
mkVar String
s VarType
X PrevDim (P2 (Expr s n))
-> FinalCoord (P2 (Expr s n)) -> P2 (Expr s n)
forall c. Coordinates c => PrevDim c -> FinalCoord c -> c
^& String -> VarType -> Expr s n
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  = () -> Constraints s n
forall a. a -> MFSolverT (Var s) n Identity a
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   = Map (DiaID s) (QDiagram b V2 n m)
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 <- QDiagram b V2 n m -> Constrained s b n m (DiaID s)
forall b n m s. QDiagram b V2 n m -> Constrained s b n m (DiaID s)
newScalableDia QDiagram b V2 n m
dia
  DiaID s -> Expr s n
forall n s. Num n => DiaID s -> Expr s n
scaleOf DiaID s
d Expr s n -> Expr s n -> Constrained s b n m ()
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
  DiaID s -> Constrained s b n m (DiaID s)
forall a. a -> StateT (ConstrainedState s b n m) Identity a
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 <- Int -> DiaID s
forall s. Int -> DiaID s
DiaID (Int -> DiaID s)
-> StateT (ConstrainedState s b n m) Identity Int
-> Constrained s b n m (DiaID s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Int -> (Int, Int))
-> ConstrainedState s b n m -> (Int, ConstrainedState s b n m)
forall s b n m (f :: * -> *).
Functor f =>
(Int -> f Int)
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
diaCounter ((Int -> (Int, Int))
 -> ConstrainedState s b n m -> (Int, ConstrainedState s b n m))
-> Int -> StateT (ConstrainedState s b n m) Identity Int
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1)
  (Map (DiaID s) (QDiagram b V2 n m)
 -> Identity (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m -> Identity (ConstrainedState s b n m)
forall s b n m b m (f :: * -> *).
Functor f =>
(Map (DiaID s) (QDiagram b V2 n m)
 -> f (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
diagrams ((Map (DiaID s) (QDiagram b V2 n m)
  -> Identity (Map (DiaID s) (QDiagram b V2 n m)))
 -> ConstrainedState s b n m -> Identity (ConstrainedState s b n m))
-> ((Maybe (QDiagram b V2 n m)
     -> Identity (Maybe (QDiagram b V2 n m)))
    -> Map (DiaID s) (QDiagram b V2 n m)
    -> Identity (Map (DiaID s) (QDiagram b V2 n m)))
-> (Maybe (QDiagram b V2 n m)
    -> Identity (Maybe (QDiagram b V2 n m)))
-> ConstrainedState s b n m
-> Identity (ConstrainedState s b n m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map (DiaID s) (QDiagram b V2 n m))
-> Lens'
     (Map (DiaID s) (QDiagram b V2 n m))
     (Maybe (IxValue (Map (DiaID s) (QDiagram b V2 n m))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at Index (Map (DiaID s) (QDiagram b V2 n m))
DiaID s
d ((Maybe (QDiagram b V2 n m)
  -> Identity (Maybe (QDiagram b V2 n m)))
 -> ConstrainedState s b n m -> Identity (ConstrainedState s b n m))
-> QDiagram b V2 n m
-> StateT (ConstrainedState s b n m) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= QDiagram b V2 n m
dia
  DiaID s -> Constrained s b n m (DiaID s)
forall a. a -> StateT (ConstrainedState s b n m) Identity a
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 = (QDiagram b V2 n m
 -> StateT (ConstrainedState s b n m) Identity (DiaID s))
-> [QDiagram b V2 n m]
-> StateT (ConstrainedState s b n m) Identity [DiaID s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM QDiagram b V2 n m
-> StateT (ConstrainedState s b n m) Identity (DiaID s)
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 = DiaID s -> String -> P2 (Expr s n)
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 = DiaID s -> String -> VarType -> Expr s n
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 = DiaID s -> String -> VarType -> Expr s n
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 = DiaID s -> String -> VarType -> Expr s n
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 <- Maybe (QDiagram b V2 n m) -> QDiagram b V2 n m
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (QDiagram b V2 n m) -> QDiagram b V2 n m)
-> StateT
     (ConstrainedState s b n m) Identity (Maybe (QDiagram b V2 n m))
-> StateT (ConstrainedState s b n m) Identity (QDiagram b V2 n m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getting
  (Maybe (QDiagram b V2 n m))
  (ConstrainedState s b n m)
  (Maybe (QDiagram b V2 n m))
-> StateT
     (ConstrainedState s b n m) Identity (Maybe (QDiagram b V2 n m))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((Map (DiaID s) (QDiagram b V2 n m)
 -> Const
      (Maybe (QDiagram b V2 n m)) (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m
-> Const (Maybe (QDiagram b V2 n m)) (ConstrainedState s b n m)
forall s b n m b m (f :: * -> *).
Functor f =>
(Map (DiaID s) (QDiagram b V2 n m)
 -> f (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
diagrams ((Map (DiaID s) (QDiagram b V2 n m)
  -> Const
       (Maybe (QDiagram b V2 n m)) (Map (DiaID s) (QDiagram b V2 n m)))
 -> ConstrainedState s b n m
 -> Const (Maybe (QDiagram b V2 n m)) (ConstrainedState s b n m))
-> ((Maybe (QDiagram b V2 n m)
     -> Const (Maybe (QDiagram b V2 n m)) (Maybe (QDiagram b V2 n m)))
    -> Map (DiaID s) (QDiagram b V2 n m)
    -> Const
         (Maybe (QDiagram b V2 n m)) (Map (DiaID s) (QDiagram b V2 n m)))
-> Getting
     (Maybe (QDiagram b V2 n m))
     (ConstrainedState s b n m)
     (Maybe (QDiagram b V2 n m))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map (DiaID s) (QDiagram b V2 n m))
-> Lens'
     (Map (DiaID s) (QDiagram b V2 n m))
     (Maybe (IxValue (Map (DiaID s) (QDiagram b V2 n m))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at Index (Map (DiaID s) (QDiagram b V2 n m))
DiaID s
d)
  let p :: P2 n
p = QDiagram b V2 n m -> P2 n
getP QDiagram b V2 n m
dia

  Int
v <- (Int -> (Int, Int))
-> ConstrainedState s b n m -> (Int, ConstrainedState s b n m)
forall s b n m (f :: * -> *).
Functor f =>
(Int -> f Int)
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
varCounter ((Int -> (Int, Int))
 -> ConstrainedState s b n m -> (Int, ConstrainedState s b n m))
-> Int -> StateT (ConstrainedState s b n m) Identity Int
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 = DiaID s -> String -> P2 (Expr s n)
forall n s. Num n => DiaID s -> String -> P2 (Expr s n)
mkDPVar DiaID s
d (String
"a" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
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
  DiaID s -> P2 (Expr s n)
forall n s. Num n => DiaID s -> P2 (Expr s n)
centerOf DiaID s
d P2 (Expr s n) -> Diff (Point V2) (Expr s n) -> P2 (Expr s n)
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (DiaID s -> Expr s n
forall n s. Num n => DiaID s -> Expr s n
scaleOf DiaID s
d Expr s n -> V2 (Expr s n) -> V2 (Expr s n)
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ (n -> Expr s n
forall n s. n -> Expr s n
mkExpr (n -> Expr s n) -> V2 n -> V2 (Expr s n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (P2 n
p P2 n -> P2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. P2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin))) P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
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

  P2 (Expr s n) -> Constrained s b n m (P2 (Expr s n))
forall a. a -> StateT (ConstrainedState s b n m) Identity a
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 <- (Int -> (Int, Int))
-> ConstrainedState s b n m -> (Int, ConstrainedState s b n m)
forall s b n m (f :: * -> *).
Functor f =>
(Int -> f Int)
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
varCounter ((Int -> (Int, Int))
 -> ConstrainedState s b n m -> (Int, ConstrainedState s b n m))
-> Int -> StateT (ConstrainedState s b n m) Identity Int
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
  P2 (Expr s n) -> Constrained s b n m (P2 (Expr s n))
forall a. a -> StateT (ConstrainedState s b n m) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (P2 (Expr s n) -> Constrained s b n m (P2 (Expr s n)))
-> P2 (Expr s n) -> Constrained s b n m (P2 (Expr s n))
forall a b. (a -> b) -> a -> b
$ String -> P2 (Expr s n)
forall n s. Num n => String -> P2 (Expr s n)
mkPVar (String
"a" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
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 <- (Int -> (Int, Int))
-> ConstrainedState s b n m -> (Int, ConstrainedState s b n m)
forall s b n m (f :: * -> *).
Functor f =>
(Int -> f Int)
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
varCounter ((Int -> (Int, Int))
 -> ConstrainedState s b n m -> (Int, ConstrainedState s b n m))
-> Int -> StateT (ConstrainedState s b n m) Identity Int
forall s (m :: * -> *) a.
(MonadState s m, Num a) =>
LensLike' ((,) a) s a -> a -> m a
<+= Int
1
  Expr s n -> Constrained s b n m (Expr s n)
forall a. a -> StateT (ConstrainedState s b n m) Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr s n -> Constrained s b n m (Expr s n))
-> Expr s n -> Constrained s b n m (Expr s n)
forall a b. (a -> b) -> a -> b
$ String -> VarType -> Expr s n
forall n s. Num n => String -> VarType -> Expr s n
mkVar (String
"s" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
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 = (Constraints s n -> Identity (Constraints s n))
-> ConstrainedState s b n m -> Identity (ConstrainedState s b n m)
forall s b n m (f :: * -> *).
Functor f =>
(Constraints s n -> f (Constraints s n))
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
equations ((Constraints s n -> Identity (Constraints s n))
 -> ConstrainedState s b n m -> Identity (ConstrainedState s b n m))
-> (Constraints s n -> Constraints s n)
-> StateT (ConstrainedState s b n m) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Constraints s n -> Constraints s n -> Constraints s n
forall a b.
MFSolverT (Var s) n Identity a
-> MFSolverT (Var s) n Identity b -> MFSolverT (Var s) n Identity b
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 = Constraints s n -> Constrained s b n m ()
forall s n b m. Constraints s n -> Constrained s b n m ()
constrain (Constraints s n -> Constrained s b n m ())
-> Constraints s n -> Constrained s b n m ()
forall a b. (a -> b) -> a -> b
$ Constraints s n -> Constraints s n
forall v n (m :: * -> *).
MonadError (DepError v n) m =>
m () -> m ()
MFS.ignore (Expr s n
a Expr s n -> Expr s n -> Constraints s n
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 ()
(P2 (Expr s n) -> Decomposition (P2 (Expr s n))
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 ()
=.= (P2 (Expr s n) -> Decomposition (P2 (Expr s n))
forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
qx :& Expr s n
qy) = do
  Expr s n
px Expr s n -> Expr s n -> Constrained s b n m ()
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 Expr s n -> Expr s n -> Constrained s b n m ()
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 ()
(V2 (Expr s n) -> Decomposition (V2 (Expr s n))
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 ()
=^= (V2 (Expr s n) -> Decomposition (V2 (Expr s n))
forall c. Coordinates c => c -> Decomposition c
coords -> Expr s n
qx :& Expr s n
qy) = do
  Expr s n
px Expr s n -> Expr s n -> Constrained s b n m ()
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 Expr s n -> Expr s n -> Constrained s b n m ()
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)]
_ [] = () -> StateT (ConstrainedState s b n m) Identity ()
forall a. a -> StateT (ConstrainedState s b n m) Identity a
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 <- Getting
  (Map (DiaID s) (QDiagram b V2 n m))
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
-> StateT
     (ConstrainedState s b n m)
     Identity
     (Map (DiaID s) (QDiagram b V2 n m))
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting
  (Map (DiaID s) (QDiagram b V2 n m))
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
forall s b n m b m (f :: * -> *).
Functor f =>
(Map (DiaID s) (QDiagram b V2 n m)
 -> f (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
diagrams
  let dias :: [QDiagram b V2 n m]
dias  = (DiaID s -> QDiagram b V2 n m) -> [DiaID s] -> [QDiagram b V2 n m]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (QDiagram b V2 n m) -> QDiagram b V2 n m
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (QDiagram b V2 n m) -> QDiagram b V2 n m)
-> (DiaID s -> Maybe (QDiagram b V2 n m))
-> DiaID s
-> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DiaID s
 -> Map (DiaID s) (QDiagram b V2 n m) -> Maybe (QDiagram b V2 n m))
-> Map (DiaID s) (QDiagram b V2 n m)
-> DiaID s
-> Maybe (QDiagram b V2 n m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DiaID s
-> Map (DiaID s) (QDiagram b V2 n m) -> Maybe (QDiagram b V2 n m)
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  = (QDiagram b V2 n m -> [Located (Envelope V2 n)])
-> [QDiagram b V2 n m] -> [[Located (Envelope V2 n)]]
forall a b. (a -> b) -> [a] -> [b]
map ((Located (Envelope V2 n)
-> [Located (Envelope V2 n)] -> [Located (Envelope V2 n)]
forall a. a -> [a] -> [a]
:[]) (Located (Envelope V2 n) -> [Located (Envelope V2 n)])
-> (QDiagram b V2 n m -> Located (Envelope V2 n))
-> QDiagram b V2 n m
-> [Located (Envelope V2 n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Envelope V2 n
-> Point (V (Envelope V2 n)) (N (Envelope V2 n))
-> Located (Envelope V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Envelope V2 n)) (N (Envelope V2 n))
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) (Envelope V2 n -> Located (Envelope V2 n))
-> (QDiagram b V2 n m -> Envelope V2 n)
-> QDiagram b V2 n m
-> Located (Envelope V2 n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QDiagram b V2 n m
-> Envelope (V (QDiagram b V2 n m)) (N (QDiagram b V2 n m))
QDiagram b V2 n m -> Envelope V2 n
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 = (Located (Envelope V2 n) -> Point V2 n)
-> [Located (Envelope V2 n)] -> [Point V2 n]
forall a b. (a -> b) -> [a] -> [b]
map Located (Envelope V2 n)
-> Point (V (Envelope V2 n)) (N (Envelope V2 n))
Located (Envelope V2 n) -> Point V2 n
forall a. Located a -> Point (V a) (N a)
loc [Located (Envelope V2 n)]
envs'
      offs :: [V2 n]
offs  = (Point V2 n -> Point V2 n -> V2 n)
-> [Point V2 n] -> [Point V2 n] -> [V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Point V2 n -> Point V2 n -> V2 n
Point V2 n -> Point V2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
(.-.) ([Point V2 n] -> [Point V2 n]
forall a. HasCallStack => [a] -> [a]
tail [Point V2 n]
eCtrs) [Point V2 n]
eCtrs
      rtps :: [Point V2 n]
rtps  = (V2 n -> Located (Envelope V2 n) -> Point V2 n)
-> [V2 n] -> [Located (Envelope V2 n)] -> [Point V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith V2 n -> Located (Envelope V2 n) -> Point V2 n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP             [V2 n]
offs ([Located (Envelope V2 n)] -> [Located (Envelope V2 n)]
forall a. HasCallStack => [a] -> [a]
init [Located (Envelope V2 n)]
envs')
      ltps :: [Point V2 n]
ltps  = (V2 n -> Located (Envelope V2 n) -> Point V2 n)
-> [V2 n] -> [Located (Envelope V2 n)] -> [Point V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (V2 n -> Located (Envelope V2 n) -> Point V2 n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP (V2 n -> Located (Envelope V2 n) -> Point V2 n)
-> (V2 n -> V2 n) -> V2 n -> Located (Envelope V2 n) -> Point V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated) [V2 n]
offs ([Located (Envelope V2 n)] -> [Located (Envelope V2 n)]
forall a. HasCallStack => [a] -> [a]
tail [Located (Envelope V2 n)]
envs')
      gaps' :: [V2 (Expr s n)]
gaps'  = ((V2 n -> V2 (Expr s n)) -> [V2 n] -> [V2 (Expr s n)]
forall a b. (a -> b) -> [a] -> [b]
map ((V2 n -> V2 (Expr s n)) -> [V2 n] -> [V2 (Expr s n)])
-> ((n -> Expr s n) -> V2 n -> V2 (Expr s n))
-> (n -> Expr s n)
-> [V2 n]
-> [V2 (Expr s n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Expr s n) -> V2 n -> V2 (Expr s n)
forall a b. (a -> b) -> V2 a -> V2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) n -> Expr s n
forall n s. n -> Expr s n
mkExpr ([V2 n] -> [V2 (Expr s n)]) -> [V2 n] -> [V2 (Expr s n)]
forall a b. (a -> b) -> a -> b
$ (Point V2 n -> Point V2 n -> V2 n)
-> [Point V2 n] -> [Point V2 n] -> [V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Point V2 n -> Point V2 n -> V2 n
Point V2 n -> Point V2 n -> Diff (Point V2) n
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
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 <- (DiaID s
 -> (QDiagram b V2 n m -> Point V2 n)
 -> StateT (ConstrainedState s b n m) Identity (P2 (Expr s n)))
-> [DiaID s]
-> [QDiagram b V2 n m -> Point V2 n]
-> StateT (ConstrainedState s b n m) Identity [P2 (Expr s n)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM DiaID s
-> (QDiagram b V2 n m -> Point V2 n)
-> StateT (ConstrainedState s b n m) Identity (P2 (Expr s n))
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] -> [DiaID s]
forall a. HasCallStack => [a] -> [a]
init [DiaID s]
hs) ((V2 n -> QDiagram b V2 n m -> Point V2 n)
-> [V2 n] -> [QDiagram b V2 n m -> Point V2 n]
forall a b. (a -> b) -> [a] -> [b]
map V2 n -> QDiagram b V2 n m -> Point V2 n
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 <- (DiaID s
 -> (QDiagram b V2 n m -> Point V2 n)
 -> StateT (ConstrainedState s b n m) Identity (P2 (Expr s n)))
-> [DiaID s]
-> [QDiagram b V2 n m -> Point V2 n]
-> StateT (ConstrainedState s b n m) Identity [P2 (Expr s n)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM DiaID s
-> (QDiagram b V2 n m -> Point V2 n)
-> StateT (ConstrainedState s b n m) Identity (P2 (Expr s n))
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] -> [DiaID s]
forall a. HasCallStack => [a] -> [a]
tail [DiaID s]
hs) ((V2 n -> QDiagram b V2 n m -> Point V2 n)
-> [V2 n] -> [QDiagram b V2 n m -> Point V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (V2 n -> QDiagram b V2 n m -> Point V2 n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> Point v n
envelopeP (V2 n -> QDiagram b V2 n m -> Point V2 n)
-> (V2 n -> V2 n) -> V2 n -> QDiagram b V2 n m -> Point V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. V2 n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated) [V2 n]
offs)
  (P2 (Expr s n)
 -> V2 (Expr s n)
 -> P2 (Expr s n)
 -> StateT (ConstrainedState s b n m) Identity ())
-> [P2 (Expr s n)]
-> [V2 (Expr s n)]
-> [P2 (Expr s n)]
-> StateT (ConstrainedState s b n m) Identity ()
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 P2 (Expr s n) -> Diff (Point V2) (Expr s n) -> P2 (Expr s n)
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 (Expr s n)
Diff (Point V2) (Expr s n)
g P2 (Expr s n)
-> P2 (Expr s n) -> StateT (ConstrainedState s b n m) Identity ()
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 [V2 (Expr s n)]
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 = [m d] -> m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([m d] -> m ()) -> [m d] -> m ()
forall a b. (a -> b) -> a -> b
$ (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> [m d]
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 = DiaID s -> Expr s n
forall n s. Num n => DiaID s -> Expr s n
xOf DiaID s
h1 Expr s n -> Expr s n -> Constrained s b n m ()
forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== DiaID s -> Expr s n
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 = DiaID s -> Expr s n
forall n s. Num n => DiaID s -> Expr s n
yOf DiaID s
h1 Expr s n -> Expr s n -> Constrained s b n m ()
forall n s b m.
(Floating n, RealFrac n, Hashable n) =>
Expr s n -> Expr s n -> Constrained s b n m ()
==== DiaID s -> Expr s n
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 = (Expr s n
 -> Expr s n -> StateT (ConstrainedState s b n m) Identity ())
-> [Expr s n]
-> [Expr s n]
-> StateT (ConstrainedState s b n m) Identity ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Expr s n
-> Expr s n -> StateT (ConstrainedState s b n m) Identity ()
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 ([Expr s n] -> [Expr s n]
forall a. HasCallStack => [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 <- Constrained s b n m (Expr s n)
forall n s b m. Num n => Constrained s b n m (Expr s n)
newScalar
  P2 (Expr s n)
p P2 (Expr s n) -> Diff (Point V2) (Expr s n) -> P2 (Expr s n)
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ (Expr s n
s Expr s n -> V2 (Expr s n) -> V2 (Expr s n)
forall (f :: * -> *) a. (Functor f, Num a) => a -> f a -> f a
*^ Direction V2 (Expr s n) -> V2 (Expr s n)
forall (v :: * -> *) n.
(Metric v, Floating n) =>
Direction v n -> v n
fromDirection Direction V2 (Expr s n)
dir) P2 (Expr s n) -> P2 (Expr s n) -> Constrained s b n m ()
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 = (P2 (Expr s n)
 -> P2 (Expr s n) -> StateT (ConstrainedState s b n m) Identity ())
-> [P2 (Expr s n)]
-> [P2 (Expr s n)]
-> StateT (ConstrainedState s b n m) Identity ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (Direction V2 (Expr s n)
-> P2 (Expr s n)
-> P2 (Expr s n)
-> StateT (ConstrainedState s b n m) Identity ()
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 ([P2 (Expr s n)] -> [P2 (Expr s n)]
forall a. HasCallStack => [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 = APrism (Maybe n) (Maybe Any) n Any -> Maybe n -> Bool
forall s t a b. APrism s t a b -> s -> Bool
L.is APrism (Maybe n) (Maybe Any) n Any
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just (Maybe n -> Bool)
-> (VarResolution s n -> Maybe n) -> VarResolution s n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting (Maybe n) (VarResolution s n) (Maybe n)
-> VarResolution s n -> Maybe n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe n) (VarResolution s n) (Maybe n)
forall s n n (f :: * -> *).
Functor f =>
(Maybe n -> f (Maybe n))
-> VarResolution s n -> f (VarResolution s 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 = [(VarType, VarResolution s n)] -> Map VarType (VarResolution s n)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(VarType, VarResolution s n)] -> Map VarType (VarResolution s n))
-> [(VarType, VarResolution s n)]
-> Map VarType (VarResolution s n)
forall a b. (a -> b) -> a -> b
$
  [ (VarType
X, Var s -> VarResolution s n
getRes (DiaID s -> String -> VarType -> Var s
forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
"center" VarType
X))
  , (VarType
Y, Var s -> VarResolution s n
getRes (DiaID s -> String -> VarType -> Var s
forall s. DiaID s -> String -> VarType -> Var s
diaVar DiaID s
d String
"center" VarType
Y))
  , (VarType
S, Var s -> VarResolution s n
getRes (DiaID s -> String -> VarType -> Var s
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
      = Var s -> Maybe n -> VarResolution s n
forall s n. Var s -> Maybe n -> VarResolution s n
VR Var s
v (([Var s] -> Maybe n)
-> (n -> Maybe n) -> Either [Var s] n -> Maybe n
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe n -> [Var s] -> Maybe n
forall a b. a -> b -> a
const Maybe n
forall a. Maybe a
Nothing) n -> Maybe n
forall a. a -> Maybe a
Just (Either [Var s] n -> Maybe n) -> Either [Var s] n -> Maybe n
forall a b. (a -> b) -> a -> b
$ Var s -> Dependencies (Var s) n -> Either [Var s] n
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 = (a, QDiagram b V2 n m) -> QDiagram b V2 n m
forall a b. (a, b) -> b
snd ((a, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> (a, QDiagram b V2 n m) -> QDiagram b V2 n m
forall a b. (a -> b) -> a -> b
$ (forall s. Constrained s b n m a) -> (a, QDiagram b V2 n m)
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 Constrained s b n m a
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 MFSolverT (Var Any) n Identity ()
-> Dependencies (Var Any) n
-> Either (DepError (Var Any) n) (Dependencies (Var Any) n)
forall v n a.
MFSolver v n a
-> Dependencies v n -> Either (DepError v n) (Dependencies v n)
MFS.execSolver (MFSolverT (Var Any) n Identity ()
-> MFSolverT (Var Any) n Identity ()
forall v n (m :: * -> *).
MonadError (DepError v n) m =>
m () -> m ()
MFS.ignore (MFSolverT (Var Any) n Identity ()
 -> MFSolverT (Var Any) n Identity ())
-> MFSolverT (Var Any) n Identity ()
-> MFSolverT (Var Any) n Identity ()
forall a b. (a -> b) -> a -> b
$ ConstrainedState Any b n m
forall {s}. ConstrainedState s b n m
s ConstrainedState Any b n m
-> Getting
     (MFSolverT (Var Any) n Identity ())
     (ConstrainedState Any b n m)
     (MFSolverT (Var Any) n Identity ())
-> MFSolverT (Var Any) n Identity ()
forall s a. s -> Getting a s a -> a
^. Getting
  (MFSolverT (Var Any) n Identity ())
  (ConstrainedState Any b n m)
  (MFSolverT (Var Any) n Identity ())
forall s b n m (f :: * -> *).
Functor f =>
(Constraints s n -> f (Constraints s n))
-> ConstrainedState s b n m -> f (ConstrainedState s b n m)
equations) Dependencies (Var Any) n
forall v n. Dependencies v n
MFS.noDeps of
    Left DepError (Var Any) n
_depError -> String -> (a, QDiagram b V2 n m)
forall a. HasCallStack => String -> a
error String
"overconstrained"
    Right Dependencies (Var Any) n
deps    ->
      let deps' :: Dependencies (Var Any) n
deps' = [DiaID Any] -> Dependencies (Var Any) n -> Dependencies (Var Any) n
forall n s.
(Hashable n, RealFrac n, Floating n, Show n) =>
[DiaID s] -> Dependencies (Var s) n -> Dependencies (Var s) n
resolve (((DiaID Any, QDiagram b V2 n m) -> DiaID Any)
-> [(DiaID Any, QDiagram b V2 n m)] -> [DiaID Any]
forall a b. (a -> b) -> [a] -> [b]
map (DiaID Any, QDiagram b V2 n m) -> DiaID Any
forall a b. (a, b) -> a
fst [(DiaID Any, QDiagram b V2 n m)]
forall {s}. [(DiaID s, QDiagram b V2 n m)]
dias) Dependencies (Var Any) n
deps
      in  (a
a, ) (QDiagram b V2 n m -> (a, QDiagram b V2 n m))
-> (((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
    -> QDiagram b V2 n m)
-> ((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> (a, QDiagram b V2 n m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [QDiagram b V2 n m] -> QDiagram b V2 n m
forall a. Monoid a => [a] -> a
mconcat ([QDiagram b V2 n m] -> QDiagram b V2 n m)
-> (((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
    -> [QDiagram b V2 n m])
-> ((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
 -> [(DiaID Any, QDiagram b V2 n m)] -> [QDiagram b V2 n m])
-> [(DiaID Any, QDiagram b V2 n m)]
-> ((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> [QDiagram b V2 n m]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> [(DiaID Any, QDiagram b V2 n m)] -> [QDiagram b V2 n m]
forall a b. (a -> b) -> [a] -> [b]
map [(DiaID Any, QDiagram b V2 n m)]
forall {s}. [(DiaID s, QDiagram b V2 n m)]
dias (((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
 -> (a, QDiagram b V2 n m))
-> ((DiaID Any, QDiagram b V2 n m) -> QDiagram b V2 n m)
-> (a, QDiagram b V2 n m)
forall a b. (a -> b) -> a -> b
$ \(DiaID Any
d, QDiagram b V2 n m
dia) ->
        let vars :: Map VarType (VarResolution Any n)
vars = Dependencies (Var Any) n
-> DiaID Any -> Map VarType (VarResolution Any n)
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 Map VarType (VarResolution Any n)
-> Getting (Endo n) (Map VarType (VarResolution Any n)) n -> n
forall s a. HasCallStack => s -> Getting (Endo a) s a -> a
^?! Index (Map VarType (VarResolution Any n))
-> Lens'
     (Map VarType (VarResolution Any n))
     (Maybe (IxValue (Map VarType (VarResolution Any n))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
L.at Index (Map VarType (VarResolution Any n))
VarType
ty ((Maybe (VarResolution Any n)
  -> Const (Endo n) (Maybe (VarResolution Any n)))
 -> Map VarType (VarResolution Any n)
 -> Const (Endo n) (Map VarType (VarResolution Any n)))
-> ((n -> Const (Endo n) n)
    -> Maybe (VarResolution Any n)
    -> Const (Endo n) (Maybe (VarResolution Any n)))
-> Getting (Endo n) (Map VarType (VarResolution Any n)) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarResolution Any n -> Const (Endo n) (VarResolution Any n))
-> Maybe (VarResolution Any n)
-> Const (Endo n) (Maybe (VarResolution Any n))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just ((VarResolution Any n -> Const (Endo n) (VarResolution Any n))
 -> Maybe (VarResolution Any n)
 -> Const (Endo n) (Maybe (VarResolution Any n)))
-> ((n -> Const (Endo n) n)
    -> VarResolution Any n -> Const (Endo n) (VarResolution Any n))
-> (n -> Const (Endo n) n)
-> Maybe (VarResolution Any n)
-> Const (Endo n) (Maybe (VarResolution Any n))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe n -> Const (Endo n) (Maybe n))
-> VarResolution Any n -> Const (Endo n) (VarResolution Any n)
forall s n n (f :: * -> *).
Functor f =>
(Maybe n -> f (Maybe n))
-> VarResolution s n -> f (VarResolution s n)
resolution ((Maybe n -> Const (Endo n) (Maybe n))
 -> VarResolution Any n -> Const (Endo n) (VarResolution Any n))
-> ((n -> Const (Endo n) n) -> Maybe n -> Const (Endo n) (Maybe n))
-> (n -> Const (Endo n) n)
-> VarResolution Any n
-> Const (Endo n) (VarResolution Any n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> Const (Endo n) n) -> Maybe n -> Const (Endo n) (Maybe n)
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
_Just
        in
          case (VarResolution Any n -> Bool)
-> Map VarType (VarResolution Any n) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (VarResolution Any n -> Bool
forall s n. VarResolution s n -> Bool
isResolved) Map VarType (VarResolution Any n)
vars of
            Bool
True -> QDiagram b V2 n m
dia QDiagram b V2 n m
-> (QDiagram b V2 n m -> QDiagram b V2 n m) -> QDiagram b V2 n m
forall a b. a -> (a -> b) -> b
# n -> QDiagram b V2 n m -> QDiagram b V2 n m
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
_ -> String -> QDiagram b V2 n m
forall a. HasCallStack => String -> a
error (String -> QDiagram b V2 n m)
-> ([String] -> String) -> [String] -> QDiagram b V2 n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> QDiagram b V2 n m) -> [String] -> QDiagram b V2 n m
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) = State (ConstrainedState s b n m) a
-> ConstrainedState s b n m -> (a, ConstrainedState s b n m)
forall s a. State s a -> s -> (a, s)
runState State (ConstrainedState s b n m) a
forall s. Constrained s b n m a
constr ConstrainedState s b n m
forall s b n m. ConstrainedState s b n m
initConstrainedState
    dias :: [(DiaID s, QDiagram b V2 n m)]
dias = Map (DiaID s) (QDiagram b V2 n m) -> [(DiaID s, QDiagram b V2 n m)]
forall k a. Map k a -> [(k, a)]
M.assocs (ConstrainedState s b n m
forall {s}. ConstrainedState s b n m
s ConstrainedState s b n m
-> Getting
     (Map (DiaID s) (QDiagram b V2 n m))
     (ConstrainedState s b n m)
     (Map (DiaID s) (QDiagram b V2 n m))
-> Map (DiaID s) (QDiagram b V2 n m)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (DiaID s) (QDiagram b V2 n m))
  (ConstrainedState s b n m)
  (Map (DiaID s) (QDiagram b V2 n m))
forall s b n m b m (f :: * -> *).
Functor f =>
(Map (DiaID s) (QDiagram b V2 n m)
 -> f (Map (DiaID s) (QDiagram b V2 n m)))
-> ConstrainedState s b n m -> f (ConstrainedState s b 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 = Var s -> Expr (Var s) n
forall n v. Num n => v -> Expr v n
MFS.makeVariable Var s
v Expr (Var s) n -> Expr (Var s) n -> Expr (Var s) n
forall a. Num a => a -> a -> a
- (if Var s
vVar s -> Getting VarType (Var s) VarType -> VarType
forall s a. s -> Getting a s a -> a
^.Getting VarType (Var s) VarType
forall s (f :: * -> *).
Functor f =>
(VarType -> f VarType) -> Var s -> f (Var s)
varType VarType -> VarType -> Bool
forall a. Eq a => a -> a -> Bool
== VarType
S then Expr (Var s) n
1 else Expr (Var s) n
0)
      in case Dependencies (Var s) n
-> Expr (Var s) n
-> Either (DepError (Var s) n) (Dependencies (Var s) n)
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' -> [DiaID s] -> Dependencies (Var s) n -> Dependencies (Var s) n
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    -> String -> Dependencies (Var s) n
forall a. HasCallStack => String -> a
error (String -> Dependencies (Var s) n)
-> ([String] -> String) -> [String] -> Dependencies (Var s) n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Dependencies (Var s) n)
-> [String] -> Dependencies (Var s) n
forall a b. (a -> b) -> a -> b
$
                 [ String
"Diagrams.TwoD.Layout.Constrained.layout: impossible!"
                 , String
"Adding equation for unconstrained variable produced an error:"
                 , DepError (Var s) n -> String
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 [DiaID s]
-> (DiaID s -> [VarResolution s n]) -> [VarResolution s n]
forall a b. [a] -> (a -> [b]) -> [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Map VarType (VarResolution s n) -> [VarResolution s n]
forall k a. Map k a -> [a]
M.elems (Map VarType (VarResolution s n) -> [VarResolution s n])
-> (DiaID s -> Map VarType (VarResolution s n))
-> DiaID s
-> [VarResolution s n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies (Var s) n
-> DiaID s -> Map VarType (VarResolution s n)
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
      = (VarResolution s n -> VarResolution s n -> Ordering)
-> [VarResolution s n] -> [VarResolution s n]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((VarResolution s n -> VarType)
-> VarResolution s n -> VarResolution s n -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Getting VarType (VarResolution s n) VarType
-> VarResolution s n -> VarType
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Var s -> Const VarType (Var s))
-> VarResolution s n -> Const VarType (VarResolution s n)
forall s n s (f :: * -> *).
Functor f =>
(Var s -> f (Var s)) -> VarResolution s n -> f (VarResolution s n)
resolvedVar((Var s -> Const VarType (Var s))
 -> VarResolution s n -> Const VarType (VarResolution s n))
-> Getting VarType (Var s) VarType
-> Getting VarType (VarResolution s n) VarType
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Getting VarType (Var s) VarType
forall s (f :: * -> *).
Functor f =>
(VarType -> f VarType) -> Var s -> f (Var s)
varType)))
      ([VarResolution s n] -> [VarResolution s n])
-> ([VarResolution s n] -> [VarResolution s n])
-> [VarResolution s n]
-> [VarResolution s n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VarResolution s n -> Bool)
-> [VarResolution s n] -> [VarResolution s n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (VarResolution s n -> Bool) -> VarResolution s n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarResolution s n -> Bool
forall s n. VarResolution s n -> Bool
isResolved)
      ([VarResolution s n] -> [VarResolution s n])
-> [VarResolution s n] -> [VarResolution s n]
forall a b. (a -> b) -> a -> b
$ [VarResolution s n]
diaVars