{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Diagrams.Core.Compile
(
RNode(..)
, RTree
, toRTree
, renderDia
, renderDiaT
, toDTree
, fromDTree
)
where
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe)
import Data.Monoid.Coproduct
import Data.Monoid.MList
import Data.Monoid.WithSemigroup (Monoid')
import Data.Semigroup
import Data.Tree
import Data.Tree.DUAL
import Data.Typeable
import Diagrams.Core.Envelope (OrderedField, diameter)
import Diagrams.Core.Style
import Diagrams.Core.Transform
import Diagrams.Core.Types
import Linear.Metric hiding (qd)
#if __GLASGOW_HASKELL__ >= 707
#define Typeable1 Typeable
#endif
emptyDTree :: Tree (DNode b v n a)
emptyDTree :: Tree (DNode b v n a)
emptyDTree = DNode b v n a -> Forest (DNode b v n a) -> Tree (DNode b v n a)
forall a. a -> Forest a -> Tree a
Node DNode b v n a
forall b (v :: * -> *) n a. DNode b v n a
DEmpty []
uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r
uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r
uncurry3 a -> b -> c -> r
f (a
x, b
y, c
z) = a -> b -> c -> r
f a
x b
y c
z
toDTree :: (HasLinearMap v, Floating n, Typeable n)
=> n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
toDTree :: n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
toDTree n
g n
n (QD DUALTree
(DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
qd)
= (DownAnnots v n -> QDiaLeaf b v n m -> DTree b v n Annotation)
-> DTree b v n Annotation
-> (NonEmpty (DTree b v n Annotation) -> DTree b v n Annotation)
-> (DownAnnots v n
-> DTree b v n Annotation -> DTree b v n Annotation)
-> (Annotation -> DTree b v n Annotation -> DTree b v n Annotation)
-> DUALTree
(DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
-> Maybe (DTree b v n Annotation)
forall d l r a u.
(Semigroup d, Monoid d) =>
(d -> l -> r)
-> r
-> (NonEmpty r -> r)
-> (d -> r -> r)
-> (a -> r -> r)
-> DUALTree d u a l
-> Maybe r
foldDUAL
(\DownAnnots v n
d -> (Prim b v n -> DTree b v n Annotation)
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> DTree b v n Annotation)
-> QDiaLeaf b v n m
-> DTree b v n Annotation
forall b (v :: * -> *) n r m.
(Prim b v n -> r)
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m) -> r)
-> QDiaLeaf b v n m
-> r
withQDiaLeaf
(\Prim b v n
p -> DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Prim b v n -> DNode b v n Annotation
forall b (v :: * -> *) n a. Prim b v n -> DNode b v n a
DPrim Prim b v n
p) [])
(DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node DNode b v n Annotation
forall b (v :: * -> *) n a. DNode b v n a
DDelay (Forest (DNode b v n Annotation) -> DTree b v n Annotation)
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> Forest (DNode b v n Annotation))
-> (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> DTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DTree b v n Annotation
-> Forest (DNode b v n Annotation)
-> Forest (DNode b v n Annotation)
forall a. a -> [a] -> [a]
:[]) (DTree b v n Annotation -> Forest (DNode b v n Annotation))
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> DTree b v n Annotation)
-> (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> Forest (DNode b v n Annotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTree b v n Annotation
-> Maybe (DTree b v n Annotation) -> DTree b v n Annotation
forall a. a -> Maybe a -> a
fromMaybe DTree b v n Annotation
forall b (v :: * -> *) n a. Tree (DNode b v n a)
emptyDTree (Maybe (DTree b v n Annotation) -> DTree b v n Annotation)
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> Maybe (DTree b v n Annotation))
-> (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> DTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
forall (v :: * -> *) n b m.
(HasLinearMap v, Floating n, Typeable n) =>
n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
toDTree n
g n
n (QDiagram b v n m -> Maybe (DTree b v n Annotation))
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> QDiagram b v n m)
-> (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> Maybe (DTree b v n Annotation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((DownAnnots v n, n, n) -> QDiagram b v n m)
-> (DownAnnots v n, n, n) -> QDiagram b v n m
forall a b. (a -> b) -> a -> b
$ (DownAnnots v n
d, n
g, n
n)) (((DownAnnots v n, n, n) -> QDiagram b v n m) -> QDiagram b v n m)
-> ((DownAnnots v n -> n -> n -> QDiagram b v n m)
-> (DownAnnots v n, n, n) -> QDiagram b v n m)
-> (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> QDiagram b v n m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DownAnnots v n -> n -> n -> QDiagram b v n m)
-> (DownAnnots v n, n, n) -> QDiagram b v n m
forall a b c r. (a -> b -> c -> r) -> (a, b, c) -> r
uncurry3)
)
DTree b v n Annotation
forall b (v :: * -> *) n a. Tree (DNode b v n a)
emptyDTree
(\NonEmpty (DTree b v n Annotation)
ts -> case NonEmpty (DTree b v n Annotation)
-> Forest (DNode b v n Annotation)
forall a. NonEmpty a -> [a]
NEL.toList NonEmpty (DTree b v n Annotation)
ts of
[DTree b v n Annotation
t] -> DTree b v n Annotation
t
Forest (DNode b v n Annotation)
ts' -> DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node DNode b v n Annotation
forall b (v :: * -> *) n a. DNode b v n a
DEmpty Forest (DNode b v n Annotation)
ts'
)
(\DownAnnots v n
d DTree b v n Annotation
t -> case DownAnnots v n -> Maybe (Transformation v n :+: Style v n)
forall l a. (l :>: a) => l -> Maybe a
get DownAnnots v n
d of
Maybe (Transformation v n :+: Style v n)
Nothing -> DTree b v n Annotation
t
Just Transformation v n :+: Style v n
d' ->
let (Transformation v n
tr,Style v n
sty) = (Transformation v n :+: Style v n)
-> (Transformation v n, Style v n)
forall m n. (Action m n, Monoid m, Monoid n) => (m :+: n) -> (m, n)
untangle Transformation v n :+: Style v n
d'
in DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Style v n -> DNode b v n Annotation
forall b (v :: * -> *) n a. Style v n -> DNode b v n a
DStyle Style v n
sty) [DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Transformation v n -> DNode b v n Annotation
forall b (v :: * -> *) n a. Transformation v n -> DNode b v n a
DTransform Transformation v n
tr) [DTree b v n Annotation
t]]
)
(\Annotation
a DTree b v n Annotation
t -> DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Annotation -> DNode b v n Annotation
forall b (v :: * -> *) n a. a -> DNode b v n a
DAnnot Annotation
a) [DTree b v n Annotation
t])
DUALTree
(DownAnnots v n) (UpAnnots b v n m) Annotation (QDiaLeaf b v n m)
qd
fromDTree :: forall b v n. (Floating n, HasLinearMap v)
=> DTree b v n Annotation -> RTree b v n Annotation
fromDTree :: DTree b v n Annotation -> RTree b v n Annotation
fromDTree = Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
forall a. Monoid a => a
mempty
where
fromDTree' :: Transformation v n -> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' :: Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
accTr (Node (DPrim Prim b v n
p) Forest (DNode b v n Annotation)
_)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Prim b v n -> RNode b v n Annotation
forall b (v :: * -> *) n a. Prim b v n -> RNode b v n a
RPrim (Transformation (V (Prim b v n)) (N (Prim b v n))
-> Prim b v n -> Prim b v n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation v n
Transformation (V (Prim b v n)) (N (Prim b v n))
accTr Prim b v n
p)) []
fromDTree' Transformation v n
accTr (Node (DStyle Style v n
s) Forest (DNode b v n Annotation)
ts)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Style v n -> RNode b v n Annotation
forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle (Transformation (V (Style v n)) (N (Style v n))
-> Style v n -> Style v n
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation v n
Transformation (V (Style v n)) (N (Style v n))
accTr Style v n
s)) ((DTree b v n Annotation -> RTree b v n Annotation)
-> Forest (DNode b v n Annotation)
-> Forest (RNode b v n Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
accTr) Forest (DNode b v n Annotation)
ts)
fromDTree' Transformation v n
accTr (Node (DTransform Transformation v n
tr) Forest (DNode b v n Annotation)
ts)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node RNode b v n Annotation
forall b (v :: * -> *) n a. RNode b v n a
REmpty ((DTree b v n Annotation -> RTree b v n Annotation)
-> Forest (DNode b v n Annotation)
-> Forest (RNode b v n Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' (Transformation v n
accTr Transformation v n -> Transformation v n -> Transformation v n
forall a. Semigroup a => a -> a -> a
<> Transformation v n
tr)) Forest (DNode b v n Annotation)
ts)
fromDTree' Transformation v n
accTr (Node (DAnnot Annotation
a) Forest (DNode b v n Annotation)
ts)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node (Annotation -> RNode b v n Annotation
forall b (v :: * -> *) n a. a -> RNode b v n a
RAnnot Annotation
a) ((DTree b v n Annotation -> RTree b v n Annotation)
-> Forest (DNode b v n Annotation)
-> Forest (RNode b v n Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
accTr) Forest (DNode b v n Annotation)
ts)
fromDTree' Transformation v n
_ (Node DNode b v n Annotation
DDelay Forest (DNode b v n Annotation)
ts)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node RNode b v n Annotation
forall b (v :: * -> *) n a. RNode b v n a
REmpty ((DTree b v n Annotation -> RTree b v n Annotation)
-> Forest (DNode b v n Annotation)
-> Forest (RNode b v n Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
forall a. Monoid a => a
mempty) Forest (DNode b v n Annotation)
ts)
fromDTree' Transformation v n
accTr (Node DNode b v n Annotation
_ Forest (DNode b v n Annotation)
ts)
= RNode b v n Annotation
-> Forest (RNode b v n Annotation) -> RTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node RNode b v n Annotation
forall b (v :: * -> *) n a. RNode b v n a
REmpty ((DTree b v n Annotation -> RTree b v n Annotation)
-> Forest (DNode b v n Annotation)
-> Forest (RNode b v n Annotation)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Transformation v n
-> DTree b v n Annotation -> RTree b v n Annotation
fromDTree' Transformation v n
accTr) Forest (DNode b v n Annotation)
ts)
toRTree
:: (HasLinearMap v, Metric v, Typeable n,
OrderedField n, Monoid m, Semigroup m)
=> Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
toRTree :: Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
toRTree Transformation v n
globalToOutput QDiagram b v n m
d
= ((RNode b v n Annotation -> RNode b v n Annotation)
-> RTree b v n Annotation -> RTree b v n Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((RNode b v n Annotation -> RNode b v n Annotation)
-> RTree b v n Annotation -> RTree b v n Annotation)
-> ((Style v n -> Style v n)
-> RNode b v n Annotation -> RNode b v n Annotation)
-> (Style v n -> Style v n)
-> RTree b v n Annotation
-> RTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Style v n -> Style v n)
-> RNode b v n Annotation -> RNode b v n Annotation
forall (v :: * -> *) n b a.
(Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
onRStyle) (n -> n -> Style v n -> Style v n
forall n (v :: * -> *). Num n => n -> n -> Style v n -> Style v n
unmeasureAttrs n
gToO n
nToO)
(RTree b v n Annotation -> RTree b v n Annotation)
-> (QDiagram b v n m -> RTree b v n Annotation)
-> QDiagram b v n m
-> RTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTree b v n Annotation -> RTree b v n Annotation
forall b (v :: * -> *) n.
(Floating n, HasLinearMap v) =>
DTree b v n Annotation -> RTree b v n Annotation
fromDTree
(DTree b v n Annotation -> RTree b v n Annotation)
-> (QDiagram b v n m -> DTree b v n Annotation)
-> QDiagram b v n m
-> RTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DTree b v n Annotation
-> Maybe (DTree b v n Annotation) -> DTree b v n Annotation
forall a. a -> Maybe a -> a
fromMaybe (DNode b v n Annotation
-> Forest (DNode b v n Annotation) -> DTree b v n Annotation
forall a. a -> Forest a -> Tree a
Node DNode b v n Annotation
forall b (v :: * -> *) n a. DNode b v n a
DEmpty [])
(Maybe (DTree b v n Annotation) -> DTree b v n Annotation)
-> (QDiagram b v n m -> Maybe (DTree b v n Annotation))
-> QDiagram b v n m
-> DTree b v n Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
forall (v :: * -> *) n b m.
(HasLinearMap v, Floating n, Typeable n) =>
n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
toDTree n
gToO n
nToO
(QDiagram b v n m -> RTree b v n Annotation)
-> QDiagram b v n m -> RTree b v n Annotation
forall a b. (a -> b) -> a -> b
$ QDiagram b v n m
d
where
gToO :: n
gToO = Transformation v n -> n
forall (v :: * -> *) n.
(Additive v, Traversable v, Floating n) =>
Transformation v n -> n
avgScale Transformation v n
globalToOutput
nToO :: n
nToO = [n] -> n
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product ((v n -> n) -> [v n] -> [n]
forall a b. (a -> b) -> [a] -> [b]
map (v n -> QDiagram b v n m -> n
forall a (v :: * -> *) n.
(V a ~ v, N a ~ n, Enveloped a) =>
v n -> a -> n
`diameter` QDiagram b v n m
d) [v n]
forall (t :: * -> *) a. (Additive t, Traversable t, Num a) => [t a]
basis) n -> n -> n
forall a. Floating a => a -> a -> a
** (n
1 n -> n -> n
forall a. Fractional a => a -> a -> a
/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral (QDiagram b v n m -> Int
forall a. (Additive (V a), Traversable (V a)) => a -> Int
dimension QDiagram b v n m
d))
onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
onRStyle Style v n -> Style v n
f (RStyle Style v n
s) = Style v n -> RNode b v n a
forall b (v :: * -> *) n a. Style v n -> RNode b v n a
RStyle (Style v n -> Style v n
f Style v n
s)
onRStyle Style v n -> Style v n
_ RNode b v n a
n = RNode b v n a
n
renderDiaT
:: (Backend b v n , HasLinearMap v, Metric v,
Typeable n, OrderedField n, Monoid' m)
=> b -> Options b v n -> QDiagram b v n m -> (Transformation v n, Result b v n)
renderDiaT :: b
-> Options b v n
-> QDiagram b v n m
-> (Transformation v n, Result b v n)
renderDiaT b
b Options b v n
opts QDiagram b v n m
d = (Transformation v n
g2o, b -> Options b v n -> RTree b v n Annotation -> Result b v n
forall b (v :: * -> *) n.
Backend b v n =>
b -> Options b v n -> RTree b v n Annotation -> Result b v n
renderRTree b
b Options b v n
opts' (RTree b v n Annotation -> Result b v n)
-> (QDiagram b v n m -> RTree b v n Annotation)
-> QDiagram b v n m
-> Result b v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
forall (v :: * -> *) n m b.
(HasLinearMap v, Metric v, Typeable n, OrderedField n, Monoid m,
Semigroup m) =>
Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
toRTree Transformation v n
g2o (QDiagram b v n m -> Result b v n)
-> QDiagram b v n m -> Result b v n
forall a b. (a -> b) -> a -> b
$ QDiagram b v n m
d')
where (Options b v n
opts', Transformation v n
g2o, QDiagram b v n m
d') = b
-> Options b v n
-> QDiagram b v n m
-> (Options b v n, Transformation v n, QDiagram b v n m)
forall b (v :: * -> *) n m.
(Backend b v n, Additive v, Monoid' m, Num n) =>
b
-> Options b v n
-> QDiagram b v n m
-> (Options b v n, Transformation v n, QDiagram b v n m)
adjustDia b
b Options b v n
opts QDiagram b v n m
d
renderDia
:: (Backend b v n , HasLinearMap v, Metric v,
Typeable n, OrderedField n, Monoid' m)
=> b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia :: b -> Options b v n -> QDiagram b v n m -> Result b v n
renderDia b
b Options b v n
opts QDiagram b v n m
d = (Transformation v n, Result b v n) -> Result b v n
forall a b. (a, b) -> b
snd (b
-> Options b v n
-> QDiagram b v n m
-> (Transformation v n, Result b v n)
forall b (v :: * -> *) n m.
(Backend b v n, HasLinearMap v, Metric v, Typeable n,
OrderedField n, Monoid' m) =>
b
-> Options b v n
-> QDiagram b v n m
-> (Transformation v n, Result b v n)
renderDiaT b
b Options b v n
opts QDiagram b v n m
d)