module Wumpus.Basic.Graphic.Primitive
(
Graphic
, DGraphic
, GraphicF
, DGraphicF
, cc
, supply
, drawGraphic
, drawGraphicU
, wrapG
, emptyG
, textline
, xtextline
, straightLine
, strokedRectangle
, filledRectangle
, rectanglePath
, strokedCircle
, filledCircle
, disk
, Point2T
, DPoint2T
, positionWith
, disp
, vdisp
, hdisp
, Rectangle(..)
, DRectangle
, grid
, border
, RectangleLoc
, DRectangleLoc
, withinRectangleLoc
) where
import Wumpus.Basic.Graphic.PointSupply
import Wumpus.Basic.Utils.HList
import Wumpus.Core
import Data.AffineSpace
import Data.Maybe
type Graphic u = H (Primitive u)
type DGraphic = Graphic Double
type GraphicF u = Point2 u -> Graphic u
type DGraphicF = GraphicF Double
infixr 9 `cc`
cc :: (r1 -> a -> ans) -> (r1 -> r2 -> a) -> r1 -> r2 -> ans
cc f g = \x y -> f x (g x y)
supply :: u -> (u -> a) -> a
supply u f = f u
drawGraphic :: (Real u, Floating u, FromPtSize u)
=> Graphic u -> Maybe (Picture u)
drawGraphic f = post $ f []
where
post [] = Nothing
post xs = Just $ frame xs
drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u
drawGraphicU = fromMaybe errK . drawGraphic
where
errK = error "drawGraphic - empty Graphic."
wrapG :: Primitive u -> Graphic u
wrapG = wrapH
emptyG :: Graphic u
emptyG = emptyH
textline :: Num u => RGBi -> FontAttr -> String -> GraphicF u
textline rgb attr ss = wrapG . textlabel rgb attr ss
xtextline :: Num u => RGBi -> FontAttr -> XLink -> String -> GraphicF u
xtextline rgb attr xl ss = wrapG . xtextlabel rgb attr xl ss
straightLine :: Fractional u => RGBi -> StrokeAttr -> Vec2 u -> GraphicF u
straightLine rgb attr v =
\pt -> wrapG $ ostroke rgb attr $ path pt [lineTo $ pt .+^ v]
strokedRectangle :: Fractional u => RGBi -> StrokeAttr -> u -> u -> GraphicF u
strokedRectangle rgb attr w h = wrapG . cstroke rgb attr . rectangle w h
filledRectangle :: Fractional u => RGBi -> u -> u -> GraphicF u
filledRectangle rgb w h = wrapG . fill rgb . rectangle w h
rectangle :: Fractional u => u -> u -> Point2 u -> PrimPath u
rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))
rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u
rectanglePath w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]
where
br = bl .+^ hvec w
tr = br .+^ vvec h
tl = bl .+^ vvec h
strokedCircle :: Floating u => RGBi -> StrokeAttr -> Int -> u -> GraphicF u
strokedCircle rgb attr n r =
wrapG . cstroke rgb attr . curvedPath . bezierCircle n r
filledCircle :: Floating u => RGBi -> Int -> u -> GraphicF u
filledCircle rgb n r = wrapG . fill rgb . curvedPath . bezierCircle n r
disk :: Fractional u => RGBi -> u -> GraphicF u
disk rgb radius = wrapG . fillEllipse rgb radius radius
type Point2T u = Point2 u -> Point2 u
type DPoint2T = Point2T Double
positionWith :: Point2T u -> (Point2 u -> a) -> (Point2 u -> a)
positionWith displacer gf = gf . displacer
disp :: Num u => u -> u -> Point2T u
disp x y = (.+^ V2 x y)
hdisp :: Num u => u -> Point2T u
hdisp x = disp x 0
vdisp :: Num u => u -> Point2T u
vdisp y = disp 0 y
data Rectangle u = Rectangle
{ rect_width :: !u
, rect_height :: !u
}
deriving (Eq,Ord,Show)
type DRectangle = Rectangle Double
grid :: RealFrac u => RGBi -> StrokeAttr -> u -> u -> Rectangle u -> GraphicF u
grid rgb attr xstep ystep (Rectangle w h) = \pt ->
vlines pt . hlines pt
where
vlines (P2 x y) = veloH (straightLine rgb attr (vvec h)) $ hpoints y xstep (x,x+w)
hlines (P2 x y) = veloH (straightLine rgb attr (hvec w)) $ vpoints x ystep (y,y+h)
border :: Num u => RGBi -> StrokeAttr -> Rectangle u -> GraphicF u
border rgb attr (Rectangle w h) = wrapG . cstroke rgb attr . rectanglePath w h
type RectangleLoc u = (Rectangle u, Point2 u)
type DRectangleLoc = RectangleLoc Double
withinRectangleLoc :: (Num u, Ord u) => Point2 u -> RectangleLoc u -> Bool
withinRectangleLoc (P2 x y) (Rectangle w h, P2 ox oy) =
ox <= x && x <= (ox+w) && oy <= y && y <= (oy+h)