AdvanceGraphic.hs

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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.AdvanceGraphic
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Extended Graphic object - an AdvanceGraphic is a Graphic 
-- twinned with and advance vector.
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.AdvanceGraphic
  (

  -- * Advance-vector graphic
    AdvGraphic
  , DAdvGraphic


  , intoAdvGraphic
  , emptyAdvGraphic


  -- * Composition
  , advcat
  , advsep
  , advconcat
  , advspace
  , advpunctuate
  , advfill

  ) where

import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.ContextFun
import Wumpus.Basic.Kernel.Objects.BaseObjects
import Wumpus.Basic.Kernel.Objects.Graphic

import Wumpus.Core                              -- package: wumpus-core

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



-- | /Advance vector/ graphic - this partially models the 
-- PostScript @show@ command which moves the /current point/ by the
-- advance (width) vector as each character is drawn.
--
type AdvGraphic u      = LocImage u (Vec2 u)

type DAdvGraphic       = AdvGraphic Double



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




-- | 'intoAdvGraphic' : @ loc_context_function * graphic -> Image @
--
-- Build an 'AdvGraphic' from a context function ('CF') that 
-- generates the answer displacement vector and a 'LocGraphic' 
-- that draws the 'AdvGraphic'.
--
intoAdvGraphic :: LocCF u (Vec2 u)
               -> LocGraphic u 
               -> AdvGraphic u
intoAdvGraphic = intoLocImage


-- | 'emptyAdvGraphic' : @ AdvGraphic @
--
-- Build an empty 'AdvGraphic'.
-- 
-- The 'emptyAdvGraphic' is treated as a /null primitive/ by 
-- @Wumpus-Core@ and is not drawn, the answer vetor generated is
-- the empty vector @(V2 0 0)@.
-- 
emptyAdvGraphic :: Num u => AdvGraphic u
emptyAdvGraphic = replaceAns (V2 0 0) $ emptyLocGraphic



-- runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u 
--               -> (Point2 u, PrimGraphic u)
-- runAdvGraphic ctx pt df = runCF1 ctx pt df



--------------------------------------------------------------------------------
-- composition

-- Note there are opportunities for extra composition operators
-- like the /picture language/...


-- Naming convention - binary functions are favoured for shorter names.

infixr 6 `advcat`
infixr 5 `advsep`

-- | Concatenate the two AdvGraphics.
--
advcat :: Num u => AdvGraphic u -> AdvGraphic u -> AdvGraphic u
advcat af ag = promoteR1 $ \start -> 
                 (af `at` start)        >>= \(v1,prim1) -> 
                 (ag `at` start .+^ v1) >>= \(v2,prim2) -> 
                 return (v1 ^+^ v2, prim1 `oplus` prim2)


-- | Concatenate the two AdvGraphics spacing them by the supplied 
-- vector.
--
advsep :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u -> AdvGraphic u
advsep sv af ag = promoteR1 $ \start -> 
                 (af `at` start)        >>= \(v1,prim1) -> 
                 (ag `at` start .+^ sv ^+^ v1) >>= \(v2,prim2) -> 
                 return (v1 ^+^ sv ^+^  v2, prim1 `oplus` prim2)


-- | Concatenate the list of AdvGraphic with 'advcat'.
--
advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u
advconcat []     = emptyAdvGraphic
advconcat (x:xs) = step x xs
  where
    step a (b:bs) = step (a `advcat` b) bs
    step a []     = a


-- | Concatenate the list of AdvGraphic with 'advsep'.
--
advspace :: Num u => Vec2 u -> [AdvGraphic u] -> AdvGraphic u
advspace _  []     = emptyAdvGraphic
advspace sv (x:xs) = step x xs
  where
    step a (b:bs) = step (advsep sv a b) bs
    step a []     = a


-- | Concatenate the list of AdvGraphic with 'advsep'.
--
advpunctuate :: Num u => AdvGraphic u -> [AdvGraphic u] -> AdvGraphic u
advpunctuate _  []     = emptyAdvGraphic
advpunctuate sep (x:xs) = step x xs
  where
    step a (b:bs) = step (a `advcat` sep `advcat` b) bs
    step a []     = a


-- | Render the supplied AdvGraphic, but swap the result advance
-- for the supplied vector. This function has behaviour analogue 
-- to @fill@ in the @wl-pprint@ library.
-- 
advfill :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u
advfill sv = replaceAns sv