{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.UpdateDC -- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Customize drawing attributes. The functions here are -- @DrawingContext@ modifiers to be run within a the scope of a -- @localize@ block (cf. @local@ of the Reader monad). -- -- By convention, underscore-separated names are used for -- DrawingContext modifiers in this module. This is because the -- modifiers defined here are expected to be used mostly as static -- \"properties\" resembling constants in drawings. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.UpdateDC ( -- * Globals snap_grid_factors -- * Line widths , set_line_width , line_default , line_thin , line_thick , line_ultra_thick , contextual_line_width , relative_line_width -- * Line cap , cap_default , cap_butt , cap_round , cap_square -- * Line join , join_default , join_miter , join_round , join_bevel -- * Dash pattern , set_dash_pattern , solid_line , dotted_line , packed_dotted , loose_dotted , dashed_line , packed_dashed , loose_dashed -- * Font properties , font_attr , set_font , set_font_size , scale_point_size , double_point_size , half_point_size -- * Text margins , text_margin , text_margin_none , text_margin_tight , text_margin_default , text_margin_loose -- * Colour , stroke_colour , fill_colour , text_colour , single_colour , swap_colours , fill_use_stroke_colour , stroke_use_fill_colour , fill_use_text_colour , stroke_use_text_colour , text_use_stroke_colour , text_use_fill_colour ) where import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.Units import Wumpus.Core -- package: wumpus-core import Control.Applicative -------------------------------------------------------------------------------- -- helpers updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF updateStrokeProps fn = (\s i -> s { dc_stroke_props = fn i }) <*> dc_stroke_props withFontSize :: (FontSize -> DrawingContextF) -> DrawingContextF withFontSize fn = (\s i -> fn i s) <*> dc_font_size -------------------------------------------------------------------------------- -- | 'snap_grid_factors' : @ x_unit * y_unit -> DrawingContextF @ -- -- Set the @snap grid factors@ - a snap grid is an alternative -- coordinate space, it can be convenient for drawing -- \"box and arrow\" diagrams. -- snap_grid_factors :: Double -> Double -> DrawingContextF snap_grid_factors xu yu = \s -> s { dc_snap_grid_factors = (xu, yu) } -------------------------------------------------------------------------------- -- line widths -- | set_line_width : @ width_in_points -> DrawingContextF @ -- -- Set the line_width to the supplied point size. -- -- Initially the line width is 1.0. -- -- /Constant/ variations of the function maybe be more -- convenient: -- -- > line_default, line_thin, line_thick, line_ultra_thick -- set_line_width :: Double -> DrawingContextF set_line_width d = updateStrokeProps (\s -> s { line_width = d }) -- | Set the line_width to @default@ - 1.0. -- line_default :: DrawingContextF line_default = set_line_width 1.0 -- | Set the line_width to @thin@ - 0.5. -- line_thin :: DrawingContextF line_thin = set_line_width 0.5 -- | Set the line_width to @thick@ - 2.0. -- line_thick :: DrawingContextF line_thick = set_line_width 2.0 -- | Set the line_width to @ultra_thick@ - 4.0. -- line_ultra_thick :: DrawingContextF line_ultra_thick = set_line_width 4.0 -- | Scale the line width respective to its current value. -- -- The size is calculated with the supplied function. -- relative_line_width :: (Double -> Double) -> DrawingContextF relative_line_width fn = updateStrokeProps (\s -> let lw = line_width s in s { line_width = fn lw }) -- | Set the line width to a size relative to the current font -- size. The size is calculated with the supplied function. -- contextual_line_width :: (FontSize -> Double) -> DrawingContextF contextual_line_width fn = withFontSize $ \sz s -> set_line_width (fn sz) s -------------------------------------------------------------------------------- -- Line props setLineCap :: LineCap -> DrawingContextF setLineCap d = updateStrokeProps (\s -> s { line_cap = d }) setLineJoin :: LineJoin -> DrawingContextF setLineJoin d = updateStrokeProps (\s -> s { line_join = d }) -- | Set the line_cap to the default which is @butt@. -- -- This is a synonym for 'cap_butt'. -- cap_default :: DrawingContextF cap_default = cap_butt -- | Set the line_cap to @butt@. -- -- Butt chamfers off the stroke, flush to the end point. -- -- This is the default. -- -- > .-------. -- > |=======| -- > '-------' -- cap_butt :: DrawingContextF cap_butt = setLineCap CapButt -- | Set the line_cap to @round@. -- -- This rounds the end of the stroke and the visually the -- rounding slightly extends the length of the line. -- -- > .-------. -- > ( ======= ) -- > '-------' -- cap_round :: DrawingContextF cap_round = setLineCap CapRound -- | Set the line_cap to @square@. -- -- This squares off the end of the stroke, but visual extends the -- stroke by half the line width. -- -- > .---------. -- > | ======= | -- > '---------' -- cap_square :: DrawingContextF cap_square = setLineCap CapSquare -- | Set the line_join to the default which is @miter@. -- -- This is a synonym for 'join_miter'. -- join_default :: DrawingContextF join_default = join_miter -- | Set the line_join to @miter@. -- -- This extends the joining line segments to form a sharp miter. -- -- This is the default. -- -- > /\ -- > /..\ -- > /./\.\ -- > /./ \.\ -- > /./ \.\ -- join_miter :: DrawingContextF join_miter = setLineJoin JoinMiter -- | Set the line_join to @round@. -- -- This rounds off the corner of the joined line segments. -- -- > \.\ -- > \.\ -- > ,.) -- > /./ -- > /./ -- join_round :: DrawingContextF join_round = setLineJoin JoinRound -- | Set the line_join to @round@. -- -- This bevels off the corner of the joined line segments with a -- notch. -- -- > __ -- > /..\ -- > /./\.\ -- > /./ \.\ -- > /./ \.\ -- join_bevel :: DrawingContextF join_bevel = setLineJoin JoinBevel -------------------------------------------------------------------------------- -- | Set the dash pattern. -- -- Initially the dash pattern is 'Solid'. -- set_dash_pattern :: DashPattern -> DrawingContextF set_dash_pattern d = updateStrokeProps (\s -> s { dash_pattern = d }) -- | Set the dash_pattern to @solid@ - i.e. no dash pattern. -- -- This is the default. -- solid_line :: DrawingContextF solid_line = set_dash_pattern Solid -- | Set the dash pattern to draw a dotted line. -- -- A dot is actually a square - side length is equal to the line -- width. -- -- The spacing between dots is 2 times the dot width. -- dotted_line :: DrawingContextF dotted_line = set_dash_pattern $ Dash 0 [(1,2)] -- | Set the dash pattern to draw a tightly packed dotted line. -- -- A dot is actually a square - side length is equal to the line -- width. -- -- The spacing between dots is equal to the dot width. -- packed_dotted :: DrawingContextF packed_dotted = set_dash_pattern $ Dash 0 [(1,1)] -- | Set the dash pattern to draw a loosely dotted line. -- -- A dot is actually a square - side length is equal to the line -- width. -- -- The spacing between dots is 4 times the dot width. -- loose_dotted :: DrawingContextF loose_dotted = set_dash_pattern $ Dash 0 [(1,4)] -- | Set the dash pattern to draw a dashed line. -- -- The dash length is 3 times the line width, the spacing is 2 -- times the line width. -- dashed_line :: DrawingContextF dashed_line = set_dash_pattern $ Dash 0 [(3,2)] -- | Set the dash pattern to draw a tightly packed, dashed line. -- -- The dash length is 3 times the line width, the spacing is -- equal to the line width. -- packed_dashed :: DrawingContextF packed_dashed = set_dash_pattern $ Dash 0 [(3,1)] -- | Set the dash pattern to draw a loosely dashed line. -- -- The dash length is 3 times the line width, the spacing is 4 -- times the line width. -- loose_dashed :: DrawingContextF loose_dashed = set_dash_pattern $ Dash 0 [(3,4)] -------------------------------------------------------------------------------- -- | Set the font attributes, point size and font face. -- font_attr :: FontDef -> Int -> DrawingContextF font_attr ft sz = \s -> s { dc_font_size = sz , dc_font_face = font_def_face ft } -- | Set the font face. -- set_font :: FontDef -> DrawingContextF set_font ft = \s -> s { dc_font_face = font_def_face ft } -- | Set the point size. -- -- This controls the drawing size of both -- text labels and marks (e.g. dots and arrowheads). -- set_font_size :: Int -> DrawingContextF set_font_size sz = \s -> s { dc_font_size = sz } -- | Scale the current point size by the supplied ratio. -- -- Note - as fonts can only be drawn at integral sizes this -- operation is not exact - for instance scaling 15pt by (1%2) -- results in 7pt. -- scale_point_size :: Double -> DrawingContextF scale_point_size a = (\s sz -> set_font_size (floor $ a * fromIntegral sz) s) <*> dc_font_size -- | Set the point size (font and mark size) to double the current -- size. -- double_point_size :: DrawingContextF double_point_size = scale_point_size 2 -- | Set the point size to half the current size, note the point -- size also controls the size of dots, arrowsheads etc. -- -- Note - as fonts can only be drawn at integral sizes this -- operation is not exact - half size of 15pt type is 7pt. -- half_point_size :: DrawingContextF half_point_size = scale_point_size 0.5 -- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @ -- -- Note - this is in @Em@ units. -- text_margin :: Em -> Em -> DrawingContextF text_margin xsep ysep = \s -> s { dc_text_margin = TextMargin xsep ysep } -- | Set the text margin to (0,0). -- -- This produces a tight box around the text vertically measured -- to the cap-height and descender. Therefore some characters may -- extend outside the margin (e.g. accented capitals like -- A-grave). -- text_margin_none :: DrawingContextF text_margin_none = text_margin 0 0 -- | Set the text margin to (0.25 em, 0.25 em). -- text_margin_tight :: DrawingContextF text_margin_tight = text_margin 0.25 0.25 -- | Set the text margin to (0.5 em, 0.5 em). -- text_margin_default :: DrawingContextF text_margin_default = text_margin 0.5 0.5 -- | Set the text margin to (1.0 em, 1.0 em). -- text_margin_loose :: DrawingContextF text_margin_loose = text_margin 1.0 1.0 -------------------------------------------------------------------------------- -- | Set the stroke colour. -- stroke_colour :: RGBi -> DrawingContextF stroke_colour rgb = \s -> s { dc_stroke_colour = rgb } -- | Set the fill colour. -- fill_colour :: RGBi -> DrawingContextF fill_colour rgb = \s -> s { dc_fill_colour = rgb } -- | Set the text colour. -- text_colour :: RGBi -> DrawingContextF text_colour rgb = (\s -> s { dc_text_colour = rgb}) -- | Set the stroke, fill and text colours to a single colour. -- single_colour :: RGBi -> DrawingContextF single_colour rgb = stroke_colour rgb . fill_colour rgb . text_colour rgb -- | Swap the stroke colour and fill colours. -- swap_colours :: DrawingContextF swap_colours = (\s a b -> s { dc_stroke_colour = b, dc_fill_colour = a }) <*> dc_stroke_colour <*> dc_fill_colour -- | Set the fill colour to use the current stroke colour. -- fill_use_stroke_colour :: DrawingContextF fill_use_stroke_colour = (\s a -> s { dc_fill_colour = a }) <*> dc_stroke_colour -- | Set the stroke colour to use the current fill colour. -- stroke_use_fill_colour :: DrawingContextF stroke_use_fill_colour = (\s a -> s { dc_stroke_colour = a }) <*> dc_fill_colour -- | Set the fill colour to use the current text colour. -- fill_use_text_colour :: DrawingContextF fill_use_text_colour = (\s a -> s { dc_fill_colour = a }) <*> dc_text_colour -- | Set the stroke colour to use the current fill colour. -- stroke_use_text_colour :: DrawingContextF stroke_use_text_colour = (\s a -> s { dc_stroke_colour = a }) <*> dc_text_colour -- | Set the text colour to use the current stroke colour. -- text_use_stroke_colour :: DrawingContextF text_use_stroke_colour = (\s a -> s { dc_text_colour = a }) <*> dc_stroke_colour -- | Set the text colour to use the current fill colour. -- text_use_fill_colour :: DrawingContextF text_use_fill_colour = (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour