{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Extras.Grids
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Drawing grids
-- 
--------------------------------------------------------------------------------

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.Drawing.Basis.LocTrace

import Wumpus.Basic.Kernel                      -- package: wumpus-basic
import Wumpus.Core                              -- package: wumpus-core
import Wumpus.Core.Colour ( black )

import Data.Monoid


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 




standard_grid :: GridContextF
standard_grid = id

dotted_major_grid :: GridContextF
dotted_major_grid = 
    grid_minor_subdivisions 0 . grid_major_dotnum 2

-- Setters for client code.

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 })




-- Drawing context updaters...

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 :: Num u 
           => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u 
           -> LocGraphic u
minorMajor count alt mv mnr mjr = execLocTrace (step count)
  where
    step n | n <= 0           = return ()
           | n `mod` alt == 0 = insertl mjr >> moveBy mv >> step (n-1)
           | otherwise        = insertl mnr >> moveBy mv >> step (n-1)