wumpus-basic-0.16.0: src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Kernel.Objects.CtxPicture
-- Copyright : (c) Stephen Tetley 2010-2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- A Picture-with-implicit-context object.
--
-- This is the corresponding type to Picture in the Wumpus-Core.
--
-- Note - many of the composition functions are in
-- /destructor form/. As Wumpus cannot make a Picture from an
-- empty list of Pictures, /destructor form/ decomposes the
-- list into the @head@ and @rest@ as arguments in the function
-- signature, rather than take a possibly empty list and have to
-- throw an error.
--
-- TODO - PosImage no longer supports composition operators, so
-- better names are up for grabs...
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Kernel.Objects.CtxPicture
(
CtxPicture
, DCtxPicture
, runCtxPicture
, runCtxPictureU
, drawTracing
, clipCtxPicture
, mapCtxPicture
-- * Composition
, cxpBeneath
, cxpUniteCenter
, cxpRight
, cxpDown
, cxpCenteredAt
, cxpRow
, cxpColumn
, cxpRightSep
, cxpDownSep
, cxpRowSep
, cxpColumnSep
-- * Compose with alignment
, cxpAlignH
, cxpAlignV
, cxpAlignSepH
, cxpAlignSepV
, cxpAlignRow
, cxpAlignColumn
, cxpAlignRowSep
, cxpAlignColumnSep
) 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 -- package: wumpus-core
import Data.AdditiveGroup -- package: vector-space
import Data.AffineSpace
import Control.Applicative
import Data.List ( foldl' )
-- Note - PosGraphic should take priority for the good names.
-- | A /Contextual Picture/.
--
-- This type corresponds to the 'Picture' type in Wumpus-Core, but
-- it is embedded with a 'DrawingContext' (for font properties,
-- fill colour etc.). So it is a function
-- /from DrawingContext to Picture/.
--
-- Internally the result is actually a (Maybe Picture) and not a
-- Picture, this is a trick to promote the extraction from
-- possibly empty drawings (created by TraceDrawing) to the
-- top-level of the type hierarchy where client code can deal
-- with empty drawings explicitly (empty Pictures cannot be
-- rendered by Wumpus-Core).
--
-- > a `oplus` b
--
-- The 'OPlus' (semigroup) instance for 'CtxPicture' draws picture
-- a in front of picture b in the z-order, neither picture is
-- moved. (Usually the picture composition operators in this
-- module move the second picture aligning it somehow with the
-- first).
--
newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }
-- | Version of CtxPicture specialized to Double for the unit type.
--
type DCtxPicture = CtxPicture Double
type instance DUnit (CtxPicture u) = u
-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @
--
-- Run a 'CtxPicture' with the supplied 'DrawingContext'
-- producing a 'Picture'.
--
-- The resulting Picture may be empty. Wumpus-Core cannot
-- generate empty pictures as they have no bounding box, so the
-- result is wrapped within a Maybe. This delegates reponsibility
-- for handling empty pictures to client code.
--
runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)
runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)
-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @
--
-- /Unsafe/ version of 'runCtxPicture'.
--
-- This function throws a runtime error when supplied with an
-- empty CtxPicture.
--
runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u
runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df
where
fk = error "runCtxPictureU - empty CtxPicture."
-- | 'drawTracing' : @ trace_drawing -> CtxPicture @
--
-- Transform a 'TraceDrawing' into a 'CtxPicture'.
--
drawTracing :: (Real u, Floating u, FromPtSize u)
=> TraceDrawing u a -> CtxPicture u
drawTracing mf = CtxPicture $
drawingCtx >>= \ctx -> return (liftToPictureMb $ execTraceDrawing ctx mf)
-- Note - cannot get an answer from a TraceDrawing with this
-- CtxPicture type. There is nowhere to put the answer in the type.
--
-- If the type was extended:
--
-- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) }
--
-- It would make things difficult for the drawing composition
-- operators. @a@ could be monoidial but are there any types of
-- a where this would be useful (rather than just making things
-- more complicated)?
--
-- | 'clipCtxPicture' : @ path * ctx_picture -> CtxPicture @
--
-- Clip a picture with a path.
--
clipCtxPicture :: (Num u, Ord u) => PrimPath u -> CtxPicture u -> CtxPicture u
clipCtxPicture cpath = mapCtxPicture (clip cpath)
-- Note - it seems preferable to clip a smaller type in the
-- hierarchy than CtxPicture. But which one Graphic, TraceDrawing?
-- ...
--
-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @
--
-- Apply a picture transformation function to the 'Picture'
-- warpped in a 'CtxPicture'.
--
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)
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
-- Extract anchors
boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a
boundaryExtr f = f . boundary
-- Operations on bounds
-- | The center of a picture.
--
boundaryCtr :: Fractional u => Picture u -> Point2 u
boundaryCtr = boundaryExtr center
-- | Extract the mid point of the top edge.
--
boundaryN :: Fractional u => Picture u -> Point2 u
boundaryN = boundaryExtr north
-- | Extract the mid point of the bottom edge.
--
boundaryS :: Fractional u => Picture u -> Point2 u
boundaryS = boundaryExtr south
-- | Extract the mid point of the left edge.
--
boundaryE :: Fractional u => Picture u -> Point2 u
boundaryE = boundaryExtr east
-- | Extract the mid point of the right edge.
--
boundaryW :: Fractional u => Picture u -> Point2 u
boundaryW = boundaryExtr west
-- | Extract the top-left corner.
--
boundaryNW :: Fractional u => Picture u -> Point2 u
boundaryNW = boundaryExtr northwest
-- | Extract the top-right corner.
--
boundaryNE :: Picture u -> Point2 u
boundaryNE = boundaryExtr ur_corner
-- | Extract the bottom-left corner.
--
boundarySW :: Picture u -> Point2 u
boundarySW = boundaryExtr ll_corner
-- | Extract the bottom-right 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)
--------------------------------------------------------------------------------
-- Composition operators
-- Naming convention - Wumpus-Core already prefixes operations
-- on Pictures with pic. As the picture operators here work on a
-- different type, they merit a different naming scheme.
--
-- Unfortunately the @cxp_@ prefix is rather ugly...
--
-- Directional names seem better than positional ones (less
-- ambiguous as when used as binary operators).
--
cxpConcat :: (Picture u -> Picture u -> Picture u)
-> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpConcat 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
-- Note - the megaCombR operator is in some way an
-- /anti-combinator/. It seems easier to think about composing
-- drawings if we do work on the result Pictures directly rather
-- than build combinators to manipulate CtxPictures.
--
-- The idea of combining pre- and post- operating combinators
-- makes me worry about circular programs even though I know
-- lazy evaluation allows me to write them (in some cicumstances).
--
-- Picture /mega-combiner/ - moves only the second argument aka the
-- right picture.
--
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 = cxpConcat fn
where
fn pic1 pic2 = let a = qL pic1
b = qR pic2
p2 = trafoR a b pic2
in pic1 `picOver` p2
-- | > a `oplus` b
--
-- Place \'drawing\' a over b. The idea of @over@ here is in
-- terms z-ordering, nither picture a or b are actually moved.
--
instance (Num u, Ord u) => OPlus (CtxPicture u) where
oplus = cxpConcat picOver
-- | 'cxpBeneath' : @ ctx_picture1 * ctx_picture2 -> CtxPicture @
--
-- > a `cxpBeneath` b
--
-- Similarly @beneath@ draws the first picture behind the second
-- picture in the z-order, neither picture is moved.
--
cxpBeneath :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpBeneath = flip oplus
--------------------------------------------------------------------------------
-- Composition
infixr 5 `cxpDown`
infixr 6 `cxpRight`, `cxpUniteCenter`
-- | Draw @a@, move @b@ so its center is at the same center as
-- @a@, @b@ is drawn over underneath in the zorder.
--
-- > a `cxpUniteCenter` b
--
cxpUniteCenter :: (Fractional u, Ord u)
=> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpUniteCenter = megaCombR boundaryCtr boundaryCtr moveFun
where
moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v
--
-- Are combinator names less ambiguous if they name direction
-- rather than position?
--
-- | > a `cxpRight` b
--
-- Horizontal composition - position picture @b@ to the right of
-- picture @a@.
--
cxpRight :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpRight = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (a - b)
-- | > a `cxpDown` b
--
-- Vertical composition - position picture @b@ /down/ from picture
-- @a@.
--
cxpDown :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpDown = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b drw = drw `picMoveBy` vvec (a - b)
-- | Center the picture at the supplied point.
--
cxpCenteredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u
cxpCenteredAt 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
-- | 'cxpRow' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
--
-- Make a row of pictures concatenating them horizontally.
--
-- Note - this function is in /destructor form/. As Wumpus cannot
-- make a Picture from an empty list of Pictures,
-- /destructor form/ decomposes the list into the @head@ and the
-- @rest@ in the function signature, rather than take a possibly
-- empty list and have to throw an error.
--
cxpRow :: (Real u, Floating u, FromPtSize u)
=> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpRow = foldl' cxpRight
-- | 'cxpColumn' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
--
-- Make a column of pictures concatenating them vertically.
--
-- Note - this function is in /destructor form/.
--
cxpColumn :: (Real u, Floating u, FromPtSize u)
=> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpColumn = foldl' cxpDown
--------------------------------------------------------------------------------
-- | > cxpRightSep n a b
--
-- Horizontal composition - move @b@, placing it to the right
-- of @a@ with a horizontal gap of @n@ separating the pictures.
--
cxpRightSep :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpRightSep n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (n + a - b)
-- | > cxpDownSep n a b
--
-- Vertical composition - move @b@, placing it below @a@ with a
-- vertical gap of @n@ separating the pictures.
--
cxpDownSep :: (Num u, Ord u)
=> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpDownSep n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b pic = pic `picMoveBy` vvec (a - b - n)
-- | > picRowSep n x xs
--
-- Concatenate the list of pictures @xs@ horizontally with
-- @hspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
cxpRowSep :: (Real u, Floating u, FromPtSize u)
=> u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpRowSep n = foldl' (cxpRightSep n)
-- | > vsepPic n xs
--
-- Concatenate the list of pictures @xs@ vertically with
-- @vspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
cxpColumnSep :: (Real u, Floating u, FromPtSize u)
=> u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpColumnSep n = foldl' (cxpDownSep n)
--------------------------------------------------------------------------------
-- Aligning pictures
alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u
alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)
-- Note - these don\'t conform to the naming convention, but using
-- /Right/ in the names would be confusing with alignment.
-- | > cxpAlignH align a b
--
-- Horizontal composition - move @b@, placing it to the right
-- of @a@ and align it with the top, center or bottom of @a@.
--
cxpAlignH :: (Fractional u, Ord u)
=> HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignH HTop = megaCombR boundaryNE boundaryNW alignMove
cxpAlignH HCenter = megaCombR boundaryE boundaryW alignMove
cxpAlignH HBottom = megaCombR boundarySE boundarySW alignMove
-- | > cxpAlignV align a b
--
-- Vertical composition - move @b@, placing it below @a@
-- and align it with the left, center or right of @a@.
--
cxpAlignV :: (Fractional u, Ord u)
=> VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignV VLeft = megaCombR boundarySW boundaryNW alignMove
cxpAlignV VCenter = megaCombR boundaryS boundaryN alignMove
cxpAlignV 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))
-- | > cxpAlignSepH align sep a b
--
-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@
-- separated by @sep@ units, align @b@ according to @align@.
--
cxpAlignSepH :: (Fractional u, Ord u)
=> HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignSepH align dx = go align
where
go HTop = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
go HCenter = megaCombR boundaryE boundaryW (alignMove2 (hvec dx))
go HBottom = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))
-- | > cxpAlignSepV align sep a b
--
-- Spacing version of alignV - move @b@ below @a@
-- separated by @sep@ units, align @b@ according to @align@.
--
cxpAlignSepV :: (Fractional u, Ord u)
=> VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignSepV align dy = go align
where
go VLeft = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy))
go VCenter = megaCombR boundaryS boundaryN (alignMove2 $ vvec (-dy))
go VRight = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))
-- | Variant of 'cxpRow' that aligns the pictures as well as
-- concatenating them.
--
cxpAlignRow :: (Real u, Floating u, FromPtSize u)
=> HAlign -> CtxPicture u-> [CtxPicture u] -> CtxPicture u
cxpAlignRow ha = foldl' (cxpAlignH ha)
-- | Variant of 'cxpColumn' that aligns the pictures as well as
-- concatenating them.
--
cxpAlignColumn :: (Real u, Floating u, FromPtSize u)
=> VAlign -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpAlignColumn va = foldl' (cxpAlignV va)
-- | Variant of 'cxpRow' that aligns the pictures as well as
-- concatenating and spacing them.
--
cxpAlignRowSep :: (Real u, Floating u, FromPtSize u)
=> HAlign -> u -> CtxPicture u -> [CtxPicture u]
-> CtxPicture u
cxpAlignRowSep ha n = foldl' (cxpAlignSepH ha n)
-- | Variant of 'cxpColumn' that aligns the pictures as well as
-- concatenating and spacing them.
--
cxpAlignColumnSep :: (Real u, Floating u, FromPtSize u)
=> VAlign -> u -> CtxPicture u -> [CtxPicture u]
-> CtxPicture u
cxpAlignColumnSep va n = foldl' (cxpAlignSepV va n)