diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,27 @@ +0.42.0 to 0.42.1: + + * Fixed bug in the @curvedPath@ function in @Core.Picture@ + where the wrong relative point was being calculated for the + second control point. + + * Changed internals of the @EscapedText@ type so it supports + efficient concatenation, and now has a Monoid instance. + +0.41.0 to 0.42.0: + + * Removed the function @oboundingBox@ from @Core.BoundingBox@. + It was unused in Wumpus-Core and had unwise error handling + baked-in. + + * Renamed @direction@ in @Wumpus.Core.Geometry@, it is now + @vdirection@. + + * Fixed internal Foldable instances for JoinList. The left and + right folds worked in the wrong direction. + + * Some improvements to the Haddock documentation. + 0.40.0 to 0.41.0: * Changed PostScript output to use pre-defined procedures for diff --git a/demo/EllipsePic.hs b/demo/EllipsePic.hs new file mode 100644 --- /dev/null +++ b/demo/EllipsePic.hs @@ -0,0 +1,38 @@ +{-# OPTIONS -Wall #-} + +module EllipsePic where + +import Wumpus.Core +import Wumpus.Core.Colour + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out" + writeEPS "./out/ellipse01.eps" pic1 + writeSVG "./out/ellipse01.svg" pic1 + + +pic1 :: DPicture +pic1 = frame [ ellipse01 $ P2 50 50 + , ellipse02 $ P2 100 50 + , ellipse03 $ P2 150 50 + ] + + +ellipse01 :: DPoint2 -> DPrimitive +ellipse01 pt = cstroke black default_stroke_attr $ + curvedPath $ bezierEllipse 20 30 pt + + +ellipse02 :: DPoint2 -> DPrimitive +ellipse02 pt = cstroke red default_stroke_attr $ + curvedPath $ rbezierEllipse 20 30 0 pt + + + +ellipse03 :: DPoint2 -> DPrimitive +ellipse03 pt = cstroke red default_stroke_attr $ + curvedPath $ rbezierEllipse 20 30 (negate $ d2r (10::Double)) pt + diff --git a/src/Wumpus/Core/Geometry.hs b/src/Wumpus/Core/Geometry.hs --- a/src/Wumpus/Core/Geometry.hs +++ b/src/Wumpus/Core/Geometry.hs @@ -83,9 +83,13 @@ , circularModulo -- * Bezier curves - , bezierArc , bezierCircle + , bezierEllipse + , rbezierEllipse + , bezierArc + , subdivisionCircle + ) where @@ -749,6 +753,109 @@ -------------------------------------------------------------------------------- -- Bezier curves + + +kappa :: Floating u => u +kappa = 4 * ((sqrt 2 - 1) / 3) + + +-- | 'bezierCircle' : @ radius * center -> [Point] @ +-- +-- Make a circle from four Bezier curves. Although this function +-- produces an approximation of a circle, the approximation seems +-- fine in practice. +-- +bezierCircle :: (Fractional u, Floating u) + => u -> Point2 u -> [Point2 u] +bezierCircle radius (P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + rl = radius * kappa + p00 = P2 (x + radius) y + c01 = p00 .+^ vvec rl + c02 = p03 .+^ hvec rl + + p03 = P2 x (y + radius) + c04 = p03 .+^ hvec (-rl) + c05 = p06 .+^ vvec rl + + p06 = P2 (x - radius) y + c07 = p06 .+^ vvec (-rl) + c08 = p09 .+^ hvec (-rl) + + p09 = P2 x (y - radius) + c10 = p09 .+^ hvec rl + c11 = p00 .+^ vvec (-rl) + + +-- | 'bezierEllipse' : @ x_radius * y_radius * center -> [Point] @ +-- +-- Make an ellipse from four Bezier curves. Although this function +-- produces an approximation of a ellipse, the approximation seems +-- fine in practice. +-- +bezierEllipse :: (Fractional u, Floating u) + => u -> u -> Point2 u -> [Point2 u] +bezierEllipse rx ry (P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + lrx = rx * kappa + lry = ry * kappa + p00 = P2 (x + rx) y + c01 = p00 .+^ vvec lry + c02 = p03 .+^ hvec lrx + + p03 = P2 x (y + ry) + c04 = p03 .+^ hvec (-lrx) + c05 = p06 .+^ vvec lry + + p06 = P2 (x - rx) y + c07 = p06 .+^ vvec (-lry) + c08 = p09 .+^ hvec (-lrx) + + p09 = P2 x (y - ry) + c10 = p09 .+^ hvec lrx + c11 = p00 .+^ vvec (-lry) + +-- | 'rbezierEllipse' : @ x_radius * y_radius * center * angle -> [Point] @ +-- +-- Make an rotated ellipse from four Bezier curves. +-- +-- Although this function produces an approximation of a ellipse, +-- the approximation seems fine in practice. +-- +rbezierEllipse :: (Real u, Floating u) + => u -> u -> Radian -> Point2 u -> [Point2 u] +rbezierEllipse rx ry theta pt@(P2 x y) = + [ p00,c01,c02, p03,c04,c05, p06,c07,c08, p09,c10,c11, p00 ] + where + lrx = rx * kappa + lry = ry * kappa + rotM = originatedRotationMatrix theta pt + + -- hvec becomes para + para = \d -> avec theta d + -- vvec becomes perp + perp = \d -> avec (circularModulo $ theta + pi*0.5) d + mkPt = \p1 -> rotM *# p1 + + p00 = mkPt $ P2 (x + rx) y + c01 = p00 .+^ perp lry + c02 = p03 .+^ para lrx + + p03 = mkPt $ P2 x (y + ry) + c04 = p03 .+^ para (-lrx) + c05 = p06 .+^ perp lry + + p06 = mkPt $ P2 (x - rx) y + c07 = p06 .+^ perp (-lry) + c08 = p09 .+^ para (-lrx) + + p09 = mkPt $ P2 x (y - ry) + c10 = p09 .+^ para lrx + c11 = p00 .+^ perp (-lry) + + -- | 'bezierArc' : @ radius * ang1 * ang2 * center -> -- (start_point, control_point1, control_point2, end_point) @ -- @@ -764,23 +871,29 @@ bezierArc r ang1 ang2 pt = (p0,p1,p2,p3) where theta = ang2 - ang1 - e = r * fromRadian ((2 * sin (theta/2)) / (1+ 2* cos (theta/2))) + e = r * fromRadian ((2 * sin (theta/2)) / (1+ 2 * cos (theta/2))) p0 = pt .+^ avec ang1 r p1 = p0 .+^ avec (ang1 + pi/2) e p2 = p3 .+^ avec (ang2 - pi/2) e p3 = pt .+^ avec ang2 r --- | 'bezierCircle' : @ subdivisions * radius * center -> [Point] @ +-- | 'subvisionCircle' : @ subdivisions * radius * center -> [Point] @ -- -- Make a circle from Bezier curves - the number of subdivsions -- controls the accuracy or the curve, more subdivisions produce -- better curves, but less subdivisions are better for rendering -- (producing more efficient PostScript). -- -bezierCircle :: (Fractional u, Floating u) - => Int -> u -> Point2 u -> [Point2 u] -bezierCircle n radius pt = start $ subdivisions (n*4) (2*pi) +-- Before revision 0.43.0, this was the only method in Wumpus to +-- draw Bezier circles in Wumpus. However the kappa method seems +-- to draw equally good circles and is more efficient both in the +-- Haskell implementation and the generated PostScript code. This +-- function is retained for completeness and testing. +-- +subdivisionCircle :: (Fractional u, Floating u) + => Int -> u -> Point2 u -> [Point2 u] +subdivisionCircle n radius pt = start $ subdivisions (n*4) (2*pi) where start (a:b:xs) = s : cp1 : cp2 : e : rest (b:xs) where (s,cp1,cp2,e) = bezierArc radius a b pt diff --git a/src/Wumpus/Core/Picture.hs b/src/Wumpus/Core/Picture.hs --- a/src/Wumpus/Core/Picture.hs +++ b/src/Wumpus/Core/Picture.hs @@ -473,7 +473,7 @@ => RGBi -> FontAttr -> String -> Point2 u -> Primitive u textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt --- | 'rtextlabel' : @ rgb * font_attr * string * rotation * +-- | 'rtextlabel' : @ rgb * font_attr * string * theta * -- baseline_left -> Primitive @ -- -- Create a text label rotated by the supplied angle about the @@ -509,7 +509,7 @@ => RGBi -> FontAttr -> EscapedText -> Point2 u -> Primitive u escapedlabel rgb attr txt pt = rescapedlabel rgb attr txt 0 pt --- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * rotation * +-- | 'rescapedlabel' : @ rgb * font_attr * escaped_text * theta * -- baseline_left -> Primitive @ -- -- Version of 'rtextlabel' where the label text has already been @@ -653,14 +653,15 @@ -- -- Note - within Wumpus, ellipses are considered an unfortunate -- but useful /optimization/. Drawing good cicles with Beziers --- needs at least eight curves, but drawing them with --- PostScript\'s @arc@ command needs a single operation. For --- drawings with many dots (e.g. scatter plots) it seems sensible --- to employ this optimization. +-- needs four curves, but drawing them with PostScript\'s @arc@ +-- command uses a single operation. For drawings with many dots +-- (e.g. scatter plots) it seems sensible to employ this +-- optimization. -- --- A deficiency of Wumpus\'s ellipse is that (non-uniformly) --- scaling a stroked ellipse also (non-uniformly) scales the pen --- it is drawn with. Where the ellipse is wider, the pen stroke +-- A deficiency of using PostScript\'s @arc@ command to draw +-- ellipses is that (non-uniformly) scaling a stroked ellipse +-- also (non-uniformly) scales the pen it is drawn with. Where +-- the ellipse is wider, the pen stroke -- will be wider too. -- -- Avoid non-uniform scaling stroked ellipses! @@ -670,10 +671,11 @@ strokeEllipse rgb sa hw hh pt = rstrokeEllipse rgb sa hw hh 0 pt --- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * rotation * +-- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * theta * -- center -> Primtive @ -- --- Create a stroked ellipse rotated about the center by /theta/. +-- Create a stroked primitive ellipse rotated about the center by +-- /theta/. -- rstrokeEllipse :: Num u => RGBi -> StrokeAttr -> u -> u -> Radian -> Point2 u @@ -685,17 +687,18 @@ -- | 'fillEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @ -- --- Create a filled ellipse. +-- Create a filled primitive ellipse. -- fillEllipse :: Num u => RGBi -> u -> u -> Point2 u -> Primitive u fillEllipse rgb rx ry pt = rfillEllipse rgb rx ry 0 pt --- | 'rfillEllipse' : @ colour * stroke_attr * rx * ry * --- rotation * center -> Primtive @ +-- | 'rfillEllipse' : @ colour * stroke_attr * rx * ry * theta * center +-- -> Primitive @ -- --- Create a filled ellipse rotated about the center by /theta/. +-- Create a filled primitive ellipse rotated about the center by +-- /theta/. -- rfillEllipse :: Num u => RGBi -> u -> u -> Radian -> Point2 u -> Primitive u @@ -714,7 +717,7 @@ -- | 'fillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry * -- center -> Primtive @ -- --- Create a bordered (i.e. filled and stroked) ellipse. +-- Create a bordered (i.e. filled and stroked) primitive ellipse. -- fillStrokeEllipse :: Num u => RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u diff --git a/src/Wumpus/Core/VersionNumber.hs b/src/Wumpus/Core/VersionNumber.hs --- a/src/Wumpus/Core/VersionNumber.hs +++ b/src/Wumpus/Core/VersionNumber.hs @@ -22,7 +22,7 @@ -- | Version number. -- --- > (0,42,1) +-- > (0,43,0) -- wumpus_core_version :: (Int,Int,Int) -wumpus_core_version = (0,42,1) +wumpus_core_version = (0,43,0) diff --git a/wumpus-core.cabal b/wumpus-core.cabal --- a/wumpus-core.cabal +++ b/wumpus-core.cabal @@ -1,5 +1,5 @@ name: wumpus-core -version: 0.42.1 +version: 0.43.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -48,29 +48,17 @@ . Changelog: . - v0.42.0 to v0.42.1: - . - * Fixed bug in the @curvedPath@ function in @Core.Picture@ - where the wrong relative point was being calculated for the - second control point. + v0.42.1 to v0.43.0: . - * Changed internals of the @EscapedText@ type so it supports - efficient concatenation, and now has a Monoid instance. + * API change - the function @bezierCircle@ in @Core.Geometry@ + has changed. It now implements a better method of drawing + circles with Bezier curves and no longer needs the + subvision factor. The old circle drawing function has been + retained as @subdivisionCircle@ as it is useful for + corroborating @bezierCircle@, but the general use of + @subdivisionCircle@ should be avoided. . - v0.41.0 to v0.42.0: - . - * Removed the function @oboundingBox@ from @Core.BoundingBox@. - It was unused in Wumpus-Core and had unwise error handling - baked-in. - . - * Renamed @direction@ in @Wumpus.Core.Geometry@, it is now - @vdirection@. - . - * Fixed internal Foldable instances for JoinList. The left and - right folds worked in the wrong direction. - . - * Some improvements to the Haddock documentation. - . + * Added a function @bezierEllipse@ to @Core.Geometry@. . build-type: Simple stability: unstable @@ -84,6 +72,7 @@ demo/AffineTest03.hs, demo/AffineTestBase.hs, demo/DeltaPic.hs, + demo/EllipsePic.hs, demo/FontMetrics.hs, demo/Hyperlink.hs, demo/KernPic.hs,