From bacb0eb57ad993144e7ac9c3277e4cc11c8c262f Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 27 Jan 2014 15:12:59 +0000 Subject: [PATCH 1/2] Remove Num instance for Angle Data.VectorSpace provides correct operators for addition and scalar multiplication. Multiplication of angles is meaningless, and allowing numeric literals as Angles leaks the internal representation. --- 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 11655be0..72619c88 100644 --- a/src/Diagrams/TwoD/Types.hs +++ b/src/Diagrams/TwoD/Types.hs @@ -239,7 +239,7 @@ instance HasY P2 where -- | 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, Fractional, Num, Real, RealFrac, AdditiveGroup) + deriving (Read, Show, Eq, Ord, Enum, AdditiveGroup) instance VectorSpace Angle where type Scalar Angle = Double From c6400d4cde049c97998dffe90c381cb06396c726 Mon Sep 17 00:00:00 2001 From: Daniel Bergey Date: Mon, 27 Jan 2014 15:15:06 +0000 Subject: [PATCH 2/2] Use VectorSpace for Angles, not Num --- src/Diagrams/TwoD/Arc.hs | 28 ++++++++++++------------- src/Diagrams/TwoD/Arrow.hs | 4 ++-- src/Diagrams/TwoD/Arrowheads.hs | 10 ++++----- src/Diagrams/TwoD/Ellipse.hs | 4 +++- src/Diagrams/TwoD/Polygons.hs | 19 ++++++++++------- src/Diagrams/TwoD/Segment.hs | 2 +- src/Diagrams/TwoD/Transform.hs | 3 ++- src/Diagrams/TwoD/Transform/ScaleInv.hs | 3 ++- src/Diagrams/TwoD/Vector.hs | 5 +++-- 9 files changed, 43 insertions(+), 35 deletions(-) diff --git a/src/Diagrams/TwoD/Arc.hs b/src/Diagrams/TwoD/Arc.hs index 58b42481..d22556a3 100644 --- a/src/Diagrams/TwoD/Arc.hs +++ b/src/Diagrams/TwoD/Arc.hs @@ -36,7 +36,7 @@ import Diagrams.Util (( # )) import Control.Lens ((^.)) import Data.AffineSpace ((.-.)) import Data.Semigroup ((<>)) -import Data.VectorSpace (magnitude, negateV, (*^), (^-^)) +import Data.VectorSpace import Diagrams.Coordinates -- For details of this approximation see: @@ -47,8 +47,8 @@ import Diagrams.Coordinates -- radians. 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 +bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s ^/ 2) $ bezier3 c2 c1 p0 + where p0@(coords -> x :& y) = rotate (s ^/ 2) v c1 = ((4-x)/3) ^& ((1-x)*(3-x)/(3*y)) c2 = reflectY c1 v = unitX @@ -62,11 +62,11 @@ bezierFromSweepQ1 s = fmap (^-^ v) . rotate (s/2) $ bezier3 c2 c1 p0 bezierFromSweep :: Angle -> [Segment Closed R2] bezierFromSweep s | s > fullTurn = bezierFromSweep fullTurn - | s < 0 = fmap reflectY . bezierFromSweep $ (-s) - | s < 0.0001 = [] - | s < fullTurn/4 = [bezierFromSweepQ1 s] - | otherwise = bezierFromSweepQ1 (fullTurn/4) - : map (rotateBy (1/4)) (bezierFromSweep (max (s - fullTurn/4) 0)) + | s < zeroV = fmap reflectY . bezierFromSweep $ (negateV s) + | s < 0.0001 @@ rad = [] + | s < fullTurn^/4 = [bezierFromSweepQ1 s] + | otherwise = bezierFromSweepQ1 (fullTurn^/4) + : map (rotateBy (1/4)) (bezierFromSweep (max (s ^-^ fullTurn^/4) zeroV)) {- ~~~~ Note [segment spacing] @@ -92,10 +92,10 @@ the approximation error. -- '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)) + | end' < start' = arcT start (end ^+^ (fromIntegral d @@ turn)) | otherwise = (if sweep >= fullTurn then glueTrail else id) $ trailFromSegments bs - where sweep = end - start + where sweep = end ^-^ start bs = map (rotate start) . bezierFromSweep $ sweep -- We want to compare the start and the end and in case @@ -175,10 +175,10 @@ arcBetween p q ht = trailLike (a # rotate (direction v) # moveTo 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) + mid | ht >= 0 = fullTurn ^/ 4 + | otherwise = 3 *^ fullTurn ^/ 4 + st = mid ^-^ (th @@ rad) + end = mid ^+^ (th @@ rad) a | isStraight = fromOffsets [d *^ unitX] | otherwise diff --git a/src/Diagrams/TwoD/Arrow.hs b/src/Diagrams/TwoD/Arrow.hs index 252f84e1..ec6f853c 100644 --- a/src/Diagrams/TwoD/Arrow.hs +++ b/src/Diagrams/TwoD/Arrow.hs @@ -383,7 +383,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 = (h' <> t' <> shaft) # moveOriginBy (tWidth *^ (unit_X # rotate tAngle)) - # rotate (direction (q .-. p) - dir) + # rotate (direction (q .-. p) ^-^ dir) # moveTo p where @@ -407,7 +407,7 @@ arrow' opts len = mkQD' (DelayedLeaf delayedArrow) shaftTrail = rawShaftTrail -- rotate it so it is pointing in the positive X direction - # rotate (- direction (trailOffset rawShaftTrail)) + # rotate (negateV direction (trailOffset rawShaftTrail)) -- apply the context transformation -- in case it includes -- things like flips and shears (the possibility of shears -- is why we must rotate it to a neutral position first) diff --git a/src/Diagrams/TwoD/Arrowheads.hs b/src/Diagrams/TwoD/Arrowheads.hs index c0182077..3c8caeae 100644 --- a/src/Diagrams/TwoD/Arrowheads.hs +++ b/src/Diagrams/TwoD/Arrowheads.hs @@ -111,7 +111,7 @@ arrowheadTriangle theta = aHead where aHead size _ = (p, mempty) where - p = polygon (def & polyType .~ PolyPolar [theta, (-2 * theta)] + p = polygon (def & polyType .~ PolyPolar [theta, (negateV 2 *^ theta)] (repeat (htRadius * size)) & polyOrient .~ NoOrient) # alignL -- | Isoceles triangle with linear concave base. Inkscape type 1 - dart like. @@ -122,7 +122,7 @@ arrowheadDart theta = aHead where r = htRadius * size dartP = polygon - ( def & polyType .~ PolyPolar [theta, (1/2 @@ turn) - theta, (1/2 @@ turn) - theta] + ( def & polyType .~ PolyPolar [theta, (1/2 @@ turn) ^-^ theta, (1/2 @@ turn) ^-^ theta] [r, r, 0.1 * size, r] & polyOrient .~ NoOrient ) @@ -146,11 +146,11 @@ arrowheadSpike theta = aHead a' = reflectY a l1 = trailFromSegments [straight (unit_X2 ^+^ a)] l2 = trailFromSegments [reverseSegment . straight $ (unit_X2 ^+^ a')] - c = reflectX $ arc' htRadius theta (-theta) + c = reflectX $ arc' htRadius theta (negateV theta) barb = (closedPath $ (l1 <> c <> l2)) # scale size m = xWidth barb --c `atParam` 0.5 b = asin ((shaftWidth / 2) / (htRadius * size)) @@ rad - c' = arc' htRadius (-b ) b # scale size + c' = arc' htRadius (negateV b) b # scale size joint = (closedPath $ (c')) # centerY # alignR xWidth p = pa + pb where @@ -167,7 +167,7 @@ arrowheadThorn theta r = aHead c1 = curvedSide theta l1 = straight $ (reflectY a) ^-^ (unit_X2 # scale r) l2 = straight $ unit_X2 # scale r ^-^ a - c2 = c1 # rotate (-theta) + c2 = c1 # rotate (negateV theta) thornP = (closedPath $ trailFromSegments [c1, l1, l2, c2]) # scale size thornVertices = (concat . pathVertices) $ thornP m = magnitude (thornVertices !! 1 .-. thornVertices !! 3) diff --git a/src/Diagrams/TwoD/Ellipse.hs b/src/Diagrams/TwoD/Ellipse.hs index 9731aeed..abdd7ff7 100644 --- a/src/Diagrams/TwoD/Ellipse.hs +++ b/src/Diagrams/TwoD/Ellipse.hs @@ -22,6 +22,8 @@ module Diagrams.TwoD.Ellipse , ellipseXY ) where +import Data.AdditiveGroup + import Diagrams.Core import Diagrams.Located (at) @@ -33,7 +35,7 @@ import Diagrams.Util -- | A circle of radius 1, with center at the origin. unitCircle :: (TrailLike t, V t ~ R2) => t -unitCircle = trailLike $ arcT 0 fullTurn `at` (p2 (1,0)) +unitCircle = trailLike $ arcT zeroV fullTurn `at` (p2 (1,0)) -- | A circle of the given radius, centered at the origin. As a path, -- it begins at (r,0). diff --git a/src/Diagrams/TwoD/Polygons.hs b/src/Diagrams/TwoD/Polygons.hs index d126acb2..3fa1a1ed 100644 --- a/src/Diagrams/TwoD/Polygons.hs +++ b/src/Diagrams/TwoD/Polygons.hs @@ -46,7 +46,7 @@ module Diagrams.TwoD.Polygons( ) where import Control.Lens (Lens', generateSignatures, lensRules, - makeLensesWith, (.~), (^.)) + makeLensesWith, (.~), (^.), view) import Control.Monad (forM, liftM) import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, @@ -58,8 +58,7 @@ import Data.Ord (comparing) import Data.AffineSpace ((.+^), (.-.)) import Data.Default.Class -import Data.VectorSpace (magnitude, normalized, project, (<.>), - (^*)) +import Data.VectorSpace import Diagrams.Core import Diagrams.Located @@ -190,7 +189,7 @@ polyPolarTrail ans (r:rs) = tr `at` p1 tr = closeTrail . trailFromVertices $ zipWith (\a l -> rotate a . scale l $ p2 (1,0)) - (scanl (+) 0 ans) + (scanl (^+^) zeroV ans) (r:rs) -- | Generate the vertices of a polygon specified by side length and @@ -199,7 +198,7 @@ polyPolarTrail ans (r:rs) = tr `at` p1 polySidesTrail :: [Angle] -> [Double] -> Located (Trail R2) polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) where - ans' = scanl (+) 0 ans + ans' = scanl (^+^) zeroV ans offsets = zipWith rotate ans' (map (unitY ^*) ls) ps = scanl (.+^) origin offsets tr = closeTrail . trailFromOffsets $ offsets @@ -207,7 +206,7 @@ polySidesTrail ans ls = tr `at` (centroid ps # scale (-1)) -- | Generate the vertices of a regular polygon. See 'PolyRegular'. polyRegularTrail :: Int -> Double -> Located (Trail R2) polyRegularTrail n r = polyPolarTrail - (take (n-1) . repeat $ fullTurn / fromIntegral n) + (take (n-1) . repeat $ fullTurn ^/ fromIntegral n) (repeat r) -- | Generate a transformation to orient a trail. @orient v t@ @@ -224,14 +223,18 @@ orientPoints v xs = rotation a (zip3 (tail (cycle xs)) xs (last xs : init xs)) distAlong w ((.-. origin) -> p) = signum (w <.> p) * magnitude (project w p) sndOf3 (_,b,_) = b - a = minimumBy (comparing abs) . map (angleFromNormal . (.-. x)) $ [n1,n2] + a :: Angle + a = minimumBy (comparing $ abs . view rad) + . map (angleFromNormal . (.-. x)) $ [n1,n2] v' = normalized v + angleFromNormal :: R2 -> Angle angleFromNormal o | leftTurn o' v' = phi - | otherwise = negate phi + | otherwise = negateV phi where o' = normalized o theta = acos (v' <.> o') + phi :: Angle phi | theta <= tau/4 = tau/4 - theta @@ rad | otherwise = theta - tau/4 @@ rad diff --git a/src/Diagrams/TwoD/Segment.hs b/src/Diagrams/TwoD/Segment.hs index 3aaffdca..7257e2e2 100644 --- a/src/Diagrams/TwoD/Segment.hs +++ b/src/Diagrams/TwoD/Segment.hs @@ -93,7 +93,7 @@ instance Traced (FixedSegment R2) where let bez'@(FCubic x1 c1 c2 x2) = bez # moveOriginTo p1 - # rotate (negate (direction v1)) + # rotate (negateV (direction v1)) # scale (1/magnitude v1) [y0,y1,y2,y3] = map (snd . unp2) [x1,c1,c2,x2] a = -y0 + 3*y1 - 3*y2 + y3 diff --git a/src/Diagrams/TwoD/Transform.hs b/src/Diagrams/TwoD/Transform.hs index 6427036d..49e7fe39 100644 --- a/src/Diagrams/TwoD/Transform.hs +++ b/src/Diagrams/TwoD/Transform.hs @@ -59,6 +59,7 @@ import Diagrams.TwoD.Types import Diagrams.TwoD.Vector (direction) import Diagrams.Coordinates +import Data.AdditiveGroup import Data.AffineSpace import Data.Semigroup import Control.Lens (review, (^.)) @@ -204,7 +205,7 @@ reflectY = transform reflectionY -- the point @p@ and vector @v@. reflectionAbout :: P2 -> R2 -> T2 reflectionAbout p v = - conjugate (rotation (-direction v) <> translation (origin .-. p)) + conjugate (rotation (negateV $ direction v) <> translation (origin .-. p)) reflectionY -- | @reflectAbout p v@ reflects a diagram in the line determined by diff --git a/src/Diagrams/TwoD/Transform/ScaleInv.hs b/src/Diagrams/TwoD/Transform/ScaleInv.hs index 8b30ce57..962e09c2 100644 --- a/src/Diagrams/TwoD/Transform/ScaleInv.hs +++ b/src/Diagrams/TwoD/Transform/ScaleInv.hs @@ -20,6 +20,7 @@ module Diagrams.TwoD.Transform.ScaleInv where import Control.Lens (makeLenses, view) +import Data.AdditiveGroup import Data.AffineSpace ((.-.)) import Data.Semigroup @@ -82,7 +83,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 = direction (transform tr v) ^-^ direction v rot :: (Transformable t, V t ~ R2) => t -> t rot = rotateAbout l angle l' = transform tr l diff --git a/src/Diagrams/TwoD/Vector.hs b/src/Diagrams/TwoD/Vector.hs index b94eaaf5..9d4a7ee1 100644 --- a/src/Diagrams/TwoD/Vector.hs +++ b/src/Diagrams/TwoD/Vector.hs @@ -23,6 +23,7 @@ module Diagrams.TwoD.Vector ) where import Control.Lens ((^.)) +import Data.AdditiveGroup import Data.VectorSpace ((<.>)) import Diagrams.TwoD.Types import Diagrams.Coordinates @@ -52,8 +53,8 @@ direction (coords -> x :& y) = atan2 y x @@ rad -- | Compute the counterclockwise angle from the first vector to the second. angleBetween :: R2 -> R2 -> Angle angleBetween v1 v2 - | d2 > d1 = d2 - d1 - | otherwise = fullTurn + d2 - d1 + | d2 > d1 = d2 ^-^ d1 + | otherwise = fullTurn ^+^ d2 ^-^ d1 where d1 = direction v1 d2 = direction v2