{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture
-- Copyright   :  (c) Stephen Tetley 2010-2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC 
--
-- A Picture-with-implicit-context object. 
-- 
-- This is the corresponding type to Picture in the Wumpus-Core.
-- 
-- Note - many of the composition functions are in 
-- /destructor form/. As Wumpus cannot make a Picture from an 
-- empty list of Pictures, /destructor form/ decomposes the 
-- list into the @head@ and @rest@ as arguments in the function 
-- signature, rather than take a possibly empty list and have to 
-- throw an error.
-- 
-- TODO - PosImage no longer supports composition operators, so 
-- better names are up for grabs...
-- 
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.CtxPicture
  (

    CtxPicture
  , DCtxPicture
  , runCtxPicture
  , runCtxPictureU
  , drawTracing

  , clipCtxPicture
  , mapCtxPicture

  -- * Composition
  , cxpBeneath

  , cxpUniteCenter
  , cxpRight
  , cxpDown
  
  , cxpCenteredAt


  , cxpRow 
  , cxpColumn


  , cxpRightSep
  , cxpDownSep
  , cxpRowSep
  , cxpColumnSep
 
  -- * Compose with alignment
  , cxpAlignH
  , cxpAlignV
  , cxpAlignSepH
  , cxpAlignSepV
  , cxpAlignRow
  , cxpAlignColumn
  , cxpAlignRowSep
  , cxpAlignColumnSep


  ) where

import Wumpus.Basic.Kernel.Base.Anchors
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Objects.TraceDrawing

import Wumpus.Core                              -- package: wumpus-core

import Data.AdditiveGroup                       -- package: vector-space
import Data.AffineSpace

import Control.Applicative
import Data.List ( foldl' )


-- Note - PosGraphic should take priority for the good names.

-- | A /Contextual Picture/.
-- 
-- This type corresponds to the 'Picture' type in Wumpus-Core, but
-- it is embedded with a 'DrawingContext' (for font properties, 
-- fill colour etc.). So it is a function 
-- /from DrawingContext to Picture/.
--
-- Internally the result is actually a (Maybe Picture) and not a 
-- Picture, this is a trick to promote the extraction from 
-- possibly empty drawings (created by TraceDrawing) to the 
-- top-level of the type hierarchy where client code can deal 
-- with empty drawings explicitly (empty Pictures cannot be 
-- rendered by Wumpus-Core).
--
-- > a `oplus` b
--
-- The 'OPlus' (semigroup) instance for 'CtxPicture' draws picture 
-- a in front of picture b in the z-order, neither picture is 
-- moved. (Usually the picture composition operators in this 
-- module move the second picture aligning it somehow with the 
-- first).
--
newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }

-- | Version of CtxPicture specialized to Double for the unit type.
--
type DCtxPicture = CtxPicture Double


type instance DUnit (CtxPicture u) = u



-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @
--
-- Run a 'CtxPicture' with the supplied 'DrawingContext' 
-- producing a 'Picture'.
--
-- The resulting Picture may be empty. Wumpus-Core cannot 
-- generate empty pictures as they have no bounding box, so the 
-- result is wrapped within a Maybe. This delegates reponsibility 
-- for handling empty pictures to client code.
--
runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)
runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)  

-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @
--
-- /Unsafe/ version of 'runCtxPicture'.
--
-- This function throws a runtime error when supplied with an
-- empty CtxPicture.
--
runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u
runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df
  where
    fk = error "runCtxPictureU - empty CtxPicture."   


-- | 'drawTracing' : @ trace_drawing  -> CtxPicture @
--
-- Transform a 'TraceDrawing' into a 'CtxPicture'.
--
drawTracing :: (Real u, Floating u, FromPtSize u) 
            => TraceDrawing u a -> CtxPicture u
drawTracing mf = CtxPicture $ 
    drawingCtx >>= \ctx -> return (liftToPictureMb $ execTraceDrawing ctx mf)


-- Note - cannot get an answer from a TraceDrawing with this 
-- CtxPicture type. There is nowhere to put the answer in the type.
--
-- If the type was extended:
--
-- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) }
--
-- It would make things difficult for the drawing composition 
-- operators. @a@ could be monoidial but are there any types of 
-- a where this would be useful (rather than just making things 
-- more complicated)? 
--

-- | 'clipCtxPicture' : @ path * ctx_picture -> CtxPicture @
--
-- Clip a picture with a path.
-- 
clipCtxPicture :: (Num u, Ord u) => PrimPath u -> CtxPicture u -> CtxPicture u
clipCtxPicture cpath = mapCtxPicture (clip cpath)

-- Note - it seems preferable to clip a smaller type in the 
-- hierarchy than CtxPicture. But which one Graphic, TraceDrawing? 
-- ...
--


-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @
--
-- Apply a picture transformation function to the 'Picture'
-- warpped in a 'CtxPicture'.
--
mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u
mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture


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




instance (Real u, Floating u) => Rotate (CtxPicture u) where 
  rotate ang = mapCtxPicture (rotate ang)

instance (Real u, Floating u) => RotateAbout (CtxPicture u) where
  rotateAbout r pt = mapCtxPicture (rotateAbout r pt)

instance (Num u, Ord u) => Scale (CtxPicture u) where
  scale sx sy = mapCtxPicture (scale sx sy)

instance (Num u, Ord u) => Translate (CtxPicture u) where
  translate dx dy = mapCtxPicture (translate dx dy)



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


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

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

-- Operations on bounds

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






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

-- Naming convention - Wumpus-Core already prefixes operations
-- on Pictures with pic. As the picture operators here work on a
-- different type, they merit a different naming scheme.
--
-- Unfortunately the @cxp_@ prefix is rather ugly...
--
-- Directional names seem better than positional ones (less 
-- ambiguous as when used as binary operators).
--

cxpConcat :: (Picture u -> Picture u -> Picture u) 
          -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)



mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)
mbpostcomb op = liftA2 fn 
  where
    fn (Just a) (Just b) = Just $ a `op` b
    fn a        Nothing  = a
    fn Nothing  b        = b


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

-- | > a `oplus` b
-- 
-- Place \'drawing\' a over b. The idea of @over@ here is in 
-- terms z-ordering, nither picture a or b are actually moved.
--
instance (Num u, Ord u) => OPlus (CtxPicture u) where
  oplus = cxpConcat picOver


-- | 'cxpBeneath' : @ ctx_picture1 * ctx_picture2 -> CtxPicture @
-- 
-- > a `cxpBeneath` b
--
-- Similarly @beneath@ draws the first picture behind the second 
-- picture in the z-order, neither picture is moved.
--
cxpBeneath :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpBeneath = flip oplus



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

infixr 5 `cxpDown`
infixr 6 `cxpRight`, `cxpUniteCenter`




-- | Draw @a@, move @b@ so its center is at the same center as 
-- @a@, @b@ is drawn over underneath in the zorder.
--
-- > a `cxpUniteCenter` b 
--

cxpUniteCenter :: (Fractional u, Ord u) 
               => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpUniteCenter = megaCombR boundaryCtr boundaryCtr moveFun
  where
    moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v

--
-- Are combinator names less ambiguous if they name direction
-- rather than position?
--

-- | > a `cxpRight` b
-- 
-- Horizontal composition - position picture @b@ to the right of 
-- picture @a@.
-- 
cxpRight :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpRight = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
  where 
    moveFun a b pic = pic `picMoveBy` hvec (a - b)



-- | > a `cxpDown` b
--
-- Vertical composition - position picture @b@ /down/ from picture
-- @a@.
--
cxpDown :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u
cxpDown = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
  where 
    moveFun a b drw = drw `picMoveBy` vvec (a - b)


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



-- | 'cxpRow' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
-- 
-- Make a row of pictures concatenating them horizontally.
-- 
-- Note - this function is in /destructor form/. As Wumpus cannot
-- make a Picture from an empty list of Pictures, 
-- /destructor form/ decomposes the list into the @head@ and the 
-- @rest@ in the function signature, rather than take a possibly
-- empty list and have to throw an error.
-- 
cxpRow :: (Real u, Floating u, FromPtSize u) 
       => CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpRow = foldl' cxpRight


-- | 'cxpColumn' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @
-- 
-- Make a column of pictures concatenating them vertically.
-- 
-- Note - this function is in /destructor form/.
--
cxpColumn :: (Real u, Floating u, FromPtSize u) 
          => CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpColumn = foldl' cxpDown




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




-- | > cxpRightSep n a b
--
-- Horizontal composition - move @b@, placing it to the right 
-- of @a@ with a horizontal gap of @n@ separating the pictures.
--
cxpRightSep :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpRightSep n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun
  where
    moveFun a b pic = pic `picMoveBy` hvec (n + a - b)

    



-- | > cxpDownSep n a b
--
-- Vertical composition - move @b@, placing it below @a@ with a
-- vertical gap of @n@ separating the pictures.
--
cxpDownSep :: (Num u, Ord u) 
           => u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpDownSep n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun
  where 
    moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)



-- | > picRowSep n x xs
--
-- Concatenate the list of pictures @xs@ horizontally with 
-- @hspace@ starting at @x@. The pictures are interspersed with 
-- spaces of @n@ units.
--
cxpRowSep :: (Real u, Floating u, FromPtSize u) 
          => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpRowSep n = foldl' (cxpRightSep n)



-- | > vsepPic n xs
--
-- Concatenate the list of pictures @xs@ vertically with 
-- @vspace@ starting at @x@. The pictures are interspersed with 
-- spaces of @n@ units.
--
cxpColumnSep :: (Real u, Floating u, FromPtSize u) 
             => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpColumnSep n = foldl' (cxpDownSep n)


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

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


-- Note - these don\'t conform to the naming convention, but using 
-- /Right/ in the names would be confusing with alignment.


-- | > cxpAlignH 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@.
-- 
cxpAlignH :: (Fractional u, Ord u) 
          =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignH HTop     = megaCombR boundaryNE boundaryNW  alignMove
cxpAlignH HCenter  = megaCombR boundaryE  boundaryW   alignMove
cxpAlignH HBottom  = megaCombR boundarySE boundarySW  alignMove


-- | > cxpAlignV align a b
-- 
-- Vertical composition - move @b@, placing it below @a@ 
-- and align it with the left, center or right of @a@.
-- 
cxpAlignV :: (Fractional u, Ord u) 
       => VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignV VLeft    = megaCombR boundarySW boundaryNW alignMove
cxpAlignV VCenter  = megaCombR boundaryS  boundaryN  alignMove
cxpAlignV 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))



-- | > cxpAlignSepH align sep a b
-- 
-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ 
-- separated by @sep@ units, align @b@ according to @align@.
-- 
cxpAlignSepH :: (Fractional u, Ord u) 
               => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignSepH align dx = go align
  where
    go HTop    = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))
    go HCenter = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))
    go HBottom = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))


-- | > cxpAlignSepV align sep a b
-- 
-- Spacing version of alignV - move @b@ below @a@ 
-- separated by @sep@ units, align @b@ according to @align@.
-- 
cxpAlignSepV :: (Fractional u, Ord u) 
               => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u
cxpAlignSepV align dy = go align
  where
    go VLeft   = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) 
    go VCenter = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) 
    go VRight  = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))


-- | Variant of 'cxpRow' that aligns the pictures as well as
-- concatenating them.
--
cxpAlignRow :: (Real u, Floating u, FromPtSize u) 
            => HAlign -> CtxPicture u-> [CtxPicture u] -> CtxPicture u
cxpAlignRow ha = foldl' (cxpAlignH ha)



-- | Variant of 'cxpColumn' that aligns the pictures as well as
-- concatenating them.
--
cxpAlignColumn :: (Real u, Floating u, FromPtSize u) 
               => VAlign -> CtxPicture u -> [CtxPicture u] -> CtxPicture u
cxpAlignColumn va = foldl' (cxpAlignV va)


-- | Variant of 'cxpRow' that aligns the pictures as well as
-- concatenating and spacing them.
--
cxpAlignRowSep :: (Real u, Floating u, FromPtSize u) 
                 => HAlign -> u -> CtxPicture u -> [CtxPicture u] 
                 -> CtxPicture u
cxpAlignRowSep ha n = foldl' (cxpAlignSepH ha n)


-- | Variant of 'cxpColumn' that aligns the pictures as well as
-- concatenating and spacing them.
--
cxpAlignColumnSep :: (Real u, Floating u, FromPtSize u) 
                    => VAlign -> u -> CtxPicture u -> [CtxPicture u] 
                    -> CtxPicture u
cxpAlignColumnSep va n = foldl' (cxpAlignSepV va n)