module Wumpus.Core.PictureLanguage
(
HAlign(..)
, VAlign(..)
, PUnit
, Horizontal(..)
, Vertical(..)
, Composite(..)
, Move(..)
, Blank(..)
, center
, topleft
, topright
, bottomleft
, bottomright
, ( -@- )
, ( ->- )
, ( -<- )
, ( -//- )
, above
, below
, at
, centeredAt
, stackOnto
, hcat
, vcat
, stackOntoCenter
, hspace
, vspace
, hsep
, vsep
, alignH
, alignV
, hcatA
, vcatA
, hsepA
, vsepA
) where
import Wumpus.Core.Geometry
import Data.AffineSpace
import Data.List ( foldl' )
data HAlign = HTop | HCenter | HBottom
deriving (Eq,Show)
data VAlign = VLeft | VCenter | VRight
deriving (Eq,Show)
type family PUnit a
class Composite a where
over :: a -> a -> a
beneath :: a -> a -> a
beneath = flip over
class Blank a where
blank :: PUnit a -> PUnit a -> a
class Horizontal a where
moveH :: PUnit a -> a -> a
leftBound :: a -> PUnit a
rightBound :: a -> PUnit a
class Vertical a where
moveV :: PUnit a -> a -> a
topBound :: a -> PUnit a
bottomBound :: a -> PUnit a
class Move a where
move :: PUnit a -> PUnit a -> a -> a
center :: (Horizontal a, Vertical a, Fractional u, u ~ PUnit a) => a -> Point2 u
center a = P2 hcenter vcenter where
hcenter = leftBound a + 0.5 * (rightBound a leftBound a)
vcenter = bottomBound a + 0.5 * (topBound a bottomBound a)
topleft :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
topleft a = P2 (leftBound a) (topBound a)
topright :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
topright a = P2 (rightBound a) (topBound a)
bottomleft :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
bottomleft a = P2 (leftBound a) (bottomBound a)
bottomright :: (Horizontal a, Vertical a, u ~ PUnit a) => a -> Point2 u
bottomright a = P2 (rightBound a) (bottomBound a)
leftmid :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a)
=> a -> Point2 u
leftmid a = P2 (leftBound a) (midpt (bottomBound a) (topBound a))
rightmid :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a)
=> a -> Point2 u
rightmid a = P2 (rightBound a) (midpt (bottomBound a) (topBound a))
topmid :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a)
=> a -> Point2 u
topmid a = P2 (midpt (leftBound a) (rightBound a)) (topBound a)
bottommid :: (Fractional u, Horizontal a, Vertical a, u ~ PUnit a)
=> a -> 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 -//-, `above`, `below`
infixr 6 ->-, -@-
(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u,
u ~ PUnit a)
=> a -> a -> a
p1 -@- p2 = (move x y p1) `over` p2 where V2 x y = center p2 .-. center p1
(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a ->- b = a `over` (moveH disp b) where disp = rightBound a leftBound b
(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a -<- b = (moveH disp a) `over` b where disp = leftBound b rightBound a
(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a -//- b = a `over` (moveV disp b) where disp = bottomBound a topBound b
below :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a `below` b = (moveV disp a) `over` b where disp = bottomBound a topBound b
above :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a `above` b = (moveV disp a) `over` b where disp = topBound b bottomBound a
at :: (Move a, u ~ PUnit a) => a -> Point2 u -> a
p `at` (P2 x y) = move x y p
centeredAt :: (Horizontal a, Vertical a, Move a, Composite a, Blank a,
Fractional u, u ~ PUnit a)
=> a -> Point2 u -> a
centeredAt p pt = p -@- (blank 0 0 `at` pt)
stackOnto :: (Composite a) => [a] -> a -> a
stackOnto = flip (foldr over)
hcat :: (Horizontal a, Composite a, Num u, u ~ PUnit a)
=> a -> [a] -> a
hcat = foldl' (->-)
vcat :: (Vertical a, Composite a, Num u, u ~ PUnit a)
=> a -> [a] -> a
vcat = foldl' (-//-)
stackOntoCenter :: (Horizontal a, Vertical a, Composite a,
Move a, Fractional u,
u ~ PUnit a)
=> [a] -> a -> a
stackOntoCenter = flip $ foldr (-@-)
blankH :: (Num u, Blank a, u ~ PUnit a) => u -> a
blankH = blank `flip` 0
blankV :: (Num u, Blank a, u ~ PUnit a) => u -> a
blankV = blank 0
hspace :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a)
=> u -> a -> a -> a
hspace n a b = a ->- blankH n ->- b
vspace :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a)
=> u -> a -> a -> a
vspace n a b = a -//- blankV n -//- b
hsep :: (Num u, Composite a, Horizontal a, Blank a, u ~ PUnit a)
=> u -> a -> [a] -> a
hsep n = foldl' (hspace n)
vsep :: (Num u, Composite a, Vertical a, Blank a, u ~ PUnit a)
=> u -> a -> [a] -> a
vsep n = foldl' (vspace n)
alignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
, u ~ PUnit a )
=> HAlign -> a -> a -> a
alignH HTop p1 p2 = vecMove p1 p2 (vvec $ topBound p1 topBound p2)
alignH HBottom p1 p2 = vecMove p1 p2 (vvec $ bottomBound p1 bottomBound p2)
alignH HCenter p1 p2 = vecMove p1 p2 (vvec v)
where V2 _ v = rightmid p1 .-. leftmid p2
alignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
, u ~ PUnit a )
=> VAlign -> a -> a -> a
alignV VLeft p1 p2 = vecMove p1 p2 (hvec $ leftBound p1 leftBound p2)
alignV VRight p1 p2 = vecMove p1 p2 (hvec $ rightBound p1 rightBound p2)
alignV VCenter p1 p2 = vecMove p1 p2 (hvec h)
where V2 h _ = bottommid p1 .-. topmid p2
vecMove :: (Composite a, Move a, u ~ PUnit a) => a -> a -> (Vec2 u) -> a
vecMove a b (V2 x y) = a `over` (move x y) b
moveAlignH :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
, u ~ PUnit a )
=> HAlign -> a -> a -> a
moveAlignH HTop p1 p2 = vecMove p1 p2 (topright p1 .-. topleft p2)
moveAlignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1 .-. leftmid p2)
moveAlignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft p2)
moveAlignV :: ( Fractional u, Composite a, Horizontal a, Vertical a, Move a
, u ~ PUnit a )
=> VAlign -> a -> a -> a
moveAlignV VLeft p1 p2 = vecMove p1 p2 (bottomleft p1 .-. topleft p2)
moveAlignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1 .-. topmid p2)
moveAlignV VRight p1 p2 = vecMove p1 p2 (bottomright p1 .-. topright p2)
hcatA :: ( Fractional u, Horizontal a, Vertical a
, Composite a, Move a, u ~ PUnit a)
=> HAlign -> a -> [a] -> a
hcatA ha = foldl' (moveAlignH ha)
vcatA :: ( Fractional u, Horizontal a, Vertical a
, Composite a, Move a, u ~ PUnit a)
=> VAlign -> a -> [a] -> a
vcatA va = foldl' (moveAlignV va)
hsepA :: ( Fractional u, Horizontal a, Vertical a
, Composite a, Move a, Blank a, u ~ PUnit a)
=> HAlign -> u -> a -> [a] -> a
hsepA ha n = foldl' op where
a `op` b = moveAlignH ha (moveAlignH ha a (blankH n)) b
vsepA :: ( Fractional u, Horizontal a, Vertical a
, Composite a, Move a, Blank a, u ~ PUnit a)
=> VAlign -> u -> a -> [a] -> a
vsepA va n = foldl' op where
a `op` b = moveAlignV va (moveAlignV va a (blankV n)) b