From 2d1828896a0d14fcb9dd0c2f9589dcbb8e102527 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:01:26 +0000 Subject: [PATCH 01/22] Add Direction type --- src/Diagrams/Direction.hs | 54 +++++++++++++++++++++++++++++++++++++++ src/Diagrams/Prelude.hs | 3 +++ 2 files changed, 57 insertions(+) create mode 100644 src/Diagrams/Direction.hs diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs new file mode 100644 index 00000000..97833b61 --- /dev/null +++ b/src/Diagrams/Direction.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +----------------------------------------------------------------------------- +-- | +-- Module : Diagrams.Angle +-- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- License : BSD-style (see LICENSE) +-- Maintainer : diagrams-discuss@googlegroups.com +-- +-- Type for representing directions, polymorphic in vector space +-- +----------------------------------------------------------------------------- + +module Diagrams.Direction + ( Direction + , _Dir + , direction, fromDirection + ) where + +import Control.Lens +import Data.AffineSpace +import Data.VectorSpace + +import Diagrams.Angle + +-------------------------------------------------------------------------------- +-- Direction + +-- | A vector is described by a @Direction@ and a magnitude. So we +-- can think of a @Direction@ as a vector that has forgotten its +-- magnitude. @Direction@s can be used with 'fromDirection' and the +-- lenses provided by its instances. +data Direction v = Direction v + +-- | _Dir is provided to allow efficient implementations of functions +-- in particular vector-spaces, but should be used with care as it +-- exposes too much information. +_Dir :: Iso' (Direction v) v +_Dir = iso (\(Direction v) -> v) Direction + +-- | @direction v@ is the direction in which @v@ points. Returns an +-- unspecified value when given the zero vector as input. +direction :: v -> Direction v +direction = Direction + +-- | @fromDirection d@ is the unit vector in the direction @d@. +fromDirection :: (InnerSpace v, Floating (Scalar v)) => Direction v -> v +fromDirection (Direction v) = normalized v + +-- | compute the positive angle between the two directions in their common plane +angleBetweenDirs :: (InnerSpace v, Scalar v ~ Double) => + Direction v -> Direction v -> Angle +angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/Prelude.hs b/src/Diagrams/Prelude.hs index ad0ccd53..3a28d131 100644 --- a/src/Diagrams/Prelude.hs +++ b/src/Diagrams/Prelude.hs @@ -88,6 +88,8 @@ module Diagrams.Prelude , module Diagrams.Angle -- | Convenience infix operators for working with coordinates. , module Diagrams.Coordinates + -- | Directions, distinguished from angles or vectors + , module Diagrams.Direction -- | A wide range of things (shapes, transformations, -- combinators) specific to creating two-dimensional @@ -132,6 +134,7 @@ import Diagrams.Combinators import Diagrams.Coordinates import Diagrams.CubicSpline import Diagrams.Deform +import Diagrams.Direction import Diagrams.Envelope import Diagrams.Located import Diagrams.Names From a7c3b0f6c6359db44daddd762869a9d7aba691e3 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:01:47 +0000 Subject: [PATCH 02/22] Add Semigroup and Monoid instances for Angle --- src/Diagrams/Angle.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index add94628..2c8d916a 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -23,16 +23,24 @@ module Diagrams.Angle , HasTheta(..) ) where -import Control.Lens (Iso', Lens', iso, review, (^.)) - -- , review , (^.), _1, _2, Lens', lens) +import Control.Lens (Iso', Lens', iso, review, (^.)) -import Data.VectorSpace +import Data.Monoid hiding ((<>)) +import Data.Semigroup +import Data.VectorSpace -- | Angles can be expressed in a variety of units. Internally, -- they are represented in radians. newtype Angle = Radians Double deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) +instance Semigroup Angle where + (<>) = (^+^) + +instance Monoid Angle where + mappend = (<>) + mempty = Radians 0 + instance VectorSpace Angle where type Scalar Angle = Double s *^ Radians t = Radians (s*t) From 8d365fba9f9be71bdee21c12b62df9df372de945 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:02:19 +0000 Subject: [PATCH 03/22] Remove old direction functions operating on Angles --- src/Diagrams/TwoD.hs | 1 - src/Diagrams/TwoD/Vector.hs | 37 ++++++++++++++++++++----------------- 2 files changed, 20 insertions(+), 18 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index c899512c..b68ec360 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -65,7 +65,6 @@ module Diagrams.TwoD , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y - , direction, fromDirection -- * Angles , tau diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 4c3ecc85..16d8847d 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Diagrams.TwoD.Vector @@ -16,16 +17,18 @@ module Diagrams.TwoD.Vector unitX, unitY, unit_X, unit_Y -- * Converting between vectors and angles - , direction, angleBetween, fromDirection, e + , e, xDir -- * 2D vector utilities , perp, leftTurn ) where -import Control.Lens ((^.)) -import Data.VectorSpace ((<.>)) +import Control.Lens ((^.), (&), (<>~)) +import Data.VectorSpace +import Data.AffineSpace import Diagrams.Angle +import Diagrams.Direction import Diagrams.TwoD.Types import Diagrams.Coordinates @@ -45,20 +48,20 @@ unit_X = (-1) ^& 0 unit_Y :: R2 unit_Y = 0 ^& (-1) --- | Compute the direction of a vector, measured counterclockwise from --- the positive x-axis as a fraction of a full turn. The zero --- vector is arbitrarily assigned the direction 0. -direction :: R2 -> Angle -direction (coords -> x :& y) = atan2 y x @@ rad +instance AffineSpace (Direction R2) where + type Diff (Direction R2) = Angle + a .-. b = a^._theta ^-^ b^._theta + a .+^ θ = a & _theta <>~ θ --- | Convert an angle into a unit vector pointing in that direction. -fromDirection :: Angle -> R2 -fromDirection a = cos a' ^& sin a' - where a' = a^.rad +-- | The origin of the direction AffineSpace. For all d, @d .-. xDir +-- = d^._theta@. +xDir :: Direction R2 +xDir = direction unitX --- | A convenient synonym for 'fromDirection'. +-- | A unit vector at a specified angle counterclockwise from the +-- positive X axis. e :: Angle -> R2 -e = fromDirection +e = fromDirection . (xDir .+^) -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. From 9d4794efe90ed211c8bd889e2e93f5cd8cf9158d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:02:45 +0000 Subject: [PATCH 04/22] Update arrow code to use Direction --- src/Diagrams/TwoD/Arrow.hs | 19 ++++++++++--------- src/Diagrams/TwoD/Arrowheads.hs | 31 ++++++++++++++++--------------- 2 files changed, 26 insertions(+), 24 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 45ec9769..38688f7b 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -101,8 +101,8 @@ module Diagrams.TwoD.Arrow import Control.Applicative ((<*>)) import Control.Lens (Lens', Setter', Traversal', generateSignatures, lensRules, - makeLensesWith, (%~), (&), (.~), - (^.)) + makeLensesWith, view, (%~), (&), + (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Functor ((<$>)) @@ -117,6 +117,7 @@ import Diagrams.Core.Types (QDiaLeaf (..), mkQD') import Diagrams.Angle import Diagrams.Attributes +import Diagrams.Direction import Diagrams.Parametric import Diagrams.Path import Diagrams.Solve (quadForm) @@ -127,7 +128,7 @@ import Diagrams.TwoD.Attributes import Diagrams.TwoD.Path (stroke, strokeT) import Diagrams.TwoD.Transform (rotate, translateX) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction, unitX, unit_X) +import Diagrams.TwoD.Vector (unitX, unit_X) import Diagrams.Util (( # )) data ArrowOpts @@ -355,7 +356,7 @@ scaleFactor tr tw hw t arrowEnv :: ArrowOpts -> Double -> Envelope R2 arrowEnv opts len = getEnvelope horizShaft where - horizShaft = shaft # rotate (negateV direction v) # scale (len / m) + horizShaft = shaft # rotate (negateV v ^. _theta) # scale (len / m) m = magnitude v v = trailOffset shaft shaft = opts ^. arrowShaft @@ -394,7 +395,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) - # rotate (direction (q .-. p) ^-^ dir) + # rotate (angleBetween (q .-. p) (fromDirection dir)) # moveTo p where @@ -425,7 +426,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) shaftTrail = rawShaftTrail -- rotate it so it is pointing in the positive X direction - # rotate (negateV direction (trailOffset rawShaftTrail)) + # rotate (negateV . view _theta . trailOffset $ rawShaftTrail) -- apply the context transformation -- in case it includes -- things like flips and shears (the possibility of shears -- is why we must rotate it to a neutral position first) @@ -436,8 +437,8 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) hWidth = hWidth' + hGap -- Calculate the angles that the head and tail should point. - tAngle = direction . tangentAtStart $ shaftTrail - hAngle = direction . tangentAtEnd $ shaftTrail + tAngle = tangentAtStart shaftTrail ^. _theta + hAngle = tangentAtEnd shaftTrail ^. _theta -- Calculte the scaling factor to apply to the shaft shaftTrail so that the entire -- arrow will be of length len. Then apply it to the shaft and make the @@ -481,7 +482,7 @@ arrowAt' opts s v = arrow' opts len # rotate dir # moveTo s where len = magnitude v - dir = direction v + dir = v ^. _theta -- | @arrowV v@ creates an arrow with the direction and magnitude of -- the vector @v@ (with its tail at the origin), using default diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index c3756a2b..9c9bf971 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -54,7 +54,7 @@ module Diagrams.TwoD.Arrowheads , ArrowHT ) where -import Control.Lens ((&), (.~), (^.)) +import Control.Lens ((&), (.~), (^.), (%~), (-~), (+~)) import Data.AffineSpace import Data.Default.Class import Data.Monoid (mempty, (<>)) @@ -64,6 +64,7 @@ import Diagrams.Angle import Diagrams.Core import Diagrams.Coordinates ((^&)) +import Diagrams.Direction import Diagrams.Path import Diagrams.Segment import Diagrams.Trail @@ -75,7 +76,7 @@ import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (fromDirection, direction, unit_X) +import Diagrams.TwoD.Vector (e, unitX, unit_X, xDir) import Diagrams.Util (( # )) ----------------------------------------------------------------------------- @@ -115,10 +116,10 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] - v = fromDirection theta + v = e theta (t1, t2) = (unit_X ^+^ v, (-0.5 ^& 0) ^-^ v) [b1, b2] = map (reflectY . negateV) [t1, t2] - psi = pi - (direction . negateV $ t2) ^. rad + psi = pi - (direction . negateV $ t2) ^. _theta.rad jLength = shaftWidth / (2 * tan psi) -- If the shaft if too wide, set the size to a default value of 1. @@ -130,11 +131,11 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 jt = alignR . centerY . pathFromTrail - . closeTrail $ arc' 1 (negateV phi) phi + . closeTrail $ arc' 1 (xDir .-^ phi) (2 *^ phi) l1 = trailFromSegments [straight $ unit_X ^+^ v] l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ (reflectY v))] - c = reflectX $ arc' 1 theta (negateV theta) - v = fromDirection theta + c = reflectX $ arc' 1 (xDir .+^ theta) ((-2) *^ theta) + v = e theta -- The length of the head without its joint is, -2r cos theta and -- the length of the joint is r - sqrt (r^2 - y^2). So the total @@ -149,7 +150,7 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) -- 2/3 * len by setting d=1 and phi=pi/2. d = max 1 (len**2 + (1 - a**2) * y**2) r = (a * len + sqrt d) / (a**2 -1) - phi = asin (min 1 (y/r)) @@ rad + phi = asinA (min 1 (y/r)) -- | Curved sides, linear concave base. Illustrator CS5 #3 arrowheadThorn :: Angle -> ArrowHT @@ -160,13 +161,13 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] c = curvedSide theta - v = fromDirection theta + v = e theta l = reverseSegment . straight $ t t = v ^-^ (-0.5 ^& 0) - psi = pi - (direction . negateV $ t) ^. rad - jLength = shaftWidth / (2 * tan psi) + psi = fullTurn ^/ 2 ^-^ (negateV t ^. _theta) + jLength = shaftWidth / (2 * tanA psi) - -- If the shaft if too wide, set the size to a default value of 1. + -- If the shaft if too wide, set the size to a default value of 1. size = max 1 ((len - jLength) / (1.5)) -- | Make a side for the thorn head. @@ -174,7 +175,7 @@ curvedSide :: Angle -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X - v1 = fromDirection theta + v1 = e theta ctrl1 = v0 ctrl2 = v0 ^+^ v1 end = v0 ^+^ v1 @@ -233,7 +234,7 @@ arrowtailBlock theta = aTail aTail len _ = (t, mempty) where t = rect len (len * x) # alignR - a' = fromDirection theta + a' = e theta a = a' ^-^ (reflectY a') x = magnitude a @@ -247,7 +248,7 @@ arrowtailQuill theta = aTail # scale size # alignR size = len / 0.6 v0 = p2 (0.5, 0) - v2 = p2 (unr2 $ fromDirection theta # scale 0.5) + v2 = origin .+^ (e theta # scale 0.5) v1 = v2 # translateX (5/8) v3 = p2 (-0.1, 0) v4 = v2 # reflectY From b3c3b8fec6f4650462b0148b82498de0b7a01f6f Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:02:56 +0000 Subject: [PATCH 05/22] Change Arc code to use a Direction and a sweep Angle --- src/Diagrams/TwoD/Arc.hs | 110 +++++++++++++++++++-------------------- 1 file changed, 54 insertions(+), 56 deletions(-) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 84aac3a5..cb70d73e 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -24,6 +24,7 @@ module Diagrams.TwoD.Arc ) where import Diagrams.Angle +import Diagrams.Direction import Diagrams.Core import Diagrams.Located (at) import Diagrams.Segment @@ -31,11 +32,11 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction, e, unitX) +import Diagrams.TwoD.Vector (e, unitX, unitY, unit_Y, xDir) import Diagrams.Util (( # )) import Control.Lens ((^.)) -import Data.AffineSpace ((.-.)) +import Data.AffineSpace import Data.Semigroup ((<>)) import Data.VectorSpace import Diagrams.Coordinates @@ -44,9 +45,9 @@ import Diagrams.Coordinates -- http://www.tinaja.com/glib/bezcirc2.pdf -- | @bezierFromSweepQ1 s@ constructs a 'Cubic' segment that starts in --- the positive y direction and sweeps counterclockwise through @s@ --- radians. The approximation is only valid for angles in the first --- quadrant. +-- the positive y direction and sweeps counterclockwise through an +-- angle @s@. The approximation is only valid for angles in the +-- first quadrant. bezierFromSweepQ1 :: Angle -> Segment Closed R2 bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 where p0@(coords -> x :& y) = rotate (s ^/ 2) v @@ -89,42 +90,37 @@ across a situation with large enough arcs that they can actually see the approximation error. -} --- | Given a start angle @s@ and an end angle @e@, @'arcT' s e@ is the --- 'Trail' of a radius one arc counterclockwise between the two angles. -arcT :: Angle -> Angle -> Trail R2 -arcT start end - | end' < start' = arcT start (end ^+^ (fromIntegral d @@ turn)) +-- | Given a start direction @d@ and a sweep angle @s@, @'arcT' d s@ +-- is the 'Trail' of a radius one arc starting at d and sweeping out +-- the angle @s@ counterclockwise. +arcT :: Direction R2 -> Angle -> Trail R2 +arcT start sweep + | sweep < zeroV = arcT start (sweep ^-^ (fromIntegral d @@ turn)) | otherwise = (if sweep >= fullTurn then glueTrail else id) $ trailFromSegments bs - where sweep = end ^-^ start - bs = map (rotate start) . bezierFromSweep $ sweep - - -- We want to compare the start and the end and in case - -- there isn't some law about 'Angle' ordering, we use a - -- known 'Angle' for that. - start' = start^.turn - end' = end^.turn - d = ceiling (start' - end') :: Integer - --- | Given a start angle @s@ and an end angle @e@, @'arc' s e@ is the --- path of a radius one arc counterclockwise between the two angles. --- The origin of the arc is its center. -arc :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t -arc start end = trailLike $ arcT start end `at` (rotate start $ p2 (1,0)) + where end = start .+^ sweep + bs = map (rotate $ start .-. xDir) . bezierFromSweep $ sweep + d = floor (sweep^.turn) :: Integer + +-- | Given a start angle @d@ and a sweep angle @s@, @'arc' d s@ is the +-- path of a radius one arc starting at d and sweeping out the angle +-- @s@ counterclockwise. +arc :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t +arc start sweep = trailLike $ arcT start sweep `at` (rotate (start .-. xDir) $ p2 (1,0)) -- | Like 'arc' but clockwise. -arcCW :: (TrailLike t, V t ~ R2) => Angle -> Angle -> t -arcCW start end = trailLike $ +arcCW :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t +arcCW start sweep = trailLike $ -- flipped arguments to get the path we want -- then reverse the trail to get the cw direction. - (reverseTrail $ arcT end start) + (reverseTrail $ arcT (start .+^ sweep) (negateV sweep)) `at` - (rotate start $ p2 (1,0)) + (rotate (start .-. xDir) $ p2 (1,0)) -- We could just have `arcCW = reversePath . flip arc` -- but that wouldn't be `TrailLike`. --- | Given a radus @r@, a start angle @s@ and an end angle @e@, --- @'arc'' r s e@ is the path of a radius @(abs r)@ arc between +-- | Given a radus @r@, a start direction @d@ and a sweep angle @s@, +-- @'arc'' r d s@ is the path of a radius @(abs r)@ arc between -- the two angles. If a negative radius is given, the arc will -- be clockwise, otherwise it will be counterclockwise. The origin -- of the arc is its center. @@ -133,10 +129,10 @@ arcCW start end = trailLike $ -- -- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 -arc' :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p -arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0)) - where ts | r < 0 = reverseTrail $ arcT end start - | otherwise = arcT start end +arc' :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p +arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start .-. xDir) $ p2 (abs r,0)) + where ts | r < 0 = reverseTrail $ arcT (start .+^ sweep) sweep + | otherwise = arcT start sweep -- | Create a circular wedge of the given radius, beginning at the -- first angle and extending counterclockwise to the second. @@ -150,11 +146,11 @@ arc' r start end = trailLike $ scale (abs r) ts `at` (rotate start $ p2 (abs r,0 -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -wedge :: (TrailLike p, V p ~ R2) => Double -> Angle -> Angle -> p -wedge r a1 a2 = trailLike . (`at` origin) . glueTrail . wrapLine - $ fromOffsets [r *^ e a1] - <> arc a1 a2 # scale r - <> fromOffsets [r *^ negateV (e a2)] +wedge :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p +wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine + $ fromOffsets [r *^ fromDirection d] + <> arc d s # scale r + <> fromOffsets [r *^ negateV (fromDirection (d .+^ s))] -- | @arcBetween p q height@ creates an arc beginning at @p@ and -- ending at @q@, with its midpoint at a distance of @abs height@ @@ -168,29 +164,29 @@ wedge r a1 a2 = trailLike . (`at` origin) . glueTrail . wrapLine -- > [ arcBetween origin (p2 (2,1)) ht | ht <- [-0.2, -0.1 .. 0.2] ] -- > # centerXY # pad 1.1 arcBetween :: (TrailLike t, V t ~ R2) => P2 -> P2 -> Double -> t -arcBetween p q ht = trailLike (a # rotate (direction v) # moveTo p) +arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) where h = abs ht isStraight = h < 0.00001 v = q .-. p d = magnitude (q .-. p) - th = acos ((d*d - 4*h*h)/(d*d + 4*h*h)) - r = d/(2*sin th) - mid | ht >= 0 = fullTurn ^/ 4 - | otherwise = 3 *^ fullTurn ^/ 4 - st = mid ^-^ (th @@ rad) - end = mid ^+^ (th @@ rad) + th = acosA ((d*d - 4*h*h)/(d*d + 4*h*h)) + r = d/(2*sinA th) + mid | ht >= 0 = direction unitY + | otherwise = direction unit_Y + st = mid .-^ th + end = mid .+^ th a | isStraight = fromOffsets [d *^ unitX] | otherwise - = arc st end + = arc st (2 *^ th) # scale r # translateY ((if ht > 0 then negate else id) (r-h)) # translateX (d/2) # (if ht > 0 then reverseLocTrail else id) -- | Create an annular wedge of the given radii, beginning at the --- first angle and extending counterclockwise to the second. +-- first direction and extending counterclockwise to the second. -- The radius of the outer circle is given first. -- -- <> @@ -202,10 +198,12 @@ arcBetween p q ht = trailLike (a # rotate (direction v) # moveTo p) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 -annularWedge :: (TrailLike p, V p ~ R2) => Double -> Double -> Angle -> Angle -> p -annularWedge r1' r2' a1 a2 = trailLike . (`at` o) . glueTrail . wrapLine - $ fromOffsets [(r1'-r2') *^ e a1] - <> arc a1 a2 # scale r1' - <> fromOffsets [(r1'-r2') *^ negateV (e a2)] - <> arcCW a2 a1 # scale r2' - where o = origin # translate (r2' *^ e a1) +annularWedge :: (TrailLike p, V p ~ R2) => + Double -> Double -> Direction R2 -> Angle -> p +annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine + $ fromOffsets [(r1'-r2') *^ fromDirection d1] + <> arc d1 s # scale r1' + <> fromOffsets [(r1'-r2') *^ negateV (fromDirection d2)] + <> arcCW d2 (negateV s) # scale r2' + where o = origin # translate (r2' *^ fromDirection d1) + d2 = d1 .+^ s From e6c1433723fc10d8d7ff1519f7f95b18a8bb1879 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:04:48 +0000 Subject: [PATCH 06/22] Update everything else to use Direction --- src/Diagrams/ThreeD/Camera.hs | 7 +++--- src/Diagrams/ThreeD/Light.hs | 3 ++- src/Diagrams/ThreeD/Transform.hs | 5 ++-- src/Diagrams/ThreeD/Types.hs | 33 +++---------------------- src/Diagrams/TwoD.hs | 2 +- src/Diagrams/TwoD/Combinators.hs | 17 +++++++------ src/Diagrams/TwoD/Ellipse.hs | 3 ++- src/Diagrams/TwoD/Offset.hs | 8 +++--- src/Diagrams/TwoD/Segment.hs | 4 ++- src/Diagrams/TwoD/Shapes.hs | 8 ++++-- src/Diagrams/TwoD/Transform.hs | 5 ++-- src/Diagrams/TwoD/Transform/ScaleInv.hs | 3 ++- src/Diagrams/TwoD/Types.hs | 8 ++++++ 13 files changed, 49 insertions(+), 57 deletions(-) diff --git a/src/Diagrams/ThreeD/Camera.hs b/src/Diagrams/ThreeD/Camera.hs index 11246992..75b55cc6 100644 --- a/src/Diagrams/ThreeD/Camera.hs +++ b/src/Diagrams/ThreeD/Camera.hs @@ -36,6 +36,7 @@ import Data.Typeable import Diagrams.Angle import Diagrams.Core +import Diagrams.Direction import Diagrams.ThreeD.Types import Diagrams.ThreeD.Vector @@ -118,13 +119,13 @@ mm50Wide = PerspectiveLens (43.2 @@ deg) (27 @@ deg) -- aspect ratio of 4:3, for VGA and similar computer resulotions. mm50Narrow = PerspectiveLens (36 @@ deg) (27 @@ deg) -camForward :: Camera l -> Direction +camForward :: Camera l -> Direction R3 camForward = direction . forward -camUp :: Camera l -> Direction +camUp :: Camera l -> Direction R3 camUp = direction . up -camRight :: Camera l -> Direction +camRight :: Camera l -> Direction R3 camRight c = direction right where right = cross3 (forward c) (up c) diff --git a/src/Diagrams/ThreeD/Light.hs b/src/Diagrams/ThreeD/Light.hs index 2333ef2e..28cbfda2 100644 --- a/src/Diagrams/ThreeD/Light.hs +++ b/src/Diagrams/ThreeD/Light.hs @@ -21,6 +21,7 @@ import Data.Monoid import Data.Typeable import Diagrams.Core +import Diagrams.Direction import Diagrams.ThreeD.Types data PointLight = PointLight P3 (Colour Double) @@ -48,7 +49,7 @@ pointLight c = mkQD (Prim $ PointLight origin c) mempty mempty mempty -- | Construct a Diagram with a single ParallelLight, which takes up no space. parallelLight :: (Backend b R3, Renderable ParallelLight b) - => Direction -- ^ The direction in which the light travels. + => Direction R3 -- ^ The direction in which the light travels. -> Colour Double -- ^ The color of the light. -> Diagram b R3 parallelLight d c = mkQD (Prim $ ParallelLight (fromDirection d) c) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 7fff6a8f..7616f394 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -47,6 +47,7 @@ import Diagrams.Core import qualified Diagrams.Core.Transform as T import Diagrams.Angle +import Diagrams.Direction import Diagrams.Transform import Diagrams.ThreeD.Types import Diagrams.Coordinates @@ -104,7 +105,7 @@ aboutY ang = fromLinear r (linv r) where -- passing through @p@. rotationAbout :: P3 -- ^ origin of rotation - -> Direction -- ^ direction of rotation axis + -> Direction R3 -- ^ direction of rotation axis -> Angle -- ^ angle of rotation -> T3 rotationAbout p d a @@ -127,7 +128,7 @@ rotationAbout p d a -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. -pointAt :: Direction -> Direction -> Direction -> T3 +pointAt :: Direction R3 -> Direction R3 -> Direction R3 -> T3 pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors diff --git a/src/Diagrams/ThreeD/Types.hs b/src/Diagrams/ThreeD/Types.hs index 07855025..db6136ee 100644 --- a/src/Diagrams/ThreeD/Types.hs +++ b/src/Diagrams/ThreeD/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -26,8 +25,6 @@ module Diagrams.ThreeD.Types , T3 , r3Iso, p3Iso - -- * Directions in 3D - , Direction, direction, fromDirection, angleBetweenDirs -- * other coördinate systems , Spherical(..), Cylindrical(..), HasPhi(..) ) where @@ -37,6 +34,7 @@ import Control.Lens (Iso', Lens', iso, over import Diagrams.Core import Diagrams.Angle +import Diagrams.Direction import Diagrams.TwoD.Types (R2) import Diagrams.Coordinates @@ -122,18 +120,6 @@ instance Transformable R3 where instance HasCross3 R3 where cross3 u v = r3 $ cross3 (unr3 u) (unr3 v) --------------------------------------------------------------------------------- --- Direction - --- | A @Direction@ represents directions in R3. The constructor is --- not exported; @Direction@s can be used with 'fromDirection' and the --- lenses provided by its instances. -data Direction = Direction R3 - --- | Not exported -_Dir :: Iso' Direction R3 -_Dir = iso (\(Direction v) -> v) Direction - instance HasX R3 where _x = r3Iso . _1 @@ -203,21 +189,8 @@ instance Cylindrical P3 where instance Spherical P3 where spherical = _relative origin . spherical -instance HasTheta Direction where +instance HasTheta (Direction R3) where _theta = _Dir . _theta -instance HasPhi Direction where +instance HasPhi (Direction R3) where _phi = _Dir . _phi - --- | @direction v@ is the direction in which @v@ points. Returns an --- unspecified value when given the zero vector as input. -direction :: R3 -> Direction -direction = Direction - --- | @fromDirection d@ is the unit vector in the direction @d@. -fromDirection :: Direction -> R3 -fromDirection (Direction v) = normalized v - --- | compute the positive angle between the two directions in their common plane -angleBetweenDirs :: Direction -> Direction -> Angle -angleBetweenDirs d1 d2 = angleBetween (fromDirection d1) (fromDirection d2) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index b68ec360..6550b0e5 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -199,7 +199,7 @@ module Diagrams.TwoD -- * Combinators -- ** Combining multiple diagrams - , (===), (|||), atAngle + , (===), (|||), atDirection , hcat, hcat' , vcat, vcat' diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 775d6dc8..6dc41700 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -49,6 +49,7 @@ import Diagrams.Angle import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates +import Diagrams.Direction import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike @@ -58,7 +59,7 @@ import Diagrams.TwoD.Path () import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform (scaleX, scaleY) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (fromDirection, unitX, unitY) +import Diagrams.TwoD.Vector (unitX, unitY) import Diagrams.Util (( # )) @@ -91,13 +92,13 @@ infixl 6 ||| (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (|||) = beside unitX --- | Place two diagrams (or other juxtaposable objects) adjacent to one --- another, with the second diagram placed along a line at angle --- 'th' from the first. The local origin of the resulting combined --- diagram is the same as the local origin of the first. --- See the documentation of 'beside' for more information. -atAngle :: (Juxtaposable a, V a ~ R2, Semigroup a) => Angle -> a -> a -> a -atAngle th = beside (fromDirection th) +-- | Place two diagrams (or other juxtaposable objects) adjacent to +-- one another, with the second diagram placed in the direction 'd' +-- from the first. The local origin of the resulting combined +-- diagram is the same as the local origin of the first. See the +-- documentation of 'beside' for more information. +atDirection :: (Juxtaposable a, V a ~ R2, Semigroup a) => Direction R2 -> a -> a -> a +atDirection d = beside (fromDirection d) -- | Lay out a list of juxtaposable objects in a row from left to right, -- so that their local origins lie along a single horizontal line, diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index e0287875..43b9d638 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -32,11 +32,12 @@ import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector import Diagrams.Util -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ arcT zeroV fullTurn `at` (p2 (1,0)) +unitCircle = trailLike $ arcT xDir fullTurn `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index ba5d817f..ce8fe273 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -51,6 +51,7 @@ import Data.Default.Class import Diagrams.Core import Diagrams.Attributes +import Diagrams.Direction (direction) import Diagrams.Located import Diagrams.Parametric import Diagrams.Path @@ -61,7 +62,7 @@ import Diagrams.TwoD.Arc import Diagrams.TwoD.Curvature import Diagrams.TwoD.Path () import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (perp, direction) +import Diagrams.TwoD.Vector (perp) unitPerp :: R2 -> R2 unitPerp = normalized . perp @@ -462,11 +463,10 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcV u v = arc (direction u) (direction v) +arcV u v = arc (direction u) (direction v .-. direction u) arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcVCW u v = arcCW (direction u) (direction v) - +arcVCW u v = arcCW (direction u) (direction v .-. direction u) -- | Join together a list of located trails with the given join style. The -- style is given as a function to compute the join given the local information diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 7257e2e2..1f3327dd 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -22,12 +22,14 @@ module Diagrams.TwoD.Segment where import Control.Applicative (liftA2) +import Control.Lens ((^.)) import Data.AffineSpace import Data.VectorSpace import Diagrams.Core +import Diagrams.Angle import Diagrams.Located import Diagrams.Parametric import Diagrams.Segment @@ -93,7 +95,7 @@ instance Traced (FixedSegment R2) where let bez'@(FCubic x1 c1 c2 x2) = bez # moveOriginTo p1 - # rotate (negateV (direction v1)) + # rotate (negateV (v1^._theta)) # scale (1/magnitude v1) [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] a = -y0 + 3*y1 - 3*y2 + y3 diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index d49d4b87..f27a569b 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -57,10 +57,12 @@ import Diagrams.TwoD.Arc import Diagrams.TwoD.Polygons import Diagrams.TwoD.Transform import Diagrams.TwoD.Types +import Diagrams.TwoD.Vector import Diagrams.Util import Control.Lens (makeLenses, op, (&), (.~), (^.)) +import Data.AffineSpace import Data.Default.Class import Data.Semigroup @@ -310,6 +312,8 @@ roundedRect' w h opts else r sign n = if n < 0 then -1 else 1 mkCorner k r | r == 0 = mempty - | r < 0 = doArc 3 2 + | r < 0 = doArc 3 (-1) | otherwise = doArc 0 1 - where doArc d d' = arc' r ((k+d)/4 @@ turn) ((k+d')/4 @@ turn) + where + doArc d s = + arc' r (xDir .+^ ((k+d)/4 @@ turn)) (s/4 @@ turn) diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 538e8f3f..097fd500 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -56,7 +56,6 @@ import Diagrams.Angle import Diagrams.Transform import Diagrams.TwoD.Size (height, width) import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (direction) import Diagrams.Coordinates import Data.AdditiveGroup @@ -205,7 +204,7 @@ reflectY = transform reflectionY -- the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 reflectionAbout p v = - conjugate (rotation (negateV $ direction v) <> translation (origin .-. p)) + conjugate (rotation (negateV $ v^._theta) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by @@ -248,4 +247,4 @@ shearY = transform . shearingY -- is mostly useful for implementing backends. onBasis :: Transformation R2 -> ((R2, R2), R2) onBasis t = ((x, y), v) - where ((x:y:[]), v) = T.onBasis t + where (x:y:[], v) = T.onBasis t diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index b012a386..c5c90b90 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -26,6 +26,7 @@ import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Typeable +import Diagrams.Angle import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types @@ -85,7 +86,7 @@ instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - angle = direction (transform tr v) ^-^ direction v + angle = angleBetween (transform tr v) v rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index f184b888..88dd247f 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -31,6 +31,7 @@ import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, lens, (^.), _1, _2) import Diagrams.Angle +import Diagrams.Direction import Diagrams.Coordinates import Diagrams.Core @@ -187,6 +188,9 @@ instance HasTheta R2 where instance HasR R2 where _r = lens magnitude (\v r -> let s = r/magnitude v in s *^ v) +instance HasTheta (Direction R2) where + _theta = _Dir . _theta + -- | Points in R^2. This type is intentionally abstract. -- -- * To construct a point, use 'p2', or '^&' (see @@ -244,3 +248,7 @@ instance HasR P2 where instance HasTheta P2 where _theta = _relative origin . _theta + +-- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. +class Polar t where + polar :: Iso' t (Double, Angle) From ddce8f686594a6a2368ba05781a8a15ff0cc79be Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 16:54:32 +0000 Subject: [PATCH 07/22] Wall: add instances for Polar move some instances around, remove some imports --- src/Diagrams/Direction.hs | 2 +- src/Diagrams/TwoD/Arc.hs | 5 ++--- src/Diagrams/TwoD/Arrowheads.hs | 4 ++-- src/Diagrams/TwoD/Combinators.hs | 3 +-- src/Diagrams/TwoD/Ellipse.hs | 4 +--- src/Diagrams/TwoD/Transform/ScaleInv.hs | 2 -- src/Diagrams/TwoD/Types.hs | 22 ++++++++++++++++++---- src/Diagrams/TwoD/Vector.hs | 8 +------- 8 files changed, 26 insertions(+), 24 deletions(-) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 97833b61..61ee70a7 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -16,10 +16,10 @@ module Diagrams.Direction ( Direction , _Dir , direction, fromDirection + , angleBetweenDirs ) where import Control.Lens -import Data.AffineSpace import Data.VectorSpace import Diagrams.Angle diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index cb70d73e..bb33b7d9 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -32,7 +32,7 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unitX, unitY, unit_Y, xDir) +import Diagrams.TwoD.Vector (unitX, unitY, unit_Y, xDir) import Diagrams.Util (( # )) import Control.Lens ((^.)) @@ -98,7 +98,7 @@ arcT start sweep | sweep < zeroV = arcT start (sweep ^-^ (fromIntegral d @@ turn)) | otherwise = (if sweep >= fullTurn then glueTrail else id) $ trailFromSegments bs - where end = start .+^ sweep + where bs = map (rotate $ start .-. xDir) . bezierFromSweep $ sweep d = floor (sweep^.turn) :: Integer @@ -175,7 +175,6 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) mid | ht >= 0 = direction unitY | otherwise = direction unit_Y st = mid .-^ th - end = mid .+^ th a | isStraight = fromOffsets [d *^ unitX] | otherwise diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 9c9bf971..73fdc40c 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -54,7 +54,7 @@ module Diagrams.TwoD.Arrowheads , ArrowHT ) where -import Control.Lens ((&), (.~), (^.), (%~), (-~), (+~)) +import Control.Lens ((&), (.~), (^.)) import Data.AffineSpace import Data.Default.Class import Data.Monoid (mempty, (<>)) @@ -76,7 +76,7 @@ import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unitX, unit_X, xDir) +import Diagrams.TwoD.Vector (e, unit_X, xDir) import Diagrams.Util (( # )) ----------------------------------------------------------------------------- diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 6dc41700..9fa7ca2e 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -18,7 +18,7 @@ module Diagrams.TwoD.Combinators ( -- * Binary combinators - (===), (|||), atAngle + (===), (|||), atDirection -- * n-ary combinators , hcat, hcat' @@ -45,7 +45,6 @@ import Data.VectorSpace import Diagrams.Core -import Diagrams.Angle import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 43b9d638..2ccd032c 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -22,8 +22,6 @@ module Diagrams.TwoD.Ellipse , ellipseXY ) where -import Data.AdditiveGroup - import Diagrams.Core import Diagrams.Angle @@ -32,7 +30,7 @@ import Diagrams.TrailLike import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector +import Diagrams.TwoD.Vector (xDir) import Diagrams.Util -- | A circle of radius 1, with center at the origin. diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index c5c90b90..41e11396 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -21,7 +21,6 @@ module Diagrams.TwoD.Transform.ScaleInv where import Control.Lens (makeLenses, view) -import Data.AdditiveGroup import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Typeable @@ -30,7 +29,6 @@ import Diagrams.Angle import Diagrams.Core import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector -- | The @ScaleInv@ wrapper creates two-dimensional /scale-invariant/ -- objects. Intuitively, a scale-invariant object is affected by diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 88dd247f..0f86d873 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -28,13 +28,15 @@ module Diagrams.TwoD.Types ) where import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, - lens, (^.), _1, _2) + (^.), (&), (<>~), _1, _2) + import Diagrams.Angle import Diagrams.Direction import Diagrams.Coordinates import Diagrams.Core +import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) @@ -182,11 +184,10 @@ instance HasY R2 where _y = r2Iso . _2 instance HasTheta R2 where - _theta = lens (\v -> atanA (v^._y / v^._x)) - (\v θ -> let r = magnitude v in R2 (r * cosA θ) (r * sinA θ)) + _theta = polar._2 instance HasR R2 where - _r = lens magnitude (\v r -> let s = r/magnitude v in s *^ v) + _r = polar._1 instance HasTheta (Direction R2) where _theta = _Dir . _theta @@ -252,3 +253,16 @@ instance HasTheta P2 where -- | Types which can be expressed in polar 2D coordinates, as a magnitude and an angle. class Polar t where polar :: Iso' t (Double, Angle) + +instance Polar R2 where + polar = + iso (\v -> ( magnitude v, atanA (v^._y / v^._x))) + (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) + +instance Polar P2 where + polar = _relative origin . polar + +instance AffineSpace (Direction R2) where + type Diff (Direction R2) = Angle + a .-. b = a^._theta ^-^ b^._theta + a .+^ θ = a & _theta <>~ θ diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index 16d8847d..f7e8f87a 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,9 +23,8 @@ module Diagrams.TwoD.Vector , perp, leftTurn ) where -import Control.Lens ((^.), (&), (<>~)) -import Data.VectorSpace import Data.AffineSpace +import Data.VectorSpace import Diagrams.Angle import Diagrams.Direction @@ -48,11 +47,6 @@ unit_X = (-1) ^& 0 unit_Y :: R2 unit_Y = 0 ^& (-1) -instance AffineSpace (Direction R2) where - type Diff (Direction R2) = Angle - a .-. b = a^._theta ^-^ b^._theta - a .+^ θ = a & _theta <>~ θ - -- | The origin of the direction AffineSpace. For all d, @d .-. xDir -- = d^._theta@. xDir :: Direction R2 From b0b39eb9cfd41d3ec97e315dec891eefaf33a4a1 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 21:01:09 +0000 Subject: [PATCH 08/22] fix header in Direction remove extra language extension pragma --- src/Diagrams/Direction.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 61ee70a7..d946a305 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -1,10 +1,9 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | --- Module : Diagrams.Angle --- Copyright : (c) 2013 diagrams-lib team (see LICENSE) +-- Module : Diagrams.Direction +-- Copyright : (c) 2014 diagrams-lib team (see LICENSE) -- License : BSD-style (see LICENSE) -- Maintainer : diagrams-discuss@googlegroups.com -- From 9f84cdcfb2c8b20175649cd0d39e95c5b2481dd4 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 16 May 2014 21:08:45 +0000 Subject: [PATCH 09/22] avoid use of `e` in Arrowheads --- src/Diagrams/TwoD/Arrowheads.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 73fdc40c..30e7d3a2 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -76,7 +76,7 @@ import Diagrams.TwoD.Polygons import Diagrams.TwoD.Shapes import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (e, unit_X, xDir) +import Diagrams.TwoD.Vector (unitX, unit_X, xDir) import Diagrams.Util (( # )) ----------------------------------------------------------------------------- @@ -116,7 +116,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) hd = snugL . pathFromTrail . glueTrail $ fromOffsets [t1, t2, b2, b1] jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] - v = e theta + v = rotate theta unitX (t1, t2) = (unit_X ^+^ v, (-0.5 ^& 0) ^-^ v) [b1, b2] = map (reflectY . negateV) [t1, t2] psi = pi - (direction . negateV $ t2) ^. _theta.rad @@ -135,7 +135,7 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) l1 = trailFromSegments [straight $ unit_X ^+^ v] l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ (reflectY v))] c = reflectX $ arc' 1 (xDir .+^ theta) ((-2) *^ theta) - v = e theta + v = rotate theta unitX -- The length of the head without its joint is, -2r cos theta and -- the length of the joint is r - sqrt (r^2 - y^2). So the total @@ -161,7 +161,7 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) jt = pathFromTrail . glueTrail $ j <> reflectY j j = closeTrail $ fromOffsets [(-jLength ^& 0), (0 ^& shaftWidth / 2)] c = curvedSide theta - v = e theta + v = rotate theta unitX l = reverseSegment . straight $ t t = v ^-^ (-0.5 ^& 0) psi = fullTurn ^/ 2 ^-^ (negateV t ^. _theta) @@ -175,7 +175,7 @@ curvedSide :: Angle -> Segment Closed R2 curvedSide theta = bezier3 ctrl1 ctrl2 end where v0 = unit_X - v1 = e theta + v1 = rotate theta unitX ctrl1 = v0 ctrl2 = v0 ^+^ v1 end = v0 ^+^ v1 @@ -234,7 +234,7 @@ arrowtailBlock theta = aTail aTail len _ = (t, mempty) where t = rect len (len * x) # alignR - a' = e theta + a' = rotate theta unitX a = a' ^-^ (reflectY a') x = magnitude a @@ -248,7 +248,7 @@ arrowtailQuill theta = aTail # scale size # alignR size = len / 0.6 v0 = p2 (0.5, 0) - v2 = origin .+^ (e theta # scale 0.5) + v2 = origin .+^ (rotate theta unitX # scale 0.5) v1 = v2 # translateX (5/8) v3 = p2 (-0.1, 0) v4 = v2 # reflectY From fbc97d0e73c45ecc83aa3334542dff153e90d6e6 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 19 May 2014 00:26:21 +0000 Subject: [PATCH 10/22] Use atan2 instead of atan --- src/Diagrams/TwoD/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 0f86d873..661adb05 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -256,7 +256,7 @@ class Polar t where instance Polar R2 where polar = - iso (\v -> ( magnitude v, atanA (v^._y / v^._x))) + iso (\v -> ( magnitude v, atan2 (v^._y) (v^._x) @@ rad)) (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) instance Polar P2 where From d89c0256d7c71b2567b297d079a6a7b9aa510249 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Fri, 23 May 2014 19:48:22 +0000 Subject: [PATCH 11/22] Export xDir, Direction module --- diagrams-lib.cabal | 1 + src/Diagrams/TwoD.hs | 1 + 2 files changed, 2 insertions(+) diff --git a/diagrams-lib.cabal b/diagrams-lib.cabal index 9235ef2f..51f9bc4e 100644 --- a/diagrams-lib.cabal +++ b/diagrams-lib.cabal @@ -43,6 +43,7 @@ Library Diagrams.Path, Diagrams.CubicSpline, Diagrams.CubicSpline.Internal, + Diagrams.Direction, Diagrams.Solve, Diagrams.Tangent, Diagrams.Transform, diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 6550b0e5..fc58866c 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -65,6 +65,7 @@ module Diagrams.TwoD , P2, p2, unp2, mkP2 , T2 , unitX, unitY, unit_X, unit_Y + , xDir -- * Angles , tau From c3c6724c9c67ebc2c4528658f644ac6a99f66795 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 20:31:57 +0000 Subject: [PATCH 12/22] Export Deform from 3D --- src/Diagrams/ThreeD.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Diagrams/ThreeD.hs b/src/Diagrams/ThreeD.hs index 2f342a51..7e338ade 100644 --- a/src/Diagrams/ThreeD.hs +++ b/src/Diagrams/ThreeD.hs @@ -35,6 +35,7 @@ module Diagrams.ThreeD module Diagrams.ThreeD.Align , module Diagrams.ThreeD.Attributes , module Diagrams.ThreeD.Camera + , module Diagrams.ThreeD.Deform , module Diagrams.ThreeD.Light , module Diagrams.ThreeD.Shapes , module Diagrams.ThreeD.Transform @@ -45,6 +46,7 @@ module Diagrams.ThreeD import Diagrams.ThreeD.Align import Diagrams.ThreeD.Attributes import Diagrams.ThreeD.Camera +import Diagrams.ThreeD.Deform import Diagrams.ThreeD.Light import Diagrams.ThreeD.Shapes import Diagrams.ThreeD.Transform From d4d7398d4255c381a3894f1bd70faa90847bd4e8 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 20:32:08 +0000 Subject: [PATCH 13/22] Remove law-breaking AffineSpace instance Direction R2 is not actually an AffineSpace. for all Directions d, d .+^ fullTurn = d therefore (d .+^ a) .-. d is not a for a >= fullTurn angleBetweenDirs and rotate give nearly the same behavior --- src/Diagrams/TwoD/Arc.hs | 2 +- src/Diagrams/TwoD/Arrowheads.hs | 6 +++--- src/Diagrams/TwoD/Combinators.hs | 1 - src/Diagrams/TwoD/Offset.hs | 5 +++-- src/Diagrams/TwoD/Shapes.hs | 5 ++--- src/Diagrams/TwoD/Types.hs | 9 +-------- src/Diagrams/TwoD/Vector.hs | 15 ++++++++------- 7 files changed, 18 insertions(+), 25 deletions(-) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index bb33b7d9..8f547354 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -32,7 +32,7 @@ import Diagrams.Trail import Diagrams.TrailLike import Diagrams.TwoD.Transform import Diagrams.TwoD.Types -import Diagrams.TwoD.Vector (unitX, unitY, unit_Y, xDir) +import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Util (( # )) import Control.Lens ((^.)) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 30e7d3a2..ee32e785 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -54,7 +54,7 @@ module Diagrams.TwoD.Arrowheads , ArrowHT ) where -import Control.Lens ((&), (.~), (^.)) +import Control.Lens ((&), (.~), (^.), (<>~)) import Data.AffineSpace import Data.Default.Class import Data.Monoid (mempty, (<>)) @@ -131,10 +131,10 @@ arrowheadSpike theta len shaftWidth = (hd # scale r, jt # scale r) where hd = snugL . closedPath $ l1 <> c <> l2 jt = alignR . centerY . pathFromTrail - . closeTrail $ arc' 1 (xDir .-^ phi) (2 *^ phi) + . closeTrail $ arc' 1 (xDir & _theta <>~ (negateV phi)) (2 *^ phi) l1 = trailFromSegments [straight $ unit_X ^+^ v] l2 = trailFromSegments [reverseSegment . straight $ (unit_X ^+^ (reflectY v))] - c = reflectX $ arc' 1 (xDir .+^ theta) ((-2) *^ theta) + c = reflectX $ arc' 1 (xDir & _theta <>~ theta) ((-2) *^ theta) v = rotate theta unitX -- The length of the head without its joint is, -2r cos theta and diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 9fa7ca2e..8b084277 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -48,7 +48,6 @@ import Diagrams.Core import Diagrams.BoundingBox import Diagrams.Combinators import Diagrams.Coordinates -import Diagrams.Direction import Diagrams.Path import Diagrams.Segment import Diagrams.TrailLike diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index ce8fe273..ba5f8361 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -50,6 +50,7 @@ import Data.Default.Class import Diagrams.Core +import Diagrams.Angle import Diagrams.Attributes import Diagrams.Direction (direction) import Diagrams.Located @@ -463,10 +464,10 @@ capArc r c a b = trailLike . moveTo c $ fs -- Arc helpers arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcV u v = arc (direction u) (direction v .-. direction u) +arcV u v = arc (direction u) (angleBetween v u) arcVCW :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t -arcVCW u v = arcCW (direction u) (direction v .-. direction u) +arcVCW u v = arc (direction u) (negateV $ angleBetween v u) -- | Join together a list of located trails with the given join style. The -- style is given as a function to compute the join given the local information diff --git a/src/Diagrams/TwoD/Shapes.hs b/src/Diagrams/TwoD/Shapes.hs index f27a569b..0b973c7e 100644 --- a/src/Diagrams/TwoD/Shapes.hs +++ b/src/Diagrams/TwoD/Shapes.hs @@ -61,8 +61,7 @@ import Diagrams.TwoD.Vector import Diagrams.Util -import Control.Lens (makeLenses, op, (&), (.~), (^.)) -import Data.AffineSpace +import Control.Lens (makeLenses, op, (&), (.~), (^.), (<>~)) import Data.Default.Class import Data.Semigroup @@ -316,4 +315,4 @@ roundedRect' w h opts | otherwise = doArc 0 1 where doArc d s = - arc' r (xDir .+^ ((k+d)/4 @@ turn)) (s/4 @@ turn) + arc' r (xDir & _theta <>~ ((k+d)/4 @@ turn)) (s/4 @@ turn) diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index 661adb05..d79c245f 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -27,8 +27,7 @@ module Diagrams.TwoD.Types ) where -import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, - (^.), (&), (<>~), _1, _2) +import Control.Lens (Iso', Rewrapped, Wrapped (..), iso, (^.), _1, _2) import Diagrams.Angle @@ -36,7 +35,6 @@ import Diagrams.Direction import Diagrams.Coordinates import Diagrams.Core -import Data.AffineSpace import Data.AffineSpace.Point import Data.Basis import Data.MemoTrie (HasTrie (..)) @@ -261,8 +259,3 @@ instance Polar R2 where instance Polar P2 where polar = _relative origin . polar - -instance AffineSpace (Direction R2) where - type Diff (Direction R2) = Angle - a .-. b = a^._theta ^-^ b^._theta - a .+^ θ = a & _theta <>~ θ diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index f7e8f87a..7ae5396a 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,13 +23,14 @@ module Diagrams.TwoD.Vector , perp, leftTurn ) where -import Data.AffineSpace -import Data.VectorSpace +import Control.Lens ((&), (.~)) -import Diagrams.Angle -import Diagrams.Direction -import Diagrams.TwoD.Types -import Diagrams.Coordinates +import Data.VectorSpace + +import Diagrams.Angle +import Diagrams.Direction +import Diagrams.TwoD.Types +import Diagrams.Coordinates -- | The unit vector in the positive X direction. unitX :: R2 @@ -55,7 +56,7 @@ xDir = direction unitX -- | A unit vector at a specified angle counterclockwise from the -- positive X axis. e :: Angle -> R2 -e = fromDirection . (xDir .+^) +e a = unitX & _theta .~ a -- | @perp v@ is perpendicular to and has the same magnitude as @v@. -- In particular @perp v == rotateBy (1/4) v@. From 42b85ede30a835258ef22306398d02da690ff24c Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 20:38:41 +0000 Subject: [PATCH 14/22] add atan2A function --- src/Diagrams/Angle.hs | 7 ++++++- src/Diagrams/TwoD/Types.hs | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Angle.hs b/src/Diagrams/Angle.hs index 2c8d916a..5fba3f72 100644 --- a/src/Diagrams/Angle.hs +++ b/src/Diagrams/Angle.hs @@ -17,7 +17,7 @@ module Diagrams.Angle Angle , rad, turn, deg , fullTurn, fullCircle, angleRatio - , sinA, cosA, tanA, asinA, acosA, atanA + , sinA, cosA, tanA, asinA, acosA, atanA, atan2A , (@@) , angleBetween , HasTheta(..) @@ -98,6 +98,11 @@ acosA = Radians . acos atanA :: Double -> Angle atanA = Radians . atan +-- | @atan2A n d@ is the @Angle with tangent @n/d@, unless d is 0, in +-- which case it is ±π/2. +atan2A :: Double -> Double -> Angle +atan2A n d = Radians $ atan2 n d + -- | @30 \@\@ deg@ is an @Angle@ of the given measure and units. -- -- More generally, @\@\@@ reverses the @Iso\'@ on its right, and diff --git a/src/Diagrams/TwoD/Types.hs b/src/Diagrams/TwoD/Types.hs index d79c245f..61a29779 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -254,7 +254,7 @@ class Polar t where instance Polar R2 where polar = - iso (\v -> ( magnitude v, atan2 (v^._y) (v^._x) @@ rad)) + iso (\v -> ( magnitude v, atan2A (v^._y) (v^._x))) (\(r,θ) -> R2 (r * cosA θ) (r * sinA θ)) instance Polar P2 where From ed7410c1fbd39e214e9827b9044a5341eead887d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 20:45:03 +0000 Subject: [PATCH 15/22] atDirection is no longer specific to R2 --- src/Diagrams/Combinators.hs | 11 +++++++++++ src/Diagrams/Direction.hs | 3 +++ src/Diagrams/TwoD.hs | 2 +- src/Diagrams/TwoD/Combinators.hs | 10 +--------- 4 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Diagrams/Combinators.hs b/src/Diagrams/Combinators.hs index 7001e6b0..32dede72 100644 --- a/src/Diagrams/Combinators.hs +++ b/src/Diagrams/Combinators.hs @@ -28,6 +28,7 @@ module Diagrams.Combinators , atop , beneath , beside + , atDirection -- * n-ary operations , appends @@ -57,6 +58,7 @@ import Data.VectorSpace import Diagrams.Core import Diagrams.Core.Types (QDiagram (QD)) +import Diagrams.Direction import Diagrams.Located import Diagrams.Path import Diagrams.Segment (straight) @@ -237,6 +239,15 @@ infixl 6 `beneath` beside :: (Juxtaposable a, Semigroup a) => V a -> a -> a -> a beside v d1 d2 = d1 <> juxtapose v d1 d2 +-- | Place two diagrams (or other juxtaposable objects) adjacent to +-- one another, with the second diagram placed in the direction 'd' +-- from the first. The local origin of the resulting combined +-- diagram is the same as the local origin of the first. See the +-- documentation of 'beside' for more information. +atDirection :: (Juxtaposable a, Semigroup a, InnerSpace (V a), Floating (Scalar (V a))) => + Direction (V a) -> a -> a -> a +atDirection = beside . fromDirection + ------------------------------------------------------------ -- Combining multiple objects ------------------------------------------------------------ diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index d946a305..984e6b8e 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -22,6 +22,7 @@ import Control.Lens import Data.VectorSpace import Diagrams.Angle +import Diagrams.Core -------------------------------------------------------------------------------- -- Direction @@ -32,6 +33,8 @@ import Diagrams.Angle -- lenses provided by its instances. data Direction v = Direction v +type instance V (Direction v) = v + -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it -- exposes too much information. diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index fc58866c..2070b835 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -200,7 +200,7 @@ module Diagrams.TwoD -- * Combinators -- ** Combining multiple diagrams - , (===), (|||), atDirection + , (===), (|||) , hcat, hcat' , vcat, vcat' diff --git a/src/Diagrams/TwoD/Combinators.hs b/src/Diagrams/TwoD/Combinators.hs index 8b084277..c4e5bb55 100644 --- a/src/Diagrams/TwoD/Combinators.hs +++ b/src/Diagrams/TwoD/Combinators.hs @@ -18,7 +18,7 @@ module Diagrams.TwoD.Combinators ( -- * Binary combinators - (===), (|||), atDirection + (===), (|||) -- * n-ary combinators , hcat, hcat' @@ -90,14 +90,6 @@ infixl 6 ||| (|||) :: (Juxtaposable a, V a ~ R2, Semigroup a) => a -> a -> a (|||) = beside unitX --- | Place two diagrams (or other juxtaposable objects) adjacent to --- one another, with the second diagram placed in the direction 'd' --- from the first. The local origin of the resulting combined --- diagram is the same as the local origin of the first. See the --- documentation of 'beside' for more information. -atDirection :: (Juxtaposable a, V a ~ R2, Semigroup a) => Direction R2 -> a -> a -> a -atDirection d = beside (fromDirection d) - -- | Lay out a list of juxtaposable objects in a row from left to right, -- so that their local origins lie along a single horizontal line, -- with successive envelopes tangent to one another. From e79f5682c62c51c15f2b3f6aa5d4c93f70eeeffb Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 21:22:46 +0000 Subject: [PATCH 16/22] revise arc functions to respect sign of Angle --- src/Diagrams/TwoD.hs | 1 - src/Diagrams/TwoD/Arc.hs | 79 ++++++++++++++++------------------------ 2 files changed, 31 insertions(+), 49 deletions(-) diff --git a/src/Diagrams/TwoD.hs b/src/Diagrams/TwoD.hs index 2070b835..d63d95a5 100644 --- a/src/Diagrams/TwoD.hs +++ b/src/Diagrams/TwoD.hs @@ -92,7 +92,6 @@ module Diagrams.TwoD , ellipseXY , arc , arc' - , arcCW , wedge , arcBetween , annularWedge diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 8f547354..f5018e89 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -14,7 +14,6 @@ module Diagrams.TwoD.Arc ( arc , arc' - , arcCW , arcT , bezierFromSweep @@ -35,7 +34,7 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (unitX, unitY, unit_Y) import Diagrams.Util (( # )) -import Control.Lens ((^.)) +import Control.Lens ((^.), (&), (<>~)) import Data.AffineSpace import Data.Semigroup ((<>)) import Data.VectorSpace @@ -59,11 +58,10 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 -- start in the positive y direction and sweep counter clockwise -- through the angle @s@. If @s@ is negative, it will start in the -- negative y direction and sweep clockwise. When @s@ is less than --- 0.0001 the empty list results. If the sweep is greater than tau --- radians then it is truncated to one full revolution. +-- 0.0001 the empty list results. If the sweep is greater than @fullTurn@ +-- later segments will overlap earlier segments. bezierFromSweep :: Angle -> [Segment Closed R2] bezierFromSweep s - | s > fullTurn = bezierFromSweep fullTurn | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) | s < 0.0001 @@ rad = [] | s < fullTurn^/4 = [bezierFromSweepQ1 s] @@ -91,58 +89,43 @@ the approximation error. -} -- | Given a start direction @d@ and a sweep angle @s@, @'arcT' d s@ --- is the 'Trail' of a radius one arc starting at d and sweeping out --- the angle @s@ counterclockwise. +-- is the 'Trail' of a radius one arc starting at @d@ and sweeping out +-- the angle @s@ counterclockwise (for positive s). The resulting +-- @Trail@ is allowed to wrap around and overlap itself. arcT :: Direction R2 -> Angle -> Trail R2 -arcT start sweep - | sweep < zeroV = arcT start (sweep ^-^ (fromIntegral d @@ turn)) - | otherwise = (if sweep >= fullTurn then glueTrail else id) - $ trailFromSegments bs +arcT start sweep = trailFromSegments bs where - bs = map (rotate $ start .-. xDir) . bezierFromSweep $ sweep - d = floor (sweep^.turn) :: Integer + bs = map (rotate $ start ^. _theta) . bezierFromSweep $ sweep -- | Given a start angle @d@ and a sweep angle @s@, @'arc' d s@ is the --- path of a radius one arc starting at d and sweeping out the angle --- @s@ counterclockwise. +-- path of a radius one arc starting at @d@ and sweeping out the angle +-- @s@ counterclockwise (for positive s). The resulting +-- @Trail@ is allowed to wrap around and overlap itself. arc :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t -arc start sweep = trailLike $ arcT start sweep `at` (rotate (start .-. xDir) $ p2 (1,0)) - --- | Like 'arc' but clockwise. -arcCW :: (TrailLike t, V t ~ R2) => Direction R2 -> Angle -> t -arcCW start sweep = trailLike $ - -- flipped arguments to get the path we want - -- then reverse the trail to get the cw direction. - (reverseTrail $ arcT (start .+^ sweep) (negateV sweep)) - `at` - (rotate (start .-. xDir) $ p2 (1,0)) - -- We could just have `arcCW = reversePath . flip arc` - -- but that wouldn't be `TrailLike`. - --- | Given a radus @r@, a start direction @d@ and a sweep angle @s@, --- @'arc'' r d s@ is the path of a radius @(abs r)@ arc between --- the two angles. If a negative radius is given, the arc will --- be clockwise, otherwise it will be counterclockwise. The origin --- of the arc is its center. +arc start sweep = trailLike $ arcT start sweep `at` (rotate (start ^. _theta) $ p2 (1,0)) + +-- | Given a radus @r@, a start direction @d@ and an angle @s@, +-- @'arc'' r d s@ is the path of a radius @(abs r)@ arc starting at +-- @d@ and sweeping out the angle @s@ counterclockwise (for positive +-- s). The origin of the arc is its center. -- -- <> -- -- > arc'Ex = mconcat [ arc' r 0 (1/4 \@\@ turn) | r <- [0.5,-1,1.5] ] -- > # centerXY # pad 1.1 arc' :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p -arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start .-. xDir) $ p2 (abs r,0)) - where ts | r < 0 = reverseTrail $ arcT (start .+^ sweep) sweep - | otherwise = arcT start sweep +arc' r start sweep = trailLike $ scale (abs r) ts `at` (rotate (start ^. _theta) $ p2 (abs r,0)) + where ts = arcT start sweep -- | Create a circular wedge of the given radius, beginning at the --- first angle and extending counterclockwise to the second. +-- given directionand extending through the given angle. -- -- <> -- -- > wedgeEx = hcat' (with & sep .~ 0.5) --- > [ wedge 1 (0 \@\@ turn) (1/4) --- > , wedge 1 (7/30 \@\@ turn) (11/30) --- > , wedge 1 (1/8 \@\@ turn) (7/8) +-- > [ wedge 1 xDir (1/4 \@\@ turn) +-- > , wedge 1 (rotate (7/30 \@\@ turn) xDir) (11/30 \@\@ turn) +-- > , wedge 1 (rotate (1/8 \@\@ turn) xDir) (7/8 \@\@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 @@ -150,7 +133,7 @@ wedge :: (TrailLike p, V p ~ R2) => Double -> Direction R2 -> Angle -> p wedge r d s = trailLike . (`at` origin) . glueTrail . wrapLine $ fromOffsets [r *^ fromDirection d] <> arc d s # scale r - <> fromOffsets [r *^ negateV (fromDirection (d .+^ s))] + <> fromOffsets [r *^ negateV (rotate s $ fromDirection d)] -- | @arcBetween p q height@ creates an arc beginning at @p@ and -- ending at @q@, with its midpoint at a distance of @abs height@ @@ -174,7 +157,7 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) r = d/(2*sinA th) mid | ht >= 0 = direction unitY | otherwise = direction unit_Y - st = mid .-^ th + st = mid & _theta <>~ (negateV th) a | isStraight = fromOffsets [d *^ unitX] | otherwise @@ -185,15 +168,15 @@ arcBetween p q ht = trailLike (a # rotate (v^._theta) # moveTo p) # (if ht > 0 then reverseLocTrail else id) -- | Create an annular wedge of the given radii, beginning at the --- first direction and extending counterclockwise to the second. +-- first direction and extending through the given sweep angle. -- The radius of the outer circle is given first. -- -- <> -- -- > annularWedgeEx = hcat' (with & sep .~ 0.50) --- > [ annularWedge 1 0.5 (0 \@\@ turn) (1/4) --- > , annularWedge 1 0.3 (7/30 \@\@ turn) (11/30) --- > , annularWedge 1 0.7 (1/8 \@\@ turn) (7/8) +-- > [ annularWedge 1 0.5 xDir (1/4 \@\@ turn) +-- > , annularWedge 1 0.3 (rotate (7/30 \@\@ turn) xDir)n (11/30 \@\@ turn) +-- > , annularWedge 1 0.7 (rotate (1/8 \@\@ turn) xDir) (7/8 \@\@ turn) -- > ] -- > # fc blue -- > # centerXY # pad 1.1 @@ -203,6 +186,6 @@ annularWedge r1' r2' d1 s = trailLike . (`at` o) . glueTrail . wrapLine $ fromOffsets [(r1'-r2') *^ fromDirection d1] <> arc d1 s # scale r1' <> fromOffsets [(r1'-r2') *^ negateV (fromDirection d2)] - <> arcCW d2 (negateV s) # scale r2' + <> arc d2 (negateV s) # scale r2' where o = origin # translate (r2' *^ fromDirection d1) - d2 = d1 .+^ s + d2 = d1 & _theta <>~ s From 6a27bf9ce250cab72df99e2428b78bf6e2f0682e Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 26 May 2014 21:57:06 +0000 Subject: [PATCH 17/22] glue circle into a Loop --- src/Diagrams/TwoD/Ellipse.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 2ccd032c..988e4112 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -27,6 +27,7 @@ import Diagrams.Core import Diagrams.Angle import Diagrams.Located (at) import Diagrams.TrailLike +import Diagrams.Trail (glueTrail) import Diagrams.TwoD.Arc import Diagrams.TwoD.Transform import Diagrams.TwoD.Types @@ -35,7 +36,7 @@ import Diagrams.Util -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ arcT xDir fullTurn `at` (p2 (1,0)) +unitCircle = trailLike $ glueTrail (arcT xDir fullTurn) `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). From 1ac0743ae1ef81e1f89946899940e3948cf2a387 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 27 May 2014 02:35:09 +0000 Subject: [PATCH 18/22] add Transformable instance for Direction --- src/Diagrams/Direction.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index 984e6b8e..f7f12248 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -18,7 +18,7 @@ module Diagrams.Direction , angleBetweenDirs ) where -import Control.Lens +import Control.Lens (Iso', iso) import Data.VectorSpace import Diagrams.Angle @@ -31,10 +31,13 @@ import Diagrams.Core -- can think of a @Direction@ as a vector that has forgotten its -- magnitude. @Direction@s can be used with 'fromDirection' and the -- lenses provided by its instances. -data Direction v = Direction v +newtype Direction v = Direction v type instance V (Direction v) = v +instance (Transformable v, V (Direction v) ~ V v) => Transformable (Direction v) where + transform t (Direction v) = Direction (transform t v) + -- | _Dir is provided to allow efficient implementations of functions -- in particular vector-spaces, but should be used with care as it -- exposes too much information. From 7be96f62585bee0b5ae24c90c7d70ad13ab6407d Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Tue, 27 May 2014 12:44:09 +0000 Subject: [PATCH 19/22] Add UndecidableInstances pragma to Direction --- src/Diagrams/Direction.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Diagrams/Direction.hs b/src/Diagrams/Direction.hs index f7f12248..effb9cab 100644 --- a/src/Diagrams/Direction.hs +++ b/src/Diagrams/Direction.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | From 02dd838d2c84da430c431847548ed97bbea35a9e Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 28 May 2014 13:51:55 +0000 Subject: [PATCH 20/22] angleBetween is commutative It is not right when the intent is to create a rotation between two vectors. --- src/Diagrams/TwoD/Arrow.hs | 4 ++-- src/Diagrams/TwoD/Arrowheads.hs | 4 ++-- src/Diagrams/TwoD/Offset.hs | 1 + src/Diagrams/TwoD/Transform/ScaleInv.hs | 2 +- 4 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 38688f7b..26cf642b 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -356,7 +356,7 @@ scaleFactor tr tw hw t arrowEnv :: ArrowOpts -> Double -> Envelope R2 arrowEnv opts len = getEnvelope horizShaft where - horizShaft = shaft # rotate (negateV v ^. _theta) # scale (len / m) + horizShaft = shaft # rotate (negateV (v ^. _theta)) # scale (len / m) m = magnitude v v = trailOffset shaft shaft = opts ^. arrowShaft @@ -395,7 +395,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) - # rotate (angleBetween (q .-. p) (fromDirection dir)) + # rotate ((q .-. p)^._theta) ^-^ (dir^._theta) # moveTo p where diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index ee32e785..034618c7 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -119,7 +119,7 @@ arrowheadDart theta len shaftWidth = (hd # scale size, jt) v = rotate theta unitX (t1, t2) = (unit_X ^+^ v, (-0.5 ^& 0) ^-^ v) [b1, b2] = map (reflectY . negateV) [t1, t2] - psi = pi - (direction . negateV $ t2) ^. _theta.rad + psi = pi - (negateV t2) ^. _theta.rad jLength = shaftWidth / (2 * tan psi) -- If the shaft if too wide, set the size to a default value of 1. @@ -164,7 +164,7 @@ arrowheadThorn theta len shaftWidth = (hd # scale size, jt) v = rotate theta unitX l = reverseSegment . straight $ t t = v ^-^ (-0.5 ^& 0) - psi = fullTurn ^/ 2 ^-^ (negateV t ^. _theta) + psi = fullTurn ^/ 2 ^-^ ((negateV t) ^. _theta) jLength = shaftWidth / (2 * tanA psi) -- If the shaft if too wide, set the size to a default value of 1. diff --git a/src/Diagrams/TwoD/Offset.hs b/src/Diagrams/TwoD/Offset.hs index ba5f8361..ea353e1c 100644 --- a/src/Diagrams/TwoD/Offset.hs +++ b/src/Diagrams/TwoD/Offset.hs @@ -463,6 +463,7 @@ capArc r c a b = trailLike . moveTo c $ fs | otherwise = scale r $ arcV (a .-. c) (b .-. c) -- Arc helpers +-- always picks the shorter arc (< τ/2) arcV :: (TrailLike t, V t ~ R2) => R2 -> R2 -> t arcV u v = arc (direction u) (angleBetween v u) diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 41e11396..80d5fdf4 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -84,7 +84,7 @@ instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - angle = angleBetween (transform tr v) v + angle = (transform tr v ^. _theta) (v^._theta) rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l From d5e265ef5b0cd1ed9a66e7bf67f4326e0372f271 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 4 Jun 2014 14:16:50 +0000 Subject: [PATCH 21/22] fix implementation of pointAt This code is confusing, untested, and poorly named. It will probably change in the future. But this implementation is not obviously wrong, like the last one was. --- src/Diagrams/ThreeD/Transform.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Diagrams/ThreeD/Transform.hs b/src/Diagrams/ThreeD/Transform.hs index 7616f394..b3c86ede 100644 --- a/src/Diagrams/ThreeD/Transform.hs +++ b/src/Diagrams/ThreeD/Transform.hs @@ -124,7 +124,7 @@ rotationAbout p d a -- | @pointAt about initial final@ produces a rotation which brings -- the direction @initial@ to point in the direction @final@ by first -- panning around @about@, then tilting about the axis perpendicular --- to initial and final. In particular, if this can be accomplished +-- to @about@ and @final@. In particular, if this can be accomplished -- without tilting, it will be, otherwise if only tilting is -- necessary, no panning will occur. The tilt will always be between -- ± 1/4 turn. @@ -134,13 +134,20 @@ pointAt a i f = pointAt' (fromDirection a) (fromDirection i) (fromDirection f) -- | pointAt' has the same behavior as 'pointAt', but takes vectors -- instead of directions. pointAt' :: R3 -> R3 -> R3 -> T3 -pointAt' about initial final = tilt <> pan where - inPanPlane = final ^-^ project final initial - panAngle = angleBetween initial inPanPlane +pointAt' about initial final = pointAtUnit (normalized about) (normalized initial) (normalized final) + +-- | pointAtUnit has the same behavior as @pointAt@, but takes unit vectors. +pointAtUnit :: R3 -> R3 -> R3 -> T3 +pointAtUnit about initial final = tilt <> pan where + -- rotating u by (signedAngle rel u v) about rel gives a vector in the direction of v + signedAngle rel u v = signum (cross3 u v <.> rel) *^ angleBetween u v + inPanPlaneF = final ^-^ project about final + inPanPlaneI = initial ^-^ project about initial + panAngle = signedAngle about inPanPlaneI inPanPlaneF pan = rotationAbout origin (direction about) panAngle - tiltAngle = angleBetween initial inPanPlane - tiltDir = direction $ cross3 inPanPlane about - tilt = rotationAbout origin tiltDir tiltAngle + tiltAngle = signedAngle tiltAxis (transform pan initial) final + tiltAxis = cross3 final about + tilt = rotationAbout origin (direction tiltAxis) tiltAngle -- Scaling ------------------------------------------------- From df10acf66ee4a451647a4925127c1853afb22af2 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Wed, 4 Jun 2014 14:44:06 +0000 Subject: [PATCH 22/22] fix imports, add some parens --- src/Diagrams/TwoD/Arrow.hs | 2 +- src/Diagrams/TwoD/Arrowheads.hs | 1 - src/Diagrams/TwoD/Transform/ScaleInv.hs | 4 ++-- 3 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index b76d607c..c00da8e2 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -395,7 +395,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) -- Build an arrow and set its endpoints to the image under tr of origin and (len,0). dArrow sty tr ln gToO nToO = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) - # rotate ((q .-. p)^._theta) ^-^ (dir^._theta) + # rotate (((q .-. p)^._theta) ^-^ (dir^._theta)) # moveTo p where diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index 79df40fb..745765ad 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -64,7 +64,6 @@ import Diagrams.Angle import Diagrams.Core import Diagrams.Coordinates ((^&)) -import Diagrams.Direction import Diagrams.Path import Diagrams.Segment import Diagrams.Trail diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 80d5fdf4..2b5ff576 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -20,7 +20,7 @@ module Diagrams.TwoD.Transform.ScaleInv , scaleInv, scaleInvPrim ) where -import Control.Lens (makeLenses, view) +import Control.Lens (makeLenses, view,(^.)) import Data.AffineSpace ((.-.)) import Data.Semigroup import Data.Typeable @@ -84,7 +84,7 @@ instance (V t ~ R2, HasOrigin t) => HasOrigin (ScaleInv t) where instance (V t ~ R2, Transformable t) => Transformable (ScaleInv t) where transform tr (ScaleInv t v l) = ScaleInv (trans . rot $ t) (rot v) l' where - angle = (transform tr v ^. _theta) (v^._theta) + angle = (transform tr v ^. _theta) rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l