module Wumpus.Basic.Graphic.PrimGraphic
(
drawGraphic
, drawGraphicU
, openStroke
, closedStroke
, filledPath
, borderedPath
, textline
, hkernline
, vkernline
, strokedEllipse
, filledEllipse
, borderedEllipse
, supplyPt
, localPoint
, displace
, straightLine
, strokedRectangle
, filledRectangle
, borderedRectangle
, strokedCircle
, filledCircle
, borderedCircle
, strokedDisk
, filledDisk
, borderedDisk
) where
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Basic.Graphic.BaseTypes
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
drawGraphic :: (Real u, Floating u, FromPtSize u)
=> DrawingContext -> Graphic u -> Maybe (Picture u)
drawGraphic ctx gf = post $ runGraphic ctx gf
where
post hf = let xs = hprimToList hf in
if null xs then Nothing else Just (frame xs)
drawGraphicU :: (Real u, Floating u, FromPtSize u)
=> DrawingContext -> Graphic u -> Picture u
drawGraphicU ctx gf = post $ runGraphic ctx gf
where
post hf = let xs = hprimToList hf in
if null xs then errK else frame xs
errK = error "drawGraphicU - empty Graphic."
openStroke :: Num u => PrimPath u -> Graphic u
openStroke pp = (\rgb attr -> singleH $ ostroke rgb attr pp)
<$> asksDF primary_colour <*> asksDF stroke_props
closedStroke :: Num u => PrimPath u -> Graphic u
closedStroke pp = (\rgb attr -> singleH $ cstroke rgb attr pp)
<$> asksDF primary_colour <*> asksDF stroke_props
filledPath :: Num u => PrimPath u -> Graphic u
filledPath pp = (\rgb -> singleH $ fill rgb pp)
<$> asksDF secondary_colour
borderedPath :: Num u => PrimPath u -> Graphic u
borderedPath pp =
(\frgb attr srgb -> singleH $ fillStroke frgb attr srgb pp)
<$> asksDF secondary_colour <*> asksDF stroke_props
<*> asksDF primary_colour
textline :: Num u => String -> LocGraphic u
textline ss baseline_left =
(\(rgb,attr) -> singleH $ textlabel rgb attr ss baseline_left)
<$> asksDF textAttr
hkernline :: Num u => [KerningChar u] -> LocGraphic u
hkernline ks baseline_left =
(\(rgb,attr) -> singleH $ hkernlabel rgb attr ks baseline_left)
<$> asksDF textAttr
vkernline :: Num u => [KerningChar u] -> LocGraphic u
vkernline ks baseline_left =
(\(rgb,attr) -> singleH $ vkernlabel rgb attr ks baseline_left)
<$> asksDF textAttr
strokedEllipse :: Num u => u -> u -> LocGraphic u
strokedEllipse hw hh pt =
(\rgb attr -> singleH $ strokeEllipse rgb attr hw hh pt)
<$> asksDF primary_colour <*> asksDF stroke_props
filledEllipse :: Num u => u -> u -> LocGraphic u
filledEllipse hw hh pt =
(\rgb -> singleH $ fillEllipse rgb hw hh pt)
<$> asksDF secondary_colour
borderedEllipse :: Num u => u -> u -> LocGraphic u
borderedEllipse hw hh pt =
(\frgb attr srgb -> singleH $ fillStrokeEllipse frgb attr srgb hw hh pt)
<$> asksDF secondary_colour <*> asksDF stroke_props
<*> asksDF primary_colour
supplyPt :: Point2 u -> LocGraphic u -> Graphic u
supplyPt pt gf = gf pt
displace :: Num u => u -> u -> Point2 u -> Point2 u
displace dx dy (P2 x y) = P2 (x+dx) (y+dy)
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]
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