diff --git a/.travis.yml b/.travis.yml index 2b9156e4..f2cc77c8 100644 --- a/.travis.yml +++ b/.travis.yml @@ -6,6 +6,7 @@ env: - HPVER=2013.2.0.0 - GHCVER=7.4.2 - GHCVER=7.6.3 + - GHCVER=7.8.1 - GHCVER=head global: - CABALVER=1.18 diff --git a/CHANGES.markdown b/CHANGES.markdown index fffbc013..6d020ad9 100644 --- a/CHANGES.markdown +++ b/CHANGES.markdown @@ -1,3 +1,87 @@ +1.1.0.3 (19 March 2014) +---------------------- + + - Allow `lens-4.1` + +1.1.0.2 (18 March 2014) +----------------------- + + - Allow `optparse-applicative-0.8` + +1.1.0.1 (9 March 2014) +---------------------- + + - Allow `vector-space-points-0.2` + +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 index 1a60252f..45b0b227 100644 --- 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 index 8e3fb5b2..5faca040 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -1,5 +1,5 @@ Name: diagrams-lib -Version: 1.1 +Version: 1.1.0.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,7 +19,7 @@ Build-type: Simple 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 @@ -28,9 +28,11 @@ Library Exposed-modules: Diagrams.Prelude, Diagrams.Prelude.ThreeD, Diagrams.Align, + Diagrams.Angle, Diagrams.Combinators, Diagrams.Coordinates, Diagrams.Attributes, + Diagrams.Attributes.Compile, Diagrams.Points, Diagrams.Located, Diagrams.Parametric, @@ -63,7 +65,6 @@ Library Diagrams.TwoD.Ellipse, Diagrams.TwoD.Arc, Diagrams.TwoD.Segment, - Diagrams.TwoD.Compile, Diagrams.TwoD.Curvature, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, @@ -76,6 +77,7 @@ Library Diagrams.TwoD.Image, Diagrams.TwoD.Adjust, Diagrams.ThreeD.Align, + Diagrams.ThreeD.Attributes, Diagrams.ThreeD.Camera, Diagrams.ThreeD.Deform, Diagrams.ThreeD.Light, @@ -94,19 +96,19 @@ Library 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, + vector-space-points >= 0.1.2 && < 0.3, MemoTrie >= 0.6 && < 0.7, 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 >= 4.0 && < 4.1, + lens >= 4.0 && < 4.2, tagged >= 0.7, - optparse-applicative >= 0.7 && < 0.8, + optparse-applicative >= 0.7 && < 0.9, filepath, safe >= 0.2 && < 0.4, hashable >= 1.1 && < 1.3 diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs new file mode 100644 index 00000000..add94628 --- /dev/null +++ b/src/Diagrams/Angle.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Angle +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing angles, independent of vector-space +-- +----------------------------------------------------------------------------- + +module Diagrams.Angle + ( + Angle + , rad, turn, deg + , fullTurn, fullCircle, angleRatio + , sinA, cosA, tanA, asinA, acosA, atanA + , (@@) + , angleBetween + , HasTheta(..) + ) where + +import Control.Lens (Iso', Lens', iso, review, (^.)) + -- , review , (^.), _1, _2, Lens', lens) + +import Data.VectorSpace + +-- | 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) + +instance VectorSpace Angle where + type Scalar Angle = Double + s *^ Radians t = Radians (s*t) + +-- | 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 + +-- | 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))) + +-- | 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 +fullTurn = 1 @@ turn + +-- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. +fullCircle :: Angle +fullCircle = fullTurn + +-- | Calculate ratio between two angles. +angleRatio :: Angle -> Angle -> Double +angleRatio a b = (a^.rad) / (b^.rad) + +-- | The sine of the given @Angle@. +sinA :: Angle -> Double +sinA (Radians r) = sin r + +-- | The cosine of the given @Angle@. +cosA :: Angle -> Double +cosA (Radians r) = cos r + +-- | The tangent function of the given @Angle@. +tanA :: Angle -> Double +tanA (Radians r) = tan r + +-- | The @Angle@ with the given sine. +asinA :: Double -> Angle +asinA = Radians . asin + +-- | The @Angle@ with the given cosine. +acosA :: Double -> Angle +acosA = Radians . acos + +-- | The @Angle@ with the given tangent. +atanA :: Double -> Angle +atanA = Radians . atan + +-- | @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 @@ + +-- | compute the positive angle between the two vectors in their common plane +angleBetween :: (InnerSpace v, Scalar v ~ Double) => v -> v -> Angle +angleBetween v1 v2 = acos (normalized v1 <.> normalized v2) @@ rad + +------------------------------------------------------------ +-- Polar Coordinates + +-- | The class of types with at least one angle coordinate, called _theta. +class HasTheta t where + _theta :: Lens' t Angle diff --git a/src/Diagrams/Attributes.hs b/src/Diagrams/Attributes.hs index a2760187..eac42d4d 100644 --- 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 @@ -49,24 +51,28 @@ module Diagrams.Attributes ( -- ** Miter limit , LineMiterLimit(..), getLineMiterLimit, lineMiterLimit, lineMiterLimitA - -- ** 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 (RGB(..)) -import Data.Colour.SRGB (toSRGB) +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 ------------------------------------------------- @@ -333,24 +339,21 @@ lineMiterLimit = applyAttr . LineMiterLimit . Last -- | Apply a 'LineMiterLimit' attribute. lineMiterLimitA :: HasStyle a => LineMiterLimit -> a -> a lineMiterLimitA = applyAttr +------------------------------------------------------------ --- | Create lines that are dashing... er, dashed. -data Dashing = Dashing [Double] Double - deriving (Typeable, Eq) +data FillLoops v = FillLoops -newtype DashingA = DashingA (Last Dashing) - deriving (Typeable, Semigroup, Eq) -instance AttributeClass DashingA - -getDashing :: DashingA -> Dashing -getDashing (DashingA (Last d)) = d - --- | Set the line dashing style. -dashing :: HasStyle a => - [Double] -- ^ A list specifying alternate lengths of on - -- and off portions of the stroke. The empty - -- list indicates no dashing. - -> Double -- ^ An offset into the dash pattern at which the - -- stroke should start. - -> a -> a -dashing ds offs = applyAttr (DashingA (Last (Dashing ds offs))) +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 index 00000000..8daa8028 --- /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/Backend/Show.hs b/src/Diagrams/Backend/Show.hs index e45dcb82..1aef14b9 100644 --- a/src/Diagrams/Backend/Show.hs +++ b/src/Diagrams/Backend/Show.hs @@ -36,8 +36,7 @@ instance HasLinearMap v => Backend ShowBackend v where data Options ShowBackend v = SBOpt doRender _ _ (SR r) = PP.render r - renderRTree _ = SR empty - renderData _ _ _ _ = SR empty + renderData _ _ _ = SR empty instance Monoid (Render ShowBackend v) where mempty = SR empty diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index f5939bf9..96224ab8 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} @@ -45,7 +46,9 @@ import Control.Lens (Lens', generateSignatures, lensField, import Data.AdditiveGroup import Data.AffineSpace ((.+^)) import Data.Default.Class +#if __GLASGOW_HASKELL__ < 707 import Data.Proxy +#endif import Data.Semigroup import Data.VectorSpace diff --git a/src/Diagrams/Coordinates.hs b/src/Diagrams/Coordinates.hs index 01e47fd6..11065a61 100644 --- a/src/Diagrams/Coordinates.hs +++ b/src/Diagrams/Coordinates.hs @@ -16,7 +16,7 @@ module Diagrams.Coordinates ( (:&)(..), Coordinates(..) -- * Lenses for particular axes - , HasX(..), HasY(..), HasZ(..) + , HasX(..), HasY(..), HasZ(..), HasR(..) ) where @@ -121,3 +121,8 @@ class HasY t where -- | The class of types with at least three coordinates, the third called _z. class HasZ t where _z :: Lens' t Double + +-- | The class of types with a single length coordinate _r. _r is +-- magnitude of a vector, or the distance from the origin of a point. +class HasR t where + _r :: Lens' t Double diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 5bb0c055..fd5a1b57 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -44,7 +44,7 @@ module Diagrams.Path , pathVertices , pathOffsets , pathCentroid - , fixPath + , pathLocSegments, fixPath -- * Modifying paths @@ -187,6 +187,11 @@ pathOffsets = map (trailOffset . unLoc) . op Path pathCentroid :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> Point v pathCentroid = centroid . concat . pathVertices +-- | Convert a path into a list of lists of located segments. +pathLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Path v -> [[Located (Segment Closed v)]] +pathLocSegments = map trailLocSegments . op Path + -- | Convert a path into a list of lists of 'FixedSegment's. fixPath :: (InnerSpace v, OrderedField (Scalar v)) => Path v -> [[FixedSegment v]] fixPath = map fixTrail . op Path diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 2ca15805..ad0ccd53 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -84,8 +84,10 @@ module Diagrams.Prelude -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional @@ -123,6 +125,7 @@ module Diagrams.Prelude import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/Prelude/ThreeD.hs b/src/Diagrams/Prelude/ThreeD.hs index 082150b6..0f1f91d2 100644 --- a/src/Diagrams/Prelude/ThreeD.hs +++ b/src/Diagrams/Prelude/ThreeD.hs @@ -80,8 +80,11 @@ module Diagrams.Prelude.ThreeD -- | Utilities for working with points. , module Diagrams.Points + -- | Angles + , module Diagrams.Angle + -- | Convenience infix operators for working with coordinates. - , module Diagrams.Coordinates + , module Diagrams.Coordinates -- | things (shapes, transformations, combinators) specific -- to creating three-dimensional diagrams. @@ -118,6 +121,7 @@ module Diagrams.Prelude.ThreeD import Diagrams.Core import Diagrams.Align +import Diagrams.Angle import Diagrams.Animation import Diagrams.Attributes import Diagrams.Combinators diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index bfaea3f0..c77469a2 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -493,7 +493,7 @@ instance (InnerSpace v, OrderedField (Scalar v)) => Semigroup (OffsetEnvelope v) (OffsetEnvelope o1 e1) <> (OffsetEnvelope o2 e2) = let !negOff = negateV . op TotalOffset $ o1 e2Off = moveOriginBy negOff e2 - !() = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off + !_unused = maybe () (\f -> f `seq` ()) $ appEnvelope e2Off in OffsetEnvelope (o1 <> o2) (e1 <> e2Off) diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 3f973834..2f342a51 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -31,7 +31,9 @@ -- for rendering 3D geometry to (2D) images. ----------------------------------------------------------------------------- module Diagrams.ThreeD - ( module Diagrams.ThreeD.Align + ( + module Diagrams.ThreeD.Align + , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera , module Diagrams.ThreeD.Light , module Diagrams.ThreeD.Shapes @@ -41,6 +43,7 @@ module Diagrams.ThreeD ) where import Diagrams.ThreeD.Align +import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes diff --git a/src/Diagrams/ThreeD/Attributes.hs b/src/Diagrams/ThreeD/Attributes.hs new file mode 100644 index 00000000..52c013ef --- /dev/null +++ b/src/Diagrams/ThreeD/Attributes.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.ThreeD.Attributes +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Diagrams may have /attributes/ which affect the way they are +-- rendered. This module defines some common attributes relevant in +-- 3D; particular backends may also define more backend-specific +-- attributes. +-- +-- Every attribute type must have a /semigroup/ structure, that is, an +-- associative binary operation for combining two attributes into one. +-- Unless otherwise noted, all the attributes defined here use the +-- 'Last' structure, that is, combining two attributes simply keeps +-- the second one and throws away the first. This means that child +-- attributes always override parent attributes. +-- +----------------------------------------------------------------------------- + +module Diagrams.ThreeD.Attributes where + +import Control.Lens +import Data.Semigroup +import Data.Typeable + +import Data.Colour + +import Diagrams.Core + +-- | @SurfaceColor@ is the inherent pigment of an object, assumed to +-- be opaque. +newtype SurfaceColor = SurfaceColor (Last (Colour Double)) + deriving (Typeable, Semigroup) +instance AttributeClass SurfaceColor + +surfaceColor :: Iso' SurfaceColor (Colour Double) +surfaceColor = iso (\(SurfaceColor (Last c)) -> c) (SurfaceColor . Last) + +-- | Set the surface color. +sc :: HasStyle d => Colour Double -> d -> d +sc = applyAttr . review surfaceColor + +-- | @Diffuse@ is the fraction of incident light reflected diffusely, +-- that is, in all directions. The actual light reflected is the +-- product of this value, the incident light, and the @SurfaceColor@ +-- Attribute. For physical reasonableness, @Diffuse@ should have a +-- value between 0 and 1; this is not checked. +newtype Diffuse = Diffuse (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Diffuse + +_Diffuse :: Iso' Diffuse Double +_Diffuse = iso (\(Diffuse (Last d)) -> d) (Diffuse . Last) + +-- | Set the diffuse reflectance. +diffuse :: HasStyle d => Double -> d -> d +diffuse = applyAttr . review _Diffuse + +-- | @Ambient@ is an ad-hoc representation of indirect lighting. The +-- product of @Ambient@ and @SurfaceColor@ is added to the light +-- leaving an object due to diffuse and specular terms. @Ambient@ can +-- be set per-object, and can be loosely thought of as the product of +-- indirect lighting incident on that object and the diffuse +-- reflectance. +newtype Ambient = Ambient (Last Double) + deriving (Typeable, Semigroup) +instance AttributeClass Ambient + +_Ambient :: Iso' Ambient Double +_Ambient = iso (\(Ambient (Last d)) -> d) (Ambient . Last) + +-- | Set the emittance due to ambient light. +ambient :: HasStyle d => Double -> d -> d +ambient = applyAttr . review _Ambient + +-- | A specular highlight has two terms, the intensity, between 0 and +-- 1, and the size. The highlight size is assumed to be the exponent +-- in a Phong shading model (though Backends are free to use a +-- different shading model). In this model, reasonable values are +-- between 1 and 50 or so, with higher values for shinier objects. +-- Physically, the intensity and the value of @Diffuse@ must add up to +-- less than 1; this is not enforced. +data Specular = Specular { _specularIntensity :: Double + , _specularSize :: Double + } + +makeLenses ''Specular + +newtype Highlight = Highlight (Last Specular) + deriving (Typeable, Semigroup) +instance AttributeClass Highlight + +_Highlight :: Iso' Highlight Specular +_Highlight = iso (\(Highlight (Last s)) -> s) (Highlight . Last) + +-- | Set the specular highlight. +highlight :: HasStyle d => Specular -> d -> d +highlight = applyAttr . review _Highlight diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 01a22b90..11246992 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -34,6 +34,7 @@ import Data.Cross import Data.Monoid import Data.Typeable +import Diagrams.Angle import Diagrams.Core import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector @@ -117,13 +118,13 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resulotions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: Direction d => Camera l -> d +camForward :: Camera l -> Direction camForward = direction . forward -camUp :: Direction d => Camera l -> d +camUp :: Camera l -> Direction camUp = direction . up -camRight :: Direction d => Camera l -> d +camRight :: Camera l -> Direction camRight c = direction right where right = cross3 (forward c) (up c) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index ed3485ce..2333ef2e 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -22,7 +22,6 @@ import Data.Typeable import Diagrams.Core import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector data PointLight = PointLight P3 (Colour Double) deriving Typeable @@ -48,8 +47,8 @@ pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty (Query . const . Any $ False) -- | Construct a Diagram with a single ParallelLight, which takes up no space. -parallelLight :: (Direction d, Backend b R3, Renderable ParallelLight b) - => d -- ^ The direction in which the light travels. +parallelLight :: (Backend b R3, Renderable ParallelLight b) + => Direction -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b R3 parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) diff --git a/src/Diagrams/ThreeD/Shapes.hs b/src/Diagrams/ThreeD/Shapes.hs index 7f9e977f..e524068c 100644 --- a/src/Diagrams/ThreeD/Shapes.hs +++ b/src/Diagrams/ThreeD/Shapes.hs @@ -15,18 +15,24 @@ module Diagrams.ThreeD.Shapes ( - Ellipsoid(..) - , sphere + Ellipsoid(..), sphere + , Box(..), cube + , Frustum(..) , frustum, cone, cylinder ) where +import Control.Applicative +import Control.Lens (review, (^.), _1) import Data.Typeable import Data.AffineSpace import Data.Semigroup import Data.VectorSpace +import Diagrams.Angle +import Diagrams.Coordinates import Diagrams.Core import Diagrams.Solve import Diagrams.ThreeD.Types +import Diagrams.ThreeD.Vector data Ellipsoid = Ellipsoid T3 deriving Typeable @@ -39,6 +45,7 @@ instance Transformable Ellipsoid where instance Renderable Ellipsoid NullBackend where render _ _ = mempty +-- | A sphere of radius 1 with its center at the origin. sphere :: (Backend b R3, Renderable Ellipsoid b) => Diagram b R3 sphere = mkQD (Prim $ Ellipsoid mempty) (mkEnvelope sphereEnv) @@ -52,3 +59,104 @@ sphere = mkQD (Prim $ Ellipsoid mempty) c = p' <.> p' - 1 p' = p .-. origin sphereQuery v = Any $ magnitudeSq (v .-. origin) <= 1 + +data Box = Box T3 + deriving (Typeable) + +type instance V Box = R3 + +instance Transformable Box where + transform t1 (Box t2) = Box (t1 <> t2) + +instance Renderable Box NullBackend where + render _ _ = mempty + +-- | A cube with side length 1, in the positive octant, with one +-- vertex at the origin. +cube :: (Backend b R3, Renderable Box b) => Diagram b R3 +cube = mkQD (Prim $ Box mempty) + (mkEnvelope boxEnv) + (mkTrace boxTrace) + mempty + (Query boxQuery) + where + corners = mkR3 <$> [0,1] <*> [0,1] <*> [0,1] + boxEnv v = maximum (map (v <.>) corners) / magnitudeSq v + -- ts gives all intersections with the planes forming the box + -- filter keeps only those actually on the box surface + boxTrace p v = mkSortedList . filter (range . atT) $ ts where + (x0, y0, z0) = unp3 p + (vx, vy, vz) = unr3 v + intersections f d = case d of + 0 -> [] + _ -> [-f/d, (1-f)/d] + ts = concat $ zipWith intersections [x0,y0,z0] [vx,vy,vz] + atT t = p .+^ (t*^v) + range u = and [x >= 0, x <= 1, y >= 0, y <= 1, z >= 0, z <= 1] where + (x, y, z) = unp3 u + boxQuery = Any . range + +data Frustum = Frustum Double Double T3 + deriving (Typeable) + +type instance V Frustum = R3 + +instance Transformable Frustum where + transform t1 (Frustum r0 r1 t2) = Frustum r0 r1 (t1 <> t2) + +instance Renderable Frustum NullBackend where + render _ _ = mempty + +-- | A frustum of a right circular cone. It has height 1 oriented +-- along the positive z axis, and radii r0 and r1 at Z=0 and Z=1. +-- 'cone' and 'cylinder' are special cases. +frustum :: (Backend b R3, Renderable Frustum b) => Double -> Double -> Diagram b R3 +frustum r0 r1 = mkQD (Prim $ Frustum r0 r1 mempty) + (mkEnvelope frEnv) + (mkTrace frTrace) + mempty + (Query frQuery) + where + projectXY u = u ^-^ project unitZ u + frQuery p = Any $ x >= 0 && x <= 1 && a <= r where + (x, _, z) = unp3 p + r = r0 + (r1-r0)*z + v = p .-. origin + a = magnitude $ projectXY v + -- The plane containing v and the z axis intersects the frustum in a trapezoid + -- Test the four corners of this trapezoid; one must determine the Envelope + frEnv v = maximum . map (magnitude . project v . review cylindrical) $ corners + where + θ = v^._theta + corners = [(r1,θ,1), (-r1,θ,1), (r0,θ,0), (-r0,θ,0)] + -- The trace can intersect the sides of the cone or one of the end + -- caps The sides are described by a quadric equation; substitute + -- in the parametric form of the ray but disregard any + -- intersections outside z = [0,1] Similarly, find intersections + -- with the planes z=0, z=1, but disregard any r>r0, r>r1 + frTrace p v = mkSortedList $ filter zbounds (quadForm a b c) ++ ends + where + (px, py, pz) = unp3 p + (vx, vy, vz) = unr3 v + ray t = p .+^ t*^v + dr = r1-r0 + a = vx**2 + vy**2 - vz**2 * dr**2 + b = 2 * (px * vx + py * vy - (r0+pz*dr) * dr * vz) + c = px**2 + py**2 - (r0 + dr*pz)**2 + zbounds t = (ray t)^._z >= 0 && (ray t)^._z <= 1 + ends = concatMap cap [0,1] + cap z = if (ray t)^.cylindrical._1 < r0 + z*dr + then [t] + else [] + where + t = (z - pz) / vz + +-- | A cone with its base centered on the origin, with radius 1 at the +-- base, height 1, and it's apex on the positive Z axis. +cone :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cone = frustum 1 0 + +-- | A circular cylinder of radius 1 with one end cap centered on the +-- origin, and extending to Z=1. +cylinder :: (Backend b R3, Renderable Frustum b) => Diagram b R3 +cylinder = frustum 1 1 diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 3c25c180..7fff6a8f 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -46,9 +46,9 @@ module Diagrams.ThreeD.Transform import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.ThreeD.Types -import Diagrams.ThreeD.Vector import Diagrams.Coordinates import Control.Lens (view, (*~), (//~)) @@ -102,11 +102,10 @@ aboutY ang = fromLinear r (linv r) where -- | @rotationAbout p d a@ is a rotation about a line parallel to @d@ -- passing through @p@. -rotationAbout - :: Direction d - => P3 -- ^ origin of rotation - -> d -- ^ direction of rotation axis - -> Angle -- ^ angle of rotation +rotationAbout :: + P3 -- ^ origin of rotation + -> Direction -- ^ direction of rotation axis + -> Angle -- ^ angle of rotation -> T3 rotationAbout p d a = mconcat [translation (negateV t), @@ -128,7 +127,7 @@ rotationAbout p d a -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: Direction d => d -> d -> d -> T3 +pointAt :: Direction -> Direction -> Direction -> T3 pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors @@ -137,9 +136,9 @@ pointAt' :: R3 -> R3 -> R3 -> T3 pointAt' about initial final = tilt <> pan where inPanPlane = final ^-^ project final initial panAngle = angleBetween initial inPanPlane - pan = rotationAbout origin (direction about :: Spherical) panAngle + pan = rotationAbout origin (direction about) panAngle tiltAngle = angleBetween initial inPanPlane - tiltDir = direction $ cross3 inPanPlane about :: Spherical + tiltDir = direction $ cross3 inPanPlane about tilt = rotationAbout origin tiltDir tiltAngle -- Scaling ------------------------------------------------- @@ -261,4 +260,4 @@ reflectAbout p v = transform (reflectionAbout p v) -- useful for implementing backends. onBasis :: T3 -> ((R3, R3, R3), R3) onBasis t = ((x, y, z), v) - where ((x:y:z:[]), v) = T.onBasis t + where (x:y:z:[], v) = T.onBasis t diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index ae915382..07855025 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,13 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - ----------------------------------------------------------------------------- -- | -- Module : Diagrams.ThreeD.Types @@ -21,28 +21,23 @@ module Diagrams.ThreeD.Types ( -- * 3D Euclidean space - R3, r3, unr3, mkR3 + R3(..), r3, unr3, mkR3 , P3, p3, unp3, mkP3 , T3 , r3Iso, p3Iso - -- * Two-dimensional angles - -- | These are defined in "Diagrams.TwoD.Types" but - -- reëxported here for convenience. - , Angle, rad, turn, deg, (@@) - , fullTurn, angleRatio - -- * Directions in 3D - , Direction(..) - , Spherical(..) - , asSpherical + , Direction, direction, fromDirection, angleBetweenDirs + -- * other coördinate systems + , Spherical(..), Cylindrical(..), HasPhi(..) ) where -import Control.Lens (Iso', iso, over, Wrapped(..), Rewrapped - , _1, _2, _3) +import Control.Lens (Iso', Lens', iso, over + , _1, _2, _3, (^.)) import Diagrams.Core -import Diagrams.TwoD.Types +import Diagrams.Angle +import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates import Data.AffineSpace.Point @@ -54,31 +49,28 @@ import Data.VectorSpace -- 3D Euclidean space -- | The three-dimensional Euclidean vector space R^3. -newtype R3 = R3 { unR3 :: (Double, Double, Double) } - deriving (AdditiveGroup, Eq, Ord, Show, Read) +data R3 = R3 !Double !Double !Double + deriving (Eq, Ord, Show, Read) r3Iso :: Iso' R3 (Double, Double, Double) -r3Iso = iso unR3 R3 +r3Iso = iso unr3 r3 -- | Construct a 3D vector from a triple of components. r3 :: (Double, Double, Double) -> R3 -r3 = R3 +r3 (x,y,z) = R3 x y z -- | Curried version of `r3`. mkR3 :: Double -> Double -> Double -> R3 -mkR3 x y z = r3 (x, y, z) +mkR3 = R3 -- | Convert a 3D vector back into a triple of components. unr3 :: R3 -> (Double, Double, Double) -unr3 = unR3 +unr3 (R3 x y z) = (x,y,z) --- | Lens wrapped isomorphisms for R3. -instance Wrapped R3 where - type Unwrapped R3 = (Double, Double, Double) - _Wrapped' = iso unr3 r3 - {-# INLINE _Wrapped' #-} - -instance Rewrapped R3 R3 +instance AdditiveGroup R3 where + zeroV = R3 0 0 0 + R3 x1 y1 z1 ^+^ R3 x2 y2 z2 = R3 (x1 + x2) (y1 + y2) (z1 + z2) + negateV (R3 x y z) = R3 (-x) (-y) (-z) type instance V R3 = R3 @@ -88,31 +80,31 @@ instance VectorSpace R3 where instance HasBasis R3 where type Basis R3 = Either () (Either () ()) -- = Basis (Double, Double, Double) - basisValue = R3 . basisValue - decompose = decompose . unR3 - decompose' = decompose' . unR3 + basisValue = r3 . basisValue + decompose = decompose . unr3 + decompose' = decompose' . unr3 instance InnerSpace R3 where - (unR3 -> vec1) <.> (unR3 -> vec2) = vec1 <.> vec2 + (R3 x1 y1 z1) <.> (R3 x2 y2 z2) = x1*x2 + y1*y2 + z1*z2 instance Coordinates R3 where type FinalCoord R3 = Double type PrevDim R3 = R2 type Decomposition R3 = Double :& Double :& Double - (coords -> x :& y) ^& z = r3 (x,y,z) - coords (unR3 -> (x,y,z)) = x :& y :& z + (coords -> x :& y) ^& z = R3 x y z + coords (R3 x y z) = x :& y :& z -- | Points in R^3. type P3 = Point R3 -- | Construct a 3D point from a triple of coordinates. p3 :: (Double, Double, Double) -> P3 -p3 = P . R3 +p3 = P . r3 -- | Convert a 3D point back into a triple of coordinates. unp3 :: P3 -> (Double, Double, Double) -unp3 = unR3 . unPoint +unp3 = unr3 . unPoint p3Iso :: Iso' P3 (Double, Double, Double) p3Iso = iso unp3 p3 @@ -133,33 +125,14 @@ instance HasCross3 R3 where -------------------------------------------------------------------------------- -- Direction --- | Direction is a type class representing directions in R3. The interface is --- based on that of the Angle class in 2D. - -class Direction d where - -- | Convert to spherical coördinates - toSpherical :: d -> Spherical - - -- | 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 = Spherical Angle Angle - deriving (Show, Read, Eq) - -instance Direction Spherical where - toSpherical = id - fromSpherical = id +-- | A @Direction@ represents directions in R3. The constructor is +-- not exported; @Direction@s can be used with 'fromDirection' and the +-- lenses provided by its instances. +data Direction = Direction R3 --- | 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 -> Spherical -asSpherical = id +-- | Not exported +_Dir :: Iso' Direction R3 +_Dir = iso (\(Direction v) -> v) Direction instance HasX R3 where _x = r3Iso . _1 @@ -178,3 +151,73 @@ instance HasZ R3 where instance HasZ P3 where _z = p3Iso . _3 + +-- | Types which can be expressed in spherical 3D coordinates, as a +-- triple (r,θ,φ), where θ is rotation about the Z axis, and φ is the +-- angle from the Z axis. +class Spherical t where + spherical :: Iso' t (Double, Angle, Angle) + +-- | Types which can be expressed in cylindrical 3D coordinates. +class Cylindrical t where + cylindrical :: Iso' t (Double, Angle, Double) -- r, θ, z + +instance Cylindrical R3 where + cylindrical = iso (\(R3 x y z) -> (sqrt (x^(2::Int)+y^(2::Int)), atanA (y/x), z)) + (\(r,θ,z) -> R3 (r*cosA θ) (r*sinA θ) z) + +instance Spherical R3 where + spherical = iso + (\v@(R3 x y z) -> (magnitude v, atanA (y/x), atanA (v^._r/z))) + (\(r,θ,φ) -> R3 (r*cosA θ*sinA φ) (r*sinA θ*sinA φ) (r*cosA φ)) + +-- We'd like to write: instance Spherical t => HasR t +-- But GHC can't work out that the instance won't overlap. Just write them explicitly: + +instance HasR R3 where + _r = spherical . _1 + +instance HasR P3 where + _r = spherical . _1 + +instance HasTheta R3 where + _theta = cylindrical . _2 + +instance HasTheta P3 where + _theta = cylindrical . _2 + +-- | The class of types with at least two angle coordinates, the +-- second called _phi. +class HasPhi t where + _phi :: Lens' t Angle + +instance HasPhi R3 where + _phi = spherical . _3 + +instance HasPhi P3 where + _phi = spherical . _3 + +instance Cylindrical P3 where + cylindrical = _relative origin . cylindrical + +instance Spherical P3 where + spherical = _relative origin . spherical + +instance HasTheta Direction where + _theta = _Dir . _theta + +instance HasPhi Direction where + _phi = _Dir . _phi + +-- | @direction v@ is the direction in which @v@ points. Returns an +-- unspecified value when given the zero vector as input. +direction :: R3 -> Direction +direction = Direction + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: Direction -> R3 +fromDirection (Direction v) = normalized v + +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: Direction -> Direction -> Angle +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/ThreeD/Vector.hs b/src/Diagrams/ThreeD/Vector.hs index 41dff9dd..975188b5 100644 --- a/src/Diagrams/ThreeD/Vector.hs +++ b/src/Diagrams/ThreeD/Vector.hs @@ -15,17 +15,10 @@ module Diagrams.ThreeD.Vector ( -- * Special 2D vectors unitX, unitY, unitZ, unit_X, unit_Y, unit_Z, - - -- * Converting between vectors and angles - direction, fromDirection, angleBetween, angleBetweenDirs ) where -import Control.Lens ((^.)) -import Data.VectorSpace -import Data.Cross - -import Diagrams.ThreeD.Types import Diagrams.Coordinates +import Diagrams.ThreeD.Types -- | The unit vector in the positive X direction. @@ -51,33 +44,3 @@ unit_Y = 0 ^& (-1) ^& 0 -- | The unit vector in the negative Z direction. unit_Z :: R3 unit_Z = 0 ^& 0 ^& (-1) - - --- | @direction v@ is the direction in which @v@ points. Returns an --- unspecified value when given the zero vector as input. -direction :: Direction d => R3 -> d -direction v - | r == 0 = fromSpherical $ Spherical zero zero - | otherwise = fromSpherical $ Spherical θ φ where - r = magnitude v - (x,y,z) = unr3 v - φ = 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 - θ = θ'^.rad - φ = φ'^.rad - x = cos θ * cos φ - y = sin θ * cos φ - z = sin φ - --- | compute the positive angle between the two vectors in their common plane -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 => d -> d -> Angle -angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Trail.hs b/src/Diagrams/Trail.hs index b28a05da..a7c2e837 100644 --- a/src/Diagrams/Trail.hs +++ b/src/Diagrams/Trail.hs @@ -77,7 +77,7 @@ module Diagrams.Trail , trailOffsets, trailOffset , lineOffsets, lineOffset, loopOffsets , trailVertices, lineVertices, loopVertices - , fixTrail + , trailLocSegments, fixTrail -- * Modifying trails @@ -163,10 +163,8 @@ deriving instance (OrderedField (Scalar v), InnerSpace v) => Monoid (SegTree v) deriving instance (OrderedField (Scalar v), InnerSpace v) => FT.Measured (SegMeasure v) (SegTree v) - -instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) - => Transformable (SegTree v) where - transform t = SegTree . transform t . op SegTree +deriving instance (HasLinearMap v, InnerSpace v, OrderedField (Scalar v)) + => Transformable (SegTree v) type instance Codomain (SegTree v) = v @@ -993,8 +991,12 @@ segmentVertices p = scanl (.+^) p . map segOffset -- | Convert a concretely located trail into a list of fixed segments. fixTrail :: (InnerSpace v, OrderedField (Scalar v)) => Located (Trail v) -> [FixedSegment v] -fixTrail t = zipWith ((mkFixedSeg .) . at) - (trailSegments (unLoc t)) (trailVertices t) +fixTrail t = map mkFixedSeg (trailLocSegments t) + +-- | Convert a concretely located trail into a list of located segments. +trailLocSegments :: (InnerSpace v, OrderedField (Scalar v)) + => Located (Trail v) -> [Located (Segment Closed v)] +trailLocSegments t = zipWith at (trailSegments (unLoc t)) (trailVertices t) ------------------------------------------------------------ -- Modifying trails -------------------------------------- diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 2a004298..9aa09869 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -65,14 +65,10 @@ module Diagrams.TwoD , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y - , direction, angleBetween, fromDirection + , direction, fromDirection -- * Angles , tau - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , (@@) -- * Paths -- ** Stroking @@ -150,19 +146,19 @@ module Diagrams.TwoD , arrowShaft , headGap , tailGap - , gap + , gaps, gap , headColor , headStyle , tailColor , tailStyle , shaftColor , shaftStyle - , HeadSize, headSize, headSizeA, getHeadSize, setHeadSize - , TailSize, tailSize, tailSizeA, getTailSize, setTailSize + , HeadSize, headSize, headSizeA, getHeadSize + , TailSize, tailSize, tailSizeA, getTailSize -- * Text , text, topLeftText, alignedText, baselineText - , font, fontSize, italic, oblique, bold, setFontSize + , font, fontSize, italic, oblique, bold -- * Images , Image, image @@ -236,8 +232,10 @@ module Diagrams.TwoD -- ** Width , LineWidth, getLineWidth, lineWidth, lineWidthA, lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick - -- * Measure conversion - , toOutput + + -- ** Dashing + , Dashing(..), DashingA, getDashing + , dashing, dashingO, dashingL, dashingN -- * Visual aids for understanding the internal model , showOrigin @@ -253,7 +251,6 @@ import Diagrams.TwoD.Arrow import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes import Diagrams.TwoD.Combinators -import Diagrams.TwoD.Compile import Diagrams.TwoD.Deform import Diagrams.TwoD.Ellipse import Diagrams.TwoD.Image diff --git a/src/Diagrams/TwoD/Adjust.hs b/src/Diagrams/TwoD/Adjust.hs index c38b604c..f28c823c 100644 --- a/src/Diagrams/TwoD/Adjust.hs +++ b/src/Diagrams/TwoD/Adjust.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | @@ -25,8 +25,7 @@ import Diagrams.Core import Diagrams.TwoD.Arrow (headSizeA, tailSizeA) import Diagrams.TwoD.Attributes (lineWidthA) import Diagrams.TwoD.Size (SizeSpec2D (..), center2D, - requiredScale, requiredScaleT, - size2D) + requiredScale, size2D) import Diagrams.TwoD.Text (fontSizeA) import Diagrams.TwoD.Types (R2, T2, p2) import Diagrams.Util (( # )) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index d22556a3..84aac3a5 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Arc , annularWedge ) where +import Diagrams.Angle import Diagrams.Core import Diagrams.Located (at) import Diagrams.Segment diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index aefb3bb3..7d6b46bc 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | @@ -72,8 +72,8 @@ module Diagrams.TwoD.Arrow , arrow' -- * Attributes - , HeadSize, headSize, headSizeA, getHeadSize, setHeadSize - , TailSize, tailSize, tailSizeA, getTailSize, setTailSize + , HeadSize, headSize, headSizeA, getHeadSize + , TailSize, tailSize, tailSizeA, getTailSize -- * Options , ArrowOpts(..) @@ -83,7 +83,7 @@ module Diagrams.TwoD.Arrow , arrowShaft , headGap , tailGap - , gap + , gaps, gap , headColor , headStyle , tailColor @@ -97,38 +97,38 @@ module Diagrams.TwoD.Arrow , module Diagrams.TwoD.Arrowheads ) where -import Control.Applicative ((<*>)) -import Control.Lens (Lens', Setter', Traversal', - generateSignatures, - lensRules, makeLensesWith, - (%~), (&), (.~), (^.)) +import Control.Applicative ((<*>)) +import Control.Lens (Lens', Setter', Traversal', + generateSignatures, lensRules, + makeLensesWith, (%~), (&), (.~), + (^.)) import Data.AffineSpace +import Data.Data import Data.Default.Class -import Data.Functor ((<$>)) -import Data.Maybe (fromMaybe) -import Data.Monoid.Coproduct (untangle) +import Data.Functor ((<$>)) +import Data.Maybe (fromMaybe) +import Data.Monoid.Coproduct (untangle) import Data.Semigroup -import Data.Typeable import Data.VectorSpace -import Data.Colour hiding (atop) +import Data.Colour hiding (atop) import Diagrams.Attributes import Diagrams.Core -import Diagrams.Core.Types (QDiaLeaf (..), mkQD') -import Diagrams.Core.Style (setAttr) +import Diagrams.Core.Types (QDiaLeaf (..), mkQD') +import Diagrams.Angle import Diagrams.Parametric import Diagrams.Path -import Diagrams.Solve (quadForm) -import Diagrams.Tangent (tangentAtEnd, tangentAtStart) +import Diagrams.Solve (quadForm) +import Diagrams.Tangent (tangentAtEnd, tangentAtStart) import Diagrams.Trail import Diagrams.TwoD.Arrowheads import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Path (strokeT, stroke) -import Diagrams.TwoD.Transform (avgScale, rotate, translateX) +import Diagrams.TwoD.Path (stroke, strokeT) +import Diagrams.TwoD.Transform (rotate, translateX) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction, unitX, unit_X) -import Diagrams.Util (( # )) +import Diagrams.TwoD.Vector (direction, unitX, unit_X) +import Diagrams.Util (( # )) data ArrowOpts = ArrowOpts @@ -171,14 +171,58 @@ arrowTail :: Lens' ArrowOpts ArrowHT -- | The trail to use for the arrow shaft. arrowShaft :: Lens' ArrowOpts (Trail R2) +-- -- | Radius of a circumcircle around the head. +-- headSize :: Lens' ArrowOpts Double + +-- -- | Radius of a circumcircle around the tail. +-- tailSize :: Lens' ArrowOpts Double + +-- -- | Width of the head. +-- headWidth :: Setter' ArrowOpts Double +-- headWidth f opts = +-- (\hd -> opts & headSize .~ g hd) <$> f (opts ^. headSize) +-- where +-- g w = w / (xWidth h + xWidth j) +-- (h, j) = (opts ^. arrowHead) 1 (widthOfJoint $ shaftSty opts) + +-- -- | Width of the tail. +-- tailWidth :: Setter' ArrowOpts Double +-- tailWidth f opts = +-- (\tl -> opts & tailSize .~ g tl) <$> f (opts ^. tailSize) +-- where +-- g w = w / (xWidth t + xWidth j) +-- (t, j) = (opts ^. arrowTail) 1 (widthOfJoint $ shaftSty opts) + +-- -- | Set both the @headWidth@ and @tailWidth@. +-- widths :: Traversal' ArrowOpts Double +-- widths f opts = +-- (\hd tl -> opts & headSize .~ gh hd & tailSize .~ gt tl) +-- <$> f (opts ^. headSize) <*> f (opts ^. tailSize) +-- where +-- gh w = w / (xWidth h + xWidth j) +-- (h, j) = (opts ^. arrowHead) 1 (widthOfJoint $ shaftSty opts) +-- gt w = w / (xWidth t + xWidth j') +-- (t, j') = (opts ^. arrowTail) 1 (widthOfJoint $ shaftSty opts) + +-- -- | Set the size of both the head and tail. +-- sizes :: Traversal' ArrowOpts Double +-- sizes f opts = +-- (\h t -> opts & headSize .~ h & tailSize .~ t) +-- <$> f (opts ^. headSize) <*> f (opts ^. tailSize) + -- | 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 +-- | Set both the @headGap@ and @tailGap@ simultaneously. +gaps :: Traversal' ArrowOpts Double +gaps f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) + +-- | Same as gaps, provided for backward compatiiblity. gap :: Traversal' ArrowOpts Double -gap f opts = (\h t -> opts & headGap .~ h & tailGap .~ t) <$> f (opts ^. headGap) <*> f (opts ^. tailGap) +gap = gaps -- | Style to apply to the head. @headStyle@ is modified by using the lens -- combinator @%~@ to change the current style. For example, to change @@ -241,7 +285,7 @@ tailSty opts = fc black (opts^.tailStyle) -- | Radius of a circumcircle around the head. newtype HeadSize = HeadSize (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass HeadSize type instance V HeadSize = R2 @@ -256,19 +300,16 @@ instance Default HeadSize where -- | Set the radius of the circumcircle around the head. headSize :: (HasStyle a, V a ~ R2) => Measure Double -> a -> a -headSize = applyTAttr . HeadSize . Last - -setHeadSize :: (Measure Double) -> Style R2 -> Style R2 -setHeadSize = setAttr . HeadSize . Last +headSize = applyGTAttr . HeadSize . Last headSizeA :: (HasStyle a, V a ~ R2) => HeadSize -> a -> a -headSizeA = applyTAttr +headSizeA = applyGTAttr getHeadSize :: HeadSize -> Measure Double getHeadSize (HeadSize (Last s)) = s newtype TailSize = TailSize (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass TailSize type instance V TailSize = R2 @@ -283,13 +324,10 @@ instance Default TailSize where -- | Set the radius of a circumcircle around the arrow tail. tailSize :: (HasStyle a, V a ~ R2) => Measure Double -> a -> a -tailSize = applyTAttr . TailSize . Last - -setTailSize :: (Measure Double) -> Style R2 -> Style R2 -setTailSize = setAttr . TailSize . Last +tailSize = applyGTAttr . TailSize . Last tailSizeA :: (HasStyle a, V a ~ R2) => TailSize -> a -> a -tailSizeA = applyTAttr +tailSizeA = applyGTAttr getTailSize :: TailSize -> Measure Double getTailSize (TailSize (Last s)) = s @@ -570,9 +608,7 @@ connectOutside' opts n1 n2 = withName n2 $ \b2 -> let v = location b2 .-. location b1 midpoint = location b1 .+^ (v/2) - s' = traceP midpoint (-v) b1 - e' = traceP midpoint v b2 + s' = fromMaybe (location b1) $ traceP midpoint (-v) b1 + e' = fromMaybe (location b2) $ traceP midpoint v b2 in - case (s', e') of - (Just s, Just e) -> atop (arrowBetween' opts s e) - (_, _) -> id + atop (arrowBetween' opts s' e') diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 3c8caeae..7622d4a6 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Arrowheads , spike , thorn , missile + , lineHead , noHead -- ** Configurable arrowheads @@ -42,6 +43,7 @@ module Diagrams.TwoD.Arrowheads , spike' , thorn' , missile' + , lineTail , noTail , quill , block @@ -63,6 +65,7 @@ import Data.Maybe (fromMaybe) import Data.Monoid (mempty, (<>)) import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core import Diagrams.CubicSpline (cubicSpline) import Diagrams.Path @@ -208,6 +211,10 @@ arrowheadMissile :: Angle -> ArrowHT arrowheadMissile theta = smoothArrowhead $ arrowheadDart theta -- Standard heads --------------------------------------------------------- +-- | A line the same width as the shaft. +lineHead :: ArrowHT +lineHead l w = (square 1 # scaleX l # scaleY w # alignL, mempty) + noHead :: ArrowHT noHead _ _ = (mempty, mempty) @@ -292,6 +299,9 @@ arrowtailQuill theta =aTail [ v0, n1, n2, v0, n3, n4, v0 ]) -- Standard tails --------------------------------------------------------- +-- | A line the same width as the shaft. +lineTail :: ArrowHT +lineTail l w = (square 1 # scaleX l # scaleY w # alignR, mempty) noTail :: ArrowHT noTail _ _ = (mempty, mempty) diff --git a/src/Diagrams/TwoD/Attributes.hs b/src/Diagrams/TwoD/Attributes.hs index eeea782b..53f8155b 100644 --- a/src/Diagrams/TwoD/Attributes.hs +++ b/src/Diagrams/TwoD/Attributes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -21,54 +22,60 @@ module Diagrams.TwoD.Attributes ( -- ** Width - LineWidth, getLineWidth, lineWidth, lineWidthA, setLineWidth + LineWidth, getLineWidth, lineWidth, lineWidthA , lw, lwN, lwO, lwL , ultraThin, veryThin, thin, medium, thick, veryThick + -- ** Dashing + , Dashing(..), DashingA, getDashing, setDashing + , dashing, dashingN, dashingO, dashingL + ) where +import Data.Data import Data.Default.Class import Data.Semigroup -import Data.Typeable import Diagrams.Core -import Diagrams.Core.Style (setAttr) -import Diagrams.TwoD.Transform (avgScale) -import Diagrams.TwoD.Types (R2) +import Diagrams.TwoD.Types (R2) + +----------------------------------------------------------------- + +type instance V (Measure Double) = R2 ------------------------------------------------------------- +instance Transformable (Measure Double) where + transform tr (Local x) = Local (avgScale tr * x) + transform _ y = y + +----------------------------------------------------------------- -- Line Width ------------------------------------------------- ------------------------------------------------------------- +----------------------------------------------------------------- -- | Line widths specified on child nodes always override line widths -- specified at parent nodes. newtype LineWidth = LineWidth (Last (Measure Double)) - deriving (Typeable, Semigroup) + deriving (Typeable, Data, Semigroup) instance AttributeClass LineWidth type instance V LineWidth = R2 instance Transformable LineWidth where - transform t (LineWidth (Last (Local w))) = - LineWidth (Last (Local (avgScale t * w))) - transform _ l = l + transform t (LineWidth (Last w)) = + LineWidth (Last (transform t w)) instance Default LineWidth where def = LineWidth (Last (Output 1)) -getLineWidth :: LineWidth -> (Measure Double) +getLineWidth :: LineWidth -> Measure Double getLineWidth (LineWidth (Last w)) = w -setLineWidth :: (Measure Double) -> Style R2 -> Style R2 -setLineWidth = setAttr . LineWidth . Last - -- | Set the line (stroke) width. lineWidth :: (HasStyle a, V a ~ R2) => (Measure Double) -> a -> a -lineWidth = applyTAttr . LineWidth . Last +lineWidth = applyGTAttr . LineWidth . Last -- | Apply a 'LineWidth' attribute. lineWidthA :: (HasStyle a, V a ~ R2) => LineWidth -> a -> a -lineWidthA = applyTAttr +lineWidthA = applyGTAttr -- | A convenient synonym for 'lineWidth (Global w)'. lw :: (HasStyle a, V a ~ R2) => Double -> a -> a @@ -95,3 +102,53 @@ thin = lwO 1 medium = lwO 2 thick = lwO 4 veryThick = lwO 5 + +----------------------------------------------------------------- +-- Dashing ---------------------------------------------------- +----------------------------------------------------------------- + +-- | Create lines that are dashing... er, dashed. +data Dashing = Dashing [Measure Double] (Measure Double) + deriving (Typeable, Data, Eq) + +newtype DashingA = DashingA (Last Dashing) + deriving (Typeable, Data, Semigroup, Eq) +instance AttributeClass DashingA + +type instance V DashingA = R2 + +instance Transformable DashingA where + transform t (DashingA (Last (Dashing w v))) = + DashingA (Last (Dashing r s)) + where + r = map (transform t) w + s = transform t v + +getDashing :: DashingA -> Dashing +getDashing (DashingA (Last d)) = d + +-- | Set the line dashing style. +setDashing :: (HasStyle a, V a ~ R2) => + [Measure Double] -- ^ A list specifying alternate lengths of on + -- and off portions of the stroke. The empty + -- list indicates no dashing. + -> Measure Double -- ^ An offset into the dash pattern at which the + -- stroke should start. + -> a -> a +setDashing ds offs = applyGTAttr (DashingA (Last (Dashing ds offs))) + +-- | A convenient synonym for 'setDashing (Global w)'. +dashing :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashing w v = setDashing (map Global w) (Global v) + +-- | A convenient synonym for 'setDashing (Normalized w)'. +dashingN :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingN w v = setDashing (map Normalized w) (Normalized v) + +-- | A convenient synonym for 'setDashing (Output w)'. +dashingO :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingO w v = setDashing (map Output w) (Output v) + +-- | A convenient sysnonym for 'setDashing (Local w)'. +dashingL :: (HasStyle a, V a ~ R2) => [Double] -> Double -> a -> a +dashingL w v = setDashing (map Local w) (Local v) diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index a2f1c8f9..aa321cbf 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -45,6 +45,7 @@ import Data.VectorSpace import Diagrams.Core +import Diagrams.Angle import Diagrams.Attributes (fc) import Diagrams.BoundingBox import Diagrams.Combinators @@ -77,7 +78,7 @@ infixl 6 ||| -- -- 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) @@ -85,7 +86,7 @@ infixl 6 ||| -- | 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 diff --git a/src/Diagrams/TwoD/Compile.hs b/src/Diagrams/TwoD/Compile.hs deleted file mode 100644 index 7c586ce8..00000000 --- a/src/Diagrams/TwoD/Compile.hs +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Diagrams.TwoD.Compile --- Copyright : (c) 2014 diagrams-lib team (see LICENSE) --- License : BSD-style (see LICENSE) --- Maintainer : diagrams-discuss@googlegroups.com --- --- Functions to rewrite the RTree form of diagrams during backend rendering. --- ------------------------------------------------------------------------------ - -module Diagrams.TwoD.Compile - ( toOutput - - ) where - -import Diagrams.Core -import Diagrams.Core.Types (RTree) -import Diagrams.TwoD.Arrow -import Diagrams.TwoD.Attributes -import Diagrams.TwoD.Size (SizeSpec2D, sizePair) -import Diagrams.TwoD.Text -import Diagrams.TwoD.Types (R2) - --- | Take a getter, a setter, and two scaling terms, return a function --- that rewrites the given Measure-containing Attribute into Output --- units. The scaling terms are from Normalized to Output and from --- Global to Output. -modifyStyle :: AttributeClass a => - (a -> Measure Double) -> - (Measure Double -> Style R2 -> Style R2) -> - SizeSpec2D -> Double -> - Style R2 -> Style R2 -modifyStyle get set outputSize gs sty = case getAttr sty of - Nothing -> sty - Just a -> case get a of - Output _ -> sty - Normalized t -> set (Output $ sqrt (w*h) * t) sty where - (w,h) = sizePair outputSize - - -- Note: we assume here that this function is being called on - -- values in an RTree; conversion to RTree involves pushing - -- transformations down to the leaves, and transforming any - -- styles encountered along the way. In particular this will - -- scale any 'Local' values; hence any 'Local' value - -- encountered here must already be in Output units. - Local t -> set (Output t) sty - - Global t -> set (Output $ gs * t) sty - --- | Convert all of the @LineWidth@ attributes in an @RTree@ to output --- units. 'w' and 'h' are the width and height of the final diagram. --- The scaling factor is the geometric mean of 'h' and 'w'. -toOutput :: SizeSpec2D -> Double -> Style R2 -> Style R2 -toOutput ns gs = modifyStyle getLineWidth setLineWidth ns gs . - modifyStyle getHeadSize setHeadSize ns gs . - modifyStyle getTailSize setTailSize ns gs . - modifyStyle getFontSize setFontSize ns gs diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index abdd7ff7..e0287875 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -26,6 +26,7 @@ import Data.AdditiveGroup import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.TrailLike import Diagrams.TwoD.Arc diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index d6bdeaab..ba5d817f 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -41,6 +41,7 @@ import Control.Applicative 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 @@ offsetTrail' :: OffsetOpts -- 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 @@ expandTrail' o r t 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 @@ expandLine opts r (mapLoc wrapLine -> t) = caps cap r s e (f r) (f $ -r) 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''. @@ -470,20 +476,25 @@ arcVCW u v = arcCW (direction u) (direction v) -- 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 * 2 - 1) $ ss es (ts ++ [t])))) t - | otherwise = mapLoc (<> mconcat (ss es ts)) t - ss es' ts' = concat [[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 index 07ee02c2..f75403b7 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -45,9 +45,9 @@ module Diagrams.TwoD.Path ) where import Control.Applicative (liftA2) -import Control.Lens ( makeWrapped, makeLensesWith, (.~), (^.) - , generateSignatures, lensRules, op - , Lens, Lens', _Wrapped') +import Control.Lens (Lens, Lens', generateSignatures, + lensRules, makeLensesWith, makeWrapped, + op, (.~), (^.), _Wrapped') import qualified Data.Foldable as F import Data.Semigroup import Data.Typeable diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index 3fa1a1ed..7879e7bc 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -60,6 +60,7 @@ import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class import Data.VectorSpace +import Diagrams.Angle import Diagrams.Core import Diagrams.Located import Diagrams.Path diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index 5eabf866..d49d4b87 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -47,6 +47,7 @@ module Diagrams.TwoD.Shapes import Diagrams.Core +import Diagrams.Angle import Diagrams.Located (at) import Diagrams.Path import Diagrams.Segment diff --git a/src/Diagrams/TwoD/Text.hs b/src/Diagrams/TwoD/Text.hs index 5a29c041..c0fe02a9 100644 --- a/src/Diagrams/TwoD/Text.hs +++ b/src/Diagrams/TwoD/Text.hs @@ -23,7 +23,7 @@ module Diagrams.TwoD.Text ( -- ** Font family , Font(..), getFont, font -- ** Font size - , FontSize(..), getFontSize, fontSize, fontSizeA, setFontSize + , FontSize(..), getFontSize, fontSize, fontSizeA -- ** Font slant , FontSlant(..), FontSlantA, getFontSlant, fontSlant, italic, oblique -- ** Font weight @@ -37,13 +37,9 @@ import Diagrams.Core.Style (setAttr) import Diagrams.TwoD.Types import Data.AffineSpace ((.-.)) - import Data.Semigroup - import Data.Colour - import Data.Default.Class - import Data.Typeable ------------------------------------------------------------ @@ -177,8 +173,6 @@ instance Default FontSize where getFontSize :: FontSize -> Measure Double getFontSize (FontSize (Last s)) = s -setFontSize :: (Measure Double) -> Style R2 -> Style R2 -setFontSize = setAttr . FontSize . Last -- | Set the font size, that is, the size of the font's em-square as -- measured within the current local vector space. The default size -- is @1@. diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 49e7fe39..538e8f3f 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -47,12 +47,12 @@ module Diagrams.TwoD.Transform -- * Utilities , onBasis - , avgScale ) where import Diagrams.Core import qualified Diagrams.Core.Transform as T +import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types @@ -249,41 +249,3 @@ shearY = transform . shearingY onBasis :: Transformation R2 -> ((R2, R2), R2) onBasis t = ((x, y), v) where ((x:y:[]), v) = T.onBasis t - --- | Compute the \"average\" amount of scaling performed by a --- transformation. Satisfies the properties --- --- @ --- avgScale (scaling k) == k --- avgScale (t1 <> t2) == avgScale t1 * avgScale t2 --- @ --- --- Backends which do not support stroking in the context of an --- arbitrary transformation may instead call 'avgScale' on --- \"frozen\" transformations and multiply the line width by the --- resulting value. -avgScale :: T2 -> Double -avgScale t = sqrt (abs (x1*y2 - y1*x2)) - where ((unr2 -> (x1,y1), unr2 -> (x2,y2)), _) = onBasis t - -{- - -avgScale is computed as the square root of the positive -determinant. Proofs for the specified properties: - -1. sqrt (|det (scaling k)|) = sqrt (k^2) = k -2. sqrt (|det t1|) * sqrt (|det t2|) - = sqrt (|det t1| * |det t2|) - = sqrt (|det t1 * det t2|) - = sqrt (|det (t1 * t2)|) - -From wikipedia: - - A geometric interpretation can be given to the value of the - determinant of a square matrix with real entries: the absolute - value of the determinant gives the scale factor by which area or - volume (or a higher dimensional analogue) is multiplied under the - associated linear transformation, while its sign indicates whether - the transformation preserves orientation. - --} diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index d1bf03cb..f184b888 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -25,25 +25,21 @@ module Diagrams.TwoD.Types , P2, p2, mkP2, unp2, p2Iso , T2 - -- * Angles - , Angle - , rad, turn, deg - , fullTurn, fullCircle, angleRatio - , (@@) ) where -import Control.Lens (Iso', Wrapped(..), Rewrapped, iso - , review , (^.), _1, _2) +import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, + lens, (^.), _1, _2) +import Diagrams.Angle import Diagrams.Coordinates import Diagrams.Core import Data.AffineSpace.Point import Data.Basis -import Data.MemoTrie (HasTrie (..)) +import Data.MemoTrie (HasTrie (..)) import Data.VectorSpace -import Data.Typeable +import Data.Data ------------------------------------------------------------ -- 2D Euclidean space @@ -77,7 +73,7 @@ import Data.Typeable data R2 = R2 {-# UNPACK #-} !Double {-# UNPACK #-} !Double - deriving (Eq, Ord, Typeable) + deriving (Eq, Ord, Typeable, Data) instance AdditiveGroup R2 where zeroV = R2 0 0 @@ -184,6 +180,13 @@ instance HasX R2 where instance HasY R2 where _y = r2Iso . _2 +instance HasTheta R2 where + _theta = lens (\v -> atanA (v^._y / v^._x)) + (\v θ -> let r = magnitude v in R2 (r * cosA θ) (r * sinA θ)) + +instance HasR R2 where + _r = lens magnitude (\v r -> let s = r/magnitude v in s *^ v) + -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '^&' (see @@ -235,55 +238,9 @@ instance HasX P2 where instance HasY P2 where _y = p2Iso . _2 ------------------------------------------------------------- --- Angles - --- | 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) - -instance VectorSpace Angle where - type Scalar Angle = Double - s *^ Radians t = Radians (s*t) - --- | 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 --- | 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))) +instance HasR P2 where + _r = _relative origin . _r --- | 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 -fullTurn = 1 @@ turn - --- | Deprecated synonym for 'fullTurn', retained for backwards compatibility. -fullCircle :: Angle -fullCircle = fullTurn - --- | Calculate ratio between two angles. -angleRatio :: Angle -> Angle -> Double -angleRatio a b = (a^.rad) / (b^.rad) - - --- | @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 @@ +instance HasTheta P2 where + _theta = _relative origin . _theta diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 9d4a7ee1..4c3ecc85 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,8 +23,9 @@ module Diagrams.TwoD.Vector ) where import Control.Lens ((^.)) -import Data.AdditiveGroup import Data.VectorSpace ((<.>)) + +import Diagrams.Angle import Diagrams.TwoD.Types import Diagrams.Coordinates @@ -50,15 +51,6 @@ unit_Y = 0 ^& (-1) direction :: R2 -> Angle direction (coords -> x :& y) = atan2 y x @@ rad --- | Compute the counterclockwise angle from the first vector to the second. -angleBetween :: R2 -> R2 -> Angle -angleBetween v1 v2 - | 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 -> R2 fromDirection a = cos a' ^& sin a' diff --git a/test/Arrowtest.hs b/test/Arrowtest.hs index ec5ec5c1..04e0f6ef 100644 --- a/test/Arrowtest.hs +++ b/test/Arrowtest.hs @@ -12,10 +12,10 @@ module Main where -import Diagrams.Prelude +import Control.Lens ((%~), (&), (.~)) import Diagrams.Backend.SVG import Diagrams.Backend.SVG.CmdLine -import Control.Lens ((.~), (&), (%~)) +import Diagrams.Prelude -- | example 0 ------------------------------------------------------------ @@ -68,4 +68,4 @@ example = d # connect' (with & arrowHead .~ dart & arrowTail .~ noTail === row3 -main = defaultMain $ ( example # pad 1.1) \ No newline at end of file +main = defaultMain $ ( example # centerXY) # pad 1.1 diff --git a/test/SplitAttr.hs b/test/SplitAttr.hs new file mode 100644 index 00000000..6c7f3366 --- /dev/null +++ b/test/SplitAttr.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Applicative +import Control.Lens ((%~), (&), _Wrapping') +import Control.Monad +import qualified Data.Map as M +import Data.Semigroup +import Data.Tree +import Data.Typeable +import Diagrams.Attributes.Compile +import Diagrams.Core +import Diagrams.Core.Style +import Diagrams.Core.Types +import Diagrams.Prelude (R2) +import Test.QuickCheck + +data FakePath = Ln | Lp + deriving (Show, Eq, Typeable) + +type instance V FakePath = R2 + +instance Transformable FakePath where + transform _ = id + +instance Renderable FakePath NullBackend where + render _ _ = undefined + +instance IsPrim FakePath where + +data A = A + deriving (Typeable, Show, Eq, Ord) +instance Semigroup A where + A <> A = A +instance AttributeClass A + +data B = B + deriving (Typeable, Show, Eq, Ord) +instance Semigroup B where + B <> B = B +instance AttributeClass B + +data FillLoopsTest = FillLoopsTest + +instance SplitAttribute FillLoopsTest where + type AttrType FillLoopsTest = A + type PrimType FillLoopsTest = FakePath + + primOK _ l = l == Lp + +showRTree :: RTree b v a -> String +showRTree = drawTree . fmap show + +instance Show (RNode b v a) where + show (RStyle s) = "<" ++ showAttr A s ++ showAttr B s ++ ">" + show (RPrim _ (Prim p)) = + case cast p of + Nothing -> "

" + Just (fp :: FakePath) -> "\"" ++ show fp ++ "\"" + show _ = "." + +showAttr :: forall a v. (Show a, AttributeClass a) => a -> Style v -> String +showAttr _ s = maybe "" show (getAttr s :: Maybe a) + +instance Eq (RNode b v a) where + r1 == r2 = show r1 == show r2 + +instance Arbitrary (RNode b v a) where + arbitrary = oneof [pure REmpty, s $ attrToStyle A, s $ attrToStyle B, s $ attrToStyle A <> attrToStyle B] + where + s = pure . RStyle + shrink REmpty = [] + shrink _ = [REmpty] + +arbPrim :: Gen (RNode NullBackend R2 ()) +arbPrim = (RPrim mempty . Prim) <$> elements [Ln, Lp] + +genTree :: Int -> Gen (Tree (RNode NullBackend R2 ())) +genTree n | n <= 0 = Node <$> arbitrary <*> pure [] +genTree n = do + len <- choose (0,3) + if len == 0 + then Node <$> arbPrim <*> pure [] + else Node <$> arbitrary <*> replicateM len (genTree (n - 1)) + +instance Arbitrary (Tree (RNode NullBackend R2 ())) where + arbitrary = sized genTree + shrink (Node r ts) + = [ t | t <- ts ] + ++ [ Node r ts' | ts' <- splices ts ] + ++ [ Node r' ts | r' <- shrink r ] + ++ [ Node r ts' | ts' <- shrink ts ] + where + splices :: [Tree a] -> [[Tree a]] + splices [] = [] + splices (t@(Node _ cs) : ts) = (cs ++ ts) : (map (t :) (splices ts)) + +splitA = splitAttr FillLoopsTest + +newtype PrettyTree = PT (RTree NullBackend R2 ()) + deriving (Arbitrary) + +instance Show PrettyTree where + show (PT t) = showRTree t + +------------------------------------------------------------ +-- Properties! + +-- should preserve semantics +-- should result in attributes in question only being over OK nodes +-- should not move other attributes + +{- + +-- Should preserve tree shape? +-- Actually, this isn't true (and shouldn't be)! New RStyle nodes have +-- to get introduced sometimes. + +class Matchable m where + matches :: m -> m -> Bool + matches _ _ = True + +instance Matchable m => Matchable [m] where + matches [] [] = True + matches (x:xs) (y:ys) = matches x y && matches xs ys + matches _ _ = False + +instance Matchable m => Matchable (Tree m) where + matches (Node x xs) (Node y ys) + = matches x y && matches xs ys + +instance Matchable (RNode b v a) + +prop_split_pres_shape :: PrettyTree -> Bool +prop_split_pres_shape (PT t) = matches t (splitA t) +-} + +-- Should preserve semantics + +type AB = (Maybe A, Maybe B) + +removeA :: AB -> AB +removeA (_,b) = (Nothing,b) + +flattenTree :: Style R2 -> RTree NullBackend R2 () -> [(Style R2, FakePath)] +flattenTree sty (Node REmpty ts) = flattenForest sty ts +flattenTree sty (Node (RStyle sty') ts) = flattenForest (sty <> sty') ts +flattenTree sty (Node (RPrim _ (Prim p)) _) = + case cast p of + Nothing -> [] + Just (l :: FakePath) -> [(sty, l)] +flattenTree sty _ = [] + +flattenForest :: Style R2 -> [RTree NullBackend R2 ()] -> [(Style R2, FakePath)] +flattenForest = concatMap . flattenTree + +semantics :: RTree NullBackend R2 () -> [(AB, FakePath)] +semantics = map postProcess . flattenTree mempty + where + styleToAB :: Style R2 -> AB + styleToAB = (,) <$> getAttr <*> getAttr + postProcess (sty, l) = ((if l == Ln then removeA else id) (styleToAB sty), l) + +prop_splitA_pres_semantics :: PrettyTree -> Bool +prop_splitA_pres_semantics (PT t) = semantics t == semantics (splitA t) + +-- Ha, this one caught a bug! Success! =D