module Wumpus.Basic.Kernel.Base.QueryDC
(
normalizeCtx
, normalizeCtxF
, dinterpCtx
, dinterpCtxF
, uconvertCtx1
, uconvertCtxF
, pointSize
, strokeAttr
, fillAttr
, borderedAttr
, textAttr
, position
, snapmove
, textMargin
, getLineWidth
, getFontAttr
, getFontSize
, getFontFace
, getTextColour
, markHeight
, markHalfHeight
, textlineSpace
, glyphBoundingBox
, capHeight
, descender
, verticalSpan
, cwLookupTable
, connectorSrcSpace
, connectorDstSpace
, connectorSrcOffset
, connectorDstOffset
, connectorArcAngle
, connectorSrcArm
, connectorDstArm
, connectorLoopSize
, connectorBoxHalfSize
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.FontSupport
import Wumpus.Core
import qualified Wumpus.Core.FontSize as FS
import Control.Applicative
normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double
normalizeCtx u = (\sz -> normalize sz u) <$> pointSize
normalizeCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u)
=> t u -> m (t Double)
normalizeCtxF t = (\sz -> fmap (normalize sz) t) <$> pointSize
dinterpCtx :: (DrawingCtxM m, InterpretUnit u) => Double -> m u
dinterpCtx u = (\sz -> dinterp sz u) <$> pointSize
dinterpCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) => t Double -> m (t u)
dinterpCtxF u = (\sz -> fmap (dinterp sz) u) <$> pointSize
uconvertCtx1 :: (DrawingCtxM m, InterpretUnit u, InterpretUnit u1)
=> u -> m u1
uconvertCtx1 t = (\sz -> uconvert1 sz t) <$> pointSize
uconvertCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u, InterpretUnit u1)
=> t u -> m (t u1)
uconvertCtxF t = (\sz -> uconvertF sz t) <$> pointSize
pointSize :: DrawingCtxM m => m FontSize
pointSize = asksDC dc_font_size
strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)
strokeAttr = (,) <$> asksDC dc_stroke_colour <*> asksDC dc_stroke_props
fillAttr :: DrawingCtxM m => m RGBi
fillAttr = asksDC dc_fill_colour
borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi)
borderedAttr = (,,) <$> asksDC dc_fill_colour
<*> asksDC dc_stroke_props
<*> asksDC dc_stroke_colour
textAttr :: DrawingCtxM m => m (RGBi,FontAttr)
textAttr =
(\a b c -> (a, FontAttr b c))
<$> asksDC dc_text_colour <*> asksDC dc_font_size <*> asksDC dc_font_face
position :: (DrawingCtxM m, Fractional u) => (Int, Int) -> m (Point2 u)
position (x,y) = post <$> asksDC dc_snap_grid_factors
where
post (sx,sy) = P2 (realToFrac $ sx * fromIntegral x)
(realToFrac $ sy * fromIntegral y)
snapmove :: (DrawingCtxM m, Fractional u) => (Int,Int) -> m (Vec2 u)
snapmove (x,y) = post <$> asksDC dc_snap_grid_factors
where
post (sx,sy) = V2 (realToFrac $ sx * fromIntegral x)
(realToFrac $ sy * fromIntegral y)
textMargin :: (DrawingCtxM m, InterpretUnit u) => m (u,u)
textMargin = post <$> asksDC dc_font_size <*> asksDC dc_text_margin
where
post sz (TextMargin xem yem) = (uconvert1 sz xem, uconvert1 sz yem)
getLineWidth :: DrawingCtxM m => m Double
getLineWidth = line_width <$> asksDC dc_stroke_props
getFontAttr :: DrawingCtxM m => m FontAttr
getFontAttr = FontAttr <$> asksDC dc_font_size <*> asksDC dc_font_face
getFontSize :: DrawingCtxM m => m Int
getFontSize = asksDC dc_font_size
getFontFace :: DrawingCtxM m => m FontFace
getFontFace = asksDC dc_font_face
getTextColour :: DrawingCtxM m => m RGBi
getTextColour = asksDC dc_text_colour
markHeight :: (DrawingCtxM m, InterpretUnit u) => m u
markHeight = post <$> asksDC dc_font_size
where
post sz = dinterp sz (FS.xcharHeight sz)
markHalfHeight :: (Fractional u, DrawingCtxM m, InterpretUnit u) => m u
markHalfHeight = (0.5*) <$> markHeight
textlineSpace :: (DrawingCtxM m, Fractional u, InterpretUnit u) => m u
textlineSpace =
post <$> asksDC dc_font_size <*> asksDC dc_line_spacing_factor
where
post sz factor = dinterp sz ((fromIntegral sz) * (realToFrac factor))
glyphQuery :: DrawingCtxM m => (FontMetrics -> FontSize -> a) -> m a
glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC
glyphBoundingBox :: (DrawingCtxM m, InterpretUnit u) => m (BoundingBox u)
glyphBoundingBox =
uconvertF <$> asksDC dc_font_size <*> glyphQuery get_bounding_box
capHeight :: (DrawingCtxM m, InterpretUnit u) => m u
capHeight = dinterp <$> asksDC dc_font_size <*> glyphQuery get_cap_height
descender :: (DrawingCtxM m, InterpretUnit u) => m u
descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender
verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u
verticalSpan =
(\ch dd -> ch dd) <$> capHeight <*> descender
cwLookupTable :: DrawingCtxM m => m CharWidthLookup
cwLookupTable = glyphQuery get_cw_table
connectorAsks :: DrawingCtxM m => (ConnectorProps -> a) -> m a
connectorAsks f = f <$> asksDC dc_connector_props
connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) => m u
connectorSrcSpace = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_src_space
connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) => m u
connectorDstSpace = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_dst_space
connectorSrcOffset :: (DrawingCtxM m, InterpretUnit u) => m u
connectorSrcOffset = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_src_offset
connectorDstOffset :: (DrawingCtxM m, InterpretUnit u) => m u
connectorDstOffset = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_dst_offset
connectorArcAngle :: DrawingCtxM m => m Radian
connectorArcAngle = connectorAsks dc_conn_arc_ang
connectorSrcArm :: (DrawingCtxM m, InterpretUnit u) => m u
connectorSrcArm = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_src_arm
connectorDstArm :: (DrawingCtxM m, InterpretUnit u) => m u
connectorDstArm = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_dst_arm
connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) => m u
connectorLoopSize = (\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_loop_size
connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) => m u
connectorBoxHalfSize =
(\sz u -> uconvert1 sz u)
<$> pointSize <*> connectorAsks dc_conn_box_halfsize