module Wumpus.Drawing.Extras.Grids
(
GridContextF
, grid
, standard_grid
, grid_major_colour
, grid_major_line_width
, grid_major_dotnum
, grid_minor_subdivisions
, grid_minor_colour
, grid_minor_line_width
, grid_minor_dotnum
, grid_point_size
, grid_label_colour
) where
import Wumpus.Basic.Kernel
import Wumpus.Core
import Wumpus.Core.Colour ( black )
type GridContextF = GridProps -> GridProps
data GridProps = GridProps
{ gp_major_colour :: RGBi
, gp_major_lnwidth :: Double
, gp_major_dotnum :: Int
, gp_minor_subdivs :: Int
, gp_minor_colour :: RGBi
, gp_minor_lnwidth :: Double
, gp_minor_dotnum :: Int
, gp_point_size :: FontSize
, gp_label_colour :: RGBi
}
default_grid_props :: GridProps
default_grid_props =
GridProps { gp_major_colour = grey1
, gp_major_lnwidth = 1
, gp_major_dotnum = 0
, gp_minor_subdivs = 5
, gp_minor_colour = grey2
, gp_minor_lnwidth = 0.5
, gp_minor_dotnum = 0
, gp_point_size = 10
, gp_label_colour = black
}
where
grey1 = RGBi 100 100 100
grey2 = RGBi 150 150 150
grid :: (Fractional u, InterpretUnit u)
=> GridContextF -> (Int,Int) -> (Int,Int) -> Graphic u
grid upd bl tr = go (upd default_grid_props)
where
go props | gp_minor_subdivs props < 1 = gridMajor bl tr props
| otherwise = gridMinor bl tr props `oplus` gridMajor bl tr props
standard_grid :: GridContextF
standard_grid = id
grid_major_colour :: RGBi -> GridContextF
grid_major_colour rgb = (\s -> s { gp_major_colour = rgb })
grid_major_line_width :: Double -> GridContextF
grid_major_line_width lw = (\s -> s { gp_major_lnwidth = lw })
grid_major_dotnum :: Int -> GridContextF
grid_major_dotnum n = (\s -> s { gp_major_dotnum = n })
grid_minor_subdivisions :: Int -> GridContextF
grid_minor_subdivisions n = (\s -> s { gp_major_dotnum = n })
grid_minor_colour :: RGBi -> GridContextF
grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb })
grid_minor_line_width :: Double -> GridContextF
grid_minor_line_width lw = (\s -> s { gp_minor_lnwidth = lw })
grid_minor_dotnum :: Int -> GridContextF
grid_minor_dotnum n = (\s -> s { gp_minor_dotnum = n })
grid_point_size :: FontSize -> GridContextF
grid_point_size i = (\s -> s { gp_point_size = i })
grid_label_colour :: RGBi -> GridContextF
grid_label_colour rgb = (\s -> s { gp_label_colour = rgb })
gridMinor :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> (Int,Int) -> GridProps -> Graphic u
gridMinor bl tr props =
let mi = minorInterior bl tr (gp_minor_subdivs props)
minF = lineProps (gp_minor_colour props) (gp_minor_lnwidth props)
(gp_minor_dotnum props)
in localize minF mi
gridMajor :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> (Int,Int) -> GridProps -> Graphic u
gridMajor bl tr props =
let mj = majorInterior bl tr
outer = outerRect bl tr
majF = lineProps (gp_major_colour props) (gp_major_lnwidth props)
(gp_major_dotnum props)
in localize majF (mj `oplus` outer)
lineProps :: RGBi -> Double -> Int -> DrawingContextF
lineProps rgb lw n
| n < 1 = stroke_colour rgb . set_line_width lw . solid_line
| otherwise = stroke_colour rgb . set_line_width lw . dashesF
where
dashesF = set_dash_pattern $ Dash 0 [(1,n)]
outerRect :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> (Int,Int) -> Graphic u
outerRect cbl@(xmin,ymin) (xmaj,ymaj) =
snapmove (xmajxmin, ymajymin) >>= \(V2 uw uh) ->
position cbl >>= \bl ->
strokedRectangle uw uh `at` bl
majorInterior :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> (Int,Int) -> Graphic u
majorInterior cbl@(xmin,ymin) (xmaj,ymaj) =
snapmove (xmajxmin, ymajymin) >>= \(V2 uw uh) ->
snapmove (1,1) >>= \(V2 w1 h1) ->
position cbl >>= \bl ->
let xcount = sub1 (xmaj xmin)
ycount = sub1 (ymaj ymin)
hlines = chainlike ycount (displaceV h1) (hline uw)
vlines = chainlike xcount (displaceH w1) (vline uh)
in (apply1R1 hlines $ displaceV h1 bl)
`oplus` (apply1R1 vlines $ displaceH w1 bl)
minorInterior :: (Fractional u, InterpretUnit u)
=> (Int,Int) -> (Int,Int) -> Int -> Graphic u
minorInterior cbl@(xmin,ymin) (xmaj,ymaj) scount =
snapmove (xmajxmin, ymajymin) >>= \(V2 uw uh) ->
snapmove (1,1) >>= \(V2 w1 h1) ->
position cbl >>= \bl ->
let xcount = xmaj xmin
ycount = ymaj ymin
subw1 = w1 / fromIntegral scount
subh1 = h1 / fromIntegral scount
hlines1 = moveStart (displaceV subh1)
$ chainlike (scount1) (displaceV subh1) (hline uw)
vlines1 = moveStart (displaceH subw1)
$ chainlike (scount1) (displaceH subw1) (vline uh)
hlines = chainlike ycount (displaceV h1) hlines1
vlines = chainlike xcount (displaceH w1) vlines1
in (apply1R1 hlines bl)
`oplus` (apply1R1 vlines bl)
chainlike :: Int -> PointDisplace u -> LocGraphic u -> LocGraphic u
chainlike i mv g = promoteR1 $ \start -> go (i1) (g `at` start) (mv start)
where
go n acc pt | n < 1 = acc
| otherwise = go (n1) (acc `oplus` (g `at` pt)) (mv pt)
vline :: InterpretUnit u => u -> LocGraphic u
vline len = locStraightLine $ vvec len
hline :: InterpretUnit u => u -> LocGraphic u
hline len = locStraightLine $ hvec len
sub1 :: Num u => u -> u
sub1 = subtract 1