Graphic.hs

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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.Graphic
-- Copyright   :  (c) Stephen Tetley 2010-2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Graphic type - this is largely equivalent to Primitive in
-- Wumpus-Core, but drawing attributes are implicitly supplied 
-- by the DrawingContext.
--
-- API in @Wumpus.Core@, but here they exploit the implicit 
-- @DrawingContext@.
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.Graphic
  (

    Graphic
  , DGraphic


  -- * LocGraphic  
  , LocGraphic
  , DLocGraphic


  , LocThetaGraphic
  , DLocThetaGraphic

  -- * Functions
  , safeconcat
  , ignoreAns
  , replaceAns
  , mapAns

  , intoImage
  , intoLocImage
  , intoLocThetaImage

  , emptyLocGraphic
  , emptyLocThetaGraphic 

  , decorate
  , sdecorate
  , adecorate
  
  , hyperlink

  ) where

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

import Wumpus.Core                              -- package: wumpus-core


import Control.Applicative

--------------------------------------------------------------------------------
-- Graphic

-- | Simple drawing - produce a primitive, access the DrawingContext
-- as required, e.g for fill colour, stroke colur, line width, etc.
--
type Graphic u          = Image u (UNil u)

-- | Alias of 'Graphic' where the unit type is specialized to 
-- Double. 
--
type DGraphic           = Graphic Double


-- | /Originated/ drawing - produce a primitive respective to the 
-- supplied start-point, access the DrawingContext as required.
--
type LocGraphic u       = LocImage u (UNil u)

-- | Alias of 'LocGraphic' where the unit type is specialized to 
-- Double. 
--
type DLocGraphic        = LocGraphic Double




-- | /Originated/ drawing - produce a primitive respective to the 
-- supplied start-point, access the DrawingContext as required.
--
type LocThetaGraphic u       = LocThetaImage u (UNil u)


-- | Alias of 'LocThetaGraphic' where the unit type is specialized 
-- to Double. 
--
type DLocThetaGraphic        = LocThetaGraphic Double


--------------------------------------------------------------------------------
-- Functions


-- | 'safeconcat' : @ alternative * [image] -> Image@
-- 
-- 'safeconcat' produces a composite 'Image' from a list of 
-- @Image@\'s. If the list is empty the alternative @Image@ is 
-- used.
--
-- This contrasts to 'oconcat' - when used for @Image@\'s, 
-- @oconcat@ has the same type signature as @safeconcat@ but 
-- @oconcat@ considers its arguments to be an already destructured 
-- list:
-- 
-- > oconcat (head::Image) (rest::[Image])
-- 
safeconcat :: OPlus a => Image u a -> [Image u a] -> Image u a
safeconcat _   (x:xs) = oconcat x xs
safeconcat alt []     = alt


-- | Ignore the answer produced by an 'Image', a 'LocImage' etc.
--
-- Use this function to turn an 'Image' into a 'Graphic', a 
-- 'LocImage into a 'LocGraphic'.
--
ignoreAns :: Functor f => f (a,b) -> f (UNil u, b)
ignoreAns = fmap (replaceL uNil)


-- | Replace the answer produced by an 'Image', a 'LocImage' etc.
--
replaceAns :: Functor f => z -> f (a,b) -> f (z, b)
replaceAns = fmap . replaceL


-- | Apply the supplied function to the answer produced by an 
-- 'Image', a 'LocImage' etc.
--
mapAns :: Functor f => (a -> z) -> f (a,b) -> f (z,b)
mapAns f = fmap (\(a,b) -> (f a ,b))


-- | 'intoImage' : @ context_function * graphic -> Image @
--
-- Build an 'Image' from a context function ('CF') that generates 
-- the answer and a 'Graphic' that draws the 'Image'.
--
intoImage :: CF a -> Graphic u -> Image u a
intoImage = liftA2 (\a (_,b) -> (a,b))


-- | 'intoLocImage' : @ loc_context_function * loc_graphic -> LocImage @
--
-- /Loc/ version of 'intoImage'. 
-- 
-- The 'LocImage' is built as a function from an implicit start 
-- point to the answer.
--
intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a
intoLocImage = liftA2 (\a (_,b) -> (a,b))

-- | 'intoLocThetaImage' : @ loc_theta_cf * loc_theta_graphic -> LocThetaImage @
--
-- /LocTheta/ version of 'intoImage'. 
-- 
-- The 'LocThetaImage' is built as a function from an implicit 
-- start point and angle of inclination to the answer.
--
intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a
intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))



-- | 'emptyLocGraphic' : @ LocGraphic @
--
-- Build an empty 'LocGraphic' (i.e. a function 
-- /from Point to Graphic/). This is a path with a start point 
-- but no path segments. 
-- 
-- The 'emptyLocGraphic' is treated as a /null primitive/ by 
-- @Wumpus-Core@ and is not drawn, although it does generate a 
-- minimum bounding box at the implicit start point.
-- 
emptyLocGraphic :: Num u => LocGraphic u
emptyLocGraphic = promoteR1 $ \pt -> 
                    return $ (uNil, primGraphic $ zostroke $ emptyPath pt)



-- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @
--
-- Build an empty 'LocThetaGraphic' (i.e. a function 
-- /from Point and Inclination to Graphic/). 
-- 
-- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by 
-- @Wumpus-Core@ and is not drawn, although it does generate a 
-- minimum bounding box at the implicit start point.
-- 
emptyLocThetaGraphic :: Num u => LocThetaGraphic u
emptyLocThetaGraphic = lift1R2 emptyLocGraphic




-- | Decorate an Image by superimposing a Graphic.
--
-- Note - this function has a very general type signature and
-- supports various graphic types:
--
-- > decorate :: Image u a -> Graphic u -> Image u a
-- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a
-- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
--
decorate :: Monad m 
         => m (ImageAns u a) -> m (ImageAns u zz) -> m (ImageAns u a) 
decorate img gf = 
    img >>= \(a,g1) -> gf >>= \(_,g2) -> return (a, g1 `oplus` g2)



-- | /Anterior decorate/ - decorate an Image by superimposing it 
-- on a Graphic.
--
-- Note - here the Graphic has access to the result produced by the 
-- the Image unlike 'decorate'.
--
-- Again, this function has a very general type signature and
-- supports various graphic types:
--
-- > adecorate :: Image u a -> Graphic u -> Image u a
-- > adecorate :: LocImage u a -> LocGraphic u -> LocImage u a
-- > adecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
--
adecorate :: Monad m 
          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)
adecorate img f = 
    img >>= \(a,g1) -> f a >>= \(_,g0) -> return (a, g0 `oplus` g1)


-- | /Superior decorate/ - decorate an image by superimposing a 
-- graphic on top of it.
--
-- Note, here the Graphic has access to the result produced by the 
-- the Image unlike 'decorate'.
--
-- Again, this function has a very general type signature and
-- supports various graphic types:
--
-- > sdecorate :: Image u a -> Graphic u -> Image u a
-- > sdecorate :: LocImage u a -> LocGraphic u -> LocImage u a
-- > sdecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
--
sdecorate :: Monad m 
          => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a)
sdecorate img f = 
    img >>= \(a,g1) -> f a >>= \(_,g2) -> return (a, g1 `oplus` g2)


-- | Hyperlink a graphic object.
-- 
-- This function has a very general type signature and supports 
-- various graphic types:
--
-- > hyperlink :: XLink -> Graphic u -> Graphic u
-- > hyperlink :: XLink -> Image u a -> Image u a
-- > hyperlink :: XLink -> LocImage u a -> LocImage u a
-- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a
--
hyperlink :: Functor m => XLink -> m (ImageAns u a) -> m (ImageAns u a)
hyperlink hypl = 
    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))