wumpus-core-0.12.0: src/Wumpus/Core/PictureLanguage.hs
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Core.PictureLanguage
-- Copyright : (c) Stephen Tetley 2009
-- License : BSD-style (see LICENSE)
-- Maintainer : stephen.tetley@gmail.com
-- Stability : experimental
-- Portability : GHC only
--
-- Picture language operations c.f. PPrint and
-- Text.PrettyPrint.HughesPJ, but fully in two dimensions
-- rather than horizontal + carriage return.
--
--------------------------------------------------------------------------------
module Wumpus.Core.PictureLanguage
(
HAlign(..)
, VAlign(..)
-- * Type family and classes
, PUnit
, Horizontal(..)
, Vertical(..)
, Composite(..)
, Move(..)
, Blank(..)
-- * Bounds
, center
, topleft
, topright
, bottomleft
, bottomright
-- * Composition
, ( ->- )
, ( -<- )
, ( -//- )
, ( -\\- )
, at
, stackOnto
, hcat
, vcat
, ( -@- )
, stackOntoCenter
, hspace
, vspace
, hsep
, vsep
-- * Compose with alignment
, alignH
, alignV
, hcatA
, vcatA
, hsepA
, vsepA
) where
import Wumpus.Core.Geometry ( Point2(..), Vec2(..) )
import Data.AffineSpace
import Data.List ( foldl' )
--------------------------------------------------------------------------------
-- Data types
-- Alignment
data HAlign = HTop | HCenter | HBottom
deriving (Eq,Show)
data VAlign = VLeft | VCenter | VRight
deriving (Eq,Show)
--------------------------------------------------------------------------------
-- Type family and classes
-- The unit type of /points/ within a Picture.
type family PUnit 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 Composite a where
over :: a -> a -> a
beneath :: a -> a -> a
beneath = flip over
-- Move in 2D
class Move a where
move :: PUnit a -> PUnit a -> a -> a
class Blank a where
blank :: PUnit a -> PUnit a -> a
--------------------------------------------------------------------------------
-- Operations on bounds
-- | The center of a picture.
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*(b-a)
--------------------------------------------------------------------------------
-- Composition
infixr 5 -//-
infixr 6 ->-, -@-
-- | Center the pic1 on top of pic2.
(-@-) :: (Horizontal a, Vertical a, Composite a, Move a, Fractional u,
u ~ PUnit a)
=> a -> a -> a
p1 -@- p2 = p1 `over` (move x y p2) where V2 x y = center p1 .-. center p2
-- | Horizontal composition - place @b@ at the right of @a@.
(->-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a ->- b = over a (moveH disp b) where disp = rightBound a - leftBound b
-- | Horizontal composition - place @a@ at the left of @b@.
(-<-) :: (Horizontal a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
(-<-) = flip (->-) -- TO TEST...
-- | Vertical composition - place @b@ below @a@.
(-//-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
a -//- b = over a (moveV disp b) where disp = bottomBound a - topBound b
-- | Vertical composition - place @a@ above @b@.
(-\\-) :: (Vertical a, Composite a, Num u, u ~ PUnit a) => a -> a -> a
(-\\-) = flip (-//-)
-- | Place the picture at the supplied point.
at :: (Move a, u ~ PUnit a) => a -> Point2 u -> a
p `at` (P2 x y) = move x y p
-- stackOnto :: [a] -> a -> a
-- This would obviate the need for pempty without needing a
-- non-empty list
-- | Stack the pictures using 'over' - the first picture in the
-- list is drawn at the top, last picture is on drawn at the
-- bottom.
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' (-//-)
-- | 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.
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
-- | The following simple definition of hspace is invalid:
--
-- > hspace n a b = a ->- (moveH n b)
--
-- The movement due to @moveH n@ is annulled by the @->-@
-- operator which moves relative to the bounding box.
--
-- The almost as simple definition below, seems to justify
-- including Blank as a Picture constructor.
--
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)
--------------------------------------------------------------------------------
-- Aligning pictures
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
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 (topright p1 .-. topleft p2)
alignH HCenter p1 p2 = vecMove p1 p2 (rightmid p1 .-. leftmid p2)
alignH HBottom p1 p2 = vecMove p1 p2 (bottomright p1 .-. bottomleft 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 (bottomleft p1 .-. topleft p2)
alignV VCenter p1 p2 = vecMove p1 p2 (bottommid p1 .-. topmid p2)
alignV 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' (alignH ha)
vcatA :: ( Fractional u, Horizontal a, Vertical a
, Composite a, Move a, u ~ PUnit a)
=> VAlign -> a -> [a] -> a
vcatA va = foldl' (alignV 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 = alignH ha (alignH 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 = alignV va (alignV va a (blankV n)) b