wumpus-basic-0.13.0: src/Wumpus/Basic/Graphic/ContextFunction.hs

{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Graphic.ContextFunction
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- The primary drawing type and base combinators to manipulate it. 
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Graphic.ContextFunction
  (

    CF

  , LocCF
  , LocThetaCF
  , ConnectorCF
  , DLocCF
  , DLocThetaCF
  , DConnectorCF



  -- * Run functions
  , runCF

  -- * Extractors
  , drawingCtx
  , queryCtx
  , locCtx
  , locPoint
  , locThetaCtx
  , locThetaPoint
  , locThetaAng
  , connCtx
  , connStart
  , connEnd

  -- * Reducers
  , unLoc
  , unTheta
  , unLocTheta
  , unConnector

  , unCF1
  , unCF2

  -- * Combinators
  , wrap
  , wrap1
  , wrap2

  , promote1
  , promote2

  , raise
  , raise1
  , raise2

  , static1 
  , static2
  , dblstatic

  , bind
  , bind1
  , bind2


  , situ1
  , situ2

  , apply
  , apply1
  , apply2

  -- * Pre-transformers
  , prepro1
  , prepro2
  , prepro2a
  , prepro2b

  -- * Post-transformers
  , postpro
  , postpro1
  , postpro2

  -- * Post-combiners
  , postcomb
  , postcomb1
  , postcomb2

  , accumulate1
  , accumulate2


  ) where

-- import Wumpus.Basic.Graphic.Anchors
import Wumpus.Basic.Graphic.Base
import Wumpus.Basic.Graphic.DrawingContext

import Wumpus.Core                      -- package: wumpus-core


import Control.Applicative
import Data.Monoid


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

-- | Most drawing operations in Wumpus-Basic have an implicit 
-- /graphics state/ the @DrawingContext@, so the most primitive 
-- building block is a function from the DrawingContext to some 
-- polymorphic answer.
-- 
-- This functional type is represented concretely as the initials 
-- @CF@ for /contextual function/.
-- 
-- > CF :: DrawingContext -> a 
--
newtype CF a = CF { getCF :: DrawingContext -> a }


type LocCF          u a = CF (Point2 u -> a)

type LocThetaCF     u a = LocCF u (Radian -> a)

type ConnectorCF    u a = LocCF u (Point2 u -> a)



type DLocCF a           = LocCF       Double a
type DLocThetaCF a      = LocThetaCF  Double a
type DConnectorCF a     = ConnectorCF Double a



--------------------------------------------------------------------------------
-- Drawing instances

instance Functor CF where
  fmap f ma = CF $ \ctx -> f $ getCF ma ctx 


instance OPlus a => OPlus (CF a)  where
  fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx

-- The monoid instance seems sensible...
--
instance Monoid a => Monoid (CF a) where 
  mempty          = CF $ \_   -> mempty
  fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx

-- Applicative

instance Applicative CF where
  pure a    = CF $ \_   -> a
  mf <*> ma = CF $ \ctx -> let f = getCF mf ctx
                               a = getCF ma ctx
                           in f a
-- Monad 

instance Monad CF where
  return a  = CF $ \_   -> a
  ma >>= k  = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx 


instance DrawingCtxM CF where
  askDC           = CF $ \ctx -> ctx
  localize upd df = CF $ \ctx -> getCF df (upd ctx)
  



--------------------------------------------------------------------------------
-- Run functions



-- | Run a /CF/ (context function) with the supplied /DrawingContext/.
--
runCF :: DrawingContext -> CF a -> a
runCF ctx df = getCF df ctx


--------------------------------------------------------------------------------
-- extractors 

-- | Extract the drawing context from a CtxFun.
--
-- > (ctx -> ctx)
-- 
drawingCtx      :: CF DrawingContext
drawingCtx      = CF $ \ctx -> ctx

-- | Apply the projection function to the drawing context.
--
-- > (ctx -> a) -> (ctx -> a)
--
queryCtx        :: (DrawingContext -> a) -> CF a
queryCtx f      = CF $ \ctx -> f ctx


-- | Extract the drawing context from a LocCF.
--
-- > (ctx -> pt -> ctx)
--
locCtx          :: LocCF u DrawingContext
locCtx          = CF $ \ctx _  -> ctx

-- | Extract the /start/ point from a LocCF.
--
-- > (ctx -> pt -> pt)
--
locPoint        :: LocCF u (Point2 u)
locPoint        = CF $ \_ pt -> pt


-- | Extract the drawing context from a LocThetaCF.
--
-- > (ctx -> pt -> ang -> ctx)
--
locThetaCtx     :: LocThetaCF u DrawingContext
locThetaCtx     = CF $ \ctx _ _ -> ctx


-- | Extract the /start/ point from a LocThetaCF.
--
-- > (ctx -> pt -> ang -> pt)
--
locThetaPoint   :: LocThetaCF u (Point2 u)
locThetaPoint   = CF $ \_ pt _ -> pt

-- | Extract the angle from a LocThetaCF.
--
-- > (ctx -> pt -> ang -> ang)
--
locThetaAng     :: LocThetaCF u Radian
locThetaAng     = CF $ \_ _ ang -> ang

-- | Extract the drawing context from a ConnectorCF.
--
-- > (ctx -> pt1 -> pt2 -> ctx)
--
connCtx         :: ConnectorCF u DrawingContext
connCtx         = CF $ \ctx _ _ -> ctx

-- | Extract the start point from a ConnectorCF.
--
-- > (ctx -> pt1 -> pt2 -> pt1)
--
connStart       :: ConnectorCF u (Point2 u) 
connStart       = CF $ \_ pt _ -> pt

-- | Extract the end point from a ConnectorCF.
--
-- > (ctx -> pt1 -> pt2 -> pt2)
--
connEnd         :: ConnectorCF u (Point2 u) 
connEnd         = CF $ \_ _ pt -> pt


--------------------------------------------------------------------------------
-- /Reducers/

-- | This is unCF1 at a specific type.
--
unLoc :: Point2 u -> LocCF u a -> CF a
unLoc pt mf = CF $ \ctx -> getCF mf ctx pt

unTheta :: Radian -> LocThetaCF u a -> LocCF u a
unTheta theta mf = CF $ \ctx pt -> getCF mf ctx pt theta

unLocTheta :: Point2 u -> Radian -> LocThetaCF u a -> CF a
unLocTheta pt theta mf = CF $ \ctx -> getCF mf ctx pt theta

unConnector :: Point2 u -> Point2 u -> ConnectorCF u a -> CF a
unConnector p0 p1 mf = CF $ \ctx -> getCF mf ctx p0 p1


unCF1 :: r1 -> CF (r1 -> a) -> CF a
unCF1 a mf = CF $ \ctx -> getCF mf ctx a

unCF2 :: r1 -> r2 ->  CF (r1 -> r2 -> a) -> CF a
unCF2 a b mf = CF $ \ctx -> getCF mf ctx a b




--------------------------------------------------------------------------------
-- Combinators

-- | Lift a pure value into a Context functional. The 
-- DrawingContext is ignored.
--
-- > ans -> (ctx -> ans)
--
-- Without any other arguments, this is the same as the 'raise' 
-- combinator for raising into the Context functional. However, 
-- the /arity family/ of @wrap@ combinators is different.
--
wrap :: a -> CF a
wrap = pure


-- | Lift a pure value into a Context functional, ignoring both 
-- the DrawingContext and the /static/ argument, e.g. this would
-- ingnore start point for a @LocDrawing@).
--
-- > ans -> (ctx -> r1 -> ans)
--
wrap1 :: a -> CF (r1 -> a)
wrap1 = pure . pure

-- | Lift a pure value into a Context functional, ignoring both 
-- the DrawingContext and the two /static/ arguments, e.g. this 
-- would ignore the start point and angle for a @LocThetaDrawing@.
--
-- > ans -> (ctx -> r1 -> r2 -> ans)
--
wrap2 :: a -> CF (r1 -> r2 -> a)
wrap2 = pure . pure . pure

   

-- | Promote a Context functional with one argument /outside/
-- the functional so that the the argument is /inside/ the 
-- Context functional.
--
-- The type signature is probably more illustrative of the 
-- operation than this description:
--
-- > (r1 -> ctx -> ans) -> (ctx -> r1 -> ans)
--
-- This is essentially the @cardinal@ combinator - @flip@
-- in Haskell.
--
promote1 :: (r1 -> CF ans) -> CF (r1 -> ans)
promote1 f = CF $ \ctx a -> getCF (f a) ctx


-- | Promote a Context functional with two arguments /outside/
-- the functional so that the two arguments are /inside/ the 
-- Context functional.
--
-- The type signature is probably more illustrative of the 
-- operation than this description:
--
-- > (r1 -> r2 -> ctx -> ans) -> (ctx -> r1 -> r2 -> ans)
--
promote2 :: (r1 -> r2 -> CF ans) -> CF (r1 -> r2 -> ans)
promote2 df = CF $ \ctx a b -> getCF (df a b) ctx


-- | Lift a value into a Context functional.
--
-- > ans -> (ctx -> ans)
--
-- Essentially this is the @kestrel@ combinator - @const@ in 
-- Haskell, though due to newtype wrapping it is @pure@ from the
-- Applicative class.
--
raise :: a -> CF a
raise = pure


-- | Lift a one argument function into a Context functional.
--
-- This is Applicative\'s 'pure' with a specialized type 
-- signature. 
--
raise1 :: (r1 -> ans) -> CF (r1 -> ans) 
raise1 = pure

-- | Lift a two argument function into a Context functional.
--
-- This is Applicative\'s 'pure' with a specialized type 
-- signature.
--
raise2 :: (r1 -> r2 -> ans) -> CF (r1 -> r2 -> ans) 
raise2 = pure


-- | Extend the arity of a /Context functional/, the original 
-- function is oblivious to the added argument.
--
-- Typically this combinator is used to take a @Graphic@ to a
-- @LocGraphic@ ingoring the start point (figuratively a @Graphic@ 
-- is not /coordinate free/). 
--
-- > (ctx -> ans) -> (ctx -> r1 -> ans)
--
-- This was called the J-combinator by Joy, Rayward-Smith and
-- Burton (ref. /Compling Functional Languages/ by Antoni 
-- Diller), however it is not the J combinator commonly in the 
-- Literature. 
--
static1 :: CF ans -> CF (r1 -> ans)
static1 df = CF $ \ctx _ -> getCF df ctx


-- | Extend the arity of a /Context functional/, the original 
-- function is oblivious to the added argument.
--
-- Typically this combinator is used to take a @LocGraphic@ to a
-- @LocThetaGraphic@ ingoring the angle of direction.
--
-- > (ctx -> r1 -> ans) -> (ctx -> r1 -> r2 -> ans)
--
-- This was called the J-Prime combinator by Joy, Rayward-Smith 
-- and Burton (ref. /Compling Functional Languages/ by Antoni 
-- Diller). 
--
static2 :: CF (r1 -> ans) -> CF (r1 -> r2 -> ans)
static2 df = CF $ \ctx a _ -> getCF df ctx a


-- | Complementary combinator to static2. 
--
-- This combinator raises a function two levels rather than one.
--
-- > (ctx -> ans) -> (ctx -> r1 -> r2 -> ans)
--
dblstatic :: CF ans -> CF (r1 -> r2 -> ans)
dblstatic df = CF $ \ctx _ _ -> getCF df ctx


infixl 1 `bind`, `bind1`, `bind2`


-- | Supply the output from the first function to the second 
-- function.
--
-- This is just monadic bind - specialized to the CF functional 
-- type.
--
-- > (ctx -> a) -> (a -> ctx -> ans) -> (ctx -> ans)
-- 
bind :: CF a -> (a -> CF ans) -> CF ans
bind df dk = CF $ \ctx -> let z = getCF df ctx in getCF (dk z) ctx


-- | Supply the output from the first function to the second 
-- function, /sharing/ the drawing context and the static 
-- argument @r1@.
--
-- > (ctx -> r1 -> a) -> (a -> ctx -> -> r1 -> ans) -> (ctx -> r1 -> ans)
-- 
bind1 :: CF (r1 -> a) -> (a -> CF (r1 -> ans)) -> CF (r1 -> ans)
bind1 df dk = CF $ \ctx a -> let z = getCF df ctx a in getCF (dk z) ctx a

-- | Supply the output from the first function to the second 
-- function, /sharing/ the DrawingContext and the two static 
-- arguments @r1@ and @r2@.
--
-- > (ctx -> r1 -> r2 -> a) -> (a -> ctx -> -> r1 -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans)
-- 
bind2 :: CF (r1 -> r2 -> a) -> (a -> CF (r1 -> r2 -> ans)) 
      -> CF (r1 -> r2 -> ans)
bind2 df dk = CF $ \ctx a b -> 
    let z = getCF df ctx a b in getCF (dk z) ctx a b


-- idstar  :: (r1 -> r2 -> ans) -> r1 -> r2 -> ans

-- | Supply the arguments to an arity 1 Context functional so it 
-- can be /situated/. Typically this is supplying the start point 
-- to a @LocGraphic@ or @LocImage@.
--
-- > (ctx -> r1 -> ans) -> r1 -> (ctx -> ans)
--
-- This is equivalent to the @id**@ combinator.
--
situ1 :: CF (r1 -> ans) -> r1 -> CF ans
situ1 df a = CF $ \ctx -> getCF df ctx a



-- | Supply the arguments to an arity 2 Conterxt functional so 
-- it can be /situated/. Typically this is supplying the start 
-- point and angle to a @LocThetaGraphic@ or @LocThetaImage@.
--
-- > (ctx -> r1 -> r2 -> ans) -> r1 -> r2 -> (ctx -> ans)
--
situ2 :: CF (r1 -> r2 -> ans) -> r1 -> r2 -> CF ans
situ2 df a b = CF $ \ctx -> getCF df ctx a b


-- | Apply the the functional produced by the first argument to
-- the value produced by the second.
--
-- > (ctx -> a -> ans) -> (ctx -> a) -> (ctx -> ans) 
--
apply :: CF (a -> ans) -> CF a -> CF ans
apply df da = CF $ \ctx -> getCF df ctx (getCF da ctx)


-- | Apply the the functional produced by the first argument to
-- the value produced by the second /sharing/ the context of the 
-- first functional argument @r1@ (usually a Point2) as well as 
-- the DrawingContext.
--
-- > (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) 
--
apply1 :: CF (r1 -> a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans)
apply1 df da = CF $ \ctx a -> getCF df ctx a (getCF da ctx a)


-- | Apply the the functional produced by the first argument to
-- the value produced by the second /sharing/ the context of the 
-- two functional arguments @r1@ and @r2@ as well as the 
-- DrawingContext.
--
-- > (ctx -> r1 -> r2 -> a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) 
--
apply2 :: CF (r1 -> r2 -> a -> ans) -> CF (r1 -> r2 -> a) 
       -> CF (r1 -> r2 -> ans)
apply2 df da = CF $ \ctx a b -> getCF df ctx a b (getCF da ctx a b)


--------------------------------------------------------------------------------
-- Pre-transformers

-- The primary /pre-transformation/ function is @localize@, here 
-- it is without the newtype wrapper or the specific types:
--
-- > fn :: (ctx -> ctx) -> (ctx -> ans) -> ctx -> ans
-- > fn f g = \ctx -> g (f ctx)
--
-- This a a type restricted version of reverse appliction, the T
-- combinator sometimes called queer, sometings @(#)@ in Haskell.
-- In Wumpus-Basic it is @localize@ which is overloaded for the
-- CF newtype and TraceDrawing monads.
--
-- > localizeDR :: (DrawingContext -> DrawingContext) -> CF a -> CF a
-- > localizeDR = localize
--
-- Figuartively speaking this is an opposite of the fmap function 
-- instance. Instead of (post-) transforming the output, ... 
-- (pre-) transforms  the input.
-- 
-- Due to Context functionals being stacked in a particular way
-- @localize@ always pre-transforms the DrawingContext regardless
-- of the arity of the functional:
--
-- > localizeDR2 :: (DrawingContext -> DrawingContext) 
-- >             -> CF (r -> a) -> CF (r -> a)
-- > localizeDR2 = localize
-- 


-- | Apply the static argument transfomer @(r1 -> a)@ to the 
-- static argument /before/ applying the Context functional.
--
-- > (r1 -> a) -> (ctx -> a -> ans) -> (ctx -> r1 -> ans)
-- 
prepro1 :: (r1 -> a) -> CF (a -> ans) -> CF (r1 -> ans)
prepro1 f mf = CF $ \ctx a -> getCF mf ctx (f a)


-- | Apply the static argument transfomers to their respective
-- static arguments /before/ applying the Context functional.
--
-- > (r1 -> a) -> (r2 -> b) -> (ctx -> a -> b -> ans) -> (ctx -> r1 -> r2 -> ans)
-- 
prepro2 :: (r1 -> a) -> (r2 -> b) -> CF (a -> b -> ans) -> CF (r1 -> r2 -> ans)
prepro2 f g mf = CF $ \ctx a b -> getCF mf ctx (f a) (g b)


-- | Apply the static argument transfomer to the first static
-- argument of a two static argument functional /before/ applying 
-- the Context functional.
--
-- > (r1 -> a) -> (ctx -> a -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans)
-- 
prepro2a :: (r1 -> a) -> CF (a -> r2 -> ans) -> CF (r1 -> r2 -> ans)
prepro2a f mf = CF $ \ctx a b -> getCF mf ctx (f a) b

-- | Apply the static argument transfomer to the second static
-- argument of a two static argument functional /before/ applying 
-- the Context functional.
--
-- > (r2 -> a) -> (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> r2 -> ans)
-- 
prepro2b :: (r2 -> a) -> CF (r1 -> a -> ans) -> CF (r1 -> r2 -> ans)
prepro2b f mf = CF $ \ctx a b -> getCF mf ctx a (f b)

------------------------------------------------------------------------------
-- Post-transfomers

-- | Apply the post-transformer to the result of the Context
-- functional.
--
-- > (a -> ans) -> (ctx -> a) -> (ctx -> ans) 
--
postpro :: (a -> ans) -> CF a -> CF ans
postpro = fmap

-- | Apply the post-transformer to the result of the Context
-- functional. Version for one static argument.
--
-- Note - the DrawingContext is always present so it is never 
-- counted as a static argument.
--
-- > (a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) 
--
postpro1 :: (a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans)
postpro1 = postpro . fmap  

-- | Apply the post-transformer to the result of the Context
-- functional. Version for two static arguments.
--
-- Note - the DrawingContext is always present so it is never 
-- counted as a static argument.
--
--
-- > (a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) 
--
postpro2 :: (a -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> ans)
postpro2 = postpro1 . fmap  


--------------------------------------------------------------------------------
-- Post-combiners

-- | Combine the results of the two Context Functions with the 
-- supplied operator.
--
-- > (a -> b -> ans) -> (ctx -> a) -> (ctx -> b) -> (ctx -> ans)
--
postcomb :: (a -> b -> ans) -> CF a -> CF b -> CF ans
postcomb op df dg = CF $ \ctx ->  getCF df ctx `op` getCF dg ctx

-- | Combine the results of the two one-static-argument Context 
-- Functions with the supplied operator.
--
-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans)
--
postcomb1 :: (a -> b -> c) -> CF (r1 -> a) -> CF (r1 -> b) -> CF (r1 -> c)
postcomb1 op df dg = CF $ \ctx a -> getCF df ctx a `op` getCF dg ctx a


-- | Combine the results of the two two-static-argument Context 
-- Functions with the supplied operator.
--
-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans)
--
postcomb2 :: (a -> b -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> b) 
          -> CF (r1 -> r2 -> ans)
postcomb2 op df dg = CF $ \ctx a b -> 
    getCF df ctx a b `op` getCF dg ctx a b



-- | Iteration combinator - the initial argument @s1@ is not 
-- shared bewteen the drawings.
--
-- Evaluate the first Context Function with the drawing context 
-- and the /initial state/ @st0@. The result of the evaluation is 
-- a new /state/ @st1@ and and answer @a1@. 
--
-- Evaluate the second Context Function with the drawing context 
-- and the new state @st1@, producing a new state @s2@ and an 
-- answer @a2@.
--
-- Return the result of combining the answers with 
-- @op :: (ans -> ans -> ans)@ and the second state @s2@.
--
-- @ (ans -> ans -> ans) -> (ctx -> s1 -> (s1,ans)) @
-- @                     -> (ctx -> s1 -> (s1,ans)) -> (ctx -> s1 -> (s1,ans)) @
--
-- This models chaining start points together, which is the model
-- PostScript uses for text output when succesively calling the 
-- @show@ operator.
-- 
accumulate1 :: (ans -> ans -> ans) 
            -> CF (s1 -> (s1,ans)) -> CF (s1 -> (s1,ans)) 
            -> CF (s1 -> (s1,ans)) 
accumulate1 op f g = CF $ \ctx s -> 
                        let (s1,a1) = getCF f ctx s
                            (s2,a2) = getCF g ctx s1
                        in (s2, a1 `op` a2)



-- | Arity two version of accumulate1 - this is not expected to be
-- useful!
--
-- @ (ans -> ans -> ans) -> (ctx -> s1 -> -> s2 (s1,s2,ans)) @
-- @     -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @
-- @     -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @
--
accumulate2 :: (ans -> ans -> ans) 
            -> CF (s1 -> s2 -> (s1,s2,ans)) 
            -> CF (s1 -> s2 -> (s1,s2,ans)) 
            -> CF (s1 -> s2 -> (s1,s2,ans)) 
accumulate2 op f g = CF $ \ctx s t -> 
                        let (s1,t1,a1) = getCF f ctx s t
                            (s2,t2,a2) = getCF g ctx s1 t1
                        in (s2, t2, a1 `op` a2)





--------------------------------------------------------------------------------
{-
instance CenterAnchor a => CenterAnchor (CF a) where
  center = postpro center
-}