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 :: 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)
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 :: Double -> Diagram
circle r = scale r $ Prim (Shape Circle)
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 :: Path -> Diagram
straight = Prim . Shape . PathShape Straight
curved :: Double -> Path -> Diagram
curved d = Prim . Shape . PathShape (Bezier d)
regPolyPath :: Int -> Double -> Path
regPolyPath n r = pathFromVertices verts
where verts = map (((*r) . cos) &&& ((*r) . sin))
[0,2*pi/nd .. (nd1)*2*pi/nd]
nd = fromIntegral n
regPoly :: Int -> Double -> Diagram
regPoly n r = straight . closed $ regPolyPath n r
rotRegPoly :: Int -> Double -> Double -> Diagram
rotRegPoly n r a = straight . closed . rotPath a $ regPolyPath n r
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 :: Double -> Double -> Diagram
rect w h = scale (h/2) $ Prim (Shape (Rect (w/h)))
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 (rx) (ry) r pi (pi/2)
C.lineTo (xr) (y)
C.arc (xr) (ry) r (pi/2) 0
C.lineTo (x) (yr)
C.arc (xr) (yr) r 0 (pi/2)
C.lineTo (rx) (y)
C.arc (rx) (yr) r (pi/2) pi
C.closePath
draw
roundRect :: Double -> Double -> Diagram
roundRect w h = Prim $ Shape $ RoundRect w h
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
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 :: 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 :: Point -> C.Render () -> Diagram
rawCairo s r = Prim (Shape (RawCairo s r))