wumpus-basic-0.5.0: src/Wumpus/Basic/PictureLanguage.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.PictureLanguage
-- Copyright : (c) Stephen Tetley 2009-2010
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Composition operators for Pictures.
--
-- Note - empty pictures cannot exist in Wumpus hence the /list/
-- functions in this module are always supplied with an initial
-- picture, as well as the (possibly empty) list.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.PictureLanguage
(
-- * Data types for alignment
HAlign(..)
, VAlign(..)
-- * Operations on boundary
, centerPoint
-- * Composition
, over
, under
, centerOver
, nextToH
, nextToV
, atPoint
, centeredAt
, stackOver
, zconcat
, hcat
, vcat
, stackOverCenter
, hspace
, vspace
, hsep
, vsep
-- * Compose with alignment
, alignH
, alignV
, alignHSep
, alignVSep
, hcatA
, vcatA
, hsepA
, vsepA
) where
import Wumpus.Core
import Data.AdditiveGroup
import Data.AffineSpace
import Data.List ( foldl' )
--------------------------------------------------------------------------------
-- Data types
-- Alignment
-- | Horizontal alignment - align to the top, center or bottom.
data HAlign = HTop | HCenter | HBottom
deriving (Eq,Show)
-- | Vertical alignment - align to the left, center or bottom.
data VAlign = VLeft | VCenter | VRight
deriving (Eq,Show)
--------------------------------------------------------------------------------
-- Operations on bounds
-- Corresponding operations are available on bounding boxes - the
-- definitions here have different type class obligations.
-- | The center of a picture.
centerPoint :: Fractional u => Picture u -> Point2 u
centerPoint = fn . boundary
where
fn (BBox (P2 x0 y0) (P2 x1 y1)) = P2 (x0 + ((x1-x0)*0.5))
(y0 + ((y1-y0)*0.5))
rightBound :: Picture u -> u
rightBound = fn . ur_corner . boundary
where
fn (P2 x _) = x
leftBound :: Picture u -> u
leftBound = fn . ll_corner . boundary
where
fn (P2 x _) = x
bottomBound :: Picture u -> u
bottomBound = fn . ll_corner . boundary
where
fn (P2 _ y) = y
topBound :: Picture u -> u
topBound = fn . ur_corner . boundary
where
fn (P2 _ y) = y
--------------------------------------------------------------------------------
-- Composition operators
-- | > a `over` b
--
-- Place \'picture\' a over b. The idea of @over@ here is in
-- terms z-ordering, nither picture a or b are actually moved.
--
over :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
over = picOver
-- | > a `under` b
--
-- Similarly @under@ draws the first picture behind
-- the second but move neither.
--
-- @under@ was previously @beneath@.
--
under :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
under = flip over
-- | Move in both the horizontal and vertical.
--
move :: (Num u, Ord u) => Vec2 u -> Picture u -> Picture u
move = flip picMoveBy
-- | Extract the top-left corner.
--
topleft :: Picture u -> Point2 u
topleft = fn . boundary
where
fn (BBox (P2 x0 _) (P2 _ y1)) = P2 x0 y1
-- | Extract the top-right corner.
--
topright :: Picture u -> Point2 u
topright = ur_corner . boundary
-- | Extract the bottom-left corner.
--
bottomleft :: Picture u -> Point2 u
bottomleft = ll_corner . boundary
-- | Extract the bottom-right corner.
--
bottomright :: Picture u -> Point2 u
bottomright = fn . boundary
where
fn (BBox (P2 _ y0) (P2 x1 _)) = P2 x1 y0
--------------------------------------------------------------------------------
-- Internal helpers
leftmid :: Fractional u => Picture u -> Point2 u
leftmid a = P2 (leftBound a) (midpt (bottomBound a) (topBound a))
rightmid :: Fractional u => Picture u -> Point2 u
rightmid a = P2 (rightBound a) (midpt (bottomBound a) (topBound a))
topmid :: Fractional u => Picture u -> Point2 u
topmid a = P2 (midpt (leftBound a) (rightBound a)) (topBound a)
bottommid :: Fractional u => Picture u -> Point2 u
bottommid a = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a)
midpt :: Fractional a => a -> a -> a
midpt a b = a + 0.5*(b-a)
--------------------------------------------------------------------------------
-- Composition
infixr 5 `nextToV`
infixr 6 `nextToH`, `centerOver`
-- Note - `centerOver` moves the first argument, whereas other
-- functions move the second...
-- | Draw a centered over b - a is moved, b is static.
--
-- > a `centerOver` b
--
-- 'centerOver' was previously the (-\@-) operator.
--
centerOver :: (Fractional u, Ord u) => Picture u -> Picture u -> Picture u
p1 `centerOver` p2 = (move v p1) `over` p2
where
v = centerPoint p2 .-. centerPoint p1
-- | > a `nextToH` b
--
-- Horizontal composition - move @b@, placing it to the right
-- of @a@.
--
-- 'nextToH' was previously the (->-) operator.
--
nextToH :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `nextToH` b = a `over` move hv b
where
hv = hvec $ rightBound a - leftBound b
-- | > a `nextToV` b
--
-- Vertical composition - move @b@, placing it below @a@.
--
-- nextToV was previously the (-//-) operator.
--
nextToV :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `nextToV` b = a `over` move vv b
where
vv = vvec $ bottomBound a - topBound b
-- | Place the picture at the supplied point.
--
-- `atPoint` was previous the `at` operator.
--
atPoint :: (Num u, Ord u) => Picture u -> Point2 u -> Picture u
p `atPoint` (P2 x y) = move (V2 x y) p
-- | Center the picture at the supplied point.
--
centeredAt :: (Fractional u, Ord u) => Picture u -> Point2 u ->Picture u
centeredAt p (P2 x y) = move (vec dx dy) p
where
bb = boundary p
dx = x - (boundaryWidth bb * 0.5)
dy = y - (boundaryHeight bb * 0.5)
-- | > xs `stackOver` x
--
-- Stack the list of pictures @xs@ 'over' @x@.
--
-- Note, the first picture in the list is drawn at the top, all
-- the pictures in the list are drawn \'over\' @x@. No pictures
-- are moved
--
-- @ [p1,p2,p3] `stackOver` p4 => [p1,p2,p3,p4] @
--
stackOver :: (Num u, Ord u) => [Picture u] -> Picture u -> Picture u
stackOver = flip (foldr over)
-- | > x `zconcat` xs
--
-- Concatenate @x@ over the list of pictures @xs@.
--
-- @x@ is drawn at the top. No pictures are moved.
--
-- @ p1 `zconcat` [p2,p3,p4] => [p1,p2,p3,p4] @
--
zconcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
zconcat = foldl' over
-- | Concatenate the list pictures @xs@ horizontally with @nextToH@
-- starting at @x@.
--
hcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
hcat = foldl' nextToH
-- | Concatenate the list of pictures @xs@ vertically with @nextToV@
-- starting at @x@.
--
vcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
vcat = foldl' nextToV
-- | Stack pictures centered ontop of each other - the first
-- picture in the list is drawn at the top, last picture is on
-- drawn at the bottom.
--
stackOverCenter :: (Fractional u, Ord u)
=> [Picture u] -> Picture u -> Picture u
stackOverCenter = flip $ foldr centerOver
--------------------------------------------------------------------------------
-- | > hspace n a b
--
-- Horizontal composition - move @b@, placing it to the right
-- of @a@ with a horizontal gap of @n@ separating the pictures.
--
hspace :: (Num u, Ord u) => u -> Picture u -> Picture u -> Picture u
hspace n a b = a `over` move hv b
where
hv = hvec $ n + rightBound a - leftBound b
-- | > vspace n a b
--
-- Vertical composition - move @b@, placing it below @a@ with a
-- vertical gap of @n@ separating the pictures.
--
vspace :: (Num u, Ord u) => u -> Picture u -> Picture u -> Picture u
vspace n a b = a `over` move vv b
where
vv = vvec $ bottomBound a - topBound b - n
-- | > hsep n x xs
--
-- Concatenate the list of pictures @xs@ horizontally with
-- @hspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
hsep :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u
hsep n = foldl' (hspace n)
-- | > vsep n x xs
--
-- Concatenate the list of pictures @xs@ vertically with
-- @vspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
vsep :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u
vsep n = foldl' (vspace n)
--------------------------------------------------------------------------------
-- Aligning pictures
vecMove :: (Num u, Ord u) => Picture u -> Picture u -> (Vec2 u) -> Picture u
vecMove a b v = a `over` (move v b)
-- | > alignH 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@.
--
alignH :: (Fractional u, Ord u)
=> HAlign -> Picture u -> Picture u -> Picture u
alignH align p1 p2 = vecMove p1 p2 $ fn align
where
fn HTop = topright p1 .-. topleft p2
fn HCenter = rightmid p1 .-. leftmid p2
fn HBottom = bottomright p1 .-. bottomleft p2
-- | > alignV align a b
--
-- Vertical composition - move @b@, placing it below @a@
-- and align it with the left, center or right of @a@.
--
alignV :: (Fractional u, Ord u)
=> VAlign -> Picture u -> Picture u -> Picture u
alignV align p1 p2 = vecMove p1 p2 $ fn align
where
fn VLeft = bottomleft p1 .-. topleft p2
fn VCenter = bottommid p1 .-. topmid p2
fn VRight = bottomright p1 .-. topright p2
-- | > alignHSep align sep a b
--
-- Spacing version of alignH - move @b@ to the right of @a@
-- separated by @sep@ units, align @b@ according to @align@.
--
alignHSep :: (Fractional u, Ord u)
=> HAlign -> u -> Picture u -> Picture u -> Picture u
alignHSep align dx p1 p2 = vecMove p1 p2 $ hvec dx ^+^ fn align
where
fn HTop = topright p1 .-. topleft p2
fn HCenter = rightmid p1 .-. leftmid p2
fn HBottom = bottomright p1 .-. bottomleft p2
-- | > alignHSep align sep a b
--
-- Spacing version of alignV - move @b@ below @a@
-- separated by @sep@ units, align @b@ according to @align@.
--
alignVSep :: (Fractional u, Ord u)
=> VAlign -> u -> Picture u -> Picture u -> Picture u
alignVSep align dy p1 p2 = vecMove p1 p2 $ vvec (-dy) ^+^ fn align
where
fn VLeft = bottomleft p1 .-. topleft p2
fn VCenter = bottommid p1 .-. topmid p2
fn VRight = bottomright p1 .-. topright p2
-- | Variant of 'hcat' that aligns the pictures as well as
-- concatenating them.
--
hcatA :: (Fractional u, Ord u)
=> HAlign -> Picture u -> [Picture u] -> Picture u
hcatA ha = foldl' (alignH ha)
-- | Variant of 'vcat' that aligns the pictures as well as
-- concatenating them.
--
vcatA :: (Fractional u, Ord u)
=> VAlign -> Picture u -> [Picture u] -> Picture u
vcatA va = foldl' (alignV va)
-- | Variant of @hsep@ that aligns the pictures as well as
-- concatenating and spacing them.
--
hsepA :: (Fractional u, Ord u)
=> HAlign -> u -> Picture u -> [Picture u] -> Picture u
hsepA ha n = foldl' op
where
a `op` b = alignHSep ha n a b
-- | Variant of @vsep@ that aligns the pictures as well as
-- concatenating and spacing them.
--
vsepA :: (Fractional u, Ord u)
=> VAlign -> u -> Picture u -> [Picture u] -> Picture u
vsepA va n = foldl' op
where
a `op` b = alignVSep va n a b