diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 94822fad..aa77b266 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -307,6 +307,8 @@ but that doesn't take into account the fact that some of the v's are inside Points and hence ought to be translated. -} +instance HasLinearMap v => IsPrim (Path v) + instance (InnerSpace v, OrderedField (Scalar v)) => Enveloped (Path v) where getEnvelope = F.foldMap trailEnvelope . pathTrails -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 8042f237..1a0d6a42 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -39,6 +39,8 @@ type instance V Ellipsoid = R3 instance Transformable Ellipsoid where transform t1 (Ellipsoid t2) = Ellipsoid (t1 <> t2) +instance IsPrim Ellipsoid + instance Renderable Ellipsoid NullBackend where render _ _ = mempty diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs index 467fbf0e..85263677 100644 --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -43,6 +43,8 @@ type instance V Image = R2 instance Transformable Image where transform t1 (Image file sz t2) = Image file sz (t1 <> t2) +instance IsPrim Image + instance HasOrigin Image where moveOriginTo p = translate (origin .-. p) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 57f6ddda..9f9307b8 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -58,6 +58,8 @@ type instance V Text = R2 instance Transformable Text where transform t (Text tt a s) = Text (t <> tt) a s +instance IsPrim Text + instance HasOrigin Text where moveOriginTo p = translate (origin .-. p) diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index b4ee3d77..6899481b 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE FlexibleContexts - , FlexibleInstances - , TypeFamilies - , ViewPatterns - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Transform @@ -46,28 +46,28 @@ module Diagrams.TwoD.Transform , shearingY, shearY -- * Scale invariance - , ScaleInv(..), scaleInv + , ScaleInv(..), scaleInv, scaleInvPrim -- * component-wise , onBasis ) where -import Diagrams.Core +import Diagrams.Core import qualified Diagrams.Core.Transform as T -import Control.Newtype (over) +import Control.Newtype (over) -import Diagrams.Coordinates -import Diagrams.Transform -import Diagrams.TwoD.Size (width, height) -import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction) +import Diagrams.Coordinates +import Diagrams.Transform +import Diagrams.TwoD.Size (height, width) +import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector (direction) -import Data.Semigroup +import Data.Semigroup -import Data.AffineSpace +import Data.AffineSpace -import Control.Arrow (first, second) +import Control.Arrow (first, second) -- Rotation ------------------------------------------------ @@ -251,9 +251,6 @@ shearY = transform . shearingY -- Scale invariance ---------------------------------------- --- XXX what about freezing? Doesn't interact with ScaleInv the way it --- ought. - -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ -- objects. Intuitively, a scale-invariant object is affected by -- transformations like translations and rotations, but not by scales. @@ -287,7 +284,7 @@ shearY = transform . shearingY data ScaleInv t = ScaleInv - { unScaleInv :: t + { unScaleInv :: t , scaleInvDir :: R2 , scaleInvLoc :: P2 } @@ -312,6 +309,39 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where l' = transform tr l trans = translate (l' .-. l) +-- This is how we handle freezing properly with ScaleInv wrappers. +-- Normal transformations are applied ignoring scaling; "frozen" +-- transformations (i.e. transformations applied after a freeze) are +-- applied directly to the underlying object, scales and all. We must +-- take care to transform the reference point and direction vector +-- appropriately. +instance (V t ~ R2, Transformable t) => IsPrim (ScaleInv t) where + transformWithFreeze t1 t2 s = ScaleInv t'' d'' origin'' + where + -- first, apply t2 normally, i.e. ignoring scaling + s'@(ScaleInv t' _ _) = transform t2 s + + -- now apply t1 to get the new direction and origin + (ScaleInv _ d'' origin'') = transform t1 s' + + -- but apply t1 directly to the underlying thing, scales and all. + t'' = transform t1 t' + +instance (Renderable t b, V t ~ R2) => Renderable (ScaleInv t) b where + render b = render b . unScaleInv + +-- | Create a diagram from a single scale-invariant primitive, which +-- will have an /empty/ envelope, trace, and query. The reason is +-- that the envelope, trace, and query cannot be cached---applying a +-- transformation would cause the cached envelope, etc. to get "out +-- of sync" with the scale-invariant object. The intention, at any +-- rate, is that scale-invariant things will be used only as +-- "decorations" (/e.g./ arrowheads) which should not affect the +-- envelope, trace, and query. +scaleInvPrim :: (Transformable t, Renderable t b, V t ~ R2, Monoid m) + => t -> R2 -> QDiagram b R2 m +scaleInvPrim t d = mkQD (Prim $ scaleInv t d) mempty mempty mempty mempty + -- | Get the matrix equivalent of the linear transform, -- (as a pair of columns) and the translation vector. This -- is mostly useful for implementing backends.