wumpus-core-0.36.0: src/Wumpus/Core/Picture.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Core.Picture
-- Copyright : (c) Stephen Tetley 2009-2010
-- License : BSD3
--
-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>
-- Stability : highly unstable
-- Portability : GHC
--
-- Construction of pictures, paths and text labels.
--
--------------------------------------------------------------------------------
module Wumpus.Core.Picture
(
-- * Construction
frame
, multi
, fontDeltaContext
, path
, lineTo
, curveTo
, vertexPath
, curvedPath
, xlinkhref
, xlinkGroup
, primGroup
-- * Constructing primitives
, ostroke
, cstroke
, zostroke
, zcstroke
, fill
, zfill
, fillStroke
, clip
, textlabel
, rtextlabel
, ztextlabel
, hkernlabel
, vkernlabel
, kernchar
, kernEscInt
, kernEscName
, strokeEllipse
, rstrokeEllipse
, fillEllipse
, rfillEllipse
, zellipse
, fillStrokeEllipse
, rfillStrokeEllipse
-- * Operations
, extendBoundary
-- * Picture composition
, picOver
, picMoveBy
, picBeside
-- * Illustrating pictures and primitives
, printPicture
, illustrateBounds
, illustrateBoundsPrim
, illustrateControlPoints
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicProps
import Wumpus.Core.PictureInternal
import Wumpus.Core.PtSize
import Wumpus.Core.Text.TextInternal
import Wumpus.Core.TrafoInternal
import Wumpus.Core.Utils.Common
import Wumpus.Core.Utils.FormatCombinators hiding ( fill )
import Wumpus.Core.Utils.OneList
import Data.AffineSpace -- package: vector-space
--------------------------------------------------------------------------------
-- Construction
-- | Lift a list of primitives to a composite picture.
--
-- The order of the list maps to the order of printing - the
-- front of the list is drawn first in the file. This also means
-- that the front of the list is drawn /at the back/ in the
-- Z-Order.
--
-- This function throws an error when supplied the empty list.
--
frame :: (Real u, Floating u, FromPtSize u) => [Primitive u] -> Picture u
frame [] = error "Wumpus.Core.Picture.frame - empty list"
frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones
where
step a [] = (boundary a, one a)
step a (x:xs) = let (bb', rest) = step x xs
in ( boundary a `boundaryUnion` bb', cons a rest )
-- | Place multiple pictures within the standard affine frame.
--
-- This function throws an error when supplied the empty list.
--
multi :: (Fractional u, Ord u) => [Picture u] -> Picture u
multi [] = error "Wumpus.Core.Picture.multi - empty list"
multi (p:ps) = let (bb,ones) = step p ps in Picture (bb,[]) ones
where
step a [] = (boundary a, one a)
step a (x:xs) = let (bb', rest) = step x xs
in ( boundary a `boundaryUnion` bb', cons a rest )
-- | Update the font /delta/ attributes for SVG output.
--
-- Note - 'fontDeltaContext' does not set the font properties of
-- elements in the supplied Picture, it is solely a mechanism to
-- help reduce the code size of the generated SVG by factoring
-- common attributes into a group (g) element. For instance,
-- settting the font properties with 'fontDeltaContext' can
-- eliminate the repeated use of font-family and font-size in
-- this code:
--
-- > <text font-family="Helvetica" font-size="12"> ... </text>
-- > <text font-family="Helvetica" font-size="12"> ... </text>
-- > <text font-family="Helvetica" font-size="12"> ... </text>
--
-- With the appropriate font delta context, this code will be
-- generated:
--
-- > <g font-family="Helvetica" font-size="12">
-- > <text > ... </text>
-- > <text > ... </text>
-- > <text > ... </text>
-- > </g>
--
-- Wumpus ignores 'fontDeltaContext' directives when generating
-- PostScript. Unlike SVG, PostScript is not naturally nested, so
-- introducing nesting with @gsave@ and @grestore@ is not likely
-- to improve the PostScript Wumpus generates.
--
fontDeltaContext :: FontAttr -> Picture u -> Picture u
fontDeltaContext fa p = Group (boundary p, []) (FontCtx fa) p
-- | Create a Path from a start point and a list of PathSegments.
--
path :: Point2 u -> [PrimPathSegment u] -> PrimPath u
path = PrimPath
-- | 'lineTo' : @ end_point -> path_segment @
--
-- Create a straight-line PathSegment, the start point is
-- implicitly the previous point in a path.
--
lineTo :: Point2 u -> PrimPathSegment u
lineTo = PLineTo
-- | 'curveTo' : @ control_point1 * control_point2 * end_point ->
-- path_segment @
--
-- Create a curved PathSegment, the start point is
-- implicitly the previous point in a path.
--
--
curveTo :: Point2 u -> Point2 u -> Point2 u -> PrimPathSegment u
curveTo = PCurveTo
-- | Convert the list of vertices to a path of straight line
-- segments.
--
vertexPath :: [Point2 u] -> PrimPath u
vertexPath [] = error "Picture.vertexPath - empty point list"
vertexPath (x:xs) = PrimPath x (map PLineTo xs)
-- | Convert a list of vertices to a path of curve segments.
-- The first point in the list makes the start point, each curve
-- segment thereafter takes 3 points. /Spare/ points at the end
-- are discarded.
--
curvedPath :: [Point2 u] -> PrimPath u
curvedPath [] = error "Picture.curvedPath - empty point list"
curvedPath (x:xs) = PrimPath x (step xs)
where
step (a:b:c:ys) = PCurveTo a b c : step ys
step _ = []
-- | Create a hyperlink for SVG output.
--
xlinkhref :: String -> XLink
xlinkhref = XLink
-- | Create a hyperlinked group of Primitives.
--
-- This function throws a runtime error when supplied with an
-- empty list.
--
xlinkGroup :: XLink -> [Primitive u] -> Primitive u
xlinkGroup _ [] = error "Picture.xlinkGroup - empty prims list"
xlinkGroup xlink (x:xs) = PGroup (Just xlink) (step x xs)
where
step a [] = one a
step a (y:ys) = cons a (step y ys)
-- | Group a list of Primitives.
--
-- This function throws a runtime error when supplied with an
-- empty list.
--
primGroup :: [Primitive u] -> Primitive u
primGroup [] = error "Picture.primGroup - empty prims list"
primGroup (x:xs) = PGroup Nothing (step x xs)
where
step a [] = one a
step a (y:ys) = cons a (step y ys)
--------------------------------------------------------------------------------
-- Take Paths to Primitives
-- *** Stroke
-- | 'ostroke' : @ rgb * stroke_attr * path -> Primitive @
--
-- Create a open, stroked path.
--
ostroke :: Num u
=> RGBi -> StrokeAttr -> PrimPath u -> Primitive u
ostroke rgb sa p = PPath (OStroke sa rgb) p
-- | 'cstroke' : @ rgb * stroke_attr * path -> Primitive @
--
-- Create a closed, stroked path.
--
cstroke :: Num u
=> RGBi -> StrokeAttr -> PrimPath u -> Primitive u
cstroke rgb sa p = PPath (CStroke sa rgb) p
-- | 'zostroke' : @ path -> Primitive @
--
-- Create an open, stroked path using the default stroke
-- attributes and coloured black.
--
zostroke :: Num u => PrimPath u -> Primitive u
zostroke = ostroke black default_stroke_attr
-- | 'zcstroke' : @ path -> Primitive @
--
-- Create a closed stroked path using the default stroke
-- attributes and coloured black.
--
zcstroke :: Num u => PrimPath u -> Primitive u
zcstroke = cstroke black default_stroke_attr
--------------------------------------------------------------------------------
-- *** Fill
-- | 'fill' : @ rgb * path -> Primitive @
--
-- Create a filled path.
--
fill :: Num u => RGBi -> PrimPath u -> Primitive u
fill rgb p = PPath (CFill rgb) p
-- | 'zfill' : @ path -> Primitive @
--
-- Create a filled path coloured black.
zfill :: Num u => PrimPath u -> Primitive u
zfill = fill black
--------------------------------------------------------------------------------
-- Filled and stroked (closed) paths
-- | 'fillStroke' : @ fill_rgb * stroke_attr * stroke_rgb * path -> Primitive @
--
-- Create a closed path that is both filled and stroked (the fill
-- is below in the zorder).
--
fillStroke :: Num u
=> RGBi -> StrokeAttr -> RGBi -> PrimPath u -> Primitive u
fillStroke frgb sa srgb p = PPath (CFillStroke frgb sa srgb) p
--------------------------------------------------------------------------------
-- Clipping
-- | 'clip' : @ path * picture -> Picture @
--
-- Clip a picture with respect to the supplied path.
--
clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u
clip cp p = Clip (pathBoundary cp, []) cp p
--------------------------------------------------------------------------------
-- Labels to primitive
-- | 'textlabel' : @ rgb * font_attr * string * baseline_left -> Primitive @
--
-- Create a text label. The string should not contain newline
-- or tab characters. Also double-spaces should not be used - a
-- rendering agent for SVG will coalesce double-spaces into a
-- single space. For precise control of spacing and kerning use
-- 'hkernlabel'.
--
-- The supplied point is the left baseline.
--
textlabel :: Num u
=> RGBi -> FontAttr -> String -> Point2 u -> Primitive u
textlabel rgb attr txt pt = rtextlabel rgb attr txt 0 pt
-- | 'rtextlabel' : @ rgb * font_attr * string * rotation *
-- baseline_left -> Primitive @
--
-- Create a text label rotated by the supplied angle about the
-- baseline-left.
--
-- The supplied point is the left baseline.
--
rtextlabel :: Num u
=> RGBi -> FontAttr -> String -> Radian -> Point2 u -> Primitive u
rtextlabel rgb attr txt theta pt = PLabel (LabelProps rgb attr) lbl
where
lbl = PrimLabel pt (StdLayout $ lexLabel txt) (thetaCTM theta)
-- | 'ztextlabel' : @ string * baseline_left -> Primitive @
--
-- Create a label where the font is @Courier@, text size is 14pt
-- and colour is black.
--
ztextlabel :: Num u => String -> Point2 u -> Primitive u
ztextlabel = textlabel black wumpus_default_font
--------------------------------------------------------------------------------
-- | 'hkernlabel' : @ rgb * font_attr * kerning_chars *
-- baseline_left -> Primitive @
--
-- Create a text label with horizontal /kerning/ for each
-- character.
--
-- Note - kerning is relative to the left baseline of the
-- previous character, it is \*not relative\* to the right-hand
-- boundary of the previous char. While the later would be more
-- obvious it would take a lot of effort to implement as it would
-- need access to the metrics encoded in font files.
--
-- Characters are expected to be drawn left to right, so
-- displacements should not be negative. If the displacement is
-- zero the character will be drawn ontop of the previous char.
--
-- The charcters should not contain newline or tab characters.
--
-- The supplied point is the left baseline.
--
-- \*\* CAUTION \*\* - @hkernlabel@ generates a coordinate list
-- for X-positions rather than a single start point. This is
-- perfectly valid SVG, but it is not universally supported by
-- renderers. Chrome support is fine, but Firefox and Safari
-- currently seem lacking.
--
hkernlabel :: Num u
=> RGBi -> FontAttr -> [KerningChar u] -> Point2 u
-> Primitive u
hkernlabel rgb attr xs pt = PLabel (LabelProps rgb attr) lbl
where
lbl = PrimLabel pt (KernTextH xs) identityCTM
-- | 'vkernlabel' : @ rgb * font_attr * kerning_chars *
-- baseline_left -> Primitive @
--
-- Create a text label with vertical /kerning/ for each
-- character - the text is expected to grow downwards.
--
-- Note - /kerning/ here is the measure between baselines of
-- sucessive characters, it is \*not\* the distance between the
-- bottom of one chararter and the top of the next character.
--
-- While the later maybe be more obvious from a drawing
-- perspective, it would take a lot of effort to implement as it
-- would need access to the metrics encoded in font files.
--
-- Characters are expected to be drawn downwards - a positive
-- number represents the downward displacement - so displacements
-- should not be negative. If the displacement is zero the
-- character will be drawn ontop of the previous char.
--
-- The charcters should not contain newline or tab characters.
--
-- The supplied point is the left baseline of the top character.
--
-- \*\* CAUTION \*\* - @vkernlabel@ generates a coordinate list
-- for Y-positions rather than a single start point. This is
-- perfectly valid SVG, but it is not universally supported by
-- renderers. Chrome support is fine, but Firefox and Safari
-- currently seem lacking.
--
vkernlabel :: Num u
=> RGBi -> FontAttr -> [KerningChar u] -> Point2 u
-> Primitive u
vkernlabel rgb attr xs pt = PLabel (LabelProps rgb attr) lbl
where
lbl = PrimLabel pt (KernTextV xs) identityCTM
-- | 'kernchar' : @ displacement * char -> KerningChar @
--
-- Construct a regular (i.e. non-special) Char along with its
-- displacement from the left-baseline of the previous Char.
--
kernchar :: u -> Char -> KerningChar u
kernchar u c = (u, CharLiteral c)
-- | 'kernEscInt' : @ displacement * char_code -> KerningChar @
--
-- Construct a Char by its character code along with its
-- displacement from the left-baseline of the previous Char.
--
kernEscInt :: u -> Int -> KerningChar u
kernEscInt u i = (u, CharEscInt i)
-- | 'kernEscName' : @ displacement * char_name -> KerningChar @
--
-- Construct a Char by its character name along with its
-- displacement from the left-baseline of the previous Char.
--
kernEscName :: u -> String -> KerningChar u
kernEscName u s = (u, CharEscName s)
--------------------------------------------------------------------------------
-- | 'strokeEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @
--
-- Create a stroked ellipse.
--
-- 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.
--
-- 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
-- will be wider too.
--
-- Avoid non-uniform scaling stroked ellipses!
--
strokeEllipse :: Num u
=> RGBi -> StrokeAttr -> u -> u -> Point2 u -> Primitive u
strokeEllipse rgb sa hw hh pt = rstrokeEllipse rgb sa hw hh 0 pt
-- | 'rstrokeEllipse' : @ rgb * stroke_attr * rx * ry * rotation *
-- center -> Primtive @
--
-- Create a stroked ellipse rotated about the center by /theta/.
--
rstrokeEllipse :: Num u
=> RGBi -> StrokeAttr -> u -> u -> Radian -> Point2 u
-> Primitive u
rstrokeEllipse rgb sa rx ry theta pt =
PEllipse (EStroke sa rgb) (mkPrimEllipse rx ry theta pt)
-- | 'fillEllipse' : @ rgb * stroke_attr * rx * ry * center -> Primtive @
--
-- Create a filled 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 @
--
-- Create a filled ellipse rotated about the center by /theta/.
--
rfillEllipse :: Num u
=> RGBi -> u -> u -> Radian -> Point2 u -> Primitive u
rfillEllipse rgb rx ry theta pt =
PEllipse (EFill rgb) (mkPrimEllipse rx ry theta pt)
-- | 'zellipse' : @ rx * ry * center -> Primtive @
--
-- Create a black, filled ellipse.
--
zellipse :: Num u => u -> u -> Point2 u -> Primitive u
zellipse hw hh pt = rfillEllipse black hw hh 0 pt
-- | 'fillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry *
-- center -> Primtive @
--
-- Create a bordered (i.e. filled and stroked) ellipse.
--
fillStrokeEllipse :: Num u
=> RGBi -> StrokeAttr -> RGBi -> u -> u -> Point2 u
-> Primitive u
fillStrokeEllipse frgb sa srgb rx ry pt =
rfillStrokeEllipse frgb sa srgb rx ry 0 pt
-- | 'rfillStrokeEllipse' : @ fill_rgb * stroke_attr * stroke_rgb * rx * ry *
-- theta * center -> Primtive @
--
-- Create a bordered (i.e. filled and stroked) ellipse rotated
-- about the center by /theta/.
--
rfillStrokeEllipse :: Num u
=> RGBi -> StrokeAttr -> RGBi -> u -> u -> Radian -> Point2 u
-> Primitive u
rfillStrokeEllipse frgb sa srgb rx ry theta pt =
PEllipse (EFillStroke frgb sa srgb) (mkPrimEllipse rx ry theta pt)
mkPrimEllipse :: Num u => u -> u -> Radian -> Point2 u -> PrimEllipse u
mkPrimEllipse rx ry theta pt = PrimEllipse pt rx ry (thetaCTM theta)
--------------------------------------------------------------------------------
-- Operations
-- | 'extendBoundary' : @ x * y * picture -> Picture @
--
-- Extend the bounding box of a picture.
--
-- The bounding box is both horizontal directions by @x@ and
-- both vertical directions by @y@. @x@ and @y@ must be positive
-- This function cannot be used to shrink a boundary.
--
extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs))
where
extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where
pt1 = P2 (x0-x') (y0-y')
pt2 = P2 (x1+x') (y1+y')
posve n | n < 0 = 0
| otherwise = n
--------------------------------------------------------------------------------
-- Minimal support for Picture composition
infixr 6 `picBeside`, `picOver`
-- | 'picOver' : @ picture * picture -> Picture @
--
-- Draw the first picture on top of the second picture -
-- neither picture will be moved.
--
picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `picOver` b = Picture (bb,[]) (cons b $ one a)
where
bb = boundary a `boundaryUnion` boundary b
-- picOver note - draw b, put b first in the list, so it draws
-- first in the output (this is also @behind@ in the Z-Order).
-- | 'picMoveBy' : @ picture * vector -> Picture @
--
-- Move a picture by the supplied vector.
--
picMoveBy :: (Num u, Ord u) => Picture u -> Vec2 u -> Picture u
p `picMoveBy` (V2 dx dy) = translate dx dy p
-- | 'picBeside' : @ picture * picture -> Picture @
--
-- Move the second picture to sit at the right side of the
-- first picture
--
picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `picBeside` b = a `picOver` (b `picMoveBy` v)
where
(P2 x1 _) = ur_corner $ boundary a
(P2 x2 _) = ll_corner $ boundary b
v = hvec $ x1 - x2
--------------------------------------------------------------------------------
-- Illustrating pictures and primitives
-- | Print the syntax tree of a Picture to the console.
--
printPicture :: (Num u, PSUnit u) => Picture u -> IO ()
printPicture pic = putStrLn (show $ format pic) >> putStrLn []
-- | 'illustrateBounds' : @ bbox_rgb * picture -> Picture @
--
-- Draw the picture on top of an image of its bounding box.
-- The bounding box image will be drawn in the supplied colour.
--
illustrateBounds :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Picture u -> Picture u
illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p)
-- | 'illustrateBoundsPrim' : @ bbox_rgb * primitive -> Picture @
--
-- Draw the primitive on top of an image of its bounding box.
-- The bounding box image will be drawn in the supplied colour.
--
-- The result will be lifted from Primitive to Picture.
--
illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Primitive u -> Picture u
illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb p)
-- | Draw a the rectangle of a bounding box, plus cross lines
-- joining the corners.
--
boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t)
=> RGBi -> t -> [Primitive u]
boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]
where
(bl,br,tr,tl) = boundaryCorners $ boundary a
bbox_rect = cstroke rgb line_attr $ vertexPath [bl,br,tr,tl]
bl_to_tr = ostroke rgb line_attr $ vertexPath [bl,tr]
br_to_tl = ostroke rgb line_attr $ vertexPath [br,tl]
line_attr = default_stroke_attr { line_cap = CapRound
, dash_pattern = Dash 0 [(1,2)] }
-- | 'illustrateControlPoints' : @ control_point_rgb * primitive -> Picture @
--
-- Generate the control points illustrating the Bezier curves
-- within a picture.
--
-- This has no effect on TextLabels. Nor does it draw Beziers of
-- a hyperlinked object.
--
-- Pseudo control points are generated for ellipses, although
-- strictly speaking ellipses do not use Bezier curves - they
-- are implemented with PostScript\'s @arc@ command.
--
illustrateControlPoints :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Primitive u -> Picture u
illustrateControlPoints rgb elt = frame $ step elt
where
step (PEllipse _ e) = ellipseCtrlLines rgb e
step (PPath _ p) = pathCtrlLines rgb p
step a = [a]
-- Genrate lines illustrating the control points of curves on
-- a Path.
--
-- Two lines are generated for a Bezier curve:
-- start-point to control-point1; control-point2 to end-point
--
-- Nothing is generated for a straight line.
--
pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [Primitive u]
pathCtrlLines rgb (PrimPath start ss) = step start ss
where
-- trail the current end point through the recursion...
step _ [] = []
step _ (PLineTo e:xs) = step e xs
step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs
mkLine s e = let pp = (PrimPath s [lineTo e]) in
ostroke rgb default_stroke_attr pp
-- Generate lines illustrating the control points of an
-- ellipse:
--
-- Two lines for each quadrant:
-- start-point to control-point1; control-point2 to end-point
--
ellipseCtrlLines :: (Real u, Floating u)
=> RGBi -> PrimEllipse u -> [Primitive u]
ellipseCtrlLines rgb pe = start all_points
where
-- list in order:
-- [s,cp1,cp2,e, cp1,cp2,e, cp1,cp2,e, cp1,cp2,e]
all_points = ellipseControlPoints pe
start (s:c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs
start _ = []
rest s (c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs
rest _ _ = []
mkLine s e = ostroke rgb default_stroke_attr (PrimPath s [lineTo e])
-- | Get the control points as a list
--
-- There are no duplicates in the list except for the final
-- /wrap-around/. We take 4 points initially (start,cp1,cp2,end)
-- then (cp1,cp2,end) for the other three quadrants.
--
ellipseControlPoints :: (Floating u, Real u)
=> PrimEllipse u -> [Point2 u]
ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) =
map (disp . (new_mtrx *#)) circ
where
disp = (.+^ V2 x y)
(radius,(dx,dy)) = circleScalingProps hw hh
new_mtrx = matrixRepCTM $ scaleCTM dx dy ctm
circ = bezierCircle 1 radius (P2 0 0)
-- subdivide the bezierCircle with 1 to get two
-- control points per quadrant.
--
-- I don't know how to calculate bezier arcs (and thus control
-- points) for an ellipse but I know how to do it for a circle...
--
-- So a make a circle with the largest of half-width and
-- half-height then apply a scale to the points
--
circleScalingProps :: (Fractional u, Ord u) => u -> u -> (u,(u,u))
circleScalingProps hw hh = (radius, (dx,dy))
where
radius = max hw hh
(dx,dy) = if radius == hw then (1, rescale (0,hw) (0,1) hh)
else (rescale (0,hh) (0,1) hw, 1)