module Wumpus.Basic.Kernel.Objects.Graphic
(
Graphic
, DGraphic
, LocGraphic
, DLocGraphic
, LocThetaGraphic
, DLocThetaGraphic
, intoImage
, intoLocImage
, intoLocThetaImage
, moveStartPoint
, moveStartPointTheta
, locPath
, emptyLocPath
, emptyLocGraphic
, openStroke
, closedStroke
, filledPath
, borderedPath
, textline
, rtextline
, escapedline
, rescapedline
, hkernline
, vkernline
, strokedEllipse
, rstrokedEllipse
, filledEllipse
, rfilledEllipse
, borderedEllipse
, rborderedEllipse
, straightLine
, straightLineBetween
, curveBetween
, strokedRectangle
, filledRectangle
, borderedRectangle
, strokedCircle
, filledCircle
, borderedCircle
, strokedDisk
, filledDisk
, borderedDisk
) where
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.QueryDC
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.BaseObjects
import Wumpus.Core
import Data.AffineSpace
import Control.Applicative
type Graphic u = Image u (UNil u)
type DGraphic = Graphic Double
type LocGraphic u = LocImage u (UNil u)
type DLocGraphic = LocGraphic Double
type LocThetaGraphic u = LocThetaImage u (UNil u)
type DLocThetaGraphic = LocThetaGraphic Double
intoImage :: CF a -> Graphic u -> Image u a
intoImage = liftA2 (\a (_,b) -> (a,b))
intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a
intoLocImage = liftA2 (\a (_,b) -> (a,b))
intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a
intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))
moveStartPoint :: PointDisplace u -> LocCF u a -> LocCF u a
moveStartPoint f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)
moveStartPointTheta :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a
moveStartPointTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta
graphicBody :: Primitive u -> (UNil u, PrimGraphic u)
graphicBody p = (uNil, primGraphic p)
locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)
locPath vs = promoteR1 $ \pt -> pure $ vectorPath pt vs
emptyLocPath :: Num u => LocCF u (PrimPath u)
emptyLocPath = locPath []
emptyLocGraphic :: Num u => LocGraphic u
emptyLocGraphic = emptyLocPath >>= (lift0R1 . openStroke)
openStroke :: Num u => PrimPath u -> Graphic u
openStroke pp =
withStrokeAttr $ \rgb attr -> graphicBody $ ostroke rgb attr pp
closedStroke :: Num u => PrimPath u -> Graphic u
closedStroke pp =
withStrokeAttr $ \rgb attr -> graphicBody $ cstroke rgb attr pp
filledPath :: Num u => PrimPath u -> Graphic u
filledPath pp = withFillAttr $ \rgb -> graphicBody $ fill rgb pp
borderedPath :: Num u => PrimPath u -> Graphic u
borderedPath pp =
withBorderedAttr $ \frgb attr srgb ->
graphicBody $ fillStroke frgb attr srgb pp
textline :: Num u => String -> LocGraphic u
textline ss =
promoteR1 $ \pt ->
withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt)
rtextline :: Num u => String -> LocThetaGraphic u
rtextline ss =
promoteR2 $ \pt theta ->
withTextAttr $ \rgb attr -> graphicBody (rtextlabel rgb attr ss theta pt)
escapedline :: Num u => EscapedText -> LocGraphic u
escapedline ss =
promoteR1 $ \pt ->
withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt)
rescapedline :: Num u => EscapedText -> LocThetaGraphic u
rescapedline ss =
promoteR2 $ \pt theta ->
withTextAttr $ \rgb attr -> graphicBody (rescapedlabel rgb attr ss theta pt)
hkernline :: Num u => [KerningChar u] -> LocGraphic u
hkernline xs =
promoteR1 $ \pt ->
withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt)
vkernline :: Num u => [KerningChar u] -> LocGraphic u
vkernline xs =
promoteR1 $ \pt ->
withTextAttr $ \rgb attr -> graphicBody (vkernlabel rgb attr xs pt)
strokedEllipse :: Num u => u -> u -> LocGraphic u
strokedEllipse hw hh =
promoteR1 $ \pt ->
withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt)
rstrokedEllipse :: Num u => u -> u -> LocThetaGraphic u
rstrokedEllipse hw hh =
promoteR2 $ \ pt theta ->
withStrokeAttr $ \rgb attr ->
graphicBody (rstrokeEllipse rgb attr hw hh theta pt)
filledEllipse :: Num u => u -> u -> LocGraphic u
filledEllipse hw hh =
promoteR1 $ \pt ->
withFillAttr $ \rgb -> graphicBody (fillEllipse rgb hw hh pt)
rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u
rfilledEllipse hw hh =
promoteR2 $ \pt theta ->
withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta pt)
borderedEllipse :: Num u => u -> u -> LocGraphic u
borderedEllipse hw hh =
promoteR1 $ \pt ->
withBorderedAttr $ \frgb attr srgb ->
graphicBody (fillStrokeEllipse frgb attr srgb hw hh pt)
rborderedEllipse :: Num u => u -> u -> LocThetaGraphic u
rborderedEllipse hw hh =
promoteR2 $ \pt theta ->
withBorderedAttr $ \frgb attr srgb ->
graphicBody (rfillStrokeEllipse frgb attr srgb hw hh theta pt)
straightLine :: Fractional u => Vec2 u -> LocGraphic u
straightLine v = mf >>= (lift0R1 . openStroke)
where
mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]
straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u
straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2]
curveBetween :: Fractional u
=> Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u
curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep]
drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u
drawWith g mf = promoteR1 $ \pt -> mf (g pt)
rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u
rectanglePath w h bl = primPath 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 = rectanglePath w h `drawWith` closedStroke
filledRectangle :: Fractional u => u -> u -> LocGraphic u
filledRectangle w h = rectanglePath w h `drawWith` filledPath
borderedRectangle :: Fractional u => u -> u -> LocGraphic u
borderedRectangle w h = rectanglePath w h `drawWith` borderedPath
strokedCircle :: Floating u => Int -> u -> LocGraphic u
strokedCircle n r = (curvedPath . bezierCircle n r) `drawWith` closedStroke
filledCircle :: Floating u => Int -> u -> LocGraphic u
filledCircle n r = (curvedPath . bezierCircle n r) `drawWith` filledPath
borderedCircle :: Floating u => Int -> u -> LocGraphic u
borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath
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