diagrams-0.2: Graphics/Rendering/Diagrams/Shapes.hs
-----------------------------------------------------------------------------
-- |
-- Module : Graphics.Rendering.Diagrams.Shapes
-- Copyright : (c) Brent Yorgey 2008
-- License : BSD-style (see LICENSE)
-- Maintainer : byorgey@gmail.com
-- Stability : experimental
-- Portability : portable
--
-- Primitive shapes out of which 'Diagram's can be built, implemented
-- via instances of 'ShapeClass'.
--
-----------------------------------------------------------------------------
module Graphics.Rendering.Diagrams.Shapes
( circle
, regPolyPath
, regPoly
, rotRegPoly
, rect
, roundRect
, straight
, curved
, textPath
, rawCairo
) where
import Graphics.Rendering.Diagrams.Types
import Graphics.Rendering.Diagrams.Attributes (scale)
import Graphics.Rendering.Diagrams.Paths
import qualified Graphics.Rendering.Cairo as C
import qualified Graphics.Rendering.Cairo.Internal as CI
import Control.Arrow ((&&&))
import Control.Monad.Reader
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (bracket)
-- | Draw the shape defined by the current cairo path, using the
-- current fill color, stroke color, and stroke width settings.
draw :: DiaRenderM ()
draw = do c $ C.save
(rf,gf,bf,af) <- asks (colorToRGBA . envFillColor)
c $ C.setSourceRGBA rf gf bf af
c $ C.fillPreserve
(rs,gs,bs,as) <- asks (colorToRGBA . envStrokeColor)
c $ C.setSourceRGBA rs gs bs as
sw <- asks envStrokeWidth
c $ fmap dist (C.deviceToUserDistance sw 0) >>= C.setLineWidth
c $ C.stroke
c $ C.restore
where dist (x,y) = sqrt (x*x + y*y)
-- | A unit circle centered at the origin.
data Circle = Circle deriving (Eq, Show, Read)
instance ShapeClass Circle where
shapeSize _ = (2,2)
renderShape _ = do
c $ C.arc 0 0 1 0 (2*pi)
draw
-- | @circle r@ is a circle with radius @r@.
circle :: Double -> Diagram
circle r = scale r $ Prim (Shape Circle)
-- | A path-based shape.
data PathShape = PathShape PathStyle Path deriving (Eq, Show, Read)
instance ShapeClass PathShape where
shapeSize (PathShape _ p) = fst $ pathSizeAndOffset p
renderShape (PathShape style p) = c (renderPath style p) >> draw
-- | @straight@ creates a 'Diagram' from a path, by drawing straight
-- lines along the path edges.
straight :: Path -> Diagram
straight = Prim . Shape . PathShape Straight
-- | @curved d p@ is a curved path which follows generally the path
-- @p@. The parameter @d@ specifies the amount of corner rounding.
-- In particular, @d@ should be a value between 0 and 1, which
-- specifies what fraction of the path segments should be rounded
-- off with bezier curves, using the path vertices as control
-- points. Thus @d = 0@ produces the polygonal path itself, with no
-- curved segments; @d = 1@ produces a continuously curving path
-- tangent to the midpoints of the path segments; and intermediate
-- values of @d@ interpolate between the two. The curved path
-- produced will be everywhere differentiable as long as @d > 0@.
-- If the path is not closed, the curve will begin and end at the
-- first and last path vertices (no rounding will take place at
-- these vertices).
curved :: Double -> Path -> Diagram
curved d = Prim . Shape . PathShape (Bezier d)
-- | @regPolyPath n r@ is an open path corresponding to a regular
-- polygon, with the first vertex oriented along the positive
-- x-axis and proceeding clockwise.
regPolyPath :: Int -> Double -> Path
regPolyPath n r = pathFromVertices verts
where verts = map (((*r) . cos) &&& ((*r) . sin))
[0,2*pi/nd .. (nd-1)*2*pi/nd]
nd = fromIntegral n
-- | @regPoly n r@ is a regular n-gon, with a circumcircle of radius
-- @r@. One vertex is oriented along the positive x-axis.
regPoly :: Int -> Double -> Diagram
regPoly n r = straight . closed $ regPolyPath n r
-- | @rotRegPoly n r a@ is the same as @'regPoly' n r@ but rotated
-- through an angle of @a*2*pi@ radians (i.e., @a@ represents a
-- fraction of an entire revolution). This is different than
-- @'rotate' a $ 'regPoly' n r@; @rotRegPoly@ will adjust the
-- bounding box correctly (using 'rotPath'), whereas the
-- construction using @rotate@ will still have a bounding box
-- corresponding to the unrotated polygon.
rotRegPoly :: Int -> Double -> Double -> Diagram
rotRegPoly n r a = straight . closed . rotPath a $ regPolyPath n r
-- | @Rect w@ is a 2w (width) by 2 (height) rectangle, centered at the
-- origin.
data Rect = Rect Double deriving (Eq, Show, Read)
instance ShapeClass Rect where
shapeSize (Rect w) = (2*w,2)
renderShape (Rect w) = do
c $ C.rectangle (-w) (-1) (2*w) 2
draw
-- | @rect w h@ is a rectangle of width @w@ and height @h@.
rect :: Double -> Double -> Diagram
rect w h = scale (h/2) $ Prim (Shape (Rect (w/h)))
-- | @RoundRect w h@ is a rectangle with rounded corners.
-- Both dimensions are given to avoid unnecessary
-- distortion in the curves when scaling.
data RoundRect = RoundRect Double Double deriving (Eq, Show, Read)
instance ShapeClass RoundRect where
shapeSize (RoundRect w h) = (w,h)
renderShape (RoundRect w h) = do
let (x,y) = (w/2, h/2)
r = min (w/3) (h/3)
c $ do C.arc (r-x) (r-y) r pi (-pi/2)
C.lineTo (x-r) (-y)
C.arc (x-r) (r-y) r (-pi/2) 0
C.lineTo (x) (y-r)
C.arc (x-r) (y-r) r 0 (pi/2)
C.lineTo (r-x) (y)
C.arc (r-x) (y-r) r (pi/2) pi
C.closePath
draw
-- | @roundRect w h@ is a rectangle of width @w@ and height @h@ with
-- rounded corners having a radius one third the length of the
-- shortest edge.
roundRect :: Double -> Double -> Diagram
roundRect w h = Prim $ Shape $ RoundRect w h
-- | @Text s t@ is a text string @t@ at size @s@.
data Text = Text Double String deriving (Eq, Show, Read)
instance ShapeClass Text where
shapeSize t = (x,y)
where x = C.textExtentsWidth e + C.textExtentsXbearing e
y = C.fontExtentsHeight f
(f,e) = unsafeExtents t
renderShape (Text s t) = do
c $ do C.setFontSize s
(x,y) <- C.getCurrentPoint
te <- C.textExtents t
fe <- C.fontExtents
C.moveTo
(x - (C.textExtentsWidth te/2) - C.textExtentsXbearing te)
(y + (C.fontExtentsHeight fe/2) - C.fontExtentsDescent fe)
C.textPath t
draw
{-# NOINLINE unsafeExtents #-}
unsafeExtents :: Text -> (CI.FontExtents, CI.TextExtents)
unsafeExtents (Text s t) = unsafePerformIO $ do
bracket
(CI.create =<< C.createImageSurface C.FormatARGB32 1000 1000)
(CI.destroy)
(\cxt -> do CI.setFontSize cxt s
te <- CI.textExtents cxt t
fe <- CI.fontExtents cxt
return (fe, te))
-- | @textPath s t@ is a string of text @t@ at size @s@,
-- represented as an outline with separate stroke and fill.
textPath :: Double -> String -> Diagram
textPath s t = Prim (Shape (Text s t))
data RawCairo = RawCairo Point (C.Render ())
instance ShapeClass RawCairo where
shapeSize (RawCairo s _) = s
renderShape (RawCairo _ r) = c r
-- | @rawCairo s r@ is a diagram with bounding box size @s@, rendered
-- by executing Cairo 'Render' action @r@. Import
-- "Graphics.Rendering.Cairo" to access Cairo operations.
rawCairo :: Point -> C.Render () -> Diagram
rawCairo s r = Prim (Shape (RawCairo s r))