module Wumpus.Basic.Kernel.Base.QueryDC
(
textAttr
, withTextAttr
, strokeAttr
, withStrokeAttr
, fillAttr
, withFillAttr
, borderedAttr
, withBorderedAttr
, getRoundCornerSize
, getTextMargin
, getLineWidth
, getFontAttr
, getFontSize
, getFontFace
, markHeight
, markHalfHeight
, baselineSpacing
, glyphBoundingBox
, glyphHeightRange
, glyphHeight
, glyphCapHeight
, cwLookupTable
, 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
import qualified Wumpus.Core.FontSize as FS
import Control.Applicative
textAttr :: DrawingCtxM m => m (RGBi,FontAttr)
textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props
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
getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)
<$> asksDC round_corner_factor
getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u)
getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))
<$> asksDC text_margin
where
fn d = (realToFrac d) * fromPtSize 1
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
baselineSpacing :: (DrawingCtxM m, Fractional u) => m u
baselineSpacing =
(\sz factor -> realToFrac $ factor * fromIntegral sz)
<$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor
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
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
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)
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)
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)
monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u)
=> Int -> m u
monoMultiLineHeight n | n < 0 = pure 0
monoMultiLineHeight n =
(\h lsf -> h + (fromIntegral $ n1) * (h * realToFrac lsf))
<$> monoTotalCharHeight <*> asksDC line_spacing_factor
monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u
monoDefaultPadding = (0.5*) <$> monoCharWidth
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