module Wumpus.Basic.Graphic.Query
(
textAttr
, withTextAttr
, strokeAttr
, withStrokeAttr
, fillAttr
, withFillAttr
, borderedAttr
, withBorderedAttr
, lineWidth
, fontSize
, markHeight
, markHalfHeight
, lineSpacing
, monoCharWidth
, monoSpacerWidth
, monoTextWidth
, monoTextLength
, monoTextHeight
, monoNumeralHeight
, monoLowerxHeight
, monoDescenderDepth
, monoTextDimensions
, monoVecToCenter
) where
import Wumpus.Basic.Graphic.Base
import Wumpus.Basic.Graphic.DrawingContext
import Wumpus.Core
import Control.Applicative
textAttr :: (Applicative m, DrawingCtxM m) => m (RGBi,FontAttr)
textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props
withTextAttr :: (Applicative m, DrawingCtxM m)
=> (RGBi -> FontAttr -> a) -> m a
withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props
strokeAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr)
strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props
withStrokeAttr :: (Applicative m, DrawingCtxM m)
=> (RGBi -> StrokeAttr -> a) -> m a
withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props
fillAttr :: (Applicative m, DrawingCtxM m) => m RGBi
fillAttr = asksDC fill_colour
withFillAttr :: (Applicative m, DrawingCtxM m) => (RGBi -> a) -> m a
withFillAttr fn = fn <$> asksDC fill_colour
borderedAttr :: (Applicative m, DrawingCtxM m) => m (RGBi, StrokeAttr, RGBi)
borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props
<*> asksDC stroke_colour
withBorderedAttr :: (Applicative m, DrawingCtxM m)
=> (RGBi -> StrokeAttr -> RGBi -> a) -> m a
withBorderedAttr fn =
fn <$> asksDC fill_colour <*> asksDC stroke_props
<*> asksDC stroke_colour
lineWidth :: (Applicative m, DrawingCtxM m) => m Double
lineWidth = line_width <$> asksDC stroke_props
fontSize :: (Applicative m, DrawingCtxM m) => m Int
fontSize = font_size <$> asksDC font_props
lineSpacing :: (Applicative m, DrawingCtxM m, Fractional u) => m u
lineSpacing =
(\sz factor -> realToFrac $ factor * fromIntegral sz)
<$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor
markHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDC font_props
markHalfHeight :: (Applicative m, DrawingCtxM m, Fractional u, FromPtSize u)
=> m u
markHalfHeight = (0.5*) <$> markHeight
withFontSize :: (Applicative m, DrawingCtxM m) => (FontSize -> u) -> m u
withFontSize fn = (fn . font_size) <$> asksDC font_props
monoCharWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoCharWidth = withFontSize (fromPtSize . charWidth)
monoSpacerWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoSpacerWidth = withFontSize (fromPtSize . spacerWidth)
monoTextWidth :: (Applicative m, DrawingCtxM m, FromPtSize u) => Int -> m u
monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n
monoTextLength :: (Applicative m, DrawingCtxM m, FromPtSize u) => String -> m u
monoTextLength ss = monoTextWidth $ charCount ss
monoTextHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoTextHeight = withFontSize (fromPtSize . textHeight)
monoNumeralHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoNumeralHeight = withFontSize (fromPtSize . numeralHeight)
monoLowerxHeight :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoLowerxHeight = withFontSize (fromPtSize . xcharHeight)
monoDescenderDepth :: (Applicative m, DrawingCtxM m, FromPtSize u) => m u
monoDescenderDepth = withFontSize (fromPtSize . descenderDepth)
monoTextDimensions :: (Applicative m, 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)
monoVecToCenter :: ( Applicative m, 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