wumpus-basic 0.18.0 → 0.20.0

raw patch · 29 files changed

+1590/−1144 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES +34/−0
• demo/SimpleAdvGraphic.hs +3/−3
• demo/SimplePosObject.hs +10/−9
• src/Wumpus/Basic/Kernel.hs +2/−0
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +82/−137
• src/Wumpus/Basic/Kernel/Base/FontSupport.hs +14/−8
• src/Wumpus/Basic/Kernel/Base/QueryDC.hs +105/−1
• src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +12/−6
• src/Wumpus/Basic/Kernel/Base/UserState.hs +36/−0
• src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs +20/−18
• src/Wumpus/Basic/Kernel/Objects/AdvObject.hs +109/−82
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +80/−168
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +4/−4
• src/Wumpus/Basic/Kernel/Objects/Chain.hs +163/−121
• src/Wumpus/Basic/Kernel/Objects/Connector.hs +40/−34
• src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +19/−32
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +0/−5
• src/Wumpus/Basic/Kernel/Objects/LocImage.hs +57/−39
• src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs +40/−34
• src/Wumpus/Basic/Kernel/Objects/Orientation.hs +140/−76
• src/Wumpus/Basic/Kernel/Objects/PosObject.hs +412/−152
• src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs +110/−170
• src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs +16/−5
• src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs +6/−4
• src/Wumpus/Basic/System/FontLoader/Datatypes.hs +17/−9
• src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs +26/−8
• src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs +6/−4
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +25/−13

@@ -1,4 +1,38 @@ +0.18.0 to 0.19.0:++  * Removed the Semigroup (OPlus) and Bifunctor classes. They are +    no longer so pertinent now that Image, LocImage etc. are +    newtypes rather than /ContextFuns/.++  * Changed internals of LocImage, LocThetaImage and  Connector +    types so the internal points always have Double (PostScript +    point) as the unit. This fixes a bug where otherwise changing+    the font size for drawings with Em or En units would break the+    layout.++  * Added @ORIGIN@ to the @RectAddress@ enumeration. I had +    overlooked that @BLC /= ORIGIN@.++  * Added underline-position and underline-thickness to the font +    metrics read by the font loader.++0.17.0 to 0.18.0:+ +  * Major change - removed @ContextFun@ from @Kernel.Base@. Now +    the drawing objects (Image, LocImage, Connector...) are +    newtype wrapped Reader-Writer monads rather than aliases to +    one of the arity family of ContextFuns. Being newtypes gives+    a lot better opportunities for overloading.++  * Changed Displacement API - it is smaller, and the function +    naming is more uniform.+  +  * Changed @DrawingPimitives@ to use @DrawStyle@.+  +  * Moved vertices generating functions from @Geometry.Path@ to +    @Geometry.Vertices@.+  0.16.0 to 0.17.0:    * Changed representation of ContextFuns - context funs are no 

@@ -50,15 +50,15 @@ -- Normally, text calculate the advance vector from the font  -- metrics... ---text01 :: AdvObject Double+text01 :: AdvGraphic Double text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"      -text02 :: AdvObject Double+text02 :: AdvGraphic Double text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"  -miniDisk :: AdvObject Double+miniDisk :: AdvGraphic Double miniDisk = makeAdvObject (pure $ V2 0 0) disk1    where     disk1 = localize (fill_colour sienna) $ dcDisk FILL 3

@@ -58,15 +58,18 @@     draw $ testDrawBl    BLC    `at` (P2 150  0)     draw $ testDrawBl    BLR    `at` (P2 225  0)     +    drawl (P2 300 0) $ runPosObject msg SW+  where+    msg = multilinePosText VALIGN_RIGHT "Red dot represents the\nrectangle address." -testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u++testDrawBl :: RectAddress -> LocGraphic Double testDrawBl raddr = dcDisk FILL 2 `mappend` rectBl raddr  -rectBl :: (Fractional u, InterpretUnit u) -       => RectAddress -> LocGraphic u+rectBl :: RectAddress -> LocGraphic Double rectBl raddr = -    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)+    ignoreAns $ runPosObject (makePosObject (return ortt) (mkRectBl w h)) raddr   where     w    = 40      h    = 30@@ -82,16 +85,14 @@   -testDrawMinor :: (Floating u, InterpretUnit u) -              => RectAddress -> LocGraphic u+testDrawMinor :: RectAddress -> LocGraphic Double testDrawMinor raddr =      dcDisk FILL 2 `mappend` (ignoreAns $ rectMinor raddr)  -rectMinor :: (Fractional u, InterpretUnit u) -          => RectAddress -> LocImage u (BoundingBox u)+rectMinor :: RectAddress -> LocGraphic Double rectMinor raddr = -    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)+    runPosObject (makePosObject (return ortt) (mkRectMinor m w h)) raddr   where     m    = 10     w    = 40 

@@ -23,6 +23,7 @@   , 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.Objects.AdvObject   , module Wumpus.Basic.Kernel.Objects.Anchors@@ -48,6 +49,7 @@ 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.Objects.AdvObject import Wumpus.Basic.Kernel.Objects.Anchors

@@ -21,19 +21,10 @@        MonUnit  -  -- * A semigroup class-  , OPlus(..)-  , oconcat-  , altconcat --  -- * A bifunctor class-  , Bimap(..)-  , replaceL-  , replaceR-   -- * Unit phantom type   , UNil(..)+  , ureturn    -- * Non-contextual unit conversion.   , ScalarUnit(..)@@ -44,9 +35,14 @@   , normalizeF   , uconvert1   , uconvertF+   , intraMapPoint   , intraMapFunctor ++  -- * KernChar+  , KernChar+   -- * Drawing paths   , DrawStyle(..) @@ -57,6 +53,9 @@   , HAlign(..)   , VAlign(..)   +  -- * Text height+  , TextHeight(..)+   -- * Cardinal (compass) positions   , Cardinal(..) @@ -64,8 +63,9 @@   , Direction(..)    -  -- * Misc (potentially for Wumpus-Core)+  -- * Misc   , vsum+  , both    ) where @@ -87,128 +87,7 @@   ----infixr 6 `oplus`---- | A Semigroup class.--- --- The perhaps unusual name is the TeX name for the circled plus --- glyph. It would be nice if there was a semigroup class in the--- Haskell Base libraries...  --- -class OPlus t where-  oplus :: t -> t -> t---- | 'oconcat' : @ list_head * [rest] -> Ans @--- --- Semigroup version of @mconcat@ from the module @Data.Monoid@.------ As a semigroup cannot build a zero value, /concat/ cannot --- handle the empty list. So to make 'oconcat' a safe function--- the input list is already destructured by one cons cell.--- --- Effectively this means that client code must handle the --- empty list case, before calling 'oconcat'.--- -oconcat :: OPlus t => t -> [t] -> t-oconcat t = step t-  where-    step ac []     = ac-    step ac (x:xs) = step (ac `oplus` x) xs------ | 'altconcat' : @ alternative * [list] -> Ans@--- --- 'altconcat' uses 'oplus' to create a summary value from a list--- of values. ------ When supplied the empty list 'altconcat' returns the supplied --- /alternative/ value. If the list is inhabited, the alternative--- value is discarded.------ This contrasts to 'oconcat' where the single value represents --- the head of an already destructured list.--- -altconcat :: OPlus a => a -> [a] -> a-altconcat _   (x:xs) = oconcat x xs-altconcat alt []     = alt---instance OPlus () where-  _ `oplus` _ = ()---instance OPlus a => OPlus (Const a b) where-  Const a0 `oplus` Const a1 = Const $ a0 `oplus` a1 ---instance Ord u => OPlus (BoundingBox u) where-  oplus = boundaryUnion--instance OPlus Primitive where-  a `oplus` b = primGroup [a,b]--instance (OPlus a, OPlus b) => OPlus (a,b) where-  (a,b) `oplus` (m,n) = (a `oplus` m, b `oplus` n)--instance (OPlus a, OPlus b, OPlus c) => OPlus (a,b,c) where-  (a,b,c) `oplus` (m,n,o) = (a `oplus` m, b `oplus` n, c `oplus` o)--instance (OPlus a, OPlus b, OPlus c, OPlus d) => OPlus (a,b,c,d) where-  (a,b,c,d) `oplus` (m,n,o,p) = (oplus a m, oplus b n, oplus c o, oplus d p)----instance OPlus a => OPlus (r -> a) where-  f `oplus` g = \x -> f x `oplus` g x---- The functional instance (r -> a) also covers (r1 -> r2 -> a),--- (r1 -> r2 -> r3 -> a) etc.--instance Num u => OPlus (Vec2 u) where -  oplus = (^+^)-- ------------------------------------------------------------------------------------ | A Bifunctor class.--- --- Again, it would be nice if there was a Bifunctor class in the--- Haskell Base libraries...  --- -class Bimap f where-  bimap     :: (a -> p) -> (b -> q) -> f a b -> f p q-  bimapL    :: (a -> p) -> f a b -> f p b-  bimapR    :: (b -> q) -> f a b -> f a q----instance Bimap (,) where-  bimap f g (a,b) = (f a, g b)-  bimapL f (a,b)  = (f a, b)-  bimapR g (a,b)  = (a, g b)--instance Bimap Either where-  bimap f _ (Left a)  = Left (f a)-  bimap _ g (Right b) = Right (g b)--  bimapL f (Left a)  = Left (f a)-  bimapL _ (Right b) = Right b--  bimapR _ (Left a)  = Left a-  bimapR g (Right b) = Right (g b)--replaceL :: Bimap f => p -> f a b -> f p b-replaceL = bimapL . const--replaceR :: Bimap f => q -> f a b -> f a q-replaceR = bimapR . const----------------------------------------------------------------------------------- -- Simple objects wrapped with unit phatom type   @@ -227,12 +106,9 @@   mempty        = UNil   _ `mappend` _ = UNil -instance OPlus (UNil u) where-  _ `oplus` _ = UNil   - instance Rotate (UNil u) where   rotate _              = id @@ -245,6 +121,27 @@ instance Translate (UNil u) where   translate _ _         = id +-- | Return a 'UNil' rather than @()@ at the end of sequence of+-- 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:+--+-- > ureturn+-- +-- or:+-- +-- return UNil+--+-- rather than:+--+-- > return ()+--+--+ureturn :: Monad m => m (UNil u)+ureturn = return UNil+ -------------------------------------------------------------------------------- -- Non-contextual units @@ -331,8 +228,26 @@   --------------------------------------------------------------------------------+-- KernChar+++-- | Unit parametric version of KerningChar from Wumpus-Core.+--+type KernChar u = (u,EscapedChar)+++-------------------------------------------------------------------------------- -- Drawing closed paths ++-- | Draw closed paths. +-- +-- > FILL +--+-- > STROKE+--+-- > FILL_STROKE - the path is filled and its edge is stroked.+-- data DrawStyle = FILL | STROKE | FILL_STROKE   deriving (Bounded,Enum,Eq,Ord,Show) @@ -354,16 +269,38 @@  -- | Horizontal alignment - align to the top, center or bottom. ---data HAlign = HTop | HCenter | HBottom+data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE   deriving (Enum,Eq,Ord,Show)  -- | Vertical alignment - align to the left, center or bottom. ---data VAlign = VLeft | VCenter | VRight+data VAlign = VALIGN_LEFT | VALIGN_CENTER | VALIGN_RIGHT   deriving (Enum,Eq,Ord,Show) + --------------------------------------------------------------------------------+-- Text height ++-- | Wumpus distinguishes two use-cases for displaying vertically +-- centered text.+-- +-- Arbitrary text that is expected to contain lower case letters +-- with descenders, show take the vertical center as the mid-point +-- between the cap height and the descender depth.+--+-- Unfortunately, including the descender depth can produce +-- unbalanced results for text which is not expected to have +-- descenders (e.g. numbers within a bordered box), visually this +-- makes the center too high.+-- +data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER+  deriving (Enum,Eq,Ord,Show)++++--------------------------------------------------------------------------------+ -- Compass positions  -- | An enumeratied type representing the compass positions.@@ -393,3 +330,11 @@   where     go a []     = a     go a (b:bs) = go (a ^+^ b) bs+++-- | Applicative /both/ - run both computations return the pair+-- of the the answers.+--+both :: Applicative f => f a -> f b -> f (a,b)+both fa fb = (,) <$> fa <*> fb+

@@ -158,10 +158,12 @@ -- current point size, the actual fields are all functions. -- data FontMetrics = FontMetrics-    { get_bounding_box :: FontSize -> BoundingBox Double-    , get_cw_table     :: FontSize -> CharWidthLookup-    , get_cap_height   :: FontSize -> Double-    , get_descender    :: FontSize -> Double+    { get_bounding_box          :: FontSize -> BoundingBox Double+    , get_cw_table              :: FontSize -> CharWidthLookup+    , get_cap_height            :: FontSize -> Double+    , get_descender             :: FontSize -> Double+    , get_underline_position    :: FontSize -> Double+    , get_underline_thickness   :: FontSize -> Double     }  @@ -235,10 +237,12 @@ -- monospace_metrics :: FontMetrics monospace_metrics = FontMetrics-    { get_bounding_box  = \sz -> BBox (lowerLeft sz) (upperRight sz)-    , get_cw_table      = \sz _ -> hvec (upscale sz width_vec) -    , get_cap_height    = \sz -> upscale sz cap_height-    , get_descender     = \sz -> upscale sz descender+    { get_bounding_box          = \sz -> BBox (lowerLeft sz) (upperRight sz)+    , get_cw_table              = \sz _ -> hvec (upscale sz width_vec) +    , get_cap_height            = \sz -> upscale sz cap_height+    , get_descender             = \sz -> upscale sz descender+    , get_underline_position    = \sz -> upscale sz underline_pos+    , get_underline_thickness   = \sz -> upscale sz underline_width     }   where     llx             = (-23)  / 1000@@ -248,6 +252,8 @@     width_vec       = 600    / 1000     cap_height      = 562    / 1000     descender       = (-157) / 1000+    underline_pos   = (-100) / 1000+    underline_width = 50     / 1000      upscale sz d    = d * fromIntegral sz     lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) 

@@ -53,8 +53,16 @@   , glyphBoundingBox   , capHeight   , descender+  , underlinePosition+  , underlineThickness   , verticalSpan+  , heightSpan +  -- * Text metrics+  , escTextVector+  , escCharVector+  , hkernVector+   , cwLookupTable  @@ -76,11 +84,20 @@ import Wumpus.Basic.Kernel.Base.FontSupport  import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Text.GlyphIndices++import Data.VectorSpace                         -- package: vector-space   import Control.Applicative-+import Data.Char+import qualified Data.Map               as Map+import Data.Maybe   +--+-- NOTE 20.5.11 - The normalize functions are not satisfactory,+-- point size is too promiscuous for evaluation contextual units.+--  normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double normalizeCtx u = (\sz -> normalize sz u) <$> pointSize@@ -224,11 +241,98 @@ descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender  +-- | Note - underline_position is expected to be negative.+--+underlinePosition :: (DrawingCtxM m, InterpretUnit u) => m u+underlinePosition = +    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_position+++-- | Line width of underline line.+--+underlineThickness :: (DrawingCtxM m, InterpretUnit u) => m u+underlineThickness = +    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_thickness++ -- | This is the distance from cap_height to descender. -- verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u verticalSpan =      (\ch dd -> ch - dd) <$> capHeight <*> descender++++-- | Variant of 'verticalSpan' that accounts for the specified+-- 'TextHeight'.+--+-- This returns a pair of @(yminor, ymajor)@.+-- +heightSpan :: (DrawingCtxM m, InterpretUnit u )+           => TextHeight -> m (u,u)+heightSpan JUST_CAP_HEIGHT           = (\ymaj -> (0, ymaj)) <$> capHeight+heightSpan CAP_HEIGHT_PLUS_DESCENDER = +    (\ymin ymaj -> (abs ymin, ymaj)) <$> descender <*> capHeight++++--------------------------------------------------------------------------------++++-- | Find the advance vector for the supplied 'EscapedText'.+--+-- Note - the text assumed to be a single line.+-- +escTextVector :: (DrawingCtxM m, InterpretUnit u) +              => EscapedText -> m (Vec2 u)+escTextVector esc = +    cwLookupTable >>= \table -> +    pointSize     >>= \sz    -> +    let cs = destrEscapedText id esc +    in return $ foldr (step sz table) (vec 0 0) cs+  where+    step sz table ch v = let cv = escCharWidth sz table ch in v ^+^ cv++++-- | Find the advance vector for the supplied 'EscapedChar'.+--+escCharVector :: (DrawingCtxM m, InterpretUnit u) +           => EscapedChar -> m (Vec2 u)+escCharVector ch = +    (\table sz -> escCharWidth sz table ch) <$> cwLookupTable <*> pointSize+++-- | This is outside the Drawing context as we don\'t want to get+-- the @cwLookupTable@ for every char.+--+escCharWidth :: InterpretUnit u +             => FontSize -> CharWidthLookup -> EscapedChar -> Vec2 u+escCharWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c+escCharWidth sz fn (CharEscInt i)  = fmap (dinterp sz) $ fn i+escCharWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix+  where+    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices+++++-- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @+-- +-- 'hkernvector' takes whatever length is paired with the +-- EscapedChar for the init of the the list, for the last element +-- it takes the charVector.+--+hkernVector :: (DrawingCtxM m, InterpretUnit u) +            => [KernChar u] -> m (Vec2 u)+hkernVector = go 0+  where+    go w []             = return $ V2 w 0+    go w [(dx,ch)]      = fmap (addWidth $ w + dx) (escCharVector ch)+    go w ((dx,_ ):xs)   = go (w + dx) xs+    +    addWidth w (V2 x y) = V2 (w+x) y   

@@ -35,6 +35,7 @@   , line_thick   , line_ultra_thick   +  , contextual_line_width   , relative_line_width    -- * Line cap@@ -189,17 +190,22 @@   --- | Set the line width to a size relative to the current font --- size. The size is calculated with the supplied function.+-- | Scale the line width respective to its current value. +-- +-- The size is calculated with the supplied function. ---relative_line_width :: (FontSize -> Double) -> DrawingContextF+relative_line_width :: (Double -> Double) -> DrawingContextF relative_line_width fn = -    withFontSize $ \sz s -> set_line_width (fn sz) s+    updateStrokeProps (\s -> let lw = line_width s in s { line_width = fn lw })  ------ All options share the prefix so the enumeration is obvious...+-- | Set the line width to a size relative to the current font +-- size. The size is calculated with the supplied function. --+contextual_line_width :: (FontSize -> Double) -> DrawingContextF+contextual_line_width fn = +    withFontSize $ \sz s -> set_line_width (fn sz) s+   --------------------------------------------------------------------------------

@@ -0,0 +1,36 @@+{-# 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 ()+   

@@ -25,6 +25,7 @@     CatPrim   , prim1   , cpmap+  , cpmove    , HPrim   , hprimToList@@ -32,7 +33,6 @@    ) where -import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Utils.HList  import Wumpus.Core                      -- package: wumpus-core@@ -44,7 +44,14 @@  -- | A wrapped version of 'Primitive' from Wumpus-Core that  -- supports Monoid.+-- +-- Note that CatPrim provides a /single-object/ that can be+-- hyperlinked or whatever.  --+-- It is different to 'HPrim' which is intended as a list type +-- with efficient concatenation to support building of multiple+-- Primitives in a frame.+-- -- This type is essentially internal to Wumpus-Basic. -- data CatPrim = CZero@@ -52,10 +59,6 @@  type instance DUnit CatPrim = Double -instance OPlus CatPrim where-  CZero  `oplus` b      = b-  a      `oplus` CZero  = a-  Cat1 a `oplus` Cat1 b = Cat1 $ a `primCat` b   instance Monoid CatPrim where@@ -71,6 +74,8 @@       step ac (x:xs) = step (ac `mappend` x) xs  ++ --------------------------------------------------------------------------------  instance Rotate CatPrim where@@ -101,23 +106,17 @@ cpmap _ CZero    = CZero cpmap f (Cat1 a) = Cat1 $ f a ++cpmove :: Vec2 Double -> CatPrim -> CatPrim+cpmove (V2 x y) = translate x y++ -------------------------------------------------------------------------------- -- Lists of primitives...  --- | Graphics objects, even simple ones (line, arrow, dot) might --- need more than one primitive (path or text label) for their--- construction. Hence, the primary representation that all the --- others are built upon must support /concatenation/ of --- primitives. ------ Wumpus-Core has a type Picture - made from one or more --- Primitives - but Pictures include support for affine frames. --- For drawing many simple graphics (dots, connector lines...) --- that do not need individual affine transformations this is a --- penalty. A list of Primitives is therefore more suitable --- representation, and a Hughes list which supports--- efficient concatenation is wise.+-- | Collected primitives - this type is effectively an analogue+-- to a @Frame@ in Wumpus-Core. -- -- This type is essentially internal to Wumpus-Basic. -- @@ -138,6 +137,9 @@   -- | Extract the internal list of 'Primitive' from a 'HPrim'.+-- +-- The expectation is that this Primitive list will be rendered+-- by Wumpus-Core as a @frame@. -- hprimToList :: HPrim u -> [Primitive] hprimToList = toListH . getHPrim

@@ -29,6 +29,9 @@   -- * Advance-vector object and graphic   , AdvObject   , DAdvObject++  , AdvGraphic+  , DAdvGraphic      , runAdvObject @@ -57,8 +60,7 @@  import Wumpus.Core                              -- package: wumpus-core -import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace+import Data.VectorSpace                         -- package: vector-space  import Control.Applicative import Data.Monoid@@ -97,54 +99,103 @@ -------------------------------------------------------------------------------- -- AdvObject -type AdvDraw u = Point2 u -> CatPrim+-- | Internal newtype wrapper so we can have a monoid instance +-- with vector plus (^+^) for mappend.+--+newtype DAV = DAV { getDAV :: AdvanceVec Double }  +instance Monoid DAV where+  mempty = DAV $ V2 0 0+  DAV v1 `mappend` DAV v2 = DAV $ v1 ^+^ v2  -- | /Advance vector/ graphic - this partially models the  -- PostScript @show@ command which moves the /current point/ by the -- advance (width) vector as each character is drawn. ---newtype AdvObject u = AdvObject { getAdvObject :: Query u (Vec2 u, AdvDraw u) }+newtype AdvObject u a = AdvObject +          { getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) } -type instance DUnit (AdvObject u) = u+type instance DUnit (AdvObject u a) = u -type DAdvObject     = AdvObject Double+type DAdvObject a   = AdvObject Double a  +type AdvGraphic u = AdvObject u (UNil u)+type DAdvGraphic  = AdvGraphic Double  ---------------------------------------------------------------------------------+instance Functor (AdvObject u) where+  fmap f mf = AdvObject $ \ctx pt -> +              let (a,v1,w1) = getAdvObject mf ctx pt in (f a,v1,w1) -instance (InterpretUnit u) => Monoid (AdvObject u) where-  mempty  = blankAdvObject (V2 0 0)-  mappend = advplus +instance Applicative (AdvObject u) where+  pure a    = AdvObject $ \_   _  -> (a,mempty,mempty)+  mf <*> ma = AdvObject $ \ctx pt -> +              let (f,v1,w1) = getAdvObject mf ctx pt+                  (a,v2,w2) = getAdvObject ma ctx pt+              in (f a, v1 `mappend` v2, w1 `mappend` w2) --- | Run an 'AdvObject' turning it into an 'LocImage'.+++instance Monad (AdvObject u) where+  return a  = AdvObject $ \_   _  -> (a,mempty,mempty)+  mf >>= k  = AdvObject $ \ctx pt -> +              let (a,v1,w1) = getAdvObject mf ctx pt+                  (b,v2,w2) = getAdvObject (k a) ctx pt+              in (b, v1 `mappend` v2, w1 `mappend` w2)++++instance DrawingCtxM (AdvObject u) where+  askDC           = AdvObject $ \ctx _ -> (ctx, mempty, mempty)+  asksDC fn       = AdvObject $ \ctx _ -> (fn ctx, mempty, mempty)+  localize upd ma = AdvObject $ \ctx pt -> getAdvObject ma (upd ctx) pt+++++instance (Monoid a, InterpretUnit u) => Monoid (AdvObject u a) where+  mempty = AdvObject $ \_ _ -> (mempty, mempty, mempty)+  ma `mappend` mb = AdvObject $ \ctx pt -> +                    let (a,v1,w1) = getAdvObject ma ctx pt+                        (b,v2,w2) = getAdvObject mb ctx pt+                        w2r       = cpmove (getDAV v1) w2+                    in (a `mappend` b, v1 `mappend` v2, w1 `mappend` w2r)++++-- | Running an AdvObject produces a LocImage. ---runAdvObject :: AdvObject u -> LocImage u (Vec2 u)-runAdvObject (AdvObject mf) = promoteLoc $ \pt -> -   askDC >>= \ctx -> -   let (v1,df) = runQuery ctx mf-   in replaceAns v1 $ primGraphic (df pt)+runAdvObject :: InterpretUnit u +             => AdvObject u a -> LocImage u a+runAdvObject ma = promoteLoc $ \ot -> +    askDC >>= \ctx -> +    let dot      = normalizeF (dc_font_size ctx) ot+        (a,_,ca) = getAdvObject ma ctx dot+    in replaceAns a $ primGraphic ca  --- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @++--------------------------------------------------------------------------------+++-- | 'makeAdvObject' : @ loc_context_function * image -> AdvObject @ -- -- Build an 'AdvObject' from a context function ('CF') that  -- generates the answer displacement vector and a 'LocGraphic'  -- that draws the 'AdvObject'. ---makeAdvObject :: Query u (Vec2 u) -> LocGraphic u -> AdvObject u-makeAdvObject mq gf = AdvObject body-  where-    body = askDC >>= \ctx -> -           let v1   = runQuery ctx mq-               pf   = \pt -> getCP $ runLocImage pt ctx gf-           in return (v1,pf)+makeAdvObject :: InterpretUnit u +              => Query u (Vec2 u) -> LocImage u a -> AdvObject u a+makeAdvObject ma gf = AdvObject $ \ctx pt -> +    let v1    = runQuery ma ctx+        dav1  = DAV $ normalizeF (dc_font_size ctx) v1+        upt   = dinterpF (dc_font_size ctx) pt+        (a,w) = runLocImage gf ctx upt+    in (a,dav1,w) -    getCP (PrimW ca _) = ca   -- | 'emptyAdvObjectAU' : @ AdvObject @@@ -155,62 +206,31 @@ -- @Wumpus-Core@ and is not drawn, the answer vector generated is -- the zero vector @(V2 0 0)@. -- -emptyAdvObject :: InterpretUnit u => AdvObject u-emptyAdvObject = blankAdvObject (V2 0 0)+emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a+emptyAdvObject = mempty  -blankAdvObject :: Vec2 u -> AdvObject u-blankAdvObject v1 = AdvObject $ pure (v1, const mempty) +blankAdvObject :: (Monoid a, InterpretUnit u) +               => Vec2 u -> AdvObject u a+blankAdvObject v1 = AdvObject $ \ctx _ ->+                    let dav1  = DAV $ normalizeF (dc_font_size ctx) v1+                    in (mempty, dav1, mempty)    + -------------------------------------------------------------------------------- -- Combining AdvObjects  --- | Design note - this is rather /uncool/.------ Here it would be nicer if PrimW didn\'t cover two cases - --- queries (Pure) and images (PrimW). However implementing this --- would double the amount of code and then require extra --- bind-like combinators to promote queries to images.------ This is simulated in @appendW@ by dropping any graphic embedded --- in a PrimW (everything should be a query anyway). But it would --- be nicer in this particular case, if the type system enforced --- this.----appendW :: Num u -        => (Vec2 u, AdvDraw u) -        -> (Vec2 u, AdvDraw u) -        -> (Vec2 u, AdvDraw u)-appendW (v0,pf0) (v1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 (pt .+^ v0)-                            in (v0 ^+^ v1, pf) ---- | Primitive combination.--- --- Move second object by the advance vector of the first. Sum --- both advance vectors.----advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u-advplus a b = AdvObject body-  where -    body = askDC >>= \ctx ->-           let ans1 = runQuery ctx (getAdvObject a)-               ans2 = runQuery ctx (getAdvObject b)-           in return (appendW ans1 ans2)---- -- Helper for list concatenation. -- -listcat :: InterpretUnit u -        => (AdvObject u -> AdvObject u -> AdvObject u)-        -> [AdvObject u] -> AdvObject u+listcat :: (Monoid a, InterpretUnit u)+        => (AdvObject u a -> AdvObject u a -> AdvObject u a)+        -> [AdvObject u a] -> AdvObject u a listcat _ []     = mempty listcat op (x:xs) = go x xs   where@@ -232,28 +252,33 @@ -- -- The final answer is the sum of both advance vectors. ---advance :: Num u => AdvObject u -> AdvObject u -> AdvObject u-advance = advplus+advance :: (Monoid a, InterpretUnit u) +        => AdvObject u a -> AdvObject u a -> AdvObject u a+advance = mappend     -- | Concatenate the list of AdvObjects with 'advance'. ---advances :: InterpretUnit u => [AdvObject u] -> AdvObject u-advances = listcat advance+advances :: (Monoid a, InterpretUnit u) +         => [AdvObject u a] -> AdvObject u a+advances = mconcat   -- | Combine the AdvObjects using the answer vector of the  -- first object plus the separator to move the start of the second -- object.  ---advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u-advspace sep a b = a `advplus` blank `advplus` b+advspace :: (Monoid a, InterpretUnit u) +         => Vec2 u -> AdvObject u a -> AdvObject u a -> AdvObject u a+advspace sep a b = a `mappend` blank `mappend` b   where     blank = blankAdvObject sep + -- | List version of 'nextSpace'. ---evenspace :: InterpretUnit u => Vec2 u -> [AdvObject u] -> AdvObject u+evenspace :: (Monoid a, InterpretUnit u) +          => Vec2 u -> [AdvObject u a] -> AdvObject u a evenspace v = listcat (advspace v)  @@ -261,14 +286,16 @@ -- | Repeat the AdvObject @n@ times, moving each time with  -- 'advance'. ---advrepeat :: InterpretUnit u => Int -> AdvObject u -> AdvObject u+advrepeat :: (Monoid a, InterpretUnit u)+          => Int -> AdvObject u a -> AdvObject u a advrepeat n = advances . replicate n   -- | Concatenate the list of AdvObjects, going next and adding -- the separator at each step. ---punctuate :: InterpretUnit u => AdvObject u -> [AdvObject u] -> AdvObject u+punctuate :: (Monoid a, InterpretUnit u)+          => AdvObject u a -> [AdvObject u a] -> AdvObject u a punctuate sep =  listcat (\a b -> a `advance` sep `advance` b)  @@ -277,11 +304,11 @@ -- for the supplied vector. This function has behaviour analogue  -- to @fill@ in the @wl-pprint@ library. -- -advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u-advfill sv a = AdvObject body-  where -    body = askDC >>= \ctx ->-           let (_,df) = runQuery ctx (getAdvObject a)-           in return (sv,df)+advfill :: InterpretUnit u +        => Vec2 u -> AdvObject u a -> AdvObject u a+advfill sv mf = AdvObject $ \ctx pt -> +    let (a,_,ca) = getAdvObject mf ctx pt+        dav1     = DAV $ normalizeF (dc_font_size ctx) sv +    in (a,dav1,ca)  

@@ -21,8 +21,7 @@ module Wumpus.Basic.Kernel.Objects.Basis   ( -    PrimW(..)-  , primAnswer+    PrimResult    , Image   , Graphic @@ -45,14 +44,15 @@    , emptyImage --  , both-   , ignoreAns   , replaceAns    , Decorate(..)+  , sdecorate+  , adecorate +  , selaborate+  , aelaborate    ) where @@ -67,68 +67,15 @@ import Data.Monoid  ---- | Unit @u@ is a phantom.----data PrimW u a = PrimW CatPrim a--type instance DUnit (PrimW u a) = u---instance Monoid a => Monoid (PrimW u a) where-  mempty = PrimW mempty mempty-  PrimW ca a `mappend` PrimW cb b = PrimW (ca `mappend` cb) (a `mappend` b)--instance Functor (PrimW u) where-  fmap f (PrimW w a) = PrimW w (f a)---instance Applicative (PrimW u) where-  pure a                        = PrimW mempty a-  (PrimW c1 f) <*> (PrimW c2 a) = PrimW (c1 `mappend` c2) (f a) ---instance Monad (PrimW u) where-  return a            = PrimW mempty a-  (PrimW c1 a) >>= mf = let (PrimW c2 b) = mf a-                        in PrimW (c1 `mappend` c2) b---primAnswer :: PrimW u a -> a-primAnswer (PrimW _ a) = a----- | For the moment the second fun is type preserving...----bimapPrimW :: (CatPrim -> CatPrim) -> (a -> a) -> PrimW u a -> PrimW u a-bimapPrimW f g (PrimW ca a) = PrimW (f ca) (g a)----+type PrimResult u a = (a, CatPrim)   --- | Convert a PrimW where the answer is some functor type --- parametrized by the unit.----szconvPrimF :: (Functor t, InterpretUnit u, InterpretUnit u1)-            => FontSize -> PrimW u (t u)  -> PrimW u1 (t u1)-szconvPrimF sz (PrimW c a) = PrimW c (uconvertF sz a)----- | Convert a PrimW where the answer is oblivious to unit.----szconvPrimZ :: (InterpretUnit u, InterpretUnit u1)-            => FontSize -> PrimW u a  -> PrimW u1 a-szconvPrimZ _ (PrimW c a) = PrimW c a-- --------------------------------------------------------------------------------   newtype Image u a = Image { -          getImage :: DrawingContext -> PrimW u a }+          getImage :: DrawingContext -> (a, CatPrim) }  type instance DUnit (Image u a) = u @@ -152,7 +99,7 @@ -- Functor  instance Functor (Image u) where-  fmap f ma = Image $ \ctx -> fmap f $ getImage ma ctx+  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@@ -160,9 +107,10 @@ -- Applicative  instance Applicative (Image u) where-  pure a    = Image $ \_   -> pure a-  mf <*> ma = Image $ \ctx -> -                getImage mf ctx <*> getImage ma ctx+  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@@ -174,8 +122,10 @@ -- Monad  instance Monad (Image u) where-  return a = Image $ \_ -> return a-  ma >>= k = Image $ \ctx -> getImage ma ctx >>= \ans -> getImage (k ans) ctx+  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@@ -199,8 +149,8 @@   instance DrawingCtxM (Image u) where-  askDC           = Image $ \ctx -> return ctx-  asksDC fn       = Image $ \ctx -> return (fn ctx)+  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@@ -209,29 +159,28 @@   localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)  -runImage :: DrawingContext -> Image u a -> PrimW u a-runImage ctx mf = getImage mf ctx+runImage :: Image u a -> DrawingContext -> PrimResult u a+runImage = getImage -runQuery :: DrawingContext -> Query u a -> a-runQuery ctx mf = getQuery mf ctx+runQuery :: Query u a -> DrawingContext -> a+runQuery = getQuery    zapQuery :: Query u a -> Image u a-zapQuery mq = askDC >>= \ctx -> let a = runQuery ctx mq in return a+zapQuery ma = askDC >>= \ctx -> let a = runQuery ma ctx in return a  -- | Constructor for Primtive graphics. -- primGraphic :: CatPrim -> Graphic u-primGraphic ca = Image $ \_ -> PrimW ca UNil+primGraphic w = Image $ \_ -> (UNil, w)   -- | Clip an Image. --  clipImage :: PrimPath -> Image u a -> Image u a-clipImage pp ma = Image $ \ctx -> step (getImage ma ctx)-  where-    step (PrimW ca a) = PrimW (cpmap (clip pp) ca) a+clipImage pp ma = Image $ \ctx -> +     let (a,w) = getImage ma ctx in (a, cpmap (clip pp) w)   @@ -249,17 +198,14 @@ uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1)              => Image u (t u) -> Image u1 (t u1)  uconvImageF ma = Image $ \ctx -> -                   let sz  = dc_font_size ctx-                       ans = getImage ma ctx-                   in szconvPrimF sz ans+    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 -> -                   let sz  = dc_font_size ctx-                       ans = getImage ma ctx-                   in szconvPrimZ sz ans+uconvImageZ ma = Image $ \ctx -> getImage ma ctx   -- | Having /empty/ at the specific 'Image' type is useful.@@ -270,10 +216,7 @@ --------------------------------------------------------------------------------  -both :: Applicative f => f a -> f b -> f (a,b)-both fa fb = (,) <$> fa <*> fb - -- | Note - the kind of f allows fo unit annotation. -- ignoreAns :: Functor (f u) => f u a -> f u (UNil u)@@ -293,45 +236,57 @@ -- it with the graphic from the second. -- class Decorate (f :: * -> * -> *) where-  decorate   :: f u a -> f u z -> f u a-  elaborate  :: f u a -> (a -> f u z) -> f u a-  obliterate :: f u a -> f u z -> f u a+  decorate   :: ZDeco -> f u a -> f u z -> f u a+  elaborate  :: ZDeco -> f u a -> (a -> f u z) -> f u a+  obliterate :: f u a -> f u a   hyperlink  :: XLink -> f u a -> f u a  --- | Do not export...----getCatPrim :: PrimW u a -> CatPrim-getCatPrim (PrimW ca _) = ca+sdecorate :: Decorate f => f u a -> f u z -> f u a+sdecorate = decorate SUPERIOR --- | Should a decoration \"lift\" a query (Pure) to an image (PrimW)? ------ Currently I don\'t think it should.+adecorate :: Decorate f => f u a -> f u z -> f u a+adecorate = decorate ANTERIOR+++selaborate :: Decorate f => f u a -> (a -> f u z) -> f u a+selaborate = elaborate SUPERIOR++aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a+aelaborate = elaborate ANTERIOR+++++-- | Decorate Image. ---decorateImage :: Image u a -> Image u z -> Image u a-decorateImage ma mb = Image $ \ctx -> -    step (getImage ma ctx) (getImage mb ctx)+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 (PrimW ca a) (PrimW cb _) = PrimW (ca `mappend` cb) a+    step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)+    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)  --- |+-- | Elaborate Image. ---elaborateImage :: Image u a -> (a -> Image u z) -> Image u a-elaborateImage ma k = Image $ \ ctx -> case getImage ma ctx of -    PrimW ca a -> let cb = getCatPrim $ getImage (k a) ctx -                  in PrimW (ca `mappend` cb) a+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 z -> Image u a-obliterateImage ma mb = Image $ \ctx -> -    let a  = primAnswer $ getImage ma ctx-        ca = getCatPrim $ getImage mb ctx-    in PrimW ca a++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 (PrimW ca a) = PrimW (cpmap (xlinkPrim xl) ca) a+    step (a,w) = (a, cpmap (xlinkPrim xl) w)   @@ -350,77 +305,34 @@ -- Are PrimW instances needed as Image cannot use them? --  -instance Rotate a => Rotate (PrimW u a) where-  rotate ang (PrimW ca a) = PrimW (rotate ang ca) (rotate ang a)---instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => -    RotateAbout (PrimW u a) where-  rotateAbout ang pt@(P2 x y) (PrimW ca a) = -    PrimW (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) ca)-          (rotateAbout ang pt a) -        ---instance Scale a => Scale (PrimW u a) where-  scale sx sy (PrimW ca a) = PrimW (scale sx sy ca) (scale sx sy a)---instance (Translate a, ScalarUnit u, u ~ DUnit a) => -    Translate (PrimW u a) where-  translate dx dy (PrimW cp a) = -    PrimW (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) ------ Image--- Cannot use /fmap/ as it does not touch the CatPrim (w)-- instance Rotate a => Rotate (Image u a) where   rotate ang ma = Image $ \ctx -> -      bimapPrimW (rotate ang) (rotate ang) $ getImage ma 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-      in bimapPrimW (rotateAbout ang ptu) (rotateAbout ang pt) $ getImage ma 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 -> -      bimapPrimW (scale sx sy) (scale sx sy) $ getImage ma 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-      in bimapPrimW (translate ddx ddy) (translate dx dy) $ getImage ma ctx-----------------------------------------------------------------------------------------{----- OLD STUFF----- | Downcast a LocThetaQuery function by applying it to the --- supplied point and angle, making an arity-zero Context Function --- (a CF). ----atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a-atIncline = apply2R2+      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)   --} 

@@ -127,7 +127,7 @@ -- illustrateBoundedGraphic :: InterpretUnit u                          => Image u (BoundingBox u) -> Image u (BoundingBox u)-illustrateBoundedGraphic gf = elaborate gf bbrectangle+illustrateBoundedGraphic gf = aelaborate gf bbrectangle   @@ -136,9 +136,9 @@ illustrateBoundedLocGraphic :: InterpretUnit u                             => LocImage u (BoundingBox u)                              -> LocImage u (BoundingBox u)-illustrateBoundedLocGraphic gf = elaborate gf fn+illustrateBoundedLocGraphic gf = aelaborate gf fn   where-    fn bb = promoteLoc $ \_ ->bbrectangle bb+    fn bb = promoteLoc $ \_ -> bbrectangle bb   @@ -148,7 +148,7 @@ illustrateBoundedLocThetaGraphic :: InterpretUnit u                                  => LocThetaImage u (BoundingBox u)                                  -> LocThetaImage u (BoundingBox u)-illustrateBoundedLocThetaGraphic gf = elaborate gf fn+illustrateBoundedLocThetaGraphic gf = aelaborate gf fn   where     fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb 

@@ -19,16 +19,19 @@  module Wumpus.Basic.Kernel.Objects.Chain   (-    ChainAlg-  , IterationScheme   -  , chain-  , chain_-  -  , linearChain-  , prefixChain-  , iterationScheme+    GenChain+  , Chain+  , DChain+  , ChainScheme(..) +  , runChain+  , runChain_++  , cnext+  , setChainScheme++   , chainIterate   , chainH   , chainV@@ -42,184 +45,223 @@   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.Basic.Utils.HList  import Wumpus.Core                              -- package: wumpus-core +import Control.Applicative import Data.Monoid --- In TikZ chains are finite node list and iterated (infite) points  --- | Chain algorithm.+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. -- --- @Linear@ simply iterates points.+-- For instance, we might want to cache the origin - this would+-- not be possible if start was just a pure @cst@ value.  ----- @Prefix@ runs the left chain @n@ times then runs the right --- chain from the end point of the left chain.--- -data ChainAlg u = L1 (IterationScheme u)-                | PX Int (ChainAlg u) (ChainAlg u)+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 (ChainAlg u) = u +type instance DUnit (ChainSt st u) = u  -data IterationScheme u = forall st. Scheme -      { scheme_start    :: Point2 u -> st-      , scheme_step     :: st -> (st, Point2 u)-      }+-- Functor  -type instance DUnit (IterationScheme u) = u+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 --- | Note the tail of of result list is infinite.--- --- As any prefixes will be generated fully. This potentially--- produces a /space bubble/ where a long prefix has to be --- generated without the streaming of lazy evaluation. However,--- chains that are long enough to cause this problem will be --- problematic for a PostScript or SVG renderer.------ In short - don'\t make long chains.----interpChainAlg :: ChainAlg u -> Point2 u -> [Point2 u]-interpChainAlg ch start = go start ch-  where-    go pt (L1 (Scheme mk run)) = let st = mk pt in runInf run st-    go pt (PX n chl chr)       = let (af,end) = takeAndLast n (go pt chl)-                                 in prefixListH af $ go end chr+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)  -runInf :: (st -> (st,Point2 u)) -> st -> [Point2 u]-runInf fn = \st -> go (fn st) -  where-    go (st,a) = a : go (fn st) +-- 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)  --- | Take n elements - also return the last of element in the --- tuple so it can be accessed without a second traversal.------ Note @(n > 0)@ --- -takeAndLast :: Int -> [a] -> (H a,a)-takeAndLast _ []      = error "takeAndLast - empty list (unreachable?)"-takeAndLast n (a:as)  = go (wrapH a,a) (n-1) as-  where-    go (af,_) i (x:xs) | i > 0     = go (af `snocH` x, x) (i-1) xs-    go acc    _ _                  = acc+-- DrawingCtxM -emptyLoc :: LocGraphic u-emptyLoc = mempty+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 --- | Returns the end point...----chain :: InterpretUnit u-      => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u)-chain _   [] = promoteLoc $ \pt -> replaceAns pt (applyLoc emptyLoc pt)-chain alg fs = promoteLoc $ \pt -> -    let ps = interpChainAlg alg pt in go1 fs pt ps -  where-    go1 (gf:gs) _  (p:ps)     = go (ignoreAns $ applyLoc gf p) gs p ps-    go1 _       p0 _          = replaceAns p0 $ applyLoc emptyLoc p0 -    go acc (gf:gs) _  (p:ps)  = let g1 = ignoreAns $ applyLoc gf p-                                in go (acc `mappend` g1) gs  p ps-    go acc _       p0 _       = replaceAns p0 acc +-- UserStateM  --- | Returns no answer, just a 'LocGraphic'.-chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u-chain_ alg xs = fmap (const UNil) $ chain alg xs+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)  -linearChain :: IterationScheme u -> ChainAlg u-linearChain = L1 -prefixChain :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u-prefixChain n c1 c2 | n < 1     = c2-                    | otherwise = PX n c1 c2+-- 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) -iterationScheme :: (Point2 u -> st) -                -> (st -> (st, Point2 u)) -                -> IterationScheme u-iterationScheme start stepper = Scheme start stepper +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   -chainIterate :: (Point2 u -> Point2 u) -> ChainAlg u-chainIterate fn = L1 $ Scheme { scheme_start = id-                              , scheme_step  = \pt -> (fn pt, pt)-                              }+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 -chainH :: Num u => u -> ChainAlg u-chainH = L1 . scHorizontal -scHorizontal :: Num u => u -> IterationScheme u-scHorizontal dx = Scheme { scheme_start = id-                         , scheme_step  = \pt -> (displace (hvec dx) pt, pt)-                         }+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, ())+                }  -chainV :: Num u => u -> ChainAlg u-chainV = L1 . scVertical -scVertical :: Num u => u -> IterationScheme u-scVertical dy = Scheme { scheme_start = id-                       , scheme_step  = \pt -> (displace (vvec dy) pt, 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) -> ChainAlg u++tableRight :: Num u => Int -> (u,u) -> ChainScheme u tableRight num_cols (col_width,row_height) = -    L1 $ scStepper downF num_cols rightF+    scStepper downF num_cols rightF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width -tableDown :: Num u => Int -> (u,u) -> ChainAlg u+tableDown :: Num u => Int -> (u,u) -> ChainScheme u tableDown num_rows (col_width,row_height) = -    L1 $ scStepper rightF num_rows downF+    scStepper rightF num_rows downF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width  --- | Outer and inner steppers.----scStepper :: PointDisplace u -> Int -> PointDisplace u -> IterationScheme u-scStepper outF n innF = Scheme start step-  where-    start pt                      = (pt,pt,0)-    step  (ogin,pt,i) | i < n     = ((ogin, innF pt, i+1), pt)-                      | otherwise = let o1 = outF ogin -                                    in ((o1, innF o1,1), o1)  ----radialChain :: Floating u => u -> Radian -> Radian -> ChainAlg u-radialChain radius start step = L1 $ scCircular radius start step--   -scCircular :: Floating u => u -> Radian -> Radian -> IterationScheme u-scCircular radius angstart angseg = Scheme start step +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) = ((ogin,ang + angseg), displace (avec ang radius) ogin)+    start pt           = (pt,angstart)+    step  _ (ogin,ang) = (displace (avec ang radius) ogin, (ogin,ang + angi))++-- Note - radialChains stepper is oblivious to the previous point...  

@@ -58,7 +58,7 @@ -- end points to a polymorphic /answer/ and a graphic /primitive/. -- newtype ConnectorImage u a = ConnectorImage { -          getConnectorImage :: Point2 u -> Point2 u -> Image u a }+          getConnectorImage :: DPoint2 -> DPoint2 -> Image u a }   type instance DUnit (ConnectorImage u a) = u@@ -154,46 +154,58 @@   instance Decorate ConnectorImage where-  decorate ma mz = ConnectorImage $ \p0 p1 -> -                      getConnectorImage ma p0 p1 `decorate` -                        getConnectorImage mz p0 p1+  decorate zo ma mz = ConnectorImage $ \p0 p1 -> +    decorate zo (getConnectorImage ma p0 p1) (getConnectorImage mz p0 p1) -  elaborate ma f = ConnectorImage $ \p0 p1 -> -                     getConnectorImage ma p0 p1 `elaborate` -                       (\a -> getConnectorImage (f a) p0 p1)+  elaborate zo ma f = ConnectorImage $ \p0 p1 -> +    elaborate zo (getConnectorImage ma p0 p1) +                 (\a -> getConnectorImage (f a) p0 p1) -  obliterate ma mz = ConnectorImage $ \p0 p1 -> -                       getConnectorImage ma p0 p1 `obliterate` -                         getConnectorImage mz p0 p1+  obliterate ma = ConnectorImage $ \p0 p1 -> +    obliterate $ getConnectorImage ma p0 p1    hyperlink xl ma = ConnectorImage $ \p0 p1 -> -                       hyperlink xl $ getConnectorImage ma p0 p1+    hyperlink xl $ getConnectorImage ma p0 p1   -runConnectorImage :: Point2 u -> Point2 u -                  -> DrawingContext -> ConnectorImage u a -                  -> PrimW u a-runConnectorImage p0 p1 ctx mf = runImage ctx (getConnectorImage mf p0 p1)+runConnectorImage :: InterpretUnit u +                  => ConnectorImage u a -> DrawingContext +                  -> Point2 u -> Point2 u+                  -> PrimResult u a+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 :: Point2 u -> Point2 u -                  -> DrawingContext -> ConnectorQuery u a +runConnectorQuery :: ConnectorQuery u a -> DrawingContext +                  -> Point2 u -> Point2 u                    -> a-runConnectorQuery p0 p1 ctx mf = runQuery ctx (getConnectorQuery mf p0 p1)+runConnectorQuery ma ctx p0 p1 = runQuery (getConnectorQuery ma p0 p1) ctx  -connect :: Point2 u -> Point2 u -> ConnectorImage u a -> Image u a-connect p0 p1 mf = getConnectorImage mf p0 p1+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    -promoteConn :: (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a-promoteConn fn       = ConnectorImage $ \p0 p1 -> fn p0 p1+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 -applyConn :: ConnectorImage u a -> Point2 u -> Point2 u -> Image u a-applyConn mf p0 p1   = getConnectorImage mf p0 p1+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   qpromoteConn :: (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a@@ -206,8 +218,8 @@ -- | \"zero-apply\" a Connector. -- zapConnectorQuery :: ConnectorQuery u a -> Point2 u -> Point2 u -> Image u a-zapConnectorQuery mq p0 p1  = askDC >>= \ctx -> -    let a = runConnectorQuery p0 p1 ctx mq in return a+zapConnectorQuery ma p0 p1  = askDC >>= \ctx -> +    let a = runConnectorQuery ma ctx p0 p1 in return a   @@ -222,10 +234,7 @@ uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)                       => ConnectorImage u (t u) -> ConnectorImage u1 (t u1) uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> -    getFontSize >>= \sz -> -    let p0u = uconvertF sz p0-        p1u = uconvertF sz p1-    in uconvImageF $ getConnectorImage ma p0u p1u+    uconvF $ getConnectorImage ma p0 p1   @@ -235,10 +244,7 @@ uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1)                       => ConnectorImage u a -> ConnectorImage u1 a uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> -    getFontSize >>= \sz -> -    let p0u = uconvertF sz p0-        p1u = uconvertF sz p1-    in uconvImageZ $ getConnectorImage ma p0u p1u+    uconvZ $ getConnectorImage ma p0 p1  -- | Having /empty/ at the specific 'ConnectorImage' type is useful. -- 

@@ -130,7 +130,7 @@ -- drawTracing :: TraceDrawing u a -> CtxPicture drawTracing mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx  -- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @ --@@ -141,10 +141,10 @@ -- udrawTracing :: u -> TraceDrawing u a -> CtxPicture udrawTracing _ mf = -    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf-+    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing mf ctx  +-- Note need Gen versions with user state...   -- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @@@ -256,22 +256,9 @@                in pl `picOver` (picMoveBy pr v1)  ----- | > a `oplus` b--- --- Place \'drawing\' a over b. The idea of @over@ here is in --- terms z-ordering, nither picture a or b are actually moved.----instance OPlus CtxPicture where-  oplus = moveSnd $ \_ _ -> V2 0 0---- instance ZConcat CtxPicture where-  superior = oplus-  anterior = flip oplus+  superior = mappend+  anterior = flip mappend  -------------------------------------------------------------------------------- -- Composition@@ -371,9 +358,9 @@ -- of @a@ and align it with the top, center or bottom of @a@. --  cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignH HTop     = moveSnd $ \a b -> northeast a .-. northwest b-cxpAlignH HCenter  = moveSnd $ \a b -> east a .-. west b-cxpAlignH HBottom  = moveSnd $ \a b -> southeast a .-. southwest b+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@@ -382,9 +369,9 @@ -- and align it with the left, center or right of @a@. --  cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture-cxpAlignV VLeft    = moveSnd $ \a b -> southwest a .-. northwest b-cxpAlignV VCenter  = moveSnd $ \a b -> south a .-. north b-cxpAlignV VRight   = moveSnd $ \a b -> southeast a .-. northeast b+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   @@ -400,10 +387,10 @@ 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 HTop    = mv northeast northwest-    go HCenter = mv east west -    go HBottom = mv southeast southwest+    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@@ -414,8 +401,8 @@ 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 VLeft   = mv southwest northwest -    go VCenter = mv south north  -    go VRight  = mv southeast northeast +    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  

@@ -37,7 +37,6 @@   , dcEscapedlabel   , dcREscapedlabel -  , KernChar   , hkernLine   , vkernLine @@ -70,7 +69,6 @@ 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 @@ -312,9 +310,6 @@   --- | Unit parametric version of KerningChar from Wumpus-Core.----type KernChar u = (u,EscapedChar)  uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar] uconvKernChar = mapM mf

@@ -35,6 +35,7 @@    , qpromoteLoc    , qapplyLoc    , zapLocQuery+   , extrLoc     , emptyLocImage @@ -76,7 +77,7 @@ -- /primitive/ (PrimW). -- newtype LocImage u a = LocImage { -          getLocImage :: Point2 u -> Image u a }+          getLocImage :: DPoint2 -> Image u a }  type instance DUnit (LocImage u a) = u @@ -157,32 +158,33 @@     instance Decorate LocImage where-  decorate ma mz = LocImage $ \pt -> -                      getLocImage ma pt `decorate` getLocImage mz pt +  decorate zo ma mz = LocImage $ \pt -> +    decorate zo (getLocImage ma pt) (getLocImage mz pt) -  elaborate ma f = LocImage $ \pt -> -                      getLocImage ma pt `elaborate` (\a -> getLocImage (f a) pt)+  elaborate zo ma f = LocImage $ \pt -> +    elaborate zo (getLocImage ma pt) (\a -> getLocImage (f a) pt) -  obliterate ma mz = LocImage $ \pt -> -                       getLocImage ma pt `obliterate` getLocImage mz pt +  obliterate ma = LocImage $ \pt -> obliterate $ getLocImage ma pt  -  hyperlink xl ma = LocImage $ \pt -> -                       hyperlink xl $ getLocImage ma pt +  hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt   -runLocImage :: Point2 u -> DrawingContext -> LocImage u a -> PrimW u a-runLocImage pt ctx mf = runImage ctx (getLocImage mf pt)+runLocImage :: InterpretUnit u +            => LocImage u a -> DrawingContext -> Point2 u -> PrimResult u a+runLocImage ma ctx pt = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runImage (getLocImage ma dpt) ctx -runLocQuery :: Point2 u -> DrawingContext -> LocQuery u a -> a-runLocQuery pt ctx mf = runQuery ctx (getLocQuery mf pt)+runLocQuery :: LocQuery u a -> DrawingContext -> Point2 u -> a+runLocQuery ma ctx pt = runQuery (getLocQuery ma pt) ctx   -promoteLoc ::  (Point2 u -> Image u a) -> LocImage u a-promoteLoc k = LocImage $ \pt -> k pt+promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= \upt -> k upt -applyLoc :: LocImage u a -> Point2 u -> Image u a-applyLoc mq pt = getLocImage mq pt+applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a+applyLoc mq pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mq dpt   qpromoteLoc :: (Point2 u -> Query u a) -> LocQuery u a@@ -192,13 +194,26 @@ qapplyLoc mq pt = getLocQuery mq pt  +-- | 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  -- | \"zero-apply\" a LocQuery. -- zapLocQuery :: LocQuery u a -> Point2 u -> Image u a-zapLocQuery mq pt = askDC >>= \ctx -> let a = runLocQuery pt ctx mq in return a+zapLocQuery ma pt = askDC >>= \ctx -> +                    let a = runLocQuery ma ctx pt in return a   @@ -218,27 +233,35 @@ -------------------------------------------------------------------------------- -- Affine instances -instance (Real u, Floating u, Rotate a) => Rotate (LocImage u a) where+instance (Real u, Floating u, InterpretUnit u, Rotate a) => +    Rotate (LocImage u a) where   rotate ang ma = promoteLoc $ \pt -> -                     fmap (rotate ang) $ getLocImage ma (rotate ang pt)+                     zapQuery (normalizeCtxF pt) >>= \dpt ->  +                     fmap (rotate ang) $ getLocImage ma (rotate ang dpt)  -instance (Real u, Floating u, RotateAbout a, ScalarUnit u, u ~ DUnit a) => +instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) =>      RotateAbout (LocImage u a) where-  rotateAbout ang pt ma = promoteLoc $ \p0 -> +  rotateAbout ang pt ma = promoteLoc $ \p0 ->+                            zapQuery (normalizeCtxF p0) >>= \dp0 ->  +                            zapQuery (normalizeCtxF pt) >>= \dpt ->                               fmap (rotateAbout ang pt) $ -                              getLocImage ma (rotateAbout ang pt p0)+                              getLocImage ma (rotateAbout ang dpt dp0)  -instance (Fractional u, Scale a) => Scale (LocImage u a) where+instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where   scale sx sy ma = promoteLoc $ \pt -> -                   fmap (scale sx sy) $ getLocImage ma (scale sx sy pt)+                     zapQuery (normalizeCtxF pt) >>= \dpt -> +                     fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt) -instance (Num u, Translate a, ScalarUnit u, u ~ DUnit a) => +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 dx dy pt)+                             getLocImage ma (translate ddx ddy dpt)  -------------------------------------------------------------------------------- @@ -252,10 +275,7 @@ -- uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)                 => LocImage u (t u) -> LocImage u1 (t u1)-uconvLocImageF ma = LocImage $ \pt -> -    getFontSize >>= \sz -> -    let ptu = uconvertF sz pt-    in uconvF $ getLocImage ma ptu+uconvLocImageF ma = LocImage $ \pt -> uconvF $ getLocImage ma pt   @@ -263,10 +283,7 @@ -- uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1)                 => LocImage u a -> LocImage u1 a-uconvLocImageZ ma = LocImage $ \pt -> -    getFontSize >>= \sz ->  -    let ptu = uconvertF sz pt-    in uconvZ $ getLocImage ma ptu+uconvLocImageZ ma = LocImage $ \pt -> uconvZ $ getLocImage ma pt   -- | Having /empty/ at the specific 'LocImage' type is useful.@@ -280,8 +297,9 @@ -- Note - maybe this should just be an operator on LocImage... -- -moveStart :: Num u => Vec2 u -> LocImage u a -> LocImage u a-moveStart v1 ma = LocImage $ \pt -> getLocImage ma (pt .+^ v1) +moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a+moveStart v1 ma = LocImage $ \pt -> +    zapQuery (normalizeCtxF v1) >>= \dv -> getLocImage ma (pt .+^ dv)    @@ -291,8 +309,8 @@ -- | Downcast a 'LocImage' function by applying it to the supplied  -- point, making an 'Image'.  -- -at :: LocImage u a -> Point2 u -> Image u a-at mf pt = getLocImage mf pt+at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a+at mf pt = zapQuery (normalizeCtxF pt) >>= \dpt -> getLocImage mf dpt   --------------------------------------------------------------------------------

@@ -61,7 +61,7 @@ -- /primitive/ (PrimW). -- newtype LocThetaImage u a = LocThetaImage { -          getLocThetaImage :: Point2 u -> Radian -> Image u a }+          getLocThetaImage :: DPoint2 -> Radian -> Image u a }  type instance DUnit (LocThetaImage u a) = u @@ -152,41 +152,46 @@ --  instance Decorate LocThetaImage where-  decorate ma mz = LocThetaImage $ \pt ang -> -                      getLocThetaImage ma pt ang `decorate` -                        getLocThetaImage mz pt ang+  decorate zo ma mz = LocThetaImage $ \pt ang -> +    decorate zo (getLocThetaImage ma pt ang) (getLocThetaImage mz pt ang) -  elaborate ma f = LocThetaImage $ \pt ang -> -                     getLocThetaImage ma pt ang `elaborate` -                       (\a -> getLocThetaImage (f a) pt ang)+  elaborate zo ma f = LocThetaImage $ \pt ang -> +    elaborate zo (getLocThetaImage ma pt ang) +                 (\a -> getLocThetaImage (f a) pt ang) -  obliterate ma mz = LocThetaImage $ \pt ang -> -                       getLocThetaImage ma pt ang `obliterate` -                         getLocThetaImage mz pt ang+  obliterate ma = LocThetaImage $ \pt ang -> +    obliterate $ getLocThetaImage ma pt ang    hyperlink xl ma = LocThetaImage $ \pt ang -> -                       hyperlink xl $ getLocThetaImage ma pt ang+    hyperlink xl $ getLocThetaImage ma pt ang               -runLocThetaImage :: Point2 u -> Radian -> DrawingContext -                 -> LocThetaImage u a -                 -> PrimW u a-runLocThetaImage pt incl ctx mf = runImage ctx (getLocThetaImage mf pt incl)+runLocThetaImage :: InterpretUnit u +                 => LocThetaImage u a -> DrawingContext +                 -> Point2 u -> Radian+                 -> PrimResult u a+runLocThetaImage ma ctx pt incl = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runImage (getLocThetaImage ma dpt incl) ctx  -runLocThetaQuery :: Point2 u -> Radian -> DrawingContext -                 -> LocThetaQuery u a +runLocThetaQuery :: LocThetaQuery u a -> DrawingContext +                 -> Point2 u -> Radian                    -> a-runLocThetaQuery pt incl ctx mf = runQuery ctx (getLocThetaQuery mf pt incl)+runLocThetaQuery ma ctx pt incl = runQuery (getLocThetaQuery ma pt incl) ctx  -promoteLocTheta ::  (Point2 u -> Radian -> Image u a) -> LocThetaImage u a-promoteLocTheta k = LocThetaImage $ \pt ang -> k 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 -applyLocTheta :: LocThetaImage u a -> Point2 u -> Radian -> Image u a-applyLocTheta mq pt ang = getLocThetaImage mq pt 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   qpromoteLocTheta :: (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a@@ -199,11 +204,12 @@ -- | \"zero-apply\" a LocThetaQuery. -- zapLocThetaQuery :: LocThetaQuery u a -> Point2 u -> Radian -> Image u a-zapLocThetaQuery mq pt ang = askDC >>= \ctx -> -    let a = runLocThetaQuery pt ang ctx mq in return a+zapLocThetaQuery ma pt ang = askDC >>= \ctx -> +    let a = runLocThetaQuery ma ctx pt ang in return a   + instance UConvert LocThetaImage where   uconvF = uconvLocThetaImageF   uconvZ = uconvLocThetaImageZ@@ -215,9 +221,7 @@ uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t)                      => LocThetaImage u (t u) -> LocThetaImage u1 (t u1) uconvLocThetaImageF ma = LocThetaImage $ \pt ang -> -    getFontSize >>= \sz -> -    let ptu = uconvertF sz pt-    in uconvF $ getLocThetaImage ma ptu ang+    uconvF $ getLocThetaImage ma pt ang   @@ -227,9 +231,7 @@ uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1)                      => LocThetaImage u a -> LocThetaImage u1 a uconvLocThetaImageZ ma = LocThetaImage $ \pt ang -> -    getFontSize >>= \sz -> -    let ptu = uconvertF sz pt-    in uconvZ $ getLocThetaImage ma ptu ang+    uconvZ $ getLocThetaImage ma pt ang   @@ -248,8 +250,12 @@ -- | Downcast a 'LocThetaImage' function by applying it to the  -- supplied angle, making a 'LocImage'.  -- -incline :: LocThetaImage u a -> Radian -> LocImage u a-incline ma incl = promoteLoc $ \pt -> getLocThetaImage ma pt incl+incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a+incline ma incl = promoteLoc $ \pt -> +                    zapQuery (normalizeCtxF pt) >>= \dpt ->+                    getLocThetaImage ma dpt incl -atIncline :: LocThetaImage u a -> Point2 u -> Radian -> Image u a-atIncline ma pt incl = getLocThetaImage ma pt 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

@@ -23,8 +23,13 @@     RectAddress(..)   , Orientation(..) -  , orientationStart+  , vtoRectAddress+  , vtoOrigin   , orientationBounds+  , orientationWidth+  , orientationHeight++  , rotateOrientation     , extendOrientation   , extendOLeft@@ -32,12 +37,12 @@   , extendODown   , extendOUp -  , padHEven-  , padXMinor-  , padXMajor-  , padVEven-  , padYMajor-  , padYMinor+  , fillHEven+  , fillXMinor+  , fillXMajor+  , fillVEven+  , fillYMajor+  , fillYMinor    , spineRight   , spineBelow@@ -61,16 +66,26 @@   ) where  -import Wumpus.Basic.Kernel.Base.BaseDefs  import Wumpus.Core                              -- package: wumpus-core +import Data.VectorSpace                         -- package: vector-space+ import Data.Monoid  -- | Datatype enumerating the addressable positions of a rectangle  -- that can be derived for a 'PosObject'.   ---data RectAddress = CENTER +-- The positions are the compass points, plus the geometric +-- center, origin and the baseline positions: +-- +-- > BLL - baseline-left+--+-- > BLC - baseline-center +-- +-- > BLR - baseline-right+--+data RectAddress = CENTER | ORIGIN                  | NN | SS | EE | WW | NE | NW | SE | SW                   | BLL | BLC | BLR   deriving (Enum,Eq,Ord,Show)@@ -111,75 +126,77 @@   fmap f (Orientation xmin xmaj ymin ymaj) =      Orientation (f xmin) (f xmaj) (f ymin) (f ymaj) -instance (Fractional u, Ord u) => OPlus (Orientation u) where-  oplus = concatOrientation -+-- | Concatenation coalesces the origins.+-- instance (Fractional u, Ord u) => Monoid (Orientation u) where   mempty  = Orientation 0 0 0 0-  mappend = concatOrientation---- | Concatenation here essentially turns both Orientation objects--- into /center-form/ then finds the maximum rectangle.----concatOrientation :: (Fractional u, Ord u) -                => Orientation u -> Orientation u -> Orientation u-concatOrientation op0 op1 = Orientation hw hw hh hh-  where-    (hw0,hh0) = halfDists op0-    (hw1,hh1) = halfDists op1-    hw        = max hw0 hw1-    hh        = max hh0 hh1--+  a `mappend` b = +     Orientation { or_x_minor = max (or_x_minor a) (or_x_minor b)+                 , or_x_major = max (or_x_major a) (or_x_major b)+                 , or_y_minor = max (or_y_minor a) (or_y_minor b)+                 , or_y_major = max (or_y_major a) (or_y_major b)+                 }  --- | Find the half-width and half-height of an Orientation.--- --- Essentially this is /center-form/ of an Orientation, but --- in /center-form/ there is duplication: ------ > xminor == xmajor--- > yminor == ymajor--- --- So instead, the result type is just a pair.----halfDists :: Fractional u => Orientation u -> (u,u)-{-# INLINE halfDists #-}-halfDists (Orientation xmin xmaj ymin ymaj) = -    (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj))+-- Helper types for calculating vector from Origin +-- (not exported). +data HDist = HCENTER | HLEFT | HRIGHT+  deriving (Eq,Ord,Show) +data VDist = VCENTER | VBASE | VTOP+  deriving (Eq,Ord,Show)   --- | The vector from a 'RectAddress' to the start point.+-- | The vector from a origin ro a 'RectAddress'. ---orientationStart :: Fractional u => RectAddress -> Orientation u -> Vec2 u-orientationStart rpos (Orientation xmin xmaj ymin ymaj) = go rpos+vtoRectAddress :: (Fractional u, Ord u) +               => Orientation u -> RectAddress -> Vec2 u+vtoRectAddress (Orientation xmin xmaj ymin ymaj) = go   where-    w         = xmin + xmaj-    h         = ymin + ymaj-    hw        = 0.5 * w-    hh        = 0.5 * h+    hw        = 0.5  * (xmin + xmaj)+    hh        = 0.5  * (ymin + ymaj)         -- CENTER, NN, SS, EE, WW all go to bottomleft then add back      -- the minors. -    go CENTER = V2 ((-hw) + xmin) ((-hh) + ymin)-    go NN     = V2 ((-hw) + xmin) ((-h)  + ymin)-    go SS     = V2 ((-hw) + xmin)   ymin-    go EE     = V2 ((-w)  + xmin) ((-hh) + ymin)-    go WW     = V2 xmin           ((-hh) + ymin)-    go NE     = V2 (-xmaj)        (-ymaj)-    go SE     = V2 (-xmaj)          ymin-    go SW     = V2 xmin             ymin-    go NW     = V2 xmin           (-ymaj)-    go BLL    = V2 xmin             0-    go BLC    = V2 ((-hw) + xmin)   0-    go BLR    = V2 ((-w)  + xmin)   0 +    go CENTER = V2 (hdist HCENTER) (vdist VCENTER)+    go ORIGIN = zeroVec+    go NN     = V2 (hdist HCENTER) (vdist VTOP)+    go SS     = V2 (hdist HCENTER) (vdist VBASE)+    go EE     = V2 (hdist HRIGHT)  (vdist VCENTER)+    go WW     = V2 (hdist HLEFT)   (vdist VCENTER)+    go NE     = V2 (hdist HRIGHT)  (vdist VTOP)+    go SE     = V2 (hdist HRIGHT)  (vdist VBASE)+    go SW     = V2 (hdist HLEFT)   (vdist VBASE)+    go NW     = V2 (hdist HLEFT)   (vdist VTOP)+    go BLL    = V2 (hdist HLEFT)   0+    go BLC    = V2 (hdist HCENTER) 0+    go BLR    = V2 (hdist HRIGHT)  0  +    -- > [..o..^.....]  , o -> ^+    --+    hdist HCENTER = if xmin < xmaj then hw - xmin else negate (xmin - hw) +    -- > [..o..^.....]  , o -> [+    --+    hdist HLEFT   = negate xmin+    +    -- > [..o..^.....]  , o -> ]+    --+    hdist HRIGHT  = xmaj++    vdist VCENTER = if ymin < ymaj then hh - ymin else negate (ymin - hh)+    vdist VBASE   = negate ymin+    vdist VTOP    = ymaj+++vtoOrigin :: (Fractional u, Ord u) +          => RectAddress -> Orientation u -> Vec2 u+vtoOrigin addr ortt = negateV $ vtoRectAddress ortt addr+ -- | Calculate the bounding box formed by locating the 'Orientation' -- at the supplied point. -- @@ -191,7 +208,54 @@     urc   = P2 (x+xmaj) (y+ymaj)  +-- | Height of the orientation.+--+orientationWidth :: Num u => Orientation u -> u+orientationWidth (Orientation xmin xmaj _ _) = xmin + xmaj++-- | Height of the orientation.+--+orientationHeight :: Num u => Orientation u -> u+orientationHeight (Orientation _ _ ymin ymaj) = ymin + ymaj+ --------------------------------------------------------------------------------+-- Rotation++-- | Rotate an Orientation about its origin (locus).+--+rotateOrientation :: (Real u, Floating u, Ord u) +               => Radian -> Orientation u -> Orientation u+rotateOrientation ang (Orientation { or_x_minor = xmin+                                   , or_x_major = xmaj+                                   , or_y_minor = ymin+                                   , or_y_major = ymaj }) = +    orthoOrientation bl br tl tr  +  where+    bl  = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin)+    br  = rotateAbout ang zeroPt $ P2   xmaj  (-ymin)+    tr  = rotateAbout ang zeroPt $ P2   xmaj    ymaj+    tl  = rotateAbout ang zeroPt $ P2 (-xmin)   ymaj+  ++orthoOrientation :: (Num u, Ord u)+                 => Point2 u -> Point2 u -> Point2 u -> Point2 u +                 -> Orientation u+orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = +    Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3+                , or_x_major = max4 x0 x1 x2 x3+                , or_y_minor = abs $ min4 y0 y1 y2 y3+                , or_y_major = max4 y0 y1 y2 y3+                }+++min4 :: Ord u => u -> u -> u -> u -> u+min4 a b c d = min (min a b) (min c d)++max4 :: Ord u => u -> u -> u -> u -> u+max4 a b c d = max (max a b) (max c d)+++-------------------------------------------------------------------------------- -- Extending an arm of the orientation  extendOrientation :: Num u @@ -218,10 +282,12 @@   --------------------------------------------------------------------------------+-- Note these are fills not pads... -padHEven :: (Fractional u, Ord u) ++fillHEven :: (Fractional u, Ord u)            => u -> Orientation u -> Orientation u-padHEven w ortt@(Orientation xmin xmaj _ _) = +fillHEven w ortt@(Orientation xmin xmaj _ _) =      if w > ow then ortt { or_x_minor = xmin + hdx                         , or_x_major = xmaj + hdx }                else ortt@@ -230,25 +296,25 @@     hdx = 0.5 * (w - ow)  -padXMinor :: (Num u, Ord u) +fillXMinor :: (Num u, Ord u)            => u -> Orientation u -> Orientation u-padXMinor w ortt@(Orientation xmin xmaj _ _) = +fillXMinor w ortt@(Orientation xmin xmaj _ _) =      if w > ow then ortt { or_x_minor = xmin + dx } else ortt   where     ow = xmin + xmaj     dx = w - ow -padXMajor :: (Num u, Ord u)+fillXMajor :: (Num u, Ord u)          => u -> Orientation u -> Orientation u-padXMajor w ortt@(Orientation xmin xmaj _ _) = +fillXMajor w ortt@(Orientation xmin xmaj _ _) =      if w > ow then ortt { or_x_major = xmaj + dx } else ortt   where     ow = xmin + xmaj     dx = w - ow -padVEven :: (Fractional u, Ord u) +fillVEven :: (Fractional u, Ord u)            => u -> Orientation u -> Orientation u-padVEven h ortt@(Orientation _ _ ymin ymaj) = +fillVEven h ortt@(Orientation _ _ ymin ymaj) =      if h > oh then ortt { or_y_minor = ymin + hdy                         , or_y_major = ymaj + hdy }                else ortt@@ -256,18 +322,18 @@     oh = ymin + ymaj     hdy = 0.5 * (h - oh) -padYMinor :: (Num u, Ord u) +fillYMinor :: (Num u, Ord u)           => u -> Orientation u -> Orientation u-padYMinor h ortt@(Orientation _ _ ymin ymaj) = +fillYMinor h ortt@(Orientation _ _ ymin ymaj) =      if h > oh then ortt { or_y_minor = ymin + dy } else ortt   where     oh = ymin + ymaj     dy = h - oh  -padYMajor :: (Num u, Ord u) +fillYMajor :: (Num u, Ord u)         => u -> Orientation u -> Orientation u-padYMajor h ortt@(Orientation _ _ ymin ymaj) = +fillYMajor h ortt@(Orientation _ _ ymin ymaj) =      if h > oh then ortt { or_y_major = ymaj + dy } else ortt   where     oh = ymin + ymaj@@ -407,12 +473,12 @@ -------------------------------------------------------------------------------- -- Binary start pos displacement +-- Note - these can be made a lot clearer...+ upDown :: Num u => u -> u -> u-{-# INLINE upDown #-} upDown u d = u - d  downUp :: Num u => u -> u -> u-{-# INLINE downUp #-} downUp d u = negate d + u  -- | Move second right.@@ -461,12 +527,10 @@   leftRight :: Num u => u -> u -> u-{-# INLINE leftRight #-} leftRight l r = negate l + r   rightLeft :: Num u => u -> u -> u-{-# INLINE rightLeft #-} rightLeft r l = r - l  

@@ -29,23 +29,49 @@     PosObject   , DPosObject +  , PosGraphic+  , DPosGraphic    -- * Operations   , runPosObject+  , runPosObjectBBox    , makePosObject---  , makeBindPosObject   , emptyPosObject +  , elaboratePosObject+  , decoratePosObject -  , localPosObject-  , decoPosObject   , extendPosObject   , mapOrientation    , illustratePosObject +  , posChar+  , posEscChar +  , posCharUpright+  , posEscCharUpright+  +  , posCharPrim +  , posText+  , posEscText +  , posTextUpright+  , posEscTextUpright++  , posTextPrim++  , multilinePosText+  , multilinePosEscText++  , rposText+  , rposEscText++  , posHKernText++  , monospaceText+  , monospaceEscText+   ) where  @@ -58,6 +84,7 @@ import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.DrawingPrimitives import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Basic.Kernel.Objects.Orientation  import Wumpus.Core                              -- package: wumpus-core@@ -69,81 +96,103 @@ import Control.Applicative import Data.Monoid +type DOrt = Orientation Double --- | Helper for PosObject - a LocImage that is /pre-applied/ to --- the DrawingContext.+-- | A positionable \"Object\". ----- This is somewhat contrived, but the orientation and the result--- graphic from a PosImage have to be generated within the same --- DrawingContext.+newtype PosObject u a = PosObject +          { getPosObject :: DrawingContext -> DPoint2 -> (a, DOrt, CatPrim) }++type instance DUnit (PosObject u a) = u+    +-- | Version of PosObject specialized to Double for the unit type. ---type PosDraw u = Point2 u -> CatPrim+type DPosObject a = PosObject Double a  --- | A positionable \"Object\" that is drawn as a --- 'BoundedLocGraphic'.+-- | Version of PosObject with answer specialized to UNil. ---newtype PosObject u = PosObject -          { getPosObject :: Query u (Orientation u, PosDraw u) }+type PosGraphic u = PosObject u (UNil u) -type instance DUnit (PosObject u) = u-    --- | Version of PosObject specialized to Double for the unit type.+-- | Version of PosGraphic specialized to Double for the unit type. ---type DPosObject = PosObject Double+type DPosGraphic = PosGraphic Double    +instance Functor (PosObject u) where+  fmap f mf = PosObject $ \ctx pt -> +              let (a,o1,w1) = getPosObject mf ctx pt in (f a,o1,w1) --------------------------------------------------------------------------------- +instance Applicative (PosObject u) where+  pure a    = PosObject $ \_   _  -> (a,mempty,mempty)+  mf <*> ma = PosObject $ \ctx pt -> +              let (f,o1,w1) = getPosObject mf ctx pt+                  (a,o2,w2) = getPosObject ma ctx pt+              in (f a, o1 `mappend` o2, w1 `mappend` w2)  -instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where-  mempty  = emptyPosObject-  mappend = poconcat +instance Monad (PosObject u) where+  return a  = PosObject $ \_   _  -> (a,mempty,mempty)+  mf >>= k  = PosObject $ \ctx pt -> +              let (a,o1,w1) = getPosObject mf ctx pt+                  (b,o2,w2) = getPosObject (k a) ctx pt+              in (b, o1 `mappend` o2, w1 `mappend` w2)  -poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u-poconcat a b = PosObject body-   where-    body = askDC >>= \ctx ->-           let ans1 = runQuery ctx (getPosObject a)-               ans2 = runQuery ctx (getPosObject b)-           in pure (appendW ans1 ans2) +instance DrawingCtxM (PosObject u) where+  askDC           = PosObject $ \ctx _ -> (ctx, mempty, mempty)+  asksDC fn       = PosObject $ \ctx _ -> (fn ctx, mempty, mempty)+  localize upd ma = PosObject $ \ctx pt -> getPosObject ma (upd ctx) pt  -appendW :: (Fractional u, Ord u)-        => (Orientation u, PosDraw u) -        -> (Orientation u, PosDraw u) -        -> (Orientation u, PosDraw u)-appendW (o0,pf0) (o1,pf1) = let pf = \pt -> pf0 pt `mappend` pf1 pt-                            in (o0 `mappend` o1, pf)  +instance (Monoid a, InterpretUnit u) => Monoid (PosObject u a) where+  mempty = PosObject $ \_ _ -> (mempty, mempty, mempty)+  ma `mappend` mb = PosObject $ \ctx pt -> +                    let (a,o1,w1) = getPosObject ma ctx pt+                        (b,o2,w2) = getPosObject mb ctx pt+                    in (a `mappend` b, o1 `mappend` o2, w1 `mappend` w2) --- | Version of 'runPosObject' that produces a --- 'LocImage' that returns a bounding box. --- --- The 'PosObject' is run with only rect-address as an explicit --- argument (start-point is implicit). The corresponding answer is --- an /arity one/ Graphic that needs drawing with the start-point.+++-- | Running an PosObject produces a LocImage. ---runPosObject :: Fractional u -             => RectAddress -> PosObject u -> LocImage u (BoundingBox u)-runPosObject addr (PosObject mf) = promoteLoc $ \pt ->-   askDC >>= \ctx -> -   let (o1,df) = runQuery ctx mf-       v1      = orientationStart addr o1-       p1      = pt .+^ v1-       bb      = orientationBounds o1 p1-   in replaceAns bb $ primGraphic (df p1)+runPosObject :: InterpretUnit u +             => PosObject u a -> RectAddress -> LocImage u a+runPosObject ma addr = promoteLoc $ \ot -> +    askDC >>= \ctx -> +    let dot       = normalizeF (dc_font_size ctx) ot+        (a,o1,ca) = getPosObject ma ctx dot+        v1        = vtoOrigin addr o1+    in replaceAns a $ primGraphic $ cpmove v1 ca   +-- | Run a PosObject producing a LocImage (BoundingBox u).+--+runPosObjectBBox :: InterpretUnit u +                 => PosObject u a -> RectAddress -> LocImage u (BoundingBox u)+runPosObjectBBox ma addr = promoteLoc $ \pt -> +    askDC >>= \ctx -> +    let sz        = dc_font_size ctx +        dpt       = normalizeF sz pt+        (_,o1,w1) = getPosObject ma ctx dpt+        v1        = vtoOrigin addr o1+        bb        = dinterpF sz $ orientationBounds o1 (dpt .+^ v1)+    in replaceAns bb $ primGraphic $ cpmove v1 w1+++++--------------------------------------------------------------------------------++ -- | 'makePosObject' : @ object_pos * loc_image -> PosObject @  -- -- Create a 'PosObject' from an 'Orientation' describing how it@@ -154,69 +203,83 @@ -- PosObject type is considered as a specialized object it does -- not have the range of functions of LocImage or LocThetaImage. -- -makePosObject :: Query u (Orientation u) -> LocGraphic u -> PosObject u-makePosObject qortt gf = PosObject body-  where-    body = askDC >>= \ctx -> -           let v1   = runQuery ctx qortt-               pf   = \pt -> getCP $ runLocImage pt ctx gf-           in return (v1,pf)--    getCP (PrimW ca _) = ca+makePosObject :: InterpretUnit u+              => Query u (Orientation u) -> LocImage u a -> PosObject u a+makePosObject ma gf = PosObject $ \ctx pt -> +    let ort1  = runQuery ma ctx+        dort1 = normalizeF (dc_font_size ctx) ort1+        upt   = dinterpF (dc_font_size ctx) pt+        (a,w) = runLocImage gf ctx upt+    in (a,dort1,w)   -- | 'emptyPosObject' : @ PosObject @ -- -- Build an empty 'PosGraphicObject'. ---emptyPosObject :: InterpretUnit u => PosObject u-emptyPosObject = PosObject $ pure (Orientation 0 0 0 0, const mempty)+emptyPosObject :: (Monoid a, InterpretUnit u) => PosObject u a+emptyPosObject = PosObject $ \_ _ -> (mempty, mempty, mempty)        ----- | Apply a DrawingContext update to a 'PosObject'. ---localPosObject :: DrawingContextF -> PosObject u -> PosObject u-localPosObject upd = PosObject . localize upd . getPosObject+-- decorate  - oblivious to /answer/.+-- elaborate - derives annotation from the /answer/ and makes a +--             cumulative graphic.+--  -decoPosObject :: (Orientation u -> LocGraphic u) -> ZDeco -              -> PosObject u -> PosObject u-decoPosObject fn zdec po = PosObject body+elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)+                   => ZDeco -> RectAddress -> LocGraphic u -> PosObject u a+                   -> PosObject u a+elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma   where-    body = askDC >>= \ctx -> -           let (ortt,ptf) = runQuery ctx (getPosObject po)-               deco       = \pt -> getCP $ runLocImage pt ctx (fn ortt)-               gf         = case zdec of-                              ANTERIOR -> deco `mappend` ptf-                              SUPERIOR -> ptf  `mappend` deco-           in return (ortt, gf)+    fn ortt = moveStart (vtoOrigin raddr ortt) gf -    getCP (PrimW ca _) = ca  +decoratePosObject :: InterpretUnit u +                  => ZDeco -> (Orientation u -> LocGraphic u) -> PosObject u a+                  -> PosObject u a+decoratePosObject zdec fn ma = PosObject $ \ctx pt -> +    let (a,o1,w1) = getPosObject ma ctx pt+        uortt     = dinterpF (dc_font_size ctx) o1+        upt       = dinterpF (dc_font_size ctx) pt+        (_,w2)    = runLocImage (fn uortt) ctx upt+        wout      = case zdec of+                         ANTERIOR -> w2 `mappend` w1+                         SUPERIOR -> w1  `mappend` w2+    in (a,o1,wout) +++ -- | Extend the orientation. ---extendPosObject :: Num u -                => u -> u -> u -> u -> PosObject u -> PosObject u-extendPosObject x0 x1 y0 y1 po = PosObject body-  where-    body = askDC >>= \ctx -> -           let (o0,pf0) = runQuery ctx (getPosObject po)-               ortt     = extendOrientation x0 x1 y0 y1 o0-           in return (ortt,pf0)-+extendPosObject :: InterpretUnit u +                => u -> u -> u -> u -> PosObject u a -> PosObject u a+extendPosObject x0 x1 y0 y1 ma = PosObject $ \ctx pt ->+    let (a,o1,w1) = getPosObject ma ctx pt+        sz        = dc_font_size ctx        +        ux0       = normalize sz x0+        ux1       = normalize sz x1+        uy0       = normalize sz y0+        uy1       = normalize sz y1+        o2        = extendOrientation ux0 ux1 uy0 uy1 o1+    in (a,o2,w1)  -mapOrientation :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u-mapOrientation fn po = PosObject body-  where-    body = askDC >>= \ctx -> -           let (o0,pf0) = runQuery ctx (getPosObject po)-           in return (fn o0,pf0)+-- | Note - this is a bad API, it would be better to have padders+-- and fillers and not expose the orientation directly.+-- +mapOrientation :: InterpretUnit u+               => (Orientation u -> Orientation u) +               -> PosObject u a -> PosObject u a+mapOrientation fn mf = PosObject $ \ctx pt -> +    let (a,o1,w1) = getPosObject mf ctx pt+        uort      = fn $ dinterpF (dc_font_size ctx) o1+        o2        = normalizeF (dc_font_size ctx) uort+    in (a,o2,w1)   --------------------------------------------------------------------------------@@ -228,14 +291,17 @@ -- of the PosObject. -- illustratePosObject :: InterpretUnit u -                   => PosObject u -> LocGraphic u-illustratePosObject (PosObject mf)  = promoteLoc $ \pt ->   -    zapQuery mf >>= \(ortt,ptf) -> -    decorate (primGraphic $ ptf pt) (illustrateOrientation ortt `at` pt)+                   => PosObject u a -> LocGraphic u+illustratePosObject mf  = promoteLoc $ \pt ->   +    askDC >>= \ctx ->+    let dpt       = normalizeF (dc_font_size ctx) pt +        (_,o1,w1) = getPosObject mf ctx dpt+        uort      = dinterpF (dc_font_size ctx) o1+    in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)   illustrateOrientation :: InterpretUnit u -                    => Orientation u -> LocGraphic u+                      => Orientation u -> LocGraphic u illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt ->      dinterpCtx 3 >>= \radius ->      let upd = localize (fill_colour blue . dotted_line)@@ -247,92 +313,286 @@     in mconcat [ bdr, hln, vln, dot ]  + --------------------------------------------------------------------------------+-- Char PosObjects+++-- Note - because the TextHeight constructors are so long winded,+-- using them directly makes for a bad API. Instead we have two +-- versions for each function.++-- | Note - no margins are added to the containing rectangle.+-- +-- To get a Char with margins, use 'posText' instead:+--+-- > posText ['1']+-- +posChar             :: InterpretUnit u => Char -> PosGraphic u+posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral++posEscChar          :: InterpretUnit u => EscapedChar -> PosGraphic u+posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER++posCharUpright      :: InterpretUnit u => Char -> PosGraphic u+posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral++posEscCharUpright   :: InterpretUnit u => EscapedChar -> PosGraphic u+posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT+++-- | Primtive builder that does not add margins.+--+posCharPrim         :: InterpretUnit u +                    => Either Char EscapedChar -> PosGraphic u+posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id+++makeCharPO :: InterpretUnit u +           => TextHeight -> EscapedChar -> PosGraphic u+makeCharPO hspec esc = +    makePosObject (charOrientation hspec esc) +                  (dcEscapedlabel $ wrapEscChar esc)+++++-- | Build the Orientation of an EscapedChar.+-- +-- The locus of the Orientation is baseline left - margins are +-- added.+--+charOrientation :: (DrawingCtxM m, InterpretUnit u)+                => TextHeight -> EscapedChar -> m (Orientation u)+charOrientation hspec esc = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> escCharVector esc <*> heightSpan hspec+++--------------------------------------------------------------------------------+-- Text PosObjects++++posText     :: InterpretUnit u => String -> PosGraphic u+posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString++posEscText  :: InterpretUnit u => EscapedText -> PosGraphic u+posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER+++posTextUpright      :: InterpretUnit u => String -> PosGraphic u+posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString++posEscTextUpright   :: InterpretUnit u => EscapedText -> PosGraphic u+posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT++-- | Primtive builder that does not add margins.+--+posTextPrim         :: InterpretUnit u +                    => Either String EscapedText -> PosGraphic u+posTextPrim = makeTextPO CAP_HEIGHT_PLUS_DESCENDER . either escapeString id+++multilinePosText :: (Fractional u, InterpretUnit u)+                 => VAlign -> String -> PosGraphic u+multilinePosText vspec xs = +    multilinePosEscText vspec $ map escapeString $ lines xs++multilinePosEscText :: (Fractional u, InterpretUnit u)+                    => VAlign -> [EscapedText] -> PosGraphic u+multilinePosEscText vspec xs = +    addMargins $ PosObject $ \ctx pt -> +      let sep    = runQuery textlineSpace ctx+      in getPosObject (body sep) ctx pt+  where+    body sp = alignColumnSep vspec sp $ +                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs++++-- | Note - this does not add margins.+--+makeTextPO :: InterpretUnit u +           => TextHeight -> EscapedText -> PosGraphic u+makeTextPO hspec esc = +    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)+++addMargins :: InterpretUnit u => PosObject u a -> PosObject u a+addMargins ma = +   textMargin >>= \(xsep,ysep) -> extendPosObject xsep xsep ysep ysep ma++-- | Build the Orientation of a single line of EscapedText - +-- writing direction zero (left-to-right).+-- +-- The locus of the Orientation is baseline left - margins are +-- added.+--+textOrientationZero :: (DrawingCtxM m, InterpretUnit u )+                    => TextHeight -> EscapedText -> m (Orientation u)+textOrientationZero hspec esc = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> escTextVector esc <*> heightSpan hspec+++--------------------------------------------------------------------------------+-- Rotated text++-- | Note - for single line text.+--+rposText        :: (Real u, Floating u, InterpretUnit u) +                => Radian -> String -> PosGraphic u+rposText ang    = addMargins . makeRotatedPO ang . escapeString++-- | Note - for single line text.+--+rposEscText     :: (Real u, Floating u, InterpretUnit u) +                => Radian -> EscapedText -> PosGraphic u+rposEscText ang = addMargins . makeRotatedPO ang+++makeRotatedPO :: (Real u, Floating u, InterpretUnit u) +              => Radian -> EscapedText -> PosGraphic u+makeRotatedPO ang esc = makePosObject qry body+  where+    qry  = rotateOrientation ang <$> +             textOrientationZero CAP_HEIGHT_PLUS_DESCENDER esc++    body = incline (dcREscapedlabel esc) ang+++--------------------------------------------------------------------------------+-- Kerned text+++posHKernText :: InterpretUnit u+            => [KernChar u] -> PosGraphic u+posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)++-- | The query should retrieve the width of one char.+--+monospaceText :: InterpretUnit u +              => Query u u -> String -> PosGraphic u+monospaceText qry = monospaceEscText qry . escapeString+++-- | The query should retrieve the width of one char.+--+monospaceEscText :: InterpretUnit u +                 => Query u u -> EscapedText -> PosGraphic u+monospaceEscText qry esc = PosObject $ \ctx pt ->+    let upt    = dinterpF (dc_font_size ctx) pt+        uw     = runQuery qry ctx+        ks     = monos uw $ destrEscapedText id esc+        ortt   = runQuery (hkernOrientationZero  ks) ctx+        dort   = normalizeF (dc_font_size ctx) ortt+        (_,w1) = runLocImage (hkernLine ks) ctx upt+    in (UNil, dort, w1)++++++monos :: Num u => u -> [EscapedChar] -> [KernChar u]+monos w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs+monos _  []     = []++++-- | Note - always CAP_HEIGHT_PLUS_DESCENDER for this one.+--+hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u )+                     => [KernChar u] -> m (Orientation u)+hkernOrientationZero xs = +    (\(V2 x _ ) (ymin,ymaj) -> Orientation 0 x ymin ymaj) +      <$> hkernVector xs <*> heightSpan CAP_HEIGHT_PLUS_DESCENDER++ ++-------------------------------------------------------------------------------- -- Combining PosObject  -instance (Fractional u, Ord u, InterpretUnit u) => ZConcat (PosObject u) where+instance (Monoid a, InterpretUnit u) => ZConcat (PosObject u a) where   superior = mappend   anterior = flip mappend  -instance (Num u, Ord u) => Concat (PosObject u) where+instance Monoid a => Concat (PosObject u a) where   hconcat = genMoveAlign spinemoveH spineRight   vconcat = genMoveAlign spinemoveV spineBelow -instance (Num u, Ord u) => CatSpace (PosObject u) where+instance (Monoid a, InterpretUnit u) => CatSpace (PosObject u a) where   hspace = genMoveSepH spinemoveH spineRight   vspace = genMoveSepV spinemoveV spineBelow   -instance (Fractional u, Ord u) => Align (PosObject u) where-  halign HTop    = genMoveAlign binmoveHTop    halignTopO-  halign HCenter = genMoveAlign binmoveHCenter halignCenterO-  halign HBottom = genMoveAlign binmoveHBottom halignBottomO+instance Monoid a => Align (PosObject u a) where+  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO+  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO+  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO -  valign VLeft   = genMoveAlign binmoveVLeft   valignLeftO-  valign VCenter = genMoveAlign binmoveVCenter valignCenterO-  valign VRight  = genMoveAlign binmoveVRight  valignRightO+  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO+  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO+  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO   -genMoveAlign :: (Num u)   -             => (Orientation u -> Orientation u -> Vec2 u) -             -> (Orientation u -> Orientation u -> Orientation u) -             -> PosObject u -> PosObject u -> PosObject u-genMoveAlign mkV mkO po0 po1 = PosObject body-  where-   body = askDC >>= \ctx -> -          let (ortt0,pf0) = runQuery ctx (getPosObject po0)-              (ortt1,pf1) = runQuery ctx (getPosObject po1)-              v1          = mkV ortt0 ortt1-              ortt        = mkO ortt0 ortt1-              pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)-          in return (ortt,pf)+genMoveAlign :: Monoid a+             => (Orientation Double -> Orientation Double -> Vec2 Double) +             -> (Orientation Double -> Orientation Double -> Orientation Double) +             -> PosObject u a -> PosObject u a -> PosObject u a+genMoveAlign mkV mkO ma mb = PosObject $ \ctx pt -> +    let (a,o1,w1) = getPosObject ma ctx pt+        (b,o2,w2) = getPosObject mb ctx pt+        v1        = mkV o1 o2+        ortt      = mkO o1 o2+        w2'       = cpmove v1 w2 +    in (a `mappend` b, ortt, w1 `mappend` w2')   -------------------------------------------------------------------------------- -- Sep -instance (Fractional u, Ord u) => AlignSpace (PosObject u) where-  halignSpace HTop    = genMoveSepH binmoveHTop    halignTopO-  halignSpace HCenter = genMoveSepH binmoveHCenter halignCenterO-  halignSpace HBottom = genMoveSepH binmoveHBottom halignBottomO+instance (Monoid a, InterpretUnit u) => AlignSpace (PosObject u a) where+  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO+  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO+  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO -  valignSpace VLeft   = genMoveSepV binmoveVLeft   valignLeftO-  valignSpace VCenter = genMoveSepV binmoveVCenter valignCenterO-  valignSpace VRight  = genMoveSepV binmoveVRight  valignRightO+  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO+  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO+  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO  -genMoveSepH :: (Num u)   -            => (Orientation u -> Orientation u -> Vec2 u) -            -> (Orientation u -> Orientation u -> Orientation u) +genMoveSepH :: (Monoid a, InterpretUnit u) +            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double)              -> u-            -> PosObject u -> PosObject u -> PosObject u-genMoveSepH mkV mkO sep po0 po1  = PosObject body-  where-    body = askDC >>= \ctx -> -           let (ortt0,pf0) = runQuery ctx (getPosObject po0)-               (ortt1,pf1) = runQuery ctx (getPosObject po1)-               v1          = hvec sep ^+^ mkV ortt0 ortt1-               ortt        = extendORight sep $ mkO ortt0 ortt1-               pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)-           in return (ortt,pf)+            -> PosObject u a -> PosObject u a -> PosObject u a+genMoveSepH mkV mkO sep ma mb  = PosObject $ \ctx pt -> +    let (a,o1,w1) = getPosObject ma ctx pt+        (b,o2,w2) = getPosObject mb ctx pt+        dsep      = normalize (dc_font_size ctx) sep+        v1        = hvec dsep ^+^ mkV o1 o2+        ortt      = extendORight dsep $ mkO o1 o2+        w2'       = cpmove v1 w2+    in (a `mappend` b, ortt, w1 `mappend` w2')  -genMoveSepV :: (Num u)   -            => (Orientation u -> Orientation u -> Vec2 u) -            -> (Orientation u -> Orientation u -> Orientation u) ++genMoveSepV :: (Monoid a, InterpretUnit u)+            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double)              -> u-            -> PosObject u -> PosObject u -> PosObject u-genMoveSepV mkV mkO sep po0 po1 = PosObject body-  where-    body = askDC >>= \ctx -> -           let (ortt0,pf0) = runQuery ctx (getPosObject po0)-               (ortt1,pf1) = runQuery ctx (getPosObject po1)-               v1          = vvec (-sep) ^+^ mkV ortt0 ortt1-               ortt        = extendODown sep $ mkO ortt0 ortt1-               pf          = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1)-           in return (ortt,pf)+            -> PosObject u a -> PosObject u a -> PosObject u a+genMoveSepV mkV mkO sep ma mb = PosObject $ \ctx pt -> +    let (a,o1,w1) = getPosObject ma ctx pt+        (b,o2,w2) = getPosObject mb ctx pt+        dsep      = normalize (dc_font_size ctx) sep+        v1        = vvec (-dsep) ^+^ mkV o1 o2+        ortt      = extendODown dsep $ mkO o1 o2+        w2'       = cpmove v1 w2+    in (a `mappend` b, ortt, w1 `mappend` w2') 

@@ -1,6 +1,4 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  --------------------------------------------------------------------------------@@ -22,26 +20,24 @@ module Wumpus.Basic.Kernel.Objects.TraceDrawing   ( -  -- * Collect primitives (writer monad) -    TraceM(..)-+  -- * Collect primitives (writer-like monad) +    GenTraceDrawing   , TraceDrawing   , DTraceDrawing-  , TraceDrawingT-  , DTraceDrawingT    , runTraceDrawing   , execTraceDrawing   , evalTraceDrawing-  , runTraceDrawingT-  , execTraceDrawingT-  , evalTraceDrawingT +  , runGenTraceDrawing++   , liftToPictureU   , liftToPictureMb   , mbPictureU  -+  , trace+  , fontDelta   , evalQuery    , draw@@ -64,6 +60,7 @@ 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@@ -81,13 +78,6 @@   --- | Collect elementary graphics as part of a larger drawing.------ TraceM works much like a writer monad.----class TraceM (m :: * -> *) where-  trace     :: MonUnit (m ()) ~ u => HPrim u -> m ()-  fontDelta :: m a -> m a  -- Note - TraceDrawing run \once\ - it is supplied with the starting -- environment (DrawingContext) and returns a Picture.@@ -98,142 +88,76 @@ --  -newtype TraceDrawing u a   = TraceDrawing { -          getTraceDrawing :: DrawingContext -> (a, HPrim u) }+newtype GenTraceDrawing st u a   = GenTraceDrawing { +          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) } -newtype TraceDrawingT u m a = TraceDrawingT { -          getTraceDrawingT :: DrawingContext -> m (a, HPrim u) } -type instance MonUnit (TraceDrawing u a) = u-type instance MonUnit (TraceDrawingT u m a) = 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-type DTraceDrawingT m a = TraceDrawingT Double m a  - -- Functor -instance Functor (TraceDrawing u) where-  fmap f ma = TraceDrawing $ \ctx -> -                let (a,w) = getTraceDrawing ma ctx in (f a,w)---instance Monad m => Functor (TraceDrawingT u m) where-  fmap f ma = TraceDrawingT $ \ctx -> -                getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w)-+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 (TraceDrawing u) where-  pure a    = TraceDrawing $ \_   -> (a, mempty)-  mf <*> ma = TraceDrawing $ \ctx -> -                let (f,w1) = getTraceDrawing mf ctx-                    (a,w2) = getTraceDrawing ma ctx-                in (f a, w1 `mappend` w2)+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)  -instance Monad m => Applicative (TraceDrawingT u m) where-  pure a    = TraceDrawingT $ \_   -> return (a,mempty)-  mf <*> ma = TraceDrawingT $ \ctx -> -                getTraceDrawingT mf ctx >>= \(f,w1) ->-                getTraceDrawingT ma ctx >>= \(a,w2) ->-                return (f a, w1 `mappend` w2)- -- Monad -instance Monad (TraceDrawing u) where-  return a  = TraceDrawing $ \_   -> (a, mempty)-  ma >>= k  = TraceDrawing $ \ctx -> -                let (a,w1) = getTraceDrawing ma ctx-                    (b,w2) = (getTraceDrawing . k) a ctx-                in (b,w1 `mappend` w2)+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)                                 ---instance Monad m => Monad (TraceDrawingT u m) where-  return a  = TraceDrawingT $ \_   -> return (a, mempty)-  ma >>= k  = TraceDrawingT $ \ctx -> -                getTraceDrawingT ma ctx      >>= \(a,w1) ->-                (getTraceDrawingT . k) a ctx >>= \(b,w2) -> -                return (b, w1 `mappend` w2)-                                 ------ 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. --- --instance TraceM (TraceDrawing u) where-  trace a = TraceDrawing $ \_ -> ((), a)-  fontDelta = fontDeltaMon--fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a-fontDeltaMon mf = TraceDrawing $ \ctx -> -    let (_,font_attrs) = primAnswer $ runImage ctx textAttr-        (a,hf)         = runTraceDrawing ctx mf-        prim           = fontDeltaContext font_attrs $ primGroup $ hprimToList hf-    in (a, singleH $ prim1 $ prim)--instance Monad m => TraceM (TraceDrawingT u m) where-  trace a = TraceDrawingT $ \_ -> return ((), a)-  fontDelta = fontDeltaTrans--fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a-fontDeltaTrans mf = TraceDrawingT $ \ctx -> -    let (_,font_props) = primAnswer $ runImage ctx textAttr-    in runTraceDrawingT ctx mf >>= \(a,hf) ->-       let prim  = fontDeltaContext font_props $ primGroup $ hprimToList hf-       in return (a, singleH $ prim1 $ prim)--- -- DrawingCtxM -instance DrawingCtxM (TraceDrawing u) where-  askDC           = TraceDrawing $ \ctx -> (ctx, mempty)-  asksDC f        = TraceDrawing $ \ctx -> (f ctx, mempty)-  localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx)+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 Monad m => DrawingCtxM (TraceDrawingT u m) where-  askDC           = TraceDrawingT $ \ctx -> return (ctx, mempty)-  asksDC f        = TraceDrawingT $ \ctx -> return (f ctx, mempty)-  localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx)+instance UserStateM (GenTraceDrawing st u) where+  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)+  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)+  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)+    --- Note - the result type of runTraceDrawing and friends needs more --- thought and may change. ------ Possibly a wrapped HPrim that only supports concat and safe--- extraction is best.------ Or it could generate a picture, but then separate drawings--- need the picture combinators to put them together. --- +runTraceDrawing :: TraceDrawing u a -> DrawingContext -> (a, HPrim u)+runTraceDrawing ma ctx = post $ getGenTraceDrawing ma ctx ()+  where+    post (a,_,w1) = (a,w1)  -runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)-runTraceDrawing ctx ma = getTraceDrawing ma ctx  -- | Run the drawing returning only the output it produces, drop -- any answer from the monadic computation. ---execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u-execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma+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.@@ -242,26 +166,18 @@ -- opposite behaviour (return the drawing, ignore than the  -- answer). -- -evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a-evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma+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 -runTraceDrawingT :: Monad m -                 => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) -runTraceDrawingT ctx ma = getTraceDrawingT ma ctx -execTraceDrawingT :: Monad m -                  => DrawingContext -> TraceDrawingT u m a -> m (HPrim u)-execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma  -evalTraceDrawingT :: Monad m -                  => DrawingContext -> TraceDrawingT u m a -> m a-evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma -- -- | /Unsafe/ promotion of @HPrim@ to @Picture@. -- -- If the HPrim is empty, a run-time error is thrown.@@ -306,8 +222,35 @@ --------------------------------------------------------------------------------  ++-- 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 ctx df+evalQuery df = askDC >>= \ctx -> return $ runQuery df ctx   @@ -318,11 +261,10 @@ -- Commonly, it is used to draw 'Graphic' objects which  -- have no /answer/. -- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -     => Image u a -> m ()+draw :: Image u a -> GenTraceDrawing st u () draw gf = askDC >>= \ctx -> -          let (PrimW o _) = runImage ctx gf-          in trace (singleH o) >> return ()+          let (_,w) = runImage gf ctx +          in trace (singleH w) >> return ()   @@ -333,11 +275,10 @@ -- The graphic representation of the Image is drawn in the Trace  -- monad, and the result is returned. -- -drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -      => Image u a -> m a+drawi :: Image u a -> GenTraceDrawing st u a drawi gf = askDC >>= \ctx -> -           let (PrimW o a) = runImage ctx gf -           in trace (singleH o) >> return a+           let (a,w) = runImage gf ctx+           in trace (singleH w) >> return a               @@ -348,8 +289,8 @@ -- Commonly, it is used to draw 'LocGraphic' objects which  -- have no /answer/. -- -drawl :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -      => Anchor u -> LocImage u a -> m ()+drawl :: InterpretUnit u+      => Anchor u -> LocImage u a -> GenTraceDrawing st u () drawl ancr img = drawli ancr img >> return ()  @@ -360,11 +301,11 @@ -- The graphic representation of the Image is drawn in the Trace  -- monad, and the result is returned. -- -drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -       => Anchor u -> LocImage u a -> m a+drawli :: InterpretUnit u+       => Anchor u -> LocImage u a -> GenTraceDrawing st u a drawli pt gf = askDC >>= \ctx -> -               let (PrimW o a) = runLocImage pt ctx gf-               in trace (singleH o) >> return a+               let (a,w) = runLocImage gf ctx pt+               in trace (singleH w) >> return a   -- Design note - having @drawlti@ for LocThetaImage does not seem @@ -385,8 +326,8 @@ -- Commonly, it is used to draw 'ConnectorGraphic' objects which  -- have no /answer/. -- -drawc :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -      => Anchor u -> Anchor u -> ConnectorImage u a -> m ()+drawc :: InterpretUnit u+      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u () drawc an0 an1 img = drawci an0 an1 img >> return ()   @@ -396,8 +337,8 @@ -- The graphic representation of the Image is drawn in the Trace  -- monad, and the result is returned. -- -drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -       => Anchor u -> Anchor u -> ConnectorImage u a -> m a+drawci :: InterpretUnit u +       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a drawci p0 p1 img = drawi (connect p0 p1 img)  @@ -415,8 +356,8 @@ -- Commonly, it is used to draw 'LocGraphic' objects which  -- have no /answer/. -- -node :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -     => (Int,Int) -> LocImage u a -> m ()+node :: ( Fractional u, InterpretUnit u)+     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u () node coord gf = nodei coord gf >> return ()  @@ -424,12 +365,12 @@ -- actual position is scaled according to the  -- @snap_grid_factors@ in the /drawing context/. -- -nodei :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) -      => (Int,Int) -> LocImage u a -> m a+nodei :: (Fractional u, InterpretUnit u) +      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a nodei coord gf = askDC >>= \ctx ->                   position coord >>= \pt ->-                 let (PrimW o a) = runLocImage pt ctx gf-                 in trace (singleH o) >> return a+                 let (a,w) = runLocImage gf ctx pt+                 in trace (singleH w) >> return a    @@ -445,12 +386,12 @@ -- Commonly, it is used to draw 'LocGraphic' objects which  -- have no /answer/. -- -drawrc :: ( Real u, Floating u, DrawingCtxM m, TraceM m -          , CenterAnchor a, RadialAnchor a-          , CenterAnchor b, RadialAnchor b-          , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b +drawrc :: ( Real u, Floating u, InterpretUnit u+          , CenterAnchor a1, RadialAnchor a1+          , CenterAnchor a2, RadialAnchor a2+          , u ~ DUnit a1, u ~ DUnit a2           ) -       => a -> b -> ConnectorImage u ans -> m ()+       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u () drawrc a b gf = drawrci a b gf >> return ()  @@ -460,12 +401,11 @@ -- are the radial points on the objects borders that cross the  -- projected line. -- -drawrci :: ( Real u, Floating u, DrawingCtxM m, TraceM m-           , CenterAnchor a, RadialAnchor  a-           , CenterAnchor b, RadialAnchor  b-           , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b+drawrci :: ( Real u, Floating u, InterpretUnit u+           , CenterAnchor a1, RadialAnchor  a1+           , CenterAnchor a2, RadialAnchor  a2+           , u ~ DUnit a1, u ~ DUnit a2            ) -        => a -> b -> ConnectorImage u ans -> m ans+        => 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)-

@@ -68,11 +68,13 @@     info <- (versionNumber    *> globalInfo)      cms  <- (startCharMetrics *> many pgm)     return $ AfmFile -              { afm_encoding        = getEncodingScheme info-              , afm_letter_bbox     = getFontBBox       info-              , afm_cap_height      = getCapHeight      info-              , afm_descender       = getDescender      info-              , afm_glyph_metrics   = cms+              { afm_encoding            = getEncodingScheme info+              , afm_letter_bbox         = getFontBBox       info+              , afm_cap_height          = getCapHeight      info+              , afm_descender           = getDescender      info+              , afm_underline_position  = getUlPosition     info+              , afm_underline_thickness = getUlThickness    info+              , afm_glyph_metrics       = cms               }  globalInfo :: CharParser GlobalInfo@@ -105,6 +107,15 @@  getDescender           :: GlobalInfo -> Maybe AfmUnit getDescender           = runQuery "Descender" number+++-- | Expected to be negative...+--+getUlPosition          :: GlobalInfo -> Maybe AfmUnit+getUlPosition          = runQuery "UnderlinePosition" number++getUlThickness         :: GlobalInfo -> Maybe AfmUnit+getUlThickness         = runQuery "UnderlineThickness" number   charBBox :: CharParser AfmBoundingBox

@@ -102,10 +102,12 @@ -- afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit afm_mono_defaults_4_1 = -    MonospaceDefaults { default_letter_bbox  = bbox-                      , default_cap_height   = 562-                      , default_descender    = (-157)-                      , default_char_width   = V2 600 0+    MonospaceDefaults { default_letter_bbox         = bbox+                      , default_cap_height          = 562+                      , default_descender           = (-157)+                      , default_underline_position  = (-100)+                      , default_underline_thickness = 50 +                      , default_char_width          = V2 600 0                       }   where     bbox = BBox (P2 (-23) (-250)) (P2 715 805)

@@ -81,11 +81,13 @@ -- Encoding Scheme is optional in AFM files. -- data AfmFile = AfmFile -      { afm_encoding        :: Maybe String-      , afm_letter_bbox     :: Maybe AfmBoundingBox-      , afm_cap_height      :: Maybe AfmUnit-      , afm_descender       :: Maybe AfmUnit-      , afm_glyph_metrics   :: [AfmGlyphMetrics]+      { afm_encoding                :: Maybe String+      , afm_letter_bbox             :: Maybe AfmBoundingBox+      , afm_cap_height              :: Maybe AfmUnit+      , afm_descender               :: Maybe AfmUnit+      , afm_underline_position      :: Maybe AfmUnit+      , afm_underline_thickness     :: Maybe AfmUnit+      , afm_glyph_metrics           :: [AfmGlyphMetrics]       }   deriving (Show)    @@ -109,10 +111,12 @@ -- in the distributed font files. -- data MonospaceDefaults cu = MonospaceDefaults -      { default_letter_bbox  :: BoundingBox cu-      , default_cap_height   :: cu-      , default_descender    :: cu-      , default_char_width   :: Vec2 cu+      { default_letter_bbox         :: BoundingBox cu+      , default_cap_height          :: cu+      , default_descender           :: cu+      , default_underline_position  :: cu+      , default_underline_thickness :: cu+      , default_char_width          :: Vec2 cu       }   deriving (Eq,Show) @@ -133,6 +137,8 @@        , fp_adv_vecs            :: IM.IntMap (Vec2 cu)        , fp_cap_height          :: cu        , fp_descender           :: cu+       , fp_underline_position  :: cu+       , fp_underline_thickness :: cu        }  @@ -148,6 +154,8 @@             maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font)       , get_cap_height    = \sz -> fn sz (fp_cap_height font)       , get_descender     = \sz -> fn sz (fp_descender font)+      , get_underline_position  = \sz -> fn sz (fp_underline_position font)+      , get_underline_thickness = \sz -> fn sz (fp_underline_thickness font)       }   where     defaultAV sz            = V2 (fn sz vx) (fn sz vy) 

@@ -149,15 +149,19 @@                   -> AfmFile                    -> FontLoadIO (FontProps AfmUnit) buildAfmFontProps defaults afm = do -    cap_height  <- extractCapHeight defaults afm-    desc_depth  <- extractDescender defaults afm-    bbox        <- extractFontBBox  defaults afm +    cap_height    <- extractCapHeight   defaults afm+    desc_depth    <- extractDescender   defaults afm+    ul_position   <- extractUlPosition  defaults afm+    ul_thickness  <- extractUlThickness defaults afm+    bbox          <- extractFontBBox    defaults afm      return $ FontProps -               { fp_bounding_box    = bbox-               , fp_default_adv_vec = default_char_width defaults-               , fp_adv_vecs        = char_widths-               , fp_cap_height      = cap_height-               , fp_descender       = desc_depth+               { fp_bounding_box        = bbox+               , fp_default_adv_vec     = default_char_width defaults+               , fp_adv_vecs            = char_widths+               , fp_cap_height          = cap_height+               , fp_descender           = desc_depth+               , fp_underline_position  = ul_position+               , fp_underline_thickness = ul_thickness                }     where     char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm@@ -180,6 +184,20 @@   where     errk = tellLoadMsg "WARNING - Could not extract Descender" >>             return (default_descender defaults)++extractUlPosition :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit+extractUlPosition defaults afm = +    maybe errk return $ afm_underline_position afm+  where+    errk = tellLoadMsg "WARNING - Could not extract UnderlinePosition" >> +           return (default_underline_position defaults)++extractUlThickness :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit+extractUlThickness defaults afm = +    maybe errk return $ afm_underline_thickness afm+  where+    errk = tellLoadMsg "WARNING - Could not extract UnderlineThickness" >> +           return (default_underline_thickness defaults)   extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile 

@@ -99,10 +99,12 @@ -- ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit ghostscript_mono_defaults_8_54 = -    MonospaceDefaults { default_letter_bbox  = bbox-                      , default_cap_height   = 563-                      , default_descender    = (-186)-                      , default_char_width   = V2 600 0+    MonospaceDefaults { default_letter_bbox         = bbox+                      , default_cap_height          = 563+                      , default_descender           = (-186)+                      , default_underline_position  = (-100)+                      , default_underline_thickness = 50 +                      , default_char_width          = V2 600 0                       }   where     bbox = BBox (P2 (-46) (-273)) (P2 650 820)

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.18.0+version:          0.20.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -30,22 +30,33 @@   .   Changelog:   .-  v0.17.0 to v0.18.0:-  . -  * Major change - removed @ContextFun@ from @Kernel.Base@. Now -    the drawing objects (Image, LocImage, Connector...) are -    newtype wrapped Reader-Writer monads rather than aliases to -    one of the arity family of ContextFuns. Being newtypes gives-    a lot better opportunities for overloading.+  v0.19.0 to v0.20.0:   .-  * Changed Displacement API - it is smaller, and the function -    naming is more uniform.+  * Added text advance-vector calculations to @QueryDC@ - +    previously they were in Wumpus-Drawing.   . -  * Changed @DrawingPimitives@ to use @DrawStyle@.+  * Changed argument order of @run@ functions to follow the usual+    style - monadic action first and then dependent parameters +    (initial state, reader environment etc.).   . -  * Moved vertices generating functions from @Geometry.Path@ to -    @Geometry.Vertices@.+  * 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.+  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2@@ -83,6 +94,7 @@     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.Objects.AdvObject,     Wumpus.Basic.Kernel.Objects.Anchors,