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
import Data.AffineSpace
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]
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
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
centermonoTextline :: (Fractional u, Ord u, FromPtSize u)
=> String -> LocGraphic u
centermonoTextline ss pt = monoVecToCenter ss >>= \v ->
textline ss (vecdisplace (negateV v) pt)
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
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]
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
strokedRectangle :: Fractional u => u -> u -> LocGraphic u
strokedRectangle w h = closedStroke . rectangle w h
filledRectangle :: Fractional u => u -> u -> LocGraphic u
filledRectangle w h = filledPath . rectangle w h
borderedRectangle :: Fractional u => u -> u -> LocGraphic u
borderedRectangle w h = borderedPath . rectangle w h
strokedCircle :: Floating u => Int -> u -> LocGraphic u
strokedCircle n r = closedStroke . curvedPath . bezierCircle n r
filledCircle :: Floating u => Int -> u -> LocGraphic u
filledCircle n r = filledPath . curvedPath . bezierCircle n r
borderedCircle :: Floating u => Int -> u -> LocGraphic u
borderedCircle n r = borderedPath . curvedPath . bezierCircle n r
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