Shapes.hs

---------------------------------------------------------
-- |
-- Copyright   : (c) alpha 2007
-- License     : BSD-style
--
-- Maintainer  : misc@NOSPAMalpheccar.org
-- Stability   : experimental
-- Portability : portable
--
-- PDF Shapes
---------------------------------------------------------

module Graphics.PDF.Shapes(
   -- * Shapes
   -- ** Types
     Point
   -- ** Lines
   , moveto
   , lineto
   -- ** Paths
   , beginPath
   , closePath
   , addBezierCubic
   , addPolygonToPath
   , addLineToPath
   , strokePath
   , fillPath
   , fillAndStrokePath
   , fillPathEO
   , fillAndStrokePathEO
   , setAsClipPath
   , setAsClipPathEO
   -- ** Usual shapes
   , Shape(..)
   , Line(..)
   , Rectangle(..)
   , Polygon(..)
   , Arc(..)
   , Ellipse(..)
   , Circle(..)
   , RoundRectangle(..)
   -- ** Style
   , CapStyle(..)
   , JoinStyle(..)
   , DashPattern(..)
   , setWidth
   , setLineCap
   , setLineJoin
   , setDash
   , setNoDash
   , setMiterLimit
 ) where

import Graphics.PDF.LowLevel.Types
import Graphics.PDF.Draw
import Data.List(intersperse)

class Shape a where
    addShape :: a -> Draw ()
    stroke :: a -> Draw ()
    fill :: a -> Draw ()
    fillAndStroke :: a -> Draw ()
    fillEO :: a -> Draw ()
    fillAndStrokeEO :: a -> Draw ()
    stroke r = do
        addShape r
        strokePath
    fill r = do
        addShape r
        fillPath
    fillAndStroke r = do
        addShape r
        fillAndStrokePath
    fillEO r = do
        addShape r
        fillPathEO
    fillAndStrokeEO r = do
        addShape r
        fillAndStrokePathEO
    
data Line = Line PDFFloat PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape Line where
    addShape (Line x0 y0 x1 y1)= do
        moveto x0 y0
        lineto x1 y1
    fill _ = error "Can't fill a line !"
    fillAndStroke _ = error "Can't fill a line !"
    fillEO _ = error "Can't fill a line !"
    fillAndStrokeEO _ = error "Can't fill a line !"
    
data Rectangle = Rectangle PDFFloat PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape Rectangle where
 addShape (Rectangle x0 y0 x1 y1) = do
    let poly = [(x0,y0),(x1,y0),(x1,y1),(x0,y1)]
    addPolygonToPath poly
    closePath
 
data Arc = Arc PDFFloat PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape Arc where
    addShape (Arc x0 y0 x1 y1) = do
        let height = y1 - y0
            width = x1 - x0
            kappa = 0.5522847498
        beginPath x0 y0
        addBezierCubic (x0+width*kappa) y0 x1 (y1-height*kappa) x1 y1
               
data Ellipse = Ellipse PDFFloat PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape Ellipse where
    addShape (Ellipse x0 y0 x1 y1) = do
        let xm = (x0+x1)/2.0
            ym = (y0+y1)/2.0
            k = 0.5522847498
            h = k*(abs (y1 - y0)/2.0)
            w = k*(abs (x1 - x0)/2.0)

        beginPath xm y0
        addBezierCubic (xm + w) y0 x1 (ym - h) x1 ym
        addBezierCubic x1 (ym + h) (xm + w) y1 xm y1
        addBezierCubic (xm - w) y1 x0 (ym + h) x0 ym
        addBezierCubic x0 (ym - h) (xm - w) y0 xm y0

data RoundRectangle = RoundRectangle PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape RoundRectangle where
    addShape (RoundRectangle rw rh x0 y0 x1 y1) = do
        let k = 0.5522847498
            h = k*rw
            w = k*rh

        beginPath (x0+rw) y0
        addLineToPath (x1-rw) y0
        addBezierCubic ((x1-rw) + w) y0 x1 (y0+rh - h) x1 (y0+rh)
        addLineToPath x1 (y1-rh)
        addBezierCubic x1 ((y1-rh) + h) (x1-rw + w) y1 (x1-rw) y1
        addLineToPath (x0+rw) y1
        addBezierCubic (x0 + rw - w) y1 x0 (y1-rh + h) x0 (y1-rh)
        addLineToPath x0 (y0+rh)
        addBezierCubic x0 (y0 + rh - h) (x0 + rw - w) y0 (x0 + rw) y0
        addLineToPath (x1-rw) y0
        
data Circle = Circle PDFFloat PDFFloat PDFFloat deriving(Eq)
instance Shape Circle where
    addShape (Circle x0 y0 r) = stroke (Ellipse (x0-r) (y0-r) (x0+r) (y0+r) )
                
newtype Polygon = Polygon [Point]
instance Shape Polygon where
    addShape (Polygon l) = addPolygonToPath l


-- | Set pen width
setWidth :: MonadPath m => PDFFloat -> m ()
setWidth w = writeCmd $ "\n " ++ (show w) ++ " w"

-- | Set pen width
setMiterLimit :: MonadPath m => PDFFloat -> m ()
setMiterLimit w = writeCmd $ "\n " ++ (show w) ++ " M"

-- | Line cap styles
data CapStyle = ButtCap
              | RoundCap
              | SquareCap
              deriving(Eq,Enum)
              
-- | Line join styles
data JoinStyle = MilterJoin
               | RoundJoin
               | BevelJoin
               deriving(Eq,Enum)
                            
-- | Set line cap
setLineCap :: MonadPath m => CapStyle -> m ()
setLineCap w = writeCmd $ "\n " ++ (show . fromEnum  $ w) ++ " J"

-- | Set line join
setLineJoin :: MonadPath m => JoinStyle -> m ()
setLineJoin w = writeCmd $ "\n " ++ (show . fromEnum  $ w) ++ " j"

data DashPattern = DashPattern ![PDFFloat] PDFFloat deriving(Eq)

-- | Set the dash pattern
setDash :: MonadPath m => DashPattern -> m()
setDash (DashPattern a p) = writeCmd $ "\n " ++  show a ++ " " ++ (show p) ++ " d"

-- | No dash pattern
setNoDash :: MonadPath m => m ()
setNoDash = setDash (DashPattern [] 0)
    
-- | Begin a new path at position x y
beginPath :: PDFFloat -- ^ Horizontal coordinate
          -> PDFFloat -- ^ Vertical coordinate
          -> Draw ()
beginPath = moveto

-- | Close current path 
closePath :: Draw ()
closePath = writeCmd $ "\nh"


-- | Append a cubic Bezier curve to the current path. The curve extends 
-- from the current point to the point (x3 , y3 ), using (x1 , y1 ) and 
-- (x2, y2) as the Bezier control points
addBezierCubic :: PDFFloat -- ^ x1
               -> PDFFloat -- ^ y1
               -> PDFFloat -- ^ x2 
               -> PDFFloat -- ^ y2 
               -> PDFFloat -- ^ x3 
               -> PDFFloat -- ^ y3
               -> Draw ()
addBezierCubic x1 y1 x2 y2 x3 y3 = writeCmd $ "\n" ++ (concat . intersperse " ". map show $ [x1,y1,x2,y2,x3,y3]) ++ " c"

-- | Move pen to a given point without drawing anything
moveto :: PDFFloat -- ^ Horizontal coordinate
       -> PDFFloat -- ^ Vertical coordinate
       -> Draw ()
moveto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " m"

-- | Draw a line from current point to the one specified by lineto
lineto :: PDFFloat -- ^ Horizontal coordinate 
       -> PDFFloat -- ^ Vertical coordinate
       -> Draw ()
lineto x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l s"

-- | Add a line from current point to the one specified by lineto
addLineToPath :: PDFFloat -- ^ Horizontal coordinate 
              -> PDFFloat -- ^ Vertical coordinate
              -> Draw ()
addLineToPath x y = writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l"

-- | A point
type Point = (PDFFloat,PDFFloat)

-- | Add a polygon to current path
addPolygonToPath :: [Point]
                 -> Draw ()
addPolygonToPath l =  do
    (uncurry moveto) . head $ l
    mapM_ (\(x,y) -> writeCmd $ "\n" ++ (show x) ++ " " ++ (show y) ++ " l") (tail l)  
    
-- | Draw current path
strokePath :: Draw ()             
strokePath = writeCmd "\nS"

-- | Fill current path
fillPath :: Draw ()             
fillPath = writeCmd "\nf"

-- | Fill current path
fillAndStrokePath :: Draw ()             
fillAndStrokePath = writeCmd "\nB"

-- | Set clipping path
setAsClipPathEO :: Draw ()             
setAsClipPathEO = writeCmd "\nW* n"

-- | Set clipping path
setAsClipPath :: Draw ()             
setAsClipPath = writeCmd "\nW n"

-- | Fill current path using even odd rule
fillPathEO :: Draw ()             
fillPathEO = writeCmd "\nf*"

-- | Fill current path using even odd rule
fillAndStrokePathEO :: Draw ()             
fillAndStrokePathEO = writeCmd "\nB*"