{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.QueryDC -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Querying the Drawing Context. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.QueryDC ( textAttr , withTextAttr , strokeAttr , withStrokeAttr , fillAttr , withFillAttr , borderedAttr , withBorderedAttr , getLineWidth , getFontAttr , getFontSize , getFontFace , markHeight , markHalfHeight , baselineSpacing -- * Glyph metrics , glyphBoundingBox , glyphHeightRange , glyphHeight , glyphCapHeight , cwLookupTable -- * Default monospace metrics , monoFontPointSize , monoCharWidth , monoTextWidth , monoTextLength , monoCapHeight , monoLowerxHeight , monoDescenderDepth , monoAscenderHeight , monoTextDimensions , monoMultiLineHeight , monoDefaultPadding , monoVecToCenter ) where import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.GlyphMetrics import Wumpus.Core -- package: wumpus-core import qualified Wumpus.Core.FontSize as FS import Control.Applicative textAttr :: DrawingCtxM m => m (RGBi,FontAttr) textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props -- | Because @textAttr@ is so commonly used here is a functional -- version that avoids tupling. -- withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props fillAttr :: DrawingCtxM m => m RGBi fillAttr = asksDC fill_colour withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a withFillAttr fn = fn <$> asksDC fill_colour borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi) borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props <*> asksDC stroke_colour withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a withBorderedAttr fn = fn <$> asksDC fill_colour <*> asksDC stroke_props <*> asksDC stroke_colour getLineWidth :: DrawingCtxM m => m Double getLineWidth = line_width <$> asksDC stroke_props getFontAttr :: DrawingCtxM m => m FontAttr getFontAttr = asksDC font_props getFontSize :: DrawingCtxM m => m Int getFontSize = font_size <$> asksDC font_props getFontFace :: DrawingCtxM m => m FontFace getFontFace = font_face <$> asksDC font_props -- | Vertical distance between baselines of consecutive text -- lines. -- baselineSpacing :: (DrawingCtxM m, Fractional u) => m u baselineSpacing = (\sz factor -> realToFrac $ factor * fromIntegral sz) <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor -- | The /mark/ height is the height of a lowercase letter in the -- current font. -- -- Arrowheads, dots etc. should generally be drawn at the mark -- height. -- markHeight :: (DrawingCtxM m, FromPtSize u) => m u markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u markHalfHeight = (0.5*) <$> markHeight -- Note - there are probably enough functions that use just -- markHeight to merit a withMarkHeight function. -------------------------------------------------------------------------------- glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) glyphBoundingBox = glyphQuery get_bounding_box glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u) glyphHeightRange = fn <$> glyphBoundingBox where fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax) glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u glyphCapHeight = glyphQuery get_cap_height cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u) cwLookupTable = glyphQuery get_cw_table -------------------------------------------------------------------------------- withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u withFontSize fn = (fn . font_size) <$> asksDC font_props -- NOTE - textHeight in Wumpus-Core should be renamed as it is -- (probably) more indiactive of Cap height than /font point size/ -- monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u monoFontPointSize = withFontSize (fromPtSize . fromIntegral) monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u monoCharWidth = withFontSize (fromPtSize . FS.charWidth) monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u monoTextLength ss = monoTextWidth $ charCount ss monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u monoCapHeight = withFontSize (fromPtSize . FS.capHeight) monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight) -- | Height of a lower case \'x\' in Courier. -- -- \'x\' has no ascenders or descenders. -- monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight) monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) -- | Query the dimensions of the text using the current font size -- but using metrics derived from Courier. -- -- Note - the width will generally be a over-estimate for -- non-monospaced fonts. -- monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u) => String -> m (u,u) monoTextDimensions ss = (\sz -> post $ textBounds sz zeroPt ss) <$> asksDC (font_size . font_props) where post bb = (boundaryWidth bb, boundaryHeight bb) -- | The heigth of @n@ lines of text, which is -- @n lines + n-1 line spacers@ -- monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => Int -> m u monoMultiLineHeight n | n < 0 = pure 0 monoMultiLineHeight n = (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf)) <$> monoTotalCharHeight <*> asksDC line_spacing_factor -- Note as the height calculation has changed in Wumpus-Core this -- no longer quite works... -- | The default padding is half of the /char width/. -- monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u monoDefaultPadding = (0.5*) <$> monoCharWidth -- | Vector from baseline left to center -- monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) => String -> m (Vec2 u) monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) <$> monoTextDimensions ss <*> monoDescenderDepth