module Wumpus.Basic.Kernel.Objects.CtxPicture
(
CtxPicture
, DCtxPicture
, runCtxPicture
, runCtxPictureU
, drawTracing
, clipCtxPicture
, mapCtxPicture
, over
, under
, centric
, nextToH
, nextToV
, atPoint
, centeredAt
, zconcat
, hcat
, vcat
, hspace
, vspace
, hsep
, vsep
, alignH
, alignV
, alignHSep
, alignVSep
, hcatA
, vcatA
, hsepA
, vsepA
) where
import Wumpus.Basic.Kernel.Base.Anchors
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Objects.TraceDrawing
import Wumpus.Core
import Data.AdditiveGroup
import Data.AffineSpace
import Control.Applicative
import Data.List ( foldl' )
newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }
type DCtxPicture = CtxPicture Double
type instance DUnit (CtxPicture u) = u
runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)
runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)
runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u
runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df
where
fk = error "runCtxPictureU - empty CtxPicture."
drawTracing :: (Real u, Floating u, FromPtSize u)
=> TraceDrawing u a -> CtxPicture u
drawTracing mf = CtxPicture $
drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )
clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u
clipCtxPicture cpath = mapCtxPicture (clip cpath)
mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u
mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture
instance (Real u, Floating u) => Rotate (CtxPicture u) where
rotate ang = mapCtxPicture (rotate ang)
instance (Real u, Floating u) => RotateAbout (CtxPicture u) where
rotateAbout r pt = mapCtxPicture (rotateAbout r pt)
instance (Num u, Ord u) => Scale (CtxPicture u) where
scale sx sy = mapCtxPicture (scale sx sy)
instance (Num u, Ord u) => Translate (CtxPicture u) where
translate dx dy = mapCtxPicture (translate dx dy)
boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a
boundaryExtr f = f . boundary
boundaryCtr :: Fractional u => Picture u -> Point2 u
boundaryCtr = boundaryExtr center
boundaryN :: Fractional u => Picture u -> Point2 u
boundaryN = boundaryExtr north
boundaryS :: Fractional u => Picture u -> Point2 u
boundaryS = boundaryExtr south
boundaryE :: Fractional u => Picture u -> Point2 u
boundaryE = boundaryExtr east
boundaryW :: Fractional u => Picture u -> Point2 u
boundaryW = boundaryExtr west
boundaryNW :: Fractional u => Picture u -> Point2 u
boundaryNW = boundaryExtr northwest
boundaryNE :: Picture u -> Point2 u
boundaryNE = boundaryExtr ur_corner
boundarySW :: Picture u -> Point2 u
boundarySW = boundaryExtr ll_corner
boundarySE :: Fractional u => Picture u -> Point2 u
boundarySE = boundaryExtr southeast
boundaryLeftEdge :: Picture u -> u
boundaryLeftEdge = boundaryExtr (point_x . ll_corner)
boundaryRightEdge :: Picture u -> u
boundaryRightEdge = boundaryExtr (point_x . ur_corner)
boundaryBottomEdge :: Picture u -> u
boundaryBottomEdge = boundaryExtr (point_y . ll_corner)
boundaryTopEdge :: Picture u -> u
boundaryTopEdge = boundaryExtr (point_y . ur_corner)
empty_drawing :: (Real u, Floating u, FromPtSize u) => CtxPicture u
empty_drawing = drawTracing $ return ()
drawingConcat :: (Picture u -> Picture u -> Picture u)
-> CtxPicture u -> CtxPicture u -> CtxPicture u
drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)
mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)
mbpostcomb op = liftA2 fn
where
fn (Just a) (Just b) = Just $ a `op` b
fn a Nothing = a
fn Nothing b = b
megaCombR :: (Num u, Ord u)
=> (Picture u -> a) -> (Picture u -> a)
-> (a -> a -> Picture u -> Picture u)
-> CtxPicture u -> CtxPicture u
-> CtxPicture u
megaCombR qL qR trafoR = drawingConcat fn
where
fn pic1 pic2 = let a = qL pic1
b = qR pic2
p2 = trafoR a b pic2
in pic1 `picOver` p2
over :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
over = drawingConcat picOver
under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
under = flip over
move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u
move v = mapCtxPicture (\p -> p `picMoveBy` v)
infixr 5 `nextToV`
infixr 6 `nextToH`, `centric`
centric :: (Fractional u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
centric = megaCombR boundaryCtr boundaryCtr moveFun
where
moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v
nextToH :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (a b)
nextToV :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b drw = drw `picMoveBy` vvec (a b)
atPoint :: (Num u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u
p `atPoint` (P2 x y) = move (V2 x y) p
centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u
centeredAt d (P2 x y) = mapCtxPicture fn d
where
fn p = let bb = boundary p
dx = x (boundaryWidth bb * 0.5)
dy = y (boundaryHeight bb * 0.5)
in p `picMoveBy` vec dx dy
zconcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
zconcat [] = empty_drawing
zconcat (d:ds) = foldl' over d ds
hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
hcat [] = empty_drawing
hcat (d:ds) = foldl' nextToH d ds
vcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u
vcat [] = empty_drawing
vcat (d:ds) = foldl' nextToV d ds
hspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (n + a b)
vspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b pic = pic `picMoveBy` vvec (a b n)
hsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u
hsep _ [] = empty_drawing
hsep n (d:ds) = foldl' (hspace n) d ds
vsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u
vsep _ [] = empty_drawing
vsep n (d:ds) = foldl' (vspace n) d ds
alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u
alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)
alignH :: (Fractional u, Ord u)
=> HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
alignH HTop = megaCombR boundaryNE boundaryNW alignMove
alignH HCenter = megaCombR boundaryE boundaryW alignMove
alignH HBottom = megaCombR boundarySE boundarySW alignMove
alignV :: (Fractional u, Ord u)
=> VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
alignV VLeft = megaCombR boundarySW boundaryNW alignMove
alignV VCenter = megaCombR boundaryS boundaryN alignMove
alignV VRight = megaCombR boundarySE boundaryNE alignMove
alignMove2 :: (Num u, Ord u)
=> Vec2 u -> Point2 u -> Point2 u -> Picture u -> Picture u
alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2))
alignHSep :: (Fractional u, Ord u)
=> HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
alignHSep HTop dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
alignHSep HCenter dx = megaCombR boundaryE boundaryW (alignMove2 (hvec dx))
alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))
alignVSep :: (Fractional u, Ord u)
=> VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
alignVSep VLeft dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (dy))
alignVSep VCenter dy = megaCombR boundaryS boundaryN (alignMove2 $ vvec (dy))
alignVSep VRight dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (dy))
hcatA :: (Real u, Floating u, FromPtSize u)
=> HAlign -> [CtxPicture u] -> CtxPicture u
hcatA _ [] = empty_drawing
hcatA ha (d:ds) = foldl' (alignH ha) d ds
vcatA :: (Real u, Floating u, FromPtSize u)
=> VAlign -> [CtxPicture u] -> CtxPicture u
vcatA _ [] = empty_drawing
vcatA va (d:ds) = foldl' (alignV va) d ds
hsepA :: (Real u, Floating u, FromPtSize u)
=> HAlign -> u -> [CtxPicture u] -> CtxPicture u
hsepA _ _ [] = empty_drawing
hsepA ha n (d:ds) = foldl' op d ds
where
a `op` b = alignHSep ha n a b
vsepA :: (Real u, Floating u, FromPtSize u)
=> VAlign -> u -> [CtxPicture u] -> CtxPicture u
vsepA _ _ [] = empty_drawing
vsepA va n (d:ds) = foldl' op d ds
where
a `op` b = alignVSep va n a b