wumpus-basic-0.17.0: src/Wumpus/Basic/Kernel/Objects/Basis.hs

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

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.Basis
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Common types and operations.
-- 
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.Basis
  (

    LocQuery
  , LocThetaQuery
  , ConnectorQuery 

  , GraphicAns
  , ImageAns(..)

  , graphicAns
  , mapAns
  , replaceAns
  , ignoreAns
  , answer
  , hyperlink  
  , clipObject 
  
  , szconvAnsF
  , szconvAnsZ


  , at
  , incline
  , atIncline
  , connect

  , replaceAnsR0
  , replaceAnsR1
  , replaceAnsR2

  , decorateR0
  , decorateR1
  , decorateR2

  , elaborateR0
  , elaborateR1
  , elaborateR2
  

  ) where

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

import Wumpus.Core                              -- package: wumpus-core


import Control.Applicative
import Data.Monoid


type LocQuery u a               = CF (Point2 u -> a)
type LocThetaQuery u a          = CF (Point2 u -> Radian -> a)
type ConnectorQuery u a         = CF (Point2 u -> Point2 u -> a)


-- Design note - GraphicAns needs a unit for consistency even 
-- though it is never scrutinized.
-- 


data ImageAns u a = Ans CatPrim a

type GraphicAns u = ImageAns u (UNil u)



type instance DUnit (ImageAns u a) = u


--------------------------------------------------------------------------------
-- OPlus and monoid


instance OPlus a => OPlus (ImageAns u a) where
  Ans cp0 a `oplus` Ans cp1 b = Ans (cp0 `oplus` cp1) (a `oplus` b)


instance Monoid a => Monoid (ImageAns u a) where
  mempty                        = Ans mempty mempty
  Ans cp0 a `mappend` Ans cp1 b = Ans (cp0 `mappend` cp1) (a `mappend` b)


--------------------------------------------------------------------------------
-- Affine instances 

-- 
-- Design Note
--
-- Translate and RotateAbout require the unit to be /scalar/ 
-- e.g. Double, Centimeter, Pica.
--
-- This is annoying and a limitation, but an alternative would
-- need access to current-font-size which cannot be a pure 
-- function.
-- 

instance Rotate a => Rotate (ImageAns u a) where
  rotate ang (Ans cp a) = Ans (rotate ang cp) (rotate ang a)


instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => 
    RotateAbout (ImageAns u a) where
  rotateAbout ang pt@(P2 x y) (Ans cp a) = 
    Ans (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) cp)
        (rotateAbout ang pt a) 
        


instance Scale a => Scale (ImageAns u a) where
  scale sx sy (Ans cp a) = Ans (scale sx sy cp) (scale sx sy a)


instance (Translate a, ScalarUnit u, u ~ DUnit a) => 
    Translate (ImageAns u a) where
  translate dx dy (Ans cp a) = 
    Ans (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) 


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



-- | Map the answer produced by a graphic object.
--
-- Note - the new answer must share the same unit type as the
-- initial answer, although it does not need to have the same
-- wrapper type.
--
mapAns :: (a -> a1) -> ImageAns u a -> ImageAns u a1
mapAns f (Ans cp a) = Ans cp (f a) 



-- | Replace the answer produced by a graphic object.
--
-- Note - the new answer must share the same unit type as the
-- initial answer, although it does not need to have the same
-- wrapper type.
--
replaceAns :: ans -> ImageAns u a -> ImageAns u ans
replaceAns ans (Ans prim _) = Ans prim ans


-- | Turn an imageAns into a GraphicAns by ignoring the 
-- result.
-- 
-- Usually this function will be used with one of the @push@ 
-- family of combinators.
--
-- > LocImage-to-LocGraphic = pushR1 ignoreAns 
--
ignoreAns :: ImageAns u a -> GraphicAns u
ignoreAns(Ans prim _) = Ans prim UNil



graphicAns :: CatPrim -> GraphicAns u
graphicAns prim = Ans prim UNil

-- | Extractor for the answer part of an image.
--
answer :: ImageAns u a -> a
answer (Ans _ a) = a


-- | Note - maybe this requires an arity family instead?
--
hyperlink :: XLink -> ImageAns u a -> ImageAns u a
hyperlink hypl (Ans prim a) = Ans (cpmap (xlinkPrim hypl) prim) a


-- | Clip a graphic object.
-- 
-- Note - maybe this requires an arity family instead?
--
clipObject :: PrimPath -> ImageAns t u -> ImageAns t u
clipObject pp (Ans prim a) =  Ans (cpmap (clip pp) prim) a


--------------------------------------------------------------------------------
-- Helpers for unit conversion...



szconvAnsF :: (Functor t, InterpretUnit u, InterpretUnit u1) 
                => FontSize -> ImageAns u (t u) -> ImageAns u1 (t u1)
szconvAnsF sz (Ans prim a) = Ans prim (uconvertF sz a)

szconvAnsZ :: FontSize -> ImageAns u a -> ImageAns u1 a
szconvAnsZ _ (Ans prim a) = Ans prim a



infixr 1 `at`


-- | Downcast a 'LocCF' function by applying it to the supplied 
-- point, making an arity-zero Context Function. 
-- 
-- Remember a 'LocCF' function is a 'CF1' context function where
-- the /static argument/ is specialized to a start point.
--
at :: LocQuery u a -> Point2 u -> CF a
at = apply1R1



infixr 1 `incline`


-- | Downcast a 'LocThetaQuery' function by applying it to the 
-- supplied angle, making an arity-one Context Function (a 
-- 'LocCF'). 
-- 
incline :: LocThetaQuery u a -> Radian -> LocQuery u a
incline = apply1R2


-- | Downcast a LocThetaQuery function by applying it to the 
-- supplied point and angle, making an arity-zero Context Function 
-- (a CF). 
--
atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a
atIncline = apply2R2


-- | Downcast a 'ConnectorQuery' function by applying it to the 
-- start and end point, making an arity-zero Context Function 
-- (a 'CF'). 
-- 
connect :: ConnectorQuery u a -> Point2 u -> Point2 u -> CF a
connect = apply2R2



-- | Replace the ans - arity 0.
-- 
replaceAnsR0 :: ans -> CF (ImageAns u a) -> CF (ImageAns u ans)
replaceAnsR0 ans = fmap (replaceAns ans)


-- | Replace the ans - arity 1.
--
replaceAnsR1 :: ans -> CF (r1 -> ImageAns u a) -> CF (r1 -> ImageAns u ans)
replaceAnsR1 ans = fmap $ fmap (replaceAns ans)


-- | Replace the ans - arity 2.
--
replaceAnsR2 :: ans 
             -> CF (r1 -> r2 -> ImageAns u a) 
             -> CF (r1 -> r2 -> ImageAns u ans)
replaceAnsR2 ans = fmap $ fmap $ fmap (replaceAns ans) 


-- | Decorate an Image by superimposing a Graphic.
--
-- Note - this function has a very general type signature and
-- supports various graphic types:
--
decorateR0 :: CF (ImageAns u a) -> CF (GraphicAns u) -> CF (ImageAns u a) 
decorateR0 img gf = op <$> img <*> gf
  where
    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a


decorateR1 :: CF (r1 -> ImageAns u a) 
           -> CF (r1 -> GraphicAns u) 
           -> CF (r1 -> ImageAns u a) 
decorateR1 img gf = promoteR1 $ \r1 ->
    op <$> apply1R1 img r1 <*> apply1R1 gf r1
  where
    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a


decorateR2 :: CF (r1 -> r2 -> ImageAns u a) 
           -> CF (r1 -> r2 -> GraphicAns u) 
           -> CF (r1 -> r2 -> ImageAns u a) 
decorateR2 img gf = promoteR2 $ \r1 r2 ->
    op <$> apply2R2 img r1 r2 <*> apply2R2 gf r1 r2
  where
    op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a


-- | Decorate an Image by superimposing a Graphic.
--
-- Note - this function has a very general type signature and
-- supports various graphic types:
--
elaborateR0 :: CF (ImageAns u a) -> (a -> CF (GraphicAns u)) -> CF (ImageAns u a) 
elaborateR0 img gf = 
    img  >>= \(Ans p1 a) ->
    gf a >>= \(Ans p2 _) -> 
    return $ Ans (p1 `oplus` p2) a




-- | Decorate an Image by superimposing a Graphic.
--
-- Note - this function has a very general type signature and
-- supports various graphic types:
--
elaborateR1 :: CF (r1 -> ImageAns u a) 
            -> (a -> CF (r1 -> GraphicAns u)) 
            -> CF (r1 -> ImageAns u a) 
elaborateR1 img gf = promoteR1 $ \r1 -> 
    apply1R1 img r1    >>= \(Ans p1 a) ->
    apply1R1 (gf a) r1 >>= \(Ans p2 _) -> 
    return $ Ans (p1 `oplus` p2) a



elaborateR2 :: CF (r1 -> r2 -> ImageAns u a) 
            -> (a -> CF (r1 -> r2 -> GraphicAns u)) 
            -> CF (r1 -> r2 -> ImageAns u a) 
elaborateR2 img gf = promoteR2 $ \r1 r2 -> 
    apply2R2 img r1 r2    >>= \(Ans p1 a) ->
    apply2R2 (gf a) r1 r2 >>= \(Ans p2 _) -> 
    return $ Ans (p1 `oplus` p2) a




{-

-- Not exported - thanks to Max Bollingbroke.
--
type family   GuardEqAns a b :: *
type instance GuardEqAns a a = a

-- | An Image always returns a pair of some polymorphic answer @a@
-- and a PrimGraphic.
--
data ImageAns t u       = Ans (t u) CatPrim

type instance DUnit (ImageAns t u) = GuardEqAns u (DUnit (t u))

type GraphicAns u       = ImageAns UNil u


instance Functor t => Functor (ImageAns t) where
  fmap f (Ans a prim) = Ans (fmap f a) prim

instance OPlus (t u) => OPlus (ImageAns t u) where
  Ans a p1 `oplus` Ans b p2 = Ans (a `oplus` b) (p1 `oplus` p2)


--------------------------------------------------------------------------------
-- Affine instances 

-- 
-- Design Note
--
-- Translate and RotateAbout require the unit to be /scalar/ 
-- e.g. Double, Centimeter, Pica.
--
-- This is annoying and a limitation, but an alternative would
-- need access to current-font-size which cannot be a pure 
-- function.
-- 

instance Rotate (t u) => Rotate (ImageAns t u) where
  rotate ang (Ans a p) = Ans (rotate ang a) (rotate ang p)


instance (RotateAbout (t u), ScalarUnit u, u ~ DUnit (t u)) => 
    RotateAbout (ImageAns t u) where
  rotateAbout ang pt@(P2 x y) (Ans a p) = 
    Ans (rotateAbout ang pt a) 
        (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) p)


instance Scale (t u) => Scale (ImageAns t u) where
  scale sx sy (Ans a p) = Ans (scale sx sy a) (scale sx sy p)


instance (Translate (t u), ScalarUnit u, u ~ DUnit (t u)) => 
    Translate (ImageAns t u) where
  translate dx dy (Ans a p) = 
    Ans (translate dx dy a) (translate (toPsPoint dx) (toPsPoint dy) p)


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


-- | Ignore the answer produced by an Image (or LocImage, etc.)
-- and form a Graphic instead.
--
ignoreAns :: Functor f
          => cf (ImageAns t u) -> cf (GraphicAns u)
ignoreAns = fmap (\(Ans _ prim) -> Ans UNil prim)



-- | Replace the answer produced by a graphic object.
--
-- Note - the new answer must share the same unit type as the
-- initial answer, although it does not need to have the same
-- wrapper type.
--
replaceAns :: Functor cf
          => t1 u -> cf (ImageAns t u) -> cf (ImageAns t1 u)
replaceAns ans = fmap (\(Ans _ prim) -> Ans ans prim)


-- | Map the answer produced by a graphic object.
--
-- Note - the new answer must share the same unit type as the
-- initial answer, although it does not need to have the same
-- wrapper type.
--
mapAns :: Functor cf
       => (t u -> t1 u) -> cf (ImageAns t u) -> cf (ImageAns t1 u)
mapAns f = fmap (trafoImageAns f id) 



-- | Transform both the answer produced by a graphic object and 
-- transform the primitive drawing.
--
-- Note - the new answer must share the same unit type as the
-- initial answer, although it does not need to have the same
-- wrapper type. Also this function is specifically exposed to
-- enable affine transofrmations - it is not expected to be 
-- generally useful.
--
trafoImageAns :: (t u -> t1 u) -> (CatPrim -> CatPrim) 
              -> ImageAns t u -> ImageAns t1 u
trafoImageAns f g (Ans a prim) = Ans (f a) (g prim)


-- | 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 cf
         => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) 
decorate img gf = combind const img (const gf) 


-- | Ante-decorate - version of 'decorate' where the decoration is 
-- drawn behind the Image.
--
adecorate :: Monad cf
          => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) 
adecorate img gf = acombind const img (const gf)


-- | Version of 'elaborate' where the decorating Graphic has access 
-- to the result produced by the Image.
--
-- Again, this function has a very general type signature and
-- supports various graphic types:
--
-- > elaborate :: Image u a -> Graphic u -> Image u a
-- > elaborate :: LocImage u a -> LocGraphic u -> LocImage u a
-- > elaborate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a
--
elaborate :: Monad cf 
          => cf (ImageAns t u) 
          -> (t u -> cf (GraphicAns u)) 
          -> cf (ImageAns t u)
elaborate img gf = combind const img gf

-- | Ante-elaborate - version of 'elaborate' where the decoration 
-- is drawn behind the Image.
--
aelaborate :: Monad cf 
           => cf (ImageAns t u) -> (t u -> cf (GraphicAns u)) -> cf (ImageAns t u)
aelaborate img gf = acombind const img gf


-- | 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 cf 
          => XLink -> cf (ImageAns t u) -> cf (ImageAns t u)
hyperlink hypl = 
    fmap (\(Ans a prim) -> Ans a (cpmap (xlinkPrim hypl) prim))


-- | Clip a graphic object.
-- 
clipObject :: Functor cf 
           => PrimPath -> cf (ImageAns t u) -> cf (ImageAns t u)
clipObject pp = 
    fmap (\(Ans a prim) -> Ans a (cpmap (clip pp) prim))




-- | This is a very general monadic combiner.
-- 
-- The first argument is a pure combiner cf. @liftM2@, @liftA2@
-- 
-- The second argument is an Image to be evaluated.
--
-- The third argument, uses the ouput from the first Image to 
-- build a second Image.
-- 
-- The function concatenates the CatPrims formed by both Images
-- and uses the pure combiner to build an answer from the
-- intermediate answers.
--
-- NOTE - note useful with CF representation change.
--
combind :: Monad cf 
        => (t1 u -> t2 u -> t3 u)
        -> cf (ImageAns t1 u) 
        -> (t1 u -> cf (ImageAns t2 u)) 
        -> cf (ImageAns t3 u) 
combind op gf fn = gf   >>= \(Ans a p1) -> 
                   fn a >>= \(Ans b p2) -> 
                   return $ Ans (a `op` b) (p1 `oplus` p2)


-- | Version of combind where the drawing order is flipped.
--
acombind :: Monad cf 
         => (t1 u -> t2 u -> t3 u)
         -> cf (ImageAns t1 u) 
         -> (t1 u -> cf (ImageAns t2 u)) 
         -> cf (ImageAns t3 u) 
acombind op gf fn = gf   >>= \(Ans a p1) -> 
                    fn a >>= \(Ans b p2) -> 
                    return $ Ans (a `op` b) (p2 `oplus` p1)

-}