{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Extras.Grids -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Drawing grids -- -------------------------------------------------------------------------------- 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 -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Wumpus.Core.Colour ( black ) type GridContextF = GridProps -> GridProps -- | GridProps control the drawing of grids. -- 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)] -- | Coordinates are expected to be normalized. -- outerRect :: (Fractional u, InterpretUnit u) => (Int,Int) -> (Int,Int) -> Graphic u outerRect cbl@(xmin,ymin) (xmaj,ymaj) = snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) -> position cbl >>= \bl -> strokedRectangle uw uh `at` bl -- | The major interior is the snap grid. -- majorInterior :: (Fractional u, InterpretUnit u) => (Int,Int) -> (Int,Int) -> Graphic u majorInterior cbl@(xmin,ymin) (xmaj,ymaj) = snapmove (xmaj-xmin, ymaj-ymin) >>= \(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) -- | The minor interior divides each element of the snap grid. -- minorInterior :: (Fractional u, InterpretUnit u) => (Int,Int) -> (Int,Int) -> Int -> Graphic u minorInterior cbl@(xmin,ymin) (xmaj,ymaj) scount = snapmove (xmaj-xmin, ymaj-ymin) >>= \(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 (scount-1) (displaceV subh1) (hline uw) vlines1 = moveStart (displaceH subw1) $ chainlike (scount-1) (displaceH subw1) (vline uh) hlines = chainlike ycount (displaceV h1) hlines1 vlines = chainlike xcount (displaceH w1) vlines1 in (apply1R1 hlines bl) `oplus` (apply1R1 vlines bl) -- This doesn\'t work as an advGraphic -- | This is an operation chain should support, but chain needs a -- rethink... -- chainlike :: Int -> PointDisplace u -> LocGraphic u -> LocGraphic u chainlike i mv g = promoteR1 $ \start -> go (i-1) (g `at` start) (mv start) where go n acc pt | n < 1 = acc | otherwise = go (n-1) (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