diff --git a/CHANGES.markdown b/CHANGES.markdown --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,72 @@ +1.1 (8 March 2014) +------------------ + +* **New features** + + - Support for `Deformation`s, arbitrary (non-affine) + transformations on objects such as points, paths, and located + trails (though not on diagrams). + + - New functions `clipTo`, which clips a diagram's envelope and + trace along with its visual representation, and `clipped`, which + clips the diagram's visual representation but replaces its + envelope and trace with those of the clipping path. + + - New `arrowV` function, for creating an arrow with the direction + and magnitude of a given vector. + + - `gap` traversal, for setting the head and tail gaps of an arrow + simultaneously. + + - Generalized types for `centerXY` and `snugXY`, based on new + `basis` function from `diagrams-core + + - New 3D `Transform`s, alignment, and 3D-specific `Prelude`. + + - New `frame` function similar to `pad`, but increases the envelope + of a diagram by an amount specified in local units in every direction + irrespective of the local origin. + + - New `splitFills` function for pushing fill attributes down to + subtrees containing only loops (mostly of relevance only to + backend implementors). + +* **New instances** + + - `Typeable` instances for all data types that are used as diagram + primitives. + - `Sectionable` instance for `FixedSegment`. + +* **API changes** + + - `Angle` is now a type, rather than a class. It uses a single + internal representation for angles, and lenses `turn`, `rad,` + and `deg` are supplied for constructing (using `@@`) and viewing + (using `^.`) `Angle`s in various units. In addition, the `Num` + instance for `Angle` has been removed, eliminating a class of + errors where a bare number is interpreted in units other than + what you expect. + + - Removed `Num` instance for angles. + +* **Dependency/version changes** + + - Require `lens >= 4.0`. + - Allow `array-0.5`. + - Allow `hashable-1.1`. + - Remove `NumInstances` dependency. + +* **Bug fixes** + + - Exclude joins in offsets on close segments (#160). + - Exclude extra segment when joining loops in offset (#155). + +* **Performance improvements** + + - `colorToSRGBA` function now avoids expensive matrix operations, + offering dramatic speedups in rendering diagrams with many color + attributes. + 1.0.1 (26 January 2014) ----------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,8 @@ -Copyright (c) 2011-2013 diagrams-lib team: +Copyright (c) 2011-2014 diagrams-lib team: Jan Bracker Daniel Bergey + Denys Duchier Daniil Frumin Niklas Haas Peter Hall diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 1.0.1 +Version: 1.1 Synopsis: Embedded domain-specific language for declarative graphics Description: Diagrams is a flexible, extensible EDSL for creating graphics of many types. Graphics can be created @@ -19,17 +19,19 @@ Cabal-version: >=1.10 Extra-source-files: CHANGES.markdown, README.markdown, diagrams/*.svg Extra-doc-files: diagrams/*.svg -Tested-with: GHC == 7.4.2, GHC == 7.6.1 +Tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.1 Source-repository head type: git location: http://github.com/diagrams/diagrams-lib.git Library Exposed-modules: Diagrams.Prelude, + Diagrams.Prelude.ThreeD, Diagrams.Align, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, + Diagrams.Attributes.Compile, Diagrams.Points, Diagrams.Located, Diagrams.Parametric, @@ -43,6 +45,7 @@ Diagrams.Solve, Diagrams.Tangent, Diagrams.Transform, + Diagrams.Deform Diagrams.BoundingBox, Diagrams.Names, Diagrams.Envelope, @@ -54,6 +57,7 @@ Diagrams.TwoD.Arrow, Diagrams.TwoD.Arrowheads, Diagrams.TwoD.Combinators, + Diagrams.TwoD.Deform, Diagrams.TwoD.Transform, Diagrams.TwoD.Transform.ScaleInv, Diagrams.TwoD.Ellipse, @@ -70,13 +74,15 @@ Diagrams.TwoD.Text, Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, - Diagrams.ThreeD.Types, - Diagrams.ThreeD.Shapes, - Diagrams.ThreeD.Vector, - Diagrams.ThreeD.Transform, + Diagrams.ThreeD.Align, Diagrams.ThreeD.Camera, + Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, - Diagrams.ThreeD + Diagrams.ThreeD.Shapes, + Diagrams.ThreeD.Transform, + Diagrams.ThreeD.Types, + Diagrams.ThreeD.Vector, + Diagrams.ThreeD, Diagrams.Animation, Diagrams.Animation.Active, Diagrams.Util, @@ -84,21 +90,20 @@ Diagrams.Backend.CmdLine Build-depends: base >= 4.2 && < 4.8, containers >= 0.3 && < 0.6, - array >= 0.3 && < 0.5, + array >= 0.3 && < 0.6, semigroups >= 0.3.4 && < 0.13, monoid-extras >= 0.3 && < 0.4, - diagrams-core >= 1.0 && < 1.1, + diagrams-core >= 1.1 && < 1.2, active >= 0.1 && < 0.2, vector-space >= 0.7.7 && < 0.9, vector-space-points >= 0.1.2 && < 0.2, MemoTrie >= 0.6 && < 0.7, - NumInstances >= 1.2 && < 1.4, colour >= 2.3.2 && < 2.4, data-default-class < 0.1, pretty >= 1.0.1.2 && < 1.2, fingertree >= 0.1 && < 0.2, intervals >= 0.3 && < 0.5, - lens >= 3.9 && < 3.11, + lens >= 4.0 && < 4.1, tagged >= 0.7, optparse-applicative >= 0.7 && < 0.8, filepath, diff --git a/src/Diagrams/Align.hs b/src/Diagrams/Align.hs --- a/src/Diagrams/Align.hs +++ b/src/Diagrams/Align.hs @@ -29,13 +29,14 @@ , align , snug - , center + , centerV, center , snugBy - , snugCenter + , snugCenterV, snugCenter ) where import Diagrams.Core +import Diagrams.Util (applyAll) import Data.AffineSpace (alerp, (.-.)) import Data.VectorSpace @@ -140,15 +141,28 @@ => V a -> a -> a snug v = snugBy v 1 --- | @center v@ centers an enveloped object along the direction of +-- | @centerV v@ centers an enveloped object along the direction of -- @v@. -center :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) +centerV :: ( Alignable a, HasOrigin a, Num (Scalar (V a)) , Fractional (Scalar (V a))) => V a -> a -> a -center v = alignBy v 0 +centerV v = alignBy v 0 --- | Like @center@ using trace. -snugCenter +-- | @center@ centers an enveloped object along all of its basis vectors. +center :: ( HasLinearMap (V a), Alignable a, HasOrigin a, Num (Scalar (V a)), + Fractional (Scalar (V a))) => a -> a +center d = applyAll fs d + where + fs = map centerV basis + +-- | Like @centerV@ using trace. +snugCenterV :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a) => V a -> a -> a -snugCenter v = (alignBy' traceBoundary) v 0 +snugCenterV v = (alignBy' traceBoundary) v 0 +-- | Like @center@ using trace. +snugCenter :: ( HasLinearMap (V a), Alignable a, HasOrigin a, Num (Scalar (V a)), + Fractional (Scalar (V a)), Traced a) => a -> a +snugCenter d = applyAll fs d + where + fs = map snugCenterV basis diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs --- a/src/Diagrams/Attributes.hs +++ b/src/Diagrams/Attributes.hs @@ -1,6 +1,8 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.Attributes @@ -37,7 +39,7 @@ , Opacity, getOpacity, opacity -- ** Converting colors - , toRGBAUsingSpace, colorToSRGBA, colorToRGBA + , colorToSRGBA, colorToRGBA -- * Lines -- ** Width @@ -55,20 +57,28 @@ -- ** Dashing , Dashing(..), DashingA, getDashing, dashing + -- * Compilation utilities + , splitFills + ) where -import Control.Lens (Setter, sets) +import Control.Lens (Setter, sets) import Data.Colour -import Data.Colour.RGBSpace -import Data.Colour.SRGB (sRGBSpace) +import Data.Colour.RGBSpace (RGB (..)) +import Data.Colour.SRGB (toSRGB) import Data.Default.Class -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid.Recommend import Data.Semigroup import Data.Typeable +import Diagrams.Attributes.Compile import Diagrams.Core -import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Types (RTree) +import Diagrams.Located (unLoc) +import Diagrams.Path (Path, pathTrails) +import Diagrams.Trail (isLoop) ------------------------------------------------------------ -- Color ------------------------------------------------- @@ -226,20 +236,14 @@ toAlphaColour (FillColor c) = toAlphaColour . getLast . getRecommend $ c fromAlphaColour = FillColor . Commit . Last . fromAlphaColour --- | Convert to an RGB space while preserving the alpha channel. -toRGBAUsingSpace :: Color c => RGBSpace Double -> c - -> (Double, Double, Double, Double) -toRGBAUsingSpace s col = (r,g,b,a) - where c' = toAlphaColour col - c = toRGBUsingSpace s (alphaToColour c') - a = alphaChannel c' - r = channelRed c - g = channelGreen c - b = channelBlue c - -- | Convert to sRGBA. colorToSRGBA, colorToRGBA :: Color c => c -> (Double, Double, Double, Double) -colorToSRGBA = toRGBAUsingSpace sRGBSpace +colorToSRGBA col = (r, g, b, a) + where + c' = toAlphaColour col + c = alphaToColour c' + a = alphaChannel c' + RGB r g b = toSRGB c colorToRGBA = colorToSRGBA {-# DEPRECATED colorToRGBA "Renamed to colorToSRGBA." #-} @@ -396,3 +400,22 @@ -- stroke should start. -> a -> a dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) + +------------------------------------------------------------ + +data FillLoops v = FillLoops + +instance Typeable v => SplitAttribute (FillLoops v) where + type AttrType (FillLoops v) = FillColor + type PrimType (FillLoops v) = Path v + + primOK _ = all (isLoop . unLoc) . pathTrails + +-- | Push fill attributes down until they are at the root of subtrees +-- containing only loops. This makes life much easier for backends, +-- which typically have a semantics where fill attributes are +-- applied to lines/non-closed paths as well as loops/closed paths, +-- whereas in the semantics of diagrams, fill attributes only apply +-- to loops. +splitFills :: forall b v a. Typeable v => RTree b v a -> RTree b v a +splitFills = splitAttr (FillLoops :: FillLoops v) diff --git a/src/Diagrams/Attributes/Compile.hs b/src/Diagrams/Attributes/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Attributes/Compile.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Attributes.Compile +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- XXX +-- +----------------------------------------------------------------------------- + +module Diagrams.Attributes.Compile ( + SplitAttribute(..), splitAttr + ) where + +import Data.Typeable + +import Control.Arrow (second) +import Control.Lens ((%~), (&), _Wrapping') +import qualified Data.Map as M +import Data.Semigroup ((<>)) +import Data.Tree (Tree (..)) + +import Diagrams.Core +import Diagrams.Core.Style (Style (..), attrToStyle) +import Diagrams.Core.Types (RNode (..), RTree) + +------------------------------------------------------------ + +-- This is a sort of roundabout, overly-general way to define +-- splitFills; it's done this way to facilitate testing. + +class (AttributeClass (AttrType code), Typeable (PrimType code)) => SplitAttribute code where + type AttrType code :: * + type PrimType code :: * + + primOK :: code -> PrimType code -> Bool + +-- | Push certain attributes down until they are at the roots of trees +-- containing only "safe" nodes. In particular this is used to push +-- fill attributes down until they are over only loops; see +-- 'splitFills'. +splitAttr :: forall code b v a. SplitAttribute code => code -> RTree b v a -> RTree b v a +splitAttr code = fst . splitAttr' Nothing + where + + -- splitAttr' is where the most interesting logic happens. + -- Mutually recursive with splitAttr'Forest. rebuildNode and + -- applyMfc are helper functions. + -- + -- Input: attribute to apply to "safe" subtrees. + -- + -- Output: tree with attributes pushed down appropriately, and + -- a Bool indicating whether the tree contains only "safe" prims (True) or + -- contains some unsafe ones (False). + splitAttr' :: Maybe (AttrType code) -> RTree b v a -> (RTree b v a, Bool) + + -- RStyle node: Check for the special attribute, and split it out of + -- the style, combining it with the incoming attribute. Recurse and + -- rebuild. The tricky bit is that we use some knot-tying to + -- determine the right attribute to pass down to the subtrees based + -- on this computed Bool: if all subtrees are safe, then we will + -- apply the attribute at the root of this tree, and pass Nothing to + -- all the subtrees. Otherwise, we pass the given attribute along. + -- This works out because the attribute does not need to be + -- pattern-matched until actually applying it at some root, so the + -- recursion can proceed and the Bool values be computed with the + -- actual value of the attributes nodes filled in lazily. + splitAttr' mattr (Node (RStyle sty) cs) = (t', ok) + where + mattr' = mattr <> getAttr sty + sty' = sty & _Wrapping' Style %~ M.delete ty + ty = show . typeOf $ (undefined :: AttrType code) + (cs', ok) = splitAttr'Forest mattr' cs + t' | ok = rebuildNode Nothing ok (RStyle sty) cs' + | otherwise = rebuildNode mattr ok (RStyle sty') cs' + + -- RPrim node: check whether it + -- * is some sort of prim not under consideration: don't apply the attribute; return True + -- * is unsafe: don't apply the attribute; return False + -- * is safe : do apply the attribute; return True + splitAttr' mattr (Node rp@(RPrim _ (Prim prm)) _) = + case cast prm :: Maybe (PrimType code) of + Nothing -> (Node rp [], True) + Just p -> + case primOK code p of + True -> (rebuildNode mattr True rp [], True) + False -> (Node rp [], False) + + -- RFrozenTr, RAnnot, REmpty cases: just recurse and rebuild. Note + -- we assume that transformations do not affect the attributes. + splitAttr' mattr (Node nd cs) = (t', ok) + where + (cs', ok) = splitAttr'Forest mattr cs + t' = rebuildNode mattr ok nd cs' + + -- Recursively call splitAttr' on all subtrees, returning the + -- logical AND of the Bool results returned (the whole forest is + -- safe iff all subtrees are). + splitAttr'Forest :: Maybe (AttrType code) -> [RTree b v a] -> ([RTree b v a], Bool) + splitAttr'Forest mattr cs = (cs', ok) + where + (cs', ok) = second and . unzip . map (splitAttr' mattr) $ cs + + -- Given a fill attribute, a Bool indicating whether the given + -- subforest contains only loops, a node, and a subforest, rebuild a + -- tree, applying the fill attribute as appropriate (only if the + -- Bool is true and the attribute is not Nothing). + rebuildNode :: Maybe (AttrType code) -> Bool -> RNode b v a -> [RTree b v a] -> RTree b v a + rebuildNode mattr ok nd cs + | ok = applyMattr mattr (Node nd cs) + | otherwise = Node nd cs + + -- Prepend a new fill color node if Just; the identity function if + -- Nothing. + applyMattr :: Maybe (AttrType code) -> RTree b v a -> RTree b v a + applyMattr Nothing t = t + applyMattr (Just a) t = Node (RStyle $ attrToStyle a) [t] diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -20,7 +20,7 @@ withEnvelope, withTrace , phantom, strut - , pad + , pad, frame , extrudeEnvelope, intrudeEnvelope -- * Binary operations @@ -37,8 +37,11 @@ ) where -import Control.Lens ( (&), (%~), (.~), Lens', makeLensesWith - , lensRules, lensField, generateSignatures, unwrapping) +import Data.Typeable + +import Control.Lens (Lens', generateSignatures, lensField, + lensRules, makeLensesWith, (%~), (&), (.~), + (^.), _Wrapping) import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class @@ -82,7 +85,7 @@ -- | @phantom x@ produces a \"phantom\" diagram, which has the same -- envelope and trace as @x@ but produces no output. -phantom :: (Backend b (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m +phantom :: (Backend b (V a), Typeable (V a), Enveloped a, Traced a, Monoid' m) => a -> QDiagram b (V a) m phantom a = mkQD nullPrim (getEnvelope a) (getTrace a) mempty mempty -- | @pad s@ \"pads\" a diagram, expanding its envelope by a factor of @@ -97,6 +100,16 @@ => Scalar v -> QDiagram b v m -> QDiagram b v m pad s d = withEnvelope (d # scale s) d +-- | @frame s@ increases the envelope of a diagram by and absolute amount @s@, +-- s is in the local units of the diagram. This function is similar to @pad@, +-- only it takes an absolute quantity and pre-centering should not be +-- necessary. +frame :: ( Backend b v, InnerSpace v, OrderedField (Scalar v), Monoid' m) + => Scalar v -> QDiagram b v m -> QDiagram b v m +frame s d = setEnvelope (onEnvelope t (d^.envelope)) d + where + t f = \x -> f x + s + -- | @strut v@ is a diagram which produces no output, but with respect -- to alignment and envelope acts like a 1-dimensional segment -- oriented along the vector @v@, with local origin at its @@ -108,7 +121,8 @@ -- <> -- -- > strutEx = (circle 1 ||| strut unitX ||| circle 1) # centerXY # pad 1.1 -strut :: ( Backend b v, InnerSpace v +strut :: ( Backend b v, Typeable v + , InnerSpace v , OrderedField (Scalar v) , Monoid' m ) @@ -156,10 +170,10 @@ :: ( Ord (Scalar v), Num (Scalar v), AdditiveGroup (Scalar v) , Floating (Scalar v), HasLinearMap v, InnerSpace v, Monoid' m ) => (Scalar v) -> v -> QDiagram b v m -> QDiagram b v m -deformEnvelope s v d = setEnvelope (getEnvelope d & unwrapping Envelope %~ deform) d +deformEnvelope s v d = setEnvelope (getEnvelope d & _Wrapping Envelope %~ deformE) d where - deform = Option . fmap deform' . getOption - deform' env v' + deformE = Option . fmap deformE' . getOption + deformE' env v' | dot > 0 = Max $ getMax (env v') + (dot * s) / magnitude v' | otherwise = env v' where @@ -360,9 +374,9 @@ -- default is 0. -- -- 'CatOpts' is an instance of 'Default', so 'with' may be used for --- the second argument, as in @cat' (1,2) with {sep = 2}@. +-- the second argument, as in @cat' (1,2) (with & sep .~ 2)@. -- --- Note that @cat' v with {catMethod = Distrib} === mconcat@ +-- Note that @cat' v (with & catMethod .~ Distrib) === mconcat@ -- (distributing with a separation of 0 is the same as -- superimposing). cat' :: ( Juxtaposable a, Monoid' a, HasOrigin a diff --git a/src/Diagrams/CubicSpline.hs b/src/Diagrams/CubicSpline.hs --- a/src/Diagrams/CubicSpline.hs +++ b/src/Diagrams/CubicSpline.hs @@ -31,9 +31,6 @@ import Diagrams.Trail import Diagrams.TrailLike (TrailLike (..)) --- for e.g. the Fractional (Double, Double) instance -import Data.NumInstances.Tuple () - import Data.AffineSpace.Point import Data.VectorSpace diff --git a/src/Diagrams/Deform.hs b/src/Diagrams/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Deform.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} + +module Diagrams.Deform (Deformation(..), Deformable(..), asDeformation) where + +import Control.Lens (under, _Unwrapped) +import Data.AffineSpace +import Data.Basis +import Data.MemoTrie +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.VectorSpace + +import Diagrams.Core +import Diagrams.Located +import Diagrams.Parametric +import Diagrams.Path +import Diagrams.Segment +import Diagrams.Trail + +------------------------------------------------------------ +-- Deformations + +-- | @Deformations@ are a superset of the affine transformations +-- represented by the 'Transformation' type. In general they are not +-- invertable. @Deformation@s include projective transformations. +-- @Deformation@ can represent other functions from points to points +-- which are "well-behaved", in that they do not introduce small wiggles. +data Deformation v = Deformation (Point v -> Point v) + +instance Semigroup (Deformation v) where + (Deformation p1) <> (Deformation p2) = Deformation (p1 . p2) + +instance Monoid (Deformation v) where + mappend = (<>) + mempty = Deformation id + +class Deformable a where + -- | @deform' epsilon d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, approximate + -- to accuracy @epsilon@. + deform' :: Scalar (V a) -> Deformation (V a) -> a -> a + + -- | @deform d a@ transforms @a@ by the deformation @d@. + -- If the type of @a@ is not closed under projection, @deform@ + -- should call @deform'@ with some reasonable default value of + -- @epsilon@. + deform :: Deformation (V a) -> a -> a + +-- | @asDeformation@ converts a 'Transformation' to a 'Deformation' by +-- discarding the inverse transform. This allows reusing +-- @Transformation@s in the construction of @Deformation@s. +asDeformation + :: ( HasTrie (Basis v), HasBasis v) => Transformation v -> Deformation v +asDeformation t = Deformation f' where + f' = papply t + +------------------------------------------------------------ +-- Instances + +instance Deformable (Point v) where + deform' = const deform + deform (Deformation l) = l + +-- | Cubic curves are not closed under perspective projections. +-- Therefore @Segment@s are not an instance of Deformable. However, +-- the deformation of a @Segment@ can be approximated to arbitrary +-- precision by a series of @Segment@s. @deformSegment@ does this, +-- which allows types built from lists of @Segment@s to themselves be +-- @Deformable@. +deformSegment :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Deformation v -> FixedSegment v -> [FixedSegment v] +deformSegment epsilon t s + | goodEnough epsilon t s = [approx t s] + | otherwise = concatMap (deformSegment epsilon t) [s1, s2] + where + (s1, s2) = splitAtParam s 0.5 + +approx :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + Deformation v -> FixedSegment v -> FixedSegment v +approx t (FLinear p0 p1) = FLinear (deform t p0) (deform t p1) +approx t (FCubic p0 c1 c2 p1) = FCubic (f p0) (f c1) (f c2) (f p1) where + f = deform t + +goodEnough :: (VectorSpace v, InnerSpace v, s ~ Scalar v, Ord s, Fractional s, Floating s) => + s -> Deformation v -> FixedSegment v -> Bool +goodEnough e t s = + all (< e) [magnitude $ deform t (s `atParam` u) .-. approx t s `atParam` u + | u <- [0.25, 0.5, 0.75]] + +instance (VectorSpace v, InnerSpace v, + s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => + Deformable (Located (Trail v)) where + deform' eps p t + | isLine $ unLoc t = line `at` p0 + | otherwise = glueTrail line `at` p0 + where + segs = concatMap (deformSegment eps p) $ fixTrail t + p0 = case segs of + (FLinear start _:_) -> start + (FCubic start _ _ _:_) -> start + _ -> loc t -- default in case of empty trail + line = trailFromSegments $ map (unLoc . fromFixedSeg) segs + deform p t = deform' (0.01 * extent) p t where + -- estimate the "size" of the Trail' as + -- the maximum distance to any vertex + extent = maximum . map dist . trailVertices $ t + dist pt = magnitude $ pt .-. loc t + +instance (VectorSpace v, InnerSpace v, + s ~ Scalar v, Ord s, Fractional s, Floating s, Show s, Show v) => + Deformable (Path v) where + deform' eps p = under _Unwrapped $ map (deform' eps p) + deform p = under _Unwrapped $ map (deform p) diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -57,6 +58,8 @@ ) where +import Data.Typeable + import Diagrams.Align import Diagrams.Core import Diagrams.Core.Points () @@ -68,8 +71,8 @@ import Diagrams.Transform import Control.Arrow ((***)) -import Control.Lens ( Wrapped(..), mapped, over, view, iso - , unwrapped, wrapped, (%~), op) +import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, + over, view, (%~), _Unwrapped', _Wrapped) import Data.AffineSpace import qualified Data.Foldable as F import Data.List (partition) @@ -85,11 +88,14 @@ -- and they form a monoid under /superposition/ (placing one path on -- top of another) rather than concatenation. newtype Path v = Path [Located (Trail v)] - deriving (Semigroup, Monoid) + deriving (Semigroup, Monoid, Typeable) -instance Wrapped [Located (Trail v)] [Located (Trail v')] (Path v) (Path v') - where wrapped = iso Path $ \(Path x) -> x +instance Wrapped (Path v) where + type Unwrapped (Path v) = [Located (Trail v)] + _Wrapped' = iso (\(Path x) -> x) Path +instance Rewrapped (Path v) (Path v') + -- | Extract the located trails making up a 'Path'. pathTrails :: Path v -> [Located (Trail v)] pathTrails = op Path @@ -101,7 +107,7 @@ type instance V (Path v) = v instance VectorSpace v => HasOrigin (Path v) where - moveOriginTo = over unwrapped . map . moveOriginTo + moveOriginTo = over _Wrapped' . map . moveOriginTo --moveOriginTo = over pathTrails . map . moveOriginTo -- | Paths are trail-like; a trail can be used to construct a @@ -112,7 +118,7 @@ -- See Note [Transforming paths] instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) => Transformable (Path v) where - transform = over unwrapped . map . transform + transform = over _Wrapped . map . transform {- ~~~~ Note [Transforming paths] @@ -196,7 +202,7 @@ -- the first containing all the trails for which the predicate returns -- @True@, and the second containing the remaining trails. partitionPath :: (Located (Trail v) -> Bool) -> Path v -> (Path v, Path v) -partitionPath p = (view wrapped *** view wrapped) . partition p . op Path +partitionPath p = (view _Unwrapped' *** view _Unwrapped') . partition p . op Path ------------------------------------------------------------ -- Modifying paths --------------------------------------- @@ -210,4 +216,4 @@ -- | Reverse all the component trails of a path. reversePath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Path v -reversePath = unwrapped . mapped %~ reverseLocTrail +reversePath = _Wrapped . mapped %~ reverseLocTrail diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -61,6 +61,10 @@ -- conjugation of transformations. , module Diagrams.Transform + -- | Projective transformations and other deformations + -- lacking an inverse. + , module Diagrams.Deform + -- | Giving names to subdiagrams and later retrieving -- subdiagrams by name. , module Diagrams.Names @@ -124,6 +128,7 @@ import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline +import Diagrams.Deform import Diagrams.Envelope import Diagrams.Located import Diagrams.Names diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Prelude.ThreeD +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- A module to re-export most of the functionality of the diagrams +-- core and standard library, including 3D types and functions. +-- +----------------------------------------------------------------------------- + +module Diagrams.Prelude.ThreeD + ( + -- * Core library + -- | The core definitions of transformations, diagrams, + -- backends, and so on. + module Diagrams.Core + + -- * Standard library + + -- | Attributes (color, line style, etc.) and styles. + , module Diagrams.Attributes + + -- | Alignment of diagrams relative to their envelopes. + , module Diagrams.Align + + -- | Combining multiple diagrams into one. + , module Diagrams.Combinators + + -- | Giving concrete locations to translation-invariant things. + , module Diagrams.Located + + -- | Linear and cubic bezier segments. + , module Diagrams.Segment + + -- | Trails. + , module Diagrams.Trail + + -- | Parametrization of segments and trails. + , module Diagrams.Parametric + + -- | Adjusting the length of parameterized objects. + , module Diagrams.Parametric.Adjust + + -- | Computing tangent and normal vectors of segments and + -- trails. + , module Diagrams.Tangent + + -- | Trail-like things. + , module Diagrams.TrailLike + + -- | Paths. + , module Diagrams.Path + + -- | Cubic splines. + , module Diagrams.CubicSpline + + -- | Some additional transformation-related functions, like + -- conjugation of transformations. + , module Diagrams.Transform + + -- | Giving names to subdiagrams and later retrieving + -- subdiagrams by name. + , module Diagrams.Names + + -- | Envelopes, aka functional bounding regions. + , module Diagrams.Envelope + + -- | Traces, aka embedded raytracers, for finding points on + -- the boundary of a diagram. + , module Diagrams.Trace + + -- | A query is a function that maps points in a vector space + -- to values in some monoid; they can be used to annotate + -- the points of a diagram with some values. + , module Diagrams.Query + + -- | Utilities for working with points. + , module Diagrams.Points + + -- | Convenience infix operators for working with coordinates. + , module Diagrams.Coordinates + + -- | things (shapes, transformations, combinators) specific + -- to creating three-dimensional diagrams. + , module Diagrams.ThreeD + + -- | Tools for making animations. + , module Diagrams.Animation + + -- | Various utility definitions. + , module Diagrams.Util + + -- * Convenience re-exports + -- | For representing and operating on colors. + , module Data.Colour + -- | A large list of color names. + , module Data.Colour.Names + -- | Semigroups and monoids show up all over the place, so things from + -- Data.Semigroup and Data.Monoid often come in handy. + , module Data.Semigroup + -- | For computing with vectors. + , module Data.VectorSpace + -- | For computing with points and vectors. + , module Data.AffineSpace + + -- | For working with 'Active' (i.e. animated) things. + , module Data.Active + + -- | Essential Lens Combinators + , (&), (.~), (%~) + + , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.Animation +import Diagrams.Attributes +import Diagrams.Combinators +import Diagrams.Coordinates +import Diagrams.CubicSpline +import Diagrams.Envelope +import Diagrams.Located +import Diagrams.Names +import Diagrams.Parametric +import Diagrams.Parametric.Adjust +import Diagrams.Path +import Diagrams.Points +import Diagrams.Query +import Diagrams.Segment +import Diagrams.Tangent +import Diagrams.Trace +import Diagrams.Trail +import Diagrams.TrailLike +import Diagrams.Transform +import Diagrams.ThreeD +import Diagrams.Util + +import Control.Applicative +import Data.Active +import Data.AffineSpace +import Data.Colour hiding (AffineSpace (..), atop, over) +import Data.Colour.Names hiding (tan) +import Data.Semigroup +import Data.VectorSpace hiding (Sum (..)) +import Control.Lens ((&), (.~), (%~)) diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -64,7 +64,7 @@ ) where -import Control.Lens (makeLenses, Wrapped(..), iso, op) +import Control.Lens (makeLenses, Wrapped(..), Rewrapped, iso, op) import Control.Applicative (liftA2) import Data.AffineSpace import Data.FingerTree @@ -375,6 +375,35 @@ p3 = alerp p21 p22 t +instance Num (Scalar v) => DomainBounds (FixedSegment v) + +instance (VectorSpace v, Num (Scalar v)) => EndValues (FixedSegment v) where + atStart (FLinear p0 _) = p0 + atStart (FCubic p0 _ _ _) = p0 + atEnd (FLinear _ p1) = p1 + atEnd (FCubic _ _ _ p1 ) = p1 + +instance (VectorSpace v, Fractional (Scalar v)) => Sectionable (FixedSegment v) where + splitAtParam (FLinear p0 p1) t = (left, right) + where left = FLinear p0 p + right = FLinear p p1 + p = alerp p0 p1 t + splitAtParam (FCubic p0 c1 c2 p1) t = (left, right) + where left = FCubic p0 a b cut + right = FCubic cut c d p1 + -- first round + a = alerp p0 c1 t + p = alerp c1 c2 t + d = alerp c2 p1 t + -- second round + b = alerp a p t + c = alerp p d t + -- final round + cut = alerp b c t + + reverseDomain (FLinear p0 p1) = FLinear p1 p0 + reverseDomain (FCubic p0 c1 c2 p1) = FCubic p1 c2 c1 p0 + ------------------------------------------------------------ -- Segment measures -------------------------------------- ------------------------------------------------------------ @@ -387,9 +416,12 @@ newtype SegCount = SegCount (Sum Int) deriving (Semigroup, Monoid) -instance Wrapped (Sum Int) (Sum Int) SegCount SegCount - where wrapped = iso SegCount $ \(SegCount x) -> x +instance Wrapped SegCount where + type Unwrapped SegCount = Sum Int + _Wrapped' = iso (\(SegCount x) -> x) SegCount +instance Rewrapped SegCount SegCount + -- | A type to represent the total arc length of a chain of -- segments. The first component is a \"standard\" arc length, -- computed to within a tolerance of @10e-6@. The second component is @@ -399,13 +431,13 @@ newtype ArcLength v = ArcLength (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) -instance (Scalar v ~ u, Scalar v' ~ u', u ~ u') => Wrapped - (Sum (Interval u), u -> Sum (Interval u )) - (Sum (Interval u'), u' -> Sum (Interval u')) - (ArcLength v) - (ArcLength v') - where wrapped = iso ArcLength $ \(ArcLength x) -> x +instance Wrapped (ArcLength v) where + type Unwrapped (ArcLength v) = + (Sum (Interval (Scalar v)), Scalar v -> Sum (Interval (Scalar v))) + _Wrapped' = iso (\(ArcLength x) -> x) ArcLength +instance Rewrapped (ArcLength v) (ArcLength v') + -- | Project out the cached arc length, stored together with error -- bounds. getArcLengthCached :: ArcLength v -> Interval (Scalar v) @@ -433,8 +465,11 @@ -- segments. newtype TotalOffset v = TotalOffset v -instance Wrapped v v (TotalOffset v) (TotalOffset v) - where wrapped = iso TotalOffset $ \(TotalOffset x) -> x +instance Wrapped (TotalOffset v) where + type Unwrapped (TotalOffset v) = v + _Wrapped' = iso (\(TotalOffset x) -> x) TotalOffset + +instance Rewrapped (TotalOffset v) (TotalOffset v') instance AdditiveGroup v => Semigroup (TotalOffset v) where TotalOffset v1 <> TotalOffset v2 = TotalOffset (v1 ^+^ v2) diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -31,18 +31,19 @@ -- for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD - ( module Diagrams.ThreeD.Types + ( module Diagrams.ThreeD.Align + , module Diagrams.ThreeD.Camera + , module Diagrams.ThreeD.Light + , module Diagrams.ThreeD.Shapes , module Diagrams.ThreeD.Transform + , module Diagrams.ThreeD.Types , module Diagrams.ThreeD.Vector - , module Diagrams.ThreeD.Shapes - , module Diagrams.ThreeD.Light - , module Diagrams.ThreeD.Camera ) where - -import Diagrams.ThreeD.Transform -import Diagrams.ThreeD.Vector -import Diagrams.ThreeD.Light -import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Align import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes +import Diagrams.ThreeD.Transform +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector diff --git a/src/Diagrams/ThreeD/Align.hs b/src/Diagrams/ThreeD/Align.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Align.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Align +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Alignment combinators specialized for three dimensions. See +-- "Diagrams.Align" for more general alignment combinators. +-- +-- The basic idea is that alignment is achieved by moving diagrams' +-- local origins relative to their envelopes or traces (or some other +-- sort of boundary). For example, to align several diagrams along +-- their tops, we first move their local origins to the upper edge of +-- their boundary (using e.g. @map 'alignZMax'@), and then put them +-- together with their local origins along a line (using e.g. 'cat' +-- from "Diagrams.Combinators"). +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Align + ( -- * Absolute alignment + -- ** Align by envelope + alignXMin, alignXMax, alignYMin, alignYMax, alignZMin, alignZMax + + -- ** Align by trace + , snugXMin, snugXMax, snugYMin, snugYMax, snugZMin, snugZMax + + -- * Relative alignment + , alignX, snugX, alignY, snugY, alignZ, snugZ + + -- * Centering + , centerX, centerY, centerZ + , centerXY, centerXZ, centerYZ, centerXYZ + , snugCenterX, snugCenterY, snugCenterZ + , snugCenterXY, snugCenterXZ, snugCenterYZ, snugCenterXYZ + + ) where + +import Diagrams.Core + +import Diagrams.Align +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector + +import Data.VectorSpace + +-- | Translate the diagram along unitX so that all points have +-- positive x-values. +alignXMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignXMin = align (negateV unitX) + +snugXMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugXMin = snug (negateV unitX) + +-- | Translate the diagram along unitX so that all points have +-- negative x-values. +alignXMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignXMax = align unitX + +snugXMax :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugXMax = snug unitX + + +-- | Translate the diagram along unitY so that all points have +-- negative y-values. +alignYMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignYMax = align unitY + +-- | Move the origin along unitY until it touches the edge of the +-- diagram. +snugYMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugYMax = snug unitY + +-- | Translate the diagram along unitY so that all points have +-- positive y-values. +alignYMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignYMin = align (negateV unitY) + +snugYMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugYMin = snug (negateV unitY) + +-- | Translate the diagram along unitZ so that all points have +-- negative z-values. +alignZMax :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignZMax = align unitZ + +-- | Move the origin along unitZ until it touches the edge of the +-- diagram. +snugZMax:: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugZMax = snug unitZ + +-- | Translate the diagram along unitZ so that all points have +-- positive z-values. +alignZMin :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +alignZMin = align (negateV unitZ) + +-- | Move the origin along unit_Z until it touches the edge of the +-- diagram. +snugZMin :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugZMin = snug (negateV unitZ) + +-- | @alignX@ and @snugX@ move the local origin along unitX as follows: +-- +-- * @alignX (-1)@ moves the local origin to the low-x of the boundary; +-- +-- * @align 1@ moves the local origin to the high-x edge; +-- +-- * any other argument interpolates linearly between these. For +-- example, @alignX 0@ centers, @alignX 2@ moves the origin one +-- \"radius\" to the right of the right edge, and so on. +-- +-- * @snugX@ works the same way. + +alignX :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignX = alignBy unitX + +-- | See the documentation for 'alignX'. +snugX :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => Double -> a -> a +snugX = snugBy unitX + +-- | Like 'alignX', but moving the local origin vertically, with an +-- argument of @1@ corresponding to the top edge and @(-1)@ corresponding +-- to the bottom edge. +alignY :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignY = alignBy unitY + +snugY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => Double -> a -> a +snugY = snugBy unitY + + +-- | Like 'alignX', but moving the local origin in the Z direction, with an +-- argument of @1@ corresponding to the top edge and @(-1)@ corresponding +-- to the bottom edge. +alignZ :: (Alignable a, HasOrigin a, V a ~ R3) => Double -> a -> a +alignZ = alignBy unitZ + +snugZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => Double -> a -> a +snugZ = snugBy unitZ + +-- | Center the local origin along the X-axis. +centerX :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerX = alignBy unitX 0 + +snugCenterX :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterX = snugBy unitX 0 + +-- | Center the local origin along the Y-axis. +centerY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerY = alignBy unitY 0 + +snugCenterY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterY = snugBy unitY 0 + +-- | Center the local origin along the Z-axis. +centerZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerZ = alignBy unitZ 0 + +snugCenterZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterZ = snugBy unitZ 0 + +-- | Center along both the X- and Y-axes. +centerXY :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerXY = centerX . centerY + +snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterXY = snugCenterX . snugCenterY + + +-- | Center along both the X- and Z-axes. +centerXZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerXZ = centerX . centerZ + +snugCenterXZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterXZ = snugCenterX . snugCenterZ + + +-- | Center along both the Y- and Z-axes. +centerYZ :: (Alignable a, HasOrigin a, V a ~ R3) => a -> a +centerYZ = centerZ . centerY + +snugCenterYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterYZ = snugCenterZ . snugCenterY + +-- | Center an object in three dimensions. +centerXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +centerXYZ = centerX . centerY . centerZ + +snugCenterXYZ :: (Fractional (Scalar (V a)), Alignable a, Traced a, + HasOrigin a, V a ~ R3) => a -> a +snugCenterXYZ = snugCenterX . snugCenterY . snugCenterZ diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -28,32 +29,35 @@ ) where -import Control.Lens (makeLenses) -import Data.Monoid -import Data.Cross +import Control.Lens (makeLenses) +import Data.Cross +import Data.Monoid +import Data.Typeable -import Diagrams.Core -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector -- Parameterize Camera on the lens type, so that Backends can express which -- lenses they handle. data Camera l = Camera - { camLoc :: P3 - , forward :: R3 - , up :: R3 - , lens :: l + { camLoc :: P3 + , forward :: R3 + , up :: R3 + , lens :: l } + deriving Typeable -class CameraLens l where +class Typeable l => CameraLens l where -- | The natural aspect ratio of the projection. aspect :: l -> Double -- | A perspective projection data PerspectiveLens = PerspectiveLens - { _horizontalFieldOfView :: Deg -- ^ Horizontal field of view. - , _verticalFieldOfView :: Deg -- ^ Vertical field of view. + { _horizontalFieldOfView :: Angle -- ^ Horizontal field of view. + , _verticalFieldOfView :: Angle -- ^ Vertical field of view. } + deriving Typeable makeLenses ''PerspectiveLens @@ -65,6 +69,7 @@ { _orthoWidth :: Double -- ^ Width , _orthoHeight :: Double -- ^ Height } + deriving Typeable makeLenses ''OrthoLens @@ -104,15 +109,15 @@ -- | mm50 has the field of view of a 50mm lens on standard 35mm film, -- hence an aspect ratio of 3:2. -mm50 = PerspectiveLens 40.5 27 +mm50 = PerspectiveLens (40.5 @@ deg) (27 @@ deg) --- | mm50Wide has the same vertical field of view as mm50, but an +-- | mm50blWide has the same vertical field of view as mm50, but an -- aspect ratio of 1.6, suitable for wide screen computer monitors. -mm50Wide = PerspectiveLens 43.2 27 +mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- | mm50Narrow has the same vertical field of view as mm50, but an -- aspect ratio of 4:3, for VGA and similar computer resulotions. -mm50Narrow = PerspectiveLens 36 27 +mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) camForward :: Direction d => Camera l -> d camForward = direction . forward diff --git a/src/Diagrams/ThreeD/Deform.hs b/src/Diagrams/ThreeD/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/ThreeD/Deform.hs @@ -0,0 +1,51 @@ +module Diagrams.ThreeD.Deform where + +import Control.Lens + +import Diagrams.Deform + +import Diagrams.Coordinates +import Diagrams.ThreeD.Types + +-- | The parallel projection onto the plane x=0 +parallelX0 :: Deformation R3 +parallelX0 = Deformation (& _x .~ 0) + +-- | The perspective division onto the plane x=1 along lines going +-- through the origin. +perspectiveX1 :: Deformation R3 +perspectiveX1 = Deformation (\p -> let x = p^._x in + p & _x .~ 1 & _y //~ x & _z //~ x ) + +-- | The parallel projection onto the plane y=0 +parallelY0 :: Deformation R3 +parallelY0 = Deformation (& _y .~ 0) + +-- | The perspective division onto the plane y=1 along lines going +-- through the origin. +perspectiveY1 :: Deformation R3 +perspectiveY1 = Deformation (\p -> let y = p^._y in + p & _x //~ y & _y .~ 1 & _z //~ y ) + +-- | The parallel projection onto the plane z=0 +parallelZ0 :: Deformation R3 +parallelZ0 = Deformation (& _z .~ 0) + +-- | The perspective division onto the plane z=1 along lines going +-- through the origin. +perspectiveZ1 :: Deformation R3 +perspectiveZ1 = Deformation (\p -> let z = p^._z in + p & _x //~ z & _y //~ z & _z .~ 1 ) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asDeformation (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Deformation R3 +facingX = Deformation (\v -> v & _y //~ (v^._x) & _z //~ (v^._x)) + +facingY :: Deformation R3 +facingY = Deformation (\v -> v & _x //~ (v^._y) & _z //~ (v^._y)) + +facingZ :: Deformation R3 +facingZ = Deformation (\v -> v & _x //~ (v^._z) & _y //~ (v^._z)) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -15,16 +16,19 @@ module Diagrams.ThreeD.Light where -import Data.Colour -import Data.Monoid +import Data.Colour +import Data.Monoid +import Data.Typeable -import Diagrams.Core -import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector +import Diagrams.Core +import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector data PointLight = PointLight P3 (Colour Double) + deriving Typeable data ParallelLight = ParallelLight R3 (Colour Double) + deriving Typeable type instance V PointLight = R3 type instance V ParallelLight = R3 diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE TypeFamilies - , FlexibleContexts - , MultiParamTypeClasses - , ViewPatterns - #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Shapes @@ -20,19 +19,17 @@ , sphere ) where -import Prelude hiding (minimum) -import Data.Semigroup - -import Data.AffineSpace -import Data.Monoid.Inf (minimum) -import Data.VectorSpace - -import Diagrams.Core +import Data.Typeable -import Diagrams.ThreeD.Types -import Diagrams.Solve +import Data.AffineSpace +import Data.Semigroup +import Data.VectorSpace +import Diagrams.Core +import Diagrams.Solve +import Diagrams.ThreeD.Types data Ellipsoid = Ellipsoid T3 + deriving Typeable type instance V Ellipsoid = R3 @@ -51,7 +48,7 @@ mempty (Query sphereQuery) where sphereEnv v = 1 / magnitude v - sphereTrace p v = minimum (quadForm a b c) + sphereTrace p v = mkSortedList $ quadForm a b c where a = v <.> v b = 2 *^ p' <.> v c = p' <.> p' - 1 diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -16,16 +16,42 @@ -- ----------------------------------------------------------------------------- -module Diagrams.ThreeD.Transform where +module Diagrams.ThreeD.Transform + ( + -- * Rotation + aboutX, aboutY, aboutZ + , rotationAbout, pointAt, pointAt' + -- * Scaling + , scalingX, scalingY, scalingZ + , scaleX, scaleY, scaleZ + , scaling, scale + + -- * Translation + , translationX, translateX + , translationY, translateY + , translationZ, translateZ + , translation, translate + + -- * Reflection + , reflectionX, reflectX + , reflectionY, reflectY + , reflectionZ, reflectZ + , reflectionAbout, reflectAbout + + -- * Utilities for Backends + , onBasis + ) where + import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Transform import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector import Diagrams.Coordinates -import Control.Lens ((*~), (//~)) +import Control.Lens (view, (*~), (//~)) import Data.Semigroup import Data.AffineSpace @@ -37,39 +63,39 @@ -- A positive angle brings positive x-values towards the positive-y axis. -- -- The angle can be expressed using any type which is an --- instance of 'Angle'. For example, @aboutZ (1\/4 :: --- 'Turn')@, @aboutZ (tau\/4 :: 'Rad')@, and @aboutZ (90 :: --- 'Deg')@ all represent the same transformation, namely, a +-- instance of 'Angle'. For example, @aboutZ (1\/4 \@\@ +-- 'turn')@, @aboutZ (tau\/4 \@\@ 'rad')@, and @aboutZ (90 \@\@ +-- 'deg')@ all represent the same transformation, namely, a -- counterclockwise rotation by a right angle. For more general rotations, -- see 'rotationAbout'. -- -- Note that writing @aboutZ (1\/4)@, with no type annotation, will -- yield an error since GHC cannot figure out which sort of angle -- you want to use. -aboutZ :: Angle a => a -> T3 +aboutZ :: Angle -> T3 aboutZ ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) - Rad theta = convertAngle ang + theta = view rad ang rot th (coords -> x :& y :& z) = (cos th * x - sin th * y) ^& (sin th * x + cos th * y) ^& z -- | Like 'aboutZ', but rotates about the X axis, bringing positive y-values -- towards the positive z-axis. -aboutX :: Angle a => a -> T3 +aboutX :: Angle -> T3 aboutX ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) - Rad theta = convertAngle ang + theta = view rad ang rot th (coords -> x :& y :& z) = (x) ^& (cos th * y - sin th * z) ^& (sin th * y + cos th * z) -- | Like 'aboutZ', but rotates about the Y axis, bringing postive -- x-values towards the negative z-axis. -aboutY :: Angle a => a -> T3 +aboutY :: Angle -> T3 aboutY ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) - Rad theta = convertAngle ang + theta = view rad ang rot th (coords -> x :& y :& z) = (cos th * x + sin th * z) ^& y ^& (-sin th * x + cos th * z) @@ -77,17 +103,17 @@ -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. rotationAbout - :: (Angle a, Direction d) + :: Direction d => P3 -- ^ origin of rotation -> d -- ^ direction of rotation axis - -> a -- ^ angle of rotation + -> Angle -- ^ angle of rotation -> T3 rotationAbout p d a = mconcat [translation (negateV t), fromLinear r (linv r), translation t] where r = rot theta <-> rot (-theta) - Rad theta = convertAngle a + theta = view rad a w = fromDirection d rot :: Double -> R3 -> R3 rot th v = v ^* cos th ^+^ @@ -110,10 +136,10 @@ pointAt' :: R3 -> R3 -> R3 -> T3 pointAt' about initial final = tilt <> pan where inPanPlane = final ^-^ project final initial - panAngle = angleBetween initial inPanPlane :: Turn - pan = rotationAbout origin (direction about :: Spherical Turn) panAngle - tiltAngle = angleBetween initial inPanPlane :: Turn - tiltDir = direction $ cross3 inPanPlane about :: Spherical Turn + panAngle = angleBetween initial inPanPlane + pan = rotationAbout origin (direction about :: Spherical) panAngle + tiltAngle = angleBetween initial inPanPlane + tiltDir = direction $ cross3 inPanPlane about :: Spherical tilt = rotationAbout origin tiltDir tiltAngle -- Scaling ------------------------------------------------- @@ -150,6 +176,85 @@ -- uniformly, use 'scale'. scaleZ :: (Transformable t, V t ~ R3) => Double -> t -> t scaleZ = transform . scalingZ + +-- Translation ---------------------------------------- + +-- | Construct a transformation which translates by the given distance +-- in the x direction. +translationX :: Double -> T3 +translationX x = translation (x ^& 0 ^& 0) + +-- | Translate a diagram by the given distance in the x +-- direction. +translateX :: (Transformable t, V t ~ R3) => Double -> t -> t +translateX = transform . translationX + +-- | Construct a transformation which translates by the given distance +-- in the y direction. +translationY :: Double -> T3 +translationY y = translation (0 ^& y ^& 0) + +-- | Translate a diagram by the given distance in the y +-- direction. +translateY :: (Transformable t, V t ~ R3) => Double -> t -> t +translateY = transform . translationY + +-- | Construct a transformation which translates by the given distance +-- in the z direction. +translationZ :: Double -> T3 +translationZ z = translation (0 ^& 0 ^& z) + +-- | Translate a diagram by the given distance in the y +-- direction. +translateZ :: (Transformable t, V t ~ R3) => Double -> t -> t +translateZ = transform . translationZ + +-- Reflection ---------------------------------------------- + +-- | Construct a transformation which flips a diagram across x=0, +-- i.e. sends the point (x,y,z) to (-x,y,z). +reflectionX :: T3 +reflectionX = scalingX (-1) + +-- | Flip a diagram across x=0, i.e. send the point (x,y,z) to (-x,y,z). +reflectX :: (Transformable t, V t ~ R3) => t -> t +reflectX = transform reflectionX + +-- | Construct a transformation which flips a diagram across y=0, +-- i.e. sends the point (x,y,z) to (x,-y,z). +reflectionY :: T3 +reflectionY = scalingY (-1) + +-- | Flip a diagram across y=0, i.e. send the point (x,y,z) to +-- (x,-y,z). +reflectY :: (Transformable t, V t ~ R3) => t -> t +reflectY = transform reflectionY + +-- | Construct a transformation which flips a diagram across z=0, +-- i.e. sends the point (x,y,z) to (x,y,-z). +reflectionZ :: T3 +reflectionZ = scalingZ (-1) + +-- | Flip a diagram across z=0, i.e. send the point (x,y,z) to +-- (x,y,-z). +reflectZ :: (Transformable t, V t ~ R3) => t -> t +reflectZ = transform reflectionZ + +-- | @reflectionAbout p v@ is a reflection across the plane through +-- the point @p@ and normal to vector @v@. +reflectionAbout :: P3 -> R3 -> T3 +reflectionAbout p v = + conjugate (translation (origin .-. p)) reflect where + reflect = fromLinear t (linv t) + t = f v <-> f (negateV v) + f u w = w ^-^ 2 *^ project u w + +-- | @reflectAbout p v@ reflects a diagram in the line determined by +-- the point @p@ and the vector @v@. +reflectAbout :: (Transformable t, V t ~ R3) => P3 -> R3 -> t -> t +reflectAbout p v = transform (reflectionAbout p v) + +-- Utilities ---------------------------------------- -- | Get the matrix equivalent of an affine transform, as a triple of -- columns paired with the translation vector. This is mostly diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -29,13 +29,8 @@ -- * Two-dimensional angles -- | These are defined in "Diagrams.TwoD.Types" but -- reëxported here for convenience. - , Angle(..) - , Turn(Turn), asTurn - , CircleFrac - , Rad(Rad), asRad - , Deg(Deg), asDeg - - , fullTurn, convertAngle, angleRatio + , Angle, rad, turn, deg, (@@) + , fullTurn, angleRatio -- * Directions in 3D , Direction(..) @@ -43,8 +38,8 @@ , asSpherical ) where -import Control.Applicative -import Control.Lens (Iso', iso, over, Wrapped, wrapped, _1, _2, _3) +import Control.Lens (Iso', iso, over, Wrapped(..), Rewrapped + , _1, _2, _3) import Diagrams.Core import Diagrams.TwoD.Types @@ -78,10 +73,13 @@ unr3 = unR3 -- | Lens wrapped isomorphisms for R3. -instance Wrapped (Double, Double, Double) (Double, Double, Double) R3 R3 where - wrapped = iso r3 unr3 - {-# INLINE wrapped #-} +instance Wrapped R3 where + type Unwrapped R3 = (Double, Double, Double) + _Wrapped' = iso unr3 r3 + {-# INLINE _Wrapped' #-} +instance Rewrapped R3 R3 + type instance V R3 = R3 instance VectorSpace R3 where @@ -139,35 +137,28 @@ -- based on that of the Angle class in 2D. class Direction d where - -- | Convert to polar angles - toSpherical :: Angle a => d -> Spherical a + -- | Convert to spherical coördinates + toSpherical :: d -> Spherical - -- | Convert from polar angles - fromSpherical :: Angle a => Spherical a -> d + -- | Convert from spherical coördinates + fromSpherical :: Spherical -> d -- | A direction expressed as a pair of spherical coordinates. -- `Spherical 0 0` is the direction of `unitX`. The first coordinate -- represents rotation about the Z axis, the second rotation towards the Z axis. -data Spherical a = Spherical a a +data Spherical = Spherical Angle Angle deriving (Show, Read, Eq) -instance Applicative Spherical where - pure a = Spherical a a - Spherical a b <*> Spherical c d = Spherical (a c) (b d) - -instance Functor Spherical where - fmap f s = pure f <*> s - -instance (Angle a) => Direction (Spherical a) where - toSpherical = fmap convertAngle - fromSpherical = fmap convertAngle +instance Direction Spherical where + toSpherical = id + fromSpherical = id -- | The identity function with a restricted type, for conveniently -- restricting unwanted polymorphism. For example, @fromDirection -- . asSpherical . camForward@ gives a unit vector pointing in the -- direction of the camera view. Without @asSpherical@, the -- intermediate type would be ambiguous. -asSpherical :: Spherical Turn -> Spherical Turn +asSpherical :: Spherical -> Spherical asSpherical = id instance HasX R3 where diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -20,7 +20,7 @@ direction, fromDirection, angleBetween, angleBetweenDirs ) where -import Control.Lens (op) +import Control.Lens ((^.)) import Data.VectorSpace import Data.Cross @@ -61,24 +61,23 @@ | otherwise = fromSpherical $ Spherical θ φ where r = magnitude v (x,y,z) = unr3 v - φ = Rad . asin $ z / r - θ = Rad . atan2 y $ x - zero = Rad $ 0 + φ = asin (z / r) @@ rad + θ = atan2 y x @@ rad + zero = 0 @@ rad -- | @fromDirection d@ is the unit vector in the direction @d@. fromDirection :: Direction d => d -> R3 fromDirection (toSpherical -> (Spherical θ' φ')) = r3 (x,y,z) where - θ = op Rad $ θ' - φ = op Rad $ φ' + θ = θ'^.rad + φ = φ'^.rad x = cos θ * cos φ y = sin θ * cos φ z = sin φ -- | compute the positive angle between the two vectors in their common plane -angleBetween :: (Angle a, Num a, Ord a) => R3 -> R3 -> a -angleBetween v1 v2 = convertAngle . Rad $ - atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) +angleBetween :: R3 -> R3 -> Angle +angleBetween v1 v2 = atan2 (magnitude $ cross3 v1 v2) (v1 <.> v2) @@ rad -- | compute the positive angle between the two vectors in their common plane -angleBetweenDirs :: (Direction d, Angle a, Num a, Ord a) => d -> d -> a +angleBetweenDirs :: Direction d => d -> d -> Angle angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -103,7 +103,7 @@ ) where import Control.Arrow ((***)) -import Control.Lens (AnIso', iso, view, op, Wrapped(..)) +import Control.Lens (AnIso', iso, view, op, Wrapped(..), Rewrapped) import Data.AffineSpace import Data.FingerTree (FingerTree, ViewL (..), ViewR (..), (<|), (|>)) @@ -151,11 +151,11 @@ newtype SegTree v = SegTree (FingerTree (SegMeasure v) (Segment Closed v)) deriving (Eq, Ord, Show) -instance Wrapped (FingerTree (SegMeasure v) (Segment Closed v)) - (FingerTree (SegMeasure v) (Segment Closed v)) - (SegTree v) - (SegTree v) - where wrapped = iso SegTree $ \(SegTree x) -> x +instance Wrapped (SegTree v) where + type Unwrapped (SegTree v) = FingerTree (SegMeasure v) (Segment Closed v) + _Wrapped' = iso (\(SegTree x) -> x) SegTree + +instance Rewrapped (SegTree v) (SegTree v') type instance V (SegTree v) = v diff --git a/src/Diagrams/TrailLike.hs b/src/Diagrams/TrailLike.hs --- a/src/Diagrams/TrailLike.hs +++ b/src/Diagrams/TrailLike.hs @@ -30,7 +30,7 @@ import Data.AffineSpace ((.-.)) import Data.VectorSpace -import Control.Lens (view, wrapped) +import Control.Lens (view, _Unwrapped') import Diagrams.Core import Diagrams.Located @@ -96,7 +96,7 @@ -- | Translationally invariant things are trail-like as long as the -- underlying type is. instance TrailLike t => TrailLike (TransInv t) where - trailLike = view wrapped . trailLike + trailLike = view _Unwrapped' . trailLike -- | 'Located' things are trail-like as long as the underlying type -- is. The location is taken to be the location of the input diff --git a/src/Diagrams/Transform.hs b/src/Diagrams/Transform.hs --- a/src/Diagrams/Transform.hs +++ b/src/Diagrams/Transform.hs @@ -41,7 +41,7 @@ -- | Carry out some transformation \"under\" another one: @f ``under`` -- t@ first applies @t@, then @f@, then the inverse of @t@. For --- example, @'scaleX' 2 ``under`` 'rotationBy' (-1/8 :: Turn)@ +-- example, @'scaleX' 2 ``under`` 'rotation' (-1/8 \@\@ Turn)@ -- is the transformation which scales by a factor of 2 along the -- diagonal line y = x. -- diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -69,11 +69,10 @@ -- * Angles , tau - , Angle(..) - , Turn(..), asTurn, CircleFrac - , Rad(..), asRad - , Deg(..), asDeg - , fullTurn, fullCircle, convertAngle + , Angle + , rad, turn, deg + , fullTurn, fullCircle, angleRatio + , (@@) -- * Paths -- ** Stroking @@ -84,7 +83,7 @@ , StrokeOpts(..), vertexNames, queryFillRule -- ** Clipping - , clipBy + , clipBy, clipTo, clipped -- * Shapes -- ** Rules @@ -134,12 +133,13 @@ , RoundedRectOpts(..), radiusTL, radiusTR, radiusBL, radiusBR -- ** Arrows - , arrow, arrow' + , arrowV, arrowV' , arrowAt, arrowAt' , arrowBetween, arrowBetween' , connect, connect' , connectPerim, connectPerim' , connectOutside, connectOutside' + , arrow, arrow' , straightShaft , module Diagrams.TwoD.Arrowheads @@ -152,6 +152,7 @@ , tailSize , headGap , tailGap + , gap , headColor , headStyle , tailColor @@ -188,6 +189,10 @@ , shearingX, shearX , shearingY, shearY + -- * Deformations - non-affine transforms + , parallelX0, perspectiveX1, parallelY0, perspectiveY1 + , facingX, facingY + -- * Combinators -- ** Combining multiple diagrams , (===), (|||), atAngle @@ -246,6 +251,7 @@ import Diagrams.TwoD.Model import Diagrams.TwoD.Path import Diagrams.TwoD.Polygons +import Diagrams.TwoD.Deform import Diagrams.TwoD.Shapes import Diagrams.TwoD.Size import Diagrams.TwoD.Text diff --git a/src/Diagrams/TwoD/Align.hs b/src/Diagrams/TwoD/Align.hs --- a/src/Diagrams/TwoD/Align.hs +++ b/src/Diagrams/TwoD/Align.hs @@ -144,8 +144,8 @@ -- | Center along both the X- and Y-axes. centerXY :: (Alignable a, HasOrigin a, V a ~ R2) => a -> a -centerXY = centerX . centerY +centerXY = center snugCenterXY :: (Fractional (Scalar (V a)), Alignable a, Traced a, HasOrigin a, V a ~ R2) => a -> a -snugCenterXY = snugCenterX . snugCenterY +snugCenterXY = snugCenter diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -31,11 +31,12 @@ import Diagrams.TwoD.Transform import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction, e, unitX) -import Diagrams.Util (tau, ( # )) +import Diagrams.Util (( # )) +import Control.Lens ((^.)) import Data.AffineSpace ((.-.)) import Data.Semigroup ((<>)) -import Data.VectorSpace (magnitude, negateV, (*^), (^-^)) +import Data.VectorSpace import Diagrams.Coordinates -- For details of this approximation see: @@ -45,27 +46,27 @@ -- the positive y direction and sweeps counterclockwise through @s@ -- radians. The approximation is only valid for angles in the first -- quadrant. -bezierFromSweepQ1 :: Rad -> Segment Closed R2 -bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 - where p0@(coords -> x :& y) = rotate (s/2) v +bezierFromSweepQ1 :: Angle -> Segment Closed R2 +bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 + where p0@(coords -> x :& y) = rotate (s ^/ 2) v c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 v = unitX -- | @bezierFromSweep s@ constructs a series of 'Cubic' segments that -- start in the positive y direction and sweep counter clockwise --- through @s@ radians. If @s@ is negative, it will start in the +-- through the angle @s@. If @s@ is negative, it will start in the -- negative y direction and sweep clockwise. When @s@ is less than -- 0.0001 the empty list results. If the sweep is greater than tau --- then it is truncated to tau. -bezierFromSweep :: Rad -> [Segment Closed R2] +-- radians then it is truncated to one full revolution. +bezierFromSweep :: Angle -> [Segment Closed R2] bezierFromSweep s - | s > tau = bezierFromSweep tau - | s < 0 = fmap reflectY . bezierFromSweep $ (-s) - | s < 0.0001 = [] - | s < tau/4 = [bezierFromSweepQ1 s] - | otherwise = bezierFromSweepQ1 (tau/4) - : map (rotateBy (1/4)) (bezierFromSweep (max (s - tau/4) 0)) + | s > fullTurn = bezierFromSweep fullTurn + | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) + | s < 0.0001 @@ rad = [] + | s < fullTurn^/4 = [bezierFromSweepQ1 s] + | otherwise = bezierFromSweepQ1 (fullTurn^/4) + : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zeroV)) {- ~~~~ Note [segment spacing] @@ -89,29 +90,29 @@ -- | Given a start angle @s@ and an end angle @e@, @'arcT' s e@ is the -- 'Trail' of a radius one arc counterclockwise between the two angles. -arcT :: Angle a => a -> a -> Trail R2 +arcT :: Angle -> Angle -> Trail R2 arcT start end - | end' < start' = arcT start' (end' + fromIntegral d) - | otherwise = (if sweep >= tau then glueTrail else id) + | end' < start' = arcT start (end ^+^ (fromIntegral d @@ turn)) + | otherwise = (if sweep >= fullTurn then glueTrail else id) $ trailFromSegments bs - where sweep = convertAngle $ end - start + where sweep = end ^-^ start bs = map (rotate start) . bezierFromSweep $ sweep -- We want to compare the start and the end and in case -- there isn't some law about 'Angle' ordering, we use a -- known 'Angle' for that. - start' = convertAngle start :: Turn - end' = convertAngle end + start' = start^.turn + end' = end^.turn d = ceiling (start' - end') :: Integer -- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the -- path of a radius one arc counterclockwise between the two angles. -- The origin of the arc is its center. -arc :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t +arc :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0)) -- | Like 'arc' but clockwise. -arcCW :: (Angle a, TrailLike t, V t ~ R2) => a -> a -> t +arcCW :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t arcCW start end = trailLike $ -- flipped arguments to get the path we want -- then reverse the trail to get the cw direction. @@ -129,9 +130,9 @@ -- -- <> -- --- > arc'Ex = mconcat [ arc' r 0 (1/4 :: Turn) | r <- [0.5,-1,1.5] ] +-- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p +arc' :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) where ts | r < 0 = reverseTrail $ arcT end start | otherwise = arcT start end @@ -142,13 +143,13 @@ -- <> -- -- > wedgeEx = hcat' (with & sep .~ 0.5) --- > [ wedge 1 (0 :: Turn) (1/4) --- > , wedge 1 (7/30 :: Turn) (11/30) --- > , wedge 1 (1/8 :: Turn) (7/8) +-- > [ wedge 1 (0 \@\@ turn) (1/4) +-- > , wedge 1 (7/30 \@\@ turn) (11/30) +-- > , wedge 1 (1/8 \@\@ turn) (7/8) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> a -> a -> p +wedge :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p wedge r a1 a2 = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ e a1] <> arc a1 a2 # scale r @@ -166,7 +167,7 @@ -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 arcBetween :: (TrailLike t, V t ~ R2) => P2 -> P2 -> Double -> t -arcBetween p q ht = trailLike (a # rotateBy (direction v) # moveTo p) +arcBetween p q ht = trailLike (a # rotate (direction v) # moveTo p) where h = abs ht isStraight = h < 0.00001 @@ -174,10 +175,10 @@ d = magnitude (q .-. p) th = acos ((d*d - 4*h*h)/(d*d + 4*h*h)) r = d/(2*sin th) - mid | ht >= 0 = tau/4 - | otherwise = 3*tau/4 - st = mid - Rad th - end = mid + Rad th + mid | ht >= 0 = fullTurn ^/ 4 + | otherwise = 3 *^ fullTurn ^/ 4 + st = mid ^-^ (th @@ rad) + end = mid ^+^ (th @@ rad) a | isStraight = fromOffsets [d *^ unitX] | otherwise @@ -194,13 +195,13 @@ -- <> -- -- > annularWedgeEx = hcat' (with & sep .~ 0.50) --- > [ annularWedge 1 0.5 (0 :: Turn) (1/4) --- > , annularWedge 1 0.3 (7/30 :: Turn) (11/30) --- > , annularWedge 1 0.7 (1/8 :: Turn) (7/8) +-- > [ annularWedge 1 0.5 (0 \@\@ turn) (1/4) +-- > , annularWedge 1 0.3 (7/30 \@\@ turn) (11/30) +-- > , annularWedge 1 0.7 (1/8 \@\@ turn) (7/8) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (Angle a, TrailLike p, V p ~ R2) => Double -> Double -> a -> a -> p +annularWedge :: (TrailLike p, V p ~ R2) => Double -> Double -> Angle -> Angle -> p annularWedge r1' r2' a1 a2 = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1'-r2') *^ e a1] <> arc a1 a2 # scale r1' diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -46,7 +46,7 @@ -- > -- > -- Connect two diagrams and two points on their trails. -- > ex12 = dias # connect "first" "second" --- > # connectPerim "first" "second" (15/16 :: Turn) (9/16 :: Turn) +-- > # connectPerim "first" "second" (15/16 \@\@ turn) (9/16 \@\@ turn) -- > -- > -- Place an arrow at (0,0) the size and direction of (0,1). -- > ex3 = arrowAt origin unit_Y @@ -54,8 +54,8 @@ -- > example2 = (ex12 <> ex3) # centerXY # pad 1.1 -- * Creating arrows - arrow - , arrow' + arrowV + , arrowV' , arrowAt , arrowAt' , arrowBetween @@ -66,8 +66,10 @@ , connectPerim' , connectOutside , connectOutside' - , straightShaft + , arrow + , arrow' + -- * Options , ArrowOpts(..) @@ -78,27 +80,30 @@ , tailSize , headGap , tailGap + , gap , headColor , headStyle , tailColor , tailStyle , shaftColor , shaftStyle + , straightShaft -- | See "Diagrams.TwoD.Arrowheads" for a list of standard -- arrowheads and help creating your own. , module Diagrams.TwoD.Arrowheads ) where +import Control.Applicative ((<*>)) import Control.Arrow (first) -import Control.Lens (Lens', Setter', +import Control.Lens (Lens', Setter', Traversal', generateSignatures, lensRules, makeLensesWith, (%~), (&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) -import Data.Maybe (fromJust, fromMaybe) +import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import Data.Monoid.Coproduct (untangle) import Data.Monoid.Split @@ -117,7 +122,7 @@ import Diagrams.Trail import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Path (strokeT) -import Diagrams.TwoD.Transform (rotate, rotateBy, translateX) +import Diagrams.TwoD.Transform (rotate, translateX) import Diagrams.TwoD.Transform.ScaleInv (scaleInvPrim) import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction, unitX, unit_X) @@ -176,9 +181,13 @@ -- | Distance to leave between the head and the target point. headGap :: Lens' ArrowOpts Double + -- | Distance to leave between the starting point and the tail. tailGap :: Lens' ArrowOpts Double +gap :: Traversal' ArrowOpts Double +gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) + -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change -- an opaque black arrowhead to translucent orange: @@ -373,8 +382,8 @@ -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). dArrow sty tr ln = (h' <> t' <> shaft) - # moveOriginBy (tWidth *^ (unit_X # rotateBy tAngle)) - # rotateBy (direction (q .-. p) - dir) + # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) + # rotate (direction (q .-. p) ^-^ dir) # moveTo p where @@ -398,7 +407,7 @@ shaftTrail = rawShaftTrail -- rotate it so it is pointing in the positive X direction - # rotateBy (- direction (trailOffset rawShaftTrail)) + # rotate (negateV direction (trailOffset rawShaftTrail)) -- apply the context transformation -- in case it includes -- things like flips and shears (the possibility of shears -- is why we must rotate it to a neutral position first) @@ -409,8 +418,8 @@ hWidth = hWidth' + opts^.headGap -- Calculate the angles that the head and tail should point. - tAngle = direction . tangentAtStart $ shaftTrail :: Turn - hAngle = direction . tangentAtEnd $ shaftTrail :: Turn + tAngle = direction . tangentAtStart $ shaftTrail + hAngle = direction . tangentAtEnd $ shaftTrail -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire -- arrow will be of length len. Then apply it to the shaft and make the @@ -420,9 +429,9 @@ shaft = strokeT shaftTrail' # applyStyle (shaftSty opts) -- Adjust the head and tail to point in the directions of the shaft ends. - h' = h # rotateBy hAngle + h' = h # rotate hAngle # moveTo (origin .+^ shaftTrail' `atParam` domainUpper shaftTrail') - t' = t # rotateBy tAngle + t' = t # rotate tAngle -- Find out what direction the arrow is pointing so we can set it back -- to point in the direction unitX when we are done. @@ -443,18 +452,31 @@ arrowBetween' opts s e = arrowAt' opts s (e .-. s) -- | Create an arrow starting at s with length and direction determined by --- the vectore v. +-- the vector v. arrowAt :: Renderable (Path R2) b => P2 -> R2 -> Diagram b R2 arrowAt s v = arrowAt' def s v arrowAt' :: Renderable (Path R2) b => ArrowOpts -> P2 -> R2 -> Diagram b R2 -arrowAt' opts s v = arrow' opts len # rotateBy dir # moveTo s +arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s where len = magnitude v dir = direction v +-- | @arrowV v@ creates an arrow with the direction and magnitude of +-- the vector @v@ (with its tail at the origin), using default +-- parameters. +arrowV :: Renderable (Path R2) b => R2 -> Diagram b R2 +arrowV = arrowV' def + +-- | @arrowV' v@ creates an arrow with the direction and magnitude of +-- the vector @v@ (with its tail at the origin). +arrowV' + :: Renderable (Path R2) b + => ArrowOpts -> R2 -> Diagram b R2 +arrowV' opts = arrowAt' opts origin + -- | Connect two diagrams with a straight arrow. connect :: (Renderable (Path R2) b, IsName n1, IsName n2) @@ -474,14 +496,14 @@ -- | Connect two diagrams at point on the perimeter of the diagrams, choosen -- by angle. connectPerim - :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a) - => n1 -> n2 -> a -> a + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => n1 -> n2 -> Angle -> Angle -> (Diagram b R2 -> Diagram b R2) connectPerim = connectPerim' def connectPerim' - :: (Renderable (Path R2) b, IsName n1, IsName n2, Angle a) - => ArrowOpts -> n1 -> n2 -> a -> a + :: (Renderable (Path R2) b, IsName n1, IsName n2) + => ArrowOpts -> n1 -> n2 -> Angle -> Angle -> (Diagram b R2 -> Diagram b R2) connectPerim' opts n1 n2 a1 a2 = withName n1 $ \sub1 -> @@ -508,6 +530,9 @@ withName n2 $ \b2 -> let v = location b2 .-. location b1 midpoint = location b1 .+^ (v/2) - s = fromJust $ traceP midpoint (-v) b1 - e = fromJust $ traceP midpoint v b2 - in atop (arrowBetween' opts s e) + s' = traceP midpoint (-v) b1 + e' = traceP midpoint v b2 + in + case (s', e') of + (Just s, Just e) -> atop (arrowBetween' opts s e) + (_, _) -> id diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -56,8 +56,8 @@ ) where import Control.Lens ((&), (.~)) -import Data.Default.Class import Data.AffineSpace +import Data.Default.Class import Data.Functor ((<$>)) import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) @@ -103,27 +103,29 @@ -- | <> --- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 :: Turn) & shaftStyle %~ lw 0) +-- > tri25Ex = arrowAt' (with & arrowHead .~ arrowheadTriangle (2/5 \@\@ turn) & shaftStyle %~ lw 0) -- > origin (r2 (0.001, 0)) -- > <> square 0.6 # alignL # lw 0 -arrowheadTriangle :: Angle a => a -> ArrowHT +arrowheadTriangle :: Angle -> ArrowHT arrowheadTriangle theta = aHead where aHead size _ = (p, mempty) where - p = polygon (def & polyType .~ PolyPolar [theta, (-2 * theta)] + p = polygon (def & polyType .~ PolyPolar [theta, (negateV 2 *^ theta)] (repeat (htRadius * size)) & polyOrient .~ NoOrient) # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. -arrowheadDart :: Angle a => a -> ArrowHT +arrowheadDart :: Angle -> ArrowHT arrowheadDart theta = aHead where aHead size shaftWidth = (dartP # moveOriginTo (dartVertices !! 2), joint) where - a = toTurn theta r = htRadius * size - dartP = polygon (def & polyType .~ PolyPolar [a, 1/2 - a, 1/2 - a] - [r, r, 0.1 * size, r] & polyOrient .~ NoOrient) + dartP = polygon + ( def & polyType .~ PolyPolar [theta, (1/2 @@ turn) ^-^ theta, (1/2 @@ turn) ^-^ theta] + [r, r, 0.1 * size, r] + & polyOrient .~ NoOrient + ) dartVertices = (concat . pathVertices) $ dartP m = magnitude (dartVertices !! 1 .-. dartVertices !! 3) s = 1 - shaftWidth / m @@ -135,7 +137,7 @@ , dartVertices !! 2 ]) # alignR -- | Isoceles triangle with curved concave base. Inkscape type 2. -arrowheadSpike :: Angle a => a -> ArrowHT +arrowheadSpike :: Angle -> ArrowHT arrowheadSpike theta = aHead where aHead size shaftWidth = (barb # moveOriginBy (m *^ unit_X) , joint) @@ -144,11 +146,11 @@ a' = reflectY a l1 = trailFromSegments [straight (unit_X2 ^+^ a)] l2 = trailFromSegments [reverseSegment . straight $ (unit_X2 ^+^ a')] - c = reflectX $ arc' htRadius theta (-theta) + c = reflectX $ arc' htRadius theta (negateV theta) barb = (closedPath $ (l1 <> c <> l2)) # scale size m = xWidth barb --c `atParam` 0.5 - b = Rad $ asin ((shaftWidth / 2) / (htRadius * size)) - c' = arc' htRadius (-b ) b # scale size + b = asin ((shaftWidth / 2) / (htRadius * size)) @@ rad + c' = arc' htRadius (negateV b) b # scale size joint = (closedPath $ (c')) # centerY # alignR xWidth p = pa + pb where @@ -156,7 +158,7 @@ pb = fromMaybe 0 (magnitude <$> traceV origin unit_X p) -- | Curved sides, linear concave base. Illustrator CS5 #3 -arrowheadThorn :: Angle a => a -> Double -> ArrowHT +arrowheadThorn :: Angle -> Double -> ArrowHT arrowheadThorn theta r = aHead where aHead size shaftWidth = (thornP # moveOriginTo (thornVertices !! 2), joint) @@ -165,7 +167,7 @@ c1 = curvedSide theta l1 = straight $ (reflectY a) ^-^ (unit_X2 # scale r) l2 = straight $ unit_X2 # scale r ^-^ a - c2 = c1 # rotate (-theta) + c2 = c1 # rotate (negateV theta) thornP = (closedPath $ trailFromSegments [c1, l1, l2, c2]) # scale size thornVertices = (concat . pathVertices) $ thornP m = magnitude (thornVertices !! 1 .-. thornVertices !! 3) @@ -178,7 +180,7 @@ , thornVertices !! 2 ]) # alignR -- | Make a side for the thorn head. -curvedSide :: Angle a => a -> Segment Closed R2 +curvedSide :: Angle -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = scaleR unit_X @@ -202,7 +204,7 @@ smooth [] = mempty smooth (x:xs) = cubicSpline True x <> smooth xs -arrowheadMissile :: Angle a => a -> ArrowHT +arrowheadMissile :: Angle -> ArrowHT arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta -- Standard heads --------------------------------------------------------- @@ -213,31 +215,31 @@ -- > triEx = drawHead tri tri :: ArrowHT -tri = arrowheadTriangle (1/3 :: Turn) +tri = arrowheadTriangle (1/3 @@ turn) -- | <> -- > spikeEx = drawHead spike spike :: ArrowHT -spike = arrowheadSpike (3/8 :: Turn) +spike = arrowheadSpike (3/8 @@ turn) -- | <> -- > thornEx = drawHead thorn thorn :: ArrowHT -thorn = arrowheadThorn (3/8 :: Turn) 1 +thorn = arrowheadThorn (3/8 @@ turn) 1 -- | <> -- > dartEx = drawHead dart dart :: ArrowHT -dart = arrowheadDart (2/5 :: Turn) +dart = arrowheadDart (2/5 @@ turn) -- | <> -- > missileEx = drawHead missile missile :: ArrowHT -missile = arrowheadMissile (2/5 :: Turn) +missile = arrowheadMissile (2/5 @@ turn) -- Tails ------------------------------------------------------------------ -- > drawTail t = arrowAt' (with & arrowTail .~ t & shaftStyle %~ lw 0 & arrowHead .~ noHead) @@ -255,7 +257,7 @@ t = reflectX t' j = reflectX j' -arrowtailBlock :: Angle a => a -> ArrowHT +arrowtailBlock :: Angle -> ArrowHT arrowtailBlock theta = aTail where aTail size _ = (t, mempty) @@ -268,16 +270,15 @@ x = magnitude b -- | The angle is where the top left corner intersects the circle. -arrowtailQuill :: Angle a => a -> ArrowHT +arrowtailQuill :: Angle -> ArrowHT arrowtailQuill theta =aTail where aTail size shaftWidth = (t, j) where t = ( closedPath $ trailFromVertices [v0, v1, v2, v3, v4, v5, v0] ) # scale size # alignR - theta' = toTurn theta v0 = p2 (0.5, 0) - v2 = p2 (unr2 $ e theta' # scaleR) + v2 = p2 (unr2 $ e theta # scaleR) v1 = v2 # translateX (5/4 * htRadius) v3 = p2 (-0.1, 0) v4 = v2 # reflectY @@ -329,10 +330,10 @@ -- > quillEx = drawTail quill quill :: ArrowHT -quill = arrowtailQuill (2/5 :: Turn) +quill = arrowtailQuill (2/5 @@ turn) -- | <> -- > blockEx = drawTail block block :: ArrowHT -block = arrowtailBlock (2/5 :: Turn) +block = arrowtailBlock (2/5 @@ turn) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -76,7 +76,7 @@ -- -- to place @c@ above @d@. The local origin of the resulting -- combined diagram is the same as the local origin of the first. --- @(|||)@ is associative and has 'mempty' as an identity. See the +-- @(===)@ is associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. (===) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (===) = beside (negateV unitY) @@ -84,7 +84,7 @@ -- | Place two diagrams (or other juxtaposable objects) horizontally -- adjacent to one another, with the first diagram to the left of -- the second. The local origin of the resulting combined diagram --- is the same as the local origin of the first. @(===)@ is +-- is the same as the local origin of the first. @(|||)@ is -- associative and has 'mempty' as an identity. See the -- documentation of 'beside' for more information. (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a @@ -95,7 +95,7 @@ -- 'th' from the first. The local origin of the resulting combined -- diagram is the same as the local origin of the first. -- See the documentation of 'beside' for more information. -atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a, Angle b) => b -> a -> a -> a +atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a) => Angle -> a -> a -> a atAngle th = beside (fromDirection th) -- | Lay out a list of juxtaposable objects in a row from left to right, diff --git a/src/Diagrams/TwoD/Curvature.hs b/src/Diagrams/TwoD/Curvature.hs --- a/src/Diagrams/TwoD/Curvature.hs +++ b/src/Diagrams/TwoD/Curvature.hs @@ -20,7 +20,6 @@ ) where import Data.Monoid.Inf -import Data.NumInstances.Tuple () import Data.VectorSpace import Control.Arrow (first, second) @@ -147,7 +146,7 @@ where (x' ,y' ) = seg `tangentAtParam` t (x'',y'') = secondDerivative - secondDerivative = (6*(3*t-2))*^b + (6-18*t)*^c + (6*t)*^d + secondDerivative = (6*(3*t-2))*^b ^+^ (6-18*t)*^c ^+^ (6*t)*^d -- TODO: We should be able to generalize this to higher dimensions. See -- diff --git a/src/Diagrams/TwoD/Deform.hs b/src/Diagrams/TwoD/Deform.hs new file mode 100644 --- /dev/null +++ b/src/Diagrams/TwoD/Deform.hs @@ -0,0 +1,36 @@ +module Diagrams.TwoD.Deform where + +import Control.Lens + +import Diagrams.Deform + +import Diagrams.Coordinates +import Diagrams.TwoD.Types + +-- | The parallel projection onto the line x=0 +parallelX0 :: Deformation R2 +parallelX0 = Deformation (& _x .~ 0) + +-- | The perspective division onto the line x=1 along lines going +-- through the origin. +perspectiveX1 :: Deformation R2 +perspectiveX1 = Deformation (\p -> p & _y //~ (p^._x) & _x .~ 1) + +-- | The parallel projection onto the line y=0 +parallelY0 :: Deformation R2 +parallelY0 = Deformation (& _y .~ 0) + +-- | The perspective division onto the line y=1 along lines going +-- through the origin. +perspectiveY1 :: Deformation R2 +perspectiveY1 = Deformation (\p -> p & _x //~ (p^._y) & _y .~ 1) + +-- | The viewing transform for a viewer facing along the positive X +-- axis. X coördinates stay fixed, while Y coördinates are compressed +-- with increasing distance. @asDeformation (translation unitX) <> +-- parallelX0 <> frustrumX = perspectiveX1@ +facingX :: Deformation R2 +facingX = Deformation (\v -> v & _y //~ (v^._x)) + +facingY :: Deformation R2 +facingY = Deformation (\v -> v & _x //~ (v^._y)) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -22,6 +22,8 @@ , ellipseXY ) where +import Data.AdditiveGroup + import Diagrams.Core import Diagrams.Located (at) @@ -33,7 +35,7 @@ -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ arcT 0 (tau::Rad) `at` (p2 (1,0)) +unitCircle = trailLike $ arcT zeroV fullTurn `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). diff --git a/src/Diagrams/TwoD/Image.hs b/src/Diagrams/TwoD/Image.hs --- a/src/Diagrams/TwoD/Image.hs +++ b/src/Diagrams/TwoD/Image.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Image @@ -19,19 +20,20 @@ , image ) where -import Control.Lens (makeLenses) +import Control.Lens (makeLenses) +import Data.Typeable -import Diagrams.Core +import Diagrams.Core -import Diagrams.Path -import Diagrams.TwoD.Types -import Diagrams.TwoD.Path -import Diagrams.TwoD.Shapes -import Diagrams.TwoD.Size (SizeSpec2D(..)) +import Diagrams.Path +import Diagrams.TwoD.Path +import Diagrams.TwoD.Shapes +import Diagrams.TwoD.Size (SizeSpec2D (..)) +import Diagrams.TwoD.Types -import Data.AffineSpace ((.-.)) +import Data.AffineSpace ((.-.)) -import Data.Semigroup +import Data.Semigroup -- | An external image primitive, representing an image the backend -- should import from another file when rendering. @@ -39,6 +41,7 @@ , _imgSize :: SizeSpec2D , _imgTransf :: T2 } + deriving Typeable makeLenses ''Image diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -38,9 +38,10 @@ ) where import Control.Applicative -import Control.Lens hiding (at, moveTo) +import Control.Lens hiding (at) import Data.AffineSpace +import Data.Maybe (catMaybes) import Data.Monoid import Data.Monoid.Inf import Data.VectorSpace @@ -263,9 +264,10 @@ -- loop. -> Located (Trail R2) -> Located (Trail R2) -offsetTrail' opts r t = joinSegments j isLoop (opts^.offsetMiterLimit) r ends . offset $ t +offsetTrail' opts r t = joinSegments eps j isLoop (opts^.offsetMiterLimit) r ends . offset $ t where - offset = map (bindLoc (offsetSegment (opts^.offsetEpsilon) r)) . locatedTrailSegments + eps = opts^.offsetEpsilon + offset = map (bindLoc (offsetSegment eps r)) . locatedTrailSegments ends | isLoop = (\(a:as) -> as ++ [a]) . trailVertices $ t | otherwise = tail . trailVertices $ t j = fromLineJoin (opts^.offsetJoin) @@ -356,8 +358,10 @@ expandLine :: ExpandOpts -> Double -> Located (Trail' Line R2) -> Located (Trail R2) expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) where - offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments - f r' = joinSegments (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends . offset r' $ t + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) False (opts^.expandMiterLimit) r' ends + . offset r' $ t ends = tail . trailVertices $ t s = atStart t e = atEnd t @@ -366,8 +370,10 @@ expandLoop :: ExpandOpts -> Double -> Located (Trail' Loop R2) -> Path R2 expandLoop opts r (mapLoc wrapLoop -> t) = (trailLike $ f r) <> (trailLike . reverseDomain . f $ -r) where - offset r' = map (bindLoc (offsetSegment (opts^.expandEpsilon) r')) . locatedTrailSegments - f r' = joinSegments (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends . offset r' $ t + eps = opts^.expandEpsilon + offset r' = map (bindLoc (offsetSegment eps r')) . locatedTrailSegments + f r' = joinSegments eps (fromLineJoin (opts^.expandJoin)) True (opts^.expandMiterLimit) r' ends + . offset r' $ t ends = (\(a:as) -> as ++ [a]) . trailVertices $ t -- | Expand a 'Trail' with the given radius and default options. See 'expandTrail''. @@ -456,10 +462,10 @@ -- Arc helpers arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcV u v = arc (direction u) (direction v :: Turn) +arcV u v = arc (direction u) (direction v) arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcVCW u v = arcCW (direction u) (direction v :: Turn) +arcVCW u v = arcCW (direction u) (direction v) -- | Join together a list of located trails with the given join style. The @@ -470,20 +476,25 @@ -- Note: this is not a general purpose join and assumes that we are joining an -- offset trail. For instance, a fixed radius arc will not fit between arbitrary -- trails without trimming or extending. -joinSegments :: (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) +joinSegments :: Double + -> (Double -> Double -> P2 -> Located (Trail R2) -> Located (Trail R2) -> Trail R2) -> Bool -> Double -> Double -> [Point R2] -> [Located (Trail R2)] -> Located (Trail R2) -joinSegments _ _ _ _ _ [] = mempty `at` origin -joinSegments _ _ _ _ [] _ = mempty `at` origin -joinSegments j isLoop ml r es ts@(t:_) = t' +joinSegments _ _ _ _ _ _ [] = mempty `at` origin +joinSegments _ _ _ _ _ [] _ = mempty `at` origin +joinSegments epsilon j isLoop ml r es ts@(t:_) = t' where - t' | isLoop = mapLoc (glueTrail . (<> mconcat (take (length ts) $ ss es (ts ++ [t])))) t - | otherwise = mapLoc (<> mconcat (ss es ts)) t - ss es' ts' = [j ml r e a b <> unLoc b | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + t' | isLoop = mapLoc (glueTrail . (<> f (take (length ts * 2 - 1) $ ss es (ts ++ [t])))) t + | otherwise = mapLoc (<> f (ss es ts)) t + ss es' ts' = concat [[test a b $ j ml r e a b, Just $ unLoc b] | (e,(a,b)) <- zip es' . (zip <*> tail) $ ts'] + test a b tj + | atStart b `distance` atEnd a > epsilon = Just tj + | otherwise = Nothing + f = mconcat . catMaybes -- | Take a join style and give the join function to be used by joinSegments. fromLineJoin diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -41,13 +41,13 @@ -- * Clipping - , Clip(..), clipBy + , Clip(..), clipBy, clipTo, clipped ) where import Control.Applicative (liftA2) import Control.Lens ( makeWrapped, makeLensesWith, (.~), (^.) , generateSignatures, lensRules, op - , Lens, Lens', unwrapped) + , Lens, Lens', _Wrapped') import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable @@ -56,8 +56,10 @@ import Data.Default.Class import Data.VectorSpace +import Diagrams.Combinators (withEnvelope, withTrace) import Diagrams.Coordinates import Diagrams.Core +import Diagrams.Core.Trace import Diagrams.Located (Located, mapLoc, unLoc) import Diagrams.Parametric import Diagrams.Path @@ -167,12 +169,12 @@ -- -- * Names can be assigned to the path's vertices -- --- 'StrokeOpts' is an instance of 'Default', so @stroke' 'with' { --- ... }@ syntax may be used. +-- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & +-- ... )@ syntax may be used. stroke' :: (Renderable (Path R2) b, IsName a) => StrokeOpts a -> Path R2 -> Diagram b R2 stroke' opts path - | null (pLines ^. unwrapped) = mkP pLoops - | null (pLoops ^. unwrapped) = mkP pLines + | null (pLines ^. _Wrapped') = mkP pLoops + | null (pLoops ^. _Wrapped') = mkP pLines | otherwise = mkP pLines <> mkP pLoops where (pLines,pLoops) = partitionPath (isLine . unLoc) path @@ -361,7 +363,30 @@ clipBy :: (HasStyle a, V a ~ R2) => Path R2 -> a -> a clipBy = applyTAttr . Clip . (:[]) --- XXX Should include a 'clipTo' function which clips a diagram AND --- restricts its envelope. It will have to take a *pointwise minimum* --- of the diagram's current envelope and the path's envelope. Not --- sure of the best way to do this at the moment. +-- | Clip a diagram to the given path setting its envelope to the +-- pointwise minimum of the envelopes of the diagram and path. The +-- trace consists of those parts of the original diagram's trace +-- which fall within the clipping path, or parts of the path's trace +-- within the original diagram. +clipTo :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 +clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d + where + envP = appEnvelope . getEnvelope $ p + envD = appEnvelope . getEnvelope $ d + toEnvelope = case (envP, envD) of + (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) + (_, _) -> id + intersectionTrace = Trace intersections + intersections pt v = + -- on boundary of d, inside p + onSortedList (filter pInside) (appTrace (getTrace d) pt v) <> + -- or on boundary of p, inside d + onSortedList (filter dInside) (appTrace (getTrace p) pt v) where + newPt dist = pt .+^ v ^* dist + pInside dDist = runFillRule Winding (newPt dDist) p + dInside pDist = getAny . sample d $ newPt pDist + +-- | Clip a diagram to the clip path taking the envelope and trace of the clip +-- path. +clipped :: (Renderable (Path R2) b) => Path R2 -> Diagram b R2 -> Diagram b R2 +clipped p = (withTrace p) . (withEnvelope p) . (clipBy p) diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -45,7 +45,8 @@ ) where -import Control.Lens hiding (transform, at, (<.>), (&), (#)) +import Control.Lens (Lens', generateSignatures, lensRules, + makeLensesWith, (.~), (^.), view) import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, @@ -57,8 +58,7 @@ import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class -import Data.VectorSpace (magnitude, normalized, project, (<.>), - (^*)) +import Data.VectorSpace import Diagrams.Core import Diagrams.Located @@ -72,7 +72,7 @@ import Diagrams.Util (tau, ( # )) -- | Method used to determine the vertices of a polygon. -data PolyType = forall a. Angle a => PolyPolar [a] [Double] +data PolyType = PolyPolar [Angle] [Double] -- ^ A \"polar\" polygon. -- -- * The first argument is a list of /central/ @@ -89,7 +89,7 @@ -- circle) can be constructed using a second -- argument of @(repeat r)@. - | forall a. Angle a => PolySides [a] [Double] + | PolySides [Angle] [Double] -- ^ A polygon determined by the distance between -- successive vertices and the angles formed by -- each three successive vertices. In other @@ -180,7 +180,7 @@ -- | Generate the located trail of a polygon specified by polar data -- (central angles and radii). See 'PolyPolar'. -polyPolarTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polyPolarTrail :: [Angle] -> [Double] -> Located (Trail R2) polyPolarTrail [] _ = emptyTrail `at` origin polyPolarTrail _ [] = emptyTrail `at` origin polyPolarTrail ans (r:rs) = tr `at` p1 @@ -189,16 +189,16 @@ tr = closeTrail . trailFromVertices $ zipWith (\a l -> rotate a . scale l $ p2 (1,0)) - (scanl (+) 0 ans) + (scanl (^+^) zeroV ans) (r:rs) -- | Generate the vertices of a polygon specified by side length and -- angles, and a starting point for the trail such that the origin -- is at the centroid of the vertices. See 'PolySides'. -polySidesTrail :: Angle a => [a] -> [Double] -> Located (Trail R2) +polySidesTrail :: [Angle] -> [Double] -> Located (Trail R2) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where - ans' = scanl (+) 0 ans + ans' = scanl (^+^) zeroV ans offsets = zipWith rotate ans' (map (unitY ^*) ls) ps = scanl (.+^) origin offsets tr = closeTrail . trailFromOffsets $ offsets @@ -206,7 +206,7 @@ -- | Generate the vertices of a regular polygon. See 'PolyRegular'. polyRegularTrail :: Int -> Double -> Located (Trail R2) polyRegularTrail n r = polyPolarTrail - (take (n-1) . repeat $ (tau::Rad) / fromIntegral n) + (take (n-1) . repeat $ fullTurn ^/ fromIntegral n) (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ @@ -223,17 +223,21 @@ (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) sndOf3 (_,b,_) = b - a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] + a :: Angle + a = minimumBy (comparing $ abs . view rad) + . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v + angleFromNormal :: R2 -> Angle angleFromNormal o | leftTurn o' v' = phi - | otherwise = negate phi + | otherwise = negateV phi where o' = normalized o theta = acos (v' <.> o') + phi :: Angle phi - | theta <= tau/4 = Rad $ tau/4 - theta - | otherwise = Rad $ theta - tau/4 + | theta <= tau/4 = tau/4 - theta @@ rad + | otherwise = theta - tau/4 @@ rad ------------------------------------------------------------ -- Function graphs diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -24,7 +24,6 @@ import Control.Applicative (liftA2) import Data.AffineSpace -import Data.Monoid.Inf hiding (minimum) import Data.VectorSpace import Diagrams.Core @@ -38,6 +37,10 @@ import Diagrams.TwoD.Vector import Diagrams.Util +{- All instances of Traced should maintain the invariant that the list of + traces is sorted in increasing order. +-} + instance Traced (Segment Closed R2) where getTrace = getTrace . mkFixedSeg . (`at` origin) @@ -73,8 +76,8 @@ t1 = (perp v0 <.> p) / det in if det == 0 || t0 < 0 || t0 > 1 - then Infinity - else Finite t1 + then mkSortedList [] + else mkSortedList [t1] {- To do intersection of a line with a cubic Bezier, we first rotate and scale everything so that the line has parameters (origin, unitX); @@ -90,7 +93,7 @@ let bez'@(FCubic x1 c1 c2 x2) = bez # moveOriginTo p1 - # rotateBy (negate (direction v1)) + # rotate (negateV (direction v1)) # scale (1/magnitude v1) [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] a = -y0 + 3*y1 - 3*y2 + y3 @@ -100,7 +103,5 @@ ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d) xs = map (fst . unp2 . atParam bez') ts in - case xs of - [] -> Infinity - _ -> Finite (minimum xs) + mkSortedList xs diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -59,7 +59,7 @@ import Diagrams.Util -import Control.Lens (makeLenses, op, (.~), (^.), (&)) +import Control.Lens (makeLenses, op, (&), (.~), (^.)) import Data.Default.Class import Data.Semigroup @@ -140,7 +140,7 @@ regPoly :: (TrailLike t, V t ~ R2) => Int -> Double -> t regPoly n l = polygon (def & polyType .~ PolySides - (repeat (1/ fromIntegral n :: Turn)) + (repeat (1/fromIntegral n @@ turn)) (replicate (n-1) l) & polyOrient .~ OrientH ) @@ -311,4 +311,4 @@ mkCorner k r | r == 0 = mempty | r < 0 = doArc 3 2 | otherwise = doArc 0 1 - where doArc d d' = arc' r ((k+d)/4) ((k+d')/4:: Turn) + where doArc d d' = arc' r ((k+d)/4 @@ turn) ((k+d')/4 @@ turn) diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -54,6 +54,7 @@ -- vector space of the text to the vector space in which it is -- embedded. data Text = Text T2 TextAlignment String + deriving Typeable type instance V Text = R2 diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -59,50 +59,52 @@ import Diagrams.TwoD.Vector (direction) import Diagrams.Coordinates +import Data.AdditiveGroup import Data.AffineSpace import Data.Semigroup +import Control.Lens (review, (^.)) -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local -- origin by the given angle. See also 'rotate'. -rotation :: Angle a => a -> T2 +rotation :: Angle -> T2 rotation ang = fromLinear r (linv r) where r = rot theta <-> rot (-theta) - Rad theta = convertAngle ang + theta = ang^.rad rot th (coords -> x :& y) = (cos th * x - sin th * y) ^& (sin th * x + cos th * y) -- | Rotate about the local origin by the given angle. Positive angles -- correspond to counterclockwise rotation, negative to --- clockwise. The angle can be expressed using any type which is an --- instance of 'Angle'. For example, @rotate (1\/4 :: --- 'Turn')@, @rotate (tau\/4 :: 'Rad')@, and @rotate (90 :: --- 'Deg')@ all represent the same transformation, namely, a --- counterclockwise rotation by a right angle. To rotate about some --- point other than the local origin, see 'rotateAbout'. +-- clockwise. The angle can be expressed using any of the 'Iso's on +-- 'Angle'. For example, @rotate (1\/4 \@\@ 'turn')@, @rotate +-- (tau\/4 \@\@ rad)@, and @rotate (90 \@\@ deg)@ all +-- represent the same transformation, namely, a counterclockwise +-- rotation by a right angle. To rotate about some point other than +-- the local origin, see 'rotateAbout'. -- --- Note that writing @rotate (1\/4)@, with no type annotation, will --- yield an error since GHC cannot figure out which sort of angle --- you want to use. In this common situation you can use --- 'rotateBy', which is specialized to take a 'Turn' argument. -rotate :: (Transformable t, V t ~ R2, Angle a) => a -> t -> t +-- Note that writing @rotate (1\/4)@, with no 'Angle' constructor, +-- will yield an error since GHC cannot figure out which sort of +-- angle you want to use. In this common situation you can use +-- 'rotateBy', which interprets its argument as a number of turns. +rotate :: (Transformable t, V t ~ R2) => Angle -> t -> t rotate = transform . rotation --- | A synonym for 'rotate', specialized to only work with --- @Turn@ arguments; it can be more convenient to write --- @rotateBy (1\/4)@ than @'rotate' (1\/4 :: 'Turn')@. -rotateBy :: (Transformable t, V t ~ R2) => Turn -> t -> t -rotateBy = transform . rotation +-- | A synonym for 'rotate', interpreting its argument in units of +-- turns; it can be more convenient to write @rotateBy (1\/4)@ than +-- @'rotate' (1\/4 \@\@ 'turn')@. +rotateBy :: (Transformable t, V t ~ R2) => Double -> t -> t +rotateBy = transform . rotation . review turn -- | @rotationAbout p@ is a rotation about the point @p@ (instead of -- around the local origin). -rotationAbout :: Angle a => P2 -> a -> T2 +rotationAbout :: P2 -> Angle -> T2 rotationAbout p angle = conjugate (translation (origin .-. p)) (rotation angle) -- | @rotateAbout p@ is like 'rotate', except it rotates around the -- point @p@ instead of around the local origin. -rotateAbout :: (Transformable t, V t ~ R2, Angle a) => P2 -> a -> t -> t +rotateAbout :: (Transformable t, V t ~ R2) => P2 -> Angle -> t -> t rotateAbout p angle = rotate angle `under` translation (origin .-. p) -- Scaling ------------------------------------------------- @@ -203,7 +205,7 @@ -- the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 reflectionAbout p v = - conjugate (rotation (-direction v :: Rad) <> translation (origin .-. p)) + conjugate (rotation (negateV $ direction v) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -20,8 +21,10 @@ where import Control.Lens (makeLenses, view) +import Data.AdditiveGroup import Data.AffineSpace ((.-.)) import Data.Semigroup +import Data.Typeable import Diagrams.Core import Diagrams.TwoD.Transform @@ -61,11 +64,11 @@ data ScaleInv t = ScaleInv - { _scaleInvObj :: t + { _scaleInvObj :: t , _scaleInvDir :: R2 , _scaleInvLoc :: P2 } - deriving (Show) + deriving (Show, Typeable) makeLenses ''ScaleInv @@ -82,8 +85,7 @@ instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - angle :: Rad - angle = direction (transform tr v) - direction v + angle = direction (transform tr v) ^-^ direction v rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l @@ -184,6 +186,6 @@ -- 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) +scaleInvPrim :: (Transformable t, Typeable 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 diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -26,25 +26,21 @@ , T2 -- * Angles - , Angle(..) - - , Turn(..), asTurn, CircleFrac - , Rad(..), asRad - , Deg(..), asDeg - , fullTurn, fullCircle, convertAngle, angleRatio + , Angle + , rad, turn, deg + , fullTurn, fullCircle, angleRatio + , (@@) ) where -import Control.Lens (Iso', Wrapped, iso, makeWrapped, op, - wrapped, _1, _2) +import Control.Lens (Iso', Wrapped(..), Rewrapped, iso + , review , (^.), _1, _2) import Diagrams.Coordinates import Diagrams.Core -import Diagrams.Util (tau) import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) -import Data.NumInstances.Tuple () import Data.VectorSpace import Data.Typeable @@ -136,10 +132,13 @@ mkR2 = curry r2 -- | Lens wrapped isomorphisms for R2. -instance Wrapped (Double, Double) (Double, Double) R2 R2 where - wrapped = iso r2 unr2 - {-# INLINE wrapped #-} +instance Wrapped R2 where + type Unwrapped R2 = (Double, Double) + _Wrapped' = iso unr2 r2 + {-# INLINE _Wrapped' #-} +instance Rewrapped R2 R2 + type instance V R2 = R2 instance VectorSpace R2 where @@ -239,98 +238,52 @@ ------------------------------------------------------------ -- Angles --- | Newtype wrapper used to represent angles as fractions of a --- circle. For example, 1\/3 turn = tau\/3 radians = 120 degrees. -newtype Turn = Turn Double - deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup) - -makeWrapped ''Turn - -instance VectorSpace Turn where - type Scalar Turn = Double - s *^ Turn t = Turn (s*t) - --- | The identity function with a restricted type, for conveniently --- declaring that some value should have type 'Turn'. For example, --- @rotation . asTurn . fromRational@ constructs a rotation from a --- rational value considered as a @Turn@. Without @asTurn@, the angle --- type would be ambiguous. -asTurn :: Turn -> Turn -asTurn = id - --- | Deprecated synonym for 'Turn', retained for backwards compatibility. -type CircleFrac = Turn - --- | Newtype wrapper for representing angles in radians. -newtype Rad = Rad Double - deriving (Read, Show, Eq, Ord, Enum, Floating, Fractional, Num, Real, RealFloat, RealFrac, AdditiveGroup) - -makeWrapped ''Rad - -instance VectorSpace Rad where - type Scalar Rad = Double - s *^ Rad r = Rad (s*r) - --- | The identity function with a restricted type, for conveniently --- declaring that some value should have type 'Rad'. For example, --- @rotation . asRad . fromRational@ constructs a rotation from a --- rational value considered as a value in radians. Without @asRad@, --- the angle type would be ambiguous. -asRad :: Rad -> Rad -asRad = id - --- | Newtype wrapper for representing angles in degrees. -newtype Deg = Deg Double - deriving (Read, Show, Eq, Ord, Enum, Fractional, Num, Real, RealFrac, AdditiveGroup) - -makeWrapped ''Deg - -instance VectorSpace Deg where - type Scalar Deg = Double - s *^ Deg d = Deg (s*d) - --- | The identity function with a restricted type, for conveniently --- declaring that some value should have type 'Deg'. For example, --- @rotation . asDeg . fromIntegral@ constructs a rotation from an --- integral value considered as a value in degrees. Without @asDeg@, --- the angle type would be ambiguous. -asDeg :: Deg -> Deg -asDeg = id - --- | Type class for types that measure angles. -class Num a => Angle a where - -- | Convert to a turn, /i.e./ a fraction of a circle. - toTurn :: a -> Turn +-- | Angles can be expressed in a variety of units. Internally, +-- they are represented in radians. +newtype Angle = Radians Double + deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) - -- | Convert from a turn, /i.e./ a fraction of a circle. - fromTurn :: Turn -> a +instance VectorSpace Angle where + type Scalar Angle = Double + s *^ Radians t = Radians (s*t) -instance Angle Turn where - toTurn = id - fromTurn = id +-- | The radian measure of an @Angle@ @a@ can be accessed as @a +-- ^. rad@. A new @Angle@ can be defined in radians as @pi \@\@ rad@. +rad :: Iso' Angle Double +rad = iso (\(Radians r) -> r) Radians --- | tau radians = 1 full turn. -instance Angle Rad where - toTurn = Turn . (/tau) . op Rad - fromTurn = Rad . (*tau) . op Turn +-- | The measure of an @Angle@ @a@ in full circles can be accessed as +-- @a ^. turn@. A new @Angle@ of one-half circle can be defined in as +-- @1/2 \@\@ turn@. +turn :: Iso' Angle Double +turn = iso (\(Radians r) -> r/2/pi) (Radians . (*(2*pi))) --- | 360 degrees = 1 full turn. -instance Angle Deg where - toTurn = Turn . (/360) . op Deg - fromTurn = Deg . (*360) . op Turn +-- | The degree measure of an @Angle@ @a@ can be accessed as @a +-- ^. deg@. A new @Angle@ can be defined in degrees as @180 \@\@ +-- deg@. +deg :: Iso' Angle Double +deg = iso (\(Radians r) -> r/2/pi*360) (Radians . (*(2*pi/360))) -- | An angle representing one full turn. -fullTurn :: Angle a => a -fullTurn = fromTurn 1 +fullTurn :: Angle +fullTurn = 1 @@ turn -- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle a => a +fullCircle :: Angle fullCircle = fullTurn --- | Convert between two angle representations. -convertAngle :: (Angle a, Angle b) => a -> b -convertAngle = fromTurn . toTurn +-- | Calculate ratio between two angles. +angleRatio :: Angle -> Angle -> Double +angleRatio a b = (a^.rad) / (b^.rad) --- | Calculate ratio between two angles -angleRatio :: Angle a => a -> a -> Double -angleRatio a b = op Turn (toTurn a) / op Turn (toTurn b) + +-- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. +-- +-- More generally, @\@\@@ reverses the @Iso\'@ on its right, and +-- applies the @Iso\'@ to the value on the left. @Angle@s are the +-- motivating example where this order improves readability. +(@@) :: b -> Iso' a b -> a +-- The signature above is slightly specialized, in favor of readability +a @@ i = review i a + +infixl 5 @@ diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -22,6 +22,8 @@ , perp, leftTurn ) where +import Control.Lens ((^.)) +import Data.AdditiveGroup import Data.VectorSpace ((<.>)) import Diagrams.TwoD.Types import Diagrams.Coordinates @@ -45,25 +47,25 @@ -- | Compute the direction of a vector, measured counterclockwise from -- the positive x-axis as a fraction of a full turn. The zero -- vector is arbitrarily assigned the direction 0. -direction :: Angle a => R2 -> a -direction (coords -> x :& y) = convertAngle . Rad $ atan2 y x +direction :: R2 -> Angle +direction (coords -> x :& y) = atan2 y x @@ rad -- | Compute the counterclockwise angle from the first vector to the second. -angleBetween :: (Angle a, Num a, Ord a) => R2 -> R2 -> a +angleBetween :: R2 -> R2 -> Angle angleBetween v1 v2 - | d2 > d1 = d2 - d1 - | otherwise = fullTurn + d2 - d1 + | d2 > d1 = d2 ^-^ d1 + | otherwise = fullTurn ^+^ d2 ^-^ d1 where d1 = direction v1 d2 = direction v2 -- | Convert an angle into a unit vector pointing in that direction. -fromDirection :: Angle a => a -> R2 +fromDirection :: Angle -> R2 fromDirection a = cos a' ^& sin a' - where Rad a' = convertAngle a + where a' = a^.rad -- | A convenient synonym for 'fromDirection'. -e :: Angle a => a -> R2 +e :: Angle -> R2 e = fromDirection -- | @perp v@ is perpendicular to and has the same magnitude as @v@.