Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Simplify dual #87

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Simplify dual #87

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
9eb1a17
more instances
cchalmers Apr 13, 2015
f7cae94
Compile with new DUALTree
cchalmers Apr 17, 2015
2731978
Cleanup Envelope type signatures
cchalmers Apr 19, 2015
811b2c4
New instances for query and a queryPoint setter
cchalmers Apr 19, 2015
c35238a
Comment typos
cchalmers Jul 12, 2015
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 3 additions & 2 deletions diagrams-core.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -41,11 +41,12 @@ Library
unordered-containers >= 0.2 && < 0.2.6,
semigroups >= 0.8.4 && < 0.17,
monoid-extras >= 0.3 && < 0.5,
dual-tree >= 0.2 && < 0.3,
lens >= 4.0 && < 4.12,
dual-tree >= 0.3 && < 0.4,
lens >= 4.0 && < 4.13,
linear >= 1.11.3 && < 1.19,
adjunctions >= 4.0 && < 5.0,
distributive >=0.2.2 && < 1.0,
hashable,
mtl
hs-source-dirs: src

Expand Down
228 changes: 92 additions & 136 deletions src/Diagrams/Core/Compile.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
Expand All @@ -18,164 +19,119 @@

module Diagrams.Core.Compile
( -- * Tools for backends
RNode(..)
, RTree
, toRTree
foldDia
, foldDia'

-- * Backend API

, renderDia
, renderDiaT

-- * Internals

, toDTree
, fromDTree
)
where

import Data.Typeable
import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe)
import Control.Lens hiding (transform)
import qualified Data.Foldable as F
import Data.Monoid.Coproduct
import Data.Monoid.MList
import qualified Data.Monoid as M
import Data.Monoid.WithSemigroup (Monoid')
import Data.Semigroup
import Data.Tree
import Data.Tree.DUAL
import Data.Tree.DUAL (foldDUAL, foldDUAL')
import Data.Typeable

import Diagrams.Core.Envelope (OrderedField, diameter)
import Diagrams.Core.Envelope (OrderedField, size)
import Diagrams.Core.Style
import Diagrams.Core.Transform
import Diagrams.Core.Types
import Diagrams.Core.Style

import Linear.Metric hiding (qd)
import Linear.Metric hiding (qd)

-- Typeable1 is a depreciated synonym in ghc > 707
#if __GLASGOW_HASKELL__ >= 707
#define Typeable1 Typeable
#endif

emptyDTree :: Tree (DNode b v n a)
emptyDTree = Node DEmpty []

uncurry3 :: (a -> b -> c -> r) -> (a, b, c) -> r
uncurry3 f (x, y, z) = f x y z

-- | Convert a @QDiagram@ into a raw tree.
toDTree :: (HasLinearMap v, Floating n, Typeable n)
=> n -> n -> QDiagram b v n m -> Maybe (DTree b v n Annotation)
toDTree g n (QD qd)
= foldDUAL

-- Prims at the leaves. We ignore the accumulated d-annotations
-- for prims (since we instead distribute them incrementally
-- throughout the tree as they occur), or pass them to the
-- continuation in the case of a delayed node.
(\d -> withQDiaLeaf

-- Prim: make a leaf node
(\p -> Node (DPrim p) [])

-- Delayed tree: pass the accumulated d-annotations to
-- the continuation, convert the result to a DTree, and
-- splice it in, adding a DDelay node to mark the point
-- of the splice.
(Node DDelay . (:[]) . fromMaybe emptyDTree . toDTree g n . ($ (d, g, n)) . uncurry3)
)

-- u-only leaves --> empty DTree. We don't care about the
-- u-annotations.
emptyDTree

-- a non-empty list of child trees.
(\ts -> case NEL.toList ts of
[t] -> t
ts' -> Node DEmpty ts'
)

-- Internal d-annotations. We untangle the interleaved
-- transformations and style, and carefully place the style
-- /above/ the transform in the tree (since by calling
-- 'untangle' we have already performed the action of the
-- transform on the style).
(\d t -> case get d of
Option Nothing -> t
Option (Just d') ->
let (tr,sty) = untangle d'
in Node (DStyle sty) [Node (DTransform tr) [t]]
)

-- Internal a-annotations.
(\a t -> Node (DAnnot a) [t])
qd

-- | Convert a @DTree@ to an @RTree@ which can be used dirctly by backends.
-- A @DTree@ includes nodes of type @DTransform (Transformation v)@;
-- in the @RTree@ transform is pushed down until it reaches a primitive node.
fromDTree :: forall b v n. (Floating n, HasLinearMap v)
=> DTree b v n Annotation -> RTree b v n Annotation
fromDTree = fromDTree' mempty
foldDiaWithScales
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think this (and the primed version below) needs a Haddock comment.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Sure. I'm still debating whether or not to export them (I'm currently not).

:: (HasLinearMap v, Floating n, Typeable n, M.Monoid r)
=> (Style v n -> Prim b v n -> r)
-> (Annotation b v n -> r -> r)
-> n -- 'global' to 'output' scale factor
-> n -- 'normalised' to 'output' scale factor
-> QDiagram b v n m -- ^ diagram to fold
-> r
foldDiaWithScales primF aF g n (QD dual) = foldDUAL lF aF dual
where
fromDTree' :: HasLinearMap v => Transformation v n -> DTree b v n Annotation -> RTree b v n Annotation
-- We put the accumulated transformation (accTr) and the prim
-- into an RPrim node.
fromDTree' accTr (Node (DPrim p) _)
= Node (RPrim (transform accTr p)) []

-- Styles are transformed then stored in their own node
-- and accTr is push down the tree.
fromDTree' accTr (Node (DStyle s) ts)
= Node (RStyle (transform accTr s)) (fmap (fromDTree' accTr) ts)

-- Transformations are accumulated and pushed down as well.
fromDTree' accTr (Node (DTransform tr) ts)
= Node REmpty (fmap (fromDTree' (accTr <> tr)) ts)

fromDTree' accTr (Node (DAnnot a) ts)
= Node (RAnnot a) (fmap (fromDTree' accTr) ts)

-- Drop accumulated transformations upon encountering a DDelay
-- node --- the tree unfolded beneath it already took into account
-- any transformation at this point.
fromDTree' _ (Node DDelay ts)
= Node REmpty (fmap (fromDTree' mempty) ts)

-- DEmpty nodes become REmpties, again accTr flows through.
fromDTree' accTr (Node _ ts)
= Node REmpty (fmap (fromDTree' accTr) ts)

-- | Compile a @QDiagram@ into an 'RTree', rewriting styles with the
-- given function along the way. Suitable for use by backends when
-- implementing 'renderData'. The first argument is the
-- transformation used to convert the diagram from local to output
-- units.
toRTree
:: (HasLinearMap v, Metric v, Typeable1 v, Typeable n,
OrderedField n, Monoid m, Semigroup m)
=> Transformation v n -> QDiagram b v n m -> RTree b v n Annotation
toRTree globalToOutput d
= (fmap . onRStyle) (unmeasureAttrs gToO nToO)
. fromDTree
. fromMaybe (Node DEmpty [])
. toDTree gToO nToO
$ d
lF d = \case
PrimLeaf p ->
let (tr, sty) = untangle d
in primF (unmeasureAttrs g n sty) (transform tr p)
DelayedLeaf f ->
let (QD dia) = f d g n
in foldDUAL lF aF dia

foldDiaWithScales'
:: (HasLinearMap v, Metric v, OrderedField n, Typeable n, Monoid' m, M.Monoid r)
=> (Style v n -> Prim b v n -> r)
-> (Annotation b v n -> r -> r)
-> (Style v n -> r -> r)
-> n
-> n
-> QDiagram b v n m -- ^ diagram to fold
-> r
foldDiaWithScales' primF aF styF g n (QD dual) = foldDUAL' lF aF mkP styF dual
where
gToO = avgScale globalToOutput

-- Scaling factor from normalized units to output units: nth root
-- of product of diameters along each basis direction. Note at
-- this point the diagram has already had the globalToOutput
-- transformation applied, so output = global = local units.
nToO = product (map (`diameter` d) basis) ** (1 / fromIntegral (dimension d))

-- | Apply a style transformation on 'RStyle' nodes; the identity for
-- other 'RNode's.
onRStyle :: (Style v n -> Style v n) -> RNode b v n a -> RNode b v n a
onRStyle f (RStyle s) = RStyle (f s)
onRStyle _ n = n
lF d = \case
PrimLeaf p ->
let (tr, sty) = untangle d
in primF (unmeasureAttrs g n sty) (transform tr p)
DelayedLeaf f ->
let (QD dia) = f d g n
in foldDUAL' lF aF mkP styF dia

-- The partial sty needs the total transform accumilated so far, but
-- ignores any style before.
mkP d w = transform t (unmeasureAttrs g n sty)
where t = killR d
(_, sty) = untangle w

-- | Simple way to fold a diagram into a monoidal result.
foldDia
:: (HasLinearMap v, Metric v, OrderedField n, Typeable n, Monoid' m, M.Monoid r)
=> (Style v n -> Prim b v n -> r) -- ^ Fold a prim
-> (Annotation b v n -> r -> r) -- ^ Apply an annotation
-> Transformation v n -- ^ final transform for diagram
-> QDiagram b v n m -- ^ diagram to fold
-> r
foldDia primF annF t d = foldDiaWithScales primF annF g n d
where
g = avgScale t
n = normalizedFactor (size d)

-- | Fold a diagram into a monoidal result. Similar to 'foldDia' but
-- gives access to the style when it's higher up the tree. This is
-- useful for things like clipping where you want to use the same
-- clipping for everything below that point. This is reset after each
-- group and given as the second argument in the prim rendering
-- function.
foldDia'
:: (HasLinearMap v, Metric v, OrderedField n, Typeable n, Monoid' m, M.Monoid r)
=> (Style v n -> Prim b v n -> r)
-> (Annotation b v n -> r -> r)
-> (Style v n -> r -> r)
-> Transformation v n
-> QDiagram b v n m -- ^ diagram to fold
-> r
foldDia' primF annF styF t d = foldDiaWithScales' primF annF styF g n d
where
g = avgScale t
n = normalizedFactor (size d)

--------------------------------------------------
-- | Get the normalized scale factor from a vector. For the
-- 'normalizedFactor' of a diagram use this with the 'size' of the
-- diagram.
--
-- Note: The 'global' factor is the 'avgScale' of the output
-- transform.
normalizedFactor :: (F.Foldable v, Floating n) => v n -> n
normalizedFactor v = F.product v ** (1 / fromIntegral (lengthOf folded v))

-- | Render a diagram, returning also the transformation which was
-- used to convert the diagram from its (\"global\") coordinate
Expand All @@ -186,7 +142,7 @@ renderDiaT
:: (Backend b v n , HasLinearMap v, Metric v, Typeable1 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 opts d = (g2o, renderRTree b opts' . toRTree g2o $ d')
renderDiaT b opts d = (g2o, renderDUAL b opts' g2o d')
where (opts', g2o, d') = adjustDia b opts d

-- | Render a diagram.
Expand Down
Loading