{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
module Diagrams.TwoD.Layout.Constrained
(
Expr, mkExpr, Constrained, ConstrainedState, DiaID
, layout
, runLayout
, newDia, newDias, newScalableDia
, newPoint, newPointOn
, newScalar
, centerOf, xOf, yOf, scaleOf
, (====), (=.=), (=^=)
, 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
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)
data VarType = S
| L
| X
| Y
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)
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
instance Hashable (DiaID s)
instance Hashable VarType
instance Hashable (Var s)
type Expr s n = MFS.Expr (Var 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
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
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
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)
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)
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
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
type Constraints s n = MFS.MFSolver (Var s) n ()
data ConstrainedState s b n m = ConstrainedState
{ forall s b n m. ConstrainedState s b n m -> Constraints s n
_equations :: Constraints s n
, forall s b n m. ConstrainedState s b n m -> Int
_diaCounter :: Int
, forall s b n m. ConstrainedState s b n m -> Int
_varCounter :: Int
, 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)
}
makeLenses ''ConstrainedState
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
}
type Constrained s b n m a = State (ConstrainedState s b n m) a
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
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
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
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"
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
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
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
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
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)
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
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)
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
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)
infix 1 =.=, =^=, ====
(====)
:: (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)
(=.=)
:: (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
(=^=)
:: (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
constrainWith
:: (Hashable n, RealFrac n, Floating n, Monoid' m)
=>
([[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
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
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
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 :: (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 :: (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)
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
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
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)
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
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"
]
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