module Wumpus.Basic.PictureLanguage
(
HAlign(..)
, VAlign(..)
, centerPoint
, over
, under
, centerOver
, nextToH
, nextToV
, atPoint
, centeredAt
, stackOver
, zconcat
, hcat
, vcat
, stackOverCenter
, hspace
, vspace
, hsep
, vsep
, alignH
, alignV
, alignHSep
, alignVSep
, hcatA
, vcatA
, hsepA
, vsepA
) where
import Wumpus.Core
import Data.AdditiveGroup
import Data.AffineSpace
import Data.List ( foldl' )
data HAlign = HTop | HCenter | HBottom
deriving (Eq,Show)
data VAlign = VLeft | VCenter | VRight
deriving (Eq,Show)
centerPoint :: Fractional u => Picture u -> Point2 u
centerPoint = fn . boundary
where
fn (BBox (P2 x0 y0) (P2 x1 y1)) = P2 (x0 + ((x1x0)*0.5))
(y0 + ((y1y0)*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
over :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
over = picOver
under :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
under = flip over
move :: (Num u, Ord u) => Vec2 u -> Picture u -> Picture u
move = flip picMoveBy
topleft :: Picture u -> Point2 u
topleft = fn . boundary
where
fn (BBox (P2 x0 _) (P2 _ y1)) = P2 x0 y1
topright :: Picture u -> Point2 u
topright = ur_corner . boundary
bottomleft :: Picture u -> Point2 u
bottomleft = ll_corner . boundary
bottomright :: Picture u -> Point2 u
bottomright = fn . boundary
where
fn (BBox (P2 _ y0) (P2 x1 _)) = P2 x1 y0
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*(ba)
infixr 5 `nextToV`
infixr 6 `nextToH`, `centerOver`
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
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
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
atPoint :: (Num u, Ord u) => Picture u -> Point2 u -> Picture u
p `atPoint` (P2 x y) = move (V2 x y) p
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)
stackOver :: (Num u, Ord u) => [Picture u] -> Picture u -> Picture u
stackOver = flip (foldr over)
zconcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
zconcat = foldl' over
hcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
hcat = foldl' nextToH
vcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u
vcat = foldl' nextToV
stackOverCenter :: (Fractional u, Ord u)
=> [Picture u] -> Picture u -> Picture u
stackOverCenter = flip $ foldr centerOver
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 :: (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 :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u
hsep n = foldl' (hspace n)
vsep :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u
vsep n = foldl' (vspace n)
vecMove :: (Num u, Ord u) => Picture u -> Picture u -> (Vec2 u) -> Picture u
vecMove a b v = a `over` (move v b)
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 :: (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 :: (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
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
hcatA :: (Fractional u, Ord u)
=> HAlign -> Picture u -> [Picture u] -> Picture u
hcatA ha = foldl' (alignH ha)
vcatA :: (Fractional u, Ord u)
=> VAlign -> Picture u -> [Picture u] -> Picture u
vcatA va = foldl' (alignV va)
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
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