{-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.ContextFun -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : highly unstable -- Portability : GHC -- -- Function types operating over the DrawingContext as a /static/ -- argument. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.ContextFun ( -- * /Context functional/ types CF , CF1 , CF2 , LocCF , LocThetaCF , ConnectorCF , DLocCF , DLocThetaCF , DConnectorCF -- * Run functions , runCF , runCF1 , runCF2 -- * Lift functions , lift0R1 , lift0R2 , lift1R2 , promoteR1 , promoteR2 , apply1R1 , apply2R2 , apply1R2 -- * Extractors , drawingCtx , queryCtx , locCtx , locPoint , locThetaCtx , locThetaPoint , locThetaAng , connCtx , connStart , connEnd -- * Combinators , at , rot , atRot , connect , chain1 ) where import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.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 { unCF :: DrawingContext -> a } -- | Variation of 'CF' with one parametric /static argument/. -- -- The static argument is commonly a point representing the start -- point / origin of a drawing. -- -- > CF1 :: DrawingContext -> r1 -> a -- newtype CF1 r1 a = CF1 { unCF1 :: DrawingContext -> r1 -> a } -- | Variation of 'CF' with two parametric /static arguments/. -- -- The first argument is commonly a point representing the start -- point / origin of a drawing. The second argument might -- typically be the angle of displacement (for drawing arrowheads) -- or an end point (for drawing connectors between two points). -- -- > CF2 :: DrawingContext -> r1 -> r2 -> a -- newtype CF2 r1 r2 a = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a } -- | Type specialized verison of 'CF1' where the /static argument/ -- is the /start point/. -- -- > LocCF :: DrawingContext -> Point2 u -> a -- type LocCF u a = CF1 (Point2 u) a -- | Type specialized verison of 'CF2' where the /static arguments/ -- are the /start point/ and the /angle of displacement/. -- -- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a -- type LocThetaCF u a = CF2 (Point2 u) Radian a -- | Type specialized verison of 'CF2' where the /static arguments/ -- are the /start point/ and the /end point/. -- -- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a -- type ConnectorCF u a = CF2 (Point2 u) (Point2 u) a -- | Alias of 'LocCF' where the unit type is specialized to -- @Double@. -- type DLocCF a = LocCF Double a -- | Alias of 'LocThetaCF' where the unit type is specialized to -- @Double@. -- type DLocThetaCF a = LocThetaCF Double a -- | Alias of 'ConnectorCF' where the unit type is specialized to -- @Double@. -- type DConnectorCF a = ConnectorCF Double a -------------------------------------------------------------------------------- -- CF instances -- OPlus instance OPlus a => OPlus (CF a) where fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx instance OPlus a => OPlus (CF1 r1 a) where fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1 instance OPlus a => OPlus (CF2 r1 r2 a) where fa `oplus` fb = CF2 $ \ctx r1 r2 -> unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2 -- Monoid -- Nothing is stopping monoid instances, though in practice there -- might be few useful types (more in Semgigroup / OPlus)... instance Monoid a => Monoid (CF a) where mempty = CF $ \_ -> mempty fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx instance Monoid a => Monoid (CF1 r1 a) where mempty = CF1 $ \_ _ -> mempty fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1 instance Monoid a => Monoid (CF2 r1 r2 a) where mempty = CF2 $ \_ _ _ -> mempty fa `mappend` fb = CF2 $ \ctx r1 r2 -> unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2 -- Functor instance Functor CF where fmap f ma = CF $ \ctx -> f $ unCF ma ctx instance Functor (CF1 r1) where fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 instance Functor (CF2 r1 r2) where fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2 -- Applicative instance Applicative CF where pure a = CF $ \_ -> a mf <*> ma = CF $ \ctx -> let f = unCF mf ctx a = unCF ma ctx in f a instance Applicative (CF1 r1) where pure a = CF1 $ \_ _ -> a mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 a = unCF1 ma ctx r1 in f a instance Applicative (CF2 r1 r2) where pure a = CF2 $ \_ _ _ -> a mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2 a = unCF2 ma ctx r1 r2 in f a -- Monad instance Monad CF where return a = CF $ \_ -> a ma >>= k = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx instance Monad (CF1 r1) where return a = CF1 $ \_ _ -> a ma >>= k = CF1 $ \ctx r1 -> let a = unCF1 ma ctx r1 in (unCF1 . k) a ctx r1 instance Monad (CF2 r1 r2) where return a = CF2 $ \_ _ _ -> a ma >>= k = CF2 $ \ctx r1 r2 -> let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2 -- DrawingCtxM instance DrawingCtxM CF where askDC = CF $ \ctx -> ctx localize upd df = CF $ \ctx -> unCF df (upd ctx) instance DrawingCtxM (CF1 r1) where askDC = CF1 $ \ctx _ -> ctx localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1 instance DrawingCtxM (CF2 r1 r2) where askDC = CF2 $ \ctx _ _ -> ctx localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2 -- Note - there is nothing determining a DUnit for the CF types, -- so it seems appropriate not to define affine instances. -- -- However affine instances can be made for the Image type in -- Objects.BaseObjects. -- -------------------------------------------------------------------------------- -- Run functions -- | Run a /CF/ (context function) with the supplied -- /DrawingContext/. -- runCF :: DrawingContext -> CF a -> a runCF ctx df = unCF df ctx -- | Run a /CF1/ (context function) with the supplied -- /DrawingContext/ and static argument. -- runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a runCF1 ctx r1 df = unCF1 df ctx r1 -- | Run a /CF1/ (context function) with the supplied -- /DrawingContext/ and two static arguments. -- runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2 -------------------------------------------------------------------------------- -- lift functions -- | Lift a zero-arity context function 'CF' to an arity one -- context function 'CF1'. -- lift0R1 :: CF a -> CF1 r1 a lift0R1 mf = CF1 $ \ctx _ -> unCF mf ctx -- | Lift a zero-arity context function 'CF' to an arity two -- context function 'CF2'. -- lift0R2 :: CF a -> CF2 r1 r2 a lift0R2 mf = CF2 $ \ctx _ _ -> unCF mf ctx -- | Lift an arity one context function 'CF1' to an arity two -- context function 'CF2'. -- lift1R2 :: CF1 r1 a -> CF2 r1 r2 a lift1R2 mf = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1 -- | Promote a function @from one argument to a Context Function@ -- to an arity one @Context Function@. -- -- The type signature is as explanatory as a description: -- -- > promoteR1 :: (r1 -> CF a) -> CF1 r1 a -- promoteR1 :: (r1 -> CF a) -> CF1 r1 a promoteR1 mf = CF1 $ \ctx r1 -> unCF (mf r1) ctx -- | Promote a function @from two arguments to a Context Function@ -- to an arity two @Context Function@. -- -- The type signature is as explanatory as a description: -- -- > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a -- promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a promoteR2 mf = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx -- | Apply an arity-one Context Function to a single argument, -- downcasting it by one level, making an arity-zero Context -- function. -- -- The type signature is as explanatory as a description: -- -- > apply1R1 :: CF1 r1 a -> r1 -> CF a -- apply1R1 :: CF1 r1 a -> r1 -> CF a apply1R1 mf r1 = CF $ \ctx -> unCF1 mf ctx r1 -- | Apply an arity-two Context Function to two arguments, -- downcasting it by two levels, making an arity-zero Context -- function. -- -- The type signature is as explanatory as a description: -- -- > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a -- apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a apply2R2 mf r1 r2 = CF $ \ctx -> unCF2 mf ctx r1 r2 -- | Apply an arity-two Context Function to one argument, -- downcasting it by one level, making an arity-one Context -- function. -- -- The type signature is as explanatory as a description: -- -- > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a -- apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a apply1R2 mf r2 = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2 -------------------------------------------------------------------------------- -- 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 = CF1 $ \ctx _ -> ctx -- | Extract the /start/ point from a LocCF. -- -- > (ctx -> pt -> pt) -- locPoint :: LocCF u (Point2 u) locPoint = CF1 $ \_ pt -> pt -- | Extract the drawing context from a LocThetaCF. -- -- > (ctx -> pt -> ang -> ctx) -- locThetaCtx :: LocThetaCF u DrawingContext locThetaCtx = CF2 $ \ctx _ _ -> ctx -- | Extract the /start/ point from a LocThetaCF. -- -- > (ctx -> pt -> ang -> pt) -- locThetaPoint :: LocThetaCF u (Point2 u) locThetaPoint = CF2 $ \_ pt _ -> pt -- | Extract the angle from a LocThetaCF. -- -- > (ctx -> pt -> ang -> ang) -- locThetaAng :: LocThetaCF u Radian locThetaAng = CF2 $ \_ _ ang -> ang -- | Extract the drawing context from a ConnectorCF. -- -- > (ctx -> pt1 -> pt2 -> ctx) -- connCtx :: ConnectorCF u DrawingContext connCtx = CF2 $ \ctx _ _ -> ctx -- | Extract the start point from a ConnectorCF. -- -- > (ctx -> pt1 -> pt2 -> pt1) -- connStart :: ConnectorCF u (Point2 u) connStart = CF2 $ \_ pt _ -> pt -- | Extract the end point from a ConnectorCF. -- -- > (ctx -> pt1 -> pt2 -> pt2) -- connEnd :: ConnectorCF u (Point2 u) connEnd = CF2 $ \_ _ pt -> pt -------------------------------------------------------------------------------- -- Combinators 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 :: LocCF u a -> Point2 u -> CF a at = apply1R1 infixr 1 `rot` -- | Downcast a 'LocThetaCF' function by applying it to the -- supplied angle, making an arity-one Context Function (a -- 'LocCF'). -- rot :: LocThetaCF u a -> Radian -> LocCF u a rot = apply1R2 -- | Downcast a 'LocThetaCF' function by applying it to the -- supplied point and angle, making an arity-zero Context -- Function (a 'CF'). -- atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a atRot = apply2R2 -- | Downcast a 'ConnectorCF' function by applying it to the -- start and end point, making an arity-zero Context Function -- (a 'CF'). -- connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a connect = apply2R2 infixr 6 `chain1` -- | /Chaining/ combinator - the /answer/ of the -- first Context Function is feed to the second Context Function. -- -- This contrasts with the usual idiom in @Wumpus-Basic@ where -- composite graphics are built by applying both functions to the -- same initial /static argument/. -- -- Desciption: -- -- 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@. -- -- @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @ -- -- This models chaining start points together, which is the model -- PostScript uses for text output when successively calling the -- @show@ operator. -- chain1 :: OPlus w => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w) chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s (s2,a2) = unCF1 g ctx s1 in (s2, a1 `oplus` a2)