{-# LANGUAGE KindSignatures #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.DrawingContext -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- 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)