diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 3fea246b..206ec597 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -83,8 +83,10 @@ Library Diagrams.TwoD.Model, Diagrams.TwoD.Offset, Diagrams.TwoD.Path, + Diagrams.TwoD.Points, Diagrams.TwoD.Polygons, Diagrams.TwoD.Segment, + Diagrams.TwoD.Segment.Bernstein, Diagrams.TwoD.Size, Diagrams.TwoD.Shapes, Diagrams.TwoD.Text, diff --git a/src/Diagrams/Path.hs b/src/Diagrams/Path.hs index 4caf438c..1138dbef 100644 --- a/src/Diagrams/Path.hs +++ b/src/Diagrams/Path.hs @@ -36,6 +36,7 @@ module Diagrams.Path -- * Constructing paths -- $construct + , ToPath (..) , pathFromTrail , pathFromTrailAt , pathFromLocTrail @@ -61,7 +62,7 @@ module Diagrams.Path import Control.Arrow ((***)) import Control.Lens (Rewrapped, Wrapped (..), iso, mapped, op, over, view, (%~), - _Unwrapped', _Wrapped) + _Unwrapped', _Wrapped, Each (..), traversed) import qualified Data.Foldable as F import Data.List (partition) import Data.Semigroup @@ -113,6 +114,9 @@ instance Wrapped (Path v n) where instance Rewrapped (Path v n) (Path v' n') +instance Each (Path v n) (Path v' n') (Located (Trail v n)) (Located (Trail v' n')) where + each = _Wrapped . traversed + -- | Extract the located trails making up a 'Path'. pathTrails :: Path v n -> [Located (Trail v n)] pathTrails = op Path @@ -138,7 +142,7 @@ instance (HasLinearMap v, Metric v, OrderedField n) transform = over _Wrapped . map . transform instance (Metric v, OrderedField n) => Enveloped (Path v n) where - getEnvelope = F.foldMap trailEnvelope . op Path --view pathTrails + getEnvelope = F.foldMap trailEnvelope . op Path -- this type signature is necessary to work around an apparent bug in ghc 6.12.1 where trailEnvelope :: Located (Trail v n) -> Envelope v n trailEnvelope (viewLoc -> (p, t)) = moveOriginTo ((-1) *. p) (getEnvelope t) @@ -157,6 +161,43 @@ instance (HasLinearMap v, Metric v, OrderedField n) -- Constructing paths ------------------------------------ ------------------------------------------------------------ +-- | Type class for things that can be converted to a 'Path'. +-- +-- Note that this class is very different from 'TrailLike'. 'TrailLike' is +-- usually the result of a library function to give you a convenient, +-- polymorphic result ('Path', 'Diagram' etc.). +-- +class ToPath t where + -- | 'toPath' takes something that can be converted to 'Path' and returns + -- the 'Path'. + toPath :: (Metric (V t), OrderedField (N t)) => t -> Path (V t) (N t) + +instance ToPath (Path v n) where + toPath = id + +instance ToPath (Trail v n) where + toPath = pathFromTrail + +instance ToPath (Located (Trail v n)) where + toPath = pathFromLocTrail + +instance ToPath (Located (Trail' l v n)) where + toPath = pathFromLocTrail . mapLoc Trail + +instance ToPath (Located (Segment Closed v n)) where + toPath (viewLoc -> (p,seg)) + = Path [trailFromSegments [seg] `at` p] + +instance ToPath (Located [Segment Closed v n]) where + toPath (viewLoc -> (p,segs)) + = Path [trailFromSegments segs `at` p] + +instance ToPath (FixedSegment v n) where + toPath = toPath . fromFixedSeg + +instance ToPath a => ToPath [a] where + toPath = F.foldMap toPath + -- $construct -- Since paths are 'TrailLike', any function producing a 'TrailLike' -- can be used to construct a (singleton) path. The functions in this diff --git a/src/Diagrams/Points.hs b/src/Diagrams/Points.hs index ec262d7c..1af58d45 100644 --- a/src/Diagrams/Points.hs +++ b/src/Diagrams/Points.hs @@ -18,7 +18,6 @@ module Diagrams.Points , centroid , pointDiagram , _Point, lensP - , project ) where import Diagrams.Core (pointDiagram) @@ -27,7 +26,6 @@ import Diagrams.Core.Points import Data.Foldable as F import Linear.Affine -import Linear.Metric import Linear.Vector -- | The centroid of a set of /n/ points is their sum divided by /n/. diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index 8745717c..fb556ff8 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -148,7 +148,7 @@ import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline import Diagrams.Deform -import Diagrams.Direction +import Diagrams.Direction hiding (dir) import Diagrams.Envelope import Diagrams.Located import Diagrams.Names diff --git a/src/Diagrams/Segment.hs b/src/Diagrams/Segment.hs index ab17acbb..820ac1b0 100644 --- a/src/Diagrams/Segment.hs +++ b/src/Diagrams/Segment.hs @@ -63,8 +63,8 @@ module Diagrams.Segment ) where -import Control.Lens (Rewrapped, Traversal, Wrapped (..), iso, makeLenses, op, - over) +import Control.Lens (Rewrapped, Wrapped (..), iso, makeLenses, op, + over, Each (..)) import Data.FingerTree import Data.Monoid.MList import Data.Semigroup @@ -116,9 +116,10 @@ instance Functor v => Functor (Offset c v) where fmap _ OffsetOpen = OffsetOpen fmap f (OffsetClosed v) = OffsetClosed (fmap f v) -offsetVector :: Traversal (Offset c v n) (Offset c v' n') (v n) (v' n') -offsetVector f (OffsetClosed v) = OffsetClosed <$> f v -offsetVector _ OffsetOpen = pure OffsetOpen +instance Each (Offset c v n) (Offset c v' n') (v n) (v' n') where + each f (OffsetClosed v) = OffsetClosed <$> f v + each _ OffsetOpen = pure OffsetOpen + {-# INLINE each #-} type instance V (Offset c v n) = v type instance N (Offset c v n) = n @@ -151,21 +152,14 @@ data Segment c v n deriving (Show, Functor, Eq, Ord) --- this is provided as a replacement of the previous fmap functionality. (Now --- fmap is only over the number type) - --- Prehaps a traversal is overkill. Only really need to map over segment vectors. - --- | A traversal of the vectors that make up a segment. -segmentVectors :: Traversal (Segment c v n) (Segment c v' n') (v n) (v' n') -segmentVectors f (Linear offset) = Linear <$> offsetVector f offset -segmentVectors f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> offsetVector f offset +instance Each (Segment c v n) (Segment c v' n') (v n) (v' n') where + each f (Linear offset) = Linear <$> each f offset + each f (Cubic v1 v2 offset) = Cubic <$> f v1 <*> f v2 <*> each f offset + {-# INLINE each #-} -- | Map over the vectors of each segment. mapSegmentVectors :: (v n -> v' n') -> Segment c v n -> Segment c v' n' -mapSegmentVectors = over segmentVectors --- mapSegmentVectors f (Linear offset) = Linear $ over offsetVector f offset --- mapSegmentVectors f (Cubic v1 v2 offset) = Cubic (f v1) (f v2) (over offsetVector f offset) +mapSegmentVectors = over each -- Note, can't yet have Haddock comments on GADT constructors; see -- http://trac.haskell.org/haddock/ticket/43. For now we don't need @@ -340,31 +334,16 @@ data FixedSegment v n = FLinear (Point v n) (Point v n) type instance V (FixedSegment v n) = v type instance N (FixedSegment v n) = n +instance Each (FixedSegment v n) (FixedSegment v' n') (Point v n) (Point v' n') where + each f (FLinear p0 p1) = FLinear <$> f p0 <*> f p1 + each f (FCubic p0 p1 p2 p3) = FCubic <$> f p0 <*> f p1 <*> f p2 <*> f p3 + {-# INLINE each #-} + instance (Additive v, Num n) => Transformable (FixedSegment v n) where - transform t (FLinear p1 p2) - = FLinear - (transform t p1) - (transform t p2) - - transform t (FCubic p1 c1 c2 p2) - = FCubic - (transform t p1) - (transform t c1) - (transform t c2) - (transform t p2) + transform t = over each (papply t) instance (Additive v, Num n) => HasOrigin (FixedSegment v n) where - moveOriginTo o (FLinear p1 p2) - = FLinear - (moveOriginTo o p1) - (moveOriginTo o p2) - - moveOriginTo o (FCubic p1 c1 c2 p2) - = FCubic - (moveOriginTo o p1) - (moveOriginTo o c1) - (moveOriginTo o c2) - (moveOriginTo o p2) + moveOriginTo o = over each (moveOriginTo o) instance (Metric v, OrderedField n) => Enveloped (FixedSegment v n) where getEnvelope f = moveTo p (getEnvelope s) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 110b9289..ac03f7e1 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -63,9 +63,6 @@ import Linear.Metric import Linear.V3 (cross) import Linear.Vector --- | Type alias for transformations in R3. -type T3 = Transformation V3 - -- | Create a transformation which rotates by the given angle about -- a line parallel the Z axis passing through the local origin. -- A positive angle brings positive x-values towards the positive-y axis. diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index dc65bee5..4cf812d5 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -18,7 +18,7 @@ module Diagrams.ThreeD.Types , p3, unp3, mkP3 , r3Iso, p3Iso, project , r3SphericalIso, r3CylindricalIso - , V3 (..), P3 + , V3 (..), P3, T3 , R1 (..), R2 (..), R3 (..) ) where @@ -39,6 +39,7 @@ import Linear.V3 as V -- Basic R3 types type P3 = Point V3 +type T3 = Transformation V3 r3Iso :: Iso' (V3 n) (n, n, n) r3Iso = iso unr3 r3 diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index b117569e..931fc029 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -78,6 +78,8 @@ module Diagrams.TwoD , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop , FillRule(..), fillRule , StrokeOpts(..), vertexNames, queryFillRule + , intersectPoints, intersectPoints' + , intersectPointsP, intersectPointsP' -- ** Clipping , clipBy, clipTo, clipped diff --git a/src/Diagrams/TwoD/Model.hs b/src/Diagrams/TwoD/Model.hs index 5283c259..e215ec82 100644 --- a/src/Diagrams/TwoD/Model.hs +++ b/src/Diagrams/TwoD/Model.hs @@ -101,10 +101,10 @@ showOrigin = showOrigin' def showOrigin' :: (TypeableFloat n, Renderable (Path V2 n) b, Monoid' m) => OriginOpts n -> QDiagram b V2 n m -> QDiagram b V2 n m showOrigin' oo d = o <> d - where o = stroke (circle sz) - # fc (oo^.oColor) - # lw none - # fmap (const mempty) + where o = strokeP (circle sz) + # fc (oo^.oColor) + # lw none + # fmap (const mempty) V2 w h = oo^.oScale *^ size d sz = maximum [w, h, oo^.oMinSize] diff --git a/src/Diagrams/TwoD/Path.hs b/src/Diagrams/TwoD/Path.hs index 3bce8ac3..334348de 100644 --- a/src/Diagrams/TwoD/Path.hs +++ b/src/Diagrams/TwoD/Path.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -27,7 +28,9 @@ module Diagrams.TwoD.Path ( -- * Constructing path-based diagrams - stroke, stroke', strokeTrail, strokeT, strokeTrail', strokeT' + stroke, stroke' + , strokePath, strokeP, strokePath', strokeP' + , strokeTrail, strokeT, strokeTrail', strokeT' , strokeLine, strokeLoop , strokeLocTrail, strokeLocT, strokeLocLine, strokeLocLoop @@ -44,6 +47,12 @@ module Diagrams.TwoD.Path -- * Clipping , Clip(..), clipBy, clipTo, clipped + + -- * Intersections + + , intersectPoints, intersectPoints' + , intersectPointsP, intersectPointsP' + , intersectPointsT, intersectPointsT' ) where import Control.Applicative (liftA2) @@ -66,8 +75,9 @@ import Diagrams.Segment import Diagrams.Solve import Diagrams.Trail import Diagrams.TrailLike -import Diagrams.TwoD.Segment () +import Diagrams.TwoD.Segment import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector import Diagrams.Util (tau) import Linear.Affine @@ -149,34 +159,44 @@ instance Default (StrokeOpts a) where , _queryFillRule = def } --- | Convert a path into a diagram. The resulting diagram has the +-- | Convert a 'ToPath' object into a diagram. The resulting diagram has the -- names 0, 1, ... assigned to each of the path's vertices. -- -- See also 'stroke'', which takes an extra options record allowing --- its behavior to be customized. --- --- Note that a bug in GHC 7.0.1 causes a context stack overflow when --- inferring the type of @stroke@. The solution is to give a type --- signature to expressions involving @stroke@, or (recommended) --- upgrade GHC (the bug is fixed in 7.0.2 onwards). -stroke :: (TypeableFloat n, Renderable (Path V2 n) b) - => Path V2 n -> QDiagram b V2 n Any -stroke = stroke' (def :: StrokeOpts ()) - -instance (TypeableFloat n, Renderable (Path V2 n) b) - => TrailLike (QDiagram b V2 n Any) where - trailLike = stroke . trailLike +-- its behaviour to be customized. +stroke :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b) + => t -> QDiagram b V2 n Any +stroke = strokeP . toPath -- | A variant of 'stroke' that takes an extra record of options to --- customize its behavior. In particular: +-- customize its behaviour. In particular: -- -- * Names can be assigned to the path's vertices -- -- 'StrokeOpts' is an instance of 'Default', so @stroke' ('with' & -- ... )@ syntax may be used. -stroke' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) +stroke' :: (InSpace V2 n t, ToPath t, TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> t -> QDiagram b V2 n Any +stroke' opts = strokeP' opts . toPath + +-- | 'stroke' specialised to 'Path'. +strokeP :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any +strokeP = strokeP' (def :: StrokeOpts ()) + +-- | 'stroke' specialised to 'Path'. +strokePath :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any +strokePath = strokeP + +instance (TypeableFloat n, Renderable (Path V2 n) b) + => TrailLike (QDiagram b V2 n Any) where + trailLike = strokeP . trailLike + +-- | 'stroke'' specialised to 'Path'. +strokeP' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any -stroke' opts path +strokeP' opts path | null (pLines ^. _Wrapped') = mkP pLoops | null (pLoops ^. _Wrapped') = mkP pLines | otherwise = mkP pLines <> mkP pLoops @@ -191,20 +211,17 @@ stroke' opts path ) (Query $ Any . flip (runFillRule (opts^.queryFillRule)) p) +-- | 'stroke'' specialised to 'Path'. +strokePath' :: (TypeableFloat n, Renderable (Path V2 n) b, IsName a) + => StrokeOpts a -> Path V2 n -> QDiagram b V2 n Any +strokePath' = strokeP' --- | A composition of 'stroke' and 'pathFromTrail' for conveniently --- converting a trail directly into a diagram. --- --- Note that a bug in GHC 7.0.1 causes a context stack overflow when --- inferring the type of 'stroke' and hence of @strokeTrail@ as well. --- The solution is to give a type signature to expressions involving --- @strokeTrail@, or (recommended) upgrade GHC (the bug is fixed in 7.0.2 --- onwards). +-- | 'stroke' specialised to 'Trail'. strokeTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> QDiagram b V2 n Any strokeTrail = stroke . pathFromTrail --- | Deprecated synonym for 'strokeTrail'. +-- | 'stroke' specialised to 'Trail'. strokeT :: (TypeableFloat n, Renderable (Path V2 n) b) => Trail V2 n -> QDiagram b V2 n Any strokeT = strokeTrail @@ -236,7 +253,7 @@ strokeLoop = strokeT . wrapLoop -- into a diagram; @strokeLocTrail = stroke . trailLike@. strokeLocTrail :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail V2 n) -> QDiagram b V2 n Any -strokeLocTrail = stroke . trailLike +strokeLocTrail = strokeP . trailLike -- | Deprecated synonym for 'strokeLocTrail'. strokeLocT :: (TypeableFloat n, Renderable (Path V2 n) b) @@ -247,13 +264,13 @@ strokeLocT = strokeLocTrail -- into a diagram; @strokeLocLine = stroke . trailLike . mapLoc wrapLine@. strokeLocLine :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Line V2 n) -> QDiagram b V2 n Any -strokeLocLine = stroke . trailLike . mapLoc wrapLine +strokeLocLine = strokeP . trailLike . mapLoc wrapLine -- | A convenience function for converting a @Located@ loop directly -- into a diagram; @strokeLocLoop = stroke . trailLike . mapLoc wrapLoop@. strokeLocLoop :: (TypeableFloat n, Renderable (Path V2 n) b) => Located (Trail' Loop V2 n) -> QDiagram b V2 n Any -strokeLocLoop = stroke . trailLike . mapLoc wrapLoop +strokeLocLoop = strokeP . trailLike . mapLoc wrapLoop ------------------------------------------------------------ -- Inside/outside testing @@ -279,9 +296,6 @@ getFillRule (FillRuleA (Last r)) = r fillRule :: HasStyle a => FillRule -> a -> a fillRule = applyAttr . FillRuleA . Last -cross2 :: Num n => V2 n -> V2 n -> n -cross2 (V2 x y) (V2 x' y') = x * y' - y * x' - -- XXX link to more info on this -- | Test whether the given point is inside the given (closed) path, @@ -319,11 +333,6 @@ trailCrossings p@(unp2 -> (x,y)) tr | by <= y && ay > y && isLeft a b < 0 = -1 | otherwise = 0 - -- test c@(FCubic (unp2 -> x1@(_,x1y)) - -- (unp2 -> c1@(_,c1y)) - -- (unp2 -> c2@(_,c2y)) - -- (unp2 -> x2@(_,x2y)) - -- ) = test c@(FCubic (P x1@(V2 _ x1y)) (P c1@(V2 _ c1y)) (P c2@(V2 _ c2y)) @@ -384,7 +393,8 @@ clipBy = applyTAttr . Clip . (:[]) -- trace consists of those parts of the original diagram's trace -- which fall within the clipping path, or parts of the path's trace -- within the original diagram. -clipTo :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipTo :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d where envP = appEnvelope . getEnvelope $ p @@ -392,8 +402,8 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d toEnvelope = case (envP, envD) of (Just eP, Just eD) -> setEnvelope . mkEnvelope $ \v -> min (eP v) (eD v) (_, _) -> id - intersectionTrace = Trace intersections - intersections pt v = + intersectionTrace = Trace traceIntersections + traceIntersections pt v = -- on boundary of d, inside p onSortedList (filter pInside) (appTrace (getTrace d) pt v) <> -- or on boundary of p, inside d @@ -404,6 +414,44 @@ clipTo p d = setTrace intersectionTrace . toEnvelope $ clipBy p d -- | Clip a diagram to the clip path taking the envelope and trace of the clip -- path. -clipped :: (TypeableFloat n, Renderable (Path V2 n) b) => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any +clipped :: (TypeableFloat n, Renderable (Path V2 n) b) + => Path V2 n -> QDiagram b V2 n Any -> QDiagram b V2 n Any clipped p = withTrace p . withEnvelope p . clipBy p +------------------------------------------------------------ +-- Intersections ----------------------------------------- +------------------------------------------------------------ + +-- | Find the intersect points of two objects that can be converted to a path. +intersectPoints :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) + => t -> s -> [P2 n] +intersectPoints = intersectPoints' 1e-10 + +-- | Find the intersect points of two objects that can be converted to a path +-- within the given tolerance. +intersectPoints' :: (InSpace V2 n t, SameSpace t s, ToPath t, ToPath s, OrderedField n) + => n -> t -> s -> [P2 n] +intersectPoints' eps t s = intersectPointsP' eps (toPath t) (toPath s) + +-- | Compute the intersect points between two paths. +intersectPointsP :: OrderedField n => Path V2 n -> Path V2 n -> [P2 n] +intersectPointsP = intersectPointsP' 1e-10 + +-- | Compute the intersect points between two paths within given tolerance. +intersectPointsP' :: OrderedField n => n -> Path V2 n -> Path V2 n -> [P2 n] +intersectPointsP' eps as bs = do + a <- pathTrails as + b <- pathTrails bs + intersectPointsT' eps a b + +-- | Compute the intersect points between two located trails. +intersectPointsT :: OrderedField n => Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] +intersectPointsT = intersectPointsT' 1e-10 + +-- | Compute the intersect points between two located trails within the given +-- tolerance. +intersectPointsT' :: OrderedField n => n -> Located (Trail V2 n) -> Located (Trail V2 n) -> [P2 n] +intersectPointsT' eps as bs = do + a <- fixTrail as + b <- fixTrail bs + intersectPointsS' eps a b diff --git a/src/Diagrams/TwoD/Points.hs b/src/Diagrams/TwoD/Points.hs new file mode 100644 index 00000000..14ca9abc --- /dev/null +++ b/src/Diagrams/TwoD/Points.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.TwoD.Points +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Special functions for points in R2. +-- +----------------------------------------------------------------------------- + +module Diagrams.TwoD.Points where + +import Data.List + +import Diagrams.Core +import Diagrams.TwoD.Vector +import Diagrams.TwoD.Types (P2) + +import Linear.Affine + +-- | Find the convex hull of a list of points using Andrew's monotone chain +-- algorithm O(n log n). +-- +-- Returns clockwise list of points starting from the left-most point. +convexHull2D :: OrderedField n => [P2 n] -> [P2 n] +convexHull2D ps = init upper ++ reverse (tail lower) + where + (upper, lower) = sortedConvexHull (sort ps) + +-- | Find the convex hull of a set of points already sorted in the x direction. +-- The first list of the tuple is the upper hull going clockwise from +-- left-most to right-most point. The second is the lower hull from +-- right-most to left-most in the anti-clockwise direction. +sortedConvexHull :: OrderedField n => [P2 n] -> ([P2 n], [P2 n]) +sortedConvexHull ps = (chain True ps, chain False ps) + where + chain upper (p1_:p2_:rest_) = + case go (p2_ .-. p1_) p2_ rest_ of + Right l -> p1_:l + Left l -> chain upper (p1_:l) + where + test = if upper then (>0) else (<0) + -- find the convex hull by comparing the angles of the vectors with + -- the cross product and backtracking if necessary + go dir p1 l@(p2:rest) + -- backtrack if the direction is outward + | test $ dir `cross2` dir' = Left l + | otherwise = + case go dir' p2 rest of + Left m -> go dir p1 m + Right m -> Right (p1:m) + where + dir' = p2 .-. p1 + go _ p1 p = Right (p1:p) + + chain _ l = l diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 7530bfb9..896bafde 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- Orphan Traced instances for Segment Closed R2 and FixedSegment R2. +-- Orphan Traced instances for Segment Closed V2 and FixedSegment V2. -- They can't go in Traced; but they shouldn't really go in -- Diagrams.Segment either because we only have Traced instances for -- the special case of R2. @@ -20,93 +22,330 @@ -- ----------------------------------------------------------------------------- -module Diagrams.TwoD.Segment where +module Diagrams.TwoD.Segment + ( -- * Segment intersections -import Control.Applicative (liftA2) -import Control.Lens ((^.)) + intersectPointsS + , intersectPointsS' + + -- * Closest point on a segment + + , closestPoint + , closestPoint' + , closestDistance + , closestDistance' + , closestParam + , closestParam' + + -- ** Low level functions + , segmentSegment + , lineSegment + ) + where + +import Control.Lens hiding (at, contains, transform, ( # )) +import Data.Maybe import Diagrams.Core -import Diagrams.Angle +import Diagrams.Direction import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment -import Diagrams.Solve +import Diagrams.TwoD.Points +import Diagrams.TwoD.Segment.Bernstein import Diagrams.TwoD.Transform -import Diagrams.TwoD.Types +import Diagrams.TwoD.Types hiding (p2) import Diagrams.TwoD.Vector -import Diagrams.Util import Linear.Affine import Linear.Metric -import Linear.Vector {- All instances of Traced should maintain the invariant that the list of traces is sorted in increasing order. -} -instance RealFloat n => Traced (Segment Closed V2 n) where +instance OrderedField n => Traced (Segment Closed V2 n) where getTrace = getTrace . mkFixedSeg . (`at` origin) -instance RealFloat n => Traced (FixedSegment V2 n) where +instance OrderedField n => Traced (FixedSegment V2 n) where + getTrace seg = mkTrace $ \p v -> + mkSortedList . map (view _1) $ lineSegment defEps (v `at` p) seg -{- Given lines defined by p0 + t0 * v0 and p1 + t1 * v1, their point of - intersection in 2D is given by +defEps :: Fractional n => n +defEps = 1e-8 - t_i = (v_(1-i)^ . (p1 - p0)) / (v1^ . v0) +-- | Compute the intersections between two fixed segments. +intersectPointsS :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] +intersectPointsS = intersectPointsS' defEps - where v^ denotes the perpendicular to v, i.e. v rotated by - -tau/4. +-- | Compute the intersections between two segments using the given tolerance. +intersectPointsS' :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [P2 n] +intersectPointsS' eps s1 s2 = map (view _3) $ segmentSegment eps s1 s2 - This can be derived by starting with the parametric equation +-- | Get the closest distance(s) from a point to a 'FixedSegment'. +closestDistance :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] +closestDistance = closestDistance' defEps - p0 + v0 t0 = p1 + v1 t1 +-- | Get the closest distance(s) from a point to a 'FixedSegment' within given +-- tolerance. +closestDistance' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] +closestDistance' eps seg p = map (distanceA p) $ closestPoint' eps seg p - and rearranging to get the matrix equation +-- | Get the closest point(s) on a 'FixedSegment' from a point. +closestPoint :: OrderedField n => FixedSegment V2 n -> P2 n -> [P2 n] +closestPoint = closestPoint' defEps - [v0 -v1] [ t0 ] = (p1 - p0) - [ t1 ] +-- | Get the closest point(s) on a 'FixedSegment' from a point within given +-- tolerance. +closestPoint' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [P2 n] +closestPoint' eps seg = map (seg `atParam`) . closestParam' eps seg - Working out the product of the inverse of [v0 -v1] with (p1 - p0) - results in the above formulas for t_i. --} +-- | Find the closest value(s) on the Bêzier to the given point. +closestParam :: OrderedField n => FixedSegment V2 n -> P2 n -> [n] +closestParam = closestParam' defEps - getTrace (FLinear p0 p0') = mkTrace $ \p1 v1 -> - let - v0 = p0' .-. p0 - det = perp v1 `dot` v0 - p = p1 .-. p0 - t0 = (perp v1 `dot` p) / det - t1 = (perp v0 `dot` p) / det - in - mkSortedList $ - if det == 0 || t0 < 0 || t0 > 1 - then [] - else [t1] - -{- To do intersection of a line with a cubic Bezier, we first rotate - and scale everything so that the line has parameters (origin, unitX); - then we find the intersection(s) of the Bezier with the x-axis. - - XXX could we speed this up by first checking whether all the - control point y-coordinates lie on the same side of the x-axis (if so, - there can't possibly be any intersections)? Need to set up some - benchmarks. --} +-- | Find the closest value(s) on the Bêzier to the given point within given +-- tolerance. +closestParam' :: OrderedField n => n -> FixedSegment V2 n -> P2 n -> [n] +closestParam' _ (FLinear p0 p1) p + | t < 0 = [0] + | t > 1 = [1] + | otherwise = [t] + where + vp = p .-. p0 + v = p1 .-. p0 + dp = vp `dot` v + t = dp / quadrance v +closestParam' eps cb (P (V2 px py)) = bezierFindRoot eps poly 0 1 + where + (bx, by) = bezierToBernstein cb + bx' = bernsteinDeriv bx + by' = bernsteinDeriv by + poly = (bx - listToBernstein [px, px, px, px]) * bx' + + (by - listToBernstein [py, py, py, py]) * by' + +------------------------------------------------------------------------ +-- Low level +------------------------------------------------------------------------ + +-- | Return the intersection points with the parameters at which each segment +-- intersects. +segmentSegment :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n, P2 n)] +segmentSegment eps s1 s2 = + case (s1,s2) of + (FCubic{}, FCubic{}) -> map (\(t1,t2) -> (t1,t2, s1 `atParam` t1)) + $ bezierClip eps s1 s2 + (FCubic{}, FLinear{}) -> map flip12 $ linearSeg (segLine s2) s1 + _ -> linearSeg (segLine s1) s2 -- s1 is linear + where + linearSeg l s = filter (inRange . view _1) $ lineSegment eps l s + flip12 (a,b,c) = (b,a,c) + +-- | Return the intersection points with the parameters at which the line and segment +-- intersect. +lineSegment :: OrderedField n => n -> Located (V2 n) -> FixedSegment V2 n -> [(n, n, P2 n)] +lineSegment _ l1 p@(FLinear p0 p1) + = map (\(tl,tp) -> (tl, tp, p `atParam` tp)) + . filter (inRange . snd) . maybeToList $ lineLine l1 (mkLine p0 p1) +lineSegment eps (viewLoc -> (p,r)) cb = map addPoint params + where + params = bezierFindRoot eps (listToBernstein $ cb' ^.. each . _y) 0 1 + cb' = transform (inv (rotationTo $ dir r)) . moveOriginTo p $ cb + -- + addPoint bt = (lt, bt, intersect) + where + intersect = cb `atParam` bt + lt = (cb' `atParam` bt) ^. _x / norm r + +-- Adapted from from kuribas's cubicbezier package https://github.com/kuribas/cubicbezier + +-- | Use the Bêzier clipping algorithm to return the parameters at which the +-- Bêzier curves intersect. +bezierClip :: OrderedField n => n -> FixedSegment V2 n -> FixedSegment V2 n -> [(n, n)] +bezierClip eps p_ q_ = filter (allOf both inRange) -- sometimes this returns NaN + $ go p_ q_ 0 1 0 1 0 False + where + go p q tmin tmax umin umax clip revCurves + | isNothing chopInterval = [] + + -- split the curve if there isn't enough reduction + | clip > 0.8 && clip' > 0.8 = + if tmax' - tmin' > umax - umin -- split the longest segment + then let (pl, pr) = p' `splitAtParam` 0.5 + tmid = avg tmin' tmax' + in go q pl umin umax tmin' tmid clip' (not revCurves) ++ + go q pr umin umax tmid tmax' clip' (not revCurves) + else let (ql, qr) = q `splitAtParam` 0.5 + umid = avg umin umax + in go ql p' umin umid tmin' tmax' clip' (not revCurves) ++ + go qr p' umid umax tmin' tmax' clip' (not revCurves) + + | max (umax - umin) (tmax' - tmin') < eps = + if revCurves -- return parameters in correct order + then [ (avg umin umax, avg tmin' tmax') ] + else [ (avg tmin' tmax', avg umin umax ) ] + + -- iterate with the curves reversed. + | otherwise = go q p' umin umax tmin' tmax' clip' (not revCurves) + where + chopInterval = chopCubics p q + Just (tminChop, tmaxChop) = chopInterval + p' = section p tminChop tmaxChop + clip' = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) + +-- | Find the zero of a 1D Bêzier curve of any degree. Note that this +-- can be used as a Bernstein polynomial root solver by converting from +-- the power basis to the Bernstein basis. +bezierFindRoot :: OrderedField n + => n -- ^ The accuracy + -> BernsteinPoly n -- ^ the Bernstein coefficients of the polynomial + -> n -- ^ The lower bound of the interval + -> n -- ^ The upper bound of the interval + -> [n] -- ^ The roots found +bezierFindRoot eps p tmin tmax + | isNothing chopInterval = [] + | clip > 0.8 = let (p1, p2) = splitAtParam newP 0.5 + tmid = tmin' + (tmax' - tmin') / 2 + in bezierFindRoot eps p1 tmin' tmid ++ + bezierFindRoot eps p2 tmid tmax' + | tmax' - tmin' < eps = [avg tmin' tmax'] + | otherwise = bezierFindRoot eps newP tmin' tmax' + where + chopInterval = chopYs (bernsteinCoeffs p) + Just (tminChop, tmaxChop) = chopInterval + newP = section p tminChop tmaxChop + clip = tmaxChop - tminChop + tmin' = tmax * tminChop + tmin * (1 - tminChop) + tmax' = tmax * tmaxChop + tmin * (1 - tmaxChop) + + + +------------------------------------------------------------------------ +-- Internal +------------------------------------------------------------------------ + +-- | An approximation of the fat line for a cubic Bêzier segment. Returns +-- @(0,0)@ for a linear segment. +fatLine :: OrderedField n => FixedSegment V2 n -> (n,n) +fatLine (FCubic p0 p1 p2 p3) + = case (d1 > 0, d2 > 0) of + (True, True) -> (0, 0.75 * max d1 d2) + (False, False) -> (0.75 * min d1 d2, 0 ) + (True, False) -> (4/9 * d2, 4/9 * d1 ) + (False, True) -> (4/9 * d1, 4/9 * d2 ) + where + d = lineDistance p0 p3 + d1 = d p1; d2 = d p2 +fatLine _ = (0,0) + +chopYs :: OrderedField n => [n] -> Maybe (n, n) +chopYs ds = chopHull 0 0 points + where + points = zipWith mkP2 [fromIntegral i / fromIntegral n | i <- [0..n]] ds + n = length ds - 1 + +chopCubics :: OrderedField n => FixedSegment V2 n -> FixedSegment V2 n -> Maybe (n,n) +chopCubics p q@(FCubic q0 _ _ q3) + = chopHull dmin dmax dps + where + dps = zipWith mkP2 [0, 1/3, 2/3, 1] ds + ds = p ^.. each . to d + d = lineDistance q0 q3 + -- + (dmin,dmax) = fatLine q +chopCubics _ _ = Nothing + +-- Reduce the interval which the intersection is known to lie in using the fat +-- line of one curve and convex hull of the points formed from the distance to +-- the thin line of the other +chopHull :: OrderedField n => n -> n -> [P2 n] -> Maybe (n, n) +chopHull dmin dmax dps = do + tL <- testBelow upper $ testBetween (head upper) $ testAbove lower + tR <- testBelow (reverse upper) $ testBetween (last upper) $ testAbove (reverse lower) + Just (tL, tR) + where + (upper, lower) = sortedConvexHull dps + + testBelow (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) continue + | y1 >= dmin = continue + | y1 > y2 = Nothing + | y2 < dmin = testBelow (p2:ps) continue + | otherwise = Just $ intersectPt dmin p1 p2 + testBelow _ _ = Nothing + + testBetween (P (V2 x y)) continue + | y <= dmax = Just x + | otherwise = continue + + testAbove (p1@(P (V2 _ y1)) : p2@(P (V2 _ y2)) : ps) + | y1 < y2 = Nothing + | y2 > dmax = testAbove (p2:ps) + | otherwise = Just $ intersectPt dmax p1 p2 + testAbove _ = Nothing + +bezierToBernstein :: Fractional n => FixedSegment V2 n -> (BernsteinPoly n, BernsteinPoly n) +bezierToBernstein seg = + (listToBernstein $ map (view _x) coeffs, listToBernstein $ map (view _y) coeffs) + where coeffs = toListOf each seg + +------------------------------------------------------------------------ +-- Lines +------------------------------------------------------------------------ + +-- Could split this into a separate module. + +-- | Returns @(a, b, c)@ such that @ax + by + c = 0@ is the line going through +-- @p1@ and @p2@ with @a^2 + b^2 = 1@. +lineEquation :: Floating n => P2 n -> P2 n -> (n, n, n) +lineEquation (P (V2 x1 y1)) (P (V2 x2 y2)) = (a, b, c) + where + a = a' / d + b = b' / d + c = -(x1*a' + y1*b') / d + a' = y1 - y2 + b' = x2 - x1 + d = sqrt $ a'*a' + b'*b' + +-- | Return the distance from a point to the line. +lineDistance :: Floating n => P2 n -> P2 n -> P2 n -> n +lineDistance p1 p2 (P (V2 x y)) = a*x + b*y + c + where (a, b, c) = lineEquation p1 p2 + +-- find the x value where the line through the two points +-- intersect the line y=d +intersectPt :: OrderedField n => n -> P2 n -> P2 n -> n +intersectPt d (P (V2 x1 y1)) (P (V2 x2 y2)) = + x1 + (d - y1) * (x2 - x1) / (y2 - y1) + +-- clockwise :: (Num n, Ord n) => V2 n -> V2 n -> Bool +-- clockwise a b = a `cross2` b <= 0 + +avg :: Fractional n => n -> n -> n +avg a b = (a + b)/2 + +lineLine :: (Fractional n, Eq n) => Located (V2 n) -> Located (V2 n) -> Maybe (n,n) +lineLine (viewLoc -> (p,r)) (viewLoc -> (q,s)) + | x1 == 0 && x2 /= 0 = Nothing -- parallel + | otherwise = Just (x3 / x1, x2 / x1) -- intersecting or collinear + where + x1 = r × s + x2 = v × r + x3 = v × s + v = q .-. p + +(×) :: Num n => V2 n -> V2 n -> n +(×) = cross2 + +mkLine :: InSpace v n (v n) => Point v n -> Point v n -> Located (v n) +mkLine p0 p1 = (p1 .-. p0) `at` p0 + +segLine :: InSpace v n (v n) => FixedSegment v n -> Located (v n) +segLine (FLinear p0 p1) = mkLine p0 p1 +segLine (FCubic p0 _ _ p3) = mkLine p0 p3 - getTrace bez@(FCubic {}) = mkTrace $ \p1 v1 -> - let - bez'@(FCubic x1 c1 c2 x2) = - bez # moveOriginTo p1 - # rotate (negated (v1^._theta)) - # scale (1/norm v1) - [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] - a = -y0 + 3*y1 - 3*y2 + y3 - b = 3*y0 - 6*y1 + 3*y2 - c = -3*y0 + 3*y1 - d = y0 - ts = filter (liftA2 (&&) (>= 0) (<= 1)) (cubForm a b c d) - xs = map (fst . unp2 . atParam bez') ts - in - mkSortedList xs +inRange :: (Fractional n, Ord n) => n -> Bool +inRange x = x < (1+defEps) && x > (-defEps) diff --git a/src/Diagrams/TwoD/Segment/Bernstein.hs b/src/Diagrams/TwoD/Segment/Bernstein.hs new file mode 100644 index 00000000..26ba2f58 --- /dev/null +++ b/src/Diagrams/TwoD/Segment/Bernstein.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TypeFamilies #-} + +module Diagrams.TwoD.Segment.Bernstein + ( BernsteinPoly (..) + , listToBernstein + , evaluateBernstein + + , degreeElevate + , bernsteinDeriv + , evaluateBernsteinDerivs + ) where + +import Data.List (tails) +import Diagrams.Core.V +import Diagrams.Parametric +import Linear.V1 + +-- find the binomial coefficients of degree n. +binomials :: Num n => Int -> [n] +binomials n = map fromIntegral $ scanl (\x m -> x * (n - m+1) `quot` m) 1 [1..n] + +data BernsteinPoly n = BernsteinPoly + { bernsteinDegree :: Int + , bernsteinCoeffs :: [n] + } deriving (Show, Functor) + +type instance V (BernsteinPoly n) = V1 +type instance N (BernsteinPoly n) = n +type instance Codomain (BernsteinPoly n) = V1 + +-- | Create a bernstein polynomial from a list of coëfficients. +listToBernstein :: Fractional n => [n] -> BernsteinPoly n +listToBernstein [] = 0 +listToBernstein l = BernsteinPoly (length l - 1) l + +-- | Degree elevate a bernstein polynomial a number of times. +degreeElevate :: Fractional n => BernsteinPoly n -> Int -> BernsteinPoly n +degreeElevate b 0 = b +degreeElevate (BernsteinPoly lp p) times = + degreeElevate (BernsteinPoly (lp+1) (head p:inner p 1)) (times-1) + where + n = fromIntegral lp + + inner [] _ = [0] + inner [a] _ = [a] + inner (a:b:rest) i = (i*a/(n+1) + b*(1 - i/(n+1))) : inner (b:rest) (i+1) + +-- | Evaluate the bernstein polynomial. +evaluateBernstein :: Fractional n => BernsteinPoly n -> n -> n +evaluateBernstein (BernsteinPoly _ []) _ = 0 +evaluateBernstein (BernsteinPoly _ [b]) _ = b +evaluateBernstein (BernsteinPoly lp (b':bs)) t = go t n (b'*u) 2 bs + where + u = 1-t + n = fromIntegral lp + + go tn bc tmp _ [b] = tmp + tn*bc*b + go tn bc tmp i (b:rest) = + go (tn*t) -- tn + (bc*(n - i+1)/i) -- bc + ((tmp + tn*bc*b)*u) -- tmp + (i+1) -- i + rest + go _ _ _ _ [] = error "evaluateBernstein: impossible" + +-- | Evaluate the bernstein polynomial and its derivatives. +evaluateBernsteinDerivs :: Fractional n => BernsteinPoly n -> n -> [n] +evaluateBernsteinDerivs b t + | bernsteinDegree b == 0 = [evaluateBernstein b t] + | otherwise = evaluateBernstein b t : evaluateBernsteinDerivs (bernsteinDeriv b) t + +-- | Find the derivative of a bernstein polynomial. +bernsteinDeriv :: Fractional n => BernsteinPoly n -> BernsteinPoly n +bernsteinDeriv (BernsteinPoly 0 _) = 0 +bernsteinDeriv (BernsteinPoly lp p) = + -- BernsteinPoly (lp-1) $ map (* fromIntegral lp) $ zipWith (-) (tail p) p + BernsteinPoly (lp-1) $ zipWith (\a b -> (a - b) * fromIntegral lp) (tail p) p + +instance Fractional n => Parametric (BernsteinPoly n) where + atParam b = V1 . evaluateBernstein b +instance Num n => DomainBounds (BernsteinPoly n) +instance Fractional n => EndValues (BernsteinPoly n) +instance Fractional n => Sectionable (BernsteinPoly n) where + splitAtParam = bernsteinSplit + reverseDomain (BernsteinPoly i xs) = BernsteinPoly i (reverse xs) + +-- | Split a bernstein polynomial +bernsteinSplit :: Num n => BernsteinPoly n -> n -> (BernsteinPoly n, BernsteinPoly n) +bernsteinSplit (BernsteinPoly lp p) t = + (BernsteinPoly lp $ map head controls, + BernsteinPoly lp $ reverse $ map last controls) + where + interp a b = (1-t)*a + t*b + + terp [_] = [] + terp l = let ctrs = zipWith interp l (tail l) + in ctrs : terp ctrs + controls = p : terp p + +instance Fractional n => Num (BernsteinPoly n) where + ba@(BernsteinPoly la a) + bb@(BernsteinPoly lb b) + | la < lb = BernsteinPoly lb $ zipWith (+) (bernsteinCoeffs $ degreeElevate ba $ lb - la) b + | la > lb = BernsteinPoly la $ zipWith (+) a (bernsteinCoeffs $ degreeElevate bb $ la - lb) + | otherwise = BernsteinPoly la $ zipWith (+) a b + + ba@(BernsteinPoly la a) - bb@(BernsteinPoly lb b) + | la < lb = BernsteinPoly lb $ zipWith (-) (bernsteinCoeffs $ degreeElevate ba (lb - la)) b + | la > lb = BernsteinPoly la $ zipWith (-) a (bernsteinCoeffs $ degreeElevate bb (la - lb)) + | otherwise = BernsteinPoly la $ zipWith (-) a b + + (BernsteinPoly la a) * (BernsteinPoly lb b) = + BernsteinPoly (la+lb) $ + zipWith (flip (/)) (binomials (la + lb)) $ + init $ map sum $ + map (zipWith (*) a') (down b') ++ + map (zipWith (*) (reverse b')) (tail $ tails a') + -- zipWith (zipWith (*)) (tail $ tails a') (repeat $ reverse b') + where down l = tail $ scanl (flip (:)) [] l -- [[1], [2, 1], [3, 2, 1], ... + a' = zipWith (*) a (binomials la) + b' = zipWith (*) b (binomials lb) + + fromInteger a = BernsteinPoly 0 [fromInteger a] + + signum (BernsteinPoly _ []) = 0 + signum (BernsteinPoly _ (a:_)) = BernsteinPoly 0 [signum a] + + abs = fmap abs + + diff --git a/src/Diagrams/TwoD/Size.hs b/src/Diagrams/TwoD/Size.hs index baddaaf0..ab11013a 100644 --- a/src/Diagrams/TwoD/Size.hs +++ b/src/Diagrams/TwoD/Size.hs @@ -76,5 +76,3 @@ mkWidth w = dims (V2 w 0) mkHeight :: Num n => n -> SizeSpec V2 n mkHeight h = dims (V2 0 h) - - diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index b89bede3..224cb100 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -65,8 +65,6 @@ import Data.Semigroup import Linear.Affine import Linear.Vector -type T2 = Transformation V2 - -- Rotation ------------------------------------------------ -- | Create a transformation which performs a rotation about the local diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 510a2c2d..6de97ce3 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -15,7 +15,8 @@ module Diagrams.TwoD.Types ( -- * 2D Euclidean space - V2 (..), P2, R1 (..), R2 (..) + V2 (..), R1 (..), R2 (..) + , P2, T2 , r2, unr2, mkR2, r2Iso , p2, mkP2, unp2, p2Iso , r2polarIso @@ -33,6 +34,7 @@ import Linear.Metric import Linear.V2 type P2 = Point V2 +type T2 = Transformation V2 type instance V (V2 n) = V2 type instance N (V2 n) = n diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index b1b70230..eb2e0dce 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -17,7 +17,7 @@ module Diagrams.TwoD.Vector , e, xDir, angleDir -- * 2D vector utilities - , perp, leftTurn + , perp, leftTurn, cross2 ) where import Control.Lens (view, (&), (.~)) @@ -64,3 +64,7 @@ angleDir = dir . e leftTurn :: (Num n, Ord n) => V2 n -> V2 n -> Bool leftTurn v1 v2 = (v1 `dot` perp v2) < 0 +-- | Cross product on vectors in R2. +cross2 :: Num n => V2 n -> V2 n -> n +cross2 (V2 x1 y1) (V2 x2 y2) = x1 * y2 - y1 * x2 +