PrimGraphic.hs

{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Graphic.PrimGraphic
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Elementary functions for the Graphic and LocGraphic types.
--
-- The functions here are generally analogeous to the Picture 
-- API in @Wumpus.Core@, but here they exploit the implicit 
-- @DrawingContext@.
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Graphic.PrimGraphic
  (
    drawGraphic

  , openStroke
  , closedStroke
  , filledPath
  , borderedPath
  
  , textline
  , rtextline
  , centermonoTextline
  , textlineMulti
  , hkernline
  , vkernline


  , strokedEllipse
  , filledEllipse  
  , borderedEllipse

  , supplyPt
  , localPoint
  , vecdisplace
  , displace
  , hdisplace
  , vdisplace
  , parallelvec
  , perpendicularvec
  , displaceParallel
  , displacePerpendicular


  , straightLine
  , straightLineBetween
  , curveBetween

  , strokedRectangle
  , filledRectangle
  , borderedRectangle


  , strokedCircle
  , filledCircle
  , borderedCircle
  
  , strokedDisk
  , filledDisk
  , borderedDisk
  

  ) where

import Wumpus.Basic.Graphic.Base
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Basic.Graphic.Query

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space
import Data.VectorSpace

import Control.Applicative
import Data.Foldable ( foldrM )


drawGraphic :: (Real u, Floating u, FromPtSize u) 
            => DrawingContext -> Graphic u -> Picture u
drawGraphic ctx gf = frame [getPrimGraphic $ runGraphic ctx gf]




-- having the same names is actually not so useful...

openStroke :: Num u => PrimPath u -> Graphic u
openStroke pp = 
    withStrokeAttr $ \rgb attr -> wrapPrim $ ostroke rgb attr pp

closedStroke :: Num u => PrimPath u -> Graphic u
closedStroke pp = 
    withStrokeAttr $ \rgb attr -> wrapPrim $ cstroke rgb attr pp

filledPath :: Num u => PrimPath u -> Graphic u
filledPath pp = withFillAttr $ \rgb -> wrapPrim $ fill rgb pp
                 


borderedPath :: Num u => PrimPath u -> Graphic u
borderedPath pp = 
    withBorderedAttr $ \frgb attr srgb -> wrapPrim $ fillStroke frgb attr srgb pp


-- Note - clipping needs a picture as well as a path, so there is
-- no analogous @clippedPath@ function.


--------------------------------------------------------------------------------
-- 



textline :: Num u => String -> LocGraphic u
textline ss baseline_left =
    withTextAttr $ \rgb attr -> wrapPrim $ textlabel rgb attr ss baseline_left

rtextline :: Num u => String -> ThetaLocGraphic u
rtextline ss theta baseline_left =
    withTextAttr $ \rgb attr -> 
      wrapPrim $ rtextlabel rgb attr ss theta baseline_left

-- | As 'textline' but the supplied point is the /center/.
--
-- Centered is inexact - it is calculated with monospaced font
-- metrics.
-- 
centermonoTextline :: (Fractional u, Ord u, FromPtSize u) 
                   => String -> LocGraphic u
centermonoTextline ss pt = monoVecToCenter ss  >>= \v ->
                           textline ss (vecdisplace (negateV v) pt)





-- | Point is the baseline left of the bottom line, text is 
-- left-aligned.
--
textlineMulti :: Fractional u => [String] -> LocGraphic u
textlineMulti xs baseline_left =  
    baselineSpacing >>= \dy -> 
    foldrM (foldStep dy) (baseline_left,[]) xs >>= \(_,gs) ->
    return (wrapPrim $ primGroup gs)
  where
    foldStep dy str (pt,ac) = (\a -> (pt .+^ vvec dy, (getPrimGraphic a) : ac)) 
                                <$> textline str pt
                                


hkernline :: Num u => [KerningChar u] -> LocGraphic u
hkernline ks baseline_left = 
    withTextAttr $ \rgb attr -> wrapPrim $ hkernlabel rgb attr ks baseline_left
      

vkernline :: Num u => [KerningChar u] -> LocGraphic u
vkernline ks baseline_left = 
    withTextAttr $ \rgb attr -> wrapPrim $ vkernlabel rgb attr ks baseline_left
  


--------------------------------------------------------------------------------


strokedEllipse :: Num u => u -> u -> LocGraphic u
strokedEllipse hw hh pt =  
    withStrokeAttr $ \rgb attr -> wrapPrim $ strokeEllipse rgb attr hw hh pt
   

filledEllipse :: Num u => u -> u -> LocGraphic u
filledEllipse hw hh pt =  
    withFillAttr $ \rgb -> wrapPrim $ fillEllipse rgb hw hh pt
  

borderedEllipse :: Num u => u -> u -> LocGraphic u
borderedEllipse hw hh pt = 
    withBorderedAttr $ \frgb attr srgb -> 
      wrapPrim $ fillStrokeEllipse frgb attr srgb hw hh pt

--------------------------------------------------------------------------------


-- | Supplying a point to a 'CFGraphic' takes it to a regular 
-- 'Graphic'.
--
supplyPt :: Point2 u -> LocGraphic u -> Graphic u
supplyPt pt gf = gf pt 

vecdisplace :: Num u => Vec2 u -> Point2 u -> Point2 u
vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)


displace :: Num u => u -> u -> Point2 u -> Point2 u
displace dx dy (P2 x y) = P2 (x+dx) (y+dy)

hdisplace :: Num u => u -> Point2 u -> Point2 u
hdisplace dx (P2 x y) = P2 (x+dx) y

vdisplace :: Num u => u -> Point2 u -> Point2 u
vdisplace dy (P2 x y) = P2 x (y+dy)



parallelvec :: Floating u => u -> Radian -> Vec2 u
parallelvec d r         = avec (circularModulo r) d

perpendicularvec :: Floating u => u -> Radian -> Vec2 u
perpendicularvec d r    = avec (circularModulo $ (0.5*pi) + r) d

displaceParallel :: Floating u => u -> Radian -> Point2F u
displaceParallel d r pt = pt .+^ parallelvec d r

displacePerpendicular :: Floating u => u -> Radian -> Point2F u
displacePerpendicular d r pt = pt .+^ perpendicularvec d r


localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u
localPoint upd gf = \pt -> gf (upd pt)


--------------------------------------------------------------------------------


straightLine :: Fractional u => Vec2 u -> LocGraphic u
straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v]
          

straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u
straightLineBetween p1 p2 = openStroke $ path p1 [lineTo p2]

curveBetween :: Fractional u 
             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
curveBetween sp cp1 cp2 ep = openStroke $ path sp [curveTo cp1 cp2 ep]



-- | Supplied point is /bottom-left/.
--
rectangle :: Num u => u -> u -> Point2 u -> PrimPath u
rectangle w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]
  where
    br = bl .+^ hvec w
    tr = br .+^ vvec h
    tl = bl .+^ vvec h 



-- | Supplied point is /bottom left/.
--
strokedRectangle :: Fractional u => u -> u -> LocGraphic u
strokedRectangle w h = closedStroke . rectangle w h



-- | Supplied point is /bottom left/.
--
filledRectangle :: Fractional u => u -> u -> LocGraphic u
filledRectangle w h = filledPath . rectangle w h
  

-- | Supplied point is /bottom left/.
--
borderedRectangle :: Fractional u => u -> u -> LocGraphic u
borderedRectangle w h = borderedPath . rectangle w h

--------------------------------------------------------------------------------


-- | Supplied point is center. Circle is drawn with Bezier 
-- curves. 
--
strokedCircle :: Floating u => Int -> u -> LocGraphic u
strokedCircle n r = closedStroke . curvedPath . bezierCircle n r



-- | Supplied point is center. Circle is drawn with Bezier 
-- curves. 
--
filledCircle :: Floating u => Int -> u -> LocGraphic u
filledCircle n r = filledPath . curvedPath . bezierCircle n r


-- | Supplied point is center. Circle is drawn with Bezier 
-- curves. 
--
borderedCircle :: Floating u => Int -> u -> LocGraphic u
borderedCircle n r = borderedPath . curvedPath . bezierCircle n r


-- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.
--
-- This is a efficient representation of circles using 
-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated 
-- output. However, stroked-circles do not draw well after 
-- non-uniform scaling - the line width is scaled as well as 
-- the shape.
--
-- For stroked circles that can be scaled, consider making the 
-- circle from Bezier curves.
--
strokedDisk :: Num u => u -> LocGraphic u
strokedDisk radius = strokedEllipse radius radius


filledDisk :: Num u => u -> LocGraphic u
filledDisk radius = filledEllipse radius radius

borderedDisk :: Num u => u -> LocGraphic u
borderedDisk radius = borderedEllipse radius radius