wumpus-basic 0.20.0 → 0.21.0

raw patch · 26 files changed

+2175/−1503 lines, 26 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +26/−1
• demo/SimplePosObject.hs +1/−1
• src/Wumpus/Basic/Geometry/Paths.hs +1/−1
• src/Wumpus/Basic/Kernel.hs +14/−8
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +11/−11
• src/Wumpus/Basic/Kernel/Base/UserState.hs +0/−36
• src/Wumpus/Basic/Kernel/Drawing/Basis.hs +101/−0
• src/Wumpus/Basic/Kernel/Drawing/Chain.hs +306/−0
• src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs +408/−0
• src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs +238/−0
• src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs +214/−0
• src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs +411/−0
• src/Wumpus/Basic/Kernel/Objects/AdvObject.hs +1/−0
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +0/−233
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +1/−0
• src/Wumpus/Basic/Kernel/Objects/Chain.hs +0/−267
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +43/−23
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +0/−408
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +13/−14
• src/Wumpus/Basic/Kernel/Objects/Image.hs +283/−0
• src/Wumpus/Basic/Kernel/Objects/LocImage.hs +40/−60
• src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs +36/−20
• src/Wumpus/Basic/Kernel/Objects/PosObject.hs +2/−1
• src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs +0/−411
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +23/−6

@@ -1,5 +1,30 @@ -0.18.0 to 0.19.0:+0.18.0 to 0.20.0 (no release numbered v0.19.0):++  * Added text advance-vector calculations to @QueryDC@ - +    previously they were in Wumpus-Drawing.+ +  * Changed argument order of @run@ functions to follow the usual+    style - monadic action first and then dependent parameters +    (initial state, reader environment etc.).+ +  * Changed representation of Chains to a monadic type with an +    explicit operation for next position.++  * Removed @PrimW@ type - pairs are now used instead. ++  * Removed transformer version of @TraceDrawing@. All operations +    in TraceDrawing are now specialized to work only on the +    @TraceDrawing@ type. Added @UserState@ to TraceDrawing and+    other drawing monads to compensate for the loss of+    expressiveness.++  * Changed the internals of @AdvObject@ and @PosObject@ so they +    are more idiomatic - both are now essentially reader-writer +    monads. Added PosObject functions for text primitives (moved +    from Wumpus-Drawing).++  * Changed the @obliterate@ method of the @Decorate@ class.    * Removed the Semigroup (OPlus) and Bifunctor classes. They are      no longer so pertinent now that Image, LocImage etc. are 

@@ -110,5 +110,5 @@         br = displace (hvec w) bl         tr = displace (vvec h) br         tl = displace (vvec h) bl-    in zapQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE+    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath STROKE 

@@ -97,7 +97,7 @@ drawVertexPathAlg :: InterpretUnit u                    => DrawStyle -> PathAlg u -> LocGraphic u drawVertexPathAlg style alg = promoteLoc $ \pt -> -    zapQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style+    liftQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style   -- | Create a PathAlg from the vertex list.

@@ -23,23 +23,26 @@   , module Wumpus.Basic.Kernel.Base.QueryDC   , module Wumpus.Basic.Kernel.Base.Units   , module Wumpus.Basic.Kernel.Base.UpdateDC-  , module Wumpus.Basic.Kernel.Base.UserState   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive+  , module Wumpus.Basic.Kernel.Drawing.Basis+  , module Wumpus.Basic.Kernel.Drawing.Chain+  , module Wumpus.Basic.Kernel.Drawing.CtxPicture+  , module Wumpus.Basic.Kernel.Drawing.LocDrawing+  , module Wumpus.Basic.Kernel.Drawing.LocTrace+  , module Wumpus.Basic.Kernel.Drawing.TraceDrawing   , module Wumpus.Basic.Kernel.Objects.AdvObject   , module Wumpus.Basic.Kernel.Objects.Anchors   , module Wumpus.Basic.Kernel.Objects.Basis   , module Wumpus.Basic.Kernel.Objects.Bounded-  , module Wumpus.Basic.Kernel.Objects.Chain   , module Wumpus.Basic.Kernel.Objects.Concat   , module Wumpus.Basic.Kernel.Objects.Connector-  , module Wumpus.Basic.Kernel.Objects.CtxPicture   , module Wumpus.Basic.Kernel.Objects.Displacement   , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives+  , module Wumpus.Basic.Kernel.Objects.Image   , module Wumpus.Basic.Kernel.Objects.LocImage   , module Wumpus.Basic.Kernel.Objects.LocThetaImage   , module Wumpus.Basic.Kernel.Objects.Orientation   , module Wumpus.Basic.Kernel.Objects.PosObject-  , module Wumpus.Basic.Kernel.Objects.TraceDrawing    ) where @@ -49,20 +52,23 @@ import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Basic.Kernel.Base.UpdateDC-import Wumpus.Basic.Kernel.Base.UserState import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Drawing.Chain+import Wumpus.Basic.Kernel.Drawing.CtxPicture+import Wumpus.Basic.Kernel.Drawing.LocDrawing+import Wumpus.Basic.Kernel.Drawing.LocTrace+import Wumpus.Basic.Kernel.Drawing.TraceDrawing import Wumpus.Basic.Kernel.Objects.AdvObject import Wumpus.Basic.Kernel.Objects.Anchors import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Bounded-import Wumpus.Basic.Kernel.Objects.Chain import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.CtxPicture import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Basic.Kernel.Objects.Orientation import Wumpus.Basic.Kernel.Objects.PosObject-import Wumpus.Basic.Kernel.Objects.TraceDrawing

@@ -19,12 +19,11 @@ module Wumpus.Basic.Kernel.Base.BaseDefs   (   -    MonUnit  -   -- * Unit phantom type-  , UNil(..)+    UNil(..)   , ureturn+  , uvoid    -- * Non-contextual unit conversion.   , ScalarUnit(..)@@ -80,13 +79,8 @@   --- | Type family to access the unit parameter of a TraceDrawing--- or a promoted TraceDrawingT transformer.----type family MonUnit m :: *  - -------------------------------------------------------------------------------- -- Simple objects wrapped with unit phatom type  @@ -125,14 +119,15 @@ -- monadic commands. -- -- Many Wumpus objects are usefully constructed in the --- @do-notation@, but due to the need to type their unit--- must finish the do-block with:+-- @do-notation@, but because Wumpus has to expose the type of +-- the @unit@ to the type checker we must finish the do-block +-- with: -- -- > ureturn --  -- or: -- --- return UNil+-- > return UNil -- -- rather than: --@@ -141,6 +136,11 @@ -- ureturn :: Monad m => m (UNil u) ureturn = return UNil++-- | 'uvoid' runs a monadic computation and returns @UNil@.+--+uvoid :: Monad m => m a -> m (UNil u)+uvoid ma = ma >> return UNil  -------------------------------------------------------------------------------- -- Non-contextual units

@@ -1,36 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.UserState--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ User state class for Drawing monads.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.UserState-  (--    UState-  , UserStateM(..)--  ) where---import Control.Applicative--type family UState m :: *---class (Applicative m, Monad m) => UserStateM (m :: * -> *) where-  getState    :: st ~ UState m  => m st-  setState    :: st ~ UState m  => st -> m ()-  updateState :: st ~ UState m  => (st -> st) -> m ()-   

@@ -0,0 +1,101 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.Basis+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- User state class for Drawing monads.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.Basis+  (++    UState+  , UserStateM(..)++  , InsertlM(..)+  , LocationM(..)+  , CursorM(..)+  , BranchCursorM(..)+  , hmoveby+  , vmoveby++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative++type family UState m :: *+++class (Applicative m, Monad m) => UserStateM (m :: * -> *) where+  getState    :: st ~ UState m  => m st+  setState    :: st ~ UState m  => st -> m ()+  updateState :: st ~ UState m  => (st -> st) -> m ()+   +++++-- | Monad that collects a graphic trace, 'insertl' is analogue +-- to the Writer monad\'s @tell@.+--+class InsertlM (m :: * -> *) where+  insertl   :: u ~ DUnit (m ()) => LocImage u a -> m a+  insertl_  :: u ~ DUnit (m ()) => LocImage u a -> m (UNil u)++  insertl_ = insertl . ignoreAns +++-- | Monad with notion of location - i.e. the current point.+--+class Monad m => LocationM (m :: * -> *) where+  location  :: u ~ DUnit (m ()) => m (Point2 u)+++-- | Monad with turtle-like cursor movememnt.+--+class LocationM m => CursorM (m :: * -> *) where  +  moveby    :: u ~ DUnit (m ()) => Vec2 u -> m ()++++-- | Add operations for branching at the current point.+-- +-- Not all drawings that support tracing support branching. For+-- instance Paths can be built by tracing but they always need +-- a cumulative progression of /next point/ they cannot resrt to +-- the start point and go in a differnt direction.+-- +class CursorM m => BranchCursorM (m :: * -> *) where+  -- | Branch is like @local@ in the Reader monad.+  branchCursor    :: m a -> m a++++--------------------------------------------------------------------------------+-- Derived operations+++-- | Move the /cursor/ horizontally.+--+hmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()+hmoveby dx = moveby (hvec dx)++-- | Move the /cursor/ vertically.+--+vmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()+vmoveby dx = moveby (vvec dx)

@@ -0,0 +1,306 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.Chain+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Chaining moveable LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.Chain+  (+  +    GenChain+  , Chain+  , DChain+  , ChainScheme(..)++  , runGenChain+  , evalGenChain+  , execGenChain+  , stripGenChain++  , runChain+  , runChain_++  , cnext+  , setChainScheme+++  , chainIterate+  , chainH+  , chainV++  , tableRight  +  , tableDown++  , radialChain++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Data.Monoid++++newtype GenChain st u a = GenChain+          { getGenChain :: DrawingContext -> DPoint2 -> ChainSt st u +                        -> (a, DPoint2, ChainSt st u, CatPrim) }+++type instance DUnit (GenChain st u a) = u+type instance UState  (GenChain st u) = st++type Chain u a   = GenChain () u a++type DChain a    = Chain Double a++-- | scheme_start is a function from the origin to state.+-- +-- For instance, we might want to cache the origin - this would+-- not be possible if start was just a pure @cst@ value. +--+data ChainScheme u = forall cst. ChainScheme +      { scheme_start    :: Point2 u -> cst+      , scheme_step     :: Point2 u -> cst -> (Point2 u,cst)+      }++type instance DUnit (ChainScheme u) = u+++data ChainSt st u = forall cst. ChainSt +       { chain_st         :: cst+       , chain_next       :: Point2 u -> cst -> (Point2 u,cst) +       , chain_user_state :: st+       }+++type instance DUnit (ChainSt st u) = u+++-- Functor ++instance Functor (GenChain st u) where+  fmap f ma = GenChain $ \ctx pt s -> +              let (a,p1,s1,w) = getGenChain ma ctx pt s in (f a, p1, s1, w)++++-- Applicative++instance Applicative (GenChain st u) where+  pure a    = GenChain $ \_   pt s -> (a, pt, s, mempty)+  mf <*> ma = GenChain $ \ctx pt s -> +                let (f,p1,s1,w1) = getGenChain mf ctx pt s+                    (a,p2,s2,w2) = getGenChain ma ctx p1 s1+                in (f a, p2, s2, w1 `mappend` w2)++++-- Monad++instance Monad (GenChain st u) where+  return a  = GenChain $ \_   pt s -> (a, pt, s, mempty)+  ma >>= k  = GenChain $ \ctx pt s -> +                let (a,p1,s1,w1) = getGenChain ma ctx pt s+                    (b,p2,s2,w2) = (getGenChain . k) a ctx p1 s1+                in (b, p2, s2, w1 `mappend` w2)+++-- DrawingCtxM++instance DrawingCtxM (GenChain st u) where+  askDC           = GenChain $ \ctx pt s -> (ctx, pt, s, mempty)+  asksDC fn       = GenChain $ \ctx pt s -> (fn ctx, pt, s, mempty)+  localize upd ma = GenChain $ \ctx pt s -> getGenChain ma (upd ctx) pt s++++-- UserStateM ++instance UserStateM (GenChain st u) where+  getState        = GenChain $ \_ pt s@(ChainSt _ _ ust) -> +                      (ust, pt, s, mempty)+  setState ust    = GenChain $ \_ pt (ChainSt a b _) -> +                      ((), pt, ChainSt a b ust, mempty)+  updateState upd = GenChain $ \_ pt (ChainSt a b ust) -> +                      ((), pt, ChainSt a b (upd ust), mempty)+++-- LocationM++instance InterpretUnit u => LocationM (GenChain st u) where+  location = GenChain $ \ctx pt s ->+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) ++++-- Monoid++instance Monoid a => Monoid (GenChain st u a) where+  mempty           = GenChain $ \_   pt s -> (mempty, pt, s, mempty)+  ma `mappend` mb  = GenChain $ \ctx pt s -> +                       let (a,p1,s1,w1) = getGenChain ma ctx pt s+                           (b,p2,s2,w2) = getGenChain mb ctx p1 s1+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)++--------------------------------------------------------------------------------+-- Run functions++runGenChain :: InterpretUnit u +         => GenChain st u a -> ChainScheme u -> st -> LocImage u (a,st)+runGenChain ma (ChainScheme start step) ust = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let st_zero     = ChainSt { chain_st         = start pt+                              , chain_next       = step+                              , chain_user_state = ust }+        dpt         = normalizeF (dc_font_size ctx) pt+        (a,_,s1,w1) = getGenChain ma ctx dpt st_zero+    in replaceAns (a, chain_user_state s1) $ primGraphic w1++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenChain :: InterpretUnit u +             => GenChain st u a -> ChainScheme u -> st -> LocImage u a+evalGenChain ma cscm st = fmap fst $ runGenChain ma cscm st+++-- | Forget the /answer/, just return the user state.+--+execGenChain :: InterpretUnit u +             => GenChain st u a -> ChainScheme u -> st -> LocImage u st +execGenChain ma cscm st = fmap snd $ runGenChain ma cscm st+++stripGenChain :: InterpretUnit u +              => GenChain st u a -> ChainScheme u -> st -> LocQuery u (a,st)+stripGenChain ma cscm st = stripLocImage $ runGenChain ma cscm st ++++runChain :: InterpretUnit u +         => Chain u a -> ChainScheme u -> LocImage u a+runChain ma cscm = evalGenChain ma cscm ()++runChain_ :: InterpretUnit u +          => Chain u a -> ChainScheme u -> LocGraphic u+runChain_ ma cscm = ignoreAns $ runChain ma cscm++++--------------------------------------------------------------------------------+-- Operations++cnext :: InterpretUnit u +      => LocImage u a -> GenChain st u a+cnext gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> +    let dpt       = dinterpF (dc_font_size ctx) pt+        (pt1,st1) = sf dpt s0+        dpt1      = normalizeF (dc_font_size ctx) pt1+        (a,w1)    = runImage (applyLoc gf pt1) ctx+        new_st    = ChainSt { chain_st = st1+                            , chain_next = sf+                            , chain_user_state = ust }+    in (a, dpt1, new_st, w1)+++setChainScheme :: InterpretUnit u +               => ChainScheme u -> GenChain st u ()+setChainScheme (ChainScheme start step) = +    GenChain $ \ctx pt (ChainSt _ _ ust) -> +      let upt     = dinterpF (dc_font_size ctx) pt+          new_st  = ChainSt { chain_st = start upt+                            , chain_next = step+                            , chain_user_state = ust }+      in ((), pt, new_st, mempty) ++++--------------------------------------------------------------------------------+-- Schemes++chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u+chainIterate fn = ChainScheme { scheme_start = const ()+                              , scheme_step  = \pt _ -> (fn pt, ())+                              }+++chainH :: Num u => u -> ChainScheme u+chainH dx = +    ChainScheme { scheme_start = const ()+                , scheme_step  = \pt _ -> (displace (hvec dx) pt, ())+                }+   +chainV :: Num u => u -> ChainScheme u+chainV dy = +    ChainScheme { scheme_start = const ()+                , scheme_step  = \pt _ -> (displace (vvec dy) pt, ())+                }+++++-- | Outer and inner steppers.+--+scStepper :: PointDisplace u -> Int -> PointDisplace u +          -> ChainScheme u+scStepper outF n innF = +    ChainScheme { scheme_start = start, scheme_step = step }+  where+    start pt                      = (pt,0)+    step  pt (ogin,i) | i < n     = (innF pt, (ogin, i+1))+                      | otherwise = let o1 = outF ogin +                                    in (innF o1, (o1,1)) +++tableRight :: Num u => Int -> (u,u) -> ChainScheme u+tableRight num_cols (col_width,row_height) = +    scStepper downF num_cols rightF+  where+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width++tableDown :: Num u => Int -> (u,u) -> ChainScheme u+tableDown num_rows (col_width,row_height) = +    scStepper rightF num_rows downF+  where+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width++++radialChain :: Floating u +            => u -> Radian -> Radian -> ChainScheme u+radialChain radius angstart angi = +    ChainScheme { scheme_start = start, scheme_step = step }+  where+    start pt           = (pt,angstart)+    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))++-- Note - radialChains stepper is oblivious to the previous point...++

@@ -0,0 +1,408 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes                 #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.CtxPicture+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- A Picture-with-implicit-context object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core.+-- +-- Note - many of the composition functions are in +-- /destructor form/. As Wumpus cannot make a Picture from an +-- empty list of Pictures, /destructor form/ decomposes the +-- list into the @head@ and @rest@ as arguments in the function +-- signature, rather than take a possibly empty list and have to +-- throw an error.+-- +-- TODO - PosImage no longer supports composition operators, so +-- better names are up for grabs...+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.CtxPicture+  (++    CtxPicture+  , runCtxPicture+  , runCtxPictureU+  , drawTracing+  , udrawTracing++  , mapCtxPicture++  -- * Composition++  , uniteCenter+  +  , centeredAt++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Drawing.TraceDrawing+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Concat++import Wumpus.Core                              -- package: wumpus-core++import Data.AdditiveGroup                       -- package: vector-space+import Data.AffineSpace++import Data.Monoid++++-- | A /Contextual/ Picture.+-- +-- > CtxPicture = DrawingContext -> Maybe Picture+-- +-- This type corresponds to the 'Picture' type in Wumpus-Core, but+-- it is embedded with a 'DrawingContext' (for font properties, +-- fill colour etc.). The DrawingContext is embedded so that font+-- metrics - loaded in @IO@ can be passed into the pure world of+-- 'TraceDrawing'.+--+-- Internally a /context picture/ is a function from +-- 'DrawingContext' to @(Maybe Picture)@. The @Maybe@ represents+-- that it is possible to construct empty Pictures, even though+-- @Wumpus-Core@ cannot render them. Just as the DrawingContext+-- pushes font-metrics from the IO to the pure world, the Maybe+-- lifts the problem of unrenderable Pictures into the API where+-- client code must deal with it explicitly. +--+-- (In practice, it is very unlikely a program will create empty +-- pictures and @runCtxPictureU@ can be used without worry).+-- +-- +-- Note - pictures are fixed to the unit @Double@ (representing +-- PostScript points). Pictures are intentionally unsophisticated,+-- any fine grained control of units should be delegated to the +-- elements that build the picture (Graphics, LocGraphics, etc.). +--+newtype CtxPicture = CtxPicture { +          getCtxPicture :: DrawingContext -> Maybe Picture }++type instance DUnit CtxPicture = Double+++++-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @+--+-- Run a 'CtxPicture' with the supplied 'DrawingContext' +-- producing a 'Picture'.+--+-- The resulting Picture may be empty. Wumpus-Core cannot +-- generate empty pictures as they have no bounding box, so the +-- result is wrapped within a Maybe. This delegates reponsibility +-- for handling empty pictures to client code.+--+runCtxPicture :: DrawingContext -> CtxPicture -> Maybe Picture+runCtxPicture ctx drw = getCtxPicture drw ctx+++-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @+--+-- /Unsafe/ version of 'runCtxPicture'.+--+-- This function throws a runtime error when supplied with an+-- empty CtxPicture.+--+runCtxPictureU :: DrawingContext -> CtxPicture -> Picture+runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df+  where+    fk = error "runCtxPictureU - empty CtxPicture."   +++-- | 'drawTracing' : @ trace_drawing  -> CtxPicture @+--+-- Transform a 'TraceDrawing' into a 'CtxPicture'.+--+drawTracing :: TraceDrawing u a -> CtxPicture+drawTracing mf = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx++-- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @+--+-- Variant of 'drawTracing' with a phantom first argument - the +-- phantom identifies the unit type of the 'TraceDrawing'. It is +-- not scurtinized at the value level.+--+--+udrawTracing :: u -> TraceDrawing u a -> CtxPicture+udrawTracing _ mf = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx+++-- Note need Gen versions with user state...+++-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @+--+-- Apply a picture transformation function to the 'Picture'+-- warpped in a 'CtxPicture'.+--+mapCtxPicture :: (Picture -> Picture) -> CtxPicture -> CtxPicture+mapCtxPicture pf pic1 = CtxPicture $ \ctx -> fmap pf $ getCtxPicture pic1 ctx+++--------------------------------------------------------------------------------+-- Affine instances+++instance Rotate CtxPicture where +  rotate ang            = mapCtxPicture (rotate ang)++instance RotateAbout CtxPicture where+  rotateAbout ang pt    = mapCtxPicture (rotateAbout ang pt)++instance Scale CtxPicture where+  scale sx sy           = mapCtxPicture (scale sx sy)++instance Translate CtxPicture where+  translate dx dy       = mapCtxPicture (translate dx dy)++++--------------------------------------------------------------------------------+-- Monoid++-- | Avoid initial mempty for mconcat.+--+instance Monoid CtxPicture where+  mempty  = CtxPicture $ \_ -> Nothing+  mappend = moveSnd $ \_ _ -> V2 0 0++  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs+++--------------------------------------------------------------------------------+-- Extract /planes/.+++leftEdge        :: BoundingBox Double -> Double+leftEdge        = point_x . ll_corner++rightEdge       :: BoundingBox Double -> Double+rightEdge       = point_x . ur_corner++bottomEdge      :: BoundingBox Double -> Double+bottomEdge      = point_y . ll_corner+++topEdge         :: BoundingBox Double -> Double+topEdge         = point_y . ur_corner++++++--------------------------------------------------------------------------------+-- Composition operators++-- Naming convention - Wumpus-Core already prefixes operations+-- on Pictures with pic. As the picture operators here work on a+-- different type, they merit a different naming scheme.+--+-- Unfortunately the @cxp_@ prefix is rather ugly...+--+-- Directional names seem better than positional ones (less +-- ambiguous as when used as binary operators).+--++++combineP2 :: (Picture -> Picture -> Picture) +          -> CtxPicture -> CtxPicture -> CtxPicture+combineP2 op mf mg = +    CtxPicture $ \ctx -> fn (getCtxPicture mf ctx) (getCtxPicture mg ctx)+  where+    fn (Just a) (Just b) = Just $ a `op` b+    fn a        Nothing  = a+    fn Nothing  b        = b+++-- Note - the megaCombR operator is in some way an+-- /anti-combinator/. It seems easier to think about composing +-- drawings if we do work on the result Pictures directly rather +-- than build combinators to manipulate CtxPictures.+--+-- The idea of combining pre- and post- operating combinators+-- makes me worry about circular programs even though I know +-- lazy evaluation allows me to write them (in some cicumstances).+--+++moveSnd :: (DBoundingBox -> DBoundingBox -> DVec2) +          -> CtxPicture -> CtxPicture+          -> CtxPicture+moveSnd mkV = combineP2 fn+  where+    fn pl pr = let v1  = mkV (boundary pl) (boundary pr)+               in pl `picOver` (picMoveBy pr v1)+++instance ZConcat CtxPicture where+  superior = mappend+  anterior = flip mappend++--------------------------------------------------------------------------------+-- Composition+++infixr 6 `uniteCenter`+++++-- | Draw @a@, move @b@ so its center is at the same center as +-- @a@, @b@ is drawn over underneath in the zorder.+--+-- > a `cxpUniteCenter` b +--++uniteCenter :: CtxPicture -> CtxPicture -> CtxPicture+uniteCenter = moveSnd $ \a b -> center a .-. center b+--+-- Are combinator names less ambiguous if they name direction+-- rather than position?+--++instance Concat CtxPicture where+  hconcat = cxpRight+  vconcat = cxpBelow+++-- | > a `cxpRight` b+-- +-- Horizontal composition - position picture @b@ to the right of +-- picture @a@.+-- +cxpRight :: CtxPicture -> CtxPicture -> CtxPicture+cxpRight = moveSnd $ \a b -> hvec $ rightEdge a - leftEdge b+++-- | > a `cxpBelow` b+--+-- Vertical composition - position picture @b@ /down/ from picture+-- @a@.+--+cxpBelow :: CtxPicture -> CtxPicture -> CtxPicture+cxpBelow = moveSnd $ \a b -> vvec $ bottomEdge a - topEdge b+++-- | Center the picture at the supplied point.+--+centeredAt :: CtxPicture -> DPoint2 -> CtxPicture+centeredAt pic (P2 x y) = mapCtxPicture fn pic+  where+    fn p = let bb = boundary p+               dx = x - (boundaryWidth  bb * 0.5)+               dy = y - (boundaryHeight bb * 0.5)+           in p `picMoveBy` vec dx dy+++++--------------------------------------------------------------------------------++instance CatSpace CtxPicture where+  hspace = cxpRightSep+  vspace = cxpDownSep+++-- | > cxpRightSep n a b+--+-- Horizontal composition - move @b@, placing it to the right +-- of @a@ with a horizontal gap of @n@ separating the pictures.+--+cxpRightSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpRightSep n = moveSnd $ \a b -> hvec $ n + (rightEdge a - leftEdge b)++++-- | > cxpDownSep n a b+--+-- Vertical composition - move @b@, placing it below @a@ with a+-- vertical gap of @n@ separating the pictures.+--+cxpDownSep :: Double  -> CtxPicture -> CtxPicture -> CtxPicture+cxpDownSep n = moveSnd $ \a b -> vvec $ bottomEdge a - (topEdge b + n)+++--------------------------------------------------------------------------------+-- Aligning pictures+++instance Align CtxPicture where+  halign = cxpAlignH+  valign = cxpAlignV++-- | > cxpAlignH align a b+-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ and align it with the top, center or bottom of @a@.+-- +cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignH HALIGN_TOP     = moveSnd $ \a b -> northeast a .-. northwest b+cxpAlignH HALIGN_CENTER  = moveSnd $ \a b -> east a .-. west b+cxpAlignH HALIGN_BASE    = moveSnd $ \a b -> southeast a .-. southwest b+++-- | > cxpAlignV align a b+-- +-- Vertical composition - move @b@, placing it below @a@ +-- and align it with the left, center or right of @a@.+-- +cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignV VALIGN_LEFT    = moveSnd $ \a b -> southwest a .-. northwest b+cxpAlignV VALIGN_CENTER  = moveSnd $ \a b -> south a .-. north b+cxpAlignV VALIGN_RIGHT   = moveSnd $ \a b -> southeast a .-. northeast b++++instance AlignSpace CtxPicture where+  halignSpace = cxpAlignSpaceH+  valignSpace = cxpAlignSpaceV++-- | > cxpAlignSpaceH align sep a b+-- +-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +cxpAlignSpaceH :: HAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignSpaceH align dx = go align+  where+    mv f g           = moveSnd $ \a b -> hvec dx ^+^ (f a .-. g b)+    go HALIGN_TOP    = mv northeast northwest+    go HALIGN_CENTER = mv east west +    go HALIGN_BASE   = mv southeast southwest+++-- | > cxpAlignSpaceV align sep a b+-- +-- Spacing version of alignV - move @b@ below @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +cxpAlignSpaceV :: VAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignSpaceV align dy = go align+  where+    mv f g           = moveSnd $ \a b -> vvec (-dy) ^+^ (f a .-. g b)+    go VALIGN_LEFT   = mv southwest northwest +    go VALIGN_CENTER = mv south north  +    go VALIGN_RIGHT  = mv southeast northeast +

@@ -0,0 +1,238 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocDrawing+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Drawing monad with immutable start point.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.LocDrawing+  (++  -- * GenLocDrawing monad+    GenLocDrawing+  , LocDrawing++  , LocDrawM(..)++  , runGenLocDrawing+  , evalGenLocDrawing+  , execGenLocDrawing+  , stripGenLocDrawing++  , runLocDrawing+  , runLocDrawing_ ++  )++  where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+import Control.Monad+import Data.Monoid+++++-- | 'GenLocDrawing' is a reader-writer-state monad, unlike +-- 'GenLocTrace' there is no updateable current point, instead +-- the start point is supplied when the drawing is run and it +-- is translated by the components of the start point.+--+-- The writer accumulates a graphical trace.+--+-- Essentially, 'GenLocDrawing' is an 'Image' object extended +-- with user state.+--+newtype GenLocDrawing st u a = GenLocDrawing { +    getGenLocDrawing :: DrawingContext -> st -> (a, st, CatPrim)}++type instance DUnit  (GenLocDrawing st u a) = u+type instance UState (GenLocDrawing st u)   = st++type LocDrawing u a = GenLocDrawing () u a+++-- Functor++instance Functor (GenLocDrawing st u) where+  fmap f ma = GenLocDrawing $ \ctx s -> +    let (a,s1,o) = getGenLocDrawing ma ctx s in (f a, s1, o)+++-- Applicative++instance Applicative (GenLocDrawing st u) where+  pure a    = GenLocDrawing $ \_   s -> (a, s, mempty)+  mf <*> ma = GenLocDrawing $ \ctx s -> +                let (f,s1,o1) = getGenLocDrawing mf ctx s+                    (a,s2,o2) = getGenLocDrawing ma ctx s1+                in (f a, s2, o1 `mappend` o2)++++-- Monad++instance Monad (GenLocDrawing st u) where+  return a  = GenLocDrawing $ \_   s -> (a, s, mempty)+  ma >>= k  = GenLocDrawing $ \ctx s -> +                let (a,s1,o1) = getGenLocDrawing ma ctx s+                    (b,s2,o2) = (getGenLocDrawing . k) a ctx s1+                in (b, s2, o1 `mappend` o2)++++-- DrawingCtxM++instance DrawingCtxM (GenLocDrawing st u) where+  askDC           = GenLocDrawing $ \ctx s -> (ctx, s, mempty)+  asksDC fn       = GenLocDrawing $ \ctx s -> (fn ctx, s, mempty)+  localize upd ma = GenLocDrawing $ \ctx s -> +                      getGenLocDrawing ma (upd ctx) s++++-- UserStateM ++instance UserStateM (GenLocDrawing st u) where+  getState        = GenLocDrawing $ \_ s -> (s, s, mempty)+  setState s      = GenLocDrawing $ \_ _ -> ((), s, mempty)+  updateState upd = GenLocDrawing $ \_ s -> ((), upd s, mempty)+++-- Monoid++instance Monoid a => Monoid (GenLocDrawing st u a) where+  mempty           = GenLocDrawing $ \_   s -> (mempty, s, mempty)+  ma `mappend` mb  = GenLocDrawing $ \ctx s -> +                       let (a,s1,w1) = getGenLocDrawing ma ctx s+                           (b,s2,w2) = getGenLocDrawing mb ctx s1+                       in (a `mappend` b, s2, w1 `mappend` w2)++++--------------------------------------------------------------------------------++class Monad m => LocDrawM (m :: * -> *) where+  inserti   :: u ~ DUnit (m ()) => Image u a -> m a+  inserti_  :: u ~ DUnit (m ()) => Image u a -> m ()+  insertli  :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m a+  insertli_ :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m ()+  insertci  :: u ~ DUnit (m ()) => +               Anchor u -> Anchor u -> ConnectorImage u a -> m a+  insertci_ :: u ~ DUnit (m ()) => +               Anchor u -> Anchor u -> ConnectorImage u a -> m ()++  inserti_  gf       = inserti gf >> return ()+  insertli_ pt gf    = insertli pt gf >> return ()+  insertci_ p1 p2 gf = insertci p1 p2 gf >> return ()+++instance InterpretUnit u => LocDrawM (GenLocDrawing st u) where+  inserti  = insertiImpl+  insertli = insertliImpl+  insertci = insertciImpl++ +--------------------------------------------------------------------------------+-- Run functions+++runGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                 => GenLocDrawing st u a -> st -> LocImage u (a,st)+runGenLocDrawing ma st = promoteLoc $ \(P2 x y) -> +    askDC >>= \ctx ->+    let (a,s1,w1) = getGenLocDrawing ma ctx st+        ans       = translate x y a +        dv1       = normalizeF (dc_font_size ctx) (V2 x y)+    in replaceAns (ans,s1) $ primGraphic $ cpmove dv1 w1+++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                  => GenLocDrawing st u a -> st -> LocImage u a+evalGenLocDrawing ma st = fmap fst $ runGenLocDrawing ma st+++-- | Forget the /answer/, just return the user state.+--+execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                  => GenLocDrawing st u a -> st -> LocImage u st +execGenLocDrawing ma st = fmap snd $ runGenLocDrawing ma st+++stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                   => GenLocDrawing st u a -> st -> LocQuery u (a,st)+stripGenLocDrawing ma st = stripLocImage $ runGenLocDrawing ma st +++-- | Simple version of 'runGenLocDrawing' - run a 'LocDrawing' without+-- user state.+--+runLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +              => LocDrawing u a -> LocImage u a+runLocDrawing ma = evalGenLocDrawing ma ()+++runLocDrawing_ :: (Translate a, InterpretUnit u, u ~ DUnit a) +               => LocDrawing u a -> LocGraphic u +runLocDrawing_ ma = ignoreAns $ runLocDrawing ma++++--------------------------------------------------------------------------------++insertiImpl :: InterpretUnit u +            => Image u a -> GenLocDrawing st u a+insertiImpl gf = GenLocDrawing $ \ctx s -> +    let (a,w1)   = runImage gf ctx in (a,s,w1) ++++++insertliImpl :: InterpretUnit u+             => Anchor u -> LocImage u a -> GenLocDrawing st u a+insertliImpl p1 gf = GenLocDrawing $ \ctx s -> +    let (a,w1) = runLocImage gf ctx p1 in (a,s,w1) ++++-- This is not right - if I\'ve taken an anchor from an object+-- within the relative coord system, the anchor points are already+-- translated respective to the origin. This implementation of +-- @insertci@ adds the translation a second time.+++insertciImpl :: InterpretUnit u +             => Anchor u -> Anchor u -> ConnectorImage u a +             -> GenLocDrawing st u a+insertciImpl p1 p2 gf = GenLocDrawing $ \ctx s -> +    let (a,w1) = runConnectorImage gf ctx p1 p2 in (a,s,w1) 

@@ -0,0 +1,214 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocTrace+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.LocTrace+  (++  -- * GenLocTrace monad+    GenLocTrace+  , LocTrace++  , runGenLocTrace+  , evalGenLocTrace+  , execGenLocTrace+  , stripGenLocTrace++  , runLocTrace+  , runLocTrace_ ++  )++  where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+import Control.Monad+import Data.Monoid+++++-- | GenLocTrace is a reader-writer-state monad.+--+-- The writer accumulates a graphical trace and the state is +-- the current point.+--+newtype GenLocTrace st u a = GenLocTrace { +    getGenLocTrace :: DrawingContext -> DPoint2 -> st +                   -> (a, DPoint2, st, CatPrim)}++type instance DUnit  (GenLocTrace st u a) = u+type instance UState (GenLocTrace st u)   = st++type LocTrace u a = GenLocTrace () u a+++-- Functor++instance Functor (GenLocTrace st u) where+  fmap f ma = GenLocTrace $ \ctx pt s -> +    let (a,p1,s1,o) = getGenLocTrace ma ctx pt s in (f a, p1, s1, o)+++-- Applicative++instance Applicative (GenLocTrace st u) where+  pure a    = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)+  mf <*> ma = GenLocTrace $ \ctx pt s -> +                let (f,p1,s1,o1) = getGenLocTrace mf ctx pt s+                    (a,p2,s2,o2) = getGenLocTrace ma ctx p1 s1+                in (f a, p2, s2, o1 `mappend` o2)++++-- Monad++instance Monad (GenLocTrace st u) where+  return a  = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)+  ma >>= k  = GenLocTrace $ \ctx pt s -> +                let (a,p1,s1,o1) = getGenLocTrace ma ctx pt s+                    (b,p2,s2,o2) = (getGenLocTrace . k) a ctx p1 s1+                in (b, p2, s2, o1 `mappend` o2)++++-- DrawingCtxM++instance DrawingCtxM (GenLocTrace st u) where+  askDC           = GenLocTrace $ \ctx pt s -> (ctx, pt, s, mempty)+  asksDC fn       = GenLocTrace $ \ctx pt s -> (fn ctx, pt, s, mempty)+  localize upd ma = GenLocTrace $ \ctx pt s -> getGenLocTrace ma (upd ctx) pt s++++-- UserStateM ++instance UserStateM (GenLocTrace st u) where+  getState        = GenLocTrace $ \_ pt s -> (s, pt, s, mempty)+  setState s      = GenLocTrace $ \_ pt _ -> ((), pt, s, mempty)+  updateState upd = GenLocTrace $ \_ pt s -> ((), pt, upd s, mempty)+++-- Monoid++instance Monoid a => Monoid (GenLocTrace st u a) where+  mempty           = GenLocTrace $ \_   pt s -> (mempty, pt, s, mempty)+  ma `mappend` mb  = GenLocTrace $ \ctx pt s -> +                       let (a,p1,s1,w1) = getGenLocTrace ma ctx pt s+                           (b,p2,s2,w2) = getGenLocTrace mb ctx p1 s1+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)+++-- LocationM++instance InterpretUnit u => LocationM (GenLocTrace st u) where+  location = GenLocTrace $ \ctx pt s ->+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) +++-- CursorM ++instance InterpretUnit u => InsertlM (GenLocTrace st u) where+  insertl   = insertlImpl++instance InterpretUnit u => CursorM (GenLocTrace st u) where+  moveby    = movebyImpl+++insertlImpl :: InterpretUnit u => LocImage u a -> GenLocTrace st u a+insertlImpl gf = GenLocTrace $ \ctx pt s ->+    let upt    = dinterpF (dc_font_size ctx) pt +        (a,w1) = runLocImage gf ctx upt+    in (a,pt,s,w1) +++movebyImpl :: InterpretUnit u => Vec2 u -> GenLocTrace st u ()+movebyImpl v1 = GenLocTrace $ \ctx pt s ->+    let dv1 = normalizeF (dc_font_size ctx) v1 +    in ((), pt .+^ dv1, s, mempty) ++++-- BranchCursorM ++instance InterpretUnit u => BranchCursorM (GenLocTrace st u) where+  branchCursor ma = GenLocTrace $ \ctx pt s ->+    let (a,_,s1,w1) = getGenLocTrace ma ctx pt s+    in (a, pt, s1, w1)  -- re-instate pt          ++++--------------------------------------------------------------------------------+-- Run functions+++runGenLocTrace :: InterpretUnit u +               => GenLocTrace st u a -> st -> LocImage u (a,st)+runGenLocTrace ma st = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt         = normalizeF (dc_font_size ctx) pt+        (a,_,s1,w1) = getGenLocTrace ma ctx dpt st+    in replaceAns (a,s1) $ primGraphic w1+++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenLocTrace :: InterpretUnit u +                => GenLocTrace st u a -> st -> LocImage u a+evalGenLocTrace ma st = fmap fst $ runGenLocTrace ma st+++-- | Forget the /answer/, just return the user state.+--+execGenLocTrace :: InterpretUnit u +                => GenLocTrace st u a -> st -> LocImage u st +execGenLocTrace ma st = fmap snd $ runGenLocTrace ma st+++stripGenLocTrace :: InterpretUnit u +                 => GenLocTrace st u a -> st -> LocQuery u (a,st)+stripGenLocTrace ma st = stripLocImage $ runGenLocTrace ma st +++-- | Simple version of 'runGenLocTrace' - run a 'LocTrace' without+-- user state.+--+runLocTrace :: InterpretUnit u +            => LocTrace u a -> LocImage u a+runLocTrace ma = evalGenLocTrace ma ()+++runLocTrace_ :: InterpretUnit u +             => LocTrace u a -> LocGraphic u +runLocTrace_ ma = ignoreAns $ runLocTrace ma+

@@ -0,0 +1,411 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.TraceDrawing+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Drawing with /trace/ - a Writer like monad collecting +-- intermediate graphics - and /drawing context/ - a reader monad+-- of attributes - font_face, fill_colour etc.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.TraceDrawing+  (++  -- * Collect primitives (writer-like monad) +    GenTraceDrawing+  , TraceDrawing+  , DTraceDrawing++  , runTraceDrawing+  , execTraceDrawing+  , evalTraceDrawing++  , runGenTraceDrawing+++  , liftToPictureU+  , liftToPictureMb+  , mbPictureU+ +  , trace+  , fontDelta+  , evalQuery++  , draw+  , drawi+  , drawl+  , drawli++  , drawc+  , drawci++  , node+  , nodei+ +  , drawrc+  , drawrci++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Control.Monad+import Data.Monoid+++--------------------------------------------------------------------------------+++++-- Note - TraceDrawing run \once\ - it is supplied with the starting+-- environment (DrawingContext) and returns a Picture.+--+-- Other Wumpus monads (e.g. Turtle) will typically be run inside+-- the TraceDrawing monad as a local effect, rather than built into a +-- transformer stack.+--+++newtype GenTraceDrawing st u a   = GenTraceDrawing { +          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }+++type instance DUnit   (GenTraceDrawing st u a) = u+type instance UState  (GenTraceDrawing st u)   = st++type TraceDrawing u a = GenTraceDrawing () u a++type DTraceDrawing a    = TraceDrawing Double a+++-- Functor++instance Functor (GenTraceDrawing st u) where+  fmap f ma = GenTraceDrawing $ \ctx s -> +                let (a,s1,w1) = getGenTraceDrawing ma ctx s in (f a,s1,w1)+++-- Applicative++instance Applicative (GenTraceDrawing st u) where+  pure a    = GenTraceDrawing $ \_   s -> (a, s, mempty)+  mf <*> ma = GenTraceDrawing $ \ctx s -> +                let (f,s1,w1) = getGenTraceDrawing mf ctx s+                    (a,s2,w2) = getGenTraceDrawing ma ctx s1+                in (f a, s2, w1 `mappend` w2)+++-- Monad++instance Monad (GenTraceDrawing st u) where+  return a  = GenTraceDrawing $ \_   s -> (a, s, mempty)+  ma >>= k  = GenTraceDrawing $ \ctx s -> +                let (a,s1,w1) = getGenTraceDrawing ma ctx s+                    (b,s2,w2) = (getGenTraceDrawing . k) a ctx s1+                in (b,s2,w1 `mappend` w2)+                               ++-- DrawingCtxM++instance DrawingCtxM (GenTraceDrawing st u) where+  askDC           = GenTraceDrawing $ \ctx s -> (ctx, s, mempty)+  asksDC f        = GenTraceDrawing $ \ctx s -> (f ctx, s, mempty)+  localize upd ma = GenTraceDrawing $ \ctx s -> +                      getGenTraceDrawing ma (upd ctx) s+++-- UserStateM ++instance UserStateM (GenTraceDrawing st u) where+  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)+  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)+  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)+ ++++runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)+runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()+  where+    post (a,_,w1) = (a,w1)++++-- | Run the drawing returning only the output it produces, drop+-- any answer from the monadic computation.+--+execTraceDrawing :: TraceDrawing u a -> DrawingContext -> HPrim u+execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx++-- | Run the drawing ignoring the output it produces, return the +-- answer from the monadic computation.+--+-- Note - this useful for testing, generally one would want the +-- opposite behaviour (return the drawing, ignore than the +-- answer).+-- +evalTraceDrawing :: TraceDrawing u a -> DrawingContext -> a+evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx+++runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st +                   -> (a,st,HPrim u)+runGenTraceDrawing = getGenTraceDrawing++++++-- | /Unsafe/ promotion of @HPrim@ to @Picture@.+--+-- If the HPrim is empty, a run-time error is thrown.+-- +liftToPictureU :: HPrim u -> Picture+liftToPictureU hf = +    let prims = hprimToList hf in if null prims then errK else frame prims+  where+    errK = error "toPictureU - empty prims list."++-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.+--+-- If the HPrim is empty, then @Nothing@ is returned.+-- +liftToPictureMb :: HPrim u -> Maybe Picture+liftToPictureMb hf = let prims = hprimToList hf in +    if null prims then Nothing else Just (frame prims)++++-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.+--+-- This is equivalent to:+--+-- > fromMaybe (error "empty") $ pic+--+-- This function is solely a convenience, using it saves one +-- import and a few characters.+--+-- If the supplied value is @Nothing@ a run-time error is thrown.+-- +mbPictureU :: Maybe Picture -> Picture+mbPictureU Nothing  = error "mbPictureU - empty picture."+mbPictureU (Just a) = a++-- Note - need an equivalent to Parsec\`s parseTest that provides+-- a very simple way to run graphics without concern for return +-- type or initial drawing context.++++--------------------------------------------------------------------------------++++-- TraceM +--+-- Note -  @ state `mappend` a @ means the first expression in a +-- monadic drawing is the first element in the output file. It is+-- also \*\* at the back \*\* in the the Z-Order.+--+-- Some control over the Z-Order, possibly by adding /layers/ to +-- the drawing model would be valuable. +-- ++-- | Primitive operation - cf. tell in Reader monad.+--+trace     :: HPrim u -> GenTraceDrawing st u ()+trace a = GenTraceDrawing $ \_ s -> ((), s, a)++++fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a+fontDelta mf = GenTraceDrawing $ \ctx s -> +    let (_,font_attrs) = runQuery textAttr ctx+        (a,s1,w1)      = getGenTraceDrawing mf ctx s+        prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList w1+    in (a, s1, singleH $ prim1 $ prim)++-- Note - this function is in the wrong module....+--+evalQuery :: DrawingCtxM m => Query u a -> m a+evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx++++-- | Draw a Graphic taking the drawing style from the +-- /drawing context/. +--+-- This function is the /forgetful/ version of 'drawi'. +-- Commonly, it is used to draw 'Graphic' objects which +-- have no /answer/.+-- +draw :: Image u a -> GenTraceDrawing st u ()+draw gf = askDC >>= \ctx -> +          let (_,w) = runImage gf ctx +          in trace (singleH w) >> return ()+++++-- | Draw an Image taking the drawing style from the +-- /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawi :: Image u a -> GenTraceDrawing st u a+drawi gf = askDC >>= \ctx -> +           let (a,w) = runImage gf ctx+           in trace (singleH w) >> return a+            +++-- | Draw a LocImage at the supplied Anchor taking the drawing +-- style from the /drawing context/. +--+-- This function is the /forgetful/ version of 'drawli'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +drawl :: InterpretUnit u+      => Anchor u -> LocImage u a -> GenTraceDrawing st u ()+drawl ancr img = drawli ancr img >> return ()++++-- | Draw a LocImage at the supplied Point taking the drawing +-- style from the /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawli :: InterpretUnit u+       => Anchor u -> LocImage u a -> GenTraceDrawing st u a+drawli pt gf = askDC >>= \ctx -> +               let (a,w) = runLocImage gf ctx pt+               in trace (singleH w) >> return a+++-- Design note - having @drawlti@ for LocThetaImage does not seem +-- compelling (at the moment). The thinking is that LocTheta+-- objects should be downcast to Loc objects before drawing. +--+-- Connectors however are be different. +-- +-- PosImages would seem to be the same as LocThetaImages.+--++++-- | Draw a ConnectorGraphic with the supplied Anchors taking the +-- drawing style from the /drawing context/. +--+-- This function is the /forgetful/ version of 'drawci'. +-- Commonly, it is used to draw 'ConnectorGraphic' objects which +-- have no /answer/.+-- +drawc :: InterpretUnit u+      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()+drawc an0 an1 img = drawci an0 an1 img >> return () +++-- | Draw a ConnectorImage with the supplied Points taking the +-- drawing style from the /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawci :: InterpretUnit u +       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a+drawci p0 p1 img = drawi (connect p0 p1 img)+++++++++-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/.+-- +-- This function is the /forgetful/ version of 'nodei'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +node :: ( Fractional u, InterpretUnit u)+     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()+node coord gf = nodei coord gf >> return ()+++-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/.+-- +nodei :: (Fractional u, InterpretUnit u) +      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a+nodei coord gf = askDC >>= \ctx -> +                 position coord >>= \pt ->+                 let (a,w) = runLocImage gf ctx pt+                 in trace (singleH w) >> return a+ +++++-- | Draw a connector between two objects. The projection of the+-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line+-- are the radial points on the objects borders that cross the +-- projected line.+-- +-- This function is the /forgetful/ version of 'drawrci'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +drawrc :: ( Real u, Floating u, InterpretUnit u+          , CenterAnchor a1, RadialAnchor a1+          , CenterAnchor a2, RadialAnchor a2+          , u ~ DUnit a1, u ~ DUnit a2+          ) +       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()+drawrc a b gf = drawrci a b gf >> return ()+++-- | Draw a connector between two objects. The projection of the+-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line+-- are the radial points on the objects borders that cross the +-- projected line.+-- +drawrci :: ( Real u, Floating u, InterpretUnit u+           , CenterAnchor a1, RadialAnchor  a1+           , CenterAnchor a2, RadialAnchor  a2+           , u ~ DUnit a1, u ~ DUnit a2+           ) +        => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a+drawrci a b gf = +    let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)

@@ -56,6 +56,7 @@ import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.WrappedPrimitive import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage  import Wumpus.Core                              -- package: wumpus-core

@@ -23,27 +23,8 @@      PrimResult -  , Image-  , Graphic --  , Query--  , DImage-  , DGraphic--  , runImage-  , runQuery-  , zapQuery--  , primGraphic-  , clipImage-   , UConvert(..)-  , uconvImageF-  , uconvImageZ -  , emptyImage-   , ignoreAns   , replaceAns @@ -57,16 +38,11 @@   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.WrappedPrimitive  import Wumpus.Core                              -- package: wumpus-core  -import Control.Applicative-import Data.Monoid-- type PrimResult u a = (a, CatPrim)  @@ -74,116 +50,6 @@ --------------------------------------------------------------------------------  -newtype Image u a = Image { -          getImage :: DrawingContext -> (a, CatPrim) }--type instance DUnit (Image u a) = u--type Graphic u = Image u (UNil u)----- | Type specialized version of 'Image'.----type DImage a       = Image Double a---- | Type specialized version of 'Graphic'.----type DGraphic       = Graphic Double ---newtype Query u a = Query { -          getQuery :: DrawingContext -> a }--type instance DUnit (Query u a) = u---- Functor--instance Functor (Image u) where-  fmap f ma = Image $ \ctx -> let (a,w1) = getImage ma ctx in (f a, w1)--instance Functor (Query u) where-  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx---- Applicative--instance Applicative (Image u) where-  pure a    = Image $ \_   -> (a,mempty)-  mf <*> ma = Image $ \ctx -> let (f,w1) = getImage mf ctx -                                  (a,w2) = getImage ma ctx-                              in (f a, w1 `mappend` w2)--instance Applicative (Query u) where-  pure a    = Query $ \_   -> a-  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx -                                  a = getQuery ma ctx-                              in f a----- Monad--instance Monad (Image u) where-  return a = Image $ \_   -> (a,mempty)-  ma >>= k = Image $ \ctx -> let (a,w1) = getImage ma ctx -                                 (b,w2) = getImage (k a) ctx-                             in (b,w1 `mappend` w2)---instance Monad (Query u) where-  return a = Query $ \_   -> a-  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx---- Monoid--instance Monoid a => Monoid (Image u a) where-  mempty          = pure mempty-  ma `mappend` mb = Image $ \ctx -> -                      getImage ma ctx `mappend` getImage mb ctx--instance Monoid a => Monoid (Query u a) where-  mempty          = pure mempty-  ma `mappend` mb = Query $ \ctx -> -                      getQuery ma ctx `mappend` getQuery mb ctx----- DrawingCtxM---instance DrawingCtxM (Image u) where-  askDC           = Image $ \ctx -> (ctx, mempty)-  asksDC fn       = Image $ \ctx -> (fn ctx, mempty)-  localize upd ma = Image $ \ctx -> getImage ma (upd ctx)--instance DrawingCtxM (Query u) where-  askDC           = Query $ \ctx -> ctx-  asksDC fn       = Query $ \ctx -> (fn ctx)-  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)---runImage :: Image u a -> DrawingContext -> PrimResult u a-runImage = getImage--runQuery :: Query u a -> DrawingContext -> a-runQuery = getQuery----zapQuery :: Query u a -> Image u a-zapQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a---- | Constructor for Primtive graphics.----primGraphic :: CatPrim -> Graphic u-primGraphic w = Image $ \_ -> (UNil, w)----- | Clip an Image.--- -clipImage :: PrimPath -> Image u a -> Image u a-clipImage pp ma = Image $ \ctx -> -     let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)--- class UConvert (f :: * -> * -> *) where   uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1)           => f u (t u) -> f u1 (t u1)@@ -191,28 +57,7 @@   uconvZ :: (InterpretUnit u, InterpretUnit u1)           => f u a -> f u1 a -instance UConvert Image where-  uconvZ = uconvImageZ-  uconvF = uconvImageF -uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) -            => Image u (t u) -> Image u1 (t u1) -uconvImageF ma = Image $ \ctx -> -    let (a,w) = getImage ma ctx-        a'    = uconvertF (dc_font_size ctx) a-    in (a',w)---uconvImageZ :: (InterpretUnit u, InterpretUnit u1) -            => Image u a -> Image u1 a-uconvImageZ ma = Image $ \ctx -> getImage ma ctx----- | Having /empty/ at the specific 'Image' type is useful.--- -emptyImage :: Monoid a => Image u a-emptyImage = mempty- --------------------------------------------------------------------------------  @@ -254,84 +99,6 @@  aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a aelaborate = elaborate ANTERIOR------- | Decorate Image.----decorateImage :: ZDeco -> Image u a -> Image u z -> Image u a-decorateImage zo ma mb = Image $ \ctx -> -    step zo (getImage ma ctx) (getImage mb ctx)-  where-    step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)-    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)----- | Elaborate Image.----elaborateImage :: ZDeco -> Image u a -> (a -> Image u z) -> Image u a-elaborateImage zo ma k = Image $ \ ctx ->-    let (a,w1) = getImage ma ctx-        (_,w2) = getImage (k a) ctx -    in case zo of-      SUPERIOR -> (a, w1 `mappend` w2)-      ANTERIOR -> (a, w2 `mappend` w1)---obliterateImage :: Image u a -> Image u a-obliterateImage ma = Image $ \ctx -> -    let (a,_) = getImage ma ctx in (a,mempty)-  -hyperlinkImage :: XLink -> Image u a -> Image u a-hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)-  where-    step (a,w) = (a, cpmap (xlinkPrim xl) w)----instance Decorate Image where-  decorate    = decorateImage-  elaborate   = elaborateImage  -  obliterate  = obliterateImage-  hyperlink   = hyperlinkImage-  ------------------------------------------------------------------------------------ Affine instances ---- --- Design Note------ Are PrimW instances needed as Image cannot use them?--- --instance Rotate a => Rotate (Image u a) where-  rotate ang ma = Image $ \ctx -> -      let (a,w) = getImage ma ctx-      in (rotate ang a, rotate ang w)--instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) => -    RotateAbout (Image u a) where-  rotateAbout ang pt ma = Image $ \ctx -> -      let ptu   = uconvertF (dc_font_size ctx) pt-          (a,w) = getImage ma ctx-      in (rotateAbout ang pt a, rotateAbout ang ptu w)---instance Scale a => Scale (Image u a) where-  scale sx sy ma = Image $ \ctx -> -      let (a,w) = getImage ma ctx-      in (scale sx sy a, scale sx sy w)---instance (Translate a, InterpretUnit u, u ~ DUnit a) => -    Translate (Image u a) where-  translate dx dy ma = Image $ \ctx -> -      let sz    = dc_font_size ctx-          ddx   = uconvert1 sz dx-          ddy   = uconvert1 sz dy-          (a,w) = getImage ma ctx-      in (translate dx dy a, translate ddx ddy w)   

@@ -45,6 +45,7 @@ import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage 

@@ -1,267 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE ExistentialQuantification  #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.Chain--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Chaining moveable LocGraphics.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.Chain-  (-  -    GenChain-  , Chain-  , DChain-  , ChainScheme(..)--  , runChain-  , runChain_--  , cnext-  , setChainScheme---  , chainIterate-  , chainH-  , chainV--  , tableRight  -  , tableDown--  , radialChain--  ) where---import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.UserState-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.Displacement-import Wumpus.Basic.Kernel.Objects.LocImage--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative-import Data.Monoid----newtype GenChain st u a = GenChain-          { getGenChain :: DrawingContext -> DPoint2 -> ChainSt st u -                        -> (a, DPoint2, ChainSt st u, CatPrim) }---type instance DUnit (GenChain st u a) = u-type instance UState  (GenChain st u) = st--type Chain u a   = GenChain () u a--type DChain a    = Chain Double a---- | scheme_start is a function from the origin to state.--- --- For instance, we might want to cache the origin - this would--- not be possible if start was just a pure @cst@ value. ----data ChainScheme u = forall cst. ChainScheme -      { scheme_start    :: Point2 u -> cst-      , scheme_step     :: Point2 u -> cst -> (Point2 u,cst)-      }--type instance DUnit (ChainScheme u) = u---data ChainSt st u = forall cst. ChainSt -       { chain_st         :: cst-       , chain_next       :: Point2 u -> cst -> (Point2 u,cst) -       , chain_user_state :: st-       }---type instance DUnit (ChainSt st u) = u----- Functor --instance Functor (GenChain st u) where-  fmap f ma = GenChain $ \ctx pt s -> -              let (a,p1,s1,w) = getGenChain ma ctx pt s in (f a, p1, s1, w)------ Applicative--instance Applicative (GenChain st u) where-  pure a    = GenChain $ \_   pt s -> (a, pt, s, mempty)-  mf <*> ma = GenChain $ \ctx pt s -> -                let (f,p1,s1,w1) = getGenChain mf ctx pt s-                    (a,p2,s2,w2) = getGenChain ma ctx p1 s1-                in (f a, p2, s2, w1 `mappend` w2)------ Monad--instance Monad (GenChain st u) where-  return a  = GenChain $ \_   pt s -> (a, pt, s, mempty)-  ma >>= k  = GenChain $ \ctx pt s -> -                let (a,p1,s1,w1) = getGenChain ma ctx pt s-                    (b,p2,s2,w2) = (getGenChain . k) a ctx p1 s1-                in (b, p2, s2, w1 `mappend` w2)----- DrawingCtxM--instance DrawingCtxM (GenChain st u) where-  askDC           = GenChain $ \ctx pt s -> (ctx, pt, s, mempty)-  asksDC fn       = GenChain $ \ctx pt s -> (fn ctx, pt, s, mempty)-  localize upd ma = GenChain $ \ctx pt s -> getGenChain ma (upd ctx) pt s------ UserStateM --instance UserStateM (GenChain st u) where-  getState        = GenChain $ \_ pt s@(ChainSt _ _ ust) -> -                      (ust, pt, s, mempty)-  setState ust    = GenChain $ \_ pt (ChainSt a b _) -> -                      ((), pt, ChainSt a b ust, mempty)-  updateState upd = GenChain $ \_ pt (ChainSt a b ust) -> -                      ((), pt, ChainSt a b (upd ust), mempty)------ Monoid--instance Monoid a => Monoid (GenChain st u a) where-  mempty           = GenChain $ \_   pt s -> (mempty, pt, s, mempty)-  ma `mappend` mb  = GenChain $ \ctx pt s -> -                       let (a,p1,s1,w1) = getGenChain ma ctx pt s-                           (b,p2,s2,w2) = getGenChain mb ctx p1 s1-                       in (a `mappend` b, p2, s2, w1 `mappend` w2)---runGenChain :: InterpretUnit u -         => GenChain st u a -> ChainScheme u -> st -> LocImage u a-runGenChain ma (ChainScheme start step) ust = promoteLoc $ \pt -> -    askDC >>= \ctx ->-    let st_zero    = ChainSt { chain_st         = start pt-                             , chain_next       = step-                             , chain_user_state = ust }-        dpt        = normalizeF (dc_font_size ctx) pt-        (a,_,_,w1) = getGenChain ma ctx dpt st_zero-    in replaceAns a $ primGraphic w1----runChain :: InterpretUnit u -         => Chain u a -> ChainScheme u -> LocImage u a-runChain ma cscm = runGenChain ma cscm ()--runChain_ :: InterpretUnit u -          => Chain u a -> ChainScheme u -> LocGraphic u-runChain_ ma cscm = ignoreAns $ runChain ma cscm---cnext :: InterpretUnit u -      => LocImage u a -> GenChain st u a-cnext gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> -    let dpt       = dinterpF (dc_font_size ctx) pt-        (pt1,st1) = sf dpt s0-        dpt1      = normalizeF (dc_font_size ctx) pt1-        (a,w1)    = runImage (applyLoc gf pt1) ctx-        new_st    = ChainSt { chain_st = st1-                            , chain_next = sf-                            , chain_user_state = ust }-    in (a, dpt1, new_st, w1)---setChainScheme :: InterpretUnit u -               => ChainScheme u -> GenChain st u ()-setChainScheme (ChainScheme start step) = -    GenChain $ \ctx pt (ChainSt _ _ ust) -> -      let upt     = dinterpF (dc_font_size ctx) pt-          new_st  = ChainSt { chain_st = start upt-                            , chain_next = step-                            , chain_user_state = ust }-      in ((), pt, new_st, mempty) --------------------------------------------------------------------------------------- Schemes--chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u-chainIterate fn = ChainScheme { scheme_start = const ()-                              , scheme_step  = \pt _ -> (fn pt, ())-                              }---chainH :: Num u => u -> ChainScheme u-chainH dx = -    ChainScheme { scheme_start = const ()-                , scheme_step  = \pt _ -> (displace (hvec dx) pt, ())-                }-   -chainV :: Num u => u -> ChainScheme u-chainV dy = -    ChainScheme { scheme_start = const ()-                , scheme_step  = \pt _ -> (displace (vvec dy) pt, ())-                }------- | Outer and inner steppers.----scStepper :: PointDisplace u -> Int -> PointDisplace u -          -> ChainScheme u-scStepper outF n innF = -    ChainScheme { scheme_start = start, scheme_step = step }-  where-    start pt                      = (pt,0)-    step  pt (ogin,i) | i < n     = (innF pt, (ogin, i+1))-                      | otherwise = let o1 = outF ogin -                                    in (innF o1, (o1,1)) ---tableRight :: Num u => Int -> (u,u) -> ChainScheme u-tableRight num_cols (col_width,row_height) = -    scStepper downF num_cols rightF-  where-    downF   = displace $ vvec $ negate row_height-    rightF  = displace $ hvec col_width--tableDown :: Num u => Int -> (u,u) -> ChainScheme u-tableDown num_rows (col_width,row_height) = -    scStepper rightF num_rows downF-  where-    downF   = displace $ vvec $ negate row_height-    rightF  = displace $ hvec col_width----radialChain :: Floating u -            => u -> Radian -> Radian -> ChainScheme u-radialChain radius angstart angi = -    ChainScheme { scheme_start = start, scheme_step = step }-  where-    start pt           = (pt,angstart)-    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))---- Note - radialChains stepper is oblivious to the previous point...--

@@ -31,11 +31,14 @@    , runConnectorQuery    , connect +   , stripConnectorImage+   , liftConnectorQuery+    , promoteConn    , applyConn+    , qpromoteConn    , qapplyConn-   , zapConnectorQuery     , emptyConnectorImage @@ -47,6 +50,7 @@ import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image  import Wumpus.Core                              -- package: wumpus-core @@ -77,7 +81,7 @@   newtype ConnectorQuery u a = ConnectorQuery { -          getConnectorQuery :: Point2 u -> Point2 u -> Query u a }+          getConnectorQuery :: DPoint2 -> DPoint2 -> Query u a }   -- Functor @@ -173,55 +177,71 @@                   => ConnectorImage u a -> DrawingContext                    -> Point2 u -> Point2 u                   -> PrimResult u a-runConnectorImage ma ctx p0 p1= +runConnectorImage ma ctx p0 p1 =      let dp0 = normalizeF (dc_font_size ctx) p0         dp1 = normalizeF (dc_font_size ctx) p1      in runImage (getConnectorImage ma dp0 dp1) ctx  -runConnectorQuery :: ConnectorQuery u a -> DrawingContext +runConnectorQuery :: InterpretUnit u +                  => ConnectorQuery u a -> DrawingContext                    -> Point2 u -> Point2 u                    -> a-runConnectorQuery ma ctx p0 p1 = runQuery (getConnectorQuery ma p0 p1) ctx+runConnectorQuery ma ctx p0 p1 = +    let dp0 = normalizeF (dc_font_size ctx) p0+        dp1 = normalizeF (dc_font_size ctx) p1 +    in runQuery (getConnectorQuery ma dp0 dp1) ctx   connect :: InterpretUnit u          => Point2 u -> Point2 u -> ConnectorImage u a -> Image u a-connect p0 p1 mf = -    zapQuery (normalizeCtxF p0) >>= \dp0 -> -    zapQuery (normalizeCtxF p1) >>= \dp1 -> -    getConnectorImage mf dp0 dp1+connect p0 p1 ma = normalizeCtxF p0 >>= \dp0 -> +                   normalizeCtxF p1 >>= \dp1 -> +                   getConnectorImage ma dp0 dp1  +stripConnectorImage :: ConnectorImage u a -> ConnectorQuery u a+stripConnectorImage ma = ConnectorQuery $ \p1 p2 -> +    stripImage $ getConnectorImage ma p1 p2  +liftConnectorQuery :: ConnectorQuery u a -> ConnectorImage u a+liftConnectorQuery ma = ConnectorImage $ \p1 p2 -> +    liftQuery $ getConnectorQuery ma p1 p2++ promoteConn :: InterpretUnit u              => (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a promoteConn k = ConnectorImage $ \p0 p1 ->-    dinterpCtxF p0 >>= \up0 -> dinterpCtxF p1 >>= \up1 -> k up0 up1+    dinterpCtxF p0 >>= \up0 -> +    dinterpCtxF p1 >>= \up1 -> +    k up0 up1  applyConn :: InterpretUnit u            => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a-applyConn mf p0 p1 = -    zapQuery (normalizeCtxF p0) >>= \dp0 -> -    zapQuery (normalizeCtxF p1) >>= \dp1 -> -    getConnectorImage mf dp0 dp1+applyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> +                     normalizeCtxF p1 >>= \dp1 -> +                     getConnectorImage ma dp0 dp1  -qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a-qpromoteConn fn      = ConnectorQuery $ \p0 p1 -> fn p0 p1 -qapplyConn :: ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a-qapplyConn mf p0 p1   = getConnectorQuery mf p0 p1 +qpromoteConn :: InterpretUnit u +             => (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a+qpromoteConn k = ConnectorQuery $ \p0 p1 ->+    dinterpCtxF p0 >>= \up0 -> +    dinterpCtxF p1 >>= \up1 -> +    k up0 up1 --- | \"zero-apply\" a Connector.----zapConnectorQuery :: ConnectorQuery u a -> Point2 u -> Point2 u -> Image u a-zapConnectorQuery ma p0 p1  = askDC >>= \ctx -> -    let a = runConnectorQuery ma ctx p0 p1 in return a+qapplyConn :: InterpretUnit u+           => ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a+qapplyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> +                      normalizeCtxF p1 >>= \dp1 -> +                      getConnectorQuery ma dp0 dp1  +--------------------------------------------------------------------------------+-- UConvert instance  instance UConvert ConnectorImage where   uconvF = uconvConnectorImageF

@@ -1,408 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE RankNTypes                 #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ A Picture-with-implicit-context object. --- --- This is the corresponding type to Picture in the Wumpus-Core.--- --- Note - many of the composition functions are in --- /destructor form/. As Wumpus cannot make a Picture from an --- empty list of Pictures, /destructor form/ decomposes the --- list into the @head@ and @rest@ as arguments in the function --- signature, rather than take a possibly empty list and have to --- throw an error.--- --- TODO - PosImage no longer supports composition operators, so --- better names are up for grabs...--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.CtxPicture-  (--    CtxPicture-  , runCtxPicture-  , runCtxPictureU-  , drawTracing-  , udrawTracing--  , mapCtxPicture--  -- * Composition--  , uniteCenter-  -  , centeredAt--  ) where--import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Objects.Anchors-import Wumpus.Basic.Kernel.Objects.Concat-import Wumpus.Basic.Kernel.Objects.TraceDrawing--import Wumpus.Core                              -- package: wumpus-core--import Data.AdditiveGroup                       -- package: vector-space-import Data.AffineSpace--import Data.Monoid------ | A /Contextual/ Picture.--- --- > CtxPicture = DrawingContext -> Maybe Picture--- --- This type corresponds to the 'Picture' type in Wumpus-Core, but--- it is embedded with a 'DrawingContext' (for font properties, --- fill colour etc.). The DrawingContext is embedded so that font--- metrics - loaded in @IO@ can be passed into the pure world of--- 'TraceDrawing'.------ Internally a /context picture/ is a function from --- 'DrawingContext' to @(Maybe Picture)@. The @Maybe@ represents--- that it is possible to construct empty Pictures, even though--- @Wumpus-Core@ cannot render them. Just as the DrawingContext--- pushes font-metrics from the IO to the pure world, the Maybe--- lifts the problem of unrenderable Pictures into the API where--- client code must deal with it explicitly. ------ (In practice, it is very unlikely a program will create empty --- pictures and @runCtxPictureU@ can be used without worry).--- --- --- Note - pictures are fixed to the unit @Double@ (representing --- PostScript points). Pictures are intentionally unsophisticated,--- any fine grained control of units should be delegated to the --- elements that build the picture (Graphics, LocGraphics, etc.). ----newtype CtxPicture = CtxPicture { -          getCtxPicture :: DrawingContext -> Maybe Picture }--type instance DUnit CtxPicture = Double------- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @------ Run a 'CtxPicture' with the supplied 'DrawingContext' --- producing a 'Picture'.------ The resulting Picture may be empty. Wumpus-Core cannot --- generate empty pictures as they have no bounding box, so the --- result is wrapped within a Maybe. This delegates reponsibility --- for handling empty pictures to client code.----runCtxPicture :: DrawingContext -> CtxPicture -> Maybe Picture-runCtxPicture ctx drw = getCtxPicture drw ctx----- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @------ /Unsafe/ version of 'runCtxPicture'.------ This function throws a runtime error when supplied with an--- empty CtxPicture.----runCtxPictureU :: DrawingContext -> CtxPicture -> Picture-runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df-  where-    fk = error "runCtxPictureU - empty CtxPicture."   ----- | 'drawTracing' : @ trace_drawing  -> CtxPicture @------ Transform a 'TraceDrawing' into a 'CtxPicture'.----drawTracing :: TraceDrawing u a -> CtxPicture-drawTracing mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx---- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @------ Variant of 'drawTracing' with a phantom first argument - the --- phantom identifies the unit type of the 'TraceDrawing'. It is --- not scurtinized at the value level.-------udrawTracing :: u -> TraceDrawing u a -> CtxPicture-udrawTracing _ mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx----- Note need Gen versions with user state...----- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @------ Apply a picture transformation function to the 'Picture'--- warpped in a 'CtxPicture'.----mapCtxPicture :: (Picture -> Picture) -> CtxPicture -> CtxPicture-mapCtxPicture pf pic1 = CtxPicture $ \ctx -> fmap pf $ getCtxPicture pic1 ctx-------------------------------------------------------------------------------------- Affine instances---instance Rotate CtxPicture where -  rotate ang            = mapCtxPicture (rotate ang)--instance RotateAbout CtxPicture where-  rotateAbout ang pt    = mapCtxPicture (rotateAbout ang pt)--instance Scale CtxPicture where-  scale sx sy           = mapCtxPicture (scale sx sy)--instance Translate CtxPicture where-  translate dx dy       = mapCtxPicture (translate dx dy)--------------------------------------------------------------------------------------- Monoid---- | Avoid initial mempty for mconcat.----instance Monoid CtxPicture where-  mempty  = CtxPicture $ \_ -> Nothing-  mappend = moveSnd $ \_ _ -> V2 0 0--  mconcat []      = mempty-  mconcat (a:as)  = step a as-    where-      step ac []     = ac-      step ac (x:xs) = step (ac `mappend` x) xs-------------------------------------------------------------------------------------- Extract /planes/.---leftEdge        :: BoundingBox Double -> Double-leftEdge        = point_x . ll_corner--rightEdge       :: BoundingBox Double -> Double-rightEdge       = point_x . ur_corner--bottomEdge      :: BoundingBox Double -> Double-bottomEdge      = point_y . ll_corner---topEdge         :: BoundingBox Double -> Double-topEdge         = point_y . ur_corner----------------------------------------------------------------------------------------- Composition operators---- Naming convention - Wumpus-Core already prefixes operations--- on Pictures with pic. As the picture operators here work on a--- different type, they merit a different naming scheme.------ Unfortunately the @cxp_@ prefix is rather ugly...------ Directional names seem better than positional ones (less --- ambiguous as when used as binary operators).-------combineP2 :: (Picture -> Picture -> Picture) -          -> CtxPicture -> CtxPicture -> CtxPicture-combineP2 op mf mg = -    CtxPicture $ \ctx -> fn (getCtxPicture mf ctx) (getCtxPicture mg ctx)-  where-    fn (Just a) (Just b) = Just $ a `op` b-    fn a        Nothing  = a-    fn Nothing  b        = b----- Note - the megaCombR operator is in some way an--- /anti-combinator/. It seems easier to think about composing --- drawings if we do work on the result Pictures directly rather --- than build combinators to manipulate CtxPictures.------ The idea of combining pre- and post- operating combinators--- makes me worry about circular programs even though I know --- lazy evaluation allows me to write them (in some cicumstances).------moveSnd :: (DBoundingBox -> DBoundingBox -> DVec2) -          -> CtxPicture -> CtxPicture-          -> CtxPicture-moveSnd mkV = combineP2 fn-  where-    fn pl pr = let v1  = mkV (boundary pl) (boundary pr)-               in pl `picOver` (picMoveBy pr v1)---instance ZConcat CtxPicture where-  superior = mappend-  anterior = flip mappend------------------------------------------------------------------------------------- Composition---infixr 6 `uniteCenter`------- | Draw @a@, move @b@ so its center is at the same center as --- @a@, @b@ is drawn over underneath in the zorder.------ > a `cxpUniteCenter` b -----uniteCenter :: CtxPicture -> CtxPicture -> CtxPicture-uniteCenter = moveSnd $ \a b -> center a .-. center b------ Are combinator names less ambiguous if they name direction--- rather than position?-----instance Concat CtxPicture where-  hconcat = cxpRight-  vconcat = cxpBelow----- | > a `cxpRight` b--- --- Horizontal composition - position picture @b@ to the right of --- picture @a@.--- -cxpRight :: CtxPicture -> CtxPicture -> CtxPicture-cxpRight = moveSnd $ \a b -> hvec $ rightEdge a - leftEdge b----- | > a `cxpBelow` b------ Vertical composition - position picture @b@ /down/ from picture--- @a@.----cxpBelow :: CtxPicture -> CtxPicture -> CtxPicture-cxpBelow = moveSnd $ \a b -> vvec $ bottomEdge a - topEdge b----- | Center the picture at the supplied point.----centeredAt :: CtxPicture -> DPoint2 -> CtxPicture-centeredAt pic (P2 x y) = mapCtxPicture fn pic-  where-    fn p = let bb = boundary p-               dx = x - (boundaryWidth  bb * 0.5)-               dy = y - (boundaryHeight bb * 0.5)-           in p `picMoveBy` vec dx dy---------------------------------------------------------------------------------------instance CatSpace CtxPicture where-  hspace = cxpRightSep-  vspace = cxpDownSep----- | > cxpRightSep n a b------ Horizontal composition - move @b@, placing it to the right --- of @a@ with a horizontal gap of @n@ separating the pictures.----cxpRightSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture-cxpRightSep n = moveSnd $ \a b -> hvec $ n + (rightEdge a - leftEdge b)------ | > cxpDownSep n a b------ Vertical composition - move @b@, placing it below @a@ with a--- vertical gap of @n@ separating the pictures.----cxpDownSep :: Double  -> CtxPicture -> CtxPicture -> CtxPicture-cxpDownSep n = moveSnd $ \a b -> vvec $ bottomEdge a - (topEdge b + n)-------------------------------------------------------------------------------------- Aligning pictures---instance Align CtxPicture where-  halign = cxpAlignH-  valign = cxpAlignV---- | > cxpAlignH align a b--- --- Horizontal composition - move @b@, placing it to the right --- of @a@ and align it with the top, center or bottom of @a@.--- -cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignH HALIGN_TOP     = moveSnd $ \a b -> northeast a .-. northwest b-cxpAlignH HALIGN_CENTER  = moveSnd $ \a b -> east a .-. west b-cxpAlignH HALIGN_BASE    = moveSnd $ \a b -> southeast a .-. southwest b----- | > cxpAlignV align a b--- --- Vertical composition - move @b@, placing it below @a@ --- and align it with the left, center or right of @a@.--- -cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignV VALIGN_LEFT    = moveSnd $ \a b -> southwest a .-. northwest b-cxpAlignV VALIGN_CENTER  = moveSnd $ \a b -> south a .-. north b-cxpAlignV VALIGN_RIGHT   = moveSnd $ \a b -> southeast a .-. northeast b----instance AlignSpace CtxPicture where-  halignSpace = cxpAlignSpaceH-  valignSpace = cxpAlignSpaceV---- | > cxpAlignSpaceH align sep a b--- --- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ --- separated by @sep@ units, align @b@ according to @align@.--- -cxpAlignSpaceH :: HAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignSpaceH align dx = go align-  where-    mv f g           = moveSnd $ \a b -> hvec dx ^+^ (f a .-. g b)-    go HALIGN_TOP    = mv northeast northwest-    go HALIGN_CENTER = mv east west -    go HALIGN_BASE   = mv southeast southwest----- | > cxpAlignSpaceV align sep a b--- --- Spacing version of alignV - move @b@ below @a@ --- separated by @sep@ units, align @b@ according to @align@.--- -cxpAlignSpaceV :: VAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignSpaceV align dy = go align-  where-    mv f g           = moveSnd $ \a b -> vvec (-dy) ^+^ (f a .-. g b)-    go VALIGN_LEFT   = mv southwest northwest -    go VALIGN_CENTER = mv south north  -    go VALIGN_RIGHT  = mv southeast northeast -

@@ -67,8 +67,8 @@ import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage @@ -331,8 +331,7 @@ -- hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u hkernLine ks = promoteLoc $ \pt -> -               normalizeCtxF pt >>= \dpt -> -               zapQuery (uconvKernChar ks) >>= body dpt+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt   where     body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans pt) @@ -351,8 +350,7 @@ -- vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u vkernLine ks = promoteLoc $ \pt -> -               normalizeCtxF pt >>= \dpt -> -               zapQuery (uconvKernChar ks) >>= body dpt+    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt   where     body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt) @@ -368,7 +366,7 @@ -- from the implicit 'DrawingContext'. --  straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u-straightLine p1 p2 = zapQuery (vertexPP [p1,p2]) >>= dcOpenPath+straightLine p1 p2 = liftQuery (vertexPP [p1,p2]) >>= dcOpenPath   -- | 'locStraightLine' : @ vec_to -> LocGraphic @ @@ -384,7 +382,8 @@ -- from the implicit 'DrawingContext'. --  locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u-locStraightLine v = promoteLoc $ \pt -> zapLocQuery (locPP [v]) pt >>= dcOpenPath+locStraightLine v = promoteLoc $ \pt -> +    liftQuery (qapplyLoc (locPP [v]) pt) >>= dcOpenPath   @@ -399,8 +398,7 @@ --  curvedLine :: InterpretUnit u            => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u-curvedLine p0 p1 p2 p3 = -    zapQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath+curvedLine p0 p1 p2 p3 = liftQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath   @@ -415,7 +413,7 @@ --  straightConnector :: InterpretUnit u => ConnectorGraphic u straightConnector = promoteConn $ \p0 p1 -> -    zapQuery (vertexPP [p0,p1]) >>= dcOpenPath+    liftQuery (vertexPP [p0,p1]) >>= dcOpenPath   @@ -441,7 +439,7 @@ --  dcCircle :: InterpretUnit u => DrawStyle -> u -> LocGraphic u dcCircle style r = promoteLoc $ \pt -> -    zapLocQuery (circlePath r) pt >>= dcClosedPath style+    liftQuery (qapplyLoc (circlePath r) pt) >>= dcClosedPath style   @@ -477,7 +475,7 @@ --  dcEllipse :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u dcEllipse style rx ry = promoteLoc $ \pt ->-   zapLocQuery (ellipsePath rx ry) pt >>= dcClosedPath style +   liftQuery (qapplyLoc (ellipsePath rx ry) pt) >>= dcClosedPath style    -- | 'dcREllipse' : @ x_radius * y_radius -> LocGraphic @@@ -492,7 +490,8 @@ dcREllipse :: InterpretUnit u            => DrawStyle -> u -> u -> LocThetaGraphic u dcREllipse style rx ry = promoteLocTheta $ \pt ang -> -    zapLocThetaQuery (rellipsePath rx ry) pt ang >>= dcClosedPath style+    liftQuery (qapplyLocTheta (rellipsePath rx ry) pt ang) >>= +    dcClosedPath style   -- Note - clipping needs some higher level path object than is defined here.@@ -518,7 +517,7 @@ --  dcRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u dcRectangle style w h = promoteLoc $ \pt -> -    zapLocQuery (rectanglePath w h) pt >>= dcClosedPath style+    liftQuery (qapplyLoc (rectanglePath w h) pt) >>= dcClosedPath style   ---------------------------------------------------------------------------

@@ -0,0 +1,283 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Image+-- 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.Image+  (+++    Image+  , Graphic ++  , Query++  , DImage+  , DGraphic++  , runImage+  , runQuery++  , stripImage+  , liftQuery++  , emptyImage+  , primGraphic+  , clipImage+++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Objects.Basis++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+import Data.Monoid++--------------------------------------------------------------------------------+++newtype Image u a = Image { +          getImage :: DrawingContext -> (a, CatPrim) }++type instance DUnit (Image u a) = u++type Graphic u = Image u (UNil u)+++-- | Type specialized version of 'Image'.+--+type DImage a       = Image Double a++-- | Type specialized version of 'Graphic'.+--+type DGraphic       = Graphic Double +++newtype Query u a = Query { +          getQuery :: DrawingContext -> a }++type instance DUnit (Query u a) = u++-- Functor++instance Functor (Image u) where+  fmap f ma = Image $ \ctx -> let (a,w1) = getImage ma ctx in (f a, w1)++instance Functor (Query u) where+  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx++-- Applicative++instance Applicative (Image u) where+  pure a    = Image $ \_   -> (a,mempty)+  mf <*> ma = Image $ \ctx -> let (f,w1) = getImage mf ctx +                                  (a,w2) = getImage ma ctx+                              in (f a, w1 `mappend` w2)++instance Applicative (Query u) where+  pure a    = Query $ \_   -> a+  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx +                                  a = getQuery ma ctx+                              in f a+++-- Monad++instance Monad (Image u) where+  return a = Image $ \_   -> (a,mempty)+  ma >>= k = Image $ \ctx -> let (a,w1) = getImage ma ctx +                                 (b,w2) = getImage (k a) ctx+                             in (b,w1 `mappend` w2)+++instance Monad (Query u) where+  return a = Query $ \_   -> a+  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx++-- Monoid++instance Monoid a => Monoid (Image u a) where+  mempty          = pure mempty+  ma `mappend` mb = Image $ \ctx -> +                      getImage ma ctx `mappend` getImage mb ctx++instance Monoid a => Monoid (Query u a) where+  mempty          = pure mempty+  ma `mappend` mb = Query $ \ctx -> +                      getQuery ma ctx `mappend` getQuery mb ctx+++-- DrawingCtxM+++instance DrawingCtxM (Image u) where+  askDC           = Image $ \ctx -> (ctx, mempty)+  asksDC fn       = Image $ \ctx -> (fn ctx, mempty)+  localize upd ma = Image $ \ctx -> getImage ma (upd ctx)++instance DrawingCtxM (Query u) where+  askDC           = Query $ \ctx -> ctx+  asksDC fn       = Query $ \ctx -> (fn ctx)+  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)+++runImage :: Image u a -> DrawingContext -> PrimResult u a+runImage = getImage++runQuery :: Query u a -> DrawingContext -> a+runQuery = getQuery++++-- | Strip the graphic content from an 'Image' making a 'Query'.+-- +stripImage :: Image u a -> Query u a+stripImage ma = Query $ \ctx -> fst $ getImage ma ctx+++-- | Turn a 'Query' into an 'Image' without graphic content.+--+liftQuery :: Query u a -> Image u a+liftQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a++++-- | Constructor for Primtive graphics.+--+primGraphic :: CatPrim -> Graphic u+primGraphic w = Image $ \_ -> (UNil, w)+++-- | Clip an Image.+-- +clipImage :: PrimPath -> Image u a -> Image u a+clipImage pp ma = Image $ \ctx -> +     let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)++++instance UConvert Image where+  uconvZ = uconvImageZ+  uconvF = uconvImageF++uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) +            => Image u (t u) -> Image u1 (t u1) +uconvImageF ma = Image $ \ctx -> +    let (a,w) = getImage ma ctx+        a'    = uconvertF (dc_font_size ctx) a+    in (a',w)+++uconvImageZ :: (InterpretUnit u, InterpretUnit u1) +            => Image u a -> Image u1 a+uconvImageZ ma = Image $ \ctx -> getImage ma ctx+++-- | Having /empty/ at the specific 'Image' type is useful.+-- +emptyImage :: Monoid a => Image u a+emptyImage = mempty++--------------------------------------------------------------------------------+++instance Decorate Image where+  decorate    = decorateImage+  elaborate   = elaborateImage  +  obliterate  = obliterateImage+  hyperlink   = hyperlinkImage+  +++-- | Decorate Image.+--+decorateImage :: ZDeco -> Image u a -> Image u z -> Image u a+decorateImage zo ma mb = Image $ \ctx -> +    step zo (getImage ma ctx) (getImage mb ctx)+  where+    step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)+    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)+++-- | Elaborate Image.+--+elaborateImage :: ZDeco -> Image u a -> (a -> Image u z) -> Image u a+elaborateImage zo ma k = Image $ \ ctx ->+    let (a,w1) = getImage ma ctx+        (_,w2) = getImage (k a) ctx +    in case zo of+      SUPERIOR -> (a, w1 `mappend` w2)+      ANTERIOR -> (a, w2 `mappend` w1)+++obliterateImage :: Image u a -> Image u a+obliterateImage ma = Image $ \ctx -> +    let (a,_) = getImage ma ctx in (a,mempty)+  +hyperlinkImage :: XLink -> Image u a -> Image u a+hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (xlinkPrim xl) w)+++--------------------------------------------------------------------------------+-- Affine instances ++-- +-- Design Note+--+-- Are PrimW instances needed as Image cannot use them?+-- ++instance Rotate a => Rotate (Image u a) where+  rotate ang ma = Image $ \ctx -> +      let (a,w) = getImage ma ctx+      in (rotate ang a, rotate ang w)++instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) => +    RotateAbout (Image u a) where+  rotateAbout ang pt ma = Image $ \ctx -> +      let ptu   = uconvertF (dc_font_size ctx) pt+          (a,w) = getImage ma ctx+      in (rotateAbout ang pt a, rotateAbout ang ptu w)+++instance Scale a => Scale (Image u a) where+  scale sx sy ma = Image $ \ctx -> +      let (a,w) = getImage ma ctx+      in (scale sx sy a, scale sx sy w)+++instance (Translate a, InterpretUnit u, u ~ DUnit a) => +    Translate (Image u a) where+  translate dx dy ma = Image $ \ctx -> +      let sz    = dc_font_size ctx+          ddx   = uconvert1 sz dx+          ddy   = uconvert1 sz dy+          (a,w) = getImage ma ctx+      in (translate dx dy a, translate ddx ddy w)++++

@@ -30,12 +30,13 @@    , runLocImage    , runLocQuery +   , stripLocImage+   , liftLocQuery+    , promoteLoc    , applyLoc    , qpromoteLoc    , qapplyLoc-   , zapLocQuery-   , extrLoc     , emptyLocImage @@ -60,6 +61,7 @@ import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image   import Wumpus.Core                              -- package: wumpus-core@@ -93,7 +95,7 @@ type DLocGraphic        = LocGraphic Double   newtype LocQuery u a = LocQuery { -          getLocQuery :: Point2 u -> Query u a }+          getLocQuery :: DPoint2 -> Query u a }  -- Functor @@ -175,93 +177,71 @@     let dpt = normalizeF (dc_font_size ctx) pt      in runImage (getLocImage ma dpt) ctx -runLocQuery :: LocQuery u a -> DrawingContext -> Point2 u -> a-runLocQuery ma ctx pt = runQuery (getLocQuery ma pt) ctx+runLocQuery :: InterpretUnit u +            => LocQuery u a -> DrawingContext -> Point2 u -> a+runLocQuery ma ctx pt = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runQuery (getLocQuery ma dpt) ctx  +stripLocImage :: LocImage u a -> LocQuery u a+stripLocImage ma = LocQuery $ \pt -> +    stripImage $ getLocImage ma pt -promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a-promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= \upt -> k upt -applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a-applyLoc mq pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mq dpt+liftLocQuery :: LocQuery u a -> LocImage u a+liftLocQuery ma = LocImage $ \pt -> +    liftQuery $ getLocQuery ma pt  -qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a-qpromoteLoc k = LocQuery $ \pt -> k pt+promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= k  -qapplyLoc :: LocQuery u a -> Point2 u -> Query u a-qapplyLoc mq pt = getLocQuery mq pt+applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a+applyLoc ma pt = normalizeCtxF pt >>= getLocImage ma  --- | Design Note - the set of combinators to shift between Images --- and Queries needs sorting out - @zapLocQuery@ probably has the --- wrong type signature - show be LocQuery to LocImage.-----extrLoc :: InterpretUnit u => LocImage u a -> LocQuery u a-extrLoc ma = LocQuery $ \pt ->-     askDC >>= \ctx -> -     let (a,_) = runLocImage ma ctx pt-     in return a-     ---- qapplyLoc :: LocQuery u a -> Point2 u -> Query u a--- qapplyLoc mq pt = getLocQuery mq pt+qpromoteLoc :: InterpretUnit u +            => (Point2 u -> Query u a) -> LocQuery u a+qpromoteLoc k = LocQuery $ \pt -> dinterpCtxF pt >>= k --- | \"zero-apply\" a LocQuery.----zapLocQuery :: LocQuery u a -> Point2 u -> Image u a-zapLocQuery ma pt = askDC >>= \ctx -> -                    let a = runLocQuery ma ctx pt in return a+qapplyLoc :: InterpretUnit u+          => LocQuery u a -> Point2 u -> Query u a+qapplyLoc ma pt = normalizeCtxF pt >>= getLocQuery ma   --- Maybe there is need for a function line qapplyLoc of this type:------ > blankLoc :: LocQuery u a -> Point2 u -> Image u a--- --- This then means we can have monadic bind back for the notation:------ > qapplyLocTheta (rellipsePath rx ry) pt ang  `bindQ` dcClosedPath style--- --- becomes------ > blankLoc (rellipsePath rx ry) pt ang >>= dcClosedPath style-- -------------------------------------------------------------------------------- -- Affine instances  instance (Real u, Floating u, InterpretUnit u, Rotate a) =>      Rotate (LocImage u a) where   rotate ang ma = promoteLoc $ \pt -> -                     zapQuery (normalizeCtxF pt) >>= \dpt ->  -                     fmap (rotate ang) $ getLocImage ma (rotate ang dpt)+      normalizeCtxF pt >>= \dpt ->  +      fmap (rotate ang) $ getLocImage ma (rotate ang dpt)   instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) =>      RotateAbout (LocImage u a) where   rotateAbout ang pt ma = promoteLoc $ \p0 ->-                            zapQuery (normalizeCtxF p0) >>= \dp0 ->  -                            zapQuery (normalizeCtxF pt) >>= \dpt ->  -                            fmap (rotateAbout ang pt) $ -                              getLocImage ma (rotateAbout ang dpt dp0)+      normalizeCtxF p0 >>= \dp0 ->  +      normalizeCtxF pt >>= \dpt ->  +      fmap (rotateAbout ang pt) $ +          getLocImage ma (rotateAbout ang dpt dp0)   instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where   scale sx sy ma = promoteLoc $ \pt -> -                     zapQuery (normalizeCtxF pt) >>= \dpt -> -                     fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)+      normalizeCtxF pt >>= \dpt -> +      fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)  instance (InterpretUnit u, Translate a, ScalarUnit u, u ~ DUnit a) =>      Translate (LocImage u a) where   translate dx dy ma = promoteLoc $ \pt -> -                         zapQuery (normalizeCtxF pt) >>= \dpt -> -                         zapQuery (normalizeCtx dx)  >>= \ddx ->-                         zapQuery (normalizeCtx dy)  >>= \ddy ->-                         fmap (translate dx dy) $ -                             getLocImage ma (translate ddx ddy dpt)+      normalizeCtxF pt >>= \dpt -> +      normalizeCtx dx  >>= \ddx ->+      normalizeCtx dy  >>= \ddy ->+      translate dx dy $ getLocImage ma (translate ddx ddy dpt)  -------------------------------------------------------------------------------- @@ -299,7 +279,7 @@  moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a moveStart v1 ma = LocImage $ \pt -> -    zapQuery (normalizeCtxF v1) >>= \dv -> getLocImage ma (pt .+^ dv) +    normalizeCtxF v1 >>= \dv -> getLocImage ma (pt .+^ dv)    @@ -310,7 +290,7 @@ -- point, making an 'Image'.  --  at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a-at mf pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mf dpt+at mf pt = normalizeCtxF pt >>= \dpt -> getLocImage mf dpt   --------------------------------------------------------------------------------

@@ -30,11 +30,13 @@    , runLocThetaImage    , runLocThetaQuery +   , stripLocThetaImage+   , liftLocThetaQuery+       , promoteLocTheta    , applyLocTheta    , qpromoteLocTheta    , qapplyLocTheta-   , zapLocThetaQuery     , emptyLocThetaImage @@ -49,6 +51,7 @@ import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage  import Wumpus.Core                              -- package: wumpus-core@@ -78,7 +81,7 @@   newtype LocThetaQuery u a = LocThetaQuery { -          getLocThetaQuery :: Point2 u -> Radian -> Query u a }+          getLocThetaQuery :: DPoint2 -> Radian -> Query u a }  -- Functor @@ -177,35 +180,49 @@     in runImage (getLocThetaImage ma dpt incl) ctx  -runLocThetaQuery :: LocThetaQuery u a -> DrawingContext +runLocThetaQuery :: InterpretUnit u +                 => LocThetaQuery u a -> DrawingContext                   -> Point2 u -> Radian                    -> a-runLocThetaQuery ma ctx pt incl = runQuery (getLocThetaQuery ma pt incl) ctx+runLocThetaQuery ma ctx pt incl = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runQuery (getLocThetaQuery ma dpt incl) ctx  ++stripLocThetaImage :: LocThetaImage u a -> LocThetaQuery u a+stripLocThetaImage ma = LocThetaQuery $ \pt ang -> +    stripImage $ getLocThetaImage ma pt ang+++liftLocThetaQuery :: LocThetaQuery u a -> LocThetaImage u a+liftLocThetaQuery ma = LocThetaImage $ \pt ang -> +    liftQuery $ getLocThetaQuery ma pt ang++++ promoteLocTheta ::  InterpretUnit u                  => (Point2 u -> Radian -> Image u a) -> LocThetaImage u a promoteLocTheta k = LocThetaImage $ \pt ang -> -                      dinterpCtxF pt >>= \upt -> k upt ang+    dinterpCtxF pt >>= \upt -> k upt ang  applyLocTheta :: InterpretUnit u                => LocThetaImage u a -> Point2 u -> Radian -> Image u a applyLocTheta mq pt ang = -    zapQuery (normalizeCtxF pt) >>= \dpt -> getLocThetaImage mq dpt ang+    normalizeCtxF pt >>= \dpt -> getLocThetaImage mq dpt ang  -qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a-qpromoteLocTheta k = LocThetaQuery $ \pt ang -> k pt ang+qpromoteLocTheta :: InterpretUnit u +                 => (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a+qpromoteLocTheta k = LocThetaQuery $ \pt ang ->+    dinterpCtxF pt >>= \upt -> k upt ang  -qapplyLocTheta :: LocThetaQuery u a -> Point2 u -> Radian -> Query u a-qapplyLocTheta mq pt ang = getLocThetaQuery mq pt ang---- | \"zero-apply\" a LocThetaQuery.----zapLocThetaQuery :: LocThetaQuery u a -> Point2 u -> Radian -> Image u a-zapLocThetaQuery ma pt ang = askDC >>= \ctx -> -    let a = runLocThetaQuery ma ctx pt ang in return a+qapplyLocTheta :: InterpretUnit u+               => LocThetaQuery u a -> Point2 u -> Radian -> Query u a+qapplyLocTheta ma pt ang = +    normalizeCtxF pt >>= \dpt -> getLocThetaQuery ma dpt ang   @@ -252,10 +269,9 @@ --  incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a incline ma incl = promoteLoc $ \pt -> -                    zapQuery (normalizeCtxF pt) >>= \dpt ->-                    getLocThetaImage ma dpt incl+    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl  atIncline :: InterpretUnit u            => LocThetaImage u a -> Point2 u -> Radian -> Image u a-atIncline ma pt incl = zapQuery (normalizeCtxF pt) >>= \dpt -> -                       getLocThetaImage ma dpt incl+atIncline ma pt incl = +    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl

@@ -83,6 +83,7 @@ import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Basic.Kernel.Objects.Orientation@@ -234,7 +235,7 @@                    -> PosObject u a elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma   where-    fn ortt = moveStart (vtoOrigin raddr ortt) gf+    fn ortt = moveStart (vtoRectAddress ortt raddr) gf   

@@ -1,411 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.TraceDrawing--- Copyright   :  (c) Stephen Tetley 2010-2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Drawing with /trace/ - a Writer like monad collecting --- intermediate graphics - and /drawing context/ - a reader monad--- of attributes - font_face, fill_colour etc.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.TraceDrawing-  (--  -- * Collect primitives (writer-like monad) -    GenTraceDrawing-  , TraceDrawing-  , DTraceDrawing--  , runTraceDrawing-  , execTraceDrawing-  , evalTraceDrawing--  , runGenTraceDrawing---  , liftToPictureU-  , liftToPictureMb-  , mbPictureU- -  , trace-  , fontDelta-  , evalQuery--  , draw-  , drawi-  , drawl-  , drawli--  , drawc-  , drawci--  , node-  , nodei- -  , drawrc-  , drawrci--  ) where---import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.UserState-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.Anchors-import Wumpus.Basic.Kernel.Objects.Basis-import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.LocImage--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative-import Control.Monad-import Data.Monoid------------------------------------------------------------------------------------------ Note - TraceDrawing run \once\ - it is supplied with the starting--- environment (DrawingContext) and returns a Picture.------ Other Wumpus monads (e.g. Turtle) will typically be run inside--- the TraceDrawing monad as a local effect, rather than built into a --- transformer stack.------newtype GenTraceDrawing st u a   = GenTraceDrawing { -          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }---type instance MonUnit (GenTraceDrawing st u a) = u-type instance UState  (GenTraceDrawing st u)   = st--type TraceDrawing u a = GenTraceDrawing () u a--type DTraceDrawing a    = TraceDrawing Double a----- Functor--instance Functor (GenTraceDrawing st u) where-  fmap f ma = GenTraceDrawing $ \ctx s -> -                let (a,s1,w1) = getGenTraceDrawing ma ctx s in (f a,s1,w1)----- Applicative--instance Applicative (GenTraceDrawing st u) where-  pure a    = GenTraceDrawing $ \_   s -> (a, s, mempty)-  mf <*> ma = GenTraceDrawing $ \ctx s -> -                let (f,s1,w1) = getGenTraceDrawing mf ctx s-                    (a,s2,w2) = getGenTraceDrawing ma ctx s1-                in (f a, s2, w1 `mappend` w2)----- Monad--instance Monad (GenTraceDrawing st u) where-  return a  = GenTraceDrawing $ \_   s -> (a, s, mempty)-  ma >>= k  = GenTraceDrawing $ \ctx s -> -                let (a,s1,w1) = getGenTraceDrawing ma ctx s-                    (b,s2,w2) = (getGenTraceDrawing . k) a ctx s1-                in (b,s2,w1 `mappend` w2)-                               ---- DrawingCtxM--instance DrawingCtxM (GenTraceDrawing st u) where-  askDC           = GenTraceDrawing $ \ctx s -> (ctx, s, mempty)-  asksDC f        = GenTraceDrawing $ \ctx s -> (f ctx, s, mempty)-  localize upd ma = GenTraceDrawing $ \ctx s -> -                      getGenTraceDrawing ma (upd ctx) s----- UserStateM --instance UserStateM (GenTraceDrawing st u) where-  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)-  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)-  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)- ----runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)-runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()-  where-    post (a,_,w1) = (a,w1)------ | Run the drawing returning only the output it produces, drop--- any answer from the monadic computation.----execTraceDrawing :: TraceDrawing u a -> DrawingContext -> HPrim u-execTraceDrawing ma ctx = snd $ runTraceDrawing ma ctx---- | Run the drawing ignoring the output it produces, return the --- answer from the monadic computation.------ Note - this useful for testing, generally one would want the --- opposite behaviour (return the drawing, ignore than the --- answer).--- -evalTraceDrawing :: TraceDrawing u a -> DrawingContext -> a-evalTraceDrawing ma ctx = fst $ runTraceDrawing ma ctx---runGenTraceDrawing :: GenTraceDrawing st u a -> DrawingContext -> st -                   -> (a,st,HPrim u)-runGenTraceDrawing = getGenTraceDrawing-------- | /Unsafe/ promotion of @HPrim@ to @Picture@.------ If the HPrim is empty, a run-time error is thrown.--- -liftToPictureU :: HPrim u -> Picture-liftToPictureU hf = -    let prims = hprimToList hf in if null prims then errK else frame prims-  where-    errK = error "toPictureU - empty prims list."---- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.------ If the HPrim is empty, then @Nothing@ is returned.--- -liftToPictureMb :: HPrim u -> Maybe Picture-liftToPictureMb hf = let prims = hprimToList hf in -    if null prims then Nothing else Just (frame prims)------ | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.------ This is equivalent to:------ > fromMaybe (error "empty") $ pic------ This function is solely a convenience, using it saves one --- import and a few characters.------ If the supplied value is @Nothing@ a run-time error is thrown.--- -mbPictureU :: Maybe Picture -> Picture-mbPictureU Nothing  = error "mbPictureU - empty picture."-mbPictureU (Just a) = a---- Note - need an equivalent to Parsec\`s parseTest that provides--- a very simple way to run graphics without concern for return --- type or initial drawing context.------------------------------------------------------------------------------------------ TraceM ------ Note -  @ state `mappend` a @ means the first expression in a --- monadic drawing is the first element in the output file. It is--- also \*\* at the back \*\* in the the Z-Order.------ Some control over the Z-Order, possibly by adding /layers/ to --- the drawing model would be valuable. --- ---- | Primitive operation - cf. tell in Reader monad.----trace     :: HPrim u -> GenTraceDrawing st u ()-trace a = GenTraceDrawing $ \_ s -> ((), s, a)----fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a-fontDelta mf = GenTraceDrawing $ \ctx s -> -    let (_,font_attrs) = runQuery textAttr ctx-        (a,s1,w1)      = getGenTraceDrawing mf ctx s-        prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList w1-    in (a, s1, singleH $ prim1 $ prim)---- Note - this function is in the wrong module....----evalQuery :: DrawingCtxM m => Query u a -> m a-evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx------ | Draw a Graphic taking the drawing style from the --- /drawing context/. ------ This function is the /forgetful/ version of 'drawi'. --- Commonly, it is used to draw 'Graphic' objects which --- have no /answer/.--- -draw :: Image u a -> GenTraceDrawing st u ()-draw gf = askDC >>= \ctx -> -          let (_,w) = runImage gf ctx -          in trace (singleH w) >> return ()------- | Draw an Image taking the drawing style from the --- /drawing context/. ------ The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned.--- -drawi :: Image u a -> GenTraceDrawing st u a-drawi gf = askDC >>= \ctx -> -           let (a,w) = runImage gf ctx-           in trace (singleH w) >> return a-            ----- | Draw a LocImage at the supplied Anchor taking the drawing --- style from the /drawing context/. ------ This function is the /forgetful/ version of 'drawli'. --- Commonly, it is used to draw 'LocGraphic' objects which --- have no /answer/.--- -drawl :: InterpretUnit u-      => Anchor u -> LocImage u a -> GenTraceDrawing st u ()-drawl ancr img = drawli ancr img >> return ()------ | Draw a LocImage at the supplied Point taking the drawing --- style from the /drawing context/. ------ The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned.--- -drawli :: InterpretUnit u-       => Anchor u -> LocImage u a -> GenTraceDrawing st u a-drawli pt gf = askDC >>= \ctx -> -               let (a,w) = runLocImage gf ctx pt-               in trace (singleH w) >> return a----- Design note - having @drawlti@ for LocThetaImage does not seem --- compelling (at the moment). The thinking is that LocTheta--- objects should be downcast to Loc objects before drawing. ------ Connectors however are be different. --- --- PosImages would seem to be the same as LocThetaImages.--------- | Draw a ConnectorGraphic with the supplied Anchors taking the --- drawing style from the /drawing context/. ------ This function is the /forgetful/ version of 'drawci'. --- Commonly, it is used to draw 'ConnectorGraphic' objects which --- have no /answer/.--- -drawc :: InterpretUnit u-      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()-drawc an0 an1 img = drawci an0 an1 img >> return () ----- | Draw a ConnectorImage with the supplied Points taking the --- drawing style from the /drawing context/. ------ The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned.--- -drawci :: InterpretUnit u -       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a-drawci p0 p1 img = drawi (connect p0 p1 img)----------- | Draw the object with the supplied grid coordinate. The --- actual position is scaled according to the --- @snap_grid_factors@ in the /drawing context/.--- --- This function is the /forgetful/ version of 'nodei'. --- Commonly, it is used to draw 'LocGraphic' objects which --- have no /answer/.--- -node :: ( Fractional u, InterpretUnit u)-     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()-node coord gf = nodei coord gf >> return ()----- | Draw the object with the supplied grid coordinate. The --- actual position is scaled according to the --- @snap_grid_factors@ in the /drawing context/.--- -nodei :: (Fractional u, InterpretUnit u) -      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a-nodei coord gf = askDC >>= \ctx -> -                 position coord >>= \pt ->-                 let (a,w) = runLocImage gf ctx pt-                 in trace (singleH w) >> return a- ------- | Draw a connector between two objects. The projection of the--- connector line is drawn on the line from center to center of --- the objects, the actual start and end points of the drawn line--- are the radial points on the objects borders that cross the --- projected line.--- --- This function is the /forgetful/ version of 'drawrci'. --- Commonly, it is used to draw 'LocGraphic' objects which --- have no /answer/.--- -drawrc :: ( Real u, Floating u, InterpretUnit u-          , CenterAnchor a1, RadialAnchor a1-          , CenterAnchor a2, RadialAnchor a2-          , u ~ DUnit a1, u ~ DUnit a2-          ) -       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()-drawrc a b gf = drawrci a b gf >> return ()----- | Draw a connector between two objects. The projection of the--- connector line is drawn on the line from center to center of --- the objects, the actual start and end points of the drawn line--- are the radial points on the objects borders that cross the --- projected line.--- -drawrci :: ( Real u, Floating u, InterpretUnit u-           , CenterAnchor a1, RadialAnchor  a1-           , CenterAnchor a2, RadialAnchor  a2-           , u ~ DUnit a1, u ~ DUnit a2-           ) -        => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a-drawrci a b gf = -    let (p0,p1) = radialConnectorPoints a b in drawi (connect p0 p1 gf)

@@ -23,7 +23,7 @@  -- | Version number ----- > (0,20,0)+-- > (0,21,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,20,0)+wumpus_basic_version = (0,21,0)

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.20.0+version:          0.21.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -30,8 +30,22 @@   .   Changelog:   .-  v0.19.0 to v0.20.0:+  v0.20.0 to v0.21.0:   .+  * The code from the @Kernel.Base.UserState@ module has been +    moved to the module @Kernel.Drawing.Basis@.+  .+  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and +    @TraceDrawing@ into the new @Drawing@ folder.+  .+  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.+  . +  * Rationalized the combinators exported by the drawing objects +    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.+  . +  v0.18.0 to v0.20.0:+  .   * Added text advance-vector calculations to @QueryDC@ -      previously they were in Wumpus-Drawing.   . @@ -94,23 +108,26 @@     Wumpus.Basic.Kernel.Base.QueryDC,     Wumpus.Basic.Kernel.Base.Units,     Wumpus.Basic.Kernel.Base.UpdateDC,-    Wumpus.Basic.Kernel.Base.UserState,     Wumpus.Basic.Kernel.Base.WrappedPrimitive,+    Wumpus.Basic.Kernel.Drawing.Basis,+    Wumpus.Basic.Kernel.Drawing.Chain,+    Wumpus.Basic.Kernel.Drawing.CtxPicture,+    Wumpus.Basic.Kernel.Drawing.LocDrawing,+    Wumpus.Basic.Kernel.Drawing.LocTrace,+    Wumpus.Basic.Kernel.Drawing.TraceDrawing,     Wumpus.Basic.Kernel.Objects.AdvObject,     Wumpus.Basic.Kernel.Objects.Anchors,     Wumpus.Basic.Kernel.Objects.Basis,     Wumpus.Basic.Kernel.Objects.Bounded,-    Wumpus.Basic.Kernel.Objects.Chain,     Wumpus.Basic.Kernel.Objects.Concat,     Wumpus.Basic.Kernel.Objects.Connector,-    Wumpus.Basic.Kernel.Objects.CtxPicture,     Wumpus.Basic.Kernel.Objects.Displacement,     Wumpus.Basic.Kernel.Objects.DrawingPrimitives,+    Wumpus.Basic.Kernel.Objects.Image,     Wumpus.Basic.Kernel.Objects.LocImage,     Wumpus.Basic.Kernel.Objects.LocThetaImage,     Wumpus.Basic.Kernel.Objects.Orientation,     Wumpus.Basic.Kernel.Objects.PosObject,-    Wumpus.Basic.Kernel.Objects.TraceDrawing,     Wumpus.Basic.System.FontLoader,     Wumpus.Basic.System.FontLoader.AfmParserBase,     Wumpus.Basic.System.FontLoader.AfmTopLevel,