├── CHANGELOG-PENDING.md ├── Setup.hs ├── test ├── Shapes.hs ├── ShapeTest.hs ├── BBTest.hs ├── Gradient │ ├── Ball.hs │ └── rectGrad.hs ├── Issue323.hs ├── Diagrams │ └── Test │ │ ├── Transform │ │ └── Matrix.hs │ │ ├── Angle.hs │ │ ├── Direction.hs │ │ ├── TwoD │ │ ├── Segment.hs │ │ └── Offset.hs │ │ ├── TwoD.hs │ │ ├── Transform.hs │ │ └── Trail.hs ├── Test.hs ├── PolyTest.hs ├── bezbench.hs ├── clipTo.hs ├── Issue57.hs ├── Speed.hs ├── Arcs.hs ├── diamBench.hs ├── splitTests.hs ├── Arrowtest.hs └── Snugtest.hs ├── .authorspellings ├── README.markdown ├── .gitignore ├── diagrams ├── src_Diagrams_TwoD_Shapes_triangleEx.svg ├── src_Diagrams_Trail_lineFromOffsetsEx.svg ├── src_Diagrams_TwoD_Shapes_rectEx.svg ├── src_Diagrams_Trail_lineFromVerticesEx.svg ├── src_Diagrams_TrailLike_fromOffsetsEx.svg ├── src_Diagrams_TwoD_Curvature_diagramA.svg ├── src_Diagrams_TwoD_Shapes_pentagonEx.svg ├── src_Diagrams_TwoD_Shapes_hexagonEx.svg ├── src_Diagrams_TrailLike_fromSegmentsEx.svg ├── src_Diagrams_TwoD_Shapes_heptagonEx.svg ├── src_Diagrams_TwoD_Shapes_octagonEx.svg ├── src_Diagrams_TwoD_Shapes_nonagonEx.svg ├── src_Diagrams_TwoD_Shapes_decagonEx.svg ├── src_Diagrams_TwoD_Shapes_hendecagonEx.svg ├── src_Diagrams_TwoD_Shapes_dodecagonEx.svg ├── src_Diagrams_TrailLike_fromVerticesEx.svg ├── src_Diagrams_Trail_trailOffsetEx.svg ├── src_Diagrams_Trail_glueLineEx.svg ├── src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg ├── src_Diagrams_Trail_closeLineEx.svg ├── src_Diagrams_TwoD_Shapes_unitSquareEx.svg ├── src_Diagrams_TwoD_Arc_arc'Ex.svg ├── src_Diagrams_TwoD_Shapes_squareEx.svg ├── src_Diagrams_Combinators_strutEx.svg ├── src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg ├── src_Diagrams_TwoD_Curvature_diagramNeg.svg ├── src_Diagrams_TwoD_Curvature_diagramPos.svg ├── src_Diagrams_TwoD_Arc_wedgeEx.svg ├── src_Diagrams_TwoD_Curvature_diagramZero.svg ├── src_Diagrams_TwoD_Shapes_hruleEx.svg ├── src_Diagrams_TrailLike_explodeTrailEx.svg ├── src_Diagrams_Combinators_withEnvelopeEx.svg ├── src_Diagrams_TwoD_Arrowheads_tri'Ex.svg ├── src_Diagrams_TwoD_Arrowheads_triEx.svg ├── src_Diagrams_TwoD_Arrowheads_tri25Ex.svg ├── src_Diagrams_TwoD_Arrowheads_blockEx.svg ├── src_Diagrams_Combinators_besideEx.svg ├── src_Diagrams_TwoD_Shapes_vruleEx.svg ├── src_Diagrams_TwoD_Arc_annularWedgeEx.svg ├── src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg ├── src_Diagrams_TwoD_Arrowheads_halfDartEx.svg ├── src_Diagrams_TwoD_Arrowheads_spike'Ex.svg ├── src_Diagrams_TwoD_Arrowheads_spikeEx.svg ├── src_Diagrams_TwoD_Arrowheads_dart'Ex.svg ├── src_Diagrams_TwoD_Arrowheads_dartEx.svg ├── src_Diagrams_TwoD_Shapes_roundedRectEx.svg ├── src_Diagrams_TwoD_Arc_arcBetweenEx.svg ├── src_Diagrams_TwoD_Arrowheads_quillEx.svg ├── src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg ├── src_Diagrams_TwoD_Arrowheads_thornEx.svg ├── src_Diagrams_TwoD_Offset_expandLoopExample.svg ├── src_Diagrams_Combinators_alignedEx2.svg ├── src_Diagrams_Combinators_alignedEx1.svg ├── src_Diagrams_CubicSpline_Boehm_bsplineEx.svg ├── src_Diagrams_TwoD_Offset_offsetTrailExample.svg ├── src_Diagrams_TwoD_Arrow_example1.svg ├── src_Diagrams_Combinators_appendsEx.svg ├── src_Diagrams_TwoD_Offset_expandTrailExample.svg ├── src_Diagrams_CubicSpline_cubicSplineEx.svg └── src_Diagrams_TwoD_Arrow_example2.svg ├── .github └── workflows │ └── bump.yaml ├── misc ├── stylish-haskell.yaml └── DKSolve.hs ├── src ├── Linear │ └── Vector │ │ └── Compat.hs └── Diagrams │ ├── ThreeD │ ├── Deform.hs │ ├── Vector.hs │ ├── Size.hs │ ├── Light.hs │ └── Types.hs │ ├── Envelope.hs │ ├── Points.hs │ ├── TwoD │ ├── Deform.hs │ ├── Points.hs │ ├── Ellipse.hs │ ├── Size.hs │ ├── Types.hs │ ├── Vector.hs │ └── Adjust.hs │ ├── Names.hs │ ├── Trace.hs │ ├── CubicSpline │ └── Internal.hs │ ├── ThreeD.hs │ ├── Transform │ └── Matrix.hs │ ├── Direction.hs │ ├── Query.hs │ ├── CubicSpline.hs │ ├── Prelude.hs │ ├── Animation │ └── Active.hs │ ├── Parametric │ └── Adjust.hs │ ├── Coordinates.hs │ └── Transform.hs └── LICENSE /CHANGELOG-PENDING.md: -------------------------------------------------------------------------------- 1 | # Pending Changes 2 | 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Shapes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Diagrams.Backend.Cairo.CmdLine 4 | import Diagrams.Prelude 5 | 6 | main = defaultMain (eqTriangle === square 1) 7 | -------------------------------------------------------------------------------- /test/ShapeTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Diagrams.Backend.Cairo.CmdLine 4 | import Diagrams.Prelude 5 | 6 | main = defaultMain (eqTriangle 1 === square 1 === octagon 1) 7 | -------------------------------------------------------------------------------- /.authorspellings: -------------------------------------------------------------------------------- 1 | Ryan Yates , fryguybob@gmail 2 | Kanchalai Suveepattananont , ksuvee@seas 3 | Scott Walck , walck@lvc 4 | Michael Sloan , mgsloan@gmail 5 | Peter Hall , peter.hall@memorphic -------------------------------------------------------------------------------- /test/BBTest.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | import Diagrams.BoundingBox 4 | 5 | instance Arbitrary (NonEmptyBoundingBox Q2) where 6 | arbitrary = do 7 | p <- arbitrary 8 | PosVec v <- arbitrary 9 | return $ NonEmptyBoundingBox p (p .+^ v) 10 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | [![Build Status](https://github.com/diagrams/diagrams-lib/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/diagrams/diagrams-lib/actions/workflows/haskell-ci.yml) 2 | 3 | The standard library for 4 | [diagrams](http://projects.haskell.org/diagrams/), a Haskell embedded 5 | domain-specific language for compositional, declarative drawing. 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virthualenv 8 | *~ 9 | *_flymake.* 10 | .hsenv_* 11 | dist_* 12 | history 13 | TAGS 14 | .diagrams-cache 15 | /cabal.sandbox.config 16 | /cabal.config 17 | /.cabal-sandbox/ 18 | \#* 19 | .stack-work 20 | dist-newstyle/ 21 | 22 | # editor-generated files 23 | .idea/ 24 | *.iml 25 | 26 | .ghc.environment.* -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_triangleEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.github/workflows/bump.yaml: -------------------------------------------------------------------------------- 1 | name: Create dependency bump PR 2 | on: 3 | # allows manual triggering from https://github.com/../../actions/workflows/bump.yml 4 | workflow_dispatch: 5 | # runs weekly on Thursday at 8:00 6 | schedule: 7 | - cron: '0 8 * * 4' 8 | 9 | permissions: 10 | contents: write 11 | pull-requests: write 12 | 13 | jobs: 14 | bump: 15 | runs-on: ubuntu-latest 16 | steps: 17 | - uses: nomeata/haskell-bounds-bump-action@main 18 | with: 19 | test: true 20 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Trail_lineFromOffsetsEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_rectEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Trail_lineFromVerticesEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TrailLike_fromOffsetsEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Curvature_diagramA.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_pentagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_hexagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TrailLike_fromSegmentsEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_heptagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Gradient/Ball.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module Main where 4 | 5 | import Diagrams.Backend.Rasterific.CmdLine 6 | import Diagrams.Prelude 7 | 8 | radial = mkRadialGradient (mkStops [(white,0,1), (black,1,1)]) ((-0.1) ^& (0.1)) 0.06 (0 ^& 0) 0.35 GradPad 9 | linear = mkLinearGradient (mkStops [(black,0,1), (white,1,1)]) (0 ^& (-0.5)) (0 ^& 0.5) GradPad 10 | 11 | 12 | example = circle 0.25 # fillTexture radial # lw none <> square 1 # fillTexture linear # lw none 13 | main = defaultMain $ example # scaleX 1 # pad 1.1 14 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_octagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_nonagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_decagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_hendecagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_dodecagonEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TrailLike_fromVerticesEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Issue323.hs: -------------------------------------------------------------------------------- 1 | {- From bug report by Mike Zuser (Issue #323): 2 | 3 | segmentSegment can fail to terminate on very specific and seemingly innocuous inputs 4 | -} 5 | 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | import Diagrams.Prelude 9 | import Diagrams.TwoD.Segment 10 | 11 | d = 72 -- ~ 71.9 to 72.1 12 | r = d/64 -- ~ 64 to 64.0000001 13 | e = 6.969e-8 -- ~ <= 6.969e-8 14 | 15 | path :: Path V2 Double 16 | path = circle r # translateY d 17 | 18 | trails :: [Located (Trail V2 Double)] 19 | trails = head $ explodePath path 20 | 21 | (s0:s1:_) = map (head . fixTrail) trails 22 | 23 | bad = segmentSegment e s0 s1 24 | 25 | -- Does not terminate or produce output. 26 | main = print bad 27 | -------------------------------------------------------------------------------- /misc/stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | steps: 5 | # Import cleanup 6 | - imports: 7 | # global produced the smallest diff 8 | align: global 9 | 10 | # Language pragmas 11 | - language_pragmas: 12 | style: vertical 13 | remove_redundant: true 14 | 15 | # Align the types in record declarations 16 | - records: {} 17 | 18 | # Remove trailing whitespace 19 | - trailing_whitespace: {} 20 | 21 | # unused steps - UnicodeSyntax, tabs to spaces 22 | 23 | # Wrap to 100 columns, because I feel like it 24 | columns: 100 25 | 26 | # No language extensions are enabled by default. 27 | # language_extensions: 28 | # - TemplateHaskell 29 | # - QuasiQuotes 30 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Trail_trailOffsetEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Trail_glueLineEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Linear/Vector/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | -- | 4 | -- Module : Linear.Vector.Compat 5 | -- Copyright : (c) 2024 diagrams-lib team (see LICENSE) 6 | -- License : BSD-style (see LICENSE) 7 | -- Maintainer : diagrams-discuss@googlegroups.com 8 | -- 9 | -- Compatibility layer for working with versions of linear both before 10 | -- (< 1.23) and after (>= 1.23) the interpolation direction of `lerp` 11 | -- was reversed. 12 | module Linear.Vector.Compat (lerp) where 13 | 14 | import qualified Linear.Vector as V 15 | 16 | -- | Linearly interpolate between two vectors, such that @lerp 0 x y = 17 | -- x@ and @lerp 1 x y = 1@. 18 | lerp :: (V.Additive f, Num a) => a -> f a -> f a -> f a 19 | lerp = 20 | #if MIN_VERSION_linear(1,23,0) 21 | V.lerp 22 | #else 23 | V.lerp . (1-) 24 | #endif 25 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Offset_offsetTrailLeftExample.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Trail_closeLineEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Diagrams/Test/Transform/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | 4 | 5 | module Diagrams.Test.Transform.Matrix where 6 | 7 | 8 | import Test.Tasty 9 | import Test.Tasty.QuickCheck 10 | import Diagrams.Transform.Matrix 11 | import Diagrams.Prelude 12 | import Data.Distributive (distribute) 13 | 14 | import Instances 15 | 16 | tests :: TestTree 17 | tests = testGroup "Transform.Matrix" 18 | [ 19 | testProperty "mkMat column vectors (2D)" $ 20 | \(Blind (t :: T2 Double)) -> distribute (mkMat t) =~ V2 (transform t unitX) (transform t unitY) 21 | , testProperty "mkMat / fromMat22" $ 22 | \(m :: V2 (V2 Double)) -> mkMat (fromMat22 m zero) =~ m 23 | 24 | , testProperty "mkMat / fromMat33" $ 25 | \(m :: V3 (V3 Double)) -> mkMat (fromMat33 m zero) =~ m 26 | ] 27 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_unitSquareEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD/Deform.hs: -------------------------------------------------------------------------------- 1 | module Diagrams.ThreeD.Deform 2 | ( parallelX0, perspectiveX1, facingX 3 | , parallelY0, perspectiveY1, facingY 4 | , parallelZ0, perspectiveZ1, facingZ 5 | ) where 6 | 7 | import Control.Lens 8 | 9 | import Diagrams.Deform 10 | import Diagrams.TwoD.Deform 11 | 12 | import Linear.V3 13 | import Linear.Vector 14 | 15 | -- | The parallel projection onto the plane z=0 16 | parallelZ0 :: (R3 v, Num n) => Deformation v v n 17 | parallelZ0 = Deformation (_z .~ 0) 18 | 19 | -- | The perspective division onto the plane z=1 along lines going 20 | -- through the origin. 21 | perspectiveZ1 :: (R3 v, Functor v, Fractional n) => Deformation v v n 22 | perspectiveZ1 = Deformation $ \p -> p ^/ (p ^. _z) 23 | 24 | facingZ :: (R3 v, Functor v, Fractional n) => Deformation v v n 25 | facingZ = Deformation $ 26 | \p -> let z = p ^. _z 27 | in p ^/ z & _z .~ z 28 | 29 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty (TestTree, defaultMain, testGroup) 2 | 3 | import qualified Diagrams.Test.Angle as Angle 4 | import qualified Diagrams.Test.Direction as Direction 5 | import qualified Diagrams.Test.Transform as Transform 6 | import qualified Diagrams.Test.Transform.Matrix as TransformMatrix 7 | import qualified Diagrams.Test.TwoD as TwoD 8 | import qualified Diagrams.Test.TwoD.Offset as TwoD.Offset 9 | import qualified Diagrams.Test.TwoD.Segment as TwoD.Segment 10 | 11 | import qualified Diagrams.Test.Trail as Trail 12 | 13 | tests :: TestTree 14 | tests = testGroup "unit tests" 15 | [ testGroup "TwoD.Offset" TwoD.Offset.tests 16 | , testGroup "TwoD.Segment" TwoD.Segment.tests 17 | , TwoD.tests 18 | , Angle.tests 19 | , Direction.tests 20 | , Transform.tests 21 | , TransformMatrix.tests 22 | , Trail.tests 23 | ] 24 | 25 | main :: IO () 26 | main = defaultMain tests 27 | -------------------------------------------------------------------------------- /test/PolyTest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Diagrams.Backend.Cairo.CmdLine 4 | import Diagrams.Prelude 5 | 6 | import Diagrams.TwoD.Polygons 7 | 8 | -- d = stroke . close $ fromVertices (polyPoints with { polyStar = StarFun succ }) 9 | 10 | vs = take 10 $ iterate (rotateBy (1/20 :: CircleFrac)) unitX 11 | 12 | mkR v = (mconcat . mconcat $ p) 13 | <> fromVertices [origin, origin .+^ v] 14 | where 15 | p = map (zipWith lc (red : repeat black)) $ 16 | (map (map stroke)) 17 | (explodePath (polygon (with & polyOrient .~ OrientTo v ))) 18 | 19 | d = hcat' with {sep = 0.5} (map mkR vs) 20 | # lw 0.05 21 | 22 | s = stroke $ starPoly (StarSkip 5) 23 | (polygon (with & polyType .~ PolyPolar 24 | (repeat (tau/15 :: Rad)) 25 | (take 15 (cycle [6,7,8])) 26 | )) 27 | 28 | main = defaultMain (pad 1.1 s) 29 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arc_arc'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_squareEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/Envelope.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Diagrams.Envelope 4 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- \"Envelopes\", aka functional bounding regions. See 9 | -- "Diagrams.Core.Envelope" for internal implementation details. 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Diagrams.Envelope 14 | ( -- * Types 15 | Envelope, Enveloped 16 | 17 | -- * Diagram envelopes 18 | , envelope, setEnvelope, withEnvelope, phantom 19 | , pad, extrudeEnvelope, intrudeEnvelope 20 | 21 | -- * Querying envelopes 22 | , envelopeVMay, envelopeV, envelopePMay, envelopeP 23 | , diameter, radius 24 | 25 | ) where 26 | 27 | import Diagrams.Core (envelope, setEnvelope) 28 | import Diagrams.Core.Envelope 29 | 30 | import Diagrams.Combinators 31 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Combinators_strutEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/bezbench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | import Criterion.Main 6 | import Data.NumInstances 7 | import Data.VectorSpace 8 | import Diagrams.Segment 9 | 10 | type Q2 = (Rational,Rational) 11 | type R2 = (Double,Double) 12 | 13 | instance AdditiveGroup (Rational) where { zeroV=0; (^+^) = (+); negateV = negate } 14 | 15 | instance VectorSpace (Rational) where 16 | type Scalar (Rational) = Rational 17 | (*^) = (*) 18 | 19 | b = Cubic (0,1) (1,1) (1,0) 20 | test f = [ f t | t <- [0.0,0.01..1.0] ] 21 | 22 | atParam' c@(Cubic _ _ _) t = x 23 | where ((Cubic _ _ x),_) = splitAtParam c t 24 | 25 | main = defaultMain 26 | [ bench "atParam R2" $ nf (\b -> test $ atParam b) (b :: Segment R2) 27 | , bench "atParam' R2" $ nf (\b -> test $ atParam' b) (b :: Segment R2) 28 | , bench "atParam Q2" $ nf (\b -> test $ atParam b) (b :: Segment Q2) 29 | , bench "atParam' Q2" $ nf (\b -> test $ atParam' b) (b :: Segment Q2) 30 | ] 31 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Offset_offsetTrailOuterExample.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Curvature_diagramNeg.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Curvature_diagramPos.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arc_wedgeEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Curvature_diagramZero.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Diagrams/Test/Angle.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Diagrams.Test.Angle where 4 | 5 | 6 | import Test.Tasty 7 | import Test.Tasty.QuickCheck 8 | import Diagrams.Prelude 9 | import Instances 10 | 11 | tests :: TestTree 12 | tests = testGroup "Angle" [ 13 | testProperty "2π radians per turn" $ 14 | \θ -> θ^.rad =~ θ^.turn*2*(pi :: Double) 15 | , testProperty "360 degrees per turn" $ 16 | \θ -> θ^.deg =~ θ^.turn*(360 :: Double) 17 | , testProperty "Angle vector addition is commutative" $ 18 | \θ φ -> (θ :: Angle Double) ^+^ φ =~ φ ^+^ θ 19 | , testProperty "Angle subtraction is the inverse of addition" $ 20 | \θ φ -> (θ :: Angle Double) ^+^ φ ^-^ φ =~ θ 21 | , testProperty "Angle vector negation squared is identity" $ 22 | \θ -> negated (negated (θ :: Angle Double)) =~ θ 23 | , testProperty "A negated angle is the additive inverse of the original" $ 24 | \θ -> (θ :: Angle Double) ^+^ (negated θ) =~ 0@@turn 25 | , testProperty "A negated angle is the additive inverse of the original" $ 26 | \θ -> (θ :: Angle Double) ^+^ (negated θ) =~ 0@@turn 27 | 28 | 29 | ] 30 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD/Vector.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Diagrams.ThreeD.Vector 4 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Three-dimensional vectors. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Diagrams.ThreeD.Vector 12 | ( -- * Special 3D vectors 13 | unitX, unitY, unitZ, unit_X, unit_Y, unit_Z 14 | , xDir, yDir, zDir 15 | ) where 16 | 17 | import Control.Lens ((&), (.~)) 18 | 19 | import Diagrams.ThreeD.Types 20 | import Diagrams.TwoD.Vector 21 | import Diagrams.Direction 22 | 23 | import Linear.Vector 24 | 25 | -- | The unit vector in the positive Y direction. 26 | unitZ :: (R3 v, Additive v, Num n) => v n 27 | unitZ = zero & _z .~ 1 28 | 29 | -- | The unit vector in the negative X direction. 30 | unit_Z :: (R3 v, Additive v, Num n) => v n 31 | unit_Z = zero & _z .~ (-1) 32 | 33 | -- | A 'Direction' pointing in the Z direction. 34 | zDir :: (R3 v, Additive v, Num n) => Direction v n 35 | zDir = dir unitZ 36 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_hruleEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TrailLike_explodeTrailEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Diagrams/Test/Direction.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Diagrams.Test.Direction where 4 | 5 | 6 | import Diagrams.Direction 7 | import Diagrams.Prelude 8 | import Instances 9 | import Test.Tasty 10 | import Test.Tasty.QuickCheck 11 | 12 | tests :: TestTree 13 | tests = testGroup "Direction" [ 14 | testProperty "Length does not effect from direction" $ 15 | \(Positive f) (NonZero v) -> fromDirection(dir ((v :: V2 Double) ^* (f+0.001))) =~ fromDirection(dir v) 16 | , testProperty "HasTheta subtraction yeilds same result as anglebetween" $ 17 | (anglebetsub) 18 | , testProperty "anglebetweenDirs is commutative" $ 19 | \a b -> angleBetweenDirs (a :: Direction V2 Double) b =~ angleBetweenDirs b a 20 | , testProperty "fromdirection does not effect angleBetweenDirs" $ 21 | \a b -> angleBetween (fromDirection (a :: Direction V2 Double)) (fromDirection b) =~ angleBetweenDirs a b 22 | 23 | 24 | 25 | ] 26 | 27 | if' :: Bool -> a -> a -> a 28 | if' True x _ = x 29 | if' False _ y = y 30 | 31 | anglebetsub :: Direction V2 Double -> Direction V2 Double -> Bool 32 | anglebetsub a b = (if' (abs (a ^. _theta^.rad - b ^. _theta^.rad) < pi) 33 | (abs ((a ^. _theta ^-^ b ^. _theta)^.rad)) 34 | (2*pi - abs (a ^. _theta^.rad - b ^. _theta^.rad) ) =~ angleBetweenDirs a b ^.rad) 35 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Combinators_withEnvelopeEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/Points.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Diagrams.Points 4 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Points in space. For more tools for working with points and 9 | -- vectors, see "Linear.Affine". 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Diagrams.Points 14 | ( -- * Points 15 | Point (..), origin, (*.) 16 | 17 | -- * Point-related utilities 18 | , centroid 19 | , pointDiagram 20 | , _Point, lensP 21 | ) where 22 | 23 | import Diagrams.Core (pointDiagram) 24 | import Diagrams.Core.Points 25 | 26 | import Data.Foldable as F 27 | 28 | import Linear.Affine 29 | import Linear.Vector 30 | 31 | -- | The centroid of a set of /n/ points is their sum divided by /n/. 32 | -- Returns the origin for an empty list of points. 33 | centroid :: (Additive v, Fractional n) => [Point v n] -> Point v n 34 | centroid [] = origin 35 | centroid ps = meanV ps 36 | {-# INLINE centroid #-} 37 | 38 | meanV :: (Foldable f, Additive v, Fractional a) => f (v a) -> v a 39 | meanV = uncurry (^/) . F.foldl' (\(s,c) e -> (e ^+^ s,c+1)) (zero,0) 40 | {-# INLINE meanV #-} 41 | 42 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_tri'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_triEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_tri25Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_blockEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Combinators_besideEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_vruleEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arc_annularWedgeEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_halfDart'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_halfDartEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_spike'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_spikeEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_dart'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_dartEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/clipTo.hs: -------------------------------------------------------------------------------- 1 | import Data.Maybe 2 | 3 | import Diagrams.Backend.SVG.CmdLine 4 | import Diagrams.Prelude 5 | 6 | clipPath :: Path R2 7 | clipPath = square 2 # alignR 8 | 9 | loopyStar :: Diagram B R2 10 | loopyStar = mconcat 11 | . map (cubicSpline True) 12 | . pathVertices 13 | . star (StarSkip 3) 14 | $ regPoly 7 1 15 | 16 | clippedStar :: Diagram B R2 17 | clippedStar = clipTo clipPath (loopyStar # fc lightgray) 18 | 19 | example :: Diagram B R2 20 | example = position (zip pts dots) 21 | <> traceArrows # lc cyan 22 | <> clippedStar 23 | <> loopyStar 24 | 25 | pts :: [P2] 26 | pts = [ (-1) ^& 0.9, (-0.65) ^& 0.65, (-0.25) ^& 0.65, (-0.25) ^& 0.4 27 | , (-0.1) ^& 0.9, 0.1 ^& 0.9, 0.25 ^& 0.4, 0.25 ^& 0.65 28 | , 0.65 ^& 0.65, 1 ^& 0.9 ] 29 | 30 | vecs :: [R2] 31 | vecs = [unitX, unitY, unit_X, unit_Y] 32 | 33 | tracePt :: P2 -> [Double] 34 | tracePt p = map (maybe 0 magnitude) vs where 35 | vs = (rayTraceV p) <$> vecs <*> [clippedStar] 36 | 37 | traceArrows :: Diagram B R2 38 | traceArrows = mconcat $ map ptArrows pts where 39 | ptArrows p = mconcat $ 40 | map (arrowAt' (with & headSize .~ 0.1) p) 41 | . catMaybes $ rayTraceV p <$> vecs <*> [clippedStar] 42 | 43 | traces :: [[Double]] 44 | traces = map tracePt pts 45 | 46 | dots :: [Diagram B R2] 47 | dots = repeat (circle 0.015 # fc red # lw 0) 48 | 49 | main :: IO () 50 | main = do 51 | putStr $ unlines $ map show traces 52 | mainWith $ example # centerXY # pad 1.1 53 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Shapes_roundedRectEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Deform.hs: -------------------------------------------------------------------------------- 1 | module Diagrams.TwoD.Deform where 2 | 3 | import Control.Lens 4 | 5 | import Diagrams.Deform 6 | 7 | import Linear.V2 8 | import Linear.Vector 9 | 10 | -- | The parallel projection onto the plane x=0 11 | parallelX0 :: (R1 v, Num n) => Deformation v v n 12 | parallelX0 = Deformation (_x .~ 0) 13 | 14 | -- | The perspective division onto the plane x=1 along lines going 15 | -- through the origin. 16 | perspectiveX1 :: (R1 v, Functor v, Fractional n) => Deformation v v n 17 | perspectiveX1 = Deformation $ \p -> p ^/ (p ^. _x) 18 | 19 | -- | The parallel projection onto the plane y=0 20 | parallelY0 :: (R2 v, Num n) => Deformation v v n 21 | parallelY0 = Deformation (_y .~ 0) 22 | 23 | -- | The perspective division onto the plane y=1 along lines going 24 | -- through the origin. 25 | perspectiveY1 :: (R2 v, Functor v, Floating n) => Deformation v v n 26 | perspectiveY1 = Deformation $ \p -> p ^/ (p ^. _y) 27 | 28 | -- | The viewing transform for a viewer facing along the positive X 29 | -- axis. X coördinates stay fixed, while Y coördinates are compressed 30 | -- with increasing distance. @asDeformation (translation unitX) <> 31 | -- parallelX0 <> frustrumX = perspectiveX1@ 32 | facingX :: (R1 v, Functor v, Fractional n) => Deformation v v n 33 | facingX = Deformation $ 34 | \p -> let x = p ^. _x 35 | in p ^/ x & _x .~ x 36 | 37 | facingY :: (R2 v, Functor v, Fractional n) => Deformation v v n 38 | facingY = Deformation $ 39 | \p -> let y = p ^. _y 40 | in p ^/ y & _y .~ y 41 | 42 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arc_arcBetweenEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_quillEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Issue57.hs: -------------------------------------------------------------------------------- 1 | {- From bug report by Felipe Lessa (Issue #57): 2 | 3 | Hello! 4 | 5 | I'm sorry that I didn't do my homework to investigate the "why", but I've included a very simple test case. You may compile and run the test as follows: 6 | 7 | $ ghc -O --make -fforce-recomp -rtsopts bug.hs 8 | $ ./bug -o t.png --selection=??? +RTS -s 9 | 10 | where ??? may be "hcat", "foldl1", "foldr1" or "foldTree". The program just concatenates 1,000 (rect 1 1)s. On my computer, I get the following: 11 | 12 | hcat: 23s, 130 MiB 13 | foldr1: 30s, 69 MiB 14 | foldl1: 27s, 62 MiB 15 | foldTree: 1s, 7 MiB 16 | 17 | Concatenating one thousand unit squares shouldn't take more than 20 seconds =). This is a showstopper for me, so I've reimplemented hcat (see hcatB at the end of [1]) 18 | 19 | -} 20 | 21 | -- from diagrams-lib 22 | import Diagrams.Prelude 23 | 24 | -- from diagrams-cairo 25 | import Diagrams.Backend.Cairo.CmdLine (Cairo, multiMain) 26 | 27 | main :: IO () 28 | main = multiMain [ ("hcat", hcat (dias n)) 29 | , ("foldr1", foldr1 (|||) (dias n)) 30 | , ("foldl1", foldl1 (|||) (dias n)) 31 | , ("foldTree", foldTree (|||) (dias n)) 32 | ] 33 | where 34 | n = 1000 35 | 36 | dias :: Int -> [Diagram Cairo R2] 37 | dias n = replicate n (rect 1 1) 38 | 39 | foldTree :: (a -> a -> a) -> [a] -> a 40 | foldTree f = go 41 | where 42 | go [x] = x 43 | go [] = error "foldTree: empty input" 44 | go xs = go (twoByTwo xs) 45 | 46 | twoByTwo (x1:x2:xs) = f x1 x2 : twoByTwo xs 47 | twoByTwo xs = xs 48 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_thorn'Ex.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrowheads_thornEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/Gradient/rectGrad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | module Main where 4 | 5 | import Diagrams.Backend.SVG.CmdLine 6 | import Diagrams.Prelude 7 | 8 | -- Red to White to Blue linear gradient wtih direction vector (1,0). 9 | --g = LGradient [(SomeColor red, 0, 1), (SomeColor black, 0.5, 0) 10 | -- ,(SomeColor blue, 1, 1)] (0.0 ^& 0) (0.2 ^& 0) (scaling 1) GradReflect 11 | 12 | stops = mkStops [(orange, 0, 1), (white, 0.5, 1), (blue, 1, 1)] 13 | g = defaultRG & _RG . rGradStops .~ stops 14 | stops' = mkStops [(lightskyblue, 0, 1), (darkgreen, 1, 0.5)] 15 | h = mkLinearGradient stops ((-10) ^& (-10)) (10 ^& (10)) GradReflect 16 | h' = mkLinearGradient stops' ((-50) ^& 0) (50 ^& 0) GradPad 17 | 18 | linear = mkLinearGradient (mkStops [(black,0,1), (white,1,1)]) (0 ^& (-300)) (0 ^& 300) GradPad 19 | radial = mkRadialGradient (mkStops [(orange, 0.0, 0.4) 20 | , (orange, 0.05, 1) 21 | , (gray, 0.35, 0.25) 22 | , (teal, 0.50, 1)]) 23 | (0 ^& 0) 10 24 | (0 ^& 0) 20 GradRepeat 25 | 26 | 27 | s = square 100 # fillTexture h # lineTexture h' # lw ultraThick # scaleX 1.5 28 | s' = square 100 # fillTexture radial # lineTexture h' # lw ultraThick # scaleX 1.5 29 | 30 | e1 = vcat' (with & sep .~ 35) [s', s # rotateBy (1/16), s # rotateBy (1/8)] 31 | e2 = vcat' (with & sep .~ 35) [s # rotateBy (3/16), s' # rotateBy (1/4), s # rotateBy (5/16)] 32 | e3 = vcat' (with & sep .~ 35) [s # rotateBy (3/8), s # rotateBy (7/16), s' # rotateBy (1/2)] 33 | example = hcat' (with & sep .~ 25) [e1, e2, e3] 34 | 35 | main = defaultMain $ (example # centerXY # pad 1.1) <> (square 600 # fillTexture linear) 36 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Offset_expandLoopExample.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.ThreeD.Size 8 | -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Utilities for working with sizes of three-dimensional objects. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | module Diagrams.ThreeD.Size 16 | ( 17 | -- ** Computing sizes 18 | extentX, extentY, extentZ 19 | 20 | -- ** Specifying sizes 21 | , mkSizeSpec3D 22 | , dims3D 23 | 24 | ) where 25 | 26 | import Diagrams.Core 27 | import Diagrams.Core.Envelope 28 | import Diagrams.Size 29 | import Diagrams.TwoD.Size 30 | import Diagrams.ThreeD.Types 31 | import Diagrams.ThreeD.Vector 32 | 33 | ------------------------------------------------------------ 34 | -- Computing diagram sizes 35 | ------------------------------------------------------------ 36 | 37 | -- | Compute the absolute z-coordinate range of an enveloped object in 38 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 39 | -- envelope. 40 | extentZ :: (InSpace v n a, R3 v, Enveloped a) => a -> Maybe (n, n) 41 | extentZ = extent unitZ 42 | 43 | -- | Make a 'SizeSpec' from possibly-specified width and height. 44 | mkSizeSpec3D :: Num n => Maybe n -> Maybe n -> Maybe n -> SizeSpec V3 n 45 | mkSizeSpec3D x y z = mkSizeSpec (V3 x y z) 46 | 47 | -- | Make a 'SizeSpec' from a width and height. 48 | dims3D :: n -> n -> n -> SizeSpec V3 n 49 | dims3D x y z = dims (V3 x y z) 50 | 51 | -------------------------------------------------------------------------------- /test/Speed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Main where 6 | 7 | import Criterion 8 | import Criterion.Main (defaultMain) 9 | 10 | import Diagrams.Prelude 11 | 12 | 13 | main :: IO () 14 | main = defaultMain 15 | [ bgroup "rotates" 16 | [ bench "rotate" $ whnf (rotate (90 @@ deg :: Angle Double)) (V2 3 3) 17 | ,bench "rotate1" $ whnf (rotate' (90 @@ deg :: Angle Double)) (V2 3 3) 18 | ,bench "rotate2" $ whnf (rotate'' (90 @@ deg :: Angle Double)) (V2 3 3) 19 | ] 20 | ] 21 | 22 | --the original " '' " and a secondary " ' " rotate function for comparing speed testing 23 | --note: function time changes dramatically when function is in this file rather than imported 24 | 25 | 26 | rotation' :: Floating n => Angle n -> T2 n 27 | rotation' theta = fromLinear r (linv r) 28 | where 29 | r = rot theta <-> rot (negated theta) 30 | rot th (V2 x y) = V2 (c * x - s * y) 31 | (s * x + c * y) 32 | where 33 | c = cosA th 34 | s = sinA th 35 | 36 | rotate' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t 37 | rotate' = transform . rotation' 38 | 39 | rotation'' :: Floating n => Angle n -> T2 n 40 | rotation'' theta = fromLinear r (linv r) 41 | where 42 | r = rot theta <-> rot (negated theta) 43 | rot th (V2 x y) = V2 (cosA th * x - sinA th * y) 44 | (sinA th * x + cosA th * y) 45 | 46 | rotate'' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t 47 | rotate'' = transform . rotation'' 48 | -------------------------------------------------------------------------------- /misc/DKSolve.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------ 2 | -- Durand-Kerner method 3 | ------------------------------------------------------------ 4 | 5 | -- See http://en.wikipedia.org/wiki/Durand–Kerner_method 6 | 7 | 8 | import Data.Complex 9 | import Data.List (inits, tails) 10 | 11 | eps :: Double 12 | eps = 1e-14 13 | 14 | -- | Given as input a list of polynomial coefficients (least 15 | -- significant first), return a list of the /real/ roots. 16 | durandKerner :: [Double] -> [Double] 17 | durandKerner as = map realPart . filter ((<(sqrt eps)) . abs . imagPart) . fixedPt eps (dkIter as) $ initial 18 | where initial = take (length as - 1) $ iterate (*(0.4 :+ 0.9)) 1 19 | 20 | -- | Given the polynomial coefficients, perform one iteration of the 21 | -- D-K method. 22 | dkIter :: [Double] -> [Complex Double] -> [Complex Double] 23 | dkIter as rs = zipWith (-) rs (zipWith (/) evals denoms) 24 | where evals = map (eval as) rs 25 | denoms = zipWith mkDenom rs (drops rs) -- (skipZip rs' rs) 26 | mkDenom r = product . map ((-) r) 27 | 28 | drops :: [a] -> [[a]] 29 | drops [x] = [[]] 30 | drops (x:xs) = xs : map (x:) (drops xs) 31 | 32 | {- 33 | skipZip :: [a] -> [a] -> [[a]] 34 | skipZip xs ys = zipWith (++) (initsL xs) (tail (tails ys)) 35 | 36 | initsL :: [a] -> [[a]] 37 | initsL xs = [] : initsL' xs 38 | where initsL' [] = [] 39 | initsL' (x:xs) = map (x:) (initsL xs) 40 | -} 41 | 42 | -- | Evaluate a polynomial for a complex input. 43 | eval :: [Double] -> Complex Double -> Complex Double 44 | eval as x = foldr (\a v -> (a :+ 0) + x*v) 0 as 45 | 46 | type C = Complex Double 47 | 48 | fixedPt :: Double -> ([C] -> [C]) -> [C] -> [C] 49 | fixedPt eps f as | all (( -------------------------------------------------------------------------------- /test/Diagrams/Test/TwoD/Segment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | 6 | module Diagrams.Test.TwoD.Segment 7 | ( 8 | tests 9 | ) where 10 | 11 | import qualified Test.QuickCheck.Property as Q 12 | import Test.Tasty (TestTree) 13 | import Test.Tasty.QuickCheck 14 | 15 | import Diagrams.Prelude 16 | import Diagrams.TwoD.Segment 17 | 18 | newtype InBox = InBox { unInBox :: Double } 19 | 20 | instance Arbitrary InBox where 21 | arbitrary = InBox <$> choose (-1, 1) 22 | 23 | instance Arbitrary (Point V2 Double) where 24 | arbitrary = curry p2 <$> (unInBox <$> arbitrary) 25 | <*> (unInBox <$> arbitrary) 26 | 27 | instance Arbitrary (FixedSegment V2 Double) where 28 | arbitrary = oneof [FLinear <$> arbitrary <*> arbitrary, FCubic <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary] 29 | 30 | epsT, epsE :: Double 31 | epsT = 1.0e-9 -- parameter space epsilon 32 | epsE = 1.0e-8 -- Euclidean space epsilon 33 | 34 | (.=~.) :: P2 Double -> P2 Double -> Bool 35 | x .=~. y = norm (x .-. y) < epsE 36 | 37 | tests :: [TestTree] 38 | tests = 39 | [ testProperty "segmentSegment" $ 40 | \a b -> validateIntersections a b (segmentSegment epsT a b) 41 | ] 42 | 43 | validateIntersections :: FixedSegment V2 Double -> FixedSegment V2 Double -> [(Double, Double, P2 Double)] -> Q.Result 44 | validateIntersections _ _ [] = Q.rejected -- TODO: check for false negatives (rasterize both and look for overlap?) 45 | validateIntersections a b isects = go isects 46 | where 47 | go [] = Q.succeeded 48 | go ((ta,tb,p):is) 49 | | and [ 0 <= ta && ta <= 1 50 | , 0 <= tb && tb <= 1 51 | , a `atParam` ta .=~. p 52 | , b `atParam` tb .=~. p 53 | ] = go is 54 | | otherwise = Q.failed 55 | -------------------------------------------------------------------------------- /test/Diagrams/Test/TwoD/Offset.hs: -------------------------------------------------------------------------------- 1 | module Diagrams.Test.TwoD.Offset 2 | ( 3 | tests 4 | ) where 5 | 6 | import Test.Tasty (TestTree) 7 | import Test.Tasty.HUnit 8 | 9 | import Diagrams.Prelude 10 | import Diagrams.TwoD.Offset 11 | 12 | tests :: [TestTree] 13 | tests = 14 | [ testCase "line" 15 | (offsetTrailVertices 16 | [p2 (0, 0), p2 (1, 0)] 17 | [p2 (0, -1), p2 (1, -1)]) 18 | , testCase "square" 19 | (offsetTrailVertices 20 | [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] 21 | [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) 22 | , testCase "square loop" 23 | (offsetTrailLoopVertices 24 | [p2 (0, 0), p2 (1, 0), p2 (1, 1), p2 (0, 1), p2 (0, 0)] 25 | [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) 26 | , testCase "redundant line" 27 | (offsetTrailVertices 28 | [p2 (0, 0), p2 (0.5, 0), p2 (1, 0)] 29 | [p2 (0, -1), p2 (1, -1)]) 30 | , testCase "redundant square" 31 | (offsetTrailVertices 32 | [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] 33 | [p2 (0, -1), p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, 0)]) 34 | , testCase "redundant square loop" 35 | (offsetTrailLoopVertices 36 | [p2 (0, 0), p2 (1, 0), p2 (1, 0.5), p2 (1, 1), p2 (0, 1), p2 (0, 0)] 37 | [p2 (2, -1), p2 (2, 2), p2 (-1, 2), p2 (-1, -1)]) 38 | ] 39 | 40 | offsetTrailVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion 41 | offsetTrailVertices orig off = 42 | (trailVertices . offsetTrail 1 . fromVertices $ orig) @?= off 43 | 44 | offsetTrailLoopVertices :: [Point V2 Double] -> [Point V2 Double] -> Assertion 45 | offsetTrailLoopVertices orig off = 46 | (trailVertices . offsetTrail 1 . loopTrailFromVertices $ orig) @?= off 47 | where 48 | loopTrailFromVertices = (`at` origin) . wrapTrail . glueLine . lineFromVertices 49 | -------------------------------------------------------------------------------- /test/Arcs.hs: -------------------------------------------------------------------------------- 1 | import Diagrams.Backend.Postscript 2 | import Diagrams.Backend.Postscript.CmdLine 3 | import Diagrams.Prelude 4 | 5 | import Diagrams.TwoD.Arc 6 | 7 | exampleArc f r = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat 8 | [ vcat 9 | [ phantom (circle (1.05 * abs r) :: D R2) 10 | <> s # lc green # lw 0.01 11 | <> e # lc red # lw 0.01 12 | <> (lw 0.01 . stroke $ f r (n/8) (m/8)) 13 | | n <- rs 14 | , let s = rotateBy (n/8) (origin ~~ (3 & 0)) 15 | , let e = rotateBy (m/8) (origin ~~ (3 & 0)) 16 | ] 17 | | m <- rs 18 | ] 19 | where 20 | rs = [0..7 :: CircleFrac] 21 | horzLabel = centerX $ rect 5 10 # lw 0 <> (text "start angle" # scale 0.4) 22 | vertLabel = centerY . rotateBy (1/4) $ rect 5 10 # lw 0 <> (text "end angle" # scale 0.4) 23 | 24 | exampleRR :: Diagram Postscript R2 25 | exampleRR = (vertLabel |||) . centerXY . (horzLabel ===) . centerXY $ hcat 26 | [ vcat 27 | [ phantom (pad 1.1 $ rect 10 15 :: D R2) 28 | <> (origin ~~ (0 & r)) # lc red # lw 0.01 29 | <> (fc lightblue . lw 0.01 . stroke $ roundedRect' 10 15 o) 30 | | o <- [ RoundedRectOpts 0 r 0 0 31 | , RoundedRectOpts r 0 0 0 32 | , RoundedRectOpts 0 0 r 0 33 | , RoundedRectOpts 0 0 0 r 34 | ] 35 | ] 36 | | r <- [-4..4] 37 | ] 38 | where 39 | horzLabel = centerX $ rect 5 10 # lw 0 <> (text "radius [-4..4]" # scale 0.4) 40 | vertLabel = centerY . rotateBy (1/4) $ rect 5 10 # lw 0 <> (text "corner" # scale 0.4) 41 | 42 | arcs = [ ("arc' CCW", exampleArc arc' 3) 43 | , ("arc' CW" , exampleArc arc' (-3)) 44 | , ("arc CCW", exampleArc (\r s e -> arc s e # scale r) 3) 45 | , ("arcCW CCW", exampleArc (\r s e -> arcCW s e # scale (abs r)) (-3)) 46 | ] :: [(String, Diagram Postscript R2)] 47 | 48 | main = defaultMain (vcat (map snd arcs) === exampleRR) 49 | -------------------------------------------------------------------------------- /src/Diagrams/Names.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | -- for Data.Semigroup 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Diagrams.Names 11 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- Names can be given to subdiagrams, and subdiagrams can later be 16 | -- queried by name. This module exports types for representing names 17 | -- and subdiagrams, and various functions for working with them. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Diagrams.Names 22 | ( -- * Names 23 | 24 | AName, Name, IsName(..), (.>) 25 | , Qualifiable(..) 26 | 27 | -- * Subdiagrams 28 | 29 | , Subdiagram, mkSubdiagram, subPoint, getSub, rawSub, location 30 | 31 | -- * Subdiagram maps 32 | 33 | , SubMap, fromNames, rememberAs, lookupSub 34 | 35 | -- * Naming things 36 | 37 | , named, nameSub, namePoint, localize 38 | 39 | -- * Querying by name 40 | 41 | , names 42 | , lookupName 43 | , withName, withNameAll, withNames 44 | 45 | ) where 46 | 47 | import Data.Semigroup 48 | 49 | import Diagrams.Core (OrderedField, Point) 50 | import Diagrams.Core.Names 51 | import Diagrams.Core.Types 52 | 53 | import Linear.Metric 54 | 55 | -- | Attach an atomic name to a diagram. 56 | named :: (IsName nm, Metric v, OrderedField n, Semigroup m) 57 | => nm -> QDiagram b v n m -> QDiagram b v n m 58 | named = nameSub mkSubdiagram 59 | 60 | -- | Attach an atomic name to a certain point (which may be computed 61 | -- from the given diagram), treated as a subdiagram with no content 62 | -- and a point envelope. 63 | namePoint :: (IsName nm , Metric v, OrderedField n, Semigroup m) 64 | => (QDiagram b v n m -> Point v n) -> nm -> QDiagram b v n m -> QDiagram b v n m 65 | namePoint p = nameSub (subPoint . p) 66 | 67 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Combinators_alignedEx1.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Points.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Diagrams.TwoD.Points 5 | -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) 6 | -- License : BSD-style (see LICENSE) 7 | -- Maintainer : diagrams-discuss@googlegroups.com 8 | -- 9 | -- Special functions for points in R2. 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | {-# LANGUAGE TypeFamilies #-} 14 | 15 | module Diagrams.TwoD.Points where 16 | 17 | import Data.List 18 | 19 | import Diagrams.Core 20 | import Diagrams.TwoD.Vector 21 | import Diagrams.TwoD.Types (P2) 22 | 23 | import Linear.Affine 24 | 25 | -- | Find the convex hull of a list of points using Andrew's monotone chain 26 | -- algorithm O(n log n). 27 | -- 28 | -- Returns clockwise list of points starting from the left-most point. 29 | convexHull2D :: OrderedField n => [P2 n] -> [P2 n] 30 | convexHull2D ps = init upper ++ reverse (tail lower) 31 | where 32 | (upper, lower) = sortedConvexHull (sort ps) 33 | 34 | -- | Find the convex hull of a set of points already sorted in the x direction. 35 | -- The first list of the tuple is the upper hull going clockwise from 36 | -- left-most to right-most point. The second is the lower hull from 37 | -- right-most to left-most in the anti-clockwise direction. 38 | sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n]) 39 | sortedConvexHull ps = (chain True ps, chain False ps) 40 | where 41 | chain upper (p1_:p2_:rest_) = 42 | case go (p2_ .-. p1_) p2_ rest_ of 43 | Right l -> p1_:l 44 | Left l -> chain upper (p1_:l) 45 | where 46 | test = if upper then (>0) else (<0) 47 | -- find the convex hull by comparing the angles of the vectors with 48 | -- the cross product and backtracking if necessary 49 | go dir p1 l@(p2:rest) 50 | -- backtrack if the direction is outward 51 | | test $ dir `cross2` dir' = Left l 52 | | otherwise = 53 | case go dir' p2 rest of 54 | Left m -> go dir p1 m 55 | Right m -> Right (p1:m) 56 | where 57 | dir' = p2 .-. p1 58 | go _ p1 p = Right (p1:p) 59 | 60 | chain _ l = l 61 | -------------------------------------------------------------------------------- /src/Diagrams/Trace.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE MonoLocalBinds #-} 4 | 5 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 6 | -- for Data.Semigroup 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Diagrams.Trace 11 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- \"Traces\", aka embedded raytracers, for finding points on the edge 16 | -- of a diagram. See "Diagrams.Core.Trace" for internal 17 | -- implementation details. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Diagrams.Trace 22 | ( -- * Types 23 | Trace, Traced 24 | 25 | -- * Diagram traces 26 | , trace, setTrace, withTrace 27 | 28 | -- * Querying traces 29 | , traceV, traceP, maxTraceV, maxTraceP 30 | 31 | -- * Subdiagram traces 32 | , boundaryFrom, boundaryFromMay 33 | 34 | ) where 35 | 36 | import Diagrams.Core (OrderedField, Point, Subdiagram, location, 37 | origin, setTrace, trace) 38 | import Diagrams.Core.Trace 39 | 40 | import Data.Maybe 41 | import Data.Semigroup 42 | import Diagrams.Combinators (withTrace) 43 | 44 | import Linear.Metric 45 | import Linear.Vector 46 | 47 | -- | Compute the furthest point on the boundary of a subdiagram, 48 | -- beginning from the location (local origin) of the subdiagram and 49 | -- moving in the direction of the given vector. If there is no such 50 | -- point, the origin is returned; see also 'boundaryFromMay'. 51 | boundaryFrom :: (OrderedField n, Metric v, Semigroup m) 52 | => Subdiagram b v n m -> v n -> Point v n 53 | boundaryFrom s v = fromMaybe origin $ boundaryFromMay s v 54 | 55 | -- | Compute the furthest point on the boundary of a subdiagram, 56 | -- beginning from the location (local origin) of the subdiagram and 57 | -- moving in the direction of the given vector, or @Nothing@ if 58 | -- there is no such point. 59 | boundaryFromMay :: (Metric v, OrderedField n, Semigroup m) 60 | => Subdiagram b v n m -> v n -> Maybe (Point v n) 61 | boundaryFromMay s v = traceP (location s) (negated v) s 62 | 63 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Ellipse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE TypeSynonymInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Diagrams.TwoD.Ellipse 9 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Two-dimensional ellipses (and, as a special case, circles). 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Diagrams.TwoD.Ellipse 18 | ( 19 | -- * Ellipse and circle diagrams 20 | unitCircle 21 | , circle 22 | , ellipse 23 | , ellipseXY 24 | ) where 25 | 26 | import Diagrams.Core 27 | 28 | import Diagrams.Angle 29 | import Diagrams.Located (at) 30 | import Diagrams.Trail (glueTrail) 31 | import Diagrams.TrailLike 32 | import Diagrams.TwoD.Arc 33 | import Diagrams.TwoD.Transform 34 | import Diagrams.TwoD.Types 35 | import Diagrams.TwoD.Vector (xDir) 36 | import Diagrams.Util 37 | 38 | -- | A circle of radius 1, with center at the origin. 39 | unitCircle :: (TrailLike t, V t ~ V2, N t ~ n) => t 40 | unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` p2 (1,0) 41 | 42 | -- | A circle of the given radius, centered at the origin. As a path, 43 | -- it begins at (r,0). 44 | circle :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t 45 | circle d = unitCircle # scale d 46 | 47 | -- | @ellipse e@ constructs an ellipse with eccentricity @e@ by 48 | -- scaling the unit circle in the X direction. The eccentricity must 49 | -- be within the interval [0,1). 50 | ellipse :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> t 51 | ellipse e 52 | | e >= 0 && e < 1 = scaleX (sqrt (1 - e*e)) unitCircle 53 | | otherwise = error "Eccentricity of ellipse must be >= 0 and < 1." 54 | 55 | -- | @ellipseXY x y@ creates an axis-aligned ellipse, centered at the 56 | -- origin, with radius @x@ along the x-axis and radius @y@ along the 57 | -- y-axis. 58 | ellipseXY :: (TrailLike t, V t ~ V2, N t ~ n, Transformable t) => n -> n -> t 59 | ellipseXY x y = unitCircle # scaleX x # scaleY y 60 | -------------------------------------------------------------------------------- /test/diamBench.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | module DiamBench where 3 | import Criterion.Main 4 | import Diagrams.Prelude 5 | import Diagrams.ThreeD.Shapes 6 | import Diagrams.ThreeD.Types 7 | 8 | -- Comparing the performance of two different diameter implementations 9 | 10 | -- Old definition: 11 | diameter1 :: Enveloped a => V a -> a -> Scalar (V a) 12 | diameter1 v a = magnitude (envelopeV v a ^-^ envelopeV (negateV v) a) 13 | 14 | -- New definition: 15 | diameter2 :: Enveloped a => V a -> a -> Scalar (V a) 16 | diameter2 v a = case appEnvelope $ getEnvelope a of 17 | (Just env) -> (env v + env (negateV v)) * magnitude v 18 | Nothing -> 0 19 | 20 | --test :: (VectorSpace v, Fractional (Scalar v), Enum (Scalar v)) => (v -> t) -> v -> [t] 21 | test f v = [ f (v ^* d) | d <- [0.0, 5.0 .. 100.0] ] 22 | 23 | main = defaultMain 24 | [ bench "diameter1" $ nf (\d -> test (`diameter1` d) $ 1 & 3) (unitSquare :: D R2) 25 | , bench "diameter2" $ nf (\d -> test (`diameter2` d) $ 1 & 3) (unitSquare :: D R2) 26 | , bench "diameter3" $ nf (\d -> test (`diameter1` d) $ (-1) & 1 & 3) (sphere :: D R3) 27 | , bench "diameter4" $ nf (\d -> test (`diameter2` d) $ (-1) & 1 & 3) (sphere :: D R3) 28 | ] 29 | 30 | 31 | {- mgsloan's results 32 | 33 | warming up 34 | estimating clock resolution... 35 | mean is 1.277677 us (640001 iterations) 36 | found 3123 outliers among 639999 samples (0.5%) 37 | 2933 (0.5%) high severe 38 | estimating cost of a clock call... 39 | mean is 28.94072 ns (7 iterations) 40 | found 1 outliers among 7 samples (14.3%) 41 | 1 (14.3%) high severe 42 | 43 | benchmarking diameter1 44 | mean: 41.10492 us, lb 41.02676 us, ub 41.20513 us, ci 0.950 45 | std dev: 453.7027 ns, lb 370.9014 ns, ub 583.8290 ns, ci 0.950 46 | 47 | benchmarking diameter2 48 | mean: 40.12666 us, lb 40.04038 us, ub 40.23655 us, ci 0.950 49 | std dev: 498.8693 ns, lb 415.3504 ns, ub 637.7434 ns, ci 0.950 50 | 51 | benchmarking diameter3 52 | mean: 1.762319 us, lb 1.759122 us, ub 1.765858 us, ci 0.950 53 | std dev: 17.29888 ns, lb 15.30558 ns, ub 20.23129 ns, ci 0.950 54 | 55 | benchmarking diameter4 56 | mean: 1.692065 us, lb 1.687748 us, ub 1.698442 us, ci 0.950 57 | std dev: 26.41623 ns, lb 20.34119 ns, ub 40.98644 ns, ci 0.950 58 | found 4 outliers among 100 samples (4.0%) 59 | 3 (3.0%) high mild 60 | 1 (1.0%) high severe 61 | variance introduced by outliers: 8.481% 62 | variance is slightly inflated by outliers 63 | -} 64 | -------------------------------------------------------------------------------- /test/splitTests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | import Control.Applicative 6 | import Data.Default 7 | import Data.Ratio 8 | import Data.VectorSpace 9 | import Test.QuickCheck 10 | 11 | import Diagrams.Prelude 12 | 13 | 14 | type Q2 = (Rational, Rational) 15 | 16 | 17 | instance AdditiveGroup (Rational) where { zeroV=0; (^+^) = (+); negateV = negate } 18 | 19 | instance VectorSpace (Rational) where 20 | type Scalar (Rational) = Rational 21 | (*^) = (*) 22 | 23 | instance (VectorSpace v, Arbitrary v) => Arbitrary (Segment v) where 24 | arbitrary = oneof [Linear <$> arbitrary, Cubic <$> arbitrary <*> arbitrary <*> arbitrary] 25 | 26 | 27 | 28 | prop_paramSplit :: Segment Q2 -> Scalar Q2 -> Scalar Q2 -> Bool 29 | prop_paramSplit s t u 30 | | u < t = atParam s u == atParam l (u / t) 31 | | otherwise = atParam s u == atParam s t ^+^ atParam r ((u - t) / (1.0 - t)) 32 | where (l,r) = splitAtParam s t 33 | 34 | prop_adjustSegParams :: Segment Q2 -> Scalar Q2 -> Scalar Q2 -> Scalar Q2 -> Property 35 | prop_adjustSegParams s p1 p2 t = p1 /= p2 ==> 36 | atParam s t == atParam s p1 ^+^ atParam s' ((t - p1) / (p2 - p1)) 37 | where s' = adjustSegmentToParams s p1 p2 38 | 39 | instance Arbitrary AdjustSide where 40 | arbitrary = elements [Start, End, Both] 41 | 42 | -- The following tests don't work very well since they fail on cases 43 | -- where the answer is not quite within the stated tolerance. But 44 | -- they have still been useful in finding cases where the adjustment 45 | -- methods fail for other reasons. Basically, (1) run QC (2) get 46 | -- counterexample (3) check counterexample by hand to see whether it 47 | -- is close. 48 | -- 49 | -- Unfortunately we can't use Q2 since arc-length-related functions 50 | -- ultimately work by finding the magnitude vectors, which uses sqrt. 51 | 52 | prop_adjustSeg_toAbs_len :: Segment R2 -> Scalar R2 -> AdjustSide -> Property 53 | prop_adjustSeg_toAbs_len s len side = abs len > eps ==> 54 | arcLength (adjustSegment s with { adjMethod = ToAbsolute len, adjSide = side }) eps ==~ abs len 55 | 56 | eps = 1/10^10 57 | x ==~ y = abs (x - y) < eps 58 | 59 | prop_adjustSeg_byAbs_len :: Segment R2 -> Scalar R2 -> AdjustSide -> Bool 60 | prop_adjustSeg_byAbs_len s len side = 61 | arcLength (adjustSegment s with { adjMethod = ByAbsolute len, adjSide = side }) eps ==~ abs (arcLength s eps + len) 62 | -------------------------------------------------------------------------------- /src/Diagrams/CubicSpline/Internal.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Diagrams.CubicSpline 4 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- A /cubic spline/ is a smooth, connected sequence of cubic curves 9 | -- passing through a given sequence of points. This module implements 10 | -- a straightforward spline generation algorithm based on solving 11 | -- tridiagonal systems of linear equations. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | module Diagrams.CubicSpline.Internal 15 | ( 16 | -- * Solving for spline coefficents 17 | solveCubicSplineDerivatives 18 | , solveCubicSplineDerivativesClosed 19 | , solveCubicSplineCoefficients 20 | ) where 21 | 22 | import Diagrams.Solve.Tridiagonal 23 | 24 | import Data.List 25 | 26 | -- | Use the tri-diagonal solver with the appropriate parameters for an open cubic spline. 27 | solveCubicSplineDerivatives :: Fractional a => [a] -> [a] 28 | solveCubicSplineDerivatives (x:xs) = solveTriDiagonal as bs as ds 29 | where 30 | as = replicate (l - 1) 1 31 | bs = 2 : replicate (l - 2) 4 ++ [2] 32 | l = length ds 33 | ds = zipWith f (xs ++ [last xs]) (x:x:xs) 34 | f a b = 3*(a - b) 35 | 36 | solveCubicSplineDerivatives _ = error "argument to solveCubicSplineDerivatives must be nonempty" 37 | 38 | -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. 39 | solveCubicSplineDerivativesClosed :: Fractional a => [a] -> [a] 40 | solveCubicSplineDerivativesClosed xs = solveCyclicTriDiagonal as bs as ds 1 1 41 | where 42 | as = replicate (l - 1) 1 43 | bs = replicate l 4 44 | l = length xs 45 | xs' = cycle xs 46 | ds = take l $ zipWith f (drop 1 xs') (drop (l - 1) xs') 47 | f a b = 3*(a - b) 48 | 49 | -- | Use the cyclic-tri-diagonal solver with the appropriate parameters for a closed cubic spline. 50 | solveCubicSplineCoefficients :: Fractional a => Bool -> [a] -> [[a]] 51 | solveCubicSplineCoefficients closed xs = 52 | [ [x,d,3*(x1-x)-2*d-d1,2*(x-x1)+d+d1] 53 | | (x,x1,d,d1) <- zip4 xs' (tail xs') ds' (tail ds') 54 | ] 55 | where 56 | ds | closed = solveCubicSplineDerivativesClosed xs 57 | | otherwise = solveCubicSplineDerivatives xs 58 | close as | closed = as ++ [head as] 59 | | otherwise = as 60 | xs' = close xs 61 | ds' = close ds 62 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_CubicSpline_Boehm_bsplineEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD/Light.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Diagrams.ThreeD.Render 11 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- Types to specify lighting for 3D rendering. 16 | -- 17 | ----------------------------------------------------------------------------- 18 | 19 | module Diagrams.ThreeD.Light where 20 | 21 | import Data.Colour 22 | import Data.Monoid 23 | import Data.Typeable 24 | 25 | import Diagrams.Core 26 | import Diagrams.Direction 27 | import Diagrams.ThreeD.Types 28 | 29 | -- | A @PointLight@ radiates uniformly in all directions from a given 30 | -- point. 31 | data PointLight n = PointLight (Point V3 n) (Colour Double) 32 | deriving Typeable 33 | 34 | type instance V (PointLight n) = V3 35 | type instance N (PointLight n) = n 36 | 37 | -- | A @ParallelLight@ casts parallel rays in the specified direction, 38 | -- from some distant location outside the scene. 39 | data ParallelLight n = ParallelLight (V3 n) (Colour Double) 40 | deriving Typeable 41 | 42 | type instance V (ParallelLight n) = V3 43 | type instance N (ParallelLight n) = n 44 | 45 | instance Fractional n => Transformable (PointLight n) where 46 | transform t (PointLight p c) = PointLight (transform t p) c 47 | 48 | instance Transformable (ParallelLight n) where 49 | transform t (ParallelLight v c) = ParallelLight (transform t v) c 50 | 51 | -- | Construct a Diagram with a single PointLight at the origin, which 52 | -- takes up no space. 53 | pointLight :: (Typeable n, Num n, Ord n, Renderable (PointLight n) b) 54 | => Colour Double -- ^ The color of the light 55 | -> QDiagram b V3 n Any 56 | pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty 57 | (Query . const . Any $ False) 58 | 59 | -- | Construct a Diagram with a single ParallelLight, which takes up no space. 60 | parallelLight :: (Typeable n, OrderedField n, Renderable (ParallelLight n) b) 61 | => Direction V3 n -- ^ The direction in which the light travels. 62 | -> Colour Double -- ^ The color of the light. 63 | -> QDiagram b V3 n Any 64 | parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) 65 | mempty mempty mempty (Query . const . Any $ False) 66 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Size.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.TwoD.Size 8 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Utilities for working with sizes of two-dimensional objects. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | module Diagrams.TwoD.Size 16 | ( 17 | -- ** Computing sizes 18 | width, height 19 | , extentX, extentY 20 | 21 | -- ** Specifying sizes 22 | , mkSizeSpec2D 23 | , mkWidth 24 | , mkHeight 25 | , dims2D 26 | 27 | ) where 28 | 29 | import Diagrams.Core 30 | import Diagrams.Core.Envelope 31 | import Diagrams.Size 32 | import Diagrams.TwoD.Types 33 | import Diagrams.TwoD.Vector 34 | 35 | ------------------------------------------------------------ 36 | -- Computing diagram sizes 37 | ------------------------------------------------------------ 38 | 39 | -- | Compute the width of an enveloped object. 40 | -- 41 | -- Note this is just @diameter unitX@. 42 | width :: (InSpace V2 n a, Enveloped a) => a -> n 43 | width = diameter unitX 44 | 45 | -- | Compute the height of an enveloped object. 46 | height :: (InSpace V2 n a, Enveloped a) => a -> n 47 | height = diameter unitY 48 | 49 | -- | Compute the absolute x-coordinate range of an enveloped object in 50 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 51 | -- envelope. 52 | -- 53 | -- Note this is just @extent unitX@. 54 | extentX :: (InSpace v n a, R1 v, Enveloped a) => a -> Maybe (n, n) 55 | extentX = extent unitX 56 | 57 | -- | Compute the absolute y-coordinate range of an enveloped object in 58 | -- the form @(lo,hi)@. Return @Nothing@ for objects with an empty 59 | -- envelope. 60 | extentY :: (InSpace v n a, R2 v, Enveloped a) => a -> Maybe (n, n) 61 | extentY = extent unitY 62 | 63 | -- | Make a 'SizeSpec' from possibly-specified width and height. 64 | mkSizeSpec2D :: Num n => Maybe n -> Maybe n -> SizeSpec V2 n 65 | mkSizeSpec2D x y = mkSizeSpec (V2 x y) 66 | 67 | -- | Make a 'SizeSpec' from a width and height. 68 | dims2D :: n -> n -> SizeSpec V2 n 69 | dims2D x y = dims (V2 x y) 70 | 71 | -- | Make a 'SizeSpec' with only width defined. 72 | mkWidth :: Num n => n -> SizeSpec V2 n 73 | mkWidth w = dims (V2 w 0) 74 | 75 | -- | Make a 'SizeSpec' with only height defined. 76 | mkHeight :: Num n => n -> SizeSpec V2 n 77 | mkHeight h = dims (V2 0 h) 78 | 79 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Diagrams.ThreeD 7 | -- Copyright : (c) 2013-2015 diagrams-lib team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- This module defines the three-dimensional vector space R^3, 12 | -- three-dimensional transformations, and various predefined 13 | -- three-dimensional shapes. This module re-exports useful 14 | -- functionality from a group of more specific modules: 15 | -- 16 | -- * "Diagrams.ThreeD.Types" defines basic types for two-dimensional 17 | -- diagrams, including types representing the 3D Euclidean vector 18 | -- space and various systems of representing directions. 19 | -- 20 | -- * "Diagrams.ThreeD.Transform" defines R^3-specific 21 | -- transformations such as rotation by an angle, and scaling, 22 | -- translation, and reflection in the X, Y, and Z directions. 23 | -- "Diagrams.ThreeD.Deform" defines several R^3-specific 24 | -- non-affine transformations, such as projections. 25 | -- 26 | -- * "Diagrams.ThreeD.Shapes" defines three-dimensional solids, 27 | -- e.g. spheres and cubes. 28 | -- 29 | -- * "Diagrams.ThreeD.Vector" defines some special 3D vectors and 30 | -- functions for converting between vectors and directions. 31 | -- 32 | -- * "Diagrams.ThreeD.Light" and "Diagrams.ThreeD.Camera" define types needed 33 | -- for rendering 3D geometry to (2D) images. 34 | -- 35 | -- * "Diagrams.ThreeD.Align" defines many alignment combinators 36 | -- specialized to three dimensions. 37 | -- 38 | -- * "Diagrams.ThreeD.Attributes" defines 3D-specific attributes 39 | -- such as surface color, diffuse reflectance, and specular 40 | -- highlights. 41 | ----------------------------------------------------------------------------- 42 | module Diagrams.ThreeD 43 | ( module Diagrams.ThreeD.Align 44 | , module Diagrams.ThreeD.Attributes 45 | , module Diagrams.ThreeD.Camera 46 | , module Diagrams.ThreeD.Deform 47 | , module Diagrams.ThreeD.Light 48 | , module Diagrams.ThreeD.Shapes 49 | , module Diagrams.ThreeD.Transform 50 | , module Diagrams.ThreeD.Types 51 | , module Diagrams.ThreeD.Vector 52 | ) where 53 | 54 | import Diagrams.ThreeD.Align 55 | import Diagrams.ThreeD.Attributes 56 | import Diagrams.ThreeD.Camera 57 | import Diagrams.ThreeD.Deform 58 | import Diagrams.ThreeD.Light 59 | import Diagrams.ThreeD.Shapes 60 | import Diagrams.ThreeD.Transform 61 | import Diagrams.ThreeD.Types 62 | import Diagrams.ThreeD.Vector 63 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.TwoD.Types 8 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Basic types for two-dimensional Euclidean space. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Diagrams.TwoD.Types 17 | ( -- * 2D Euclidean space 18 | V2 (..), R1 (..), R2 (..) 19 | , P2, T2 20 | , r2, unr2, mkR2, r2Iso 21 | , p2, mkP2, unp2, p2Iso 22 | , r2PolarIso 23 | , HasR (..) 24 | ) where 25 | 26 | import Control.Lens (Iso', Lens', iso, _1, _2) 27 | 28 | import Diagrams.Angle 29 | import Diagrams.Points 30 | 31 | import Diagrams.Core.Transform 32 | import Diagrams.Core.V 33 | import Linear.Metric 34 | import Linear.V2 35 | 36 | type P2 = Point V2 37 | type T2 = Transformation V2 38 | 39 | type instance V (V2 n) = V2 40 | type instance N (V2 n) = n 41 | 42 | -- | Construct a 2D vector from a pair of components. See also '&'. 43 | r2 :: (n, n) -> V2 n 44 | r2 = uncurry V2 45 | 46 | -- | Convert a 2D vector back into a pair of components. See also 'coords'. 47 | unr2 :: V2 n -> (n, n) 48 | unr2 (V2 x y) = (x, y) 49 | 50 | -- | Curried form of `r2`. 51 | mkR2 :: n -> n -> V2 n 52 | mkR2 = V2 53 | 54 | r2Iso :: Iso' (V2 n) (n, n) 55 | r2Iso = iso unr2 r2 56 | 57 | -- | Construct a 2D point from a pair of coordinates. See also '^&'. 58 | p2 :: (n, n) -> P2 n 59 | p2 = P . uncurry V2 60 | 61 | -- | Convert a 2D point back into a pair of coordinates. See also 'coords'. 62 | unp2 :: P2 n -> (n,n) 63 | unp2 (P (V2 x y)) = (x,y) 64 | 65 | -- | Curried form of `p2`. 66 | mkP2 :: n -> n -> P2 n 67 | mkP2 x y = P (V2 x y) 68 | 69 | p2Iso :: Iso' (Point V2 n) (n, n) 70 | p2Iso = iso unp2 p2 71 | 72 | instance Transformable (V2 n) where 73 | transform = apply 74 | 75 | r2PolarIso :: RealFloat n => Iso' (V2 n) (n, Angle n) 76 | r2PolarIso = iso (\v@(V2 x y) -> (norm v, atan2A y x)) 77 | (\(r,θ) -> V2 (r * cosA θ) (r * sinA θ)) 78 | {-# INLINE r2PolarIso #-} 79 | 80 | -- | A space which has magnitude '_r' that can be calculated numerically. 81 | class HasR t where 82 | _r :: RealFloat n => Lens' (t n) n 83 | 84 | instance HasR v => HasR (Point v) where 85 | _r = lensP . _r 86 | {-# INLINE _r #-} 87 | 88 | instance HasR V2 where 89 | _r = r2PolarIso . _1 90 | {-# INLINE _r #-} 91 | 92 | instance HasTheta V2 where 93 | _theta = r2PolarIso . _2 94 | {-# INLINE _theta #-} 95 | -------------------------------------------------------------------------------- /test/Arrowtest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | 3 | import Data.List.Split (chunksOf) 4 | import Diagrams.Backend.SVG.CmdLine 5 | import Diagrams.Prelude 6 | 7 | -- Create a 3 x 3 grid of circles named "1" to "9" 8 | c = circle 1.5 # fc lightgray # lw none # showOrigin 9 | cs = [c # named (show x) | x <- [1..9]] 10 | cGrid = (vcat' $ with & sep .~ 4) 11 | . map (hcat' $ with & sep .~ 12) 12 | . chunksOf 3 $ cs 13 | 14 | -- For the Shafts. 15 | semicircle = arc xDir (2/5 @@ turn) 16 | quartercircle = arc xDir (1/4 @@ turn) 17 | 18 | parab = bezier3 (1 ^& 1) (1 ^& 1) (0 ^& 2) 19 | parab' = reflectX parab 20 | 21 | seg = straight unitX 22 | seg' = seg # rotateBy (1/6) 23 | 24 | shaft0 = trailFromSegments [parab, seg, parab', seg, parab] 25 | shaft1 = cubicSpline False (trailVertices (shaft0 `at` origin)) 26 | shaft2 = cubicSpline False (map p2 [(0,0), (1,0), (0.8, 0.2),(2, 0.2)]) 27 | 28 | example :: Diagram B R2 29 | example = connect' arrow1 "1" "2" 30 | . connect' arrow2 "4" "3" 31 | . connect' arrow3 "1" "6" 32 | . connectOutside' arrow4 "4" "8" 33 | . connect' arrow5 "9" "5" 34 | . connectOutside' arrow6 "8" "9" 35 | . connectOutside' arrow7 "8" "7" 36 | $ cGrid 37 | 38 | where 39 | -- The arrows 40 | arrow1 = with & arrowHead .~ dart 41 | & arrowTail .~ quill & shaftStyle %~ lw thick . lc black 42 | & arrowShaft .~ shaft0 & headStyle %~ fc blue 43 | & tailStyle %~ fc red & tailLength .~ large 44 | 45 | arrow2 = with & arrowHead .~ dart & headLength .~ large 46 | & arrowTail .~ dart' & tailLength .~ large 47 | & shaftStyle %~ lw thin & arrowShaft .~ shaft1 48 | 49 | arrow3 = with & arrowHead .~ thorn & headLength .~ large 50 | & arrowShaft .~ quartercircle & arrowTail .~ noTail 51 | & gaps .~ normal 52 | 53 | arrow4 = with & arrowHead .~ dart & arrowTail .~ dart' 54 | & arrowShaft .~ shaft2 & headStyle %~ fc teal 55 | & tailStyle %~ fc teal & shaftStyle %~ lw thick . lc teal 56 | 57 | arrow5 = with & arrowTail .~ spike' & tailLength .~ large 58 | & arrowShaft .~ semicircle & arrowHead .~ spike 59 | & headLength .~ large & headStyle %~ fc darkorange 60 | & tailStyle %~ fc darkorange 61 | & shaftStyle %~ lw veryThick . lc navy 62 | 63 | arrow6 = with & arrowHead .~ tri & arrowTail .~ tri' 64 | & headLength .~ large 65 | & headStyle %~ fc black . opacity 0.5 66 | & tailStyle %~ fc black . opacity 0.5 67 | & shaftStyle %~ dashingN [0.01,0.02,0.03,0.01] 0 68 | 69 | arrow7 = arrow6 & arrowHead .~ tri & arrowTail .~ tri' 70 | 71 | main = mainWith $ example # frame 0.2 72 | -------------------------------------------------------------------------------- /test/Snugtest.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Diagrams.TwoD.Arrowtest 5 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 6 | -- License : BSD-style (see LICENSE) 7 | -- Maintainer : diagrams-discuss@googlegroups.com 8 | -- 9 | -- Test module for Diagrams.Snug and Diagrams.TwoD.Snug 10 | -- 11 | ----------------------------------------------------------------------------- 12 | 13 | module Main where 14 | 15 | import Diagrams.Backend.SVG 16 | import Diagrams.Backend.SVG.CmdLine 17 | import Diagrams.Prelude hiding (alignL, alignR, centerXY) 18 | 19 | import Diagrams.Align 20 | import Diagrams.TwoD.Align 21 | 22 | concave :: Diagram SVG R2 23 | concave = polygon (with & polyType .~ PolyPolar [a, b, b, b] 24 | [0.25,1,1,1,1] & polyOrient .~ NoOrient) 25 | # fc blue # lw 0 26 | where 27 | a = 1/8 :: Turn 28 | b = 1/4 :: Turn 29 | 30 | convex :: Diagram SVG R2 31 | convex = polygon (with & polyType .~ PolyPolar [a,b] [0.25, 1, 1] 32 | & polyOrient .~ NoOrient) 33 | # fc orange # lw 0 34 | where 35 | a = 1/8 :: Turn 36 | b = 3/4 :: Turn 37 | 38 | example1 = (concave # centerXY # alignR # showOrigin) 39 | <> (convex # centerXY # alignL # showOrigin) 40 | 41 | example2 = (concave # centerXY # snugR # showOrigin) 42 | <> (convex # centerXY # snugL # showOrigin) 43 | 44 | example3 = (concave # rotateBy (1/4 :: Turn) # centerXY 45 | # snugT # showOrigin) 46 | <> (convex # rotateBy (1/4 :: Turn) # centerXY 47 | #snugB # showOrigin) 48 | example4= (concave # rotateBy (2/4 :: Turn) # centerXY 49 | # snugL # showOrigin) 50 | <> (convex # rotateBy (2/4 :: Turn) # centerXY 51 | # snugR # showOrigin) 52 | example5= (concave # rotateBy (3/4 :: Turn) # centerXY 53 | # snugB # showOrigin) 54 | <> (convex # rotateBy (3/4 :: Turn) # centerXY 55 | # snugT # showOrigin) 56 | example6 = (mconcat $ [circle 0.25 # fc orange, concave] # alignR) # showOrigin 57 | example7 = (mconcat $ [circle 0.25 # fc orange, concave] # snugR) # showOrigin 58 | 59 | main = defaultMain $ ( example1 # centerXY 60 | === strutY 0.25 61 | === example2 # centerXY 62 | === strutY 0.25 63 | === example3 # centerXY 64 | === strutY 0.25 65 | === example4 # centerXY 66 | === strutY 0.25 67 | === example5 # centerXY 68 | === strutY 0.25 69 | === example6 # centerXY 70 | === strutY 0.25 71 | === example7 # centerXY 72 | ) # pad 1.1 73 | -------------------------------------------------------------------------------- /src/Diagrams/ThreeD/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Diagrams.ThreeD.Types 7 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : diagrams-discuss@googlegroups.com 10 | -- 11 | -- Basic types for three-dimensional Euclidean space. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Diagrams.ThreeD.Types 16 | ( -- * 3D Euclidean space 17 | r3, unr3, mkR3 18 | , p3, unp3, mkP3 19 | , r3Iso, p3Iso, project 20 | , r3SphericalIso, r3CylindricalIso 21 | , V3 (..), P3, T3 22 | , R1 (..), R2 (..), R3 (..) 23 | 24 | ) where 25 | 26 | import Control.Lens (Iso', iso, _1, _2, _3) 27 | 28 | import Diagrams.Angle 29 | import Diagrams.Core 30 | import Diagrams.Points 31 | import Diagrams.TwoD.Types 32 | 33 | import Linear.Metric 34 | import Linear.V3 as V 35 | 36 | ------------------------------------------------------------ 37 | -- 3D Euclidean space 38 | 39 | -- Basic R3 types 40 | 41 | type P3 = Point V3 42 | type T3 = Transformation V3 43 | 44 | r3Iso :: Iso' (V3 n) (n, n, n) 45 | r3Iso = iso unr3 r3 46 | 47 | -- | Construct a 3D vector from a triple of components. 48 | r3 :: (n, n, n) -> V3 n 49 | r3 (x,y,z) = V3 x y z 50 | 51 | -- | Curried version of `r3`. 52 | mkR3 :: n -> n -> n -> V3 n 53 | mkR3 = V3 54 | 55 | -- | Convert a 3D vector back into a triple of components. 56 | unr3 :: V3 n -> (n, n, n) 57 | unr3 (V3 x y z) = (x,y,z) 58 | 59 | -- | Construct a 3D point from a triple of coordinates. 60 | p3 :: (n, n, n) -> P3 n 61 | p3 = P . r3 62 | 63 | -- | Convert a 3D point back into a triple of coordinates. 64 | unp3 :: P3 n -> (n, n, n) 65 | unp3 (P (V3 x y z)) = (x,y,z) 66 | 67 | p3Iso :: Iso' (P3 n) (n, n, n) 68 | p3Iso = iso unp3 p3 69 | 70 | -- | Curried version of `r3`. 71 | mkP3 :: n -> n -> n -> P3 n 72 | mkP3 x y z = p3 (x, y, z) 73 | 74 | type instance V (V3 n) = V3 75 | type instance N (V3 n) = n 76 | 77 | instance Transformable (V3 n) where 78 | transform = apply 79 | 80 | r3SphericalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, Angle n) 81 | r3SphericalIso = iso 82 | (\v@(V3 x y z) -> (norm v, atan2A y x, acosA (z / norm v))) 83 | (\(r,θ,φ) -> V3 (r * cosA θ * sinA φ) (r * sinA θ * sinA φ) (r * cosA φ)) 84 | 85 | r3CylindricalIso :: RealFloat n => Iso' (V3 n) (n, Angle n, n) 86 | r3CylindricalIso = iso 87 | (\(V3 x y z) -> (sqrt $ x*x + y*y, atan2A y x, z)) 88 | (\(r,θ,z) -> V3 (r*cosA θ) (r*sinA θ) z) 89 | 90 | instance HasR V3 where 91 | _r = r3SphericalIso . _1 92 | 93 | instance HasTheta V3 where 94 | _theta = r3CylindricalIso . _2 95 | 96 | instance HasPhi V3 where 97 | _phi = r3SphericalIso . _3 98 | 99 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Offset_offsetTrailExample.svg: -------------------------------------------------------------------------------- 1 | LineJoinBevelLineJoinRoundLineJoinMiter -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011-2016 diagrams-lib team: 2 | 3 | Florent Becker 4 | Jan Bracker 5 | Daniel Bergey 6 | Vincent Berthoux 7 | Christopher Chalmers 8 | Michael Chavinda 9 | Denys Duchier 10 | Daniil Frumin 11 | Ben Gamari 12 | Allan Gardner 13 | Pontus Granström 14 | Gabor Greif 15 | Niklas Haas 16 | Peter Hall 17 | Dashiell Halpern 18 | Claude Heiland-Allen 19 | Deepak Jois 20 | Sidharth Kapur 21 | Taru Karttunen 22 | John Lato 23 | Konrad Madej 24 | Chris Mears 25 | Alexis Praga 26 | Jeffrey Rosenbluth 27 | Ian Ross 28 | Carlos Scheidegger 29 | Michael Sloan 30 | Jim Snavely 31 | Kanchalai Suveepattananont 32 | Robert Vollmert 33 | Scott Walck 34 | Ryan Yates 35 | Brent Yorgey 36 | 37 | All rights reserved. 38 | 39 | Redistribution and use in source and binary forms, with or without 40 | modification, are permitted provided that the following conditions are met: 41 | 42 | * Redistributions of source code must retain the above copyright 43 | notice, this list of conditions and the following disclaimer. 44 | 45 | * Redistributions in binary form must reproduce the above 46 | copyright notice, this list of conditions and the following 47 | disclaimer in the documentation and/or other materials provided 48 | with the distribution. 49 | 50 | * Neither the name of Brent Yorgey nor the names of other 51 | contributors may be used to endorse or promote products derived 52 | from this software without specific prior written permission. 53 | 54 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 55 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 56 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 57 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 58 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 59 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 60 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 61 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 62 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 63 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 64 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 65 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrow_example1.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_Combinators_appendsEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/Transform/Matrix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE MonoLocalBinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.Transform.Matrix 8 | -- Copyright : (c) 2014 diagrams team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Functions for converting between 'Transformation's and matricies. 13 | -- 14 | ----------------------------------------------------------------------------- 15 | 16 | module Diagrams.Transform.Matrix where 17 | 18 | import Control.Arrow ((&&&)) 19 | import Control.Lens 20 | import Data.Distributive 21 | import qualified Data.Foldable as F 22 | import Data.Functor.Rep 23 | 24 | import Diagrams.Core.Transform as D 25 | import Diagrams.ThreeD.Types 26 | import Diagrams.TwoD.Types 27 | 28 | import Linear.Matrix 29 | import Linear.Vector 30 | 31 | -- | Build a matrix from a 'Transformation', ignoring the translation. 32 | mkMat :: (HasBasis v, Num n) => Transformation v n -> v (v n) 33 | mkMat t = distribute . tabulate $ apply t . unit . (\x -> el x) 34 | 35 | -- | Build a 3D transformation matrix in homogeneous coordinates from 36 | -- a 'Transformation V3'. 37 | mkMatHomo :: Num n => Transformation V3 n -> M44 n 38 | mkMatHomo t = mkTransformationMat (mkMat t) (transl t) 39 | 40 | -- | Make a 2D transformation from a 2x2 transform matrix and a 41 | -- translation vector. Does not check if the matrix is not invertible 42 | -- (in which case the 'T2' will be invalid). 43 | fromMat22 :: Floating n => M22 n -> V2 n -> T2 n 44 | fromMat22 m v = fromMatWithInv m (inv22 m) v 45 | 46 | -- | Make a 3D transformation from a 3x3 transform matrix and a 47 | -- translation vector. Does not check if the matrix is not invertible 48 | -- (in which case the 'T3' will be invalid). 49 | fromMat33 :: Floating n => M33 n -> V3 n -> T3 n 50 | fromMat33 m v = fromMatWithInv m (inv33 m) v 51 | 52 | -- | Build a transform with a maxtrix along with its inverse. 53 | fromMatWithInv :: (Additive v, Distributive v, F.Foldable v, Num n) 54 | => v (v n) -- ^ matrix 55 | -> v (v n) -- ^ inverse 56 | -> v n -- ^ translation 57 | -> Transformation v n 58 | fromMatWithInv m m_ v = 59 | Transformation ((m !*) <-> (m_ !*)) 60 | ((distribute m !*) <-> (distribute m_ !*)) 61 | v 62 | 63 | -- | Prism onto a 2D transformation from a 2x2 transform matrix and 64 | -- translation vector. Does not check if the matrix is invertible (in 65 | -- which case the 'T2' will be invalid). 66 | mat22 :: Floating n => Iso' (M22 n, V2 n) (T2 n) 67 | mat22 = iso (uncurry fromMat22) (mkMat &&& transl) 68 | 69 | -- | Prism onto a 3D transformation from a 3x3 transform matrix and 70 | -- translation vector. Does not check if the matrix is invertible 71 | -- (in which case the 'T3' will be invalid). 72 | mat33 :: Floating n => Iso' (M33 n, V3 n) (T3 n) 73 | mat33 = iso (uncurry fromMat33) (mkMat &&& transl) 74 | -------------------------------------------------------------------------------- /src/Diagrams/Direction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Diagrams.Direction 9 | -- Copyright : (c) 2014 diagrams-lib team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Type for representing directions, polymorphic in vector space 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Diagrams.Direction 18 | ( Direction 19 | , _Dir 20 | , direction, dir, fromDirection, fromDir 21 | , angleBetweenDirs 22 | , dirBetween 23 | ) where 24 | 25 | import Control.Lens (Iso', iso) 26 | 27 | import Diagrams.Angle 28 | import Diagrams.Core 29 | 30 | import Linear.Affine 31 | import Linear.Metric 32 | import Linear.Vector 33 | 34 | -------------------------------------------------------------------------------- 35 | -- Direction 36 | 37 | -- | A vector is described by a @Direction@ and a magnitude. So we 38 | -- can think of a @Direction@ as a vector that has forgotten its 39 | -- magnitude. @Direction@s can be used with 'fromDirection' and the 40 | -- lenses provided by its instances. 41 | newtype Direction v n = Dir (v n) 42 | deriving (Read, Show, Eq, Ord, Functor) -- todo: special instances 43 | 44 | type instance V (Direction v n) = v 45 | type instance N (Direction v n) = n 46 | 47 | instance (V (v n) ~ v, N (v n) ~ n, Transformable (v n)) => Transformable (Direction v n) where 48 | transform t (Dir v) = Dir (transform t v) 49 | 50 | instance HasTheta v => HasTheta (Direction v) where 51 | _theta = _Dir . _theta 52 | 53 | instance HasPhi v => HasPhi (Direction v) where 54 | _phi = _Dir . _phi 55 | 56 | -- | _Dir is provided to allow efficient implementations of functions 57 | -- in particular vector-spaces, but should be used with care as it 58 | -- exposes too much information. 59 | _Dir :: Iso' (Direction v n) (v n) 60 | _Dir = iso (\(Dir v) -> v) Dir 61 | 62 | -- | @direction v@ is the direction in which @v@ points. Returns an 63 | -- unspecified value when given the zero vector as input. 64 | direction :: v n -> Direction v n 65 | direction = Dir 66 | 67 | -- | Synonym for 'direction'. 68 | dir :: v n -> Direction v n 69 | dir = Dir 70 | 71 | -- | @fromDirection d@ is the unit vector in the direction @d@. 72 | fromDirection :: (Metric v, Floating n) => Direction v n -> v n 73 | fromDirection (Dir v) = signorm v 74 | 75 | -- | Synonym for 'fromDirection'. 76 | fromDir :: (Metric v, Floating n) => Direction v n -> v n 77 | fromDir (Dir v) = signorm v 78 | 79 | -- | compute the positive angle between the two directions in their common plane 80 | angleBetweenDirs :: (Metric v, Floating n, Ord n) 81 | => Direction v n -> Direction v n -> Angle n 82 | angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) 83 | 84 | -- | @dirBetween p q@ returns the direction from @p@ to @q@. 85 | dirBetween :: (Additive v, Num n) => Point v n -> Point v n -> Direction v n 86 | dirBetween p q = dir $ q .-. p 87 | -------------------------------------------------------------------------------- /src/Diagrams/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.Query 8 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- A query is a function that maps points in a vector space to values 13 | -- in some monoid. Queries naturally form a monoid, with two queries 14 | -- being combined pointwise. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | 18 | module Diagrams.Query 19 | ( -- * Queries 20 | Query(..) 21 | , HasQuery (..) 22 | , sample 23 | , inquire 24 | 25 | -- ** Queries on diagrams 26 | , query 27 | , value 28 | , resetValue 29 | , clearValue 30 | ) where 31 | 32 | import Data.Monoid 33 | 34 | import Diagrams.Core 35 | 36 | -- | Types which can answer a 'Query' about points inside the geometric 37 | -- object. 38 | -- 39 | -- If @t@ and @m@ are both a 'Semigroup's, 'getQuery' should satisfy 40 | -- 41 | -- @ 42 | -- 'getQuery' (t1 <> t2) = 'getQuery' t1 <> 'getQuery' t2 43 | -- @ 44 | class HasQuery t m | t -> m where 45 | -- | Extract the query of an object. 46 | getQuery :: t -> Query (V t) (N t) m 47 | 48 | instance HasQuery (Query v n m) m where 49 | getQuery = id 50 | 51 | instance Monoid m => HasQuery (QDiagram b v n m) m where 52 | getQuery = query 53 | 54 | -- | Test if a point is not equal to 'mempty'. 55 | -- 56 | -- @ 57 | -- 'inquire' :: 'QDiagram' b v n 'Any' -> 'Point' v n -> 'Bool' 58 | -- 'inquire' :: 'Query' v n 'Any' -> 'Point' v n -> 'Bool' 59 | -- 'inquire' :: 'Diagrams.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Bool' 60 | -- @ 61 | inquire :: HasQuery t Any => t -> Point (V t) (N t) -> Bool 62 | inquire t = getAny . sample t 63 | 64 | -- | Sample a diagram's query function at a given point. 65 | -- 66 | -- @ 67 | -- 'sample' :: 'QDiagram' b v n m -> 'Point' v n -> m 68 | -- 'sample' :: 'Query' v n m -> 'Point' v n -> m 69 | -- 'sample' :: 'Diagrams.BoundingBox.BoundingBox' v n -> 'Point' v n -> 'Any' 70 | -- 'sample' :: 'Diagrams.Path.Path' 'V2' 'Double' -> 'Point' v n -> 'Diagrams.TwoD.Path.Crossings' 71 | -- @ 72 | sample :: HasQuery t m => t -> Point (V t) (N t) -> m 73 | sample = runQuery . getQuery 74 | 75 | -- | Set the query value for 'True' points in a diagram (/i.e./ points 76 | -- \"inquire\" the diagram); 'False' points will be set to 'mempty'. 77 | value :: Monoid m => m -> QDiagram b v n Any -> QDiagram b v n m 78 | value m = fmap fromAny 79 | where fromAny (Any True) = m 80 | fromAny (Any False) = mempty 81 | 82 | -- | Reset the query values of a diagram to @True@/@False@: any values 83 | -- equal to 'mempty' are set to 'False'; any other values are set to 84 | -- 'True'. 85 | resetValue :: (Eq m, Monoid m) => QDiagram b v n m -> QDiagram b v n Any 86 | resetValue = fmap toAny 87 | where toAny m | m == mempty = Any False 88 | | otherwise = Any True 89 | 90 | -- | Set all the query values of a diagram to 'False'. 91 | clearValue :: QDiagram b v n m -> QDiagram b v n Any 92 | clearValue = fmap (const (Any False)) 93 | 94 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Vector.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Diagrams.TwoD.Vector 4 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 5 | -- License : BSD-style (see LICENSE) 6 | -- Maintainer : diagrams-discuss@googlegroups.com 7 | -- 8 | -- Two-dimensional vectors. 9 | -- 10 | ----------------------------------------------------------------------------- 11 | module Diagrams.TwoD.Vector 12 | ( -- * Special 2D vectors 13 | unitX, unitY, unit_X, unit_Y 14 | , xDir, yDir 15 | 16 | -- * Converting between vectors and angles 17 | , angleV, angleDir, e, signedAngleBetween, signedAngleBetweenDirs 18 | 19 | -- * 2D vector utilities 20 | , perp, leftTurn, cross2 21 | 22 | ) where 23 | 24 | import Control.Lens (view, (&), (.~), (^.)) 25 | 26 | import Diagrams.Angle 27 | import Diagrams.Direction 28 | import Diagrams.TwoD.Types 29 | 30 | import Linear.Metric 31 | import Linear.V2 32 | import Linear.Vector 33 | 34 | -- | The unit vector in the positive X direction. 35 | unitX :: (R1 v, Additive v, Num n) => v n 36 | unitX = zero & _x .~ 1 37 | 38 | -- | The unit vector in the negative X direction. 39 | unit_X :: (R1 v, Additive v, Num n) => v n 40 | unit_X = zero & _x .~ (-1) 41 | 42 | -- | The unit vector in the positive Y direction. 43 | unitY :: (R2 v, Additive v, Num n) => v n 44 | unitY = zero & _y .~ 1 45 | 46 | -- | The unit vector in the negative Y direction. 47 | unit_Y :: (R2 v, Additive v, Num n) => v n 48 | unit_Y = zero & _y .~ (-1) 49 | 50 | -- | A 'Direction' pointing in the X direction. 51 | xDir :: (R1 v, Additive v, Num n) => Direction v n 52 | xDir = dir unitX 53 | 54 | -- | A 'Direction' pointing in the Y direction. 55 | yDir :: (R2 v, Additive v, Num n) => Direction v n 56 | yDir = dir unitY 57 | 58 | -- | A direction at a specified angle counter-clockwise from the 'xDir'. 59 | angleDir :: Floating n => Angle n -> Direction V2 n 60 | angleDir = dir . angleV 61 | 62 | -- | A unit vector at a specified angle counter-clockwise from the 63 | -- positive x-axis 64 | angleV :: Floating n => Angle n -> V2 n 65 | angleV = angle . view rad 66 | 67 | -- | A unit vector at a specified angle counter-clockwise from the 68 | -- positive X axis. 69 | e :: Floating n => Angle n -> V2 n 70 | e = angleV 71 | 72 | -- | @leftTurn v1 v2@ tests whether the direction of @v2@ is a left 73 | -- turn from @v1@ (that is, if the direction of @v2@ can be obtained 74 | -- from that of @v1@ by adding an angle 0 <= theta <= tau/2). 75 | leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool 76 | leftTurn v1 v2 = (v1 `dot` perp v2) < 0 77 | 78 | -- | Cross product on vectors in R2. 79 | cross2 :: Num n => V2 n -> V2 n -> n 80 | cross2 (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2 81 | 82 | -- | Signed angle between two vectors. Currently defined as 83 | -- 84 | -- @ 85 | -- signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) 86 | -- @ 87 | signedAngleBetween :: RealFloat n => V2 n -> V2 n -> Angle n 88 | signedAngleBetween u v = (u ^. _theta) ^-^ (v ^. _theta) 89 | 90 | -- | Same as 'signedAngleBetween' but for 'Directions's. 91 | signedAngleBetweenDirs :: RealFloat n => Direction V2 n -> Direction V2 n -> Angle n 92 | signedAngleBetweenDirs u v = (u ^. _theta) ^-^ (v ^. _theta) 93 | -------------------------------------------------------------------------------- /test/Diagrams/Test/TwoD.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | 3 | module Diagrams.Test.TwoD where 4 | 5 | import Diagrams.Prelude 6 | import qualified Diagrams.Query as Query (sample) 7 | import Diagrams.Trail (linePoints) 8 | import Instances 9 | import Test.Tasty 10 | import Test.Tasty.QuickCheck as QC 11 | 12 | newtype SmallAngle = SmallAngle (Angle Double) 13 | deriving (Eq, Ord, Show) 14 | 15 | -- Generate random angles within a reasonably small range (+/- 5 16 | -- turns). 17 | instance Arbitrary SmallAngle where 18 | arbitrary = SmallAngle . (@@turn) <$> choose (-5, 5) 19 | 20 | tests :: TestTree 21 | tests = testGroup "TwoD" 22 | [ testGroup "TwoD.Arc" [ 23 | testProperty "arc start point is at radius 1 in the starting direction" $ \d (SmallAngle a) -> 24 | pathVertices (arc d a :: Path V2 Double) ^? _head . _head =~ Just (origin .+^ fromDirection d ) 25 | , testProperty "arc end point is at radius 1 in the ending direction" $ \d (SmallAngle a) -> 26 | pathVertices (arc d a :: Path V2 Double) ^? _head . _last =~ Just (origin .+^ fromDirection (rotate a d)) 27 | ] 28 | , testGroup "TwoD.Types" [ 29 | testProperty "R2 vector addition is commutative" $ 30 | \u v -> (u :: V2 Double) ^+^ v =~ v ^+^ u 31 | , testProperty "R2 subtraction is the inverse of addition" $ 32 | \u v -> u ^+^ v ^-^ v =~ (u :: V2 Double) 33 | , testProperty "R2 vector negation squared is identity" $ 34 | \u -> negated (negated (u :: V2 Double)) =~ u 35 | ] 36 | , testGroup "cubicSpline" [ 37 | testProperty "Open cubic spline interpolates all points" $ 38 | \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline False pts :: [P2 Double])) 39 | , testProperty "Closed cubic spline interpolates all points" $ 40 | \pts -> length pts > 1 ==> and (zipWith (=~) pts (cubicSpline True pts :: [P2 Double])) 41 | ] 42 | , testGroup "Trail" [ 43 | testProperty "glueLine . cutLoop === id" $ 44 | \l -> glueLine (cutLoop l :: Trail' Line V2 Double) =~ l 45 | , testProperty "cutLoop ends at starting point" $ 46 | \l -> let ps = linePoints (cutLoop (l :: Trail' Loop V2 Double) `at` origin) in (ps ^? _head) =~ (ps ^? _last) 47 | , testProperty "cutTrail makes a Line" $ 48 | \t -> isLine (cutTrail (t :: Trail V2 Double)) 49 | , testProperty "fromSegments . lineSegments === id" $ 50 | \l -> fromSegments (lineSegments l) =~ (l :: Trail' Line V2 Double) 51 | , testProperty "lineSegments . fromSegments === id" $ 52 | \segs -> lineSegments (fromSegments segs) =~ (segs :: [Segment Closed V2 Double]) 53 | ] 54 | , testGroup "Queries and Backgrounds" 55 | (let dia :: QDiagram NullBackend V2 Double [Int] 56 | dia = circle 5 # scaleX 2 # rotateBy (1/14) # value [1] 57 | <> 58 | circle 2 # scaleX 5 # rotateBy (-4/14) # value [2] 59 | in [ 60 | testProperty "sample dia pt === sample (dia # bg color) pt" $ 61 | \pt -> Query.sample dia pt QC.=== Query.sample (dia # bg orange) pt 62 | , testProperty "sample dia pt === sample (dia # bgFrame 0.1 color) pt" $ 63 | \pt -> Query.sample dia pt QC.=== Query.sample (dia # bgFrame 0.1 green) pt 64 | ]) 65 | ] 66 | -------------------------------------------------------------------------------- /src/Diagrams/CubicSpline.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} 7 | 8 | ----------------------------------------------------------------------------- 9 | -- | 10 | -- Module : Diagrams.CubicSpline 11 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 12 | -- License : BSD-style (see LICENSE) 13 | -- Maintainer : diagrams-discuss@googlegroups.com 14 | -- 15 | -- A /cubic spline/ is a smooth, connected sequence of cubic curves. 16 | -- This module provides two methods for constructing splines. 17 | -- 18 | -- The 'cubicSpline' method can be used to create closed or open cubic 19 | -- splines from a list of points. The resulting splines /pass through/ 20 | -- all the control points, but depend on the control points in a 21 | -- "global" way (that is, changing one control point may alter the 22 | -- entire curve). For access to the internals of the spline 23 | -- generation algorithm, see "Diagrams.CubicSpline.Internal". 24 | -- 25 | -- 'bspline' creates a cubic B-spline, which starts and ends at the 26 | -- first and last control points, but does not necessarily pass 27 | -- through any of the other control points. It depends on the control 28 | -- points in a "local" way, that is, changing one control point will 29 | -- only affect a local portion of the curve near that control point. 30 | -- 31 | ----------------------------------------------------------------------------- 32 | module Diagrams.CubicSpline 33 | ( 34 | -- * Constructing paths from cubic splines 35 | cubicSpline 36 | , BSpline 37 | , bspline 38 | ) where 39 | 40 | import Control.Lens (view) 41 | 42 | import Diagrams.Core 43 | import Diagrams.CubicSpline.Boehm 44 | import Diagrams.CubicSpline.Internal 45 | import Diagrams.Located (Located, at, mapLoc) 46 | import Diagrams.Segment 47 | import Diagrams.Trail 48 | import Diagrams.TrailLike (TrailLike (..)) 49 | 50 | import Linear.Affine 51 | import Linear.Metric 52 | 53 | -- | Construct a spline path-like thing of cubic segments from a list of 54 | -- vertices, with the first vertex as the starting point. The first 55 | -- argument specifies whether the path should be closed. 56 | -- 57 | -- <> 58 | -- 59 | -- > pts = map p2 [(0,0), (2,3), (5,-2), (-4,1), (0,3)] 60 | -- > spot = circle 0.2 # fc blue # lw none 61 | -- > mkPath closed = position (zip pts (repeat spot)) 62 | -- > <> cubicSpline closed pts 63 | -- > cubicSplineEx = (mkPath False ||| strutX 2 ||| mkPath True) 64 | -- > # centerXY # pad 1.1 65 | -- 66 | -- For more information, see . 67 | cubicSpline :: (V t ~ v, N t ~ n, TrailLike t, Fractional (v n)) => Bool -> [Point v n] -> t 68 | cubicSpline closed [] = trailLike . closeIf closed $ emptyLine `at` origin 69 | cubicSpline closed [p] = trailLike . closeIf closed $ emptyLine `at` p 70 | cubicSpline closed ps = flattenBeziers . map f . solveCubicSplineCoefficients closed . map (view lensP) $ ps 71 | where 72 | f [a,b,c,d] = [a, (3*a+b)/3, (3*a+2*b+c)/3, a+b+c+d] 73 | flattenBeziers bs@((b:_):_) 74 | = trailLike . closeIf closed $ lineFromSegments (map bez bs) `at` P b 75 | bez [a,b,c,d] = bezier3 (b - a) (c - a) (d - a) 76 | 77 | closeIf :: (Metric v, OrderedField n) 78 | => Bool -> Located (Trail' Line v n) -> Located (Trail v n) 79 | closeIf c = mapLoc (if c then wrapLoop . glueLine else wrapLine) 80 | -------------------------------------------------------------------------------- /src/Diagrams/TwoD/Adjust.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE Rank2Types #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 7 | -- for Data.Semigroup 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Diagrams.TwoD.Adjust 12 | -- Copyright : (c) 2011 diagrams-lib team (see LICENSE) 13 | -- License : BSD-style (see LICENSE) 14 | -- Maintainer : diagrams-discuss@googlegroups.com 15 | -- 16 | -- A default diagram-adjustment implementation for two-dimensional 17 | -- diagrams, useful for backend implementors. 18 | -- 19 | ----------------------------------------------------------------------------- 20 | 21 | module Diagrams.TwoD.Adjust 22 | ( setDefault2DAttributes 23 | , adjustSize2D 24 | , adjustDia2D 25 | ) where 26 | 27 | import Diagrams.Attributes 28 | import Diagrams.BoundingBox 29 | import Diagrams.Core 30 | import Diagrams.Size 31 | import Diagrams.TwoD.Attributes (lineTextureA) 32 | import Diagrams.TwoD.Types 33 | import Diagrams.Util (( # )) 34 | 35 | import Control.Lens (Lens', set, (^.)) 36 | import Data.Default 37 | import Data.Semigroup 38 | 39 | 40 | -- | Set default attributes of a 2D diagram (in case they have not 41 | -- been set): 42 | -- 43 | -- * 'LineWidth': 0.01 44 | -- 45 | -- * 'LineTexture': solid black 46 | -- 47 | -- * 'LineCap': LineCapButt 48 | -- 49 | -- * 'LineJoin': miter 50 | -- 51 | -- * 'MiterLimit': 10 52 | setDefault2DAttributes :: (TypeableFloat n, Semigroup m) 53 | => QDiagram b V2 n m -> QDiagram b V2 n m 54 | setDefault2DAttributes d 55 | = d # lineWidthM def 56 | # lineTextureA def 57 | # lineCap def 58 | # lineJoin def 59 | # lineMiterLimitA def 60 | 61 | -- | Adjust the size and position of a 2D diagram to fit within the 62 | -- requested size. The first argument is a lens into the output 63 | -- size contained in the rendering options. Returns an updated 64 | -- options record, any transformation applied to the diagram (the 65 | -- inverse of which can be used, say, to translate output/device 66 | -- coordinates back into local diagram coordinates), and the 67 | -- modified diagram itself. 68 | adjustSize2D 69 | :: (TypeableFloat n, Monoid' m) 70 | => Lens' (Options b V2 n) (SizeSpec V2 n) 71 | -> b 72 | -> Options b V2 n 73 | -> QDiagram b V2 n m 74 | -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) 75 | adjustSize2D szL _ opts d = (set szL spec opts, t, d # transform t) 76 | where 77 | spec = dims sz 78 | (sz, t) = sizeAdjustment (opts ^. szL) (boundingBox d) 79 | 80 | -- | @adjustDia2D@ provides a useful default implementation of 81 | -- the 'adjustDia' method from the 'Backend' type class. 82 | -- 83 | -- As its first argument it requires a lens into the output size 84 | -- contained in the rendering options. 85 | -- 86 | -- It then performs the following adjustments: 87 | -- 88 | -- * Set default attributes (see 'setDefault2DAttributes') 89 | -- 90 | -- * Scale and translate the diagram to fit within the requested 91 | -- size (see 'adjustDiaSize2D') 92 | -- 93 | -- It returns an updated options record, any transformation applied 94 | -- to the diagram (the inverse of which can be used, say, to 95 | -- translate output/device coordinates back into local diagram 96 | -- coordinates), and the modified diagram itself. 97 | adjustDia2D :: (TypeableFloat n, Monoid' m) 98 | => Lens' (Options b V2 n) (SizeSpec V2 n) 99 | -> b -> Options b V2 n -> QDiagram b V2 n m 100 | -> (Options b V2 n, Transformation V2 n, QDiagram b V2 n m) 101 | adjustDia2D szL b opts d 102 | = adjustSize2D szL b opts (d # setDefault2DAttributes) 103 | 104 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Offset_expandTrailExample.svg: -------------------------------------------------------------------------------- 1 | LineCapSquareLineCapRoundLineCapButt -------------------------------------------------------------------------------- /src/Diagrams/Prelude.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} 2 | {-# LANGUAGE CPP #-} 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : Diagrams.Prelude 6 | -- Copyright : (c) 2011-2015 diagrams-lib team (see LICENSE) 7 | -- License : BSD-style (see LICENSE) 8 | -- Maintainer : diagrams-discuss@googlegroups.com 9 | -- 10 | -- A module to re-export most of the functionality of the diagrams 11 | -- core and standard library. 12 | -- 13 | ----------------------------------------------------------------------------- 14 | 15 | module Diagrams.Prelude 16 | ( 17 | -- * Diagrams library 18 | -- | Exports from this library for working with diagrams. 19 | module Diagrams 20 | 21 | -- * Convenience re-exports from other packages 22 | 23 | -- | For working with default values. Diagrams also exports 'with', 24 | -- an alias for 'def'. 25 | , module Data.Default 26 | 27 | -- | For representing and operating on colors. 28 | , module Data.Colour 29 | 30 | -- | A large list of color names. 31 | , module Data.Colour.Names 32 | 33 | -- | Specify your own colours. 34 | , module Data.Colour.SRGB 35 | 36 | -- | Semigroups and monoids show up all over the place, so things from 37 | -- Data.Semigroup and Data.Monoid often come in handy. 38 | , module Data.Semigroup 39 | 40 | -- | For computing with vectors. 41 | , module Linear.Vector 42 | 43 | -- | For computing with points and vectors. 44 | , module Linear.Affine 45 | 46 | -- | For computing with dot products and norm. 47 | , module Linear.Metric 48 | 49 | -- | For working with 'Active' (i.e. animated) things. 50 | , module Data.Active 51 | 52 | -- | Most of the lens package. The following functions are not 53 | -- exported from lens because they either conflict with 54 | -- diagrams or may conflict with other libraries: 55 | -- 56 | -- * 'Control.Lens.At.at' 57 | -- * 'Control.Lens.At.contains' 58 | -- * 'Control.Lens.Indexed..>' 59 | -- * 'Control.Lens.Indexed.<.>' 60 | -- * 'Control.Lens.Indexed.index' 61 | -- * 'Control.Lens.Indexed.indices' 62 | -- * 'Control.Lens.Indexed.none' 63 | -- * 'Control.Lens.Internal.Getter.coerce' 64 | -- * 'Control.Lens.Internal.Indexed.indexed' 65 | -- * 'Control.Lens.Lens.inside' 66 | -- * 'Control.Lens.Level.levels' 67 | -- * 'Control.Lens.Plated....' 68 | -- * 'Control.Lens.Plated.children' 69 | -- * 'Control.Lens.Plated.transform' 70 | -- * 'Control.Lens.Prism.outside' 71 | -- * 'Control.Lens.Setter.argument' 72 | -- * 'Control.Lens.Traversal.beside' 73 | -- * 'Control.Lens.Traversal.singular' 74 | , module Control.Lens 75 | 76 | , Applicative(..), (*>), (<*), (<$>), (<$), liftA, liftA2, liftA3 77 | ) where 78 | 79 | import Diagrams 80 | 81 | import Control.Applicative 82 | 83 | #if MIN_VERSION_lens(4,13,0) 84 | import Control.Lens hiding (argument, at, backwards, beside, 85 | children, contains, indexed, indices, 86 | inside, levels, none, outside, singular, 87 | transform, ( # ), (...), (.>), (<.>)) 88 | #else 89 | import Control.Lens hiding (argument, at, backwards, beside, 90 | children, coerce, contains, indexed, 91 | indices, inside, levels, none, outside, 92 | singular, transform, ( # ), (...), (.>), 93 | (<.>)) 94 | #endif 95 | 96 | import Data.Active 97 | import Data.Colour hiding (AffineSpace (..), atop, over) 98 | import Data.Colour.Names hiding (tan) 99 | import Data.Colour.SRGB 100 | import Data.Default 101 | import Data.Semigroup 102 | 103 | import Linear.Affine 104 | import Linear.Metric 105 | import Linear.Vector 106 | -------------------------------------------------------------------------------- /src/Diagrams/Animation/Active.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | 4 | ----------------------------------------------------------------------------- 5 | -- | 6 | -- Module : Diagrams.Animation.Active 7 | -- Copyright : (c) 2011 Brent Yorgey 8 | -- License : BSD-style (see LICENSE) 9 | -- Maintainer : byorgey@cis.upenn.edu 10 | -- 11 | -- A few utilities and class instances for 'Active' (from the @active@ 12 | -- package). In particular, this module defines 13 | -- 14 | -- * An instance of 'V' for 'Active': @'V' ('Active' a) = 'V' a@ 15 | -- 16 | -- * 'HasOrigin', 'Transformable', and 'HasStyle' instances for 17 | -- 'Active' which all work pointwise. 18 | -- 19 | -- * A 'TrailLike' instance for @'Active' p@ where @p@ is also 20 | -- 'TrailLike', which simply lifts a pathlike thing to a constant 21 | -- active value. 22 | -- 23 | -- * A 'Juxtaposable' instance for @'Active' a@ where @a@ is also 24 | -- 'Juxtaposable'. An active value can be juxtaposed against 25 | -- another by doing the juxtaposition pointwise over time. The 26 | -- era of @juxtapose v a1 a2@ will be the same as the era of @a2@, 27 | -- unless @a2@ is constant, in which case it will be the era of 28 | -- @a1@. (Note that @juxtapose v a1 a2@ and @liftA2 (juxtapose v) 29 | -- a1 a2@ therefore have different semantics: the second is an 30 | -- active value whose era is the /combination/ of the eras of @a1@ 31 | -- and @a2@). 32 | -- 33 | -- * An 'Alignable' instance for @'Active' a@ where @a@ is also 34 | -- 'Alignable'; the active value is aligned pointwise over time. 35 | 36 | ----------------------------------------------------------------------------- 37 | 38 | module Diagrams.Animation.Active where 39 | 40 | import Diagrams.Core 41 | import Diagrams.TrailLike 42 | 43 | import Data.Active 44 | 45 | type instance V (Active a) = V a 46 | type instance N (Active a) = N a 47 | 48 | -- Yes, these are all orphan instances. Get over it. We don't want to 49 | -- put them in the 'active' package because 'active' is supposed to be 50 | -- generally useful and shouldn't depend on diagrams. We'd also 51 | -- rather not put them in diagrams-core so that diagrams-core doesn't 52 | -- have to depend on active. 53 | 54 | instance HasOrigin a => HasOrigin (Active a) where 55 | moveOriginTo = fmap . moveOriginTo 56 | 57 | instance Transformable a => Transformable (Active a) where 58 | transform = fmap . transform 59 | 60 | instance HasStyle a => HasStyle (Active a) where 61 | applyStyle = fmap . applyStyle 62 | 63 | instance TrailLike t => TrailLike (Active t) where 64 | trailLike = pure . trailLike 65 | 66 | -- | An active value can be juxtaposed against another by doing the 67 | -- juxtaposition pointwise over time. The era of @juxtapose v a1 68 | -- a2@ will be the same as the era of @a2@, unless @a2@ is constant, 69 | -- in which case it will be the era of @a1@. (Note that @juxtapose 70 | -- v a1 a2@ and @liftA2 (juxtapose v) a1 a2@ therefore have 71 | -- different semantics: the second is an active value whose era is 72 | -- the /combination/ of the eras of @a1@ and @a2@). 73 | instance Juxtaposable a => Juxtaposable (Active a) where 74 | 75 | juxtapose v a1 a2 = 76 | onActive -- a1 77 | (\c1 -> -- if a1 is constant, just juxtapose a2 pointwise with its value 78 | juxtapose v c1 <$> a2 79 | ) 80 | -- if a1 is dynamic... 81 | (onDynamic $ \s1 e1 d1 -> 82 | onActive -- a2 83 | (\c2 -> -- if a2 is constant, juxtapose pointwise with a1. Since 84 | -- the result will no longer be constant, the result 85 | -- needs an era: we use a1's. 86 | mkActive s1 e1 (\t -> juxtapose v (d1 t) c2) 87 | ) 88 | 89 | -- otherwise, juxtapose pointwise, without changing a2's era 90 | (onDynamic $ \s2 e2 d2 -> 91 | mkActive s2 e2 (\t -> juxtapose v (d1 t) (d2 t)) 92 | ) 93 | a2 94 | ) 95 | a1 96 | 97 | -- instance Alignable a => Alignable (Active a) where 98 | -- alignBy v d a = alignBy v d <$> a 99 | -------------------------------------------------------------------------------- /src/Diagrams/Parametric/Adjust.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | ----------------------------------------------------------------------------- 7 | -- | 8 | -- Module : Diagrams.Parametric.Adjust 9 | -- Copyright : (c) 2013 diagrams-lib team (see LICENSE) 10 | -- License : BSD-style (see LICENSE) 11 | -- Maintainer : diagrams-discuss@googlegroups.com 12 | -- 13 | -- Tools for adjusting the length of parametric objects such as 14 | -- segments and trails. 15 | -- 16 | ----------------------------------------------------------------------------- 17 | module Diagrams.Parametric.Adjust 18 | ( adjust 19 | , AdjustOpts(_adjMethod, _adjSide, _adjEps) 20 | , adjMethod, adjSide, adjEps 21 | , AdjustMethod(..), AdjustSide(..) 22 | 23 | ) where 24 | 25 | import Control.Lens (Lens', generateSignatures, lensRules, makeLensesWith, (&), 26 | (.~), (^.)) 27 | import Data.Proxy 28 | 29 | import Data.Default 30 | 31 | import Diagrams.Core.V 32 | import Diagrams.Parametric 33 | 34 | -- | What method should be used for adjusting a segment, trail, or 35 | -- path? 36 | data AdjustMethod n = ByParam n -- ^ Extend by the given parameter value 37 | -- (use a negative parameter to shrink) 38 | | ByAbsolute n -- ^ Extend by the given arc length 39 | -- (use a negative length to shrink) 40 | | ToAbsolute n -- ^ Extend or shrink to the given 41 | -- arc length 42 | 43 | -- | Which side of a segment, trail, or path should be adjusted? 44 | data AdjustSide = Start -- ^ Adjust only the beginning 45 | | End -- ^ Adjust only the end 46 | | Both -- ^ Adjust both sides equally 47 | deriving (Show, Read, Eq, Ord, Bounded, Enum) 48 | 49 | -- | How should a segment, trail, or path be adjusted? 50 | data AdjustOpts n = AO { _adjMethod :: AdjustMethod n 51 | , _adjSide :: AdjustSide 52 | , _adjEps :: n 53 | , adjOptsvProxy :: Proxy n 54 | } 55 | 56 | -- See Diagrams.Combinators for reasoning behind 'Proxy'. 57 | 58 | makeLensesWith (lensRules & generateSignatures .~ False) ''AdjustOpts 59 | 60 | -- | Which method should be used for adjusting? 61 | adjMethod :: Lens' (AdjustOpts n) (AdjustMethod n) 62 | 63 | -- | Which end(s) of the object should be adjusted? 64 | adjSide :: Lens' (AdjustOpts n) AdjustSide 65 | 66 | -- | Tolerance to use when doing adjustment. 67 | adjEps :: Lens' (AdjustOpts n) n 68 | 69 | instance Fractional n => Default (AdjustMethod n) where 70 | def = ByParam 0.2 71 | 72 | instance Default AdjustSide where 73 | def = Both 74 | 75 | instance Fractional n => Default (AdjustOpts n) where 76 | def = AO { _adjMethod = def 77 | , _adjSide = def 78 | , _adjEps = stdTolerance 79 | , adjOptsvProxy = Proxy 80 | } 81 | 82 | -- | Adjust the length of a parametric object such as a segment or 83 | -- trail. The second parameter is an option record which controls how 84 | -- the adjustment should be performed; see 'AdjustOpts'. 85 | adjust :: (N t ~ n, Sectionable t, HasArcLength t, Fractional n) 86 | => t -> AdjustOpts n -> t 87 | adjust s opts = section s 88 | (if opts^.adjSide == End then domainLower s else getParam s) 89 | (if opts^.adjSide == Start then domainUpper s else domainUpper s - getParam (reverseDomain s)) 90 | where 91 | getParam seg = case opts^.adjMethod of 92 | ByParam p -> -p * bothCoef 93 | ByAbsolute len -> param (-len * bothCoef) 94 | ToAbsolute len -> param (absDelta len * bothCoef) 95 | where 96 | param = arcLengthToParam eps seg 97 | absDelta len = arcLength eps s - len 98 | bothCoef = if opts^.adjSide == Both then 0.5 else 1 99 | eps = opts^.adjEps 100 | -------------------------------------------------------------------------------- /test/Diagrams/Test/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | 6 | module Diagrams.Test.Transform where 7 | 8 | import Test.Tasty 9 | import Test.Tasty.QuickCheck 10 | import Diagrams.Prelude 11 | import Diagrams.Direction 12 | import Instances 13 | 14 | tests :: TestTree 15 | tests = testGroup "Transform" [ 16 | 17 | testProperty "rotating a vector by a number then its additive inverse will yield the original vector" $ 18 | \θ a -> rotate ((θ * (-1)) @@ deg) (rotate ((θ :: Double) @@ deg) (a :: V2 Double)) =~ a 19 | , testProperty "under rotated allows scaling along an angle" $ 20 | \θ f a -> under (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (negated (θ @@ deg)) . (scaleX f) . rotate (θ @@ deg)) a 21 | , testProperty "a rotation of 0 does nothing" $ 22 | \a -> rotate (0 @@ deg) (a :: V2 Double) =~ a 23 | , testProperty "adding 360 degrees to a turn does nothing" $ 24 | \c a -> rotate (((c :: Double) + 360) @@ deg) (a :: V2 Double) =~ rotate (c @@ deg) a 25 | , testProperty "over rotated allows scaling along x of a rotated shape" $ 26 | \θ f a -> over (rotated ((θ :: Double) @@ deg)) (scaleX (f :: Double)) (a :: V2 Double) =~ (rotate (θ @@ deg) . (scaleX f) . rotate (negated (θ @@ deg))) a 27 | , testProperty "scaleX" $ 28 | \f a b -> (scaleX (f :: Double)) (V2 (a :: Double) b) =~ V2 (a * f) b 29 | , testProperty "scaleY" $ 30 | \f a b -> (scaleY (f :: Double)) (V2 (a :: Double) b) =~ V2 a (f * b) 31 | , testProperty "reflectX" $ 32 | \a b -> reflectX (V2 (a :: Double) b) =~ V2 (a * (-1)) b 33 | , testProperty "reflectY" $ 34 | \a b -> reflectY (V2 (a :: Double) b) =~ V2 a ((-1) * b) 35 | , testProperty "reflectXY" $ 36 | \a b -> reflectXY (V2 (a :: Double) b) =~ V2 b a 37 | , testProperty "translate" $ 38 | \a b c d -> translateX (a :: Double) (translateY b (P (V2 c d ))) =~ P (V2 (a + c) (b + d)) 39 | , testProperty "shear" $ 40 | \a b c d -> shearX (a :: Double) (shearY b (V2 c d)) =~ V2 ((c*b + d) * a + c) (c*b + d) 41 | , testProperty "(1,0) rotateTo some dir will return normalised dir" $ 42 | \(NonZero a) b -> rotateTo (dir (V2 (a :: Double) b)) (V2 1 0) =~ signorm (V2 a b) 43 | , testProperty "rotates" $ 44 | \a c -> rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate'' ((a :: Double)@@ deg) (c :: V2 Double) && rotate ((a :: Double)@@ deg) (c :: V2 Double) =~ rotate' ((a :: Double)@@ deg) (c :: V2 Double) 45 | , testProperty "reflectAbout works for a vector" $ 46 | \a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (V2 e f) =~ over (rotated (atan2A' d c)) reflectY (V2 e f) 47 | , testProperty "reflectAbout works for a point" $ 48 | \a b c d e f -> reflectAbout (P (V2 (a :: Double) b)) (dir (V2 c d)) (P (V2 e f)) =~ translate (V2 a b) ((over (rotated (atan2A' d c)) reflectY) ((translate (V2 (-a) (-b)) ) (P (V2 e f)))) 49 | 50 | 51 | ] 52 | 53 | --the original " '' " and a secondary " ' " rotate function for testing 54 | 55 | rotation'' :: Floating n => Angle n -> T2 n 56 | rotation'' theta = fromLinear r (linv r) 57 | where 58 | r = rot theta <-> rot (negated theta) 59 | rot th (V2 x y) = V2 (cosA th * x - sinA th * y) 60 | (sinA th * x + cosA th * y) 61 | 62 | rotate'' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t 63 | rotate'' = transform . rotation'' 64 | 65 | rotation' :: Floating n => Angle n -> T2 n 66 | rotation' theta = fromLinear r (linv r) 67 | where 68 | r = rot theta <-> rot (negated theta) 69 | rot th (V2 x y) = V2 (c * x - s * y) 70 | (s * x + c * y) 71 | where 72 | c = cosA th 73 | s = sinA th 74 | 75 | rotate' :: (InSpace V2 n t, Transformable t, Floating n) => Angle n -> t -> t 76 | rotate' = transform . rotation' 77 | -------------------------------------------------------------------------------- /test/Diagrams/Test/Trail.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module Diagrams.Test.Trail where 5 | 6 | import Diagrams.Prelude 7 | import Instances 8 | import Test.Tasty 9 | import Test.Tasty.QuickCheck 10 | 11 | import Data.Fixed 12 | import Data.List 13 | 14 | tests :: TestTree 15 | tests = testGroup "Trail" 16 | [ let wrap :: Trail' Line V2 Double -> Located (Trail V2 Double) 17 | wrap = (`at` origin) . wrapLine 18 | in 19 | testProperty "unfixTrail . fixTrail == id for lines" $ 20 | \l -> (unfixTrail . fixTrail $ wrap l) =~ (wrap l) 21 | 22 | , testProperty "glueLine . cutLoop == id" $ 23 | \loop -> (glueLine . cutLoop $ loop) =~ (loop :: Trail' Loop V2 Double) 24 | 25 | , testProperty "trailOffset == sumV . trailOffsets" $ 26 | \t -> trailOffset t =~ (sumV . trailOffsets $ (t :: Trail V2 Double)) 27 | 28 | , testProperty "reverseTrail . reverseTrail == id" $ 29 | \t -> (reverseTrail . reverseTrail $ t) =~ (t :: Trail V2 Double) 30 | 31 | , testProperty "reverseLocTrail . reverseLocTrail == id" $ 32 | \t -> (reverseLocTrail . reverseLocTrail $ t) =~ 33 | (t :: Located (Trail V2 Double)) 34 | 35 | , testProperty "reverseLine . reverseLine == id" $ 36 | \t -> (reverseLine . reverseLine $ t) =~ 37 | (t :: Trail' Line V2 Double) 38 | 39 | , testProperty "reverseLocLine . reverseLocLine == id" $ 40 | \t -> (reverseLocLine . reverseLocLine $ t) =~ 41 | (t :: Located (Trail' Line V2 Double)) 42 | 43 | , testProperty "reverseLoop . reverseLoop == id" $ 44 | \t -> (reverseLoop . reverseLoop $ t) =~ 45 | (t :: Trail' Loop V2 Double) 46 | 47 | , testProperty "reverseLocLoop . reverseLocLoop == id" $ 48 | \t -> (reverseLocLoop . reverseLocLoop $ t) =~ 49 | (t :: Located (Trail' Loop V2 Double)) 50 | 51 | , testProperty "section on Trail' Line endpoints match paramaters" $ 52 | \t (Param a) (Param b) -> 53 | let s = section (t :: Located (Trail' Line V2 Double)) a b 54 | in t `atParam` a =~ s `atParam` 0 && 55 | t `atParam` b =~ s `atParam` 1 56 | 57 | , testProperty "section on Trail' Line where a paramater is 0 or 1" $ 58 | \t (Param a) -> 59 | let l = section (t :: Located (Trail' Line V2 Double)) 0 a 60 | r = section (t :: Located (Trail' Line V2 Double)) a 1 61 | in t `atParam` 0 =~ l `atParam` 0 && 62 | t `atParam` a =~ l `atParam` 1 && 63 | t `atParam` a =~ r `atParam` 0 && 64 | t `atParam` 1 =~ r `atParam` 1 65 | 66 | , testProperty "section on Trail' Line where a segment paramater is 0 or 1" $ 67 | \t (Param a) i -> 68 | let st = unLoc t # \(Line st') -> st' :: SegTree V2 Double 69 | b | (numSegs st :: Word) > 0 = (fromIntegral (i `mod` (numSegs st + 1) :: Word)) / numSegs st 70 | | otherwise = 0 71 | s = section (t :: Located (Trail' Line V2 Double)) a b 72 | in t `atParam` a =~ s `atParam` 0 && 73 | t `atParam` b =~ s `atParam` 1 74 | 75 | , testProperty "section on Trail' Line matches section on FixedSegment" $ 76 | \t (Param a) (Param b) -> sectionTrailSectionFixedSegment t a b 77 | 78 | ] 79 | 80 | data Param = Param Double deriving Show 81 | 82 | instance Arbitrary Param where 83 | arbitrary = Param <$> choose (-0.5, 1.5) 84 | 85 | sectionTrailSectionFixedSegment :: Located (Trail' Line V2 Double) -> Double -> Double -> Bool 86 | sectionTrailSectionFixedSegment t k1 k2 87 | | null segs = t == t' 88 | | otherwise = aSecT =~ aSecFS && bSecT =~ bSecFS 89 | where 90 | a = min k1 k2 91 | b = max k1 k2 92 | t' = section t a b 93 | 94 | segs = fixTrail $ mapLoc wrapLine t 95 | segs' = fixTrail $ mapLoc wrapLine t' 96 | 97 | aSecT = head segs' 98 | bSecT = last segs' 99 | 100 | (aSegIx, a') = splitParam a 101 | (bSegIx, b') = splitParam b 102 | 103 | aSecFS = section (segs !! floor aSegIx) a' x 104 | where x = if aSegIx == bSegIx then b' else 1 105 | bSecFS = section (segs !! floor bSegIx) x b' 106 | where x = if aSegIx == bSegIx then a' else 0 107 | 108 | splitParam p | p < 0 = (0 , p * n) 109 | | p >= 1 = (n - 1, 1 + (p - 1) * n) 110 | | otherwise = propFrac $ p * n 111 | where 112 | propFrac x = let m = x `mod'` 1 in (x - m, m) 113 | n = genericLength segs 114 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_CubicSpline_cubicSplineEx.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /diagrams/src_Diagrams_TwoD_Arrow_example2.svg: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /src/Diagrams/Coordinates.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Diagrams.Coordinates 8 | -- Copyright : (c) 2012 diagrams-lib team (see LICENSE) 9 | -- License : BSD-style (see LICENSE) 10 | -- Maintainer : diagrams-discuss@googlegroups.com 11 | -- 12 | -- Nice syntax for constructing and pattern-matching on literal 13 | -- points and vectors. 14 | -- 15 | ----------------------------------------------------------------------------- 16 | 17 | module Diagrams.Coordinates 18 | ( (:&)(..), Coordinates(..) 19 | ) 20 | where 21 | 22 | import Data.Kind (Type) 23 | import Diagrams.Points 24 | import Linear (V2 (..), V3 (..), V4 (..)) 25 | 26 | -- | Types which are instances of the @Coordinates@ class can be 27 | -- constructed using '^&' (for example, a three-dimensional vector 28 | -- could be constructed by @1 ^& 6 ^& 3@), and deconstructed using 29 | -- 'coords'. A common pattern is to use 'coords' in conjunction 30 | -- with the @ViewPatterns@ extension, like so: 31 | -- 32 | -- @ 33 | -- foo :: Vector3 -> ... 34 | -- foo (coords -> x :& y :& z) = ... 35 | -- @ 36 | class Coordinates c where 37 | 38 | -- | The type of the final coordinate. 39 | type FinalCoord c :: Type 40 | 41 | -- | The type of everything other than the final coordinate. 42 | type PrevDim c :: Type 43 | 44 | -- | Decomposition of @c@ into applications of ':&'. 45 | type Decomposition c :: Type 46 | -- Decomposition c = Decomposition (PrevDim c) :& FinalCoord c (essentially) 47 | 48 | -- | Construct a value of type @c@ by providing something of one 49 | -- less dimension (which is perhaps itself recursively constructed 50 | -- using @(^&)@) and a final coordinate. For example, 51 | -- 52 | -- @ 53 | -- 2 ^& 3 :: P2 54 | -- 3 ^& 5 ^& 6 :: V3 55 | -- @ 56 | -- 57 | -- Note that @^&@ is left-associative. 58 | (^&) :: PrevDim c -> FinalCoord c -> c 59 | 60 | -- | Prefix synonym for @^&@. pr stands for pair of @PrevDim@, @FinalCoord@ 61 | pr :: PrevDim c -> FinalCoord c -> c 62 | pr = (^&) 63 | 64 | -- | Decompose a value of type @c@ into its constituent coordinates, 65 | -- stored in a nested @(:&)@ structure. 66 | coords :: c -> Decomposition c 67 | 68 | infixl 7 ^& 69 | 70 | -- | A pair of values, with a convenient infix (left-associative) 71 | -- data constructor. 72 | data a :& b = a :& b 73 | deriving (Eq, Ord, Show) 74 | 75 | infixl 7 :& 76 | 77 | -- Instance for :& (the buck stops here) 78 | instance Coordinates (a :& b) where 79 | type FinalCoord (a :& b) = b 80 | type PrevDim (a :& b) = a 81 | type Decomposition (a :& b) = a :& b 82 | x ^& y = x :& y 83 | coords (x :& y) = x :& y 84 | 85 | 86 | -- Some standard instances for plain old tuples 87 | 88 | instance Coordinates (a,b) where 89 | type FinalCoord (a,b) = b 90 | type PrevDim (a,b) = a 91 | type Decomposition (a,b) = a :& b 92 | 93 | x ^& y = (x,y) 94 | coords (x,y) = x :& y 95 | 96 | instance Coordinates (a,b,c) where 97 | type FinalCoord (a,b,c) = c 98 | type PrevDim (a,b,c) = (a,b) 99 | type Decomposition (a,b,c) = Decomposition (a,b) :& c 100 | 101 | (x,y) ^& z = (x,y,z) 102 | coords (x,y,z) = coords (x,y) :& z 103 | 104 | instance Coordinates (a,b,c,d) where 105 | type FinalCoord (a,b,c,d) = d 106 | type PrevDim (a,b,c,d) = (a,b,c) 107 | type Decomposition (a,b,c,d) = Decomposition (a,b,c) :& d 108 | 109 | (w,x,y) ^& z = (w,x,y,z) 110 | coords (w,x,y,z) = coords (w,x,y) :& z 111 | 112 | instance Coordinates (v n) => Coordinates (Point v n) where 113 | type FinalCoord (Point v n) = FinalCoord (v n) 114 | type PrevDim (Point v n) = PrevDim (v n) 115 | type Decomposition (Point v n) = Decomposition (v n) 116 | 117 | x ^& y = P (x ^& y) 118 | coords (P v) = coords v 119 | 120 | -- instances for linear 121 | 122 | instance Coordinates (V2 n) where 123 | type FinalCoord (V2 n) = n 124 | type PrevDim (V2 n) = n 125 | type Decomposition (V2 n) = n :& n 126 | 127 | x ^& y = V2 x y 128 | coords (V2 x y) = x :& y 129 | 130 | instance Coordinates (V3 n) where 131 | type FinalCoord (V3 n) = n 132 | type PrevDim (V3 n) = V2 n 133 | type Decomposition (V3 n) = n :& n :& n 134 | 135 | V2 x y ^& z = V3 x y z 136 | coords (V3 x y z) = x :& y :& z 137 | 138 | instance Coordinates (V4 n) where 139 | type FinalCoord (V4 n) = n 140 | type PrevDim (V4 n) = V3 n 141 | type Decomposition (V4 n) = n :& n :& n :& n 142 | 143 | V3 x y z ^& w = V4 x y z w 144 | coords (V4 x y z w) = x :& y :& z :& w 145 | 146 | -------------------------------------------------------------------------------- /src/Diagrams/Transform.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-unused-imports #-} 7 | -- for Data.Semigroup 8 | 9 | ----------------------------------------------------------------------------- 10 | -- | 11 | -- Module : Diagrams.Transform 12 | -- Copyright : (c) 2011-15 diagrams-lib team (see LICENSE) 13 | -- License : BSD-style (see LICENSE) 14 | -- Maintainer : diagrams-discuss@googlegroups.com 15 | -- 16 | -- Affine transformations, parameterized by any vector space. For 17 | -- transformations on particular vector spaces, see /e.g./ 18 | -- "Diagrams.TwoD.Transform". 19 | -- 20 | ----------------------------------------------------------------------------- 21 | 22 | 23 | module Diagrams.Transform 24 | ( -- * Transformations 25 | Transformation, inv, transl, apply, papply 26 | 27 | -- * The Transformable class 28 | , Transformable(..) 29 | 30 | -- * Some specific transformations 31 | , translation, translate, moveTo, place, scaling, scale 32 | 33 | -- * Miscellaneous transformation-related utilities 34 | , conjugate, underT, transformed, translated, movedTo, movedFrom 35 | 36 | -- * The HasOrigin class 37 | 38 | , HasOrigin(..), moveOriginBy 39 | 40 | ) where 41 | 42 | import Control.Lens hiding (transform) 43 | import Data.Semigroup 44 | import Diagrams.Core 45 | 46 | import Linear.Vector 47 | 48 | -- | Conjugate one transformation by another. @conjugate t1 t2@ is the 49 | -- transformation which performs first @t1@, then @t2@, then the 50 | -- inverse of @t1@. 51 | conjugate :: (Additive v, Num n) 52 | => Transformation v n -> Transformation v n -> Transformation v n 53 | conjugate t1 t2 = inv t1 <> t2 <> t1 54 | 55 | -- | Carry out some transformation \"under\" another one: @f ``underT`` 56 | -- t@ first applies @t@, then @f@, then the inverse of @t@. For 57 | -- example, @'scaleX' 2 ``underT`` 'rotation' (-1/8 \@\@ Turn)@ 58 | -- is the transformation which scales by a factor of 2 along the 59 | -- diagonal line y = x. 60 | -- 61 | -- Note that 62 | -- 63 | -- @ 64 | -- (transform t2) `underT` t1 == transform (conjugate t1 t2) 65 | -- @ 66 | -- 67 | -- for all transformations @t1@ and @t2@. 68 | -- 69 | -- See also the isomorphisms like 'transformed', 'movedTo', 70 | -- 'movedFrom', and 'translated'. 71 | underT :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) 72 | => (a -> b) -> Transformation v n -> a -> b 73 | f `underT` t = transform (inv t) . f . transform t 74 | 75 | -- | Use a 'Transformation' to make an 'Iso' between an object 76 | -- transformed and untransformed. This is useful for carrying out 77 | -- functions 'under' another transform: 78 | -- 79 | -- @ 80 | -- under (transformed t) f == transform (inv t) . f . transform t 81 | -- under (transformed t1) (transform t2) == transform (conjugate t1 t2) 82 | -- transformed t ## a == transform t a 83 | -- a ^. transformed t == transform (inv t) a 84 | -- @ 85 | transformed :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) 86 | => Transformation v n -> Iso a b a b 87 | transformed t = iso (transform $ inv t) (transform t) 88 | 89 | -- | Use a 'Point' to make an 'Iso' between an object 90 | -- moved to and from that point: 91 | -- 92 | -- @ 93 | -- under (movedTo p) f == moveTo (-p) . f . moveTo p 94 | -- over (movedTo p) f == moveTo p . f . moveTo (-p) 95 | -- movedTo p == from (movedFrom p) 96 | -- movedTo p ## a == moveTo p a 97 | -- a ^. movedTo p == moveOriginTo p a 98 | -- @ 99 | movedTo :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) 100 | => Point v n -> Iso a b a b 101 | movedTo p = iso (moveTo (negated p)) (moveTo p) 102 | 103 | -- | Use a 'Transformation' to make an 'Iso' between an object 104 | -- transformed and untransformed. We have 105 | -- 106 | -- @ 107 | -- under (movedFrom p) f == moveTo p . f . moveTo (-p) 108 | -- movedFrom p == from (movedTo p) 109 | -- movedFrom p ## a == moveOriginTo p a 110 | -- a ^. movedFrom p == moveTo p a 111 | -- over (movedFrom p) f == moveTo (-p) . f . moveTo p 112 | -- @ 113 | movedFrom :: (InSpace v n a, SameSpace a b, HasOrigin a, HasOrigin b) 114 | => Point v n -> Iso a b a b 115 | movedFrom p = iso (moveOriginTo (negated p)) (moveOriginTo p) 116 | 117 | -- | Use a vector to make an 'Iso' between an object translated and 118 | -- untranslated. 119 | -- 120 | -- @ 121 | -- under (translated v) f == translate (-v) . f . translate v 122 | -- translated v ## a == translate v a 123 | -- a ^. translated v == translate (-v) a 124 | -- over (translated v) f == translate v . f . translate (-v) 125 | -- @ 126 | translated :: (InSpace v n a, SameSpace a b, Transformable a, Transformable b) 127 | => v n -> Iso a b a b 128 | translated v = transformed $ translation v 129 | --------------------------------------------------------------------------------