```{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.DrawingComposition
-- Copyright   :  (c) Stephen Tetley 2010
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Composition operators for Drawings.
--
-- Note - some operations can produce empty drawings...
--
--------------------------------------------------------------------------------

module Wumpus.Basic.DrawingComposition
(
-- * Composition
over
, under

, centric
, nextToH
, nextToV

, atPoint
, centeredAt

, zconcat

, hcat
, vcat

, hspace
, vspace
, hsep
, vsep

-- * Compose with alignment
, alignH
, alignV
, alignHSep
, alignVSep
, hcatA
, vcatA
, hsepA
, vsepA

) where

import Wumpus.Basic.Graphic

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace

import Data.List ( foldl' )

--------------------------------------------------------------------------------
-- Extract anchors

boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a
boundaryExtr f = f . boundary

-- Operations on bounds

-- | The center of a picture.
--
boundaryCenter :: Fractional u => Picture u -> Point2 u
boundaryCenter = 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)

-- Note - do not export the empty drawing. It is easier to
-- pretend it doesn't exist.
--
empty_drawing :: (Real u, Floating u, FromPtSize u) => Drawing u
empty_drawing = drawTracing \$ return ()

--------------------------------------------------------------------------------
-- Composition operators

-- 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 Drawings.
--
-- 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)
-> Drawing u -> Drawing u
-> Drawing u
megaCombR qL qR trafoR = drawingConcat fn
where
fn pic1 pic2 = let a    = qL pic1
b    = qR pic2
p2   = trafoR a b pic2
in pic1 `picOver` p2

-- | > a `over` b
--
-- Place \'drawing\' 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) => Drawing u -> Drawing u -> Drawing u
over    = drawingConcat picOver

-- | > a `under` b
--
-- Similarly @under@ draws the first drawing behind
-- the second but move neither.
--
under :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u
under = flip over

-- | Move in both the horizontal and vertical.
--
move :: (Num u, Ord u) => Vec2 u -> Drawing u -> Drawing u
move v = modifyDrawing (\p -> p `picMoveBy` v)

--------------------------------------------------------------------------------
-- Composition

infixr 5 `nextToV`
infixr 6 `nextToH`, `centric`

-- | Draw @a@, move @b@ so its center is at the same center as
-- @a@, @b@ is drawn over underneath in the zorder.
--
-- > a `centeric` b
--
--
centric :: (Fractional u, Ord u) => Drawing u -> Drawing u -> Drawing u
centric = megaCombR boundaryCenter boundaryCenter moveFun
where
moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v

-- | > a `nextToH` b
--
-- Horizontal composition - move @b@, placing it to the right
-- of @a@.
--
nextToH :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u
nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (a - b)

-- | > a `nextToV` b
--
-- Vertical composition - move @b@, placing it below @a@.
--
nextToV :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u
nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b drw = drw `picMoveBy` vvec (a - b)

-- | Place the picture at the supplied point.
--
-- `atPoint` was previous the `at` operator.
--
atPoint :: (Num u, Ord u) => Drawing u -> Point2 u  -> Drawing u
p `atPoint` (P2 x y) = move (V2 x y) p

-- | Center the picture at the supplied point.
--
centeredAt :: (Fractional u, Ord u) => Drawing u -> Point2 u -> Drawing u
centeredAt d (P2 x y) = modifyDrawing 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

-- | Concatenate the list of drawings.
--
-- No pictures are moved.
--
zconcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u
zconcat []     = empty_drawing
zconcat (d:ds) = foldl' over d ds

-- | Concatenate the list pictures @xs@ horizontally.
--
hcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u
hcat []     = empty_drawing
hcat (d:ds) = foldl' nextToH d ds

-- | Concatenate the list of pictures @xs@ vertically.
--
vcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u
vcat []     = empty_drawing
vcat (d:ds) = foldl' nextToV d ds

--------------------------------------------------------------------------------

-- | > 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 -> Drawing u -> Drawing u -> Drawing u
hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
where
moveFun a b pic = pic `picMoveBy` hvec (n + a - 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 -> Drawing u -> Drawing u -> Drawing u
vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
where
moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)

-- | > hsep n xs
--
-- Concatenate the list of pictures @xs@ horizontally with
-- @hspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
hsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u
hsep _ []     = empty_drawing
hsep n (d:ds) = foldl' (hspace n) d ds

-- | > vsep n xs
--
-- Concatenate the list of pictures @xs@ vertically with
-- @vspace@ starting at @x@. The pictures are interspersed with
-- spaces of @n@ units.
--
vsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u
vsep _ []     = empty_drawing
vsep n (d:ds) = foldl' (vspace n) d ds

--------------------------------------------------------------------------------
-- Aligning pictures

alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u
alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)

-- | > 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 -> Drawing u -> Drawing u -> Drawing u
alignH HTop     = megaCombR boundaryNE    boundaryNW     alignMove
alignH HCenter  = megaCombR boundaryE    boundaryW     alignMove
alignH HBottom  = megaCombR boundarySE boundarySW  alignMove

-- | > 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 -> Drawing u -> Drawing u -> Drawing u
alignV VLeft    = megaCombR boundarySW  boundaryNW   alignMove
alignV VCenter  = megaCombR boundaryS   boundaryN    alignMove
alignV 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))

-- | > 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 -> Drawing u -> Drawing u -> Drawing u
alignHSep HTop    dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
alignHSep HCenter dx = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))
alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))

-- | > alignVSep 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 -> Drawing u -> Drawing u -> Drawing u
alignVSep VLeft   dy = megaCombR boundarySW boundaryNW (alignMove2 \$ vvec (-dy))
alignVSep VCenter dy = megaCombR boundaryS  boundaryN  (alignMove2 \$ vvec (-dy))
alignVSep VRight  dy = megaCombR boundarySE boundaryNE (alignMove2 \$ vvec (-dy))

-- | Variant of 'hcat' that aligns the pictures as well as
-- concatenating them.
--
hcatA :: (Real u, Floating u, FromPtSize u)
=> HAlign -> [Drawing u] -> Drawing u
hcatA _  []     = empty_drawing
hcatA ha (d:ds) = foldl' (alignH ha) d ds

-- | Variant of 'vcat' that aligns the pictures as well as
-- concatenating them.
--
vcatA :: (Real u, Floating u, FromPtSize u)
=> VAlign -> [Drawing u] -> Drawing u
vcatA _  []     = empty_drawing
vcatA va (d:ds) = foldl' (alignV va) d ds

-- | Variant of @hsep@ that aligns the pictures as well as
-- concatenating and spacing them.
--
hsepA :: (Real u, Floating u, FromPtSize u)
=> HAlign -> u -> [Drawing u] -> Drawing u
hsepA _  _ []     = empty_drawing
hsepA ha n (d:ds) = foldl' op d ds
where
a `op` b = alignHSep ha n a b

-- | Variant of @vsep@ that aligns the pictures as well as
-- concatenating and spacing them.
--
vsepA :: (Real u, Floating u, FromPtSize u)
=> VAlign -> u -> [Drawing u] -> Drawing u
vsepA _  _ []     = empty_drawing
vsepA va n (d:ds) = foldl' op d ds
where
a `op` b = alignVSep va n a b

```