module Wumpus.Basic.Graphic
(
Graphic
, DGraphic
, GraphicF
, DGraphicF
, cc
, supply
, drawGraphic
, drawGraphicU
, wrapG
, emptyG
, textline
, 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 $ frameMulti $ 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 :: (TextLabel t, Num u) => t -> String -> GraphicF u
textline t ss = wrapG . textlabel t ss
straightLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u
straightLine t v = \pt -> wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]
strokedRectangle :: (Stroke t, Fractional u) => t -> u -> u -> GraphicF u
strokedRectangle t w h = wrapG . cstroke t . rectangle w h
filledRectangle :: (Fill t, Fractional u) => t -> u -> u -> GraphicF u
filledRectangle t w h = wrapG . fill t . rectangle w h
rectangle :: Fractional u => u -> u -> Point2 u -> Path u
rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))
rectanglePath :: Num u => u -> u -> Point2 u -> Path 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 :: (Stroke t, Floating u) => t -> Int -> u -> GraphicF u
strokedCircle t n r = wrapG . cstroke t . curvedPath . bezierCircle n r
filledCircle :: (Fill t, Floating u) => t -> Int -> u -> GraphicF u
filledCircle t n r = wrapG . fill t . curvedPath . bezierCircle n r
disk :: (Ellipse t, Fractional u) => t -> u -> GraphicF u
disk t radius = wrapG . ellipse t 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 :: (Stroke t, RealFrac u) => t -> u -> u -> Rectangle u -> GraphicF u
grid t xstep ystep (Rectangle w h) = \pt ->
vlines pt . hlines pt
where
vlines (P2 x y) = veloH (straightLine t (vvec h)) $ hpoints y xstep (x,x+w)
hlines (P2 x y) = veloH (straightLine t (hvec w)) $ vpoints x ystep (y,y+h)
border :: (Stroke t, Num u) => t -> Rectangle u -> GraphicF u
border t (Rectangle w h) = wrapG . cstroke t . 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)