DrawingContext.hs

{-# LANGUAGE KindSignatures             #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Base.DrawingContext
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Drawing attributes
--
-- \*\* WARNING \*\* - The drawing context modules need systematic 
-- naming schemes both for update functions (primaryColour, ...) 
-- and for synthesized selectors (e.g. lowerxHeight). The current 
-- names in @QueryDC@ and @UpdateDC@ are expected to change.
--
-- 
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Base.DrawingContext
  ( 

  -- * Drawing context
    DrawingContext(..)
  , DrawingContextF

  , TextMargin(..)

  , standardContext
  , metricsContext

  , default_drawing_context

  -- * DrawingCtxM (reader) monad
  , DrawingCtxM(..)
  , asksDC


  -- * Glyph metrics
  , withFontMetrics

  
  ) where


import Wumpus.Basic.Kernel.Base.GlyphMetrics

import Wumpus.Core                              -- package: wumpus-core
import Wumpus.Core.Text.StandardEncoding

import Control.Applicative
import Data.Maybe

-- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic. 
-- DrawingContext is operated on within a Reader monad rather than 
-- a State monad so \"updates\" are delineated within a @local@ 
-- operation (called @localize@ in Wumpus), rather than permanent
-- until overridden as per @set@ of a State monad.
-- 
-- Note - @round_corner_factor@ is only accounted for by some 
-- graphic objects (certain Path objects and Shapes in 
-- Wumpus-Drawing for instance). There many be many objects that 
-- ignore it and are drawn only with angular corners.
-- 
-- Also note - in contrast to most other drawing objects in 
-- Wumpus, none of the measurement values are parameteric - 
-- usually notated with the type variable @u@ in Wumpus. This is 
-- so Wumpus can (potentially) support different units e.g. 
-- centimeters rather than just Doubles (represening printers 
-- points), though adding support for other units has a very low 
-- priority.
-- 
data DrawingContext = DrawingContext
      { glyph_tables          :: GlyphMetrics
      , fallback_metrics      :: MetricsOps
      , stroke_props          :: StrokeAttr
      , font_props            :: FontAttr
      , stroke_colour         :: RGBi      -- also text colour...
      , fill_colour           :: RGBi      
      , line_spacing_factor   :: Double
      , round_corner_factor   :: Double 
      , text_margin           :: TextMargin
      }

-- TODO - what parts of the Drawing Context should be strict? 


-- | Type synonym for DrawingContext update functions.
--
type DrawingContextF = DrawingContext -> DrawingContext

-- | The unit of Margin is always Double representing Points, e.g.
-- 1.0 is 1 Point. Margins are not scaled relative to the current
-- font size.
-- 
-- The default value is 2 point.
--
data TextMargin = TextMargin
       { text_margin_x          :: !Double
       , text_margin_y          :: !Double
       }



standardContext :: FontSize -> DrawingContext
standardContext sz = 
    DrawingContext { glyph_tables         = emptyGlyphMetrics
                   , fallback_metrics     = monospace_metrics
                   , stroke_props         = default_stroke_attr
                   , font_props           = FontAttr sz wumpus_courier
                   , stroke_colour        = wumpus_black
                   , fill_colour          = wumpus_light_gray
                   , line_spacing_factor  = 1.2  
                   , round_corner_factor  = 0
                   , text_margin          = standardTextMargin
                   }

standardTextMargin :: TextMargin
standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 }

-- out-of-date - should be adding loaded fonts, not replacing the 
-- GlyphMetrics Map wholesale.
--
metricsContext :: FontSize -> GlyphMetrics -> DrawingContext
metricsContext sz bgm = 
    let env = standardContext sz in env { glyph_tables = bgm }


wumpus_black            :: RGBi
wumpus_black            = RGBi 0 0 0 

wumpus_light_gray       :: RGBi
wumpus_light_gray       = RGBi 200 200 200


-- | Courier
-- 
wumpus_courier :: FontFace
wumpus_courier = 
    FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding



default_drawing_context :: DrawingContext
default_drawing_context = 
    standardContext (font_size wumpus_default_font)



--------------------------------------------------------------------------------


class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where
  askDC    :: m DrawingContext
  localize :: (DrawingContext -> DrawingContext) -> m a -> m a


-- | Project a value out of a context.
--
asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a
asksDC f = askDC >>= (return . f)



--------------------------------------------------------------------------------
-- Glyph metrics

-- These are directly on the DrawingContext /for efficiency/.



withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u
withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = 
      fn metric_set point_sz
  where 
    ps_name     = ps_font_name $ font_face font_stats
    point_sz    = fromIntegral $ font_size font_stats 
    metric_set  = fromMaybe (fallback_metrics ctx) $ 
                    lookupFont ps_name (glyph_tables ctx)