module Wumpus.Drawing.Extras.Grids
(
GridContextF
, grid
, standard_grid
, dotted_major_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.Drawing.Basis.DrawingPrimitives
import Wumpus.Basic.Kernel
import Wumpus.Core
import Wumpus.Core.Colour ( black )
import Data.Monoid
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
standard_grid :: GridContextF
standard_grid = id
dotted_major_grid :: GridContextF
dotted_major_grid =
grid_minor_subdivisions 0 . grid_major_dotnum 2
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_minor_subdivs = 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 })
major_line_update :: GridProps -> DrawingContextF
major_line_update (GridProps { gp_major_colour = rgb
, gp_major_lnwidth = lnwidth
, gp_major_dotnum = dotnum }) =
lineProps rgb lnwidth dotnum
minor_line_update :: GridProps -> DrawingContextF
minor_line_update (GridProps { gp_minor_colour = rgb
, gp_minor_lnwidth = lnwidth
, gp_minor_dotnum = dotnum }) =
lineProps rgb lnwidth dotnum
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)]
grid :: (Fractional u, InterpretUnit u)
=> GridContextF -> Int -> Int -> LocGraphic u
grid upd nx ny =
snapmove (1,1) >>= \(V2 uw uh) ->
let props = upd default_grid_props
width = uw * fromIntegral nx
height = uh * fromIntegral ny
intrr = gridInterior nx width uw ny height uh props
rect = localize (major_line_update props) $
blRectangle STROKE width height
in intrr `mappend` rect
gridInterior :: (Fractional u, InterpretUnit u)
=> Int -> u -> u -> Int -> u -> u -> GridProps -> LocGraphic u
gridInterior nx w uw ny h uh props = hlines `mappend` vlines
where
hlines = horizontalLines ny w uh props
vlines = verticalLines nx h uw props
horizontalLines :: (Fractional u, InterpretUnit u)
=> Int -> u -> u -> GridProps -> LocGraphic u
horizontalLines numh w uh props@(GridProps { gp_minor_subdivs = subs })
| subs > 0 = let dy = uh / (fromIntegral subs)
n = (numh * subs) 1
in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr
| otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr
where
mnr = localize (minor_line_update props) $ hline w
mjr = localize (major_line_update props) $ hline w
verticalLines :: (Fractional u, InterpretUnit u)
=> Int -> u -> u -> GridProps -> LocGraphic u
verticalLines numv h uw props@(GridProps { gp_minor_subdivs = subs })
| subs > 0 = let dx = uw / (fromIntegral subs)
n = (numv * subs) 1
in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr
| otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr
where
mnr = localize (minor_line_update props) $ vline h
mjr = localize (major_line_update props) $ vline h
minorMajor :: InterpretUnit u
=> Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u
-> LocGraphic u
minorMajor count alt mv mnr mjr = runLocTrace (step count)
where
step n | n <= 0 = ureturn
| n `mod` alt == 0 = insertl mjr >> moveby mv >> step (n1)
| otherwise = insertl mnr >> moveby mv >> step (n1)