packages feed

wumpus-basic 0.15.0 → 0.24.0

raw patch · 63 files changed

Files

CHANGES view
@@ -1,3 +1,155 @@++0.20.0 to 0.21.0:++  * The code from the @Kernel.Base.UserState@ module has been +    moved to the module @Kernel.Drawing.Basis@.++  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and +    @TraceDrawing@ into the new @Drawing@ folder.++  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.+ +  * Rationalized the combinators exported by the drawing objects +    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.+ ++0.18.0 to 0.20.0 (no release numbered v0.19.0):++  * Added text advance-vector calculations to @QueryDC@ - +    previously they were in Wumpus-Drawing.+ +  * Changed argument order of @run@ functions to follow the usual+    style - monadic action first and then dependent parameters +    (initial state, reader environment etc.).+ +  * Changed representation of Chains to a monadic type with an +    explicit operation for next position.++  * Removed @PrimW@ type - pairs are now used instead. ++  * Removed transformer version of @TraceDrawing@. All operations +    in TraceDrawing are now specialized to work only on the +    @TraceDrawing@ type. Added @UserState@ to TraceDrawing and+    other drawing monads to compensate for the loss of+    expressiveness.++  * Changed the internals of @AdvObject@ and @PosObject@ so they +    are more idiomatic - both are now essentially reader-writer +    monads. Added PosObject functions for text primitives (moved +    from Wumpus-Drawing).++  * Changed the @obliterate@ method of the @Decorate@ class.++  * Removed the Semigroup (OPlus) and Bifunctor classes. They are +    no longer so pertinent now that Image, LocImage etc. are +    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 +    longer an arity family of newtypes. The new representation +    is simpler, but some of the opportunities for overloading +    have been lost.++  * Substantial round of renaming for the @DrawingContext@ types+    an query and update functions.++  * Re-worked the font metrics and font loader modules. The new+    names should be more systematic. Removed the need for the +    GhostScript font modules to match PostScript names to +    GhostScript font files.    ++  * Superceded the PointSupplyM class by adding snapping grid +    scaling to the DrawingContext. + +  * Removed @ScalingContext@ module.++  * Made text colour a distinct property in the DrawingContext. +    Text is now drawn with the text colour rather than the stroke +    colour.++  * Added FontLoadLog to the DrawingContext - this allows access +    to the errors recorded during font loading.++0.15.0 to 0.16.0:++  * Moved the Geometry modules from Wumpus-Drawing into +    Wumpus-Basic.++  * Re-worked the @CtxPicture@ API, although the current naming +    scheme is not satisfactory.++  * Added extra Anchor classes.++  * Added @PosImage@ object - this is a rectangle-framed object +    that can be drawn from any of its corners or its center. ++  * Added @CF3@, an arity three /ContextFunction/.++  * Added @Displacement@ module. This defines the @PointDisplace@+    type and provides a library of @PointDisplace@ functions.+    Note - some of the new functions have taken names previously +    used for anchor projection functions (@northwards@, +    @southwards@, etc.), anchor projections are now build with the +    function @projectAnchor@.++  * Added the property @descender@ to the font metrics.++  * Split drawing primitives from type in @Objects.Graphic@, +    drawing primitives are now in the module +    @Objects.DrawingPrimitives@.++0.14.0 to 0.15.0:+ +  * Split previous @Wumpus-Basic@ package into two packages:+    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move +    to separate the developed (although not yet polished) @Kernel@ +    and @FontLoader@ code from the prototypical @Drawing@ code.++  * Renamed the @Drawing@ object to @CtxPicture@. Although +    @CtxPicture@ is a less pleasant name, it should be less +    confusing. A @CtxPicture@ is the essentially the @Picture@ +    type from Wumpus-Core with an implicit context - +    @ContextPicture@ is simply too long and @CtxPicture@ is +    almost jibberish but the previous unrelated name @Drawing@ +    was not helpful.++  * @Kernel.Base.ScalingContext@ has been simplified. +    ScalingContexts are no longer manipulated via a custom Reader+    monad or transformer as the type signatures were too unwieldy.++  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing +    can now calculate more appealing bounding boxes for text.+ 0.13.0 to 0.14.0:    * Re-organised module hierarchy, Wumpus-Basic is now divided
+ demo/AltUnits.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS -Wall #-}+++module AltUnits where++import Wumpus.Basic.Kernel++import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid+import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let pic1 = runCtxPictureU std_attr drawing01+    writeEPS "./out/alt_units01.eps" pic1+    writeSVG "./out/alt_units01.svg" pic1+++std_attr :: DrawingContext+std_attr = (stroke_colour firebrick . fill_colour linen) $ standardContext 12+++drawing01 :: CtxPicture+drawing01 = drawTracing $ combined+++mf1 :: TraceDrawing Double ()+mf1 = do+    draw $ dblLocGraphic `at` P2 12 0++mf2 :: TraceDrawing Em ()+mf2 = do+    draw $ emLocGraphic `at` P2 1 0++combined :: TraceDrawing Double ()+combined = do +    draw $ dblLocGraphic `at` P2 12 108+    drawl (P2 12 72) $ uconvF emLocGraphic+    draw $ uconvF $ emLocGraphic `at` P2 1 3+    drawl (P2 12 0) $ uconvF $ hyperlink haskell_org enLocGraphic++dblLocGraphic :: LocGraphic Double+dblLocGraphic = rect1 `mappend` rect2  +  where+    rect1 = dcRectangle DRAW_FILL_STROKE 36 24 +    rect2 = moveStart (hvec 36) $ dcRectangle DRAW_FILL_STROKE 60 24 ++++emLocGraphic :: LocGraphic Em+emLocGraphic = localize swap_colours $  rect1 `mappend` rect2  +  where+    rect1 = dcRectangle DRAW_FILL_STROKE 3 2 +    rect2 = moveStart (hvec 3) $ dcRectangle DRAW_FILL_STROKE 5 2 +++enLocGraphic :: LocGraphic En+enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `mappend` rect2  +  where+    rect1 = dcRectangle DRAW_FILL_STROKE 6 4+    rect2 = moveStart (hvec 6) $ dcRectangle DRAW_FILL_STROKE 10 4+++haskell_org :: XLink+haskell_org = xlinkhref "http://www.haskell.org"++firebrick               :: RGBi+firebrick               = RGBi 0xb2 0x22 0x22++lemon_chiffon           :: RGBi+lemon_chiffon           = RGBi 0xff 0xfa 0xcd++linen                   :: RGBi+linen                   = RGBi 0xfa 0xf0 0xe6++
demo/FontDeltaPic.hs view
@@ -16,8 +16,7 @@ main :: IO () main = do      createDirectoryIfMissing True "./out/"-    putStrLn $ "Note - the SVG optimization that should be used here"-    putStrLn $ "has bit-rotted and is not currently in use.."+    putStrLn $ "Check the generated SVG to verify the font attrs are grouped..."     --     let pic1 = runCtxPictureU std_attr drawing01     writeEPS "./out/font_delta01.eps" pic1@@ -28,23 +27,23 @@ std_attr = standardContext 24  -drawing01 :: DCtxPicture+drawing01 :: CtxPicture drawing01 = drawTracing $ mf   -mf :: (Floating u, FromPtSize u) => TraceDrawing u ()-mf = do +mf :: TraceDrawing Double ()+mf = fontDelta $ do     draw $ line1 `at` (P2 0 100)     draw $ line2 `at` (P2 0  75)     draw $ line3 `at` (P2 0  50)     draw $ line4 `at` (P2 0  25)     draw $ line5 `at` (P2 0   0)    where-    line1 = textline "All the lines of this drawing" -    line2 = textline "should be grouped within a SVG"-    line3 = textline "g-element, from where they"-    line4 = textline "inherit the font-family and"-    line5 = textline "font-size attributes."+    line1 = dcTextlabel "All the lines of this drawing" +    line2 = dcTextlabel "should be grouped within a SVG"+    line3 = dcTextlabel "g-element, from where they"+    line4 = dcTextlabel "inherit the font-family and"+    line5 = dcTextlabel "font-size attributes."
+ demo/SimpleAdvGraphic.hs view
@@ -0,0 +1,68 @@+{-# OPTIONS -Wall #-}+++module SimpleAdvGraphic where++import Wumpus.Basic.Kernel++import Wumpus.Core                      -- package: wumpus-core++import Control.Applicative+import System.Directory++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let pic1 = runCtxPictureU std_attr drawing01+    writeEPS "./out/simple_adv_graphic01.eps" pic1+    writeSVG "./out/simple_adv_graphic01.svg" pic1+++std_attr :: DrawingContext+std_attr = standardContext 24+++drawing01 :: CtxPicture+drawing01 = drawTracing mf ++++-- Although TraceDrawing can be fully unit polymorphic, it seems +-- always best to specialize as we are stating concrete values+-- (and they will be in some unit).+--++mf :: TraceDrawing Double ()+mf = do+    drawl (P2 0 120) $ +        runAdvObject $ evenspace (hvec 10) [text01, text02, text01]++    drawl (P2 0 80) $ +        runAdvObject $ advances [text01, text02, text01]++    drawl (P2 0 40) $ +        runAdvObject (miniDisk `advance` text01 `advance` miniDisk)++    drawl (P2 0 0) $+        runAdvObject (miniDisk `advance` text02 `advance` miniDisk)+++-- Normally, text calculate the advance vector from the font +-- metrics...+--+text01 :: AdvGraphic Double+text01 = makeAdvObject (pure $ hvec 84) $ dcTextlabel "text01"+    ++text02 :: AdvGraphic Double+text02 = makeAdvObject (pure $ hvec 210) $ dcTextlabel "text number two"+++miniDisk :: AdvGraphic Double+miniDisk = makeAdvObject (pure $ V2 0 0) disk1 +  where+    disk1 = localize (fill_colour sienna) $ dcDisk DRAW_FILL 3+++sienna :: RGBi+sienna = RGBi 160 82 45
+ demo/SimplePosObject.hs view
@@ -0,0 +1,114 @@+{-# OPTIONS -Wall #-}+++module SimplePosObject where++import Wumpus.Basic.Kernel++import Wumpus.Core                      -- package: wumpus-core+import Wumpus.Core.Colour ( red )++import Data.Monoid+import System.Directory++++main :: IO ()+main = do +    createDirectoryIfMissing True "./out/"+    let pic1 = runCtxPictureU std_ctx drawing01+    writeEPS "./out/simple_pos_object01.eps" pic1+    writeSVG "./out/simple_pos_object01.svg" pic1+++std_ctx :: DrawingContext+std_ctx = standardContext 24+++drawing01 :: CtxPicture+drawing01 = drawTracing $ localize (fill_colour red) $ mf +++mf :: TraceDrawing Double ()+mf = do+    draw $ testDrawMinor NN     `at` (P2   0 400)+    draw $ testDrawMinor SS     `at` (P2  75 400)+    draw $ testDrawMinor EE     `at` (P2 150 400)+    draw $ testDrawMinor WW     `at` (P2 225 400)+    draw $ testDrawMinor NE     `at` (P2   0 325)+    draw $ testDrawMinor SE     `at` (P2  75 325)+    draw $ testDrawMinor SW     `at` (P2 150 325)+    draw $ testDrawMinor NW     `at` (P2 225 325)+    draw $ testDrawMinor CENTER `at` (P2   0 250)+    draw $ testDrawMinor BLL    `at` (P2  75 250)+    draw $ testDrawMinor BLC    `at` (P2 150 250)+    draw $ testDrawMinor BLR    `at` (P2 225 250)+++    draw $ testDrawBl    NN     `at` (P2   0 150)+    draw $ testDrawBl    SS     `at` (P2  75 150)+    draw $ testDrawBl    EE     `at` (P2 150 150)+    draw $ testDrawBl    WW     `at` (P2 225 150)+    draw $ testDrawBl    NE     `at` (P2   0 75)+    draw $ testDrawBl    SE     `at` (P2  75 75)+    draw $ testDrawBl    SW     `at` (P2 150 75)+    draw $ testDrawBl    NW     `at` (P2 225 75)+    draw $ testDrawBl    CENTER `at` (P2   0  0)+    draw $ testDrawBl    BLL    `at` (P2  75  0)+    draw $ testDrawBl    BLC    `at` (P2 150  0)+    draw $ testDrawBl    BLR    `at` (P2 225  0)+    +    drawl (P2 300 0) $ runPosObject SW msg+  where+    msg = multilinePosText VALIGN_RIGHT "Red dot represents the\nrectangle address."+++testDrawBl :: RectAddress -> LocGraphic Double+testDrawBl raddr = dcDisk DRAW_FILL 2 `mappend` rectBl raddr+++rectBl :: RectAddress -> LocGraphic Double+rectBl raddr = +    ignoreAns $ runPosObject raddr $ makePosObject (return ortt) (mkRectBl w h)+  where+    w    = 40 +    h    = 30+    ortt = Orientation { or_x_minor = 0+                       , or_x_major = w+                       , or_y_minor = 0+                       , or_y_major = h }+ ++-- start-point - bottom left+mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u+mkRectBl w h = dcRectangle DRAW_STROKE w h++++testDrawMinor :: RectAddress -> LocGraphic Double+testDrawMinor raddr = +    dcDisk DRAW_FILL 2 `mappend` (ignoreAns $ rectMinor raddr)+++rectMinor :: RectAddress -> LocGraphic Double+rectMinor raddr = +    runPosObject raddr $ makePosObject (return ortt) (mkRectMinor m w h)+  where+    m    = 10+    w    = 40 +    h    = 30+    ortt = Orientation { or_x_minor = m+                       , or_x_major = (w-m)+                       , or_y_minor = m+                       , or_y_major = (h-m) }+ ++-- start-point - +10 +10+mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u+mkRectMinor m w h = promoteLoc $ \pt -> +    let bl = displace (vec (-m) (-m)) pt+        br = displace (hvec w) bl+        tr = displace (vvec h) br+        tl = displace (vvec h) bl+    in liftQuery (vertexPP [bl, br, tr, tl]) >>= dcClosedPath DRAW_STROKE+
src/Wumpus/Basic/Kernel.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -12,42 +12,80 @@ -- -- Import shim for @Wumpus.Basic.Kernel@ modules. --+-- @Kernel.Base@ - low-level objects, general enumerations, unit +-- and @DrawingContext@ support. @DrawingContext@ is comparative +-- to the /graphics state/ in PostScript, but it is a read-only+-- environment (cf. the Reader monad). Like the Reader monad it +-- supports branching update through @local@ - here called +-- @localize@.+-- +-- @Kernel.Objects@ - \"elementary\" drawing objects, plus some +-- catalogues of named, predefined drawing objects +-- (DrawingPrimitives) and useful operations (named vectors - +-- Displacement). --+-- @Kernel.Drawing@ - \"collective\" drawing objects. @Drawing@ is +-- considered a higher layer than @Objects@, so there should be +-- dependencies only from @Drawing@ to @Objects@.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel   (-    module Wumpus.Basic.Kernel.Base.Anchors-  , module Wumpus.Basic.Kernel.Base.BaseDefs-  , module Wumpus.Basic.Kernel.Base.ContextFun+    module Wumpus.Basic.Kernel.Base.BaseDefs   , module Wumpus.Basic.Kernel.Base.DrawingContext-  , module Wumpus.Basic.Kernel.Base.GlyphMetrics+  , module Wumpus.Basic.Kernel.Base.FontSupport   , module Wumpus.Basic.Kernel.Base.QueryDC-  , module Wumpus.Basic.Kernel.Base.ScalingContext+  , module Wumpus.Basic.Kernel.Base.Units   , module Wumpus.Basic.Kernel.Base.UpdateDC   , module Wumpus.Basic.Kernel.Base.WrappedPrimitive-  , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic-  , module Wumpus.Basic.Kernel.Objects.BaseObjects+  , module Wumpus.Basic.Kernel.Drawing.Basis+  , module Wumpus.Basic.Kernel.Drawing.Chain+  , module Wumpus.Basic.Kernel.Drawing.CtxPicture+  , module Wumpus.Basic.Kernel.Drawing.LocDrawing+  , module Wumpus.Basic.Kernel.Drawing.LocTrace+  , module Wumpus.Basic.Kernel.Drawing.PosObject+  , module Wumpus.Basic.Kernel.Drawing.TraceDrawing+  , module Wumpus.Basic.Kernel.Objects.AdvObject+  , module Wumpus.Basic.Kernel.Objects.Anchors+  , module Wumpus.Basic.Kernel.Objects.Basis   , module Wumpus.Basic.Kernel.Objects.Bounded+  , module Wumpus.Basic.Kernel.Objects.Concat   , module Wumpus.Basic.Kernel.Objects.Connector-  , module Wumpus.Basic.Kernel.Objects.CtxPicture-  , module Wumpus.Basic.Kernel.Objects.Graphic-  , module Wumpus.Basic.Kernel.Objects.TraceDrawing+  , module Wumpus.Basic.Kernel.Objects.Displacement+  , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives+  , module Wumpus.Basic.Kernel.Objects.Image+  , module Wumpus.Basic.Kernel.Objects.LocImage+  , module Wumpus.Basic.Kernel.Objects.LocThetaImage+  , module Wumpus.Basic.Kernel.Objects.Orientation+  , module Wumpus.Basic.Kernel.Objects.Trail+   ) where -import Wumpus.Basic.Kernel.Base.Anchors import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.ScalingContext+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.AdvanceGraphic-import Wumpus.Basic.Kernel.Objects.BaseObjects+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Drawing.Chain+import Wumpus.Basic.Kernel.Drawing.CtxPicture+import Wumpus.Basic.Kernel.Drawing.LocDrawing+import Wumpus.Basic.Kernel.Drawing.LocTrace+import Wumpus.Basic.Kernel.Drawing.PosObject+import Wumpus.Basic.Kernel.Drawing.TraceDrawing+import Wumpus.Basic.Kernel.Objects.AdvObject+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Bounded+import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.Connector-import Wumpus.Basic.Kernel.Objects.CtxPicture-import Wumpus.Basic.Kernel.Objects.Graphic-import Wumpus.Basic.Kernel.Objects.TraceDrawing+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage+import Wumpus.Basic.Kernel.Objects.Orientation+import Wumpus.Basic.Kernel.Objects.Trail
− src/Wumpus/Basic/Kernel/Base/Anchors.hs 
@@ -1,238 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.Anchors--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Anchor points on shapes, bounding boxes, etc.------ Anchors are addressable positions, an examplary use is taking--- anchors on node shapes to get the start and end points for --- connectors in a network (graph) diagram.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.Anchors-  ( --  -- * Anchors-    CenterAnchor(..)-  , CardinalAnchor(..)-  , CardinalAnchor2(..)-  , RadialAnchor(..)--  -- * Extended anchor points-  , northwards-  , southwards-  , eastwards-  , westwards-  , northeastwards-  , southeastwards-  , southwestwards-  , northwestwards--  , radialConnectorPoints--  ) where--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space----- | Center of an object.----class CenterAnchor t where-  center :: DUnit t ~ u => t -> Point2 u---- | Cardinal (compass) positions on an object. --- --- Note - in TikZ cardinal anchors are not necessarily at the--- equivalent radial position, for instance reactangle north-east--- is the top-right corner whether or not this is incident at --- 45deg.------ Wumpus generally follows the TikZ convention.----class CardinalAnchor t where-  north :: DUnit t ~ u => t -> Point2 u-  south :: DUnit t ~ u => t -> Point2 u-  east  :: DUnit t ~ u => t -> Point2 u-  west  :: DUnit t ~ u => t -> Point2 u----- | Secondary group of cardinal (compass) positions on an object. --- --- It seems possible that for some objects defining the primary--- compass points (north, south,...) will be straight-forward --- whereas defining the secondary compass points may be --- problemmatic, hence the compass points are split into two --- classes.----class CardinalAnchor2 t where-  northeast :: DUnit t ~ u => t -> Point2 u-  southeast :: DUnit t ~ u => t -> Point2 u-  southwest :: DUnit t ~ u => t -> Point2 u-  northwest :: DUnit t ~ u => t -> Point2 u----- | Anchor on a border that can be addressed by an angle.------ The angle is counter-clockwise from the right-horizontal, i.e.--- 0 is /east/.----class RadialAnchor t where-  radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u-----extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u-extendPtDist d p1 p2 = let v   = pvec p1 p2-                           ang = vdirection v-                           len = vlength v-                       in p1 .+^ avec ang (len+d)----- | 'northwards' : @ dist * object -> Point @--- --- Project the anchor along a line from the center that goes --- through the north anchor. ------ If the distance is zero the answer with be the north anchor.------ If the distance is negative the answer within the object before --- the north anchor.------ If the distance is positive the anchor outside the object.----northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-northwards u a = extendPtDist u (center a) (north a)----- | 'southwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- southwards from the center of the object.----southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-              , u ~ DUnit t ) -           => u -> t -> Point2 u-southwards u a = extendPtDist u (center a) (south a)----- | 'eastwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- eastwards from the center of the object.----eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-eastwards u a = extendPtDist u (center a) (east a)----- | 'westwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- westwards from the center of the object.----westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t-             , u ~ DUnit t ) -          => u -> t -> Point2 u-westwards u a = extendPtDist u (center a) (west a)----- | 'northeastwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- northeastwards from the center of the object.----northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northeastwards u a = extendPtDist u (center a) (northeast a)----- | 'southeastwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- southeastwards from the center of the object.----southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southeastwards u a = extendPtDist u (center a) (southeast a)----- | 'southwestwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- southwestwards from the center of the object.----southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-southwestwards u a = extendPtDist u (center a) (southwest a)----- | 'northwestwards' : @ dist * object -> Point @--- --- Variant of the function 'northwards', but projecting the line --- northwestwards from the center of the object.----northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t-                  , u ~ DUnit t ) -               => u -> t -> Point2 u-northwestwards u a = extendPtDist u (center a) (northwest a)--------------------------------------------------------------------------------------- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @------ Find the radial connectors points for objects @a@ and @b@ along--- the line joining their centers.----radialConnectorPoints :: ( Real u, Floating u-                         , CenterAnchor t1, RadialAnchor t1-                         , CenterAnchor t2, RadialAnchor t2-                         , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) -                      => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b)-  where-    theta = vdirection $ pvec (center a) (center b)-    ------------------------------------------------------------------------------------- Instances --instance Fractional u => CenterAnchor (BoundingBox u) where-  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y -     where-       x = xl+0.5*(xr-xl)-       y = ylo+0.5*(yhi-ylo)-       --instance Fractional u => CardinalAnchor (BoundingBox u) where-  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi-  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo-  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))-  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))---instance Fractional u => CardinalAnchor2 (BoundingBox u) where-  northeast (BBox _ ur)                 = ur-  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo-  southwest (BBox ll _)                 = ll-  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi -
src/Wumpus/Basic/Kernel/Base/BaseDefs.hs view
@@ -1,13 +1,10 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FlexibleContexts           #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernal.Base.BaseDefs--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -22,262 +19,540 @@ module Wumpus.Basic.Kernel.Base.BaseDefs   ( -  -- * A semigroup class-    OPlus(..)-  , oconcat+  -- * Constants+    quarter_pi+  , half_pi+  , two_pi -  -- * A bifunctor class-  , Bimap(..)-  , replaceL-  , replaceR+  , ang180+  , ang150+  , ang120+  , ang90+  , ang60+  , ang45+  , ang30+  , ang15 +  -- * Unit phantom type+  , UNil(..)+  , ureturn+  , uvoid++  -- * Non-contextual unit conversion.+  , ScalarUnit(..)++  -- * Unit interpretation with respect to the current Point size+  , InterpretUnit(..)+  , dinterpF+  , normalizeF+  , uconvert1+  , uconvertF++  , intraMapPoint+  , intraMapFunctor+++  -- * KernChar+  , KernChar++  -- * Drawing paths and shapes (closed paths)+  , PathMode(..)+  , DrawMode(..)+  , closedMode++  -- * Drawing layers+  , ZOrder(..)  +   -- * Alignment   , HAlign(..)   , VAlign(..)   -  -- * Advance vector-  , AdvanceVec-  , advanceH-  , advanceV+  -- * Text height+  , TextHeight(..) -  -- * Moving points-  , PointDisplace-  , displace-  , displaceVec-  , displaceH-  , displaceV+  -- * Cardinal (compass) positions+  , Cardinal(..) -  , ThetaPointDisplace-  , displaceParallel-  , displacePerpendicular+  -- * Direction enumeration+  , Direction(..)+  , ClockDirection(..)  +  , clockDirection +  , HDirection(..)+  , horizontalDirection+  , VDirection(..)+  , verticalDirection -  -- * Monadic drawing-  , MonUnit+  -- * Quadrant enumeration+  , Quadrant(..)+  , quadrant -  , PointSupplyM(..)+  -- * Beziers +  , bezierArcPoints  +  , bezierMinorArc+  ++  -- * Misc++  , both+  , monPreRepeatPost+   ) where  import Wumpus.Core                              -- package: wumpus-core + import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace -infixr 6 `oplus`+import Control.Applicative+import Data.Monoid --- | 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 :: OPlus t => t -> [t] -> t-oconcat t = step t-  where-    step ac []     = ac-    step ac (x:xs) = step (ac `oplus` x) xs   -instance OPlus () where-  _ `oplus` _ = () -instance OPlus (UNil u) where-  _ `oplus` _ = uNil+quarter_pi      :: Radian+quarter_pi      = 0.25 * pi -instance Ord u => OPlus (BoundingBox u) where-  oplus = boundaryUnion+half_pi         :: Radian+half_pi         = 0.5 * pi -instance OPlus (Primitive u) where-  a `oplus` b = primGroup [a,b]+two_pi          :: Radian+two_pi          = 2.0 * pi -instance (OPlus a, OPlus b) => OPlus (a,b) where-  (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b') +ang180          :: Radian+ang180          = pi -instance OPlus a => OPlus (r -> a) where-  f `oplus` g = \x -> f x `oplus` g x+ang150          :: Radian+ang150          = 5 * ang30 --- The functional instance (r -> a) also covers (r1 -> r2 -> a),--- (r1 -> r2 -> r3 -> a) etc.+ang120          :: Radian +ang120          = 2 * ang60 +ang90           :: Radian+ang90           = pi / 2++ang60           :: Radian+ang60           = pi / 3++ang45           :: Radian +ang45           = pi / 4++ang30           :: Radian+ang30           = pi / 6++ang15           :: Radian+ang15           = pi / 12+++ --------------------------------------------------------------------------------+-- Simple objects wrapped with unit phatom type  --- | A Bifunctor class.++-- | The empty data type - i.e. @()@ - wrapped with a phantom unit +-- parameter.+--+data UNil   u = UNil          deriving (Eq,Ord,Read,Show)++type instance DUnit (UNil u) = u++instance Functor UNil where+  fmap _ UNil= UNil+++instance Monoid (UNil u) where+  mempty        = UNil+  _ `mappend` _ = UNil+++++instance Rotate (UNil u) where+  rotate _              = id++instance RotateAbout (UNil u) where+  rotateAbout _ _       = id++instance Scale (UNil u) where+  scale _ _             = id++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 because Wumpus has to expose the type of +-- the @unit@ to the type checker we must finish the do-block +-- with:+--+-- > ureturn -- --- Again, it would be nice if there was a Bifunctor class in the--- Haskell Base libraries...  +-- or: -- -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+-- > return UNil+--+-- rather than:+--+-- > return ()+--+--+ureturn :: Monad m => m (UNil u)+ureturn = return UNil +-- | 'uvoid' runs a monadic computation and returns @UNil@.+--+uvoid :: Monad m => m a -> m (UNil u)+uvoid ma = ma >> return UNil +--------------------------------------------------------------------------------+-- Non-contextual units -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)+class ScalarUnit a where+  fromPsPoint :: Double -> a +  toPsPoint   :: a -> Double -instance Bimap Either where-  bimap f _ (Left a)  = Left (f a)-  bimap _ g (Right b) = Right (g b)+instance ScalarUnit Double where+  fromPsPoint = id+  toPsPoint   = id  -  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+--------------------------------------------------------------------------------+-- Interpreting units  -replaceR :: Bimap f => q -> f a b -> f a q-replaceR = bimapR . const+-- Units may or may not depend on current font size+-- +class (Eq u, Num u) => InterpretUnit u where+  normalize :: FontSize -> u -> Double+  dinterp   :: FontSize -> Double -> u ---------------------------------------------------------------------------------+instance InterpretUnit Double where+  normalize _ = id+  dinterp   _ = id  --- Alignment+instance InterpretUnit AfmUnit where+  normalize sz = afmValue sz +  dinterp   sz = afmUnit sz --- | Horizontal alignment - align to the top, center or bottom.++-- | 'dinterp' an object that gives access to its unit at the +-- functor position. ---data HAlign = HTop | HCenter | HBottom-  deriving (Enum,Eq,Ord,Show)+dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u+dinterpF sz = fmap (dinterp sz) --- | Vertical alignment - align to the left, center or bottom.++-- | 'normalize' an object that gives access to its unit at the +-- functor position. ---data VAlign = VLeft | VCenter | VRight-  deriving (Enum,Eq,Ord,Show)+normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double+normalizeF sz = fmap (normalize sz)  ---------------------------------------------------------------------------------+-- | Convert a scalar value from one unit to another.+--+uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1+uconvert1 sz = dinterp sz . normalize sz --- | Advance vectors provide an idiom for drawing consecutive--- graphics. PostScript uses them to draw left-to-right text - --- each character has an advance vector for the width and --- as characters are drawn they successively displace the start--- point for the next character with their advance vector.+-- | Unit convert an object that gives access to its unit at the+-- Functor position. ----- Type alias for Vec2.+-- In practive this will be \*all\* Image answers. ---type AdvanceVec u = Vec2 u+uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1) +          => FontSize -> t u -> t u1+uconvertF sz = fmap (uconvert1 sz)  --- | Extract the horizontal component of an advance vector.++-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then+-- converted back to the original unit. Thus transformations can +-- work in contextual units. ----- For left-to-right latin text, the vertical component of an--- advance vector is expected to be 0. Ingoring it seems --- permissible when drawing text.+intraMapPoint :: InterpretUnit u +              => FontSize -> (DPoint2 -> DPoint2) -> Point2 u -> Point2 u+intraMapPoint sz fn (P2 x y) = +    let P2 x' y' = fn $ P2 (normalize sz x) (normalize sz y)+    in  P2 (dinterp sz x') (dinterp sz y')++++-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then+-- converted back to the original unit. Thus transformations can +-- work in contextual units. ---advanceH :: AdvanceVec u -> u-advanceH (V2 w _)  = w+intraMapFunctor :: (Functor f, InterpretUnit u)+                => FontSize -> (f Double -> f Double) -> f u -> f u+intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma --- | Extract the verticall component of an advance vector.++--------------------------------------------------------------------------------+-- KernChar+++-- | Unit parametric version of KerningChar from Wumpus-Core. ---advanceV :: AdvanceVec u -> u-advanceV (V2 _ h)  = h+type KernChar u = (u,EscapedChar) + ----------------------------------------------------------------------------------- Displacing points+-- Drawing closed paths --- | 'PointDisplace' is a type representing functions --- @from Point to Point@.++-- | Draw closed paths. +-- +-- > OSTROKE - open and stroked ----- It is especially useful for building composite graphics where --- one part of the graphic is drawn from a different start point --- to the other part.+-- > CSTROKE - closed and stroke ---type PointDisplace u = Point2 u -> Point2 u+-- > CFILL - closed and filled+--+-- > CFILL_STROKE - closed, the path is filled, its edge is stroked.+--+data PathMode = OSTROKE | CSTROKE | CFILL | CFILL_STROKE+  deriving (Bounded,Enum,Eq,Ord,Show) --- | 'displace' : @ x -> y -> PointDisplace @+++-- | Draw closed paths and shapes. +-- +-- > DRAW_STROKE - closed and stroked ----- Build a combinator to move @Points@ by the supplied @x@ and --- @y@ distances.+-- > DRAW_FILL - closed and filled ---displace :: Num u => u -> u -> PointDisplace u-displace dx dy (P2 x y) = P2 (x+dx) (y+dy)+-- > DRAW_FILL_STROKE - the path is filled, its edge is stroked.+--+data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE+  deriving (Bounded,Enum,Eq,Ord,Show)  --- | 'displaceV' : @ (V2 x y) -> PointDisplace @+-- | Interpret a 'DrawMode' for a closed path.+--+closedMode :: DrawMode -> PathMode+closedMode DRAW_STROKE      = CSTROKE +closedMode DRAW_FILL        = CFILL +closedMode DRAW_FILL_STROKE = CFILL_STROKE++++++-- | Enumerated type for drawing with respect to the z-order.+--+data ZOrder = ZBELOW | ZABOVE+  deriving (Bounded,Enum,Eq,Ord,Show)+++--------------------------------------------------------------------------------++-- Alignment++-- | Horizontal alignment - align to the top, center or bottom.+--+data HAlign = HALIGN_TOP | HALIGN_CENTER | HALIGN_BASE+  deriving (Enum,Eq,Ord,Show)++-- | Vertical alignment - align to the left, center or bottom.+--+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. -- --- Version of 'displace' where the displacement is supplied as--- a vector rather than two parameters.+-- 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. -- -displaceVec :: Num u => Vec2 u -> PointDisplace u-displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)+data TextHeight = JUST_CAP_HEIGHT | CAP_HEIGHT_PLUS_DESCENDER+  deriving (Enum,Eq,Ord,Show)  --- | 'displaceH' : @ x -> PointDisplace @--- --- Build a combinator to move @Points@ by horizontally the --- supplied @x@ distance.++--------------------------------------------------------------------------------++-- Compass positions++-- | An enumeratied type representing the compass positions. ---displaceH :: Num u => u -> PointDisplace u-displaceH dx (P2 x y) = P2 (x+dx) y+data Cardinal = NORTH | NORTH_EAST | EAST | SOUTH_EAST +              | SOUTH | SOUTH_WEST | WEST | NORTH_WEST+   deriving (Enum,Eq,Ord,Show)  --- | 'displaceV' : @ y -> PointDisplace @--- --- Build a combinator to move @Points@ vertically by the supplied --- @y@ distance.++-- | An enumerated type representing horizontal and vertical +-- directions. ---displaceV :: Num u => u -> PointDisplace u-displaceV dy (P2 x y) = P2 x (y+dy)+data Direction = UP | DOWN | LEFT | RIGHT+   deriving (Enum,Eq,Ord,Show)   --- | 'ThetaPointDisplace' is a type representing functions --- @from Radian * Point to Point@.+-- | An enumerated type representing horizontal direction. ----- It is useful for building arrowheads which are constructed --- with an implicit angle representing the direction of the line --- at the arrow tip.+data HDirection = LEFTWARDS | RIGHTWARDS+   deriving (Enum,Eq,Ord,Show) +++horizontalDirection :: Radian -> HDirection+horizontalDirection = fn . circularModulo+  where+    fn a | a <= 0.5*pi || a > 1.5*pi = RIGHTWARDS+         | otherwise                 = LEFTWARDS++-- | An enumerated type representing vertical direction. ---type ThetaPointDisplace u = Radian -> PointDisplace u+data VDirection = UPWARDS | DOWNWARDS+   deriving (Enum,Eq,Ord,Show)   +verticalDirection :: Radian -> VDirection+verticalDirection = fn . circularModulo+  where+    fn a | a <= pi   = UPWARDS+         | otherwise = DOWNWARDS+   --- | 'displaceParallel' : @ dist -> ThetaPointDisplace @--- --- Build a combinator to move @Points@ in parallel to the --- direction of the implicit angle by the supplied distance --- @dist@. +-- | An enumerated type representing /clock/ directions. ---displaceParallel :: Floating u => u -> ThetaPointDisplace u-displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d+data ClockDirection = CW | CCW+   deriving (Enum,Eq,Ord,Show)   --- | 'displaceParallel' : @ dist -> ThetaPointDisplace @--- --- Build a combinator to move @Points@ perpendicular to the --- direction of the implicit angle by the supplied distance --- @dist@. ++-- | Note - behaviour at the continuity (0 deg, 180 deg, ...) is+-- unspecified. ---displacePerpendicular :: Floating u => u -> ThetaPointDisplace u-displacePerpendicular d = -    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d+clockDirection :: (Real u, Floating u) +               => Vec2 u -> Vec2 u -> ClockDirection+clockDirection v1 v2 = if a1 < asum then CW else CCW+  where+    a1   = r2d $ vdirection v1+    asum = r2d $ vdirection (v1 ^+^ v2)   +-- | An enumerated type representing quadrants.+-- +data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE+  deriving (Enum,Eq,Ord,Show) +-- | 'quadrant' : @ ang -> Quadrant @+--+-- Get the quadrant of an angle.+--+quadrant :: Radian -> Quadrant+quadrant = fn . circularModulo+  where+    fn a | a < 0.5*pi   = QUAD_NE+         | a < pi       = QUAD_NW+         | a < 1.5*pi   = QUAD_SW+         | otherwise    = QUAD_SE ++ ----------------------------------------------------------------------------------- Monadic drawing+-- Beziers --- | DUnit is always for fully saturated type constructors, so --- (seemingly) an equivalent type family is needed for monads.+kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3) -type family MonUnit m :: *   --- | A monad that supplies points, e.g. a turtle monad. +-- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @ ----- \*\* WARNING \*\* - the idea behind this class is somewhat--- half-baked. It may be revised or even dropped in subsequent--- versions of Wumpus-Basic.+-- > ang should be in the range 0 < ang < 360deg. ---class Monad m => PointSupplyM (m :: * -> *) where-  position :: MonUnit m ~ u => m (Point2 u)+-- > if   0 < ang <=  90 returns 4 points+-- > if  90 < ang <= 180 returns 7 points+-- > if 180 < ang <= 270 returns 10 points+-- > if 270 < ang <  360 returns 13 points+--+bezierArcPoints ::  Floating u +                => Radian -> u -> Radian -> Point2 u -> [Point2 u]+bezierArcPoints ang radius theta pt = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+      in [p0,p1,p2,p3]++    wedge2 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6 ] ++    wedge3 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt+          (_ ,p7,p8,p9) = bezierMinorArc a radius (theta+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] +  +    wedge4 a = +      let (p0,p1,p2,p3)    = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6)    = bezierMinorArc a radius (theta+a) pt+          (_ ,p7,p8,p9)    = bezierMinorArc a radius (theta+a+a) pt+          (_ ,p10,p11,p12) = bezierMinorArc a radius (theta+a+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] +++-- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+bezierMinorArc :: Floating u +               => Radian -> u -> Radian -> Point2 u +               -> (Point2 u, Point2 u, Point2 u, Point2 u)+bezierMinorArc ang radius theta pt = (p0,p1,p2,p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ ang + theta++    p0      = pt .+^ orthoVec radius 0 theta+    p1      = p0 .+^ orthoVec 0 rl theta+    p2      = p3 .+^ orthoVec 0 (-rl) totang+    p3      = pt .+^ orthoVec radius 0 totang+++--------------------------------------------------------------------------------+++-- | 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+++-- | Monodial scheme - prefix, repeat body n times, suffix.+--+monPreRepeatPost :: Monoid a => a -> (Int, a) -> a -> a+monPreRepeatPost pre (n,body1) post = step pre n+  where+    step ac i | i < 1     = ac `mappend` post+              | otherwise = step (ac `mappend` body1) (i - 1) +
− src/Wumpus/Basic/Kernel/Base/ContextFun.hs 
@@ -1,550 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.ContextFun--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Function types operating over the DrawingContext as a /static/ --- argument. --------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.ContextFun-  (--  -- * /Context functional/ types-    CF     -  , CF1-  , CF2--  , LocCF-  , LocThetaCF-  , ConnectorCF-  , DLocCF-  , DLocThetaCF-  , DConnectorCF----  -- * Run functions-  , runCF-  , runCF1 -  , runCF2--  -- * Lift functions-  , lift0R1-  , lift0R2-  , lift1R2- -  , promoteR1-  , promoteR2---  , apply1R1-  , apply2R2-  , apply1R2--  -- * Extractors-  , drawingCtx-  , queryCtx-  , locCtx-  , locPoint-  , locThetaCtx-  , locThetaPoint-  , locThetaAng-  , connCtx-  , connStart-  , connEnd--  -- * Combinators-  , at-  , rot-  , atRot-  , connect-  , chain1---  ) where--import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.DrawingContext--import Wumpus.Core                              -- package: wumpus-core---import Control.Applicative-import Data.Monoid------------------------------------------------------------------------------------------ | Most drawing operations in Wumpus-Basic have an implicit --- /graphics state/ the 'DrawingContext', so the most primitive --- building block is a function from the DrawingContext to some --- polymorphic answer.--- --- This functional type is represented concretely as the initials --- @CF@ for /contextual function/.--- --- > CF :: DrawingContext -> a ----newtype CF a            = CF  { unCF :: DrawingContext -> a }----- | Variation of 'CF' with one parametric /static argument/.------ The static argument is commonly a point representing the start --- point / origin of a drawing.--- --- > CF1 :: DrawingContext -> r1 -> a ----newtype CF1 r1 a        = CF1 { unCF1 :: DrawingContext -> r1 -> a }----- | Variation of 'CF' with two parametric /static arguments/.------ The first argument is commonly a point representing the start --- point / origin of a drawing. The second argument might --- typically be the angle of displacement (for drawing arrowheads) --- or an end point (for drawing connectors between two points).--- --- > CF2 :: DrawingContext -> r1 -> r2 -> a ----newtype CF2 r1 r2 a     = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a }-- ---- | Type specialized verison of 'CF1' where the /static argument/--- is the /start point/.--- --- > LocCF :: DrawingContext -> Point2 u -> a ----type LocCF          u a = CF1 (Point2 u) a----- | Type specialized verison of 'CF2' where the /static arguments/--- are the /start point/ and the /angle of displacement/.--- --- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a ----type LocThetaCF     u a = CF2 (Point2 u) Radian a----- | Type specialized verison of 'CF2' where the /static arguments/--- are the /start point/ and the /end point/.--- --- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a ----type ConnectorCF    u a = CF2 (Point2 u) (Point2 u) a----- | Alias of 'LocCF' where the unit type is specialized to --- @Double@.----type DLocCF a           = LocCF       Double a----- | Alias of 'LocThetaCF' where the unit type is specialized to --- @Double@.----type DLocThetaCF a      = LocThetaCF  Double a---- | Alias of 'ConnectorCF' where the unit type is specialized to --- @Double@.----type DConnectorCF a     = ConnectorCF Double a--------------------------------------------------------------------------------------- CF instances---- OPlus--instance OPlus a => OPlus (CF a)  where-  fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx--instance OPlus a => OPlus (CF1 r1 a)  where-  fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1--instance OPlus a => OPlus (CF2 r1 r2 a)  where-  fa `oplus` fb = CF2 $ \ctx r1 r2 -> -                          unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2----- Monoid- --- Nothing is stopping monoid instances, though in practice there--- might be few useful types (more in Semgigroup / OPlus)...--instance Monoid a => Monoid (CF a) where -  mempty          = CF $ \_   -> mempty-  fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx--instance Monoid a => Monoid (CF1 r1 a) where -  mempty          = CF1 $ \_   _  -> mempty-  fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1--instance Monoid a => Monoid (CF2 r1 r2 a) where -  mempty          = CF2 $ \_   _  _  -> mempty-  fa `mappend` fb = CF2 $ \ctx r1 r2 -> -                            unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2------ Functor--instance Functor CF where-  fmap f ma = CF $ \ctx -> f $ unCF ma ctx ---instance Functor (CF1 r1) where-  fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 --instance Functor (CF2 r1 r2) where-  fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2------ Applicative--instance Applicative CF where-  pure a    = CF $ \_   -> a-  mf <*> ma = CF $ \ctx -> let f = unCF mf ctx-                               a = unCF ma ctx-                           in f a---instance Applicative (CF1 r1) where-  pure a    = CF1 $ \_   _  -> a-  mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 -                                   a = unCF1 ma ctx r1-                               in f a---instance Applicative (CF2 r1 r2) where-  pure a    = CF2 $ \_   _  _  -> a-  mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2-                                      a = unCF2 ma ctx r1 r2-                                  in f a------- Monad --instance Monad CF where-  return a  = CF $ \_   -> a-  ma >>= k  = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx --instance Monad (CF1 r1) where-  return a  = CF1 $ \_   _  -> a-  ma >>= k  = CF1 $ \ctx r1 -> let a = unCF1 ma ctx  r1 in (unCF1 . k) a ctx r1 --instance Monad (CF2 r1 r2) where-  return a  = CF2 $ \_   _  _  -> a-  ma >>= k  = CF2 $ \ctx r1 r2 -> -                      let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2------ DrawingCtxM --instance DrawingCtxM CF where-  askDC           = CF $ \ctx -> ctx-  localize upd df = CF $ \ctx -> unCF df (upd ctx)-  --instance DrawingCtxM (CF1 r1) where-  askDC           = CF1 $ \ctx _  -> ctx-  localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1---instance DrawingCtxM (CF2 r1 r2) where-  askDC           = CF2 $ \ctx _  _  -> ctx-  localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2----- Note - there is nothing determining a DUnit for the CF types, --- so it seems appropriate not to define affine instances.------ However affine instances can be made for the Image type in --- Objects.BaseObjects.----------------------------------------------------------------------------------------- Run functions---- | Run a /CF/ (context function) with the supplied --- /DrawingContext/.----runCF :: DrawingContext -> CF a -> a-runCF ctx df = unCF df ctx----- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and static argument.----runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a-runCF1 ctx r1 df = unCF1 df ctx r1----- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and two static arguments.----runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a-runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2--------------------------------------------------------------------------------------- lift functions----- | Lift a zero-arity context function 'CF' to an arity one --- context function 'CF1'.--- -lift0R1             :: CF a -> CF1 r1 a-lift0R1 mf          = CF1 $ \ctx _ -> unCF mf ctx---- | Lift a zero-arity context function 'CF' to an arity two --- context function 'CF2'.--- -lift0R2             :: CF a -> CF2 r1 r2 a-lift0R2 mf          = CF2 $ \ctx _ _ -> unCF mf ctx---- | Lift an arity one context function 'CF1' to an arity two--- context function 'CF2'.--- -lift1R2             :: CF1 r1 a -> CF2 r1 r2 a-lift1R2 mf          = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1------ | Promote a function @from one argument to a Context Function@ --- to an arity one @Context Function@.------ The type signature is as explanatory as a description:------ > promoteR1 :: (r1 -> CF a) -> CF1 r1 a--- -promoteR1           :: (r1 -> CF a) -> CF1 r1 a-promoteR1 mf        = CF1 $ \ctx r1 -> unCF (mf r1) ctx---- | Promote a function @from two arguments to a Context Function@ --- to an arity two @Context Function@.------ The type signature is as explanatory as a description:------ > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a--- -promoteR2           :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a-promoteR2 mf        = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx------ | Apply an arity-one Context Function to a single argument, --- downcasting it by one level, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description:------ > apply1R1 :: CF1 r1 a -> r1 -> CF a----apply1R1            :: CF1 r1 a -> r1 -> CF a-apply1R1 mf r1      = CF $ \ctx -> unCF1 mf ctx r1----- | Apply an arity-two Context Function to two arguments, --- downcasting it by two levels, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description:------ > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a--- -apply2R2            :: CF2 r1 r2 a -> r1 -> r2 -> CF a-apply2R2 mf r1 r2   = CF $ \ctx -> unCF2 mf ctx r1 r2---- | Apply an arity-two Context Function to one argument, --- downcasting it by one level, making an arity-one Context --- function. --- --- The type signature is as explanatory as a description:------ > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a----apply1R2            :: CF2 r1 r2 a -> r2 -> CF1 r1 a-apply1R2 mf r2      = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2-------------------------------------------------------------------------------------- extractors ---- | Extract the drawing context from a CtxFun.------ > (ctx -> ctx)--- -drawingCtx      :: CF DrawingContext-drawingCtx      = CF $ \ctx -> ctx---- | Apply the projection function to the drawing context.------ > (ctx -> a) -> (ctx -> a)----queryCtx        :: (DrawingContext -> a) -> CF a-queryCtx f      = CF $ \ctx -> f ctx----- | Extract the drawing context from a LocCF.------ > (ctx -> pt -> ctx)----locCtx          :: LocCF u DrawingContext-locCtx          = CF1 $ \ctx _  -> ctx---- | Extract the /start/ point from a LocCF.------ > (ctx -> pt -> pt)----locPoint        :: LocCF u (Point2 u)-locPoint        = CF1 $ \_ pt -> pt----- | Extract the drawing context from a LocThetaCF.------ > (ctx -> pt -> ang -> ctx)----locThetaCtx     :: LocThetaCF u DrawingContext-locThetaCtx     = CF2 $ \ctx _ _ -> ctx----- | Extract the /start/ point from a LocThetaCF.------ > (ctx -> pt -> ang -> pt)----locThetaPoint   :: LocThetaCF u (Point2 u)-locThetaPoint   = CF2 $ \_ pt _ -> pt---- | Extract the angle from a LocThetaCF.------ > (ctx -> pt -> ang -> ang)----locThetaAng     :: LocThetaCF u Radian-locThetaAng     = CF2 $ \_ _ ang -> ang---- | Extract the drawing context from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> ctx)----connCtx         :: ConnectorCF u DrawingContext-connCtx         = CF2 $ \ctx _ _ -> ctx---- | Extract the start point from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> pt1)----connStart       :: ConnectorCF u (Point2 u) -connStart       = CF2 $ \_ pt _ -> pt---- | Extract the end point from a ConnectorCF.------ > (ctx -> pt1 -> pt2 -> pt2)----connEnd         :: ConnectorCF u (Point2 u) -connEnd         = CF2 $ \_ _ pt -> pt----------------------------------------------------------------------------------------- Combinators----infixr 1 `at`----- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context Function. --- --- Remember a 'LocCF' function is a 'CF1' context function where--- the /static argument/ is specialized to a start point.----at :: LocCF u a -> Point2 u -> CF a-at = apply1R1---infixr 1 `rot`----- | Downcast a 'LocThetaCF' function by applying it to the --- supplied angle, making an arity-one Context Function (a --- 'LocCF'). --- --rot :: LocThetaCF u a -> Radian -> LocCF u a-rot = apply1R2----- | Downcast a 'LocThetaCF' function by applying it to the --- supplied point and angle, making an arity-zero Context --- Function (a 'CF'). ----atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a-atRot = apply2R2----- | Downcast a 'ConnectorCF' function by applying it to the --- start and end point, making an arity-zero Context Function --- (a 'CF'). --- -connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a-connect = apply2R2----infixr 6 `chain1`---- | /Chaining/ combinator - the /answer/ of the --- first Context Function is feed to the second Context Function. ------ This contrasts with the usual idiom in @Wumpus-Basic@ where --- composite graphics are built by applying both functions to the --- same initial /static argument/.------ Desciption:------ Evaluate the first Context Function with the drawing context --- and the /initial state/ @st0@. The result of the evaluation is --- a new /state/ @st1@ and and answer @a1@. ------ Evaluate the second Context Function with the drawing context --- and the new state @st1@, producing a new state @s2@ and an --- answer @a2@.------ Return the result of combining the answers with --- @op :: (ans -> ans -> ans)@ and the second state @s2@.------ @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @------ This models chaining start points together, which is the model--- PostScript uses for text output when successively calling the --- @show@ operator.--- -chain1 :: OPlus w -            => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w)-chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s-                                 (s2,a2) = unCF1 g ctx s1-                             in (s2, a1 `oplus` a2)--
src/Wumpus/Basic/Kernel/Base/DrawingContext.hs view
@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.DrawingContext--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -24,22 +24,23 @@ module Wumpus.Basic.Kernel.Base.DrawingContext   (  -  -- * Drawing context+  -- * Drawing context types     DrawingContext(..)-  , DrawingContextF +  , DrawingContextF   , TextMargin(..) +  -- * Construction   , standardContext   , metricsContext+  , addFontTables -  , default_drawing_context+  , reset_drawing_properties+  , reset_drawing_metrics    -- * DrawingCtxM (reader) monad   , DrawingCtxM(..)-  , asksDC -   -- * Glyph metrics   , withFontMetrics @@ -47,13 +48,15 @@   ) where  -import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Core                              -- package: wumpus-core import Wumpus.Core.Text.StandardEncoding  import Control.Applicative import Data.Maybe+import Data.Monoid  -- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic.  -- DrawingContext is operated on within a Reader monad rather than @@ -61,29 +64,30 @@ -- operation (called @localize@ in Wumpus), rather than permanent -- until overridden as per @set@ of a State monad. -- --- Note - @round_corner_factor@ is only accounted for by some --- graphic objects (certain Path objects and Shapes in --- Wumpus-Drawing for instance). There many be many objects that --- ignore it and are drawn only with angular corners.--- --- Also note - in contrast to most other drawing objects in --- Wumpus, none of the measurement values are parameteric - --- usually notated with the type variable @u@ in Wumpus. This is --- so Wumpus can (potentially) support different units e.g. --- centimeters rather than just Doubles (represening printers --- points), though adding support for other units has a very low --- priority.--- +-- Note - in contrast to most other drawing objects in Wumpus, +-- none of the types of measurement values are parameteric  +-- (usually notated with the type variable @u@ in Wumpus). Types +-- are either 'Double' representing PostScript points or Em - a +-- contextual size that is interpreted according to the current +-- font size.+--+-- It is easier to specialize all the measurement types and +-- within the 'DrawingContext' and add parametricity to the +-- /getters/ and /setters/ instead.+-- data DrawingContext = DrawingContext-      { glyph_tables          :: GlyphMetrics-      , fallback_metrics      :: MetricsOps-      , stroke_props          :: StrokeAttr-      , font_props            :: FontAttr-      , stroke_colour         :: RGBi      -- also text colour...-      , fill_colour           :: RGBi      -      , line_spacing_factor   :: Double-      , round_corner_factor   :: Double -      , text_margin           :: TextMargin+      { dc_font_metrics_table   :: FontTable+      , dc_font_load_log        :: FontLoadLog+      , dc_fallback_metrics     :: FontMetrics+      , dc_font_face            :: FontFace+      , dc_font_size            :: !FontSize+      , dc_snap_grid_factors    :: (Double,Double)+      , dc_stroke_props         :: StrokeAttr+      , dc_stroke_colour        :: RGBi+      , dc_fill_colour          :: RGBi      +      , dc_text_colour          :: RGBi+      , dc_line_spacing_factor  :: Double+      , dc_text_margin          :: TextMargin       }  -- TODO - what parts of the Drawing Context should be strict? @@ -93,43 +97,163 @@ -- type DrawingContextF = DrawingContext -> DrawingContext --- | The unit of Margin is always Double representing Points, e.g.--- 1.0 is 1 Point. Margins are not scaled relative to the current--- font size.+-- | The text margin is measured in 'Em' so it is relative to the+-- current font size. -- --- The default value is 2 point.+-- The default value is 0.5. -- data TextMargin = TextMargin-       { text_margin_x          :: !Double-       , text_margin_y          :: !Double+       { text_margin_x          :: !Em+       , text_margin_y          :: !Em        }   +-- | 'standardContext' : @ font_size -> DrawingContext @  +--+-- Create a 'DrawingContext'.+-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their+-- metrics derived from the font size.+-- +-- No real font metrics are present in the 'DrawingContext' +-- created by 'standardContext'. Static, hard-coded fallback +-- metrics derived from the @Courier@ font are available but+-- these metrics might not accurately correspond to the +-- @Courier@ available to the the final renderer (GhostScript,+-- an SVG viewer, etc.).+-- +-- Use this constructor for drawings that make primitive use of+-- text.+-- +-- > font_metrics_table:  empty+-- > font_load_log:       empty+-- > fallback_metrics:    monospace_metrics+-- > font_face:           Courier+-- > font_size:           @supplied_font_size@+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour:       black+-- > fill_colour:         light_gray+-- > text_colour:         black+-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+-- standardContext :: FontSize -> DrawingContext standardContext sz = -    DrawingContext { glyph_tables         = emptyGlyphMetrics-                   , fallback_metrics     = monospace_metrics-                   , stroke_props         = default_stroke_attr-                   , font_props           = FontAttr sz wumpus_courier-                   , stroke_colour        = wumpus_black-                   , fill_colour          = wumpus_light_gray-                   , line_spacing_factor  = 1.2  -                   , round_corner_factor  = 0-                   , text_margin          = standardTextMargin+    DrawingContext { dc_font_metrics_table   = emptyFontTable+                   , dc_font_load_log        = mempty+                   , dc_fallback_metrics     = monospace_metrics+                   , dc_font_face            = wumpus_courier+                   , dc_font_size            = sz+                   , dc_stroke_props         = default_stroke_attr+                   , dc_snap_grid_factors    = (50.0, 50.0)+                   , dc_stroke_colour        = wumpus_black+                   , dc_fill_colour          = wumpus_light_gray+                   , dc_text_colour          = wumpus_black+                   , dc_line_spacing_factor  = default_line_spacing  +                   , dc_text_margin          = default_text_margin                    } -standardTextMargin :: TextMargin-standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 } --- out-of-date - should be adding loaded fonts, not replacing the --- GlyphMetrics Map wholesale.+-- | 'metricsContext' : @ font_size * font_metrics -> DrawingContext @   ---metricsContext :: FontSize -> GlyphMetrics -> DrawingContext-metricsContext sz bgm = -    let env = standardContext sz in env { glyph_tables = bgm }+-- Create a 'DrawingContext' with font metrics loaded from the +-- file system.+-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their+-- metrics derived from the font size.+-- +-- Use this constructor for drawings that make use of the text +-- objects provided by @Wumpus-Drawing@ (DocText and RotText).+-- +metricsContext :: FontSize -> FontLoadResult -> DrawingContext+metricsContext sz res = +    let env = standardContext sz +    in env { dc_font_metrics_table = loaded_font_table res+           , dc_font_load_log      = loader_errors res+           }  ++-- | 'addFontTables' : @ font_load_result -> DrawinContextUpdate @+--+-- Add the font metrics from the FontLoadResult, if a font with +-- the same name alreay exists in the 'DrawingContext' it will be +-- replaced. Error and warning messages in the @font_load_result@ +-- will be appended to the 'font_load_log'.+--+addFontTables :: FontLoadResult -> DrawingContextF+addFontTables (FontLoadResult table msgs) = +    (\s i j -> s { dc_font_metrics_table = i `mappend` table+                 , dc_font_load_log      = j `mappend` msgs }) +      <*> dc_font_metrics_table <*> dc_font_load_log++++-- | 'reset_drawing_properties' : @ DrawingContextF @  +--+-- Reset the drawing properties in the 'DrawingContext' to their +-- default values. This changes the following fields:+--+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour:       black+-- > fill_colour:         light_gray+-- > text_colour:         black+-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+reset_drawing_properties :: DrawingContextF +reset_drawing_properties dcxt = +    dcxt { dc_stroke_props          = default_stroke_attr+         , dc_stroke_colour         = wumpus_black+         , dc_fill_colour           = wumpus_light_gray+         , dc_text_colour           = wumpus_black+         , dc_line_spacing_factor   = default_line_spacing+         , dc_text_margin           = default_text_margin+         }++-- Ideally @reset_drawing_properties@ would be in the UpdateDC +-- module, but that would mean exporting @default_line_spacing@ +-- etc.+--++++-- | 'reset_drawing_metrics' : @ DrawingContextF @  +--+-- Reset the drawing metrics in the 'DrawingContext' to their +-- default values. This is a more limited version of+-- 'reset_drawing_properties' and changes the following fields:+--+-- > stroke_props:        line_width 1, no dash_pattern, cap-butt, join-miter. +-- > line_spacing_factor: 0.2+-- > round_corner_factor: 0+-- > text_margin:         (0.5 em, 0.5 em) +--+reset_drawing_metrics :: DrawingContextF +reset_drawing_metrics dcxt = +    dcxt { dc_stroke_props          = default_stroke_attr+         , dc_line_spacing_factor   = default_line_spacing+         , dc_text_margin           = default_text_margin+         }++++-- Helpers - not exported++default_text_margin :: TextMargin+default_text_margin = TextMargin { text_margin_x = 0.5, text_margin_y = 0.5 }++++default_line_spacing :: Double+default_line_spacing = 0.2+ wumpus_black            :: RGBi wumpus_black            = RGBi 0 0 0  @@ -144,26 +268,27 @@     FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding  --default_drawing_context :: DrawingContext-default_drawing_context = -    standardContext (font_size wumpus_default_font)--- -------------------------------------------------------------------------------- --class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where-  askDC    :: m DrawingContext-  localize :: (DrawingContext -> DrawingContext) -> m a -> m a----- | Project a value out of a context.+-- | 'DrawingCtxM' is equivalent to the to the @MonadReader@ +-- class, but the environment type is fixed to 'DrawingContext'. ---asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a-asksDC f = askDC >>= (return . f)+-- To avoid name clashes with @mtl@ this scheme is used:+--+-- > askDC    = ask+-- > asksDC   = asks+-- > localize = local+--+-- Note, because the derived operation 'query' (aka @asks@) is+-- expected to be used more often than queryCtx (aka @ask@) it +-- gets the more convenient name.+--+class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where+  askDC     :: m DrawingContext+  asksDC    :: (DrawingContext -> a) -> m a+  localize  :: (DrawingContext -> DrawingContext) -> m a -> m a +  asksDC f  = f <$> askDC   --------------------------------------------------------------------------------@@ -173,13 +298,15 @@   -withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u-withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = -      fn metric_set point_sz+withFontMetrics :: (FontMetrics -> FontSize -> u) -> DrawingContext -> u+withFontMetrics fn ctx@(DrawingContext { dc_font_face = fface+                                       , dc_font_size = ftsize }) = +      fn metric_set ftsize   where -    ps_name     = ps_font_name $ font_face font_stats-    point_sz    = fromIntegral $ font_size font_stats -    metric_set  = fromMaybe (fallback_metrics ctx) $ -                    lookupFont ps_name (glyph_tables ctx) +    ps_name     = ps_font_name fface+    metric_set  = fromMaybe (dc_fallback_metrics ctx) $ +                    lookupFont ps_name (dc_font_metrics_table ctx)++
+ src/Wumpus/Basic/Kernel/Base/FontSupport.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE RankNTypes                 #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Base.FontSupport+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Data types representing font metrics.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Base.FontSupport+  ( ++    FontName+  , CodePoint+  , FontDef(..)+  , FontFamily(..)+  , regularWeight+  , boldWeight+  , italicWeight+  , boldItalicWeight++  , CharWidthLookup++  , FontMetrics(..)++  , FontTable+  , emptyFontTable+  , lookupFont+  , insertFont++  , FontLoadMsg+  , FontLoadLog+  , fontLoadMsg++  , FontLoadResult(..)+  , printLoadErrors++  , monospace_metrics++  +  ) where++import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import qualified Data.Map      as Map+import Data.Monoid++++type FontName = String++-- | A Unicode code-point.+--+type CodePoint = Int++-- | FontDef wraps @FontFace@ from Wumpus-Core with file name+-- information for the font loaders.+--+data FontDef = FontDef+      { font_def_face   :: FontFace+      , gs_file_name    :: String+      , afm_file_name   :: String+      }+  deriving (Eq,Ord,Show)++++-- | A family group of FontDefs (regular, bold, italic and +-- bold-italic).+--+-- It is convenient for some higher-level text objects in Wumpus +-- (particularly @Doc@ in Wumpus-Drawing) to treat a font and its+-- standard weights as the same entity. This allows @Doc@ API to +-- provide a @bold@ operation to simply change to the the bold+-- weight of the current family, rather than use the primitive +-- @set_font@ operation to change to an explicitly named font.+--+--+data FontFamily = FontFamily+      { ff_regular      :: FontDef+      , ff_bold         :: Maybe FontDef+      , ff_italic       :: Maybe FontDef+      , ff_bold_italic  :: Maybe FontDef  +      }++-- | Extract the regular weight 'FontDef' from a 'FontFamily'.+--+regularWeight :: FontFamily -> FontDef+regularWeight = ff_regular+++-- | Extract the bold weight 'FontDef' from a 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no bold weight. To get the bold weight or @Nothing@ if it+-- is not present use the record selector @ff_bold@.+--+boldWeight :: FontFamily -> FontDef+boldWeight s = maybe (ff_regular s) id $ ff_bold s+++-- | Extract the @italic@ weight 'FontDef' from a 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no italic weight. To get the italic weight or @Nothing@ if +-- it is not present use the record selector @ff_italic@.+--+italicWeight :: FontFamily -> FontDef+italicWeight s = maybe (ff_regular s) id $ ff_italic s+++-- | Extract the @bold-italic@ weight 'FontDef' from a +-- 'FontFamily'.+--+-- Note - this falls back to the regular weight if the font family +-- has no bold-italic weight. To get the bold-italic weight or +-- @Nothing@ if it is not present use the record selector +-- @ff_bold_italic@.+--+boldItalicWeight :: FontFamily -> FontDef+boldItalicWeight s = maybe (ff_regular s) id $ ff_bold_italic s++++-- | A lookup function from code point to /width vector/.+--+-- The unit is always stored as a Double representing PostScript+-- points.+--+-- Note - in PostScript terminology a width vector is not obliged+-- to be left-to-right (writing direction 0). It could be +-- top-to-bottom (writing direction 1).+--+type CharWidthLookup = CodePoint -> Vec2 Double++++-- | 'FontMetrics' store a subset of the properties available in +-- a font file - enough to calculate accurate bounding boxes and+-- positions for text.+--+-- > Bounding box representing the maximum glyph area.+-- > Width vectors for each character.+-- > Cap height+-- > Descender depth.+--+-- Because Wumpus always needs font metrics respective to the +-- 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_underline_position    :: FontSize -> Double+    , get_underline_thickness   :: FontSize -> Double+    }+++-- | A map between a font name and the respective FontMetrics.+--+newtype FontTable = FontTable { +          getFontTable :: Map.Map FontName FontMetrics }++++instance Monoid FontTable where+  mempty        = emptyFontTable+  a `mappend` b = FontTable $ getFontTable a `mappend` getFontTable b+++emptyFontTable :: FontTable+emptyFontTable = FontTable $ Map.empty+++-- | 'FontLoadMsg' - type synonym for String.+--+type FontLoadMsg        = String++-- | 'FontLoadLog' is a Hughes list of Strings, so it supports +-- efficient append.+--+newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H FontLoadMsg }+++instance Monoid FontLoadLog where+  mempty        = FontLoadLog $ emptyH+  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b+++fontLoadMsg :: String -> FontLoadLog +fontLoadMsg = FontLoadLog . wrapH+++-- Need a synonym for @FontLoading@...+data FontLoadResult = FontLoadResult+      { loaded_font_table    :: FontTable+      , loader_errors        :: FontLoadLog+      }+++-- | Print the loader errors from the 'FontLoadResult' to std-out.+--+printLoadErrors :: FontLoadResult -> IO ()+printLoadErrors = mapM_ putStrLn . toListH . getFontLoadLog . loader_errors++--------------------------------------------------------------------------------+++-- | 'lookupFont' : @ name * font_table -> Maybe FontMetrics @ +-- +-- Lookup a font in the font_table.+-- +lookupFont :: FontName -> FontTable -> Maybe FontMetrics+lookupFont name = Map.lookup name . getFontTable++-- | 'insertFont' : @ name * font_metrics * font_table -> FontTable @ +-- +-- Insert a named font into the font_table.+-- +insertFont :: FontName -> FontMetrics -> FontTable -> FontTable+insertFont name ops = +    FontTable . Map.insert name ops . getFontTable++-- | This ignores the Char code lookup and just returns the +-- default advance vector.+--+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_underline_position    = \sz -> upscale sz underline_pos+    , get_underline_thickness   = \sz -> upscale sz underline_width+    }+  where+    llx             = (-23)  / 1000+    lly             = (-250) / 1000+    urx             = 715    / 1000+    ury             = 805    / 1000+    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) +    upperRight sz   = P2 (upscale sz urx) (upscale sz ury) ++
− src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE RankNTypes                 #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.GlyphMetrics--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Data types representing glyph metrics loaded from font files.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.GlyphMetrics-  ( --    FontName-  , CodePoint-  , CharWidthTable-  , MetricsOps(..)-  , FontMetricsOps(..)--  , GlyphMetrics-  , emptyGlyphMetrics-  , lookupFont-  , insertFont--  , monospace_metrics--  -  ) where--import Wumpus.Core                              -- package: wumpus-core--import qualified Data.Map      as Map-import Data.Monoid----type FontName = String---- | A Unicode code-point.----type CodePoint = Int---- | A lookup from code point to /width vector/.------ Note - in PostScript terminology a width vector is not obliged--- to be left-to-right (writing direction 0). It could be --- top-to-bottom (writing direction 1).----type CharWidthTable u = CodePoint -> Vec2 u------ | Operations on the metrics set of a font.------ The is the internal representation used by Wumpus-Basic after--- parsing the font file.----data MetricsOps = MetricsOps-      { get_bounding_box  :: forall u. FromPtSize u => PtSize -> BoundingBox u -      , get_cw_table      :: forall u. FromPtSize u => PtSize -> CharWidthTable u-      , get_cap_height    :: forall u. FromPtSize u => PtSize -> u-      }---- | 'MetricsOps' tfor a particular named font.--- -data FontMetricsOps = FontMetricsOps FontName MetricsOps----- | A map between a font name and MetricsOps.----newtype GlyphMetrics = GlyphMetrics { -          getGlyphMetrics :: Map.Map FontName MetricsOps }--instance Monoid GlyphMetrics where-  mempty        = emptyGlyphMetrics-  a `mappend` b = GlyphMetrics $ getGlyphMetrics a `mappend` getGlyphMetrics b---emptyGlyphMetrics :: GlyphMetrics-emptyGlyphMetrics = GlyphMetrics $ Map.empty--lookupFont :: FontName -> GlyphMetrics -> Maybe MetricsOps-lookupFont name = Map.lookup name . getGlyphMetrics--insertFont :: FontMetricsOps -> GlyphMetrics -> GlyphMetrics-insertFont (FontMetricsOps name ops) = -    GlyphMetrics . Map.insert name ops . getGlyphMetrics---- | This ignores the Char code lookup and just returns the --- default advance vector.----monospace_metrics :: MetricsOps-monospace_metrics = MetricsOps-    { 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-    }-  where-    llx           = (-23)  / 1000-    lly           = (-250) / 1000-    urx           = 715    / 1000-    ury           = 805    / 1000-    width_vec     = 600    / 1000-    cap_height    = 562    / 1000--    upscale sz d  = fromPtSize $ sz * d-    lowerLeft sz  = P2 (upscale sz llx) (upscale sz lly) -    upperRight sz = P2 (upscale sz urx) (upscale sz ury) --
src/Wumpus/Basic/Kernel/Base/QueryDC.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.QueryDC--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>@@ -12,274 +12,322 @@ -- -- Querying the Drawing Context. --+-- \*\* WARNING \*\* - parts of this module especially the +-- mono-space glyph metrics need a re-think and will change or be +-- dropped.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.QueryDC   (  -    -    textAttr-  , withTextAttr+    normalizeCtx+  , normalizeCtxF+  , dinterpCtx+  , dinterpCtxF -  , strokeAttr-  , withStrokeAttr+  , uconvertCtx1+  , uconvertCtxF -  , fillAttr-  , withFillAttr+  , pointSize +  , strokeAttr+  , fillAttr   , borderedAttr-  , withBorderedAttr+  , textAttr -  , getRoundCornerSize-  , getTextMargin+  , position+  , snapmove +  , textMargin+   , getLineWidth   , getFontAttr   , getFontSize   , getFontFace-  , markHeight-  , markHalfHeight-  , baselineSpacing+  , getTextColour +  , textlineSpace+   -- * Glyph metrics   , glyphBoundingBox-  , glyphHeightRange-  , glyphHeight-  , glyphCapHeight+  , capHeight+  , descender+  , underlinePosition+  , underlineThickness+  , verticalSpan+  , heightSpan -  , cwLookupTable+  -- * Text metrics+  , escTextVector+  , escCharVector+  , hkernVector -  -- * Default monospace metrics+  , cwLookupTable -  , monoFontPointSize-  , monoCharWidth-  , monoTextWidth-  , monoTextLength-  , monoCapHeight-  , monoLowerxHeight-  , monoDescenderDepth-  , monoAscenderHeight-  , monoTextDimensions-  , monoMultiLineHeight-  , monoDefaultPadding-  , monoVecToCenter     ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.GlyphMetrics+import Wumpus.Basic.Kernel.Base.FontSupport  import Wumpus.Core                              -- package: wumpus-core-import qualified Wumpus.Core.FontSize   as FS+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   -textAttr :: DrawingCtxM m => m (RGBi,FontAttr)-textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props---- | Because @textAttr@ is so commonly used here is a functional--- version that avoids tupling. ---withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a-withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props+-- 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 -strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)-strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props+normalizeCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) +             => t u -> m (t Double)+normalizeCtxF t = (\sz -> fmap (normalize sz) t) <$> pointSize -withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a-withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props+dinterpCtx :: (DrawingCtxM m, InterpretUnit u) => Double -> m u+dinterpCtx u = (\sz -> dinterp sz u) <$> pointSize +dinterpCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) => t Double -> m (t u)+dinterpCtxF u = (\sz -> fmap (dinterp sz) u) <$> pointSize +uconvertCtx1 :: (DrawingCtxM m, InterpretUnit u, InterpretUnit u1) +             => u -> m u1+uconvertCtx1 t = (\sz -> uconvert1 sz t) <$> pointSize++uconvertCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u, InterpretUnit u1) +            => t u -> m (t u1)+uconvertCtxF t = (\sz -> uconvertF sz t) <$> pointSize+++pointSize :: DrawingCtxM m => m FontSize+pointSize = asksDC dc_font_size++strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr)+strokeAttr = (,) <$> asksDC dc_stroke_colour <*> asksDC dc_stroke_props+ fillAttr :: DrawingCtxM m => m RGBi-fillAttr = asksDC fill_colour+fillAttr = asksDC dc_fill_colour -withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a-withFillAttr fn = fn <$> asksDC fill_colour  borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi)-borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props -                                           <*> asksDC stroke_colour+borderedAttr = (,,) <$> asksDC dc_fill_colour +                    <*> asksDC dc_stroke_props +                    <*> asksDC dc_stroke_colour -withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a-withBorderedAttr fn = -    fn <$> asksDC fill_colour <*> asksDC stroke_props -                              <*> asksDC stroke_colour  +textAttr :: DrawingCtxM m => m (RGBi,FontAttr)+textAttr = +    (\a b c -> (a, FontAttr b c)) +      <$> asksDC dc_text_colour <*> asksDC dc_font_size <*> asksDC dc_font_face --- | Vertical distance between baselines of consecutive text --- lines.++++-- | Get the Point corresponding the grid coordinates scaled by+-- the snap-grid scaling factors. ---getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u-getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1)-                    <$> asksDC round_corner_factor+position :: (DrawingCtxM m, Fractional u) => (Int, Int) -> m (Point2 u)+position (x,y) = post <$> asksDC dc_snap_grid_factors+  where+    post (sx,sy) = P2 (realToFrac $ sx * fromIntegral x) +                      (realToFrac $ sy * fromIntegral y)   --- | Vertical distance between baselines of consecutive text --- lines.++-- | Scale a vector coordinate by the snap-grid scaling factors. ---getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u)-getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep))-                    <$> asksDC text_margin+-- Absolute units.+--+snapmove :: (DrawingCtxM m, Fractional u) => (Int,Int) -> m (Vec2 u)+snapmove (x,y) = post <$> asksDC dc_snap_grid_factors   where-    fn d = (realToFrac d) * fromPtSize 1+    post (sx,sy) = V2 (realToFrac $ sx * fromIntegral x) +                      (realToFrac $ sy * fromIntegral y)   -getLineWidth :: DrawingCtxM m => m Double-getLineWidth = line_width <$> asksDC stroke_props+-- | Get the (x,y) margin around text.+--+-- Note - not all text operations in Wumpus are drawn with text +-- margin. +-- +textMargin :: (DrawingCtxM m, InterpretUnit u) => m (u,u)+textMargin = post <$> asksDC dc_font_size <*> asksDC dc_text_margin+  where+    post sz (TextMargin xem yem) = (uconvert1 sz xem, uconvert1 sz yem) -getFontAttr :: DrawingCtxM m => m FontAttr-getFontAttr = asksDC font_props -getFontSize :: DrawingCtxM m => m Int-getFontSize = font_size <$> asksDC font_props -getFontFace :: DrawingCtxM m => m FontFace-getFontFace = font_face <$> asksDC font_props  +getLineWidth :: DrawingCtxM m => m Double+getLineWidth = line_width <$> asksDC dc_stroke_props +getFontAttr :: DrawingCtxM m => m FontAttr+getFontAttr = FontAttr <$> asksDC dc_font_size <*> asksDC dc_font_face --- | Vertical distance between baselines of consecutive text --- lines.----baselineSpacing :: (DrawingCtxM m, Fractional u) => m u-baselineSpacing = -    (\sz factor -> realToFrac $ factor * fromIntegral sz)-      <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor --- | The /mark/ height is the height of a lowercase letter in the --- current font.------ Arrowheads, dots etc. should generally be drawn at the mark --- height.--- -markHeight :: (DrawingCtxM m, FromPtSize u) => m u-markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props+getFontSize     :: DrawingCtxM m => m Int+getFontSize     = asksDC dc_font_size +getFontFace     :: DrawingCtxM m => m FontFace+getFontFace     = asksDC dc_font_face -markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u-markHalfHeight = (0.5*) <$> markHeight+getTextColour   :: DrawingCtxM m => m RGBi+getTextColour   = asksDC dc_text_colour  --- Note - there are probably enough functions that use just --- markHeight to merit a withMarkHeight function. +-- | Vertical distance between descender of a line and the +-- cap-height of the line below. +-- +textlineSpace :: (DrawingCtxM m, Fractional u, InterpretUnit u) => m u+textlineSpace = +    post <$> asksDC dc_font_size <*> asksDC dc_line_spacing_factor+  where+    post sz factor = dinterp sz ((fromIntegral sz) * (realToFrac factor))  -------------------------------------------------------------------------------- -glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u++glyphQuery :: DrawingCtxM m => (FontMetrics -> FontSize -> a) -> m a glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC -glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u)-glyphBoundingBox = glyphQuery get_bounding_box  -glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u)-glyphHeightRange = fn <$> glyphBoundingBox-  where-    fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax)+-- | Get the font bounding box - this is the maximum boundary of +-- the glyphs in the font. The span of the height is expected to +-- be bigger than the cap_height plus descender depth.+--+glyphBoundingBox :: (DrawingCtxM m, InterpretUnit u) => m (BoundingBox u)+glyphBoundingBox = +    uconvertF <$> asksDC dc_font_size <*> glyphQuery get_bounding_box  -glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u-glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange +-- | Height of a capital letter.+--+capHeight :: (DrawingCtxM m, InterpretUnit u) => m u+capHeight = dinterp <$> asksDC dc_font_size <*> glyphQuery get_cap_height -glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u-glyphCapHeight = glyphQuery get_cap_height -cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u)-cwLookupTable = glyphQuery get_cw_table+-- | Note - descender is expected to be negative.+--+descender :: (DrawingCtxM m, InterpretUnit u) => m u+descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender  -----------------------------------------------------------------------------------withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u-withFontSize fn = (fn . font_size) <$> asksDC font_props+-- | 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  --- NOTE - textHeight in Wumpus-Core should be renamed as it is--- (probably) more indiactive of Cap height than /font point size/+-- | Line width of underline line. --+underlineThickness :: (DrawingCtxM m, InterpretUnit u) => m u+underlineThickness = +    dinterp <$> asksDC dc_font_size <*> glyphQuery get_underline_thickness -monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u-monoFontPointSize = withFontSize (fromPtSize . fromIntegral) -monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u-monoCharWidth = withFontSize (fromPtSize . FS.charWidth)+-- | This is the distance from cap_height to descender.+--+verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u+verticalSpan = +    (\ch dd -> ch - dd) <$> capHeight <*> descender  -monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u-monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n +-- | 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 -monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u-monoTextLength ss = monoTextWidth $ charCount ss  -monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoCapHeight = withFontSize (fromPtSize . FS.capHeight)--monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight)+--------------------------------------------------------------------------------   --- | Height of a lower case \'x\' in Courier.---  --- \'x\' has no ascenders or descenders. +-- | Find the advance vector for the supplied 'EscapedText'.+--+-- Note - the text assumed to be a single line. -- -monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight)+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 -monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u-monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) -monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u-monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) +-- | 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 --- | Query the dimensions of the text using the current font size--- but using metrics derived from Courier.++-- | This is outside the Drawing context as we don\'t want to get+-- the @cwLookupTable@ for every char. ----- Note - the width will generally be a over-estimate for --- non-monospaced fonts.--- -monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u)-                   => String -> m (u,u)-monoTextDimensions ss = -    (\sz -> post $ textBounds sz zeroPt ss) -      <$> asksDC (font_size . font_props)+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-    post bb = (boundaryWidth bb, boundaryHeight bb)+    ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices  --- | The heigth of @n@ lines of text, which is --- @n lines + n-1 line spacers@----monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) -                        => Int -> m u-monoMultiLineHeight n | n < 0   = pure 0-monoMultiLineHeight n           = -    (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf))-      <$> monoTotalCharHeight <*> asksDC line_spacing_factor- -    -- Note as the height calculation has changed in Wumpus-Core this-    -- no longer quite works...  -  --- | The default padding is half of the /char width/.+-- | '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. ---monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u-monoDefaultPadding = (0.5*) <$> monoCharWidth+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 --- | Vector from baseline left to center+++-- | Note the CharWidthLookup is not parameteric on units. ---monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) -                => String -> m (Vec2 u)-monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) -                       <$> monoTextDimensions ss <*> monoDescenderDepth+-- /CharWidth/ is always Double representing PostScript points.+-- Client code must convert this value accordingly.+--+cwLookupTable :: DrawingCtxM m => m CharWidthLookup+cwLookupTable = glyphQuery get_cw_table
− src/Wumpus/Basic/Kernel/Base/ScalingContext.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Base.ScalingContext--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC------ Scaling in X and Y------ \*\* WARNING \*\* - half baked.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Base.ScalingContext-  (--    ScalingContext(..)--  , scaleX-  , scaleY-  , scalePt-  , scaleVec--  , unitX-  , unitY--  , uniformScaling-  , coordinateScaling--  ) where---import Wumpus.Core				-- package: wumpus-core------ | ScalingContext is a dictionary of two functions for scaling --- in X and Y.----data ScalingContext ux uy u = ScalingContext-      { scale_in_x  :: ux -> u-      , scale_in_y  :: uy -> u-      }---scaleX              :: ScalingContext ux uy u -> ux -> u-scaleX ctx ux       = (scale_in_x ctx) ux--scaleY              :: ScalingContext ux uy u -> uy -> u-scaleY ctx uy       = (scale_in_y ctx) uy---scalePt             :: ScalingContext ux uy u -> ux -> uy -> Point2 u-scalePt ctx ux uy   = P2 (scale_in_x ctx ux) (scale_in_y ctx uy)--scaleVec            :: ScalingContext ux uy u -> ux -> uy -> Vec2 u-scaleVec ctx ux uy  = V2 (scale_in_x ctx ux) (scale_in_y ctx uy)---unitX               :: Num ux => ScalingContext ux uy u -> u-unitX ctx           = scaleX ctx 1- -unitY               :: Num uy => ScalingContext ux uy u -> u-unitY ctx           = scaleY ctx 1---------------------------------------------------------------------------------------- constructors for scaling context----- | Build a ScalingContext where both X and Y are scaled by the --- same uniform step.------ The dimensions (types) of the ScalingContext are unified - the --- output type and the input types are all the same.----uniformScaling :: Num u => u -> ScalingContext u u u-uniformScaling u = ScalingContext-      { scale_in_x  = (\x -> u*x)-      , scale_in_y  = (\y -> u*y)-      }------ | Build a ScalingContext for scaling Int coordinates.------ The scaling factors in X and Y can be different sizes.-----coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u-coordinateScaling sx sy = ScalingContext-      { scale_in_x  = (\x -> sx * fromIntegral x)-      , scale_in_y  = (\y -> sy * fromIntegral y)-      }---
+ src/Wumpus/Basic/Kernel/Base/Units.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Base.Units+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Units @cm@, @pica@ and \"contextual\" units - @em@, @en@.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Base.Units+  (+++  -- * Centimeter+    Centimeter+  , cm+  , dcm++  -- * Pica+  , Pica+  , pica+  , dpica++  -- * Em+  , Em++  -- * En+  , En++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs++import Wumpus.Core                              -- package: wumpus-core+++--------------------------------------------------------------------------------++-- | Wrapped Double representing Centimeter.+-- +newtype Centimeter = Centimeter { getCentimeter :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)+++instance Show Centimeter where+  showsPrec p d = showsPrec p (getCentimeter d)++-- | Cast a value in Centimeters to some Fractional type.+-- +-- Note - this casting should only be used for non-contextual+-- units such as Double.+--+cm :: Fractional u => Centimeter -> u +cm = realToFrac . (28.45275619 *) . getCentimeter++-- | Convert Double to Centimer.+-- +dcm :: Double -> Centimeter+dcm = Centimeter . (0.03514598 *)++instance ScalarUnit Centimeter where+  fromPsPoint = dcm+  toPsPoint   = cm ++instance InterpretUnit Centimeter where+  normalize _ = cm +  dinterp   _ = dcm++instance Tolerance Centimeter where +  eq_tolerance     = 0.001+  length_tolerance = 0.01++++-- | Wrapped Double /Pica/ unit type.+-- +-- Pica is 12 Points.+--+newtype Pica = Pica { getPica :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)+++instance Show Pica where+  showsPrec p d = showsPrec p (getPica d)++                            +-- | Cast a value in Pica to some Fractional type.+-- +-- Note - this casting should only be used for non-contextual+-- units such as Double.+--+pica :: Fractional u => Pica -> u +pica = realToFrac . (* 12.0) . getPica++-- | Convert a Double to a Pica.+--+dpica :: Double -> Pica+dpica = Pica . (\x -> x / 12.0)++++instance ScalarUnit Pica where+  fromPsPoint = dpica+  toPsPoint   = pica++instance InterpretUnit Pica where+  normalize _ = pica+  dinterp   _ = dpica+++instance Tolerance Pica where +  eq_tolerance     = 0.001+  length_tolerance = 0.01++++--------------------------------------------------------------------------------+-- Contextual units++-- | Wrapped Double representing an Em. +-- +newtype Em = Em { getEm :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show Em where+  showsPrec p d = showsPrec p (getEm d)++++instance InterpretUnit Em where+  normalize sz a = fromIntegral sz * realToFrac a+  dinterp sz d   = realToFrac d / fromIntegral sz+++instance Tolerance Em where +  eq_tolerance     = 0.001+  length_tolerance = 0.01+++-- | Wrapped Double representing an En.+-- +newtype En = En { getEn :: Double } +  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)++instance Show En where+  showsPrec p d = showsPrec p (getEn d)+++instance InterpretUnit En where+  normalize sz a = (realToFrac  a) * 0.5 * fromIntegral sz+  dinterp sz d   = 2 * (realToFrac d) / (fromIntegral sz)+++instance Tolerance En where+  eq_tolerance     = 0.001 +  length_tolerance = 0.01+
src/Wumpus/Basic/Kernel/Base/UpdateDC.hs view
@@ -3,77 +3,105 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.UpdateDC--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com> -- Stability   :  highly unstable -- Portability :  GHC ----- Customize drawing attributes------ \*\* WARNING \*\* - this module needs systematic naming --- schemes both for update functions (primaryColour, ...) and --- for synthesized selectors (e.g. lowerxHeight). The current --- names will change.+-- Customize drawing attributes. The functions here are +-- @DrawingContext@ modifiers to be run within a the scope of a +-- @localize@ block (cf. @local@ of the Reader monad). --+-- By convention, underscore-separated names are used for +-- DrawingContext modifiers in this module. This is because the +-- modifiers defined here are expected to be used mostly as static +-- \"properties\" resembling constants in drawings. --  --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.UpdateDC   (  -  -- * Modifiers -  -    roundCornerFactor-  , textMargin+  -- * Globals+    snap_grid_factors -  -- ** Line widths-  , lineWidth-  , thick-  , ultrathick-  , thin+  -- * Line widths+  , set_line_width -  -- ** Line caps-  , capButt-  , capRound-  , capSquare+  , line_default+  , line_thin+  , line_thick+  , line_ultra_thick+  +  , contextual_line_width+  , relative_line_width -  -- ** Line joins-  , joinMiter-  , joinRound-  , joinBevel+  -- * Line cap+  , cap_default+  , cap_butt+  , cap_round+  , cap_square -  -- ** Dash Pattern-  , dashPattern-  , unit_dash_pattern-  , phase-  , dphase-  , doublegaps-  , doubledashes+  -- * Line join+  , join_default+  , join_miter+  , join_round+  , join_bevel +  -- * Dash pattern+  , set_dash_pattern++  , solid_line+  , dotted_line+  , packed_dotted+  , loose_dotted+  +  , dashed_line+  , packed_dashed+  , loose_dashed+     -- * Font properties-  , fontAttr-  , fontSize-  , fontFace+  , font_attr+  , set_font+  , set_font_size+  , scale_point_size -  -- * Font / mark drawing size-  , doublesize-  , halfsize+  , double_point_size+  , half_point_size ++  -- * Text margins+  , text_margin+  , text_margin_none+  , text_margin_tight+  , text_margin_default+  , text_margin_loose++   -- * Colour-  , swapColours-  , bothStrokeColour-  , bothFillColour-  , strokeColour-  , fillColour +  , stroke_colour+  , fill_colour +  , text_colour+  , single_colour +  , swap_colours+  , fill_use_stroke_colour+  , stroke_use_fill_colour -  +  , fill_use_text_colour+  , stroke_use_text_colour++  , text_use_stroke_colour+  , text_use_fill_colour+   ) where   import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.FontSupport+import Wumpus.Basic.Kernel.Base.Units  import Wumpus.Core                              -- package: wumpus-core @@ -81,180 +109,443 @@   --------------------------------------------------------------------------------+-- helpers   updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF-updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props--updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF-updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props+updateStrokeProps fn = +    (\s i -> s { dc_stroke_props = fn i }) <*> dc_stroke_props  +withFontSize :: (FontSize -> DrawingContextF) -> DrawingContextF+withFontSize fn = (\s i -> fn i s) <*> dc_font_size  -------------------------------------------------------------------------------- -roundCornerFactor   :: Double -> DrawingContextF-roundCornerFactor d = (\s -> s { round_corner_factor = d }) --- | 'textMargin' : @ xsep * ysep -> DrawingContextF @++-- | 'snap_grid_factors' : @ x_unit * y_unit -> DrawingContextF @+-- +-- Set the @snap grid factors@ - a snap grid is an alternative +-- coordinate space, it can be convenient for drawing +-- \"box and arrow\" diagrams. ---textMargin   :: Double -> Double -> DrawingContextF-textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep })+snap_grid_factors   :: Double -> Double -> DrawingContextF+snap_grid_factors xu yu = \s -> s { dc_snap_grid_factors = (xu, yu) }   -------------------------------------------------------------------------------- -- line widths --- Note - some care might be needed if we ever define other unit --- types... -lineWidth       :: Double -> DrawingContextF-lineWidth d      = updateStrokeProps (\s -> s { line_width = d })+-- | set_line_width : @ width_in_points -> DrawingContextF @+--+-- Set the line_width to the supplied point size.+--+-- Initially the line width is 1.0.+--+-- /Constant/ variations of the function maybe be more +-- convenient:+--+-- > line_default, line_thin, line_thick, line_ultra_thick+--+set_line_width      :: Double -> DrawingContextF+set_line_width d    = updateStrokeProps (\s -> s { line_width = d })  --- std_line_width      :: Double--- std_line_width      = 1.0+-- | Set the line_width to @default@ - 1.0.+--+line_default        :: DrawingContextF+line_default        = set_line_width 1.0 -thick_line          :: Double-thick_line          = 2.0 -ultra_thick_line    :: Double-ultra_thick_line    = 4.0+-- | Set the line_width to @thin@ - 0.5.+--+line_thin           :: DrawingContextF+line_thin           = set_line_width 0.5 -thin_line           :: Double-thin_line           = 0.5 +-- | Set the line_width to @thick@ - 2.0.+--+line_thick          :: DrawingContextF+line_thick          = set_line_width 2.0 --- | Set the line width to a /thick/.+-- | Set the line_width to @ultra_thick@ - 4.0. ----- Note this context update is /oblivious/ - operationally the --- line width is set to exactly @2.0@.+line_ultra_thick    :: DrawingContextF+line_ultra_thick    = set_line_width 4.0++++-- | Scale the line width respective to its current value. +-- +-- The size is calculated with the supplied function. ---thick               :: DrawingContextF-thick               = lineWidth thick_line+relative_line_width :: (Double -> Double) -> DrawingContextF+relative_line_width fn = +    updateStrokeProps (\s -> let lw = line_width s in s { line_width = fn lw }) -ultrathick          :: DrawingContextF-ultrathick          = lineWidth ultra_thick_line -thin                :: DrawingContextF-thin                = lineWidth thin_line+-- | 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  + --------------------------------------------------------------------------------+-- Line props  setLineCap          :: LineCap -> DrawingContextF setLineCap d        = updateStrokeProps (\s -> s { line_cap = d }) +setLineJoin         :: LineJoin -> DrawingContextF+setLineJoin d       = updateStrokeProps (\s -> s { line_join = d }) -capButt             :: DrawingContextF-capButt             = setLineCap CapButt -capRound            :: DrawingContextF-capRound            = setLineCap CapRound+-- | Set the line_cap to the default which is @butt@.+--+-- This is a synonym for 'cap_butt'.+--+cap_default         :: DrawingContextF+cap_default         = cap_butt -capSquare           :: DrawingContextF-capSquare           = setLineCap CapSquare+-- | Set the line_cap to @butt@.+--+-- Butt chamfers off the stroke, flush to the end point.+--+-- This is the default.+--+-- >  .-------.+-- >  |=======|+-- >  '-------'+--+cap_butt            :: DrawingContextF+cap_butt            = setLineCap CapButt +-- | Set the line_cap to @round@.+--+-- This rounds the end of the stroke and the visually the +-- rounding slightly extends the length of the line.+--+-- >  .-------.+-- > ( ======= )+-- >  '-------'+--+cap_round           :: DrawingContextF+cap_round           = setLineCap CapRound -setLineJoin         :: LineJoin -> DrawingContextF-setLineJoin d       = updateStrokeProps (\s -> s { line_join = d }) +-- | Set the line_cap to @square@.+--+-- This squares off the end of the stroke, but visual extends the +-- stroke by half the line width.+--+-- >  .---------.+-- >  | ======= |+-- >  '---------'+--+cap_square          :: DrawingContextF+cap_square          = setLineCap CapSquare -joinMiter           :: DrawingContextF-joinMiter           = setLineJoin JoinMiter -joinRound           :: DrawingContextF-joinRound           = setLineJoin JoinRound -joinBevel           :: DrawingContextF-joinBevel           = setLineJoin JoinBevel+-- | Set the line_join to the default which is @miter@.+--+-- This is a synonym for 'join_miter'.+--+join_default        :: DrawingContextF+join_default        = join_miter  +-- | Set the line_join to @miter@.+--+-- This extends the joining line segments to form a sharp miter.+--+-- This is the default.+--+-- >      /\+-- >     /..\ +-- >    /./\.\+-- >   /./  \.\+-- >  /./    \.\+--+join_miter          :: DrawingContextF+join_miter          = setLineJoin JoinMiter+++-- | Set the line_join to @round@.+--+-- This rounds off the corner of the joined line segments.+--+-- >  \.\  +-- >   \.\ +-- >    ,.)+-- >   /./+-- >  /./+--+join_round          :: DrawingContextF+join_round          = setLineJoin JoinRound+++-- | Set the line_join to @round@.+--+-- This bevels off the corner of the joined line segments with a +-- notch.+--+-- >      __+-- >     /..\ +-- >    /./\.\+-- >   /./  \.\+-- >  /./    \.\+--+join_bevel          :: DrawingContextF+join_bevel          = setLineJoin JoinBevel++ -------------------------------------------------------------------------------- -dashPattern         :: DashPattern -> DrawingContextF-dashPattern d       = updateStrokeProps (\s -> s { dash_pattern = d })        + +-- | Set the dash pattern.+--+-- Initially the dash pattern is 'Solid'.+--+set_dash_pattern    :: DashPattern -> DrawingContextF+set_dash_pattern d  = updateStrokeProps (\s -> s { dash_pattern = d })         -unit_dash_pattern   :: DashPattern-unit_dash_pattern   = Dash 0 [(1,1)] --- oblivious-phase               :: Int -> DashPattern -> DashPattern-phase _ Solid       = Solid-phase i (Dash _ xs) = Dash i xs+-- | Set the dash_pattern to @solid@ - i.e. no dash pattern.+--+-- This is the default.+--+solid_line          :: DrawingContextF +solid_line          = set_dash_pattern Solid --- non-oblivious-dphase               :: Int -> DashPattern -> DashPattern-dphase _ Solid       = Solid-dphase d (Dash i xs) = Dash (i+d) xs+-- | Set the dash pattern to draw a dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is 2 times the dot width.+--+dotted_line         :: DrawingContextF +dotted_line         = set_dash_pattern $ Dash 0 [(1,2)] -doublegaps              :: DashPattern -> DashPattern-doublegaps Solid        = Solid-doublegaps (Dash i xs)  = Dash i (map fn xs)-  where-    fn (a,b) = (a,2*b)+-- | Set the dash pattern to draw a tightly packed dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is equal to the dot width.+--+packed_dotted       :: DrawingContextF +packed_dotted       = set_dash_pattern $ Dash 0 [(1,1)] -doubledashes              :: DashPattern -> DashPattern-doubledashes Solid        = Solid-doubledashes (Dash i xs)  = Dash i (map fn xs)-  where-    fn (a,b) = (a*2,b) +-- | Set the dash pattern to draw a loosely dotted line.+-- +-- A dot is actually a square - side length is equal to the line +-- width.+-- +-- The spacing between dots is 4 times the dot width.+--+loose_dotted        :: DrawingContextF +loose_dotted        = set_dash_pattern $ Dash 0 [(1,4)] --------------------------------------------------------------------------------- -fontAttr            :: FontFace -> Int -> DrawingContextF-fontAttr ff sz      = (\s -> s { font_props = FontAttr sz ff }) -fontFace            :: FontFace -> DrawingContextF-fontFace ff         = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff)+-- | Set the dash pattern to draw a dashed line.+-- +-- The dash length is 3 times the line width, the spacing is 2+-- times the line width.+--+dashed_line        :: DrawingContextF+dashed_line        = set_dash_pattern $ Dash 0 [(3,2)] -fontSize            :: Int -> DrawingContextF-fontSize sz         = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) +-- | Set the dash pattern to draw a tightly packed, dashed line.+-- +-- The dash length is 3 times the line width, the spacing is +-- equal to the line width.+--+packed_dashed      :: DrawingContextF+packed_dashed      = set_dash_pattern $ Dash 0 [(3,1)] ++-- | Set the dash pattern to draw a loosely dashed line.+-- +-- The dash length is 3 times the line width, the spacing is 4+-- times the line width.+--+loose_dashed      :: DrawingContextF+loose_dashed      = set_dash_pattern $ Dash 0 [(3,4)]+++ -------------------------------------------------------------------------------- --- | Set the font size to double the current size, note the font--- size also controls the size of dots, arrowsheads etc.+-- | Set the font attributes, point size and font face.+--+font_attr               :: FontDef -> Int -> DrawingContextF+font_attr ft sz         = \s -> s { dc_font_size = sz+                                  , dc_font_face = font_def_face ft }++-- | Set the font face.+--+set_font                :: FontDef -> DrawingContextF+set_font ft             = \s -> s { dc_font_face = font_def_face ft }+++-- | Set the point size.+--+-- This controls the drawing size of both +-- text labels and marks (e.g. dots and arrowheads).+--+set_font_size           :: Int -> DrawingContextF+set_font_size sz        = \s -> s { dc_font_size = sz }+++-- | Scale the current point size by the supplied ratio. -- -doublesize          :: DrawingContextF-doublesize          = (\s sz -> fontSize (sz*2) s) -                        <*> (font_size . font_props)+-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - for instance scaling 15pt by (1%2) +-- results in 7pt.+-- +scale_point_size    :: Double -> DrawingContextF+scale_point_size a  = (\s sz -> set_font_size (floor $ a * fromIntegral sz) s) +                         <*> dc_font_size +-- | Set the point size (font and mark size) to double the current +-- size.+--+double_point_size   :: DrawingContextF+double_point_size   = scale_point_size 2  --- | Set the font size to half the current size, note the font++-- | Set the point size to half the current size, note the point -- size also controls the size of dots, arrowsheads etc. -- --- As fontsize is an integer this is not exact - half size of--- 15pt type is 7pt.+-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - half size of 15pt type is 7pt. -- -halfsize            :: DrawingContextF-halfsize            = (\s sz -> fontSize (sz `div` 2) s) -                        <*> (font_size . font_props)+half_point_size     :: DrawingContextF+half_point_size     = scale_point_size 0.5  +-- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @+--+-- Note - this is in @Em@ units.+--+text_margin   :: Em -> Em -> DrawingContextF+text_margin xsep ysep = \s -> +    s { dc_text_margin = TextMargin xsep ysep }+++-- | Set the text margin to (0,0).+-- +-- This produces a tight box around the text vertically measured +-- to the cap-height and descender. Therefore some characters may +-- extend outside the margin (e.g. accented capitals like +-- A-grave).+--+text_margin_none    :: DrawingContextF+text_margin_none    = text_margin 0 0 ++++-- | Set the text margin to (0.25 em, 0.25 em).+-- +text_margin_tight       :: DrawingContextF+text_margin_tight       = text_margin 0.25 0.25++-- | Set the text margin to (0.5 em, 0.5 em).+-- +text_margin_default :: DrawingContextF+text_margin_default = text_margin 0.5 0.5++-- | Set the text margin to (1.0 em, 1.0 em).+-- +text_margin_loose   :: DrawingContextF+text_margin_loose = text_margin 1.0 1.0++ -------------------------------------------------------------------------------- -swapColours :: DrawingContextF-swapColours = -    (\s a b -> s { stroke_colour = b, fill_colour = a })-        <*> stroke_colour <*> fill_colour+-- | Set the stroke colour.+--+stroke_colour :: RGBi -> DrawingContextF+stroke_colour rgb = \s -> s { dc_stroke_colour = rgb }  -bothStrokeColour :: DrawingContextF-bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour -bothFillColour :: DrawingContextF-bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour+-- | Set the fill colour.+--+fill_colour :: RGBi -> DrawingContextF+fill_colour rgb = \s -> s { dc_fill_colour = rgb }   +-- | Set the text colour.+--+text_colour          :: RGBi -> DrawingContextF+text_colour rgb      = (\s -> s { dc_text_colour = rgb}) -strokeColour :: RGBi -> DrawingContextF-strokeColour rgb = \s -> s { stroke_colour = rgb }   -fillColour :: RGBi -> DrawingContextF-fillColour rgb = \s -> s { fill_colour = rgb } +-- | Set the stroke, fill and text colours to a single colour.+--+single_colour :: RGBi -> DrawingContextF+single_colour rgb = stroke_colour rgb . fill_colour rgb . text_colour rgb  ++-- | Swap the stroke colour and fill colours.+--+swap_colours :: DrawingContextF+swap_colours = +    (\s a b -> s { dc_stroke_colour = b, dc_fill_colour = a })+        <*> dc_stroke_colour <*> dc_fill_colour+++-- | Set the fill colour to use the current stroke colour.+--+fill_use_stroke_colour :: DrawingContextF+fill_use_stroke_colour = +    (\s a -> s { dc_fill_colour = a }) <*> dc_stroke_colour+++-- | Set the stroke colour to use the current fill colour.+--+stroke_use_fill_colour :: DrawingContextF+stroke_use_fill_colour = +    (\s a -> s { dc_stroke_colour = a }) <*> dc_fill_colour+++-- | Set the fill colour to use the current text colour.+--+fill_use_text_colour :: DrawingContextF+fill_use_text_colour = +    (\s a -> s { dc_fill_colour = a }) <*> dc_text_colour+++-- | Set the stroke colour to use the current fill colour.+--+stroke_use_text_colour :: DrawingContextF+stroke_use_text_colour = +    (\s a -> s { dc_stroke_colour = a }) <*> dc_text_colour++++-- | Set the text colour to use the current stroke colour.+--+text_use_stroke_colour :: DrawingContextF+text_use_stroke_colour = +    (\s a -> s { dc_text_colour = a }) <*> dc_stroke_colour+++-- | Set the text colour to use the current fill colour.+--+text_use_fill_colour :: DrawingContextF+text_use_fill_colour = +    (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour
src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs view
@@ -1,43 +1,38 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# LANGUAGE FlexibleInstances          #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.WrappedPrimitive--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  highly unstable -- Portability :  GHC  ----- Two /warpped/ versions of the Primitive type from Wumpus-Core.+-- Wrapped versions of the @Primitive@ type from Wumpus-Core. --+-- This file is essentially /internal/ to Wumpus-Basic.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Base.WrappedPrimitive   ( +   -- * Primitives-    HPrim+    CatPrim+  , prim1+  , cpmap+  , cpmove++  , HPrim   , hprimToList   , singleH -  -- * Collect primitives (writer monad) -  , TraceM(..)--  , PrimGraphic--  , getPrimGraphic-  , primGraphic-  , metamorphPrim-  , collectH-   ) where -import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Utils.HList  import Wumpus.Core                      -- package: wumpus-core@@ -47,103 +42,117 @@   --- As of version 0.36.0, Wumpus-Core supports grouping primitives--- together (a common operation in vector drawing editors). +-- | A wrapped version of 'Primitive' from Wumpus-Core that +-- supports Monoid.+-- +-- Note that CatPrim provides a /single-object/ that can be+-- hyperlinked or whatever.  ----- For Wumpus-Basic this means e.g. a line with arrowheads can --- still be a primitive.+-- It is different to 'HPrim' which is intended as a list type +-- with efficient concatenation to support building of multiple+-- Primitives in a frame. ----- Still, we wrap Primitive as a newtype...+-- This type is essentially internal to Wumpus-Basic. --+data CatPrim = CZero+             | Cat1 Primitive -newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u }-  deriving (Eq,Show)+type instance DUnit CatPrim = Double  -type instance DUnit (PrimGraphic u) = u +instance Monoid CatPrim where+  mempty                  = CZero+  CZero  `mappend` b      = b+  a      `mappend` CZero  = a+  Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b +  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs ------------------------------------------------------------------------------------ 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.----newtype HPrim u = HPrim { getHPrim :: H (Primitive u) } --- Note - only a Monoid instance for HPrim - they cannot be --- shown, fmapped etc. -instance Monoid (HPrim u) where-  mempty          = HPrim emptyH-  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb+-------------------------------------------------------------------------------- +instance Rotate CatPrim where+  rotate _   CZero              = CZero+  rotate ang (Cat1 a)           = Cat1 $ rotate ang a -hprimToList :: HPrim u -> [Primitive u]-hprimToList = toListH . getHPrim+instance RotateAbout CatPrim where+  rotateAbout _   _  CZero      = CZero+  rotateAbout ang pt (Cat1 a)   = Cat1 $ rotateAbout ang pt a +instance Scale CatPrim where+  scale _  _  CZero             = CZero+  scale sx sy (Cat1 a)          = Cat1 $ scale sx sy a -singleH :: Primitive u -> HPrim u-singleH = HPrim . wrapH +instance Translate CatPrim where+  translate _  _  CZero         = CZero+  translate dx dy (Cat1 a)      = Cat1 $ translate dx dy a   -------------------------------------------------------------------------------- --- | 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 ()+prim1 :: Primitive -> CatPrim +prim1 = Cat1  +-- | Map +cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim+cpmap _ CZero    = CZero+cpmap f (Cat1 a) = Cat1 $ f a  +cpmove :: Vec2 Double -> CatPrim -> CatPrim+cpmove (V2 x y) = translate x y + ----------------------------------------------------------------------------------- instances+-- Lists of primitives... -instance OPlus (PrimGraphic u) where-  oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b +-- | Collected primitives - this type is effectively an analogue+-- to a @Frame@ in Wumpus-Core.+--+-- This type is essentially internal to Wumpus-Basic.+-- +newtype HPrim u = HPrim { getHPrim :: H Primitive } --- Affine transformations+-- Note - only a Monoid instance for HPrim - they cannot be +-- shown, fmapped etc. -instance (Real u, Floating u) => Rotate (PrimGraphic u) where-  rotate ang = PrimGraphic . rotate ang . getPrimGraphic+instance Monoid (HPrim u) where+  mempty          = HPrim emptyH+  ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb +  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs -instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where-  rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic +-- | 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 -instance Num u => Scale (PrimGraphic u) where-  scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic +-- | Form a 'HPrim' from a 'CatPrim'.+--+singleH :: CatPrim -> HPrim u+singleH CZero    = HPrim emptyH+singleH (Cat1 a) = HPrim $ wrapH a -instance Num u => Translate (PrimGraphic u) where-  translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic --------------------------------------------------------------------------------- -primGraphic :: Primitive u -> PrimGraphic u -primGraphic = PrimGraphic -metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u-metamorphPrim f = primGraphic . f . getPrimGraphic -collectH :: PrimGraphic u -> HPrim u-collectH = singleH . getPrimGraphic
+ src/Wumpus/Basic/Kernel/Drawing/Basis.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.Basis+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- User state class for Drawing monads.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.Basis+  (++    UState+  , UserStateM(..)++  , InsertlM(..)+  , LocationM(..)+  , CursorM(..)+  , BranchCursorM(..)+  , hmoveby+  , vmoveby++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative++type family UState m :: *+++class (Applicative m, Monad m) => UserStateM (m :: * -> *) where+  getState    :: st ~ UState (m a) => m st+  setState    :: st ~ UState (m a) => st -> m ()+  updateState :: st ~ UState (m a) => (st -> st) -> m ()+   +++++-- | Monad that collects a graphic trace, 'insertl' is analogue +-- to the Writer monad\'s @tell@.+--+class InsertlM (m :: * -> *) where+  insertl   :: u ~ DUnit (m ()) => LocImage u a -> m a+  insertl_  :: u ~ DUnit (m ()) => LocImage u a -> m (UNil u)++  insertl_ = insertl . ignoreAns +++-- | Monad with notion of location - i.e. the current point.+--+class Monad m => LocationM (m :: * -> *) where+  location  :: u ~ DUnit (m ()) => m (Point2 u)+++-- | Monad with turtle-like cursor movememnt.+--+class LocationM m => CursorM (m :: * -> *) where  +  moveby    :: u ~ DUnit (m ()) => Vec2 u -> m ()++++-- | Add operations for branching at the current point.+-- +-- Not all drawings that support tracing support branching. For+-- instance Paths can be built by tracing but they always need +-- a cumulative progression of /next point/ they cannot resrt to +-- the start point and go in a differnt direction.+-- +class CursorM m => BranchCursorM (m :: * -> *) where+  -- | Branch is like @local@ in the Reader monad.+  branchCursor    :: m a -> m a++++--------------------------------------------------------------------------------+-- Derived operations+++-- | Move the /cursor/ horizontally.+--+hmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()+hmoveby dx = moveby (hvec dx)++-- | Move the /cursor/ vertically.+--+vmoveby :: (CursorM m, Num u, u ~ DUnit (m ())) => u -> m ()+vmoveby dx = moveby (vvec dx)
+ src/Wumpus/Basic/Kernel/Drawing/Chain.hs view
@@ -0,0 +1,463 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.Chain+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Chaining LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.Chain+  (+  +    GenChain+  , Chain+  , DChain+  , ChainScheme(..)++  , runGenChain+  , evalGenChain+  , execGenChain+  , stripGenChain++  , runChain+  , runChain_++  , chain1+  , chainSkip_+  , chainMany+  , chainReplicate+  , chainCount++  , iterationScheme+  , sequenceScheme+  , catTrailScheme+  , countingScheme+++  , horizontalScheme+  , verticalScheme+++  , rowwiseTableScheme+  , columnwiseTableScheme+  ++  , distribRowwiseTable+  , duplicateRowwiseTable+  , distribColumnwiseTable+  , duplicateColumnwiseTable++  , radialChainScheme++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.Trail++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Data.Monoid++++newtype GenChain st u a = GenChain+          { getGenChain :: DrawingContext -> DPoint2 -> ChainSt st u +                        -> (a, DPoint2, ChainSt st u, CatPrim) }+++type instance DUnit (GenChain st u a)   = u+type instance UState  (GenChain st u a) = st++type Chain u a   = GenChain () u a++type DChain a    = Chain Double a++-- | scheme_start is a function from the origin to state.+-- +-- For instance, we might want to cache the origin - this would+-- not be possible if start was just a pure @cst@ value. +--+data ChainScheme u = forall cst. ChainScheme +      { chain_init      :: Point2 u -> cst+      , chain_step      :: Point2 u -> cst -> (Point2 u,cst)+      }++type instance DUnit (ChainScheme u) = u+++data ChainSt st u = forall cst. ChainSt +       { chain_count      :: Int+       , chain_st         :: cst+       , chain_next       :: Point2 u -> cst -> (Point2 u,cst) +       , chain_user_state :: st+       }+++type instance DUnit (ChainSt st u) = u+++-- Functor ++instance Functor (GenChain st u) where+  fmap f ma = GenChain $ \ctx pt s -> +              let (a,p1,s1,w) = getGenChain ma ctx pt s in (f a, p1, s1, w)++++-- Applicative++instance Applicative (GenChain st u) where+  pure a    = GenChain $ \_   pt s -> (a, pt, s, mempty)+  mf <*> ma = GenChain $ \ctx pt s -> +                let (f,p1,s1,w1) = getGenChain mf ctx pt s+                    (a,p2,s2,w2) = getGenChain ma ctx p1 s1+                in (f a, p2, s2, w1 `mappend` w2)++++-- Monad++instance Monad (GenChain st u) where+  return a  = GenChain $ \_   pt s -> (a, pt, s, mempty)+  ma >>= k  = GenChain $ \ctx pt s -> +                let (a,p1,s1,w1) = getGenChain ma ctx pt s+                    (b,p2,s2,w2) = (getGenChain . k) a ctx p1 s1+                in (b, p2, s2, w1 `mappend` w2)+++-- DrawingCtxM++instance DrawingCtxM (GenChain st u) where+  askDC           = GenChain $ \ctx pt s -> (ctx, pt, s, mempty)+  asksDC fn       = GenChain $ \ctx pt s -> (fn ctx, pt, s, mempty)+  localize upd ma = GenChain $ \ctx pt s -> getGenChain ma (upd ctx) pt s++++-- UserStateM ++instance UserStateM (GenChain st u) where+  getState        = GenChain $ \_ pt s@(ChainSt _ _ _ ust) -> +                      (ust, pt, s, mempty)+  setState ust    = GenChain $ \_ pt (ChainSt i a b _) -> +                      ((), pt, ChainSt i a b ust, mempty)+  updateState upd = GenChain $ \_ pt (ChainSt i a b ust) -> +                      ((), pt, ChainSt i a b (upd ust), mempty)+++-- LocationM++instance InterpretUnit u => LocationM (GenChain st u) where+  location = GenChain $ \ctx pt s ->+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) ++++-- Monoid++instance Monoid a => Monoid (GenChain st u a) where+  mempty           = GenChain $ \_   pt s -> (mempty, pt, s, mempty)+  ma `mappend` mb  = GenChain $ \ctx pt s -> +                       let (a,p1,s1,w1) = getGenChain ma ctx pt s+                           (b,p2,s2,w2) = getGenChain mb ctx p1 s1+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)++--------------------------------------------------------------------------------+-- Run functions++runGenChain :: InterpretUnit u +            => ChainScheme u -> st -> GenChain st u a -> LocImage u (a,st)+runGenChain (ChainScheme start step) ust ma = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let st_zero     = ChainSt { chain_count      = 0+                              , chain_st         = start pt+                              , chain_next       = step+                              , chain_user_state = ust }+        dpt         = normalizeF (dc_font_size ctx) pt+        (a,_,s1,w1) = getGenChain ma ctx dpt st_zero+    in replaceAns (a, chain_user_state s1) $ primGraphic w1++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenChain :: InterpretUnit u +             => ChainScheme u -> st -> GenChain st u a -> LocImage u a+evalGenChain cscm st ma = fmap fst $ runGenChain cscm st ma+++-- | Forget the /answer/, just return the user state.+--+execGenChain :: InterpretUnit u +             => ChainScheme u -> st -> GenChain st u a -> LocImage u st +execGenChain cscm st ma = fmap snd $ runGenChain cscm st ma+++stripGenChain :: InterpretUnit u +              => ChainScheme u -> st -> GenChain st u a -> LocQuery u (a,st)+stripGenChain cscm st ma = stripLocImage $ runGenChain cscm st ma++++runChain :: InterpretUnit u +         => ChainScheme u -> Chain u a -> LocImage u a+runChain cscm ma = evalGenChain cscm () ma++runChain_ :: InterpretUnit u +          => ChainScheme u -> Chain u a -> LocGraphic u+runChain_ cscm ma = ignoreAns $ runChain cscm ma+++++--------------------------------------------------------------------------------+-- Operations+++-- | Demand a point on the Chain and draw the LocImage+-- at it.+--+chain1 :: InterpretUnit u +       => LocImage u a -> GenChain st u a+chain1 gf  = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) -> +    let upt       = dinterpF (dc_font_size ctx) pt+        (a,w1)    = runImage ctx $ applyLoc gf upt+        (pt1,st1) = sf upt s0+        dpt1      = normalizeF (dc_font_size ctx) pt1+        new_st    = ChainSt { chain_count      = i0 + 1+                            , chain_st         = st1+                            , chain_next       = sf+                            , chain_user_state = ust }+    in (a, dpt1, new_st, w1)+++-- | Demand the next position, but draw nothing.+--+chainSkip_ :: InterpretUnit u => GenChain st u ()+chainSkip_ = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) -> +    let upt       = dinterpF (dc_font_size ctx) pt+        (pt1,st1) = sf upt s0+        dpt1      = normalizeF (dc_font_size ctx) pt1+        new_st    = ChainSt { chain_count      = i0 + 1+                            , chain_st         = st1+                            , chain_next       = sf+                            , chain_user_state = ust }+    in ((), dpt1, new_st, mempty)++++-- | Chain a list of images, each demanding a succesive start +-- point.+--+chainMany :: InterpretUnit u +          => [LocImage u a] -> GenChain st u (UNil u)+chainMany = ignoreAns . mapM_ chain1+++-- | Replicate a LocImage @n@ times along a Chain.+--+chainReplicate :: InterpretUnit u +               => Int -> LocImage u a -> GenChain st u (UNil u)+chainReplicate n = chainMany . replicate n +++-- | Return the count of chain steps.+--+chainCount :: GenChain st u Int+chainCount = GenChain $ \_ dpt st@(ChainSt i _ _ _) -> (i, dpt, st, mempty)+             +++++--------------------------------------------------------------------------------+-- Schemes+++-- | General scheme - iterate the next point with the supplied+-- function.+--+iterationScheme :: (Point2 u -> Point2 u) -> ChainScheme u+iterationScheme fn = ChainScheme { chain_init = const ()+                                 , chain_step = \pt _ -> (fn pt, ())+                                 }++-- | General scheme - displace successively by the elements of the+-- list of vectors. +-- +-- Note - the list is cycled to make the chain infinite.+--+sequenceScheme :: Num u => [Vec2 u] -> ChainScheme u+sequenceScheme [] = error "sequenceScheme - empty list."+sequenceScheme vs = ChainScheme { chain_init = const $ cycle vs+                                , chain_step = step+                                }+  where+    step _  []     = error "sequenceScheme - unreachable, cycled."+    step pt (w:ws) = (displace w pt, ws) +++-- | Derive a ChainScheme from a CatTrail.+--+-- Note - this iterates the control points of curves, it does not+-- iterate points on the curve.+--+catTrailScheme :: Num u => CatTrail u -> ChainScheme u+catTrailScheme = sequenceScheme . linear . destrCatTrail+  where+    linear (TLine v0 :xs)        = v0 : linear xs+    linear (TCurve v0 v1 v2 :xs) = v0 : v1 : v2 : linear xs+    linear []                    = []+++-- | Build an (infinite) ChainScheme for a prefix list of counted +-- schemes and a final scheme that runs out to infinity.+--+countingScheme :: [(Int, ChainScheme u)] -> ChainScheme u -> ChainScheme u+countingScheme []     rest = rest+countingScheme (x:xs) rest = chainPrefix  x (countingScheme xs rest)+++-- | Helper - complicated...+--+chainPrefix :: (Int, ChainScheme u) -> ChainScheme u -> ChainScheme u+chainPrefix (ntimes, ChainScheme astart astep) rest@(ChainScheme bstart bstep)+    | ntimes < 1 = rest+    | otherwise  = ChainScheme { chain_init = start, chain_step = next }+  where+    start pt = (astart pt,ntimes, bstart pt)++    next pt (ast,n,bst) +        | n > 0     = let (p2,ast1) = astep pt ast in (p2, (ast1,n-1,bst))+        | n == 0    = let bst1      = bstart pt +                          (p2,bst2) = bstep pt bst1 +                      in (p2, (ast,(-1),bst2))+        | otherwise = let (p2,bst1) = bstep pt bst in (p2,(ast, (-1), bst1))+ ++++horizontalScheme :: Num u => u -> ChainScheme u+horizontalScheme dx = iterationScheme (displace (hvec dx))+                +   +verticalScheme :: Num u => u -> ChainScheme u+verticalScheme dy = iterationScheme (displace (vvec dy))+               +++++-- | Outer and inner steppers.+--+scStepper :: PointDisplace u -> Int -> PointDisplace u +          -> ChainScheme u+scStepper outF n innF = +    ChainScheme { chain_init = start, chain_step = step }+  where+    start pt                      = (pt,1)+    step  pt (ogin,i) | i <  n    = (innF pt, (ogin, i+1))+                      | otherwise = let o1 = outF ogin +                                    in (o1, (o1,1)) ++++-- | Generate a tabular scheme going rowwise (left-to-right) and+-- downwards.+--+-- TODO - should probably account for the initial position... +--+rowwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u+rowwiseTableScheme num_cols (col_width,row_height) = +    scStepper downF num_cols rightF+  where+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width++-- | Generate a tabular scheme going columwise (top-to-bottom) +-- and rightwards.+--+-- TODO - should probably account for the initial position... +--+columnwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u+columnwiseTableScheme num_rows (col_width,row_height) = +    scStepper rightF num_rows downF+  where+    downF   = displace $ vvec $ negate row_height+    rightF  = displace $ hvec col_width+++++distribRowwiseTable :: (Monoid a, InterpretUnit u)+                    => Int -> (u,u) -> [LocImage u a] -> LocImage u a+distribRowwiseTable num_cols dims gs = fmap mconcat $ +    runChain (rowwiseTableScheme num_cols dims) $ mapM chain1 gs+  ++duplicateRowwiseTable :: (Monoid a, InterpretUnit u)+                      => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a+duplicateRowwiseTable i num_cols dims gf =+    distribRowwiseTable num_cols dims (replicate i gf) ++++distribColumnwiseTable :: (Monoid a, InterpretUnit u)+                       => Int -> (u,u) -> [LocImage u a] -> LocImage u a+distribColumnwiseTable num_rows dims gs = fmap mconcat $ +    runChain (columnwiseTableScheme num_rows dims) $ mapM chain1 gs+  ++duplicateColumnwiseTable :: (Monoid a, InterpretUnit u)+                         => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a+duplicateColumnwiseTable i num_rows dims gf = +    distribColumnwiseTable num_rows dims (replicate i gf) ++++-- | TODO - account for CW CCW or just rely on +ve -ve angles?...+--+radialChainScheme :: Floating u +                  => u -> Radian -> Radian -> ChainScheme u+radialChainScheme radius angstart angi = +    ChainScheme { chain_init = start, chain_step = step }+  where+    start pt           = let ogin = displace (avec angstart (-radius)) pt+                         in (ogin, angstart)+    step  _ (ogin,ang) = let ang_next = ang + angi +                             pt       = displace (avec ang_next radius) ogin+                         in (pt, (ogin, ang_next))++    ++-- radialChain is convoluted because first point is not the +-- circle center but a point on the circumference. Also the next+-- step iterates the (constant) origin rather than the previous +-- point.+++++    +    +
+ src/Wumpus/Basic/Kernel/Drawing/CtxPicture.hs view
@@ -0,0 +1,408 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE RankNTypes                 #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.CtxPicture+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- A Picture-with-implicit-context object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core.+-- +-- Note - many of the composition functions are in +-- /destructor form/. As Wumpus cannot make a Picture from an +-- empty list of Pictures, /destructor form/ decomposes the +-- list into the @head@ and @rest@ as arguments in the function +-- signature, rather than take a possibly empty list and have to +-- throw an error.+-- +-- TODO - PosImage no longer supports composition operators, so +-- better names are up for grabs...+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.CtxPicture+  (++    CtxPicture+  , runCtxPicture+  , runCtxPictureU+  , drawTracing+  , udrawTracing++  , mapCtxPicture++  -- * Composition++  , uniteCenter+  +  , centeredAt++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Drawing.TraceDrawing+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Concat++import Wumpus.Core                              -- package: wumpus-core++import Data.AdditiveGroup                       -- package: vector-space+import Data.AffineSpace++import Data.Monoid++++-- | A /Contextual/ Picture.+-- +-- > CtxPicture = DrawingContext -> Maybe Picture+-- +-- This type corresponds to the 'Picture' type in Wumpus-Core, but+-- it is embedded with a 'DrawingContext' (for font properties, +-- fill colour etc.). The DrawingContext is embedded so that font+-- metrics - loaded in @IO@ can be passed into the pure world of+-- 'TraceDrawing'.+--+-- Internally a /context picture/ is a function from +-- 'DrawingContext' to @(Maybe Picture)@. The @Maybe@ represents+-- that it is possible to construct empty Pictures, even though+-- @Wumpus-Core@ cannot render them. Just as the DrawingContext+-- pushes font-metrics from the IO to the pure world, the Maybe+-- lifts the problem of unrenderable Pictures into the API where+-- client code must deal with it explicitly. +--+-- (In practice, it is very unlikely a program will create empty +-- pictures and @runCtxPictureU@ can be used without worry).+-- +-- +-- Note - pictures are fixed to the unit @Double@ (representing +-- PostScript points). Pictures are intentionally unsophisticated,+-- any fine grained control of units should be delegated to the +-- elements that build the picture (Graphics, LocGraphics, etc.). +--+newtype CtxPicture = CtxPicture { +          getCtxPicture :: DrawingContext -> Maybe Picture }++type instance DUnit CtxPicture = Double+++++-- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @+--+-- Run a 'CtxPicture' with the supplied 'DrawingContext' +-- producing a 'Picture'.+--+-- The resulting Picture may be empty. Wumpus-Core cannot +-- generate empty pictures as they have no bounding box, so the +-- result is wrapped within a Maybe. This delegates reponsibility +-- for handling empty pictures to client code.+--+runCtxPicture :: DrawingContext -> CtxPicture -> Maybe Picture+runCtxPicture ctx drw = getCtxPicture drw ctx+++-- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @+--+-- /Unsafe/ version of 'runCtxPicture'.+--+-- This function throws a runtime error when supplied with an+-- empty CtxPicture.+--+runCtxPictureU :: DrawingContext -> CtxPicture -> Picture+runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df+  where+    fk = error "runCtxPictureU - empty CtxPicture."   +++-- | 'drawTracing' : @ trace_drawing  -> CtxPicture @+--+-- Transform a 'TraceDrawing' into a 'CtxPicture'.+--+drawTracing :: TraceDrawing u a -> CtxPicture+drawTracing ma = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma++-- | 'udrawTracing' : @ scalar_unit_value * trace_drawing  -> CtxPicture @+--+-- Variant of 'drawTracing' with a phantom first argument - the +-- phantom identifies the unit type of the 'TraceDrawing'. It is +-- not scurtinized at the value level.+--+--+udrawTracing :: u -> TraceDrawing u a -> CtxPicture+udrawTracing _ ma = +    CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx ma+++-- Note need Gen versions with user state...+++-- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @+--+-- Apply a picture transformation function to the 'Picture'+-- warpped in a 'CtxPicture'.+--+mapCtxPicture :: (Picture -> Picture) -> CtxPicture -> CtxPicture+mapCtxPicture pf pic1 = CtxPicture $ \ctx -> fmap pf $ getCtxPicture pic1 ctx+++--------------------------------------------------------------------------------+-- Affine instances+++instance Rotate CtxPicture where +  rotate ang            = mapCtxPicture (rotate ang)++instance RotateAbout CtxPicture where+  rotateAbout ang pt    = mapCtxPicture (rotateAbout ang pt)++instance Scale CtxPicture where+  scale sx sy           = mapCtxPicture (scale sx sy)++instance Translate CtxPicture where+  translate dx dy       = mapCtxPicture (translate dx dy)++++--------------------------------------------------------------------------------+-- Monoid++-- | Avoid initial mempty for mconcat.+--+instance Monoid CtxPicture where+  mempty  = CtxPicture $ \_ -> Nothing+  mappend = moveSnd $ \_ _ -> V2 0 0++  mconcat []      = mempty+  mconcat (a:as)  = step a as+    where+      step ac []     = ac+      step ac (x:xs) = step (ac `mappend` x) xs+++--------------------------------------------------------------------------------+-- Extract /planes/.+++leftEdge        :: BoundingBox Double -> Double+leftEdge        = point_x . ll_corner++rightEdge       :: BoundingBox Double -> Double+rightEdge       = point_x . ur_corner++bottomEdge      :: BoundingBox Double -> Double+bottomEdge      = point_y . ll_corner+++topEdge         :: BoundingBox Double -> Double+topEdge         = point_y . ur_corner++++++--------------------------------------------------------------------------------+-- Composition operators++-- Naming convention - Wumpus-Core already prefixes operations+-- on Pictures with pic. As the picture operators here work on a+-- different type, they merit a different naming scheme.+--+-- Unfortunately the @cxp_@ prefix is rather ugly...+--+-- Directional names seem better than positional ones (less +-- ambiguous as when used as binary operators).+--++++combineP2 :: (Picture -> Picture -> Picture) +          -> CtxPicture -> CtxPicture -> CtxPicture+combineP2 op mf mg = +    CtxPicture $ \ctx -> fn (getCtxPicture mf ctx) (getCtxPicture mg ctx)+  where+    fn (Just a) (Just b) = Just $ a `op` b+    fn a        Nothing  = a+    fn Nothing  b        = b+++-- Note - the megaCombR operator is in some way an+-- /anti-combinator/. It seems easier to think about composing +-- drawings if we do work on the result Pictures directly rather +-- than build combinators to manipulate CtxPictures.+--+-- The idea of combining pre- and post- operating combinators+-- makes me worry about circular programs even though I know +-- lazy evaluation allows me to write them (in some cicumstances).+--+++moveSnd :: (DBoundingBox -> DBoundingBox -> DVec2) +          -> CtxPicture -> CtxPicture+          -> CtxPicture+moveSnd mkV = combineP2 fn+  where+    fn pl pr = let v1  = mkV (boundary pl) (boundary pr)+               in pl `picOver` (picMoveBy pr v1)+++instance ZConcat CtxPicture where+  superior = mappend+  anterior = flip mappend++--------------------------------------------------------------------------------+-- Composition+++infixr 6 `uniteCenter`+++++-- | Draw @a@, move @b@ so its center is at the same center as +-- @a@, @b@ is drawn over underneath in the zorder.+--+-- > a `cxpUniteCenter` b +--++uniteCenter :: CtxPicture -> CtxPicture -> CtxPicture+uniteCenter = moveSnd $ \a b -> center a .-. center b+--+-- Are combinator names less ambiguous if they name direction+-- rather than position?+--++instance Concat CtxPicture where+  hconcat = cxpRight+  vconcat = cxpBelow+++-- | > a `cxpRight` b+-- +-- Horizontal composition - position picture @b@ to the right of +-- picture @a@.+-- +cxpRight :: CtxPicture -> CtxPicture -> CtxPicture+cxpRight = moveSnd $ \a b -> hvec $ rightEdge a - leftEdge b+++-- | > a `cxpBelow` b+--+-- Vertical composition - position picture @b@ /down/ from picture+-- @a@.+--+cxpBelow :: CtxPicture -> CtxPicture -> CtxPicture+cxpBelow = moveSnd $ \a b -> vvec $ bottomEdge a - topEdge b+++-- | Center the picture at the supplied point.+--+centeredAt :: CtxPicture -> DPoint2 -> CtxPicture+centeredAt pic (P2 x y) = mapCtxPicture fn pic+  where+    fn p = let bb = boundary p+               dx = x - (boundaryWidth  bb * 0.5)+               dy = y - (boundaryHeight bb * 0.5)+           in p `picMoveBy` vec dx dy+++++--------------------------------------------------------------------------------++instance CatSpace CtxPicture where+  hspace = cxpRightSep+  vspace = cxpDownSep+++-- | > cxpRightSep n a b+--+-- Horizontal composition - move @b@, placing it to the right +-- of @a@ with a horizontal gap of @n@ separating the pictures.+--+cxpRightSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpRightSep n = moveSnd $ \a b -> hvec $ n + (rightEdge a - leftEdge b)++++-- | > cxpDownSep n a b+--+-- Vertical composition - move @b@, placing it below @a@ with a+-- vertical gap of @n@ separating the pictures.+--+cxpDownSep :: Double  -> CtxPicture -> CtxPicture -> CtxPicture+cxpDownSep n = moveSnd $ \a b -> vvec $ bottomEdge a - (topEdge b + n)+++--------------------------------------------------------------------------------+-- Aligning pictures+++instance Align CtxPicture where+  halign = cxpAlignH+  valign = cxpAlignV++-- | > cxpAlignH align a b+-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ and align it with the top, center or bottom of @a@.+-- +cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignH HALIGN_TOP     = moveSnd $ \a b -> northeast a .-. northwest b+cxpAlignH HALIGN_CENTER  = moveSnd $ \a b -> east a .-. west b+cxpAlignH HALIGN_BASE    = moveSnd $ \a b -> southeast a .-. southwest b+++-- | > cxpAlignV align a b+-- +-- Vertical composition - move @b@, placing it below @a@ +-- and align it with the left, center or right of @a@.+-- +cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignV VALIGN_LEFT    = moveSnd $ \a b -> southwest a .-. northwest b+cxpAlignV VALIGN_CENTER  = moveSnd $ \a b -> south a .-. north b+cxpAlignV VALIGN_RIGHT   = moveSnd $ \a b -> southeast a .-. northeast b++++instance AlignSpace CtxPicture where+  halignSpace = cxpAlignSpaceH+  valignSpace = cxpAlignSpaceV++-- | > cxpAlignSpaceH align sep a b+-- +-- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +cxpAlignSpaceH :: HAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignSpaceH align dx = go align+  where+    mv f g           = moveSnd $ \a b -> hvec dx ^+^ (f a .-. g b)+    go HALIGN_TOP    = mv northeast northwest+    go HALIGN_CENTER = mv east west +    go HALIGN_BASE   = mv southeast southwest+++-- | > cxpAlignSpaceV align sep a b+-- +-- Spacing version of alignV - move @b@ below @a@ +-- separated by @sep@ units, align @b@ according to @align@.+-- +cxpAlignSpaceV :: VAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture+cxpAlignSpaceV align dy = go align+  where+    mv f g           = moveSnd $ \a b -> vvec (-dy) ^+^ (f a .-. g b)+    go VALIGN_LEFT   = mv southwest northwest +    go VALIGN_CENTER = mv south north  +    go VALIGN_RIGHT  = mv southeast northeast +
+ src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs view
@@ -0,0 +1,237 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocDrawing+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Drawing monad with immutable start point.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.LocDrawing+  (++  -- * GenLocDrawing monad+    GenLocDrawing+  , LocDrawing++  , LocDrawM(..)++  , runGenLocDrawing+  , evalGenLocDrawing+  , execGenLocDrawing+  , stripGenLocDrawing++  , runLocDrawing+  , runLocDrawing_ ++  )++  where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+import Data.Monoid+++++-- | 'GenLocDrawing' is a reader-writer-state monad, unlike +-- 'GenLocTrace' there is no updateable current point, instead +-- the start point is supplied when the drawing is run and it +-- is translated by the components of the start point.+--+-- The writer accumulates a graphical trace.+--+-- Essentially, 'GenLocDrawing' is an 'Image' object extended +-- with user state.+--+newtype GenLocDrawing st u a = GenLocDrawing { +    getGenLocDrawing :: DrawingContext -> st -> (a, st, CatPrim)}++type instance DUnit  (GenLocDrawing st u a) = u+type instance UState (GenLocDrawing st u a) = st++type LocDrawing u a = GenLocDrawing () u a+++-- Functor++instance Functor (GenLocDrawing st u) where+  fmap f ma = GenLocDrawing $ \ctx s -> +    let (a,s1,o) = getGenLocDrawing ma ctx s in (f a, s1, o)+++-- Applicative++instance Applicative (GenLocDrawing st u) where+  pure a    = GenLocDrawing $ \_   s -> (a, s, mempty)+  mf <*> ma = GenLocDrawing $ \ctx s -> +                let (f,s1,o1) = getGenLocDrawing mf ctx s+                    (a,s2,o2) = getGenLocDrawing ma ctx s1+                in (f a, s2, o1 `mappend` o2)++++-- Monad++instance Monad (GenLocDrawing st u) where+  return a  = GenLocDrawing $ \_   s -> (a, s, mempty)+  ma >>= k  = GenLocDrawing $ \ctx s -> +                let (a,s1,o1) = getGenLocDrawing ma ctx s+                    (b,s2,o2) = (getGenLocDrawing . k) a ctx s1+                in (b, s2, o1 `mappend` o2)++++-- DrawingCtxM++instance DrawingCtxM (GenLocDrawing st u) where+  askDC           = GenLocDrawing $ \ctx s -> (ctx, s, mempty)+  asksDC fn       = GenLocDrawing $ \ctx s -> (fn ctx, s, mempty)+  localize upd ma = GenLocDrawing $ \ctx s -> +                      getGenLocDrawing ma (upd ctx) s++++-- UserStateM ++instance UserStateM (GenLocDrawing st u) where+  getState        = GenLocDrawing $ \_ s -> (s, s, mempty)+  setState s      = GenLocDrawing $ \_ _ -> ((), s, mempty)+  updateState upd = GenLocDrawing $ \_ s -> ((), upd s, mempty)+++-- Monoid++instance Monoid a => Monoid (GenLocDrawing st u a) where+  mempty           = GenLocDrawing $ \_   s -> (mempty, s, mempty)+  ma `mappend` mb  = GenLocDrawing $ \ctx s -> +                       let (a,s1,w1) = getGenLocDrawing ma ctx s+                           (b,s2,w2) = getGenLocDrawing mb ctx s1+                       in (a `mappend` b, s2, w1 `mappend` w2)++++--------------------------------------------------------------------------------++class Monad m => LocDrawM (m :: * -> *) where+  inserti   :: u ~ DUnit (m ()) => Image u a -> m a+  inserti_  :: u ~ DUnit (m ()) => Image u a -> m ()+  insertli  :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m a+  insertli_ :: u ~ DUnit (m ()) => Anchor u -> LocImage u a -> m ()+  insertci  :: u ~ DUnit (m ()) => +               Anchor u -> Anchor u -> ConnectorImage u a -> m a+  insertci_ :: u ~ DUnit (m ()) => +               Anchor u -> Anchor u -> ConnectorImage u a -> m ()++  inserti_  gf       = inserti gf >> return ()+  insertli_ pt gf    = insertli pt gf >> return ()+  insertci_ p1 p2 gf = insertci p1 p2 gf >> return ()+++instance InterpretUnit u => LocDrawM (GenLocDrawing st u) where+  inserti  = insertiImpl+  insertli = insertliImpl+  insertci = insertciImpl++ +--------------------------------------------------------------------------------+-- Run functions+++runGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                 => st -> GenLocDrawing st u a -> LocImage u (a,st)+runGenLocDrawing st ma = promoteLoc $ \(P2 x y) -> +    askDC >>= \ctx ->+    let (a,s1,w1) = getGenLocDrawing ma ctx st+        ans       = translate x y a +        dv1       = normalizeF (dc_font_size ctx) (V2 x y)+    in replaceAns (ans,s1) $ primGraphic $ cpmove dv1 w1+++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                  => st -> GenLocDrawing st u a -> LocImage u a+evalGenLocDrawing st ma = fmap fst $ runGenLocDrawing st ma+++-- | Forget the /answer/, just return the user state.+--+execGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                  => st -> GenLocDrawing st u a -> LocImage u st +execGenLocDrawing st ma = fmap snd $ runGenLocDrawing st ma+++stripGenLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +                   => st -> GenLocDrawing st u a -> LocQuery u (a,st)+stripGenLocDrawing st ma = stripLocImage $ runGenLocDrawing st ma+++-- | Simple version of 'runGenLocDrawing' - run a 'LocDrawing' without+-- user state.+--+runLocDrawing :: (Translate a, InterpretUnit u, u ~ DUnit a) +              => LocDrawing u a -> LocImage u a+runLocDrawing ma = evalGenLocDrawing () ma+++runLocDrawing_ :: (Translate a, InterpretUnit u, u ~ DUnit a) +               => LocDrawing u a -> LocGraphic u +runLocDrawing_ ma = ignoreAns $ runLocDrawing ma++++--------------------------------------------------------------------------------++insertiImpl :: InterpretUnit u +            => Image u a -> GenLocDrawing st u a+insertiImpl gf = GenLocDrawing $ \ctx s -> +    let (a,w1)   = runImage ctx gf in (a,s,w1) ++++++insertliImpl :: InterpretUnit u+             => Anchor u -> LocImage u a -> GenLocDrawing st u a+insertliImpl p1 gf = GenLocDrawing $ \ctx s -> +    let (a,w1) = runLocImage ctx p1 gf in (a,s,w1) ++++-- This is not right - if I\'ve taken an anchor from an object+-- within the relative coord system, the anchor points are already+-- translated respective to the origin. This implementation of +-- @insertci@ adds the translation a second time.+++insertciImpl :: InterpretUnit u +             => Anchor u -> Anchor u -> ConnectorImage u a +             -> GenLocDrawing st u a+insertciImpl p1 p2 gf = GenLocDrawing $ \ctx s -> +    let (a,w1) = runConnectorImage ctx p1 p2 gf in (a,s,w1)
+ src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}+++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.LocTrace+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.LocTrace+  (++  -- * GenLocTrace monad+    GenLocTrace+  , LocTrace++  , runGenLocTrace+  , evalGenLocTrace+  , execGenLocTrace+  , stripGenLocTrace++  , runLocTrace+  , runLocTrace_ ++  )++  where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space++import Control.Applicative+import Data.Monoid+++++-- | GenLocTrace is a reader-writer-state monad.+--+-- The writer accumulates a graphical trace and the state is +-- the current point.+--+newtype GenLocTrace st u a = GenLocTrace { +    getGenLocTrace :: DrawingContext -> DPoint2 -> st +                   -> (a, DPoint2, st, CatPrim)}++type instance DUnit  (GenLocTrace st u a) = u+type instance UState (GenLocTrace st u a) = st++type LocTrace u a = GenLocTrace () u a+++-- Functor++instance Functor (GenLocTrace st u) where+  fmap f ma = GenLocTrace $ \ctx pt s -> +    let (a,p1,s1,o) = getGenLocTrace ma ctx pt s in (f a, p1, s1, o)+++-- Applicative++instance Applicative (GenLocTrace st u) where+  pure a    = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)+  mf <*> ma = GenLocTrace $ \ctx pt s -> +                let (f,p1,s1,o1) = getGenLocTrace mf ctx pt s+                    (a,p2,s2,o2) = getGenLocTrace ma ctx p1 s1+                in (f a, p2, s2, o1 `mappend` o2)++++-- Monad++instance Monad (GenLocTrace st u) where+  return a  = GenLocTrace $ \_   pt s -> (a, pt, s, mempty)+  ma >>= k  = GenLocTrace $ \ctx pt s -> +                let (a,p1,s1,o1) = getGenLocTrace ma ctx pt s+                    (b,p2,s2,o2) = (getGenLocTrace . k) a ctx p1 s1+                in (b, p2, s2, o1 `mappend` o2)++++-- DrawingCtxM++instance DrawingCtxM (GenLocTrace st u) where+  askDC           = GenLocTrace $ \ctx pt s -> (ctx, pt, s, mempty)+  asksDC fn       = GenLocTrace $ \ctx pt s -> (fn ctx, pt, s, mempty)+  localize upd ma = GenLocTrace $ \ctx pt s -> getGenLocTrace ma (upd ctx) pt s++++-- UserStateM ++instance UserStateM (GenLocTrace st u) where+  getState        = GenLocTrace $ \_ pt s -> (s, pt, s, mempty)+  setState s      = GenLocTrace $ \_ pt _ -> ((), pt, s, mempty)+  updateState upd = GenLocTrace $ \_ pt s -> ((), pt, upd s, mempty)+++-- Monoid++instance Monoid a => Monoid (GenLocTrace st u a) where+  mempty           = GenLocTrace $ \_   pt s -> (mempty, pt, s, mempty)+  ma `mappend` mb  = GenLocTrace $ \ctx pt s -> +                       let (a,p1,s1,w1) = getGenLocTrace ma ctx pt s+                           (b,p2,s2,w2) = getGenLocTrace mb ctx p1 s1+                       in (a `mappend` b, p2, s2, w1 `mappend` w2)+++-- LocationM++instance InterpretUnit u => LocationM (GenLocTrace st u) where+  location = GenLocTrace $ \ctx pt s ->+      let upt = dinterpF (dc_font_size ctx) pt in (upt, pt, s, mempty) +++-- CursorM ++instance InterpretUnit u => InsertlM (GenLocTrace st u) where+  insertl   = insertlImpl++instance InterpretUnit u => CursorM (GenLocTrace st u) where+  moveby    = movebyImpl+++insertlImpl :: InterpretUnit u => LocImage u a -> GenLocTrace st u a+insertlImpl gf = GenLocTrace $ \ctx pt s ->+    let upt    = dinterpF (dc_font_size ctx) pt +        (a,w1) = runLocImage ctx upt gf+    in (a,pt,s,w1) +++movebyImpl :: InterpretUnit u => Vec2 u -> GenLocTrace st u ()+movebyImpl v1 = GenLocTrace $ \ctx pt s ->+    let dv1 = normalizeF (dc_font_size ctx) v1 +    in ((), pt .+^ dv1, s, mempty) ++++-- BranchCursorM ++instance InterpretUnit u => BranchCursorM (GenLocTrace st u) where+  branchCursor ma = GenLocTrace $ \ctx pt s ->+    let (a,_,s1,w1) = getGenLocTrace ma ctx pt s+    in (a, pt, s1, w1)  -- re-instate pt          ++++--------------------------------------------------------------------------------+-- Run functions+++runGenLocTrace :: InterpretUnit u +               => st -> GenLocTrace st u a -> LocImage u (a,st)+runGenLocTrace st ma = promoteLoc $ \pt -> +    askDC >>= \ctx ->+    let dpt         = normalizeF (dc_font_size ctx) pt+        (a,_,s1,w1) = getGenLocTrace ma ctx dpt st+    in replaceAns (a,s1) $ primGraphic w1+++++-- | Forget the user state LocImage, just return the /answer/.+--+evalGenLocTrace :: InterpretUnit u +                => st -> GenLocTrace st u a -> LocImage u a+evalGenLocTrace st ma = fmap fst $ runGenLocTrace st ma+++-- | Forget the /answer/, just return the user state.+--+execGenLocTrace :: InterpretUnit u +                => st -> GenLocTrace st u a -> LocImage u st +execGenLocTrace st ma = fmap snd $ runGenLocTrace st ma+++stripGenLocTrace :: InterpretUnit u +                 => st -> GenLocTrace st u a -> LocQuery u (a,st)+stripGenLocTrace st ma = stripLocImage $ runGenLocTrace st ma+++-- | Simple version of 'runGenLocTrace' - run a 'LocTrace' without+-- user state.+--+runLocTrace :: InterpretUnit u +            => LocTrace u a -> LocImage u a+runLocTrace ma = evalGenLocTrace () ma+++runLocTrace_ :: InterpretUnit u +             => LocTrace u a -> LocGraphic u +runLocTrace_ ma = ignoreAns $ runLocTrace ma+
+ src/Wumpus/Basic/Kernel/Drawing/PosObject.hs view
@@ -0,0 +1,668 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.PosObject+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Extended Graphic object - a rectangular /positionable/ Image.+-- +-- This graphic object has a more flexible API for positioning +-- than other graphic objects. Rather than a LocGraphic which +-- supports a single method of positioning at some start-point,+-- a @PosGraphic@ can be drawn at its center or locations on its +-- outer rectangle.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.PosObject+  (++  -- * Positionable image+    GenPosObject+  , GenPosGraphic++  , PosObject+  , DPosObject++  , PosGraphic+  , DPosGraphic++  -- * Operations+  , runGenPosObject+  , evalGenPosObject+  , execGenPosObject+  +  , runPosObject++  , runPosObjectBBox++  , makePosObject+  , emptyPosObject++  , elaboratePosObject+  , decoratePosObject++  , extendPosObject+  , mapOrientation++  , illustratePosObject++  -- * Primitive text PosObjects+  , posChar+  , posEscChar +  , posCharUpright+  , posEscCharUpright+  +  , posCharPrim++  , posText+  , posEscText +  , posTextUpright+  , posEscTextUpright++  , posTextPrim++  , multilinePosText+  , multilinePosEscText++  , rposText+  , rposEscText+  , rposChar+  , rposEscChar+  ++  , posHKernText++  , monospaceText+  , monospaceEscText++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.UpdateDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Concat+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage+import Wumpus.Basic.Kernel.Objects.Orientation++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Colour ( red, blue )++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.Monoid++--+-- Note - PosObject could be in the @Object@ rather than @Drawing@+-- namespace.+--++type DOrt = Orientation Double++-- | A positionable \"Object\".+--+newtype GenPosObject st u a = GenPosObject { +    getGenPosObject :: DrawingContext -> DPoint2 -> st -> (a, st, DOrt, CatPrim) }++type instance DUnit   (GenPosObject st u a) = u+type instance UState  (GenPosObject st u a) = st++type GenPosGraphic st u = GenPosObject st u (UNil u)+++-- | Type synonym for @GenPosObject () u a@, a PosObject without+-- user state.+--+type PosObject u a = GenPosObject () u a+    +-- | Version of PosObject specialized to Double for the unit type.+--+type DPosObject a = PosObject Double a+++-- | Version of PosObject with answer specialized to UNil.+--+type PosGraphic u = PosObject u (UNil u)++-- | Version of PosGraphic specialized to Double for the unit type.+--+type DPosGraphic = PosGraphic Double+++++instance Functor (GenPosObject st u) where+  fmap f mf = GenPosObject $ \ctx pt s -> +              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s in (f a,s1,o1,w1)+++instance Applicative (GenPosObject st u) where+  pure a    = GenPosObject $ \_   _  s -> (a,s,mempty,mempty)+  mf <*> ma = GenPosObject $ \ctx pt s -> +              let (f,s1,o1,w1) = getGenPosObject mf ctx pt s+                  (a,s2,o2,w2) = getGenPosObject ma ctx pt s1+              in (f a, s2, o1 `mappend` o2, w1 `mappend` w2)++++instance Monad (GenPosObject st u) where+  return a  = GenPosObject $ \_   _  s  -> (a, s, mempty, mempty)+  mf >>= k  = GenPosObject $ \ctx pt s -> +              let (a,s1,o1,w1) = getGenPosObject mf ctx pt s+                  (b,s2,o2,w2) = getGenPosObject (k a) ctx pt s1+              in (b, s2, o1 `mappend` o2, w1 `mappend` w2)+++instance (Monoid a, InterpretUnit u) => Monoid (GenPosObject st u a) where+  mempty = GenPosObject $ \_ _ s -> (mempty, s, mempty, mempty)+  ma `mappend` mb = GenPosObject $ \ctx pt s -> +                    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+                        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+                    in (a `mappend` b, s2, o1 `mappend` o2, w1 `mappend` w2)++++-- DrawingCtxM++instance DrawingCtxM (GenPosObject st u) where+  askDC           = GenPosObject $ \ctx _  s -> (ctx, s, mempty, mempty)+  asksDC fn       = GenPosObject $ \ctx _  s -> (fn ctx, s, mempty, mempty)+  localize upd ma = GenPosObject $ \ctx pt s -> +                      getGenPosObject ma (upd ctx) pt s++instance UserStateM (GenPosObject st u) where+  getState        = GenPosObject $ \_ _ s -> (s, s, mempty, mempty)+  setState s      = GenPosObject $ \_ _ _ -> ((), s, mempty, mempty)+  updateState upd = GenPosObject $ \_ _ s -> ((), upd s, mempty, mempty)++++-- | Running an PosObject produces a LocImage.+--+runGenPosObject :: InterpretUnit u +                => RectAddress -> st -> GenPosObject st u a -> LocImage u (a,st)+runGenPosObject addr st ma = promoteLoc $ \ot -> +    askDC >>= \ctx -> +    let dot          = normalizeF (dc_font_size ctx) ot+        (a,s1,o1,ca) = getGenPosObject ma ctx dot st+        v1           = vtoOrigin addr o1+    in replaceAns (a,s1) $ primGraphic $ cpmove v1 ca+++evalGenPosObject :: InterpretUnit u +                 => RectAddress -> st -> GenPosObject st u a -> LocImage u a+evalGenPosObject addr st ma = fmap fst $ runGenPosObject addr st ma++execGenPosObject :: InterpretUnit u +                 => RectAddress -> st -> GenPosObject st u a -> LocImage u st+execGenPosObject addr st ma = fmap snd $ runGenPosObject addr st ma++runPosObject :: InterpretUnit u +             => RectAddress -> PosObject u a -> LocImage u a+runPosObject addr ma = fmap fst $ runGenPosObject addr () ma+++++-- | Run a PosObject producing a LocImage (BoundingBox u).+--+runPosObjectBBox :: InterpretUnit u +                    => RectAddress -> PosObject u a -> LocImage u (BoundingBox u)+runPosObjectBBox addr ma = promoteLoc $ \pt -> +    askDC >>= \ctx -> +    let sz          = dc_font_size ctx +        dpt         = normalizeF sz pt+        (_,_,o1,w1) = getGenPosObject 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+-- is orientated within a border rectangle and a 'LocImage' that +-- draws it.+--+-- This is the /primary/ constructor for PosObjects. Because the+-- PosObject type is considered as a specialized object it does+-- not have the range of functions of LocImage or LocThetaImage.+-- +makePosObject :: InterpretUnit u+              => Query u (Orientation u) -> LocImage u a -> GenPosObject st u a+makePosObject ma gf = GenPosObject $ \ctx pt s -> +    let ort1  = runQuery ctx ma+        dort1 = normalizeF (dc_font_size ctx) ort1+        upt   = dinterpF (dc_font_size ctx) pt+        (a,w) = runLocImage ctx upt gf+    in (a,s,dort1,w)+++-- | 'emptyPosObject' : @ PosObject @+--+-- Build an empty 'PosGraphicObject'.+--+emptyPosObject :: (Monoid a, InterpretUnit u) => GenPosObject st u a+emptyPosObject = mempty++    ++--+-- decorate  - oblivious to /answer/.+-- elaborate - derives annotation from the /answer/ and makes a +--             cumulative graphic.+--+++elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)+                   => ZOrder -> RectAddress -> LocGraphic u +                   -> GenPosObject st u a+                   -> GenPosObject st u a+elaboratePosObject zo raddr gf ma = decoratePosObject zo fn ma+  where+    fn ortt = moveStart (vtoRectAddress ortt raddr) gf++++decoratePosObject :: InterpretUnit u +                  => ZOrder -> (Orientation u -> LocGraphic u) +                  -> GenPosObject st u a+                  -> GenPosObject st u a+decoratePosObject zo fn ma = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        uortt        = dinterpF (dc_font_size ctx) o1+        upt          = dinterpF (dc_font_size ctx) pt+        (_,w2)       = runLocImage ctx upt $ fn uortt+        wout         = case zo of+                         ZABOVE -> w1 `mappend` w2+                         ZBELOW -> w2 `mappend` w1+    in (a,s1,o1,wout)+++++-- | Extend the orientation.+--+extendPosObject :: InterpretUnit u +                => u -> u -> u -> u -> GenPosObject st u a +                -> GenPosObject st u a+extendPosObject x0 x1 y0 y1 ma = GenPosObject $ \ctx pt s ->+    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        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,s1,o2,w1)+++-- | 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) +               -> GenPosObject st u a -> GenPosObject st u a+mapOrientation fn mf = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject mf ctx pt s+        uort      = fn $ dinterpF (dc_font_size ctx) o1+        o2        = normalizeF (dc_font_size ctx) uort+    in (a,s1,o2,w1)+++--------------------------------------------------------------------------------+++-- | Illustrate a 'PosObject' by super-imposing its 'Orientation'.+--+-- This turns the 'PosObject' into a 'LocImage' drawn at the locus+-- of the PosObject.+--+illustratePosObject :: InterpretUnit u +                    => PosObject u a -> LocGraphic u+illustratePosObject mf  = promoteLoc $ \pt ->   +    askDC >>= \ctx ->+    let dpt         = normalizeF (dc_font_size ctx) pt +        (_,_,o1,w1) = getGenPosObject mf ctx dpt ()+        uort        = dinterpF (dc_font_size ctx) o1+    in decorateBelow (primGraphic w1) (illustrateOrientation uort `at` pt)+++illustrateOrientation :: InterpretUnit u +                      => Orientation u -> LocGraphic u+illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteLoc $ \pt -> +    dinterpCtx 3 >>= \radius -> +    let upd = localize (fill_colour blue . dotted_line)+        bl  = pt .-^ V2 xmin ymin+        dot = localize (fill_colour red) $ dcDisk DRAW_FILL radius `at` pt+        hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin+        vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin+        bdr = upd $ dcRectangle DRAW_STROKE (xmin+xmaj) (ymin+ymaj) `at` bl+    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 -> GenPosGraphic st u+posChar             = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . CharLiteral++posEscChar          :: InterpretUnit u +                    => EscapedChar -> GenPosGraphic st u+posEscChar          = makeCharPO CAP_HEIGHT_PLUS_DESCENDER++posCharUpright      :: InterpretUnit u +                    => Char -> GenPosGraphic st u+posCharUpright      = makeCharPO JUST_CAP_HEIGHT . CharLiteral++posEscCharUpright   :: InterpretUnit u +                    => EscapedChar -> GenPosGraphic st u+posEscCharUpright   = makeCharPO JUST_CAP_HEIGHT+++-- | Primtive builder that does not add margins.+--+posCharPrim         :: InterpretUnit u +                    => Either Char EscapedChar -> GenPosGraphic st u+posCharPrim = makeCharPO CAP_HEIGHT_PLUS_DESCENDER . either CharLiteral id+++makeCharPO :: InterpretUnit u +           => TextHeight -> EscapedChar -> GenPosGraphic st 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 -> GenPosGraphic st u+posText     = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER . escapeString++posEscText  :: InterpretUnit u +            => EscapedText -> GenPosGraphic st u+posEscText  = addMargins . makeTextPO CAP_HEIGHT_PLUS_DESCENDER+++posTextUpright      :: InterpretUnit u +                    => String -> GenPosGraphic st u+posTextUpright      = addMargins . makeTextPO JUST_CAP_HEIGHT . escapeString++posEscTextUpright   :: InterpretUnit u +                    => EscapedText -> GenPosGraphic st u+posEscTextUpright   = addMargins . makeTextPO JUST_CAP_HEIGHT++-- | Primtive builder that does not add margins.+--+posTextPrim         :: InterpretUnit u +                    => Either String EscapedText -> GenPosGraphic st 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] -> GenPosGraphic st u+multilinePosEscText vspec xs = addMargins $ GenPosObject $ \ctx pt s -> +      let sep    = runQuery ctx textlineSpace+      in getGenPosObject (body sep) ctx pt s+  where+    body sp = alignColumnSep vspec sp $ +                map (makeTextPO CAP_HEIGHT_PLUS_DESCENDER) xs++++-- | Note - this does not add margins.+--+makeTextPO :: InterpretUnit u +           => TextHeight -> EscapedText -> GenPosGraphic st u+makeTextPO hspec esc = +    makePosObject (textOrientationZero hspec esc) (dcEscapedlabel esc)+++addMargins :: InterpretUnit u => GenPosObject st u a -> GenPosObject st 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 -> GenPosGraphic st u+rposText ang    = addMargins . makeRotatedPO ang . escapeString++-- | Note - for single line text.+--+rposEscText     :: (Real u, Floating u, InterpretUnit u) +                => Radian -> EscapedText -> GenPosGraphic st u+rposEscText ang = addMargins . makeRotatedPO ang+++rposChar        :: (Real u, Floating u, InterpretUnit u) +                => Radian -> Char -> GenPosGraphic st u+rposChar ang ch = rposEscText ang $ wrapEscChar $ CharLiteral ch++rposEscChar     :: (Real u, Floating u, InterpretUnit u) +                => Radian -> EscapedChar -> GenPosGraphic st u+rposEscChar ang ch = rposEscText ang $ wrapEscChar ch+++++makeRotatedPO :: (Real u, Floating u, InterpretUnit u) +              => Radian -> EscapedText -> GenPosGraphic st 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] -> GenPosGraphic st u+posHKernText xs = makePosObject (hkernOrientationZero xs) (hkernLine xs)++-- | The query should retrieve the width of one char.+--+monospaceText :: InterpretUnit u +              => Query u u -> String -> GenPosGraphic st u+monospaceText qry = monospaceEscText qry . escapeString+++-- | The query should retrieve the width of one char.+--+monospaceEscText :: InterpretUnit u +                 => Query u u -> EscapedText -> GenPosGraphic st u+monospaceEscText qry esc = GenPosObject $ \ctx pt s ->+    let upt    = dinterpF (dc_font_size ctx) pt+        uw     = runQuery ctx qry+        ks     = monos uw $ destrEscapedText id esc+        ortt   = runQuery ctx $ hkernOrientationZero ks+        dort   = normalizeF (dc_font_size ctx) ortt+        (_,w1) = runLocImage ctx upt $ hkernLine ks+    in (UNil, s, 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 (Monoid a, InterpretUnit u) => ZConcat (GenPosObject st u a) where+  superior = mappend+  anterior = flip mappend+++instance Monoid a => Concat (GenPosObject st u a) where+  hconcat = genMoveAlign spinemoveH spineRight+  vconcat = genMoveAlign spinemoveV spineBelow++instance (Monoid a, InterpretUnit u) => CatSpace (GenPosObject st u a) where+  hspace = genMoveSepH spinemoveH spineRight+  vspace = genMoveSepV spinemoveV spineBelow++++instance Monoid a => Align (GenPosObject st u a) where+  halign HALIGN_TOP    = genMoveAlign binmoveHTop    halignTopO+  halign HALIGN_CENTER = genMoveAlign binmoveHCenter halignCenterO+  halign HALIGN_BASE   = genMoveAlign binmoveHBottom halignBottomO++  valign VALIGN_LEFT   = genMoveAlign binmoveVLeft   valignLeftO+  valign VALIGN_CENTER = genMoveAlign binmoveVCenter valignCenterO+  valign VALIGN_RIGHT  = genMoveAlign binmoveVRight  valignRightO++++genMoveAlign :: Monoid a+             => (Orientation Double -> Orientation Double -> Vec2 Double) +             -> (Orientation Double -> Orientation Double -> Orientation Double) +             -> GenPosObject st u a -> GenPosObject st u a -> GenPosObject st u a+genMoveAlign mkV mkO ma mb = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        v1           = mkV o1 o2+        ortt         = mkO o1 o2+        w2'          = cpmove v1 w2 +    in (a `mappend` b, s2, ortt, w1 `mappend` w2')+++--------------------------------------------------------------------------------+-- Sep++instance (Monoid a, InterpretUnit u) => AlignSpace (GenPosObject st u a) where+  halignSpace HALIGN_TOP    = genMoveSepH binmoveHTop    halignTopO+  halignSpace HALIGN_CENTER = genMoveSepH binmoveHCenter halignCenterO+  halignSpace HALIGN_BASE   = genMoveSepH binmoveHBottom halignBottomO++  valignSpace VALIGN_LEFT   = genMoveSepV binmoveVLeft   valignLeftO+  valignSpace VALIGN_CENTER = genMoveSepV binmoveVCenter valignCenterO+  valignSpace VALIGN_RIGHT  = genMoveSepV binmoveVRight  valignRightO+++genMoveSepH :: (Monoid a, InterpretUnit u) +            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double) +            -> u+            -> GenPosObject st u a -> GenPosObject st u a +            -> GenPosObject st u a+genMoveSepH mkV mkO sep ma mb  = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s+        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        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, s2, ortt, w1 `mappend` w2')++++genMoveSepV :: (Monoid a, InterpretUnit u)+            => (Orientation Double -> Orientation Double -> Vec2 Double) +            -> (Orientation Double -> Orientation Double -> Orientation Double) +            -> u+            -> GenPosObject st u a -> GenPosObject st u a +            -> GenPosObject st u a+genMoveSepV mkV mkO sep ma mb = GenPosObject $ \ctx pt s -> +    let (a,s1,o1,w1) = getGenPosObject ma ctx pt s +        (b,s2,o2,w2) = getGenPosObject mb ctx pt s1+        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, s2, ortt, w1 `mappend` w2')+
+ src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs view
@@ -0,0 +1,410 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Drawing.TraceDrawing+-- Copyright   :  (c) Stephen Tetley 2010-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  unstable+-- Portability :  GHC +--+-- Drawing with /trace/ - a Writer like monad collecting +-- intermediate graphics - and /drawing context/ - a reader monad+-- of attributes - font_face, fill_colour etc.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Drawing.TraceDrawing+  (++  -- * Collect primitives (writer-like monad) +    GenTraceDrawing+  , TraceDrawing+  , DTraceDrawing++  , runTraceDrawing+  , execTraceDrawing+  , evalTraceDrawing++  , runGenTraceDrawing+++  , liftToPictureU+  , liftToPictureMb+  , mbPictureU+ +  , trace+  , fontDelta+  , evalQuery++  , draw+  , drawi+  , drawl+  , drawli++  , drawc+  , drawci++  , node+  , nodei+ +  , drawrc+  , drawrci++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Drawing.Basis+import Wumpus.Basic.Kernel.Objects.Anchors+import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Data.Monoid+++--------------------------------------------------------------------------------+++++-- Note - TraceDrawing run \once\ - it is supplied with the starting+-- environment (DrawingContext) and returns a Picture.+--+-- Other Wumpus monads (e.g. Turtle) will typically be run inside+-- the TraceDrawing monad as a local effect, rather than built into a +-- transformer stack.+--+++newtype GenTraceDrawing st u a   = GenTraceDrawing { +          getGenTraceDrawing :: DrawingContext -> st -> (a, st, HPrim u) }+++type instance DUnit   (GenTraceDrawing st u a) = u+type instance UState  (GenTraceDrawing st u a) = st++type TraceDrawing u a = GenTraceDrawing () u a++type DTraceDrawing a    = TraceDrawing Double a+++-- Functor++instance Functor (GenTraceDrawing st u) where+  fmap f ma = GenTraceDrawing $ \ctx s -> +                let (a,s1,w1) = getGenTraceDrawing ma ctx s in (f a,s1,w1)+++-- Applicative++instance Applicative (GenTraceDrawing st u) where+  pure a    = GenTraceDrawing $ \_   s -> (a, s, mempty)+  mf <*> ma = GenTraceDrawing $ \ctx s -> +                let (f,s1,w1) = getGenTraceDrawing mf ctx s+                    (a,s2,w2) = getGenTraceDrawing ma ctx s1+                in (f a, s2, w1 `mappend` w2)+++-- Monad++instance Monad (GenTraceDrawing st u) where+  return a  = GenTraceDrawing $ \_   s -> (a, s, mempty)+  ma >>= k  = GenTraceDrawing $ \ctx s -> +                let (a,s1,w1) = getGenTraceDrawing ma ctx s+                    (b,s2,w2) = (getGenTraceDrawing . k) a ctx s1+                in (b,s2,w1 `mappend` w2)+                               ++-- DrawingCtxM++instance DrawingCtxM (GenTraceDrawing st u) where+  askDC           = GenTraceDrawing $ \ctx s -> (ctx, s, mempty)+  asksDC f        = GenTraceDrawing $ \ctx s -> (f ctx, s, mempty)+  localize upd ma = GenTraceDrawing $ \ctx s -> +                      getGenTraceDrawing ma (upd ctx) s+++-- UserStateM ++instance UserStateM (GenTraceDrawing st u) where+  getState        = GenTraceDrawing $ \_ s -> (s, s, mempty)+  setState s      = GenTraceDrawing $ \_ _ -> ((), s, mempty)+  updateState upd = GenTraceDrawing $ \_ s -> ((), upd s, mempty)+ ++++runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u)+runTraceDrawing ctx ma = post $ getGenTraceDrawing ma ctx ()+  where+    post (a,_,w1) = (a,w1)++++-- | Run the drawing returning only the output it produces, drop+-- any answer from the monadic computation.+--+execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u+execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma++-- | Run the drawing ignoring the output it produces, return the +-- answer from the monadic computation.+--+-- Note - this useful for testing, generally one would want the +-- opposite behaviour (return the drawing, ignore than the +-- answer).+-- +evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a+evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma+++runGenTraceDrawing :: DrawingContext -> st -> GenTraceDrawing st u a +                   -> (a,st,HPrim u)+runGenTraceDrawing ctx st ma = getGenTraceDrawing ma ctx st++++++-- | /Unsafe/ promotion of @HPrim@ to @Picture@.+--+-- If the HPrim is empty, a run-time error is thrown.+-- +liftToPictureU :: HPrim u -> Picture+liftToPictureU hf = +    let prims = hprimToList hf in if null prims then errK else frame prims+  where+    errK = error "toPictureU - empty prims list."++-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.+--+-- If the HPrim is empty, then @Nothing@ is returned.+-- +liftToPictureMb :: HPrim u -> Maybe Picture+liftToPictureMb hf = let prims = hprimToList hf in +    if null prims then Nothing else Just (frame prims)++++-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.+--+-- This is equivalent to:+--+-- > fromMaybe (error "empty") $ pic+--+-- This function is solely a convenience, using it saves one +-- import and a few characters.+--+-- If the supplied value is @Nothing@ a run-time error is thrown.+-- +mbPictureU :: Maybe Picture -> Picture+mbPictureU Nothing  = error "mbPictureU - empty picture."+mbPictureU (Just a) = a++-- Note - need an equivalent to Parsec\`s parseTest that provides+-- a very simple way to run graphics without concern for return +-- type or initial drawing context.++++--------------------------------------------------------------------------------++++-- TraceM +--+-- Note -  @ state `mappend` a @ means the first expression in a +-- monadic drawing is the first element in the output file. It is+-- also \*\* at the back \*\* in the the Z-Order.+--+-- Some control over the Z-Order, possibly by adding /layers/ to +-- the drawing model would be valuable. +-- ++-- | Primitive operation - cf. tell in Reader monad.+--+trace     :: HPrim u -> GenTraceDrawing st u ()+trace a = GenTraceDrawing $ \_ s -> ((), s, a)++++fontDelta :: GenTraceDrawing st u a -> GenTraceDrawing st u a+fontDelta mf = GenTraceDrawing $ \ctx s -> +    let (_,font_attrs) = runQuery ctx textAttr+        (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++++-- | Draw a Graphic taking the drawing style from the +-- /drawing context/. +--+-- This function is the /forgetful/ version of 'drawi'. +-- Commonly, it is used to draw 'Graphic' objects which +-- have no /answer/.+-- +draw :: Image u a -> GenTraceDrawing st u ()+draw gf = askDC >>= \ctx -> +          let (_,w) = runImage ctx gf+          in trace (singleH w) >> return ()+++++-- | Draw an Image taking the drawing style from the +-- /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawi :: Image u a -> GenTraceDrawing st u a+drawi gf = askDC >>= \ctx -> +           let (a,w) = runImage ctx gf+           in trace (singleH w) >> return a+            +++-- | Draw a LocImage at the supplied Anchor taking the drawing +-- style from the /drawing context/. +--+-- This function is the /forgetful/ version of 'drawli'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +drawl :: InterpretUnit u+      => Anchor u -> LocImage u a -> GenTraceDrawing st u ()+drawl ancr img = drawli ancr img >> return ()++++-- | Draw a LocImage at the supplied Point taking the drawing +-- style from the /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawli :: InterpretUnit u+       => Anchor u -> LocImage u a -> GenTraceDrawing st u a+drawli pt gf = askDC >>= \ctx -> +               let (a,w) = runLocImage ctx pt gf+               in trace (singleH w) >> return a+++-- Design note - having @drawlti@ for LocThetaImage does not seem +-- compelling (at the moment). The thinking is that LocTheta+-- objects should be downcast to Loc objects before drawing. +--+-- Connectors however are be different. +-- +-- PosImages would seem to be the same as LocThetaImages.+--++++-- | Draw a ConnectorGraphic with the supplied Anchors taking the +-- drawing style from the /drawing context/. +--+-- This function is the /forgetful/ version of 'drawci'. +-- Commonly, it is used to draw 'ConnectorGraphic' objects which +-- have no /answer/.+-- +drawc :: InterpretUnit u+      => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u ()+drawc an0 an1 gf = drawci an0 an1 gf >> return () +++-- | Draw a ConnectorImage with the supplied Points taking the +-- drawing style from the /drawing context/. +--+-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned.+-- +drawci :: InterpretUnit u +       => Anchor u -> Anchor u -> ConnectorImage u a -> GenTraceDrawing st u a+drawci p0 p1 gf = drawi (connect gf p0 p1)+++++++++-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/.+-- +-- This function is the /forgetful/ version of 'nodei'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +node :: ( Fractional u, InterpretUnit u)+     => (Int,Int) -> LocImage u a -> GenTraceDrawing st u ()+node coord gf = nodei coord gf >> return ()+++-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/.+-- +nodei :: (Fractional u, InterpretUnit u) +      => (Int,Int) -> LocImage u a -> GenTraceDrawing st u a+nodei coord gf = askDC >>= \ctx -> +                 position coord >>= \pt ->+                 let (a,w) = runLocImage ctx pt gf+                 in trace (singleH w) >> return a+ +++++-- | Draw a connector between two objects. The projection of the+-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line+-- are the radial points on the objects borders that cross the +-- projected line.+-- +-- This function is the /forgetful/ version of 'drawrci'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/.+-- +drawrc :: ( Real u, Floating u, InterpretUnit u+          , CenterAnchor a1, RadialAnchor a1+          , CenterAnchor a2, RadialAnchor a2+          , u ~ DUnit a1, u ~ DUnit a2+          ) +       => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u ()+drawrc a b gf = drawrci a b gf >> return ()+++-- | Draw a connector between two objects. The projection of the+-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line+-- are the radial points on the objects borders that cross the +-- projected line.+-- +drawrci :: ( Real u, Floating u, InterpretUnit u+           , CenterAnchor a1, RadialAnchor  a1+           , CenterAnchor a2, RadialAnchor  a2+           , u ~ DUnit a1, u ~ DUnit a2+           ) +        => a1 -> a2 -> ConnectorImage u a -> GenTraceDrawing st u a+drawrci a b gf = +    let (p0,p1) = radialConnectorPoints a b in drawi (connect gf p0 p1)
+ src/Wumpus/Basic/Kernel/Objects/AdvObject.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.AdvObject+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Extended Graphic object - an AdvanceGraphic is a Graphic +-- twinned with and advance vector.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.AdvObject+  (+++  -- * Advance vector+    AdvanceVec+  , advanceH+  , advanceV+++  -- * Advance-vector object and graphic+  , AdvObject+  , DAdvObject++  , AdvGraphic+  , DAdvGraphic+  +  , runAdvObject++  , makeAdvObject+  , emptyAdvObject+  , blankAdvObject+  ++  -- * Composition+  , advance+  , advances+  , advspace+  , evenspace++  , advrepeat+  , punctuate+  , advfill++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Data.VectorSpace                         -- package: vector-space++import Control.Applicative+import Data.Monoid+++++--------------------------------------------------------------------------------++-- | Advance vectors provide an idiom for drawing consecutive+-- graphics. PostScript uses them to draw left-to-right text - +-- each character has an advance vector for the width and +-- as characters are drawn they successively displace the start+-- point for the next character with their advance vector.+--+-- Type alias for Vec2.+--+type AdvanceVec u = Vec2 u+++-- | Extract the horizontal component of an advance vector.+--+-- For left-to-right latin text, the vertical component of an+-- advance vector is expected to be 0. Ingoring it seems +-- permissible when drawing text.+--+advanceH :: AdvanceVec u -> u+advanceH (V2 w _)  = w++-- | Extract the verticall component of an advance vector.+--+advanceV :: AdvanceVec u -> u+advanceV (V2 _ h)  = h+++--------------------------------------------------------------------------------+-- AdvObject++-- | 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 a = AdvObject +          { getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) }++type instance DUnit (AdvObject u a) = u++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 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)++++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 :: 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 * image -> AdvObject @+--+-- Build an 'AdvObject' from a context function ('CF') that +-- generates the answer displacement vector and a 'LocGraphic' +-- that draws the 'AdvObject'.+--+makeAdvObject :: InterpretUnit u +              => Query u (Vec2 u) -> LocImage u a -> AdvObject u a+makeAdvObject ma gf = AdvObject $ \ctx pt -> +    let v1    = runQuery ctx ma+        dav1  = DAV $ normalizeF (dc_font_size ctx) v1+        upt   = dinterpF (dc_font_size ctx) pt+        (a,w) = runLocImage ctx upt gf+    in (a,dav1,w)++++-- | 'emptyAdvObjectAU' : @ AdvObject @+--+-- Build an empty 'AdvObject'.+-- +-- The 'emptyAdvObject' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, the answer vector generated is+-- the zero vector @(V2 0 0)@.+-- +emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a+emptyAdvObject = 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++++-- Helper for list concatenation.+-- +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+    go acc []     = acc+    go acc (b:bs) = go (acc `op` b) bs++++-- AdvObject does not have the same ability to be concatenated+-- as PosObject - all the advance vector says is \"where to go +-- next\". Nothing in the AdvObject tracks the boundary so we+-- cannot implement the Concat classes.++infixr 6 `advance`+++-- | Draw the first AdvObject and use the advance vector to +-- displace the second AdvObject.+--+-- The final answer is the sum of both advance vectors.+--+advance :: (Monoid a, InterpretUnit u) +        => AdvObject u a -> AdvObject u a -> AdvObject u a+advance = mappend+  ++-- | Concatenate the list of AdvObjects with '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 :: (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 :: (Monoid a, InterpretUnit u) +          => Vec2 u -> [AdvObject u a] -> AdvObject u a+evenspace v = listcat (advspace v)++++-- | Repeat the AdvObject @n@ times, moving each time with +-- 'advance'.+--+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 :: (Monoid a, InterpretUnit u)+          => AdvObject u a -> [AdvObject u a] -> AdvObject u a+punctuate sep =  listcat (\a b -> a `advance` sep `advance` b)++++-- | Render the supplied AdvObject, but swap the result advance+-- for the supplied vector. This function has behaviour analogue +-- to @fill@ in the @wl-pprint@ library.+-- +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)++
− src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs 
@@ -1,106 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.AdvanceGraphic--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Extended Graphic object - an AdvanceGraphic is a Graphic --- twinned with and AdvanceV vector.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.AdvanceGraphic-  (--  -- * Advance-vector graphic-    AdvGraphic-  , DAdvGraphic---  , makeAdvGraphic-  , extractLocGraphic-  , runAdvGraphic--  -- * Composition-  , advplus-  , advconcat--  ) where--import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.BaseObjects-import Wumpus.Basic.Kernel.Objects.Graphic--import Wumpus.Core                              -- package: wumpus-core---import Control.Applicative---- | /Advance vector/ graphic - this partially models the --- PostScript @show@ command which moves the /current point/ by the--- width (advance) vector as each character is drawn.----type AdvGraphic u      = LocImage u (Point2 u)--type DAdvGraphic       = AdvGraphic Double------------------------------------------------------------------------------------------ | Construction is different to intoZZ functions hence the --- different name.----makeAdvGraphic :: DrawingInfo (PointDisplace u)-               -> LocGraphic u -               -> AdvGraphic u-makeAdvGraphic dispf gf = -    promoteR1 $ \pt -> dispf >>= \fn -> fmap (replaceL $ fn pt) (gf `at` pt)  -------- This should probably go - the name is not exact enough...--extractLocGraphic :: AdvGraphic u -> LocGraphic u-extractLocGraphic = fmap (replaceL uNil)--runAdvGraphic :: DrawingContext  -> Point2 u -> AdvGraphic u -              -> (Point2 u, PrimGraphic u)-runAdvGraphic ctx pt df = runCF1 ctx pt df--------------------------------------------------------------------------------------- composition---- Note there are opportunities for extra composition operators--- like the /picture language/...--infixr 6 `advplus`----- | \*\* WARNING \*\* - pending removal.----advplus :: AdvGraphic u -> AdvGraphic u -> AdvGraphic u-advplus = chain1---advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u-advconcat []     = makeAdvGraphic (pure id) emptyLocGraphic-advconcat [x]    = x-advconcat (x:xs) = x `chain1` advconcat xs
+ src/Wumpus/Basic/Kernel/Objects/Anchors.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE KindSignatures             #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Anchors+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Anchor points on shapes, bounding boxes, etc.+--+-- Anchors are addressable positions, an examplary use is taking+-- anchors on node shapes to get the in-bound and out-bound points +-- for connectors in a network (graph) diagram.+-- +-- \*\* WARNING \*\* - the API here probably needs some more +-- thought.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Anchors+  ( ++  -- * Anchors+    Anchor++  -- * Anchor classes+  , CenterAnchor(..)+  , ApexAnchor(..)+  , CardinalAnchor(..)+  , CardinalAnchor2(..)+  , RadialAnchor(..)+  , TopCornerAnchor(..)+  , BottomCornerAnchor(..)+  , SideMidpointAnchor(..)+++  -- * Extended anchor points+  , projectAnchor++  , radialConnectorPoints++  ) where+++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space+++-- | Note an Anchor is just a Point2.+--+type Anchor u = Point2 u+++-- | Center of an object.+--+class CenterAnchor a where+  center :: u ~ DUnit a => a -> Anchor u+++-- | Apex of an object.+--+class ApexAnchor a where+  apex :: u ~ DUnit a => a -> Anchor u+++-- | Cardinal (compass) positions on an object. +-- +-- Cardinal anchors should be at their equivalent radial position.+-- However, some shapes may not be able to easily define radial +-- positions or may be able to provide more efficient definitions +-- for the cardinal anchors. Hence the redundancy seems justified. +--+class CardinalAnchor a where+  north :: u ~ DUnit a => a -> Anchor u+  south :: u ~ DUnit a => a -> Anchor u+  east  :: u ~ DUnit a => a -> Anchor u+  west  :: u ~ DUnit a => a -> Anchor u++--+-- Note - a design change is probably in order where the cardinals +-- should /always/ represent their true cardinal position.+--+-- If this change is made, it is worthwhile having cardinals as+-- classes (rather than making them derived operations on +-- RadialAnchor) as classes allow for more efficient +-- implementations usually by trigonometry.+-- +++-- | Secondary group of cardinal (compass) positions on an object+-- for the diagonal positions. +-- +-- It seems possible that for some objects defining the primary+-- compass points (north, south,...) will be straight-forward +-- whereas defining the secondary compass points may be +-- problematic, hence the compass points are split into two +-- classes.+--+class CardinalAnchor2 a where+  northeast :: u ~ DUnit a => a -> Anchor u+  southeast :: u ~ DUnit a => a -> Anchor u+  southwest :: u ~ DUnit a => a -> Anchor u+  northwest :: u ~ DUnit a => a -> Anchor u+++-- | Anchor on a border that can be addressed by an angle.+--+-- The angle is counter-clockwise from the right-horizontal, i.e.+-- 0 is /east/.+--+class RadialAnchor a where+  radialAnchor :: Radian -> u ~ DUnit a => a -> Anchor u+++-- | Anchors at the top left and right corners of a shape.+--+-- For some shapes (Rectangle) the TikZ convention appears to be+-- have cardinals as the corner anchors, but this doesn\'t seem+-- to be uniform. Wumpus will need to reconsider anchors at some +-- point...+--+class TopCornerAnchor a where+  topLeftCorner  :: u ~ DUnit a => a -> Anchor u+  topRightCorner :: u ~ DUnit a => a -> Anchor u+++-- | Anchors at the bottom left and right corners of a shape.+--+class BottomCornerAnchor a where+  bottomLeftCorner  :: u ~ DUnit a => a -> Anchor u+  bottomRightCorner :: u ~ DUnit a => a -> Anchor u+++-- | Anchors in the center of a side.+-- +-- Sides are addressable by index. Following TikZ, side 1 is +-- expected to be the top of the shape. If the shape has an apex +-- instead of a side then side 1 is expected to be the first side +-- left of the apex.+-- +-- Implementations are also expected to modulo the side number, +-- rather than throw an out-of-bounds error.+--+class SideMidpointAnchor a where+  sideMidpoint :: Int -> u ~ DUnit a => a -> Anchor u++++--------------------------------------------------------------------------------++-- | 'projectAnchor' : @ extract_func * dist * object -> Point @+-- +-- Derive a anchor by projecting a line from the center of an +-- object through the intermediate anchor (produced by the +-- extraction function). The final answer point is located along+-- the projected line at the supplied distance @dist@.+-- +-- E.g. take the north of a rectangle and project it 10 units +-- further on:+--  +-- > projectAnchor north 10 my_rect+--+-- If the distance is zero the answer with be whatever point the +-- the extraction function produces.+--+-- If the distance is negative the answer will be along the +-- projection line, between the center and the intermediate anchor.+--+-- If the distance is positive the anchor will be extend outwards +-- from the intermediate anchor.+--+projectAnchor :: (Real u, Floating u, CenterAnchor a, u ~ DUnit a) +              => (a -> Anchor u) -> u -> a -> Anchor u+projectAnchor fn d a = p1 .+^ (avec (vdirection v) d)+  where+    p1  = fn a +    v   = pvec (center a) p1 +     +++--------------------------------------------------------------------------------++-- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @+--+-- Find the radial connectors points for objects @a@ and @b@ along+-- the line joining their centers.+--+radialConnectorPoints :: ( Real u, Floating u+                         , CenterAnchor a, RadialAnchor a+                         , CenterAnchor b, RadialAnchor b+                         , u ~ DUnit a, u ~ DUnit b) +                      => a -> b -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor ang a, radialAnchor (ang+pi) b)+  where+    ang = vdirection $ pvec (center a) (center b)+     +    ++--------------------------------------------------------------------------------+-- Instances ++instance Fractional u => CenterAnchor (BoundingBox u) where+  center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y +     where+       x = xl+0.5*(xr-xl)+       y = ylo+0.5*(yhi-ylo)+       ++instance Fractional u => CardinalAnchor (BoundingBox u) where+  north (BBox (P2 xl _  ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi+  south (BBox (P2 xl ylo) (P2 xr _  )) = P2 (xl+0.5*(xr-xl)) ylo+  east  (BBox (P2 _  ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo))+  west  (BBox (P2 xl ylo) (P2 _  yhi)) = P2 xl (ylo+0.5*(yhi-ylo))+++instance Fractional u => CardinalAnchor2 (BoundingBox u) where+  northeast (BBox _ ur)                 = ur+  southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo+  southwest (BBox ll _)                 = ll+  northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi +
− src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.BaseObjects--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Aliases for ContextFun types.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.BaseObjects-  (--  -- * Drawing info-    DrawingInfo-  , LocDrawingInfo-  , LocThetaDrawingInfo---  -  -- * Drawing objects-  , ImageAns-  , GraphicAns--  , Image-  , LocImage-  , LocThetaImage--  , DImage-  , DLocImage-  , DLocThetaImage--  , hyperlink--  ) where--import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.WrappedPrimitive--import Wumpus.Core                              -- package: wumpus-core------------------------------------------------------------------------------------- DrawingInfo---- | A query on the DrawingContext.------ Alias for 'CF'.--- -type DrawingInfo a      = CF a----- | A query on the DrawingContext respective to the supplied---  point.------ Alias for 'LocCF'.--- -type LocDrawingInfo u a   = LocCF u a----- | A query on the DrawingContext respective to the supplied---  point and angle.------ Alias for 'LocCF'.--- -type LocThetaDrawingInfo u a   = LocThetaCF u a---------------------------------------------------------------------------------------- Image----- | An Image always returns a pair of some polymorphic answer @a@--- and a PrimGraphic.------ Note a PrimGraphic cannot be empty.--- -type ImageAns u a       = (a, PrimGraphic u)---type GraphicAns u       = ImageAns u (UNil u)----- | Draw a PrimGraphic repsective to the 'DrawingContext' and --- return some answer @a@.--- -type Image u a      = CF (ImageAns u a)----- | Draw a PrimGraphic respective to the 'DrawingContext' and --- the supplied point, return some answer @a@.--- -type LocImage u a   = LocCF u (ImageAns u a)----- | Draw a PrimGraphic respective to the 'DrawingContext' and--- the supplied point and angle.--- -type LocThetaImage u a   = LocThetaCF u (ImageAns u a)----type DImage a            = Image Double a-type DLocImage a         = LocImage Double a-type DLocThetaImage a    = LocThetaImage Double a---type instance DUnit (Image u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u))--type instance DUnit (LocImage u a) = u --  GuardEq (DUnit a) (DUnit (PrimGraphic u))--type instance DUnit (LocThetaImage u a) = u--------------------------------------------------------------------------------------- Affine instances---- Note - it seems better to have these instances for Image (even --- though Image is a type synonym) rather than more general --- instances on a CF.------ There is nothing determining a DUnit for the CF types.------ The downside is these instances are effectively orphan --- instances.-----instance (Real u, Floating u, Rotate a, DUnit a ~ u) => -    Rotate (Image u a) where-  rotate ang = fmap (rotate ang)---instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => -    RotateAbout (Image u a) where-  rotateAbout ang pt = fmap (rotateAbout ang pt)---instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where-  scale sx sy = fmap (scale sx sy)---instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where-  translate dx dy = fmap (translate dx dy)----- \*\* WARNING \*\* - I am not sure having affine instances for --- LocImage makes sense...------ Particularly, what is a rotateAbout on a function from Point to --- Graphic? Is it just a post-transformation, or should the start --- point be transformed as well.-----instance (Real u, Floating u, Rotate a, DUnit a ~ u) => -    Rotate (LocImage u a) where-  rotate ang = fmap (rotate ang)--instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => -    RotateAbout (LocImage u a) where-  rotateAbout ang pt = fmap (rotateAbout ang pt)---instance (Num u, Scale a, DUnit a ~ u) => Scale (LocImage u a) where-  scale sx sy = fmap (scale sx sy)---instance (Num u, Translate a, DUnit a ~ u) => Translate (LocImage u a) where-  translate dx dy = fmap (translate dx dy)-------------------------------------------------------------------------------------hyperlink :: XLink -> Image u a -> Image u a-hyperlink hypl = -    fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim))------
+ src/Wumpus/Basic/Kernel/Objects/Basis.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Basis+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Common types and operations.+-- +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Basis+  (++    PrimResult++  , UConvert(..)++  , ignoreAns+  , replaceAns++  , Decorate(..)+  , decorateAbove+  , decorateBelow++  , elaborateAbove+  , elaborateBelow++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.WrappedPrimitive++import Wumpus.Core                              -- package: wumpus-core+++type PrimResult u a = (a, CatPrim)++++--------------------------------------------------------------------------------+++class UConvert (f :: * -> * -> *) where+  uconvF :: (Functor t, InterpretUnit u, InterpretUnit u1) +         => f u (t u) -> f u1 (t u1)++  uconvZ :: (InterpretUnit u, InterpretUnit u1) +         => f u a -> f u1 a+++--------------------------------------------------------------------------------++++-- | Note - the kind of f allows fo unit annotation.+--+ignoreAns :: Functor (f u) => f u a -> f u (UNil u)+ignoreAns = fmap (const UNil)++-- | Replace the answer produced by a graphic object.+--+replaceAns :: Functor (f u) => a -> f u z -> f u a+replaceAns a = fmap (const a)+++++-- | Decorate an object+--+-- oliterate - drops the graphic from the first object replacing +-- it with the graphic from the second.+--+class Decorate (f :: * -> * -> *) where+  -- | Should be read as @ decorate (above|below) A with B @+  decorate    :: ZOrder -> f u a -> f u z -> f u a+  elaborate   :: ZOrder -> 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+  svgId       :: String -> f u a -> f u a+  svgAnnotate :: [SvgAttr] -> f u a -> f u a++++-- | Decorate (ABOVE) a with b.+--+decorateAbove :: Decorate f => f u a -> f u z -> f u a+decorateAbove = decorate ZABOVE++-- | Decorate (BELOW) a with b.+--+decorateBelow :: Decorate f => f u a -> f u z -> f u a+decorateBelow = decorate ZBELOW++-- | Elaborate (ABOVE) a with b.+--+elaborateAbove :: Decorate f => f u a -> (a -> f u z) -> f u a+elaborateAbove = elaborate ZABOVE++-- | Elaborate (BELOW) a with b.+--+elaborateBelow :: Decorate f => f u a -> (a -> f u z) -> f u a+elaborateBelow = elaborate ZBELOW++++
src/Wumpus/Basic/Kernel/Objects/Bounded.hs view
@@ -3,17 +3,15 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.Bounded--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  highly unstable -- Portability :  GHC  ----- Bounded versions of Graphic and LocGraphic.------ Bounded meaning they are actually Images that return the --- bounding box of the Graphic.+-- Helpers for working with Images and LocImages that produce+-- bounding boxes. -- -------------------------------------------------------------------------------- @@ -21,67 +19,53 @@   (  -  -- * Bounded graphic / loc graphic+  -- * Type synonyms     BoundedGraphic-  , DBoundedGraphic   , BoundedLocGraphic-  , DBoundedLocGraphic   , BoundedLocThetaGraphic-  , DBoundedLocThetaGraphic +  -- * Bounding box graphic helpers+  , centerOrthoBBox++   , emptyBoundedLocGraphic+  , emptyBoundedLocThetaGraphic -  , centerOrthoBBox+   , illustrateBoundedGraphic   , illustrateBoundedLocGraphic   , illustrateBoundedLocThetaGraphic +  , bbrectangle++  , boundedRect+   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.UpdateDC-import Wumpus.Basic.Kernel.Objects.BaseObjects-import Wumpus.Basic.Kernel.Objects.Graphic+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage  import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Colour ( blue ) -import Control.Applicative+import Data.Monoid  -------------------------------------------------------------------------------- --- | Graphic with a bounding box.--- -type BoundedGraphic u      = Image u (BoundingBox u) -type DBoundedGraphic       = BoundedGraphic Double------- | LocGraphic with a bounding box.----type BoundedLocGraphic u      = LocImage u (BoundingBox u)--type DBoundedLocGraphic       = BoundedLocGraphic Double----- | LocThetaGraphic with a bounding box.------ Note the size of bounding box for the \"same\" shape will vary --- according to the rotation. A bounding box is always --- orthonormal (?) to the x- and y-axes.---+type BoundedGraphic u           = Image u (BoundingBox u)+type BoundedLocGraphic u        = LocImage u (BoundingBox u) type BoundedLocThetaGraphic u   = LocThetaImage u (BoundingBox u) -type DBoundedLocThetaGraphic    = BoundedLocThetaGraphic Double   ---- | 'openStroke' : @ theta * bbox -> BBox @+-- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ --  -- Rotate a bounding box by @theta@ about its center. Take the  -- new bounding box.@@ -90,51 +74,120 @@ -- so the dimensions as well as the positions may change under  -- rotation.  ---centerOrthoBBox :: (Real u, Floating u) ++centerOrthoBBox :: (Real u, Floating u, Ord u)                 => Radian -> BoundingBox u -> BoundingBox u-centerOrthoBBox theta bb = -    traceBoundary $ map (rotateAbout theta ctr) ps+centerOrthoBBox theta bb = traceBoundary $ map (rotateAbout theta ctr) ps   where-    ps  = boundaryCornerList bb     ctr = boundaryCenter bb+    ps  = boundaryCornerList bb  -emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u-emptyBoundedLocGraphic = intoLocImage fn  emptyLocGraphic-  where-    fn = promoteR1 $ \pt -> pure (BBox pt pt) +-- | Build an empty 'LocGraphic' returning a bounding box.+-- +-- The 'emptyBoundedLocGraphic' is treated as a /null primitive/ +-- by @Wumpus-Core@ and is not drawn, although it does generate+-- the minimum bounding box with both the bottom-left and +-- upper-right corners at the implicit start point.+--+emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u +emptyBoundedLocGraphic = promoteLoc $ \pt -> +    replaceAns (BBox pt pt) $ primGraphic mempty+++++-- | Build an empty 'LocThetaGraphic' returning a bounding box.+-- +-- The 'emptyBoundedLocThetaGraphic' is treated as a +-- /null primitive/  by @Wumpus-Core@ and is not drawn, although +-- it does generate the minimum bounding box with both the +-- bottom-left and upper-right corners at the implicit start point +--+emptyBoundedLocThetaGraphic :: InterpretUnit u +                            => BoundedLocThetaGraphic u+emptyBoundedLocThetaGraphic = promoteLocTheta $ \pt _ -> +    replaceAns (BBox pt pt) $ primGraphic mempty+++--+-- NOTE - CONCATENATION+--+-- Because there is no tangible relation between the start point +-- and answer BoundingBox, LocBoundedGraphic supports exactly the+-- same concatenation as LocImage.+--+-- PosImage and AdvGraphic are the objects that support more +-- sophisticated concatenation.+--+ ++ -------------------------------------------------------------------------------- --  --- This is a common pattern so needs a name... -illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u-illustrateBoundedGraphic mf = -    mf >>= \(bb,g1) -> bbrectangle bb >>= \(_,g0) -> return (bb, g0 `oplus` g1)+-- | Draw a BoundedGraphic, illustrating the bounding box.+--+illustrateBoundedGraphic :: InterpretUnit u+                         => Image u (BoundingBox u) -> Image u (BoundingBox u)+illustrateBoundedGraphic gf = elaborateBelow gf bbrectangle  -illustrateBoundedLocGraphic :: Fractional u -                            => BoundedLocGraphic u -> BoundedLocGraphic u-illustrateBoundedLocGraphic mf = -    promoteR1 $ \pt -> illustrateBoundedGraphic $ apply1R1 mf pt +-- | Draw a BoundedLocGraphic, illustrating the bounding box.+--+illustrateBoundedLocGraphic :: InterpretUnit u+                            => LocImage u (BoundingBox u) +                            -> LocImage u (BoundingBox u)+illustrateBoundedLocGraphic gf = elaborateBelow gf fn+  where+    fn bb = promoteLoc $ \_ -> bbrectangle bb -illustrateBoundedLocThetaGraphic :: Fractional u -    => BoundedLocThetaGraphic u -> BoundedLocThetaGraphic u-illustrateBoundedLocThetaGraphic mf = -    promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta   -bbrectangle :: Fractional u => BoundingBox u -> Graphic u+-- | Draw a BoundedLocThetaGraphic, illustrating the bounding box.+--+illustrateBoundedLocThetaGraphic :: InterpretUnit u+                                 => LocThetaImage u (BoundingBox u)+                                 -> LocThetaImage u (BoundingBox u)+illustrateBoundedLocThetaGraphic gf = elaborateBelow gf fn+  where+    fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb++++-- | Draw a bounding box as a stroked rectangle with +-- dotted lines.+--+bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury))-    | llx == urx && lly == ury = emptyLocGraphic `at` p1+    | llx == urx && lly == ury = mempty `at` p1     | otherwise                = -        localize drawing_props $ rect1 `oplus` cross+        localize drawing_props $ rect1 `mappend` cross   where-    drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)])-    rect1         = strokedRectangle (urx-llx) (ury-lly) `at` p1-    cross         = straightLineBetween p1 p2 -                      `oplus` straightLineBetween (P2 llx ury) (P2 urx lly)+    drawing_props = cap_round . dotted_line+    rect1         = dcRectangle DRAW_STROKE (urx-llx) (ury-lly) `at` p1+    cross         = straightLine p1 p2 +                      `mappend` straightLine (P2 llx ury) (P2 urx lly) +++-- | 'boundedRect' : @ style * width * height -> LocGraphic @+--+-- Create a stroked rectangle - the implicit start point is +-- /bottom-left/, return the bounding box of the rectangle as the +-- answer.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +boundedRect :: InterpretUnit u +            => DrawMode -> u -> u -> BoundedLocGraphic u +boundedRect style w h = promoteLoc $ \pt@(P2 x y) -> +    let bb = BBox pt (P2 (x + w) (y + h))+    in replaceAns bb $ applyLoc (dcRectangle style w h) pt++
+ src/Wumpus/Basic/Kernel/Objects/Concat.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Concat+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Classes for concatenation.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Concat+  (++    ZConcat(..)+  , cat+  , Concat(..)+  , hcat+  , vcat++  , CatSpace(..)+  , hsep+  , vsep++  , Align(..)+  , alignRow+  , alignColumn++  , AlignSpace(..)+  , alignRowSep+  , alignColumnSep+  +  +  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs++import Wumpus.Core                              -- package: wumpus-core++import Data.Monoid++infixr 6 `superior`, `anterior`++-- | Minimal defintion is 'superior', 'anterior' is usually +-- @flip superior@.+--+-- > `superior` (infixr 6)+--+-- > `anterior` (infixr 6)+-- +-- +class ZConcat o where+  anterior :: o -> o -> o +  superior :: o -> o -> o++  anterior = flip superior+++cat :: (Monoid o, ZConcat o) => [o] -> o+cat [] = mempty+cat (x:xs) = go x xs+  where+    go acc []     = acc+    go acc (a:as) = go (acc `superior` a) as+  +++infixr 6 `hconcat`+infixr 5 `vconcat`+++-- | Concatenation with /movement/ - the second object is moved+-- next to the first.+--+-- > hconcat is equivalent to @(<>)@ in WL-PPrint.+-- > (infixr 6)+-- +-- > vconcat is equivalent to @(<$>)@ in WL_PPrint.+-- > (infixr 5)+--+class Concat o where+  hconcat :: o -> o -> o+  vconcat :: o -> o -> o++-- | Horizontally concatenate a list of objects.+-- +-- Note - the first argument is an /alternative/ - this is drawn +-- if the list is empty, otherwise it is not drawn.+--+hcat :: (Monoid o, Concat o) => [o] -> o+hcat []     = mempty+hcat (x:xs) = go x xs+  where+    go acc []     = acc+    go acc (a:as) = go (acc `hconcat` a) as+  ++-- | Vertically concatenate a list of objects.+-- +-- Note - the first argument is an /alternative/ - this is drawn +-- if the list is empty, otherwise it is not drawn.+--+vcat :: (Monoid o, Concat o) => [o] -> o+vcat []     = mempty+vcat (x:xs) = go x xs+  where+    go acc []     = acc+    go acc (a:as) = go (acc `vconcat` a) as+  ++class CatSpace o where+   hspace :: u ~ DUnit o => u -> o -> o -> o+   vspace :: u ~ DUnit o => u -> o -> o -> o++hsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o+hsep _  []     = mempty+hsep dx (x:xs) = go x xs+  where+    op            = hspace dx+    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as+  ++vsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o+vsep _  []     = mempty+vsep dx (x:xs) = go x xs+  where+    op            = vspace dx+    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as+++class Align o where+  halign :: HAlign -> o -> o -> o +  valign :: VAlign -> o -> o -> o+++alignRow :: (Monoid o, Align o) => HAlign -> [o] -> o+alignRow _ []     = mempty+alignRow ha (x:xs) = go x xs+  where+    op            = halign ha +    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as+++alignColumn :: (Monoid o, Align o) => VAlign -> [o] -> o+alignColumn _ []     = mempty+alignColumn va (x:xs) = go x xs+  where+    op            = valign va +    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as++++class AlignSpace o where+  halignSpace :: u ~ DUnit o => HAlign -> u -> o -> o -> o +  valignSpace :: u ~ DUnit o => VAlign -> u -> o -> o -> o++++alignRowSep :: (Monoid o, AlignSpace o, u ~ DUnit o) +            => HAlign -> u -> [o] -> o+alignRowSep _  _  []     = mempty+alignRowSep ha dx (x:xs) = go x xs+  where+    op            = halignSpace ha dx+    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as+++alignColumnSep :: (Monoid o, AlignSpace o, u ~ DUnit o) +            => VAlign -> u -> [o] -> o+alignColumnSep _  _  []     = mempty+alignColumnSep va dx (x:xs) = go x xs+  where+    op            = valignSpace va dx+    go acc []     = acc+    go acc (a:as) = go (acc `op` a) as++
src/Wumpus/Basic/Kernel/Objects/Connector.hs view
@@ -1,74 +1,295 @@ {-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-} {-# OPTIONS -Wall #-}  -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.Connector--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2011 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  highly unstable -- Portability :  GHC  ----- Graphic and Image types representing connectors - connectors--- have two implicit points - start and end.+-- ConnImage and ConnGraphic types - these are functional types+-- from the DrawingContext plus start point and end point to a +-- graphic /primitive/. -- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Objects.Connector-  (+   (+     ConnectorImage+   , ConnectorGraphic -  -- * Connector Graphic-    ConnectorGraphic-  , DConnectorGraphic+   , DConnectorImage+   , DConnectorGraphic +   , ConnectorQuery -  -- * Connector Image-  , ConnectorImage-  , DConnectorImage+   , runConnectorImage+   , runConnectorQuery+   , connect +   , stripConnectorImage+   , liftConnectorQuery +   , promoteConn+   , applyConn -  ) where+   , qpromoteConn+   , qapplyConn -import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Objects.BaseObjects+   , emptyConnectorImage --- import Wumpus.Core                              -- package: wumpus-core+   ) +   where ------------------------------------------------------------------------------------ Connector Graphic+import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Core                              -- package: wumpus-core --- | ConnectorGraphic is a connector drawn between two points --- contructing a Graphic.+import Control.Applicative+import Data.Monoid+++-- | ConnectorImage - function from DrawingContext and start and +-- end points to a polymorphic /answer/ and a graphic /primitive/. ---type ConnectorGraphic u         = ConnectorCF u (GraphicAns u)+newtype ConnectorImage u a = ConnectorImage { +          getConnectorImage :: DPoint2 -> DPoint2 -> Image u a }  -type DConnectorGraphic          = ConnectorGraphic Double+type instance DUnit (ConnectorImage u a) = u   +type ConnectorGraphic u = ConnectorImage u (UNil u) +-- | Type specialized version of 'ConnectorImage'.+--+type DConnectorImage a        = ConnectorImage Double a++-- | Type specialized version of 'ConnectorGraphic'.+--+type DConnectorGraphic        = ConnectorGraphic Double +++newtype ConnectorQuery u a = ConnectorQuery { +          getConnectorQuery :: DPoint2 -> DPoint2 -> Query u a }+++-- Functor ++instance Functor (ConnectorImage u) where+  fmap f ma = ConnectorImage $ \p0 p1 -> fmap f $ getConnectorImage ma p0 p1++instance Functor (ConnectorQuery u) where+  fmap f ma = ConnectorQuery $ \p0 p1 -> fmap f $ getConnectorQuery ma p0 p1+++-- Applicative++instance Applicative (ConnectorImage u) where+  pure a    = ConnectorImage $ \_  _  -> pure a+  mf <*> ma = ConnectorImage $ \p0 p1 -> +                getConnectorImage mf p0 p1 <*> getConnectorImage ma p0 p1++instance Applicative (ConnectorQuery u) where+  pure a    = ConnectorQuery $ \_  _  -> pure a+  mf <*> ma = ConnectorQuery $ \p0 p1 -> +                getConnectorQuery mf p0 p1 <*> getConnectorQuery ma p0 p1+++-- Monad ++instance Monad (ConnectorImage u) where+  return a  = ConnectorImage $ \_  _  -> return a+  ma >>= k  = ConnectorImage $ \p0 p1 -> +                getConnectorImage ma p0 p1 >>= \ans -> +                getConnectorImage (k ans) p0 p1+++instance Monad (ConnectorQuery u) where+  return a  = ConnectorQuery $ \_  _  -> return a+  ma >>= k  = ConnectorQuery $ \p0 p1 -> +                getConnectorQuery ma p0 p1 >>= \ans -> +                getConnectorQuery (k ans) p0 p1+++-- Monoid++instance Monoid a => Monoid (ConnectorImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = ConnectorImage $ \p0 p1 -> +                      getConnectorImage ma p0 p1 +                        `mappend` getConnectorImage mb p0 p1 +++instance Monoid a => Monoid (ConnectorQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = ConnectorQuery $ \p0 p1 -> +                      getConnectorQuery ma p0 p1 +                        `mappend` getConnectorQuery mb p0 p1 ++++-- DrawingCtxM++instance DrawingCtxM (ConnectorImage u) where+  askDC           = ConnectorImage $ \_  _  -> askDC+  asksDC fn       = ConnectorImage $ \_  _  -> asksDC fn+  localize upd ma = ConnectorImage $ \p0 p1 -> +                      localize upd (getConnectorImage ma p0 p1)++instance DrawingCtxM (ConnectorQuery u) where+  askDC           = ConnectorQuery $ \_  _  -> askDC+  asksDC fn       = ConnectorQuery $ \_  _  -> asksDC fn+  localize upd ma = ConnectorQuery $ \p0 p1 -> +                      localize upd (getConnectorQuery ma p0 p1)+++  +++instance Decorate ConnectorImage where+  decorate zo ma mz     = ConnectorImage $ \p0 p1 -> +    decorate zo (getConnectorImage ma p0 p1) (getConnectorImage mz p0 p1)++  elaborate zo ma f     = ConnectorImage $ \p0 p1 -> +    elaborate zo (getConnectorImage ma p0 p1) +                 (\a -> getConnectorImage (f a) p0 p1)++  obliterate ma         = ConnectorImage $ \p0 p1 -> +    obliterate $ getConnectorImage ma p0 p1++  hyperlink xl ma       = ConnectorImage $ \p0 p1 -> +    hyperlink xl $ getConnectorImage ma p0 p1++  svgId ss ma           = ConnectorImage $ \p0 p1 -> +    svgId ss $ getConnectorImage ma p0 p1++  svgAnnotate attrs ma  = ConnectorImage $ \p0 p1 -> +    svgAnnotate attrs $ getConnectorImage ma p0 p1+++++runConnectorImage :: InterpretUnit u +                  => DrawingContext -> Point2 u -> Point2 u+                  -> ConnectorImage u a+                  -> PrimResult u a+runConnectorImage ctx p0 p1 ma = +    let dp0 = normalizeF (dc_font_size ctx) p0+        dp1 = normalizeF (dc_font_size ctx) p1 +    in runImage ctx $ getConnectorImage ma dp0 dp1+++runConnectorQuery :: InterpretUnit u +                  => DrawingContext -> Point2 u -> Point2 u +                  -> ConnectorQuery u a+                  -> a+runConnectorQuery ctx p0 p1 ma = +    let dp0 = normalizeF (dc_font_size ctx) p0+        dp1 = normalizeF (dc_font_size ctx) p1 +    in runQuery ctx $ getConnectorQuery ma dp0 dp1+++connect :: InterpretUnit u +        => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a+connect ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> +                   normalizeCtxF p1 >>= \dp1 -> +                   getConnectorImage ma dp0 dp1+++stripConnectorImage :: ConnectorImage u a -> ConnectorQuery u a+stripConnectorImage ma = ConnectorQuery $ \p1 p2 -> +    stripImage $ getConnectorImage ma p1 p2+++liftConnectorQuery :: ConnectorQuery u a -> ConnectorImage u a+liftConnectorQuery ma = ConnectorImage $ \p1 p2 -> +    liftQuery $ getConnectorQuery ma p1 p2+++promoteConn :: InterpretUnit u +            => (Point2 u -> Point2 u -> Image u a) -> ConnectorImage u a+promoteConn k = ConnectorImage $ \p0 p1 ->+    dinterpCtxF p0 >>= \up0 -> +    dinterpCtxF p1 >>= \up1 -> +    k up0 up1++applyConn :: InterpretUnit u +          => ConnectorImage u a -> Point2 u -> Point2 u -> Image u a+applyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> +                     normalizeCtxF p1 >>= \dp1 -> +                     getConnectorImage ma dp0 dp1+++++qpromoteConn :: InterpretUnit u +             => (Point2 u -> Point2 u -> Query u a) -> ConnectorQuery u a+qpromoteConn k = ConnectorQuery $ \p0 p1 ->+    dinterpCtxF p0 >>= \up0 -> +    dinterpCtxF p1 >>= \up1 -> +    k up0 up1++qapplyConn :: InterpretUnit u+           => ConnectorQuery u a -> Point2 u -> Point2 u -> Query u a+qapplyConn ma p0 p1 = normalizeCtxF p0 >>= \dp0 -> +                      normalizeCtxF p1 >>= \dp1 -> +                      getConnectorQuery ma dp0 dp1++ ----------------------------------------------------------------------------------- Connector Image+-- UConvert instance +instance UConvert ConnectorImage where+  uconvF = uconvConnectorImageF+  uconvZ = uconvConnectorImageZ --- | ConnectorImage is a connector drawn between two points --- constructing an Image.++-- | Use this to convert 'ConnectorGraphic' or 'ConnectorImage' +-- with Functor answer. ----- Usually the answer type of a ConnectorImage will be a Path so--- the Points ar @midway@, @atstart@ etc. can be taken on it.+uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) +                     => ConnectorImage u (t u) -> ConnectorImage u1 (t u1)+uconvConnectorImageF ma = ConnectorImage $ \p0 p1 -> +    uconvF $ getConnectorImage ma p0 p1+++++-- | Use this to convert 'ConnectorImage' with unit-less answer. ---type ConnectorImage u a = ConnectorCF u (ImageAns u a)+uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1) +                     => ConnectorImage u a -> ConnectorImage u1 a+uconvConnectorImageZ ma = ConnectorImage $ \p0 p1 -> +    uconvZ $ getConnectorImage ma p0 p1 +-- | Having /empty/ at the specific 'ConnectorImage' type is useful.+-- +emptyConnectorImage :: Monoid a => ConnectorImage u a+emptyConnectorImage = mempty -type DConnectorImage a  = ConnectorImage Double a +--------------------------------------------------------------------------------  ++--+-- Design note - potentially there are no useful combining +-- operators on Connectors (!).+--+-- Division - i.e. splitting a path at points between the start +-- and end - seems a more obvious operation on connector paths +-- than combination. See the ConnectorPath operations in +-- Wumpus-Drawing for some examples.+--
− src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs 
@@ -1,563 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.CtxPicture--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ A Picture-with-implicit-context object. --- --- This is the corresponding type to Picture in the Wumpus-Core.--- --- CtxPicture is a function from the DrawingContext to a Picture.--- Internally the result is actually a (Maybe Picture) and not a --- Picture, this is a trick to promote the extraction from --- possibly empty drawings (created by TraceDrawing) to the --- top-level of the type hierarchy where client code can deal --- with empty drawings explicitly (empty Pictures cannot be --- rendered by Wumpus-Core).--- -----------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.CtxPicture-  (--    CtxPicture-  , DCtxPicture-  , runCtxPicture-  , runCtxPictureU-  , drawTracing--  , clipCtxPicture-  , mapCtxPicture--  -- * Composition-  , over -  , under--  , centric-  , nextToH-  , nextToV-  -  , atPoint -  , centeredAt--  , zconcat--  , hcat -  , vcat---  , hspace-  , vspace-  , hsep-  , vsep- -  -- * Compose with alignment-  , alignH-  , alignV-  , alignHSep-  , alignVSep-  , hcatA-  , vcatA-  , hsepA-  , vsepA---  ) where--import Wumpus.Basic.Kernel.Base.Anchors-import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Objects.TraceDrawing--import Wumpus.Core                              -- package: wumpus-core--import Data.AdditiveGroup                       -- package: vector-space-import Data.AffineSpace--import Control.Applicative-import Data.List ( foldl' )----newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) }--type DCtxPicture = CtxPicture Double---type instance DUnit (CtxPicture u) = u-----runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u)-runCtxPicture ctx drw = runCF ctx (getCtxPicture drw)  ---runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u-runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df-  where-    fk = error "runCtxPictureU - empty CtxPicture."   ----drawTracing :: (Real u, Floating u, FromPtSize u) -            => TraceDrawing u a -> CtxPicture u-drawTracing mf = CtxPicture $ -    drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) )----- Note - cannot get an answer from a TraceDrawing with this --- CtxPicture type. There is nowhere to put the answer in the type.------ If the type was extended:------ > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) }------ It would make things difficult for the drawing composition --- operators. @a@ could be monoidial but are there any types of --- a where this would be useful (rather than just making things --- more complicated)? --------------------------------------------------------------------------------------clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u-clipCtxPicture cpath = mapCtxPicture (clip cpath)---mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u-mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture--instance (Real u, Floating u) => Rotate (CtxPicture u) where -  rotate ang = mapCtxPicture (rotate ang)--instance (Real u, Floating u) => RotateAbout (CtxPicture u) where-  rotateAbout r pt = mapCtxPicture (rotateAbout r pt)--instance (Num u, Ord u) => Scale (CtxPicture u) where-  scale sx sy = mapCtxPicture (scale sx sy)--instance (Num u, Ord u) => Translate (CtxPicture u) where-  translate dx dy = mapCtxPicture (translate dx dy)-------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Extract anchors--boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a-boundaryExtr f = f . boundary---- Operations on bounds---- | The center of a picture.----boundaryCtr :: Fractional u => Picture u -> Point2 u-boundaryCtr = boundaryExtr center------ | Extract the mid point of the top edge.----boundaryN :: Fractional u => Picture u -> Point2 u-boundaryN = boundaryExtr north---- | Extract the mid point of the bottom edge.----boundaryS :: Fractional u => Picture u -> Point2 u-boundaryS = boundaryExtr south---- | Extract the mid point of the left edge.----boundaryE :: Fractional u => Picture u -> Point2 u-boundaryE = boundaryExtr east---- | Extract the mid point of the right edge.----boundaryW :: Fractional u => Picture u -> Point2 u-boundaryW = boundaryExtr west----- | Extract the top-left corner.----boundaryNW :: Fractional u => Picture u -> Point2 u-boundaryNW = boundaryExtr northwest---- | Extract the top-right corner.----boundaryNE :: Picture u -> Point2 u-boundaryNE = boundaryExtr ur_corner---- | Extract the bottom-left corner.----boundarySW :: Picture u -> Point2 u-boundarySW = boundaryExtr ll_corner---- | Extract the bottom-right corner.----boundarySE :: Fractional u => Picture u -> Point2 u-boundarySE = boundaryExtr southeast---boundaryLeftEdge :: Picture u -> u-boundaryLeftEdge = boundaryExtr (point_x . ll_corner)--boundaryRightEdge :: Picture u -> u-boundaryRightEdge = boundaryExtr (point_x . ur_corner)--boundaryBottomEdge :: Picture u -> u-boundaryBottomEdge = boundaryExtr (point_y . ll_corner)---boundaryTopEdge :: Picture u -> u-boundaryTopEdge = boundaryExtr (point_y . ur_corner)-----  --- Note - do not export the empty drawing. It is easier to --- pretend it doesn't exist.--- -empty_drawing :: (Real u, Floating u, FromPtSize u) => CtxPicture u-empty_drawing = drawTracing $ return ()---------------------------------------------------------------------------------------- Composition operators---drawingConcat :: (Picture u -> Picture u -> Picture u) -              -> CtxPicture u -> CtxPicture u -> CtxPicture u-drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b)----mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a)-mbpostcomb op = liftA2 fn -  where-    fn (Just a) (Just b) = Just $ a `op` b-    fn a        Nothing  = a-    fn Nothing  b        = b----- Note - the megaCombR operator is in some way an--- /anti-combinator/. It seems easier to think about composing --- drawings if we do work on the result Pictures directly rather --- than build combinators to manipulate CtxPictures.------ The idea of combining pre- and post- operating combinators--- makes me worry about circular programs even though I know --- lazy evaluation allows me to write them (in some cicumstances).-------- Picture /mega-combiner/ - moves only the second argument aka the --- right picture.----megaCombR :: (Num u, Ord u)-          => (Picture u -> a) -> (Picture u -> a) -          -> (a -> a -> Picture u -> Picture u) -          -> CtxPicture u -> CtxPicture u-          -> CtxPicture u-megaCombR qL qR trafoR = drawingConcat fn-  where-    fn pic1 pic2 = let a    = qL pic1-                       b    = qR pic2-                       p2   = trafoR a b pic2-                   in pic1 `picOver` p2------- | > a `over` b--- --- Place \'drawing\' a over b. The idea of @over@ here is in --- terms z-ordering, nither picture a or b are actually moved.----over    :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-over    = drawingConcat picOver------ | > a `under` b------ Similarly @under@ draws the first drawing behind --- the second but move neither.----under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-under = flip over------ | Move in both the horizontal and vertical.----move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u-move v = mapCtxPicture (\p -> p `picMoveBy` v)---------------------------------------------------------------------------------------- Composition--infixr 5 `nextToV`-infixr 6 `nextToH`, `centric`------- | Draw @a@, move @b@ so its center is at the same center as --- @a@, @b@ is drawn over underneath in the zorder.------ > a `centeric` b -------centric :: (Fractional u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-centric = megaCombR boundaryCtr boundaryCtr moveFun-  where-    moveFun p1 p2 pic =  let v = p1 .-. p2 in pic `picMoveBy` v------ | > a `nextToH` b--- --- Horizontal composition - move @b@, placing it to the right --- of @a@.--- -nextToH :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun-  where -    moveFun a b pic = pic `picMoveBy` hvec (a - b)------ | > a `nextToV` b------ Vertical composition - move @b@, placing it below @a@.----nextToV :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u-nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun-  where -    moveFun a b drw = drw `picMoveBy` vvec (a - b)----- | Place the picture at the supplied point.------ `atPoint` was previous the `at` operator.--- -atPoint :: (Num u, Ord u) => CtxPicture u -> Point2 u  -> CtxPicture u-p `atPoint` (P2 x y) = move (V2 x y) p------ | Center the picture at the supplied point.----centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u-centeredAt d (P2 x y) = mapCtxPicture fn d-  where-    fn p = let bb = boundary p-               dx = x - (boundaryWidth  bb * 0.5)-               dy = y - (boundaryHeight bb * 0.5)-           in p `picMoveBy` vec dx dy----- | Concatenate the list of drawings. ------ No pictures are moved. ----zconcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-zconcat []     = empty_drawing-zconcat (d:ds) = foldl' over d ds------- | Concatenate the list pictures @xs@ horizontally.--- -hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-hcat []     = empty_drawing-hcat (d:ds) = foldl' nextToH d ds----- | Concatenate the list of pictures @xs@ vertically.----vcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture u-vcat []     = empty_drawing-vcat (d:ds) = foldl' nextToV d ds-------------------------------------------------------------------------------------------- | > hspace n a b------ Horizontal composition - move @b@, placing it to the right --- of @a@ with a horizontal gap of @n@ separating the pictures.----hspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u-hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun-  where-    moveFun a b pic = pic `picMoveBy` hvec (n + a - b)--    ------ | > vspace n a b------ Vertical composition - move @b@, placing it below @a@ with a--- vertical gap of @n@ separating the pictures.----vspace :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u-vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun-  where -    moveFun a b pic = pic `picMoveBy`  vvec (a - b - n)------ | > hsep n xs------ Concatenate the list of pictures @xs@ horizontally with --- @hspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units.----hsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u-hsep _ []     = empty_drawing-hsep n (d:ds) = foldl' (hspace n) d ds------ | > vsep n xs------ Concatenate the list of pictures @xs@ vertically with --- @vspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units.----vsep :: (Real u, Floating u, FromPtSize u) => u -> [CtxPicture u] -> CtxPicture u-vsep _ []     = empty_drawing-vsep n (d:ds) = foldl' (vspace n) d ds-------------------------------------------------------------------------------------- Aligning pictures--alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u-alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2)------ | > alignH align a b--- --- Horizontal composition - move @b@, placing it to the right --- of @a@ and align it with the top, center or bottom of @a@.--- -alignH :: (Fractional u, Ord u) -       =>  HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignH HTop     = megaCombR boundaryNE    boundaryNW     alignMove-alignH HCenter  = megaCombR boundaryE    boundaryW     alignMove-alignH HBottom  = megaCombR boundarySE boundarySW  alignMove----- | > alignV align a b--- --- Vertical composition - move @b@, placing it below @a@ --- and align it with the left, center or right of @a@.--- -alignV :: (Fractional u, Ord u) -       => VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignV VLeft    = megaCombR boundarySW  boundaryNW   alignMove-alignV VCenter  = megaCombR boundaryS   boundaryN    alignMove-alignV VRight   = megaCombR boundarySE boundaryNE  alignMove----alignMove2 :: (Num u, Ord u) -           => Vec2 u ->  Point2 u -> Point2 u -> Picture u -> Picture u-alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2))------ | > alignHSep align sep a b--- --- Spacing version of alignH - move @b@ to the right of @a@ --- separated by @sep@ units, align @b@ according to @align@.--- -alignHSep :: (Fractional u, Ord u) -          => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignHSep HTop    dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx))-alignHSep HCenter dx = megaCombR boundaryE  boundaryW  (alignMove2 (hvec dx))-alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx))----- | > alignVSep align sep a b--- --- Spacing version of alignV - move @b@ below @a@ --- separated by @sep@ units, align @b@ according to @align@.--- -alignVSep :: (Fractional u, Ord u) -          => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u-alignVSep VLeft   dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) -alignVSep VCenter dy = megaCombR boundaryS  boundaryN  (alignMove2 $ vvec (-dy)) -alignVSep VRight  dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy))----- | Variant of 'hcat' that aligns the pictures as well as--- concatenating them.----hcatA :: (Real u, Floating u, FromPtSize u) -      => HAlign -> [CtxPicture u] -> CtxPicture u-hcatA _  []     = empty_drawing-hcatA ha (d:ds) = foldl' (alignH ha) d ds------ | Variant of 'vcat' that aligns the pictures as well as--- concatenating them.----vcatA :: (Real u, Floating u, FromPtSize u) -      => VAlign -> [CtxPicture u] -> CtxPicture u-vcatA _  []     = empty_drawing-vcatA va (d:ds) = foldl' (alignV va) d ds----- | Variant of @hsep@ that aligns the pictures as well as--- concatenating and spacing them.----hsepA :: (Real u, Floating u, FromPtSize u) -      => HAlign -> u -> [CtxPicture u] -> CtxPicture u-hsepA _  _ []     = empty_drawing-hsepA ha n (d:ds) = foldl' op d ds-  where -    a `op` b = alignHSep ha n a b ----- | Variant of @vsep@ that aligns the pictures as well as--- concatenating and spacing them.----vsepA :: (Real u, Floating u, FromPtSize u) -      => VAlign -> u -> [CtxPicture u] -> CtxPicture u-vsepA _  _ []     = empty_drawing-vsepA va n (d:ds) = foldl' op d ds-  where -    a `op` b = alignVSep va n a b ---
+ src/Wumpus/Basic/Kernel/Objects/Displacement.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Displacement+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Displacing points - often start points. +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Displacement+  (+++  -- * Displacement+    PointDisplace+  , ThetaPointDisplace+  , displace++  , dispParallel+  , dispPerpendicular+  , dispOrtho++  , dispDirectionTheta+  , dispCardinalTheta++  -- * Named vector constructors++  , go_up+  , go_down+  , go_left+  , go_right++  , go_north+  , go_south+  , go_east+  , go_west+  , go_north_east+  , go_north_west+  , go_south_east+  , go_south_west+  +  , go_up_left+  , go_up_right+  , go_down_left+  , go_down_right++  , theta_up+  , theta_down+  , theta_left+  , theta_right++  , theta_north+  , theta_south+  , theta_east+  , theta_west+  , theta_north_east+  , theta_north_west+  , theta_south_east+  , theta_south_west++  , theta_up_left+  , theta_up_right+  , theta_down_left+  , theta_down_right++  , theta_adj_grazing+  , theta_bkwd_adj_grazing+++  ) where+++import Wumpus.Basic.Kernel.Base.BaseDefs++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+++++-- | 'PointDisplace' is a type representing functions +-- @from Point to Point@.+--+-- It is especially useful for building composite graphics where +-- one part of the graphic is drawn from a different start point +-- to the other part.+--+type PointDisplace u = Point2 u -> Point2 u+++++-- | 'ThetaPointDisplace' is a type representing functions +-- @from Radian * Point to Point@.+--+-- It is useful for building arrowheads which are constructed +-- with an implicit angle representing the direction of the line +-- at the arrow tip.+--+type ThetaPointDisplace u = Radian -> Point2 u -> Point2 u++++-- | 'displace' : @ Vec2 -> PointDisplace @+--+-- Alias for @.+^@ from @Data.AffineSpace@.+--+displace :: Num u => Vec2 u -> PointDisplace u+displace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)+++++++++--------------------------------------------------------------------------------+-- ThetaPointDisplace functions+++-- | 'dispParallel' : @ dist -> ThetaPointDisplace @+-- +-- Build a combinator to move @Points@ in parallel to the +-- direction of the implicit angle by the supplied distance +-- @dist@. +--+dispParallel :: Floating u => u -> ThetaPointDisplace u+dispParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d+++-- | 'dispParallel' : @ dist -> ThetaPointDisplace @+-- +-- Build a combinator to move @Points@ perpendicular to the +-- inclnation of the implicit angle by the supplied distance +-- @dist@. +--+dispPerpendicular :: Floating u => u -> ThetaPointDisplace u+dispPerpendicular d = +    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d++++-- | 'dispOrtho' : @ vec -> ThetaPointDisplace @+-- +-- This is a combination of @displaceParallel@ and +-- @displacePerpendicular@, with the x component of the vector+-- displaced in parallel and the y component displaced+-- perpendicular. +-- +dispOrtho :: Floating u => u -> u -> ThetaPointDisplace u+dispOrtho x y = \theta -> dispParallel x theta . dispPerpendicular y theta+++++-- | /Angular/ version of 'dispDirection'. +--+-- The displacement direction is with respect to implicit angle+-- of inclination, so:+--+-- > up    == perpendicular+-- > down  == perdendicular . negate+-- > left  == parallel . negate+-- > right == parallel+-- +dispDirectionTheta :: Floating u => Direction -> u -> ThetaPointDisplace u+dispDirectionTheta UP      = dispPerpendicular+dispDirectionTheta DOWN    = dispPerpendicular . negate+dispDirectionTheta LEFT    = dispParallel . negate+dispDirectionTheta RIGHT   = dispParallel+++-- | /Angular/ version of 'dispCardinal'.+--+-- The displacement direction is with respect to implicit angle+-- of inclination, so:+--+-- > north == perpendicular+-- > east  == parallel+-- > south == perdendicular . negate+-- > etc.+-- +dispCardinalTheta :: Floating u => Cardinal -> u -> ThetaPointDisplace u+dispCardinalTheta NORTH      = dispPerpendicular+dispCardinalTheta NORTH_EAST = \d ang -> displace (avec (ang + (0.25*pi)) d)+dispCardinalTheta EAST       = dispParallel+dispCardinalTheta SOUTH_EAST = \d ang -> displace (avec (ang + (1.75*pi)) d)+dispCardinalTheta SOUTH      = dispPerpendicular . negate+dispCardinalTheta SOUTH_WEST = \d ang -> displace (avec (ang + (1.25*pi)) d)+dispCardinalTheta WEST       = dispParallel . negate+dispCardinalTheta NORTH_WEST = \d ang -> displace (avec (ang + (0.75*pi)) d)+++--------------------------------------------------------------------------------+-- Named vectors+++go_up :: Num u => u -> Vec2 u+go_up d = V2 0 d++go_down :: Num u => u -> Vec2 u+go_down d = V2 0 (-d)++go_left :: Num u => u -> Vec2 u+go_left d = V2 (-d) 0++go_right :: Num u => u -> Vec2 u+go_right d = V2 d 0+++go_north :: Num u => u -> Vec2 u+go_north = go_up++go_south :: Num u => u -> Vec2 u+go_south = go_down++go_east :: Num u => u -> Vec2 u+go_east = go_right++go_west :: Num u => u -> Vec2 u+go_west = go_left+++go_north_east :: Floating u => u -> Vec2 u+go_north_east = avec (0.25*pi)++go_north_west :: Floating u => u -> Vec2 u+go_north_west = avec (0.75*pi)++go_south_east :: Floating u => u -> Vec2 u+go_south_east = avec (1.75*pi)++go_south_west :: Floating u => u -> Vec2 u+go_south_west = avec (1.25*pi)+++go_up_left :: Num u => u -> Vec2 u+go_up_left d = V2 (-d) d++go_up_right :: Num u => u -> Vec2 u+go_up_right d = V2 d d++go_down_left :: Num u => u -> Vec2 u+go_down_left d = V2 (-d) (-d)++go_down_right :: Num u => u -> Vec2 u+go_down_right d = V2 d (-d)+++--------------------------------------------------------------------------------++++theta_up :: Floating u => u -> Radian -> Vec2 u+theta_up d ang = avec (ang + half_pi) d++theta_down :: Floating u => u -> Radian -> Vec2 u+theta_down d ang = avec (ang - half_pi) d+++-- | Parallel (reverse)+--+theta_left :: Floating u => u -> Radian -> Vec2 u+theta_left d ang = avec (ang + pi) d++-- | Parallel (forward)+--+theta_right :: Floating u => u -> Radian -> Vec2 u+theta_right d ang = avec ang d++++theta_north :: Floating u => u -> Radian -> Vec2 u+theta_north = theta_up++theta_south :: Floating u => u -> Radian -> Vec2 u+theta_south = theta_down++theta_east :: Floating u => u -> Radian -> Vec2 u+theta_east = theta_right++theta_west :: Floating u => u -> Radian -> Vec2 u+theta_west = theta_left+++theta_north_east :: Floating u => u -> Radian -> Vec2 u+theta_north_east d ang = avec (ang + quarter_pi) d++theta_north_west :: Floating u => u -> Radian -> Vec2 u+theta_north_west d ang = avec (ang + 0.75*pi) d++theta_south_east :: Floating u => u -> Radian -> Vec2 u+theta_south_east d ang = avec (ang - quarter_pi) d++theta_south_west :: Floating u => u -> Radian -> Vec2 u+theta_south_west d ang = avec (ang + 1.25*pi) d++++theta_up_left :: Floating u => u -> Radian -> Vec2 u+theta_up_left d = orthoVec (-d) d++theta_up_right :: Floating u => u -> Radian -> Vec2 u+theta_up_right d = orthoVec d d++theta_down_left :: Floating u => u -> Radian -> Vec2 u+theta_down_left d = orthoVec (-d) (-d)++theta_down_right :: Floating u => u -> Radian -> Vec2 u+theta_down_right d = orthoVec d (-d)+++++-- | Return @a-o@ when supplied length of @b-o@ and the grazing +-- angle @boa@:+--+-- >    a+-- >    .\+-- >    . \+-- >  ..b..o+--+-- This is useful for building arrowhead vectors.+--+theta_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u +theta_adj_grazing adj_len ang theta = orthoVec adj_len (-opp) theta+  where+    opp = adj_len * (fromRadian $ tan ang)+++-- | Return @o-c@ when supplied length of @b-o@ and the grazing +-- angle @boc@:+--+--+-- >  ..b..o+-- >    . /+-- >    ./+-- >    c+--+-- This is useful for building arrowhead vectors.+--+theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u +theta_bkwd_adj_grazing adj_len ang theta = orthoVec (-adj_len) (-opp) theta+  where+    opp = adj_len * (fromRadian $ tan ang)++
+ src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs view
@@ -0,0 +1,614 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.DrawingPrimitives+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Primitive drawings - text, paths, lines, rectangles, disks, +-- ellipses...+--+-- All the primitives take their drawing properties (colour, line +-- width, etc.) from the DrawingContext.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.DrawingPrimitives+  (+++  -- * Prim Paths+    locPP++  , emptyLocPP+  , vertexPP+  , curvePP+++  , dcPath+  , dcOpenPath+  , dcClosedPath++  -- * Text+  , dcTextlabel+  , dcRTextlabel+  , dcEscapedlabel+  , dcREscapedlabel++  , hkernLine+  , vkernLine++  -- * Lines+  , straightLine+  , locStraightLine+  , curvedLine+  , straightConnector++  -- * Circles+  , dcCircle++  -- * Ellipses+  , dcEllipse+  , dcREllipse+++  -- * Rectangles+  , dcRectangle++  -- * Disks  +  , dcDisk+  , dcEllipseDisk++  -- * Arc+  , dcArc+++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Objects.Connector+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.LocThetaImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++-- Helpers+++textPrim :: (RGBi -> FontAttr -> Primitive) -> Graphic u+textPrim fn = +    textAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)+    +++strokePrim :: (RGBi -> StrokeAttr -> Primitive) -> Graphic u+strokePrim fn = +    strokeAttr >>= \(rgb,attr) -> primGraphic (prim1 $ fn rgb attr)+                     ++fillPrim :: (RGBi -> Primitive) -> Graphic u+fillPrim fn = +    fillAttr >>= \rgb -> primGraphic (prim1 $ fn rgb)++fillStrokePrim :: (RGBi -> StrokeAttr -> RGBi -> Primitive) +               -> Graphic u+fillStrokePrim fn = +    borderedAttr >>= \(frgb,attr,srgb) -> +        primGraphic (prim1 $ fn frgb attr srgb)+++textLoc :: InterpretUnit u +        => (RGBi -> FontAttr -> DPoint2 -> Primitive) -> LocGraphic u+textLoc fn = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt)+++strokeLoc :: InterpretUnit u+          => (RGBi -> StrokeAttr -> DPoint2 -> Primitive) -> LocGraphic u+strokeLoc fn = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> strokePrim (\rgb attr -> fn rgb attr dpt)++fillLoc :: InterpretUnit u +        => (RGBi -> DPoint2 -> Primitive) -> LocGraphic u+fillLoc fn = promoteLoc $ \pt ->+    normalizeCtxF pt >>= \dpt -> fillPrim (\rgb -> fn rgb dpt)++fillStrokeLoc :: InterpretUnit u+              => (RGBi -> StrokeAttr -> RGBi -> DPoint2 -> Primitive) +              -> LocGraphic u+fillStrokeLoc fn = promoteLoc $ \pt ->+    normalizeCtxF pt >>= \dpt -> +    fillStrokePrim (\frgb attr srgb -> fn frgb attr srgb dpt) + +++textLocTheta :: InterpretUnit u +             => (RGBi -> FontAttr -> DPoint2 -> Radian -> Primitive) +             -> LocThetaGraphic u+textLocTheta fn = promoteLocTheta $ \pt ang -> +    normalizeCtxF pt >>= \dpt -> textPrim (\rgb attr -> fn rgb attr dpt ang)+++++--------------------------------------------------------------------------------+-- Paths++-- Note - naming convention, the PP suffix is to avoid confusion +-- with the Path data type in Wumpus-Drawing. These paths are+-- considered more /internal/.+--++-- | 'locPP' : @ [next_vector] -> LocImage PrimPath @+--+-- Create a path /query/ - i.e. a functional type +-- /from Point to PrimPath/.+-- +-- This is the analogue to 'vectorPath' in @Wumpus-Core@, but the +-- result is produced /within/ the 'DrawingContext'.+--+locPP :: InterpretUnit u => [Vec2 u] -> LocQuery u PrimPath+locPP vs = qpromoteLoc $ \pt -> +    vectorPrimPath <$> normalizeCtxF pt <*> mapM normalizeCtxF vs+++++-- | 'emptyLocPP' : @ (Point ~> PrimPath) @+--+-- Create an empty path /query/ - i.e. a functional type +-- /from Point to PrimPath/.+--+-- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the+-- result is produced /within/ the 'DrawingContext'.+--+emptyLocPP :: InterpretUnit u => LocQuery u PrimPath+emptyLocPP = locPP []+++++-- | 'vertexPP' : @ (Point ~> PrimPath) @+--+-- Create a PrimPath made of straight line segments joining the +-- supplied points.+--+-- This is the analogue to 'vertexPrimPath' in @Wumpus-Core@, but +-- it is polymorphic on unit.+--+vertexPP :: InterpretUnit u => [Point2 u] -> Query u PrimPath+vertexPP xs = vertexPrimPath <$> mapM normalizeCtxF xs++++-- | 'curvePP' : @ (Point ~> PrimPath) @+--+-- Create a path made of curve segments joining the +-- supplied points.+--+-- This is the analogue to 'curvedPrimPath' in @Wumpus-Core@, but +-- it is polymorphic on unit.+--+curvePP :: InterpretUnit u => [Point2 u] -> Query u PrimPath+curvePP xs = curvedPrimPath <$> mapM normalizeCtxF xs+++--------------------------------------------------------------------------------++--+-- Drawing paths (stroke, fill, fillStroke)...+--++dcPath :: PathMode -> PrimPath -> Graphic u+dcPath OSTROKE      = dcOpenPath+dcPath CSTROKE      = dcClosedPath DRAW_STROKE+dcPath CFILL        = dcClosedPath DRAW_FILL+dcPath CFILL_STROKE = dcClosedPath DRAW_FILL_STROKE++++-- | 'dcOpenPath' : @ path -> Graphic @+--+-- This is the analogue to the 'ostroke' function in +-- @Wumpus-Core@, but the drawing properties (colour, line width, +-- etc.) are taken from the implicit 'DrawingContext'.+--+dcOpenPath :: PrimPath -> Graphic u+dcOpenPath pp = strokePrim (\rgb attr -> ostroke rgb attr pp)++++-- | 'dcClosedPath' : @ DrawStyle * path -> Graphic @+--+-- Draw a closed path according to the supplied DrawStyle+-- ( fill | stroke | fill_stroke). +---+-- Drawing properties (colour, line width, etc.) for the +-- respective style are taken from the implicit 'DrawingContext'.+--+dcClosedPath :: DrawMode -> PrimPath -> Graphic u+dcClosedPath DRAW_FILL        pp = fillPrim (\rgb -> fill rgb pp)++dcClosedPath DRAW_STROKE      pp = strokePrim (\rgb attr -> cstroke rgb attr pp)++dcClosedPath DRAW_FILL_STROKE pp = +    fillStrokePrim (\frgb attr srgb -> fillStroke frgb attr srgb pp)+++--------------------------------------------------------------------------------+-- Text++-- | 'dcTextlabel' : @ string -> LocGraphic @+-- +-- Create a text 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'textlabel' in @Wumpus-core@, but the+-- text properties (font family, font size, colour) are taken from+-- the implicit 'DrawingContext'.+--+dcTextlabel :: InterpretUnit u => String -> LocGraphic u+dcTextlabel ss = textLoc (\rgb attr pt -> textlabel rgb attr ss pt)++++++-- | 'dcRTextlabel' : @ string -> LocThetaGraphic @+-- +-- Create a text 'LocThetaGraphic' - i.e. a functional type +-- /from Point and Angle to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left, the+-- implicit angle is rotation factor of the text.+--+-- Note - rotated text often does not render well in PostScript or+-- SVG. Rotated text should be used sparingly.+-- +-- This is the analogue to 'rtextlabel' in @Wumpus-core@.+--+dcRTextlabel :: InterpretUnit u => String -> LocThetaGraphic u+dcRTextlabel ss =+    textLocTheta (\rgb attr pt ang -> rtextlabel rgb attr ss ang pt)+++-- | 'dcEscapedlabel' : @ escaped_text -> LocGraphic @+-- +-- Create a text 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'escapedlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+dcEscapedlabel :: InterpretUnit u => EscapedText -> LocGraphic u+dcEscapedlabel esc =           +    textLoc (\rgb attr pt -> escapedlabel rgb attr esc pt)++++-- | 'dcREscapedlabel' : @ escaped_text -> LocThetaGraphic @+-- +-- Create a text 'LocThetaGraphic' - i.e. a functional type +-- /from Point and Angle to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left, the+-- implicit angle is rotation factor of the text.+--+-- Note - rotated text often does not render well in PostScript or+-- SVG. Rotated text should be used sparingly.+-- +-- This is the analogue to 'rescapedlabel' in @Wumpus-core@, but+-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+dcREscapedlabel :: InterpretUnit u => EscapedText -> LocThetaGraphic u+dcREscapedlabel esc = +    textLocTheta (\rgb attr pt ang -> rescapedlabel rgb attr esc ang pt)+++++uconvKernChar :: InterpretUnit u => [KernChar u] -> Query u [KerningChar]+uconvKernChar = mapM mf+  where+    mf (u,ch) = (\u1 -> (u1,ch)) <$> normalizeCtx u++++-- | 'hkernLine' : @ [kern_char] -> LocGraphic @+-- +-- Create a horizontally kerned text 'LocGraphic' - i.e. a +-- functional type /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'hkernlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u+hkernLine ks = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt+  where+    body pt ans = textPrim (\rgb attr -> hkernlabel rgb attr ans pt)++++-- | 'vkernLine' : @ [kern_char] -> LocGraphic @+-- +-- Create a vertically kerned text 'LocGraphic' - i.e. a +-- functional type /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the baseline left.+--+-- This is the analogue to 'vkernlabel' in @Wumpus-core@, but +-- the text properties (font family, font size, colour) are taken +-- from the implicit 'DrawingContext'.+--+vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u+vkernLine ks = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> liftQuery (uconvKernChar ks) >>= body dpt+  where+    body pt ans = textPrim (\rgb attr -> vkernlabel rgb attr ans pt)++--------------------------------------------------------------------------------+-- Lines++-- | 'straightLine' : @ start_point * end_point -> LocGraphic @ +-- +-- Create a straight line 'Graphic', the start and end point +-- are supplied explicitly.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u+straightLine p1 p2 = liftQuery (vertexPP [p1,p2]) >>= dcOpenPath+++-- | 'locStraightLine' : @ vec_to -> LocGraphic @ +--+-- Create a stright line 'LocGraphic' - i.e. a functional type +-- /from Point to Graphic/.+--+-- The implicit point of the LocGraphic is the start point, the +-- end point is calculated by displacing the start point with the +-- supplied vector.+--+-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u+locStraightLine v = promoteLoc $ \pt -> +    liftQuery (qapplyLoc (locPP [v]) pt) >>= dcOpenPath++++-- | 'curveLine' : @ start_point * control_point1 * +--        control_point2 * end_point -> Graphic @ +-- +-- Create a Bezier curve 'Graphic', all control points are +-- supplied explicitly.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +curvedLine :: InterpretUnit u+           => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u+curvedLine p0 p1 p2 p3 = liftQuery (curvePP [p0,p1,p2,p3]) >>= dcOpenPath+++++-- | 'straightConnector' : @ start_point * end_point -> Connector @ +-- +-- Create a straight line 'Graphic', the start and end point +-- are supplied implicitly.+-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +straightConnector :: InterpretUnit u => ConnectorGraphic u+straightConnector = promoteConn $ \p0 p1 -> +    liftQuery (vertexPP [p0,p1]) >>= dcOpenPath++++--------------------------------------------------------------------------------+-- Circles++-- | Helper for circle drawing.+--+circlePath :: InterpretUnit u +         => u -> LocQuery u PrimPath+circlePath r = qpromoteLoc $ \pt -> +    (\dr dpt -> curvedPrimPath $ bezierCircle dr dpt) +      <$> normalizeCtx r <*> normalizeCtxF pt+++-- | 'dcCircle' : @ DrawStyle * radius -> LocGraphic @+--+-- Create a circle 'LocGraphic' - the implicit point is +-- center. The circle is drawn with four Bezier curves. +-- +-- The respective line or fill properties for the 'DrawStyle' are +-- taken from the implicit 'DrawingContext'.+-- +dcCircle :: InterpretUnit u => DrawMode -> u -> LocGraphic u+dcCircle style r = promoteLoc $ \pt -> +    liftQuery (qapplyLoc (circlePath r) pt) >>= dcClosedPath style++++--------------------------------------------------------------------------------+-- Ellipses+++-- | Helper for ellipse drawing.+--+ellipsePath :: InterpretUnit u +            => u -> u -> LocQuery u PrimPath+ellipsePath rx ry = qpromoteLoc $ \pt -> +    (\drx dry dpt -> curvedPrimPath $ bezierEllipse drx dry dpt) +      <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt+++-- | Helper for ellipse drawing.+--+rellipsePath :: InterpretUnit u +            => u -> u -> LocThetaQuery u PrimPath+rellipsePath rx ry = qpromoteLocTheta $ \pt ang ->+    (\drx dry dpt -> curvedPrimPath $ rbezierEllipse drx dry ang dpt) +      <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt+++-- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a stroked ellipse 'LocGraphic' - the implicit point is +-- center. The ellipse is drawn with four Bezier curves. +-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +dcEllipse :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u+dcEllipse style rx ry = promoteLoc $ \pt ->+   liftQuery (qapplyLoc (ellipsePath rx ry) pt) >>= dcClosedPath style +++-- | 'dcREllipse' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a bordered ellipse 'LocThetaGraphic' - the implicit point+-- is center and the angle is rotation about the center. The +-- ellipse is drawn with four Bezier curves.  +-- +-- The background fill colour and the outline stroke properties +-- are taken from the implicit 'DrawingContext'.+-- +dcREllipse :: InterpretUnit u+           => DrawMode -> u -> u -> LocThetaGraphic u+dcREllipse style rx ry = promoteLocTheta $ \pt ang -> +    liftQuery (qapplyLocTheta (rellipsePath rx ry) pt ang) >>= +    dcClosedPath style+++-- Note - clipping needs some higher level path object than is defined here.++--------------------------------------------------------------------------------+-- Rectangles++-- | Supplied point is /bottom-left/.+--+rectanglePath :: InterpretUnit u +              => u -> u -> LocQuery u PrimPath+rectanglePath w h = locPP [hvec w, vvec h, hvec (-w)]++++-- | 'strokedRectangle' : @ style * width * height -> LocGraphic @+--+-- Create a stroked rectangle 'LocGraphic' - the implicit point is +-- bottom-left. +-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +dcRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u+dcRectangle style w h = promoteLoc $ \pt -> +    liftQuery (qapplyLoc (rectanglePath w h) pt) >>= dcClosedPath style+++---------------------------------------------------------------------------++-- | 'dcDisk' : @ radius -> LocGraphic @+--+-- Create a circle 'LocGraphic' - the implicit point is the +-- center. +-- +-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated +-- output. However, stroked-circles do not draw well after +-- non-uniform scaling - the pen width is scaled as well as +-- the shape.+--+-- For stroked circles that can be adequately scaled, use +-- 'dcCircle' instead.+--+-- The fill or stroke properties for the respective DrawStyle are+-- taken from the implicit 'DrawingContext'.+-- +dcDisk :: InterpretUnit u => DrawMode -> u -> LocGraphic u+dcDisk DRAW_FILL radius = +    normalizeCtx radius >>= \r -> +    fillLoc (\rgb pt -> fillEllipse rgb r r pt)++dcDisk DRAW_STROKE radius = +    normalizeCtx radius >>= \r -> +    strokeLoc (\rgb attr pt -> strokeEllipse rgb attr r r pt)++dcDisk DRAW_FILL_STROKE radius = +    normalizeCtx radius >>= \r -> +    fillStrokeLoc (\frgb attr srgb pt -> fillStrokeEllipse frgb attr srgb r r pt)+++++-- | 'strokeEllipseDisk' : @ x_radius * y_radius -> LocGraphic @+--+-- Create a stroked ellipse 'LocGraphic' - the implicit point is +-- the center. +-- +-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @ellipse@ in the generated +-- output. However, stroked ellipses do not draw well after +-- non-uniform scaling - the pen width is scaled as well as +-- the shape.+--+-- For stroked ellipses that can be adequately scaled, use +-- 'strokedEllipse' instead.+--+-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'.+-- +dcEllipseDisk :: InterpretUnit u +              => DrawMode -> u -> u -> LocGraphic u+dcEllipseDisk style rx ry = +    normalizeCtx rx >>= \drx -> +    normalizeCtx ry >>= \dry -> +    case style of+      DRAW_FILL -> fillLoc (\rgb pt -> fillEllipse rgb drx dry pt)+      DRAW_STROKE -> strokeLoc +                       (\rgb attr pt -> strokeEllipse rgb attr drx dry pt)+      DRAW_FILL_STROKE -> fillStrokeLoc $ +                       (\frgb attr srgb pt -> +                           fillStrokeEllipse frgb attr srgb drx dry pt)++++--------------------------------------------------------------------------------++++-- | dcArc : radius * apex_angle+-- +-- Always open-stroked.+--+dcArc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u+dcArc radius ang = promoteLocTheta $ \pt inclin -> +    let ps = bezierArcPoints ang radius inclin pt+    in liftQuery (curvePP ps) >>= dcOpenPath
− src/Wumpus/Basic/Kernel/Objects/Graphic.hs 
@@ -1,478 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE TypeSynonymInstances       #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.Graphic--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Graphic type - this is largely equivalent to Primitive in--- Wumpus-Core, but drawing attributes are implicitly supplied --- by the DrawingContext.------ API in @Wumpus.Core@, but here they exploit the implicit --- @DrawingContext@.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.Graphic-  (--    Graphic-  , DGraphic---  -- * LocGraphic  -  , LocGraphic-  , DLocGraphic---  , LocThetaGraphic-  , DLocThetaGraphic--  -- * Functions-  , intoImage-  , intoLocImage-  , intoLocThetaImage--  , moveStartPoint-  , moveStartPointTheta--  , locPath-  , emptyLocPath-  , emptyLocGraphic---  , openStroke-  , closedStroke-  , filledPath-  , borderedPath--  , textline-  , rtextline-  , escapedline-  , rescapedline--  , hkernline-  , vkernline--  , strokedEllipse-  , rstrokedEllipse-  , filledEllipse-  , rfilledEllipse--  , borderedEllipse-  , rborderedEllipse--  , straightLine-  , straightLineBetween-  , curveBetween--  , strokedRectangle-  , filledRectangle-  , borderedRectangle--  , strokedCircle-  , filledCircle-  , borderedCircle-  -  , strokedDisk-  , filledDisk-  , borderedDisk--  ) where--import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.QueryDC-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.BaseObjects--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space--import Control.Applicative------------------------------------------------------------------------------------- Graphic---- | Simple drawing - produce a primitive, access the DrawingContext--- as required, e.g for fill colour, stroke colur, line width, etc.----type Graphic u          = Image u (UNil u)---- | Alias of 'Graphic' where the unit type is specialized to --- Double. ----type DGraphic           = Graphic Double----- | /Originated/ drawing - produce a primitive respective to the --- supplied start-point, access the DrawingContext as required.----type LocGraphic u       = LocImage u (UNil u)---- | Alias of 'LocGraphic' where the unit type is specialized to --- Double. ----type DLocGraphic        = LocGraphic Double------- | /Originated/ drawing - produce a primitive respective to the --- supplied start-point, access the DrawingContext as required.----type LocThetaGraphic u       = LocThetaImage u (UNil u)----- | Alias of 'LocThetaGraphic' where the unit type is specialized --- to Double. ----type DLocThetaGraphic        = LocThetaGraphic Double-------------------------------------------------------------------------------------- Functions----- | Build an Image...----intoImage :: CF a -> Graphic u -> Image u a-intoImage = liftA2 (\a (_,b) -> (a,b))----- | Build a LocImage...----intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a-intoLocImage = liftA2 (\a (_,b) -> (a,b))---- | Build a LocThetaImage...----intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a-intoLocThetaImage = liftA2 (\a (_,b) -> (a,b))----- | Move the start-point of a LocImage with the supplied --- displacement function.----moveStartPoint :: PointDisplace u -> LocCF u a -> LocCF u a-moveStartPoint f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)----- | Move the start-point of a LocImage with the supplied --- displacement function.----moveStartPointTheta :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a-moveStartPointTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta--------------------------------------------------------------------------------------graphicBody :: Primitive u -> (UNil u, PrimGraphic u)-graphicBody p = (uNil, primGraphic p)----- | This is the analogue to 'vectorPath' in @Wumpus-core@.----locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u)-locPath vs = promoteR1 $ \pt  -> pure $ vectorPath pt vs----- | This is the analogue to 'emptyPath' in @Wumpus-core@.----emptyLocPath :: Num u => LocCF u (PrimPath u)-emptyLocPath = locPath []---- | Build an empty LocGraphic - this is a path with a start--- point but no path segments. --- --- The 'emptyLocGraphic' It is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- minimum bounding box at the implicit start point.--- -emptyLocGraphic :: Num u => LocGraphic u-emptyLocGraphic = emptyLocPath >>= (lift0R1 . openStroke)----- | 'openStroke' : @ path -> Graphic @------ This is the analogue to 'ostroke' in @Wumpus-core@, but the --- drawing properties (colour, line width, etc.) are taken from --- the implicit 'DrawingContext'.----openStroke :: Num u => PrimPath u -> Graphic u-openStroke pp = -    withStrokeAttr $ \rgb attr -> graphicBody $ ostroke rgb attr pp----- | 'closedStroke' : @ path -> Graphic @------ This is the analogue to 'cstroke' in @Wumpus-core@, but the --- drawing properties (colour, line width, etc.) are taken from --- the implicit 'DrawingContext'.----closedStroke :: Num u => PrimPath u -> Graphic u-closedStroke pp = -    withStrokeAttr $ \rgb attr -> graphicBody $ cstroke rgb attr pp----- | 'filledPath' : @ path -> Graphic @--- --- This is the analogue to 'fill' in @Wumpus-core@, but the --- fill colour is taken from the implicit 'DrawingContext'.-------filledPath :: Num u => PrimPath u -> Graphic u-filledPath pp = withFillAttr $ \rgb -> graphicBody $ fill rgb pp-                 ---- | 'borderedPath' : @ path -> Graphic @------ This is the analogue to 'fillStroke' in @Wumpus-core@, but the --- drawing properties (fill colour, border colour, line width, --- etc.) are taken from the implicit 'DrawingContext'.-------borderedPath :: Num u => PrimPath u -> Graphic u-borderedPath pp =-    withBorderedAttr $ \frgb attr srgb -> -      graphicBody $ fillStroke frgb attr srgb pp------- | This is the analogue to 'textlabel' in @Wumpus-core@.----textline :: Num u => String -> LocGraphic u-textline ss = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt)------- | This is the analogue to 'rtextlabel' in @Wumpus-core@.----rtextline :: Num u => String -> LocThetaGraphic u-rtextline ss = -    promoteR2 $ \pt theta -> -      withTextAttr $ \rgb attr -> graphicBody (rtextlabel rgb attr ss theta pt)------ | This is the analogue to 'escapedlabel' in @Wumpus-core@.----escapedline :: Num u => EscapedText -> LocGraphic u-escapedline ss = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt)------ | This is the analogue to 'rescapedlabel' in @Wumpus-core@.----rescapedline :: Num u => EscapedText -> LocThetaGraphic u-rescapedline ss = -    promoteR2 $ \pt theta -> -      withTextAttr $ \rgb attr -> graphicBody (rescapedlabel rgb attr ss theta pt)------- | This is the analogue to 'hkernlabel' in @Wumpus-core@.----hkernline :: Num u => [KerningChar u] -> LocGraphic u-hkernline xs = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt)----- | This is the analogue to 'vkernlabel' in @Wumpus-core@.----vkernline :: Num u => [KerningChar u] -> LocGraphic u-vkernline xs = -    promoteR1 $ \pt -> -      withTextAttr $ \rgb attr -> graphicBody (vkernlabel rgb attr xs pt)--------------------------------------------------------------------------------------------- | This is the analogue to 'strokeEllipse' in @Wumpus-core@.----strokedEllipse :: Num u => u -> u -> LocGraphic u-strokedEllipse hw hh =-    promoteR1 $ \pt -> -      withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt)------ | This is the analogue to 'rstrokeEllispe' in @Wumpus-core@.----rstrokedEllipse :: Num u => u -> u -> LocThetaGraphic u-rstrokedEllipse hw hh = -    promoteR2 $ \ pt theta -> -      withStrokeAttr $ \rgb attr -> -        graphicBody (rstrokeEllipse rgb attr hw hh theta pt)----- | This is the analogue to 'fillEllispe' in @Wumpus-core@.----filledEllipse :: Num u => u -> u -> LocGraphic u-filledEllipse hw hh = -    promoteR1 $ \pt ->  -      withFillAttr $ \rgb -> graphicBody (fillEllipse rgb hw hh pt)----- | This is the analogue to 'rfillEllispe' in @Wumpus-core@.----rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u-rfilledEllipse hw hh = -    promoteR2 $ \pt theta ->-      withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta pt)------ | This is the analogue to 'fillStrokeEllispe' in @Wumpus-core@.----borderedEllipse :: Num u => u -> u -> LocGraphic u-borderedEllipse hw hh =-    promoteR1 $ \pt -> -      withBorderedAttr $ \frgb attr srgb -> -        graphicBody (fillStrokeEllipse frgb attr srgb hw hh pt)---- | This is the analogue to 'rfillStrokeEllispe' in @Wumpus-core@.----rborderedEllipse :: Num u => u -> u -> LocThetaGraphic u-rborderedEllipse hw hh = -    promoteR2 $ \pt theta -> -      withBorderedAttr $ \frgb attr srgb -> -        graphicBody (rfillStrokeEllipse frgb attr srgb hw hh theta pt)------ Note - clipping needs a picture as well as a path, so there is--- no analogous @clippedPath@ function.--------------------------------------------------------------------------------------- | Draw a straight line formed from displacing the implicit --- start point with the supplied vector.--- -straightLine :: Fractional u => Vec2 u -> LocGraphic u-straightLine v = mf >>= (lift0R1 . openStroke)-  where-    mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v]--          --- | Draw a straight line - start and end point are supplied --- explicitly.--- -straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u-straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2]------ | Draw a Bezier curve - all points are supplied explicitly.--- -curveBetween :: Fractional u -             => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u-curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep]----- This is a permuted version of the cardinal-prime combinator...--- --- > (r2 -> a) -> (a -> r1 -> ans) -> (r1 -> r2 -> ans)-----drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u -drawWith g mf = promoteR1 $ \pt -> mf (g pt)----- | Supplied point is /bottom-left/.----rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u-rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h---- | Supplied point is /bottom left/.----strokedRectangle :: Fractional u => u -> u -> LocGraphic u-strokedRectangle w h = rectanglePath w h `drawWith` closedStroke----- | Supplied point is /bottom left/.----filledRectangle :: Fractional u => u -> u -> LocGraphic u-filledRectangle w h = rectanglePath w h `drawWith` filledPath---- | Supplied point is /bottom left/.----borderedRectangle :: Fractional u => u -> u -> LocGraphic u-borderedRectangle w h = rectanglePath w h `drawWith` borderedPath----- | Supplied point is center. Circle is drawn with Bezier --- curves. ----strokedCircle :: Floating u => Int -> u -> LocGraphic u-strokedCircle n r = (curvedPath . bezierCircle n r) `drawWith` closedStroke ------ | Supplied point is center. Circle is drawn with Bezier --- curves. ----filledCircle :: Floating u => Int -> u -> LocGraphic u-filledCircle n r =  (curvedPath . bezierCircle n r) `drawWith` filledPath------ | Supplied point is center. Circle is drawn with Bezier --- curves. ----borderedCircle :: Floating u => Int -> u -> LocGraphic u-borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath ----- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive.------ This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, stroked-circles do not draw well after --- non-uniform scaling - the line width is scaled as well as --- the shape.------ For stroked circles that can be adequately scaled, use --- 'strokedCircle' instead.----strokedDisk :: Num u => u -> LocGraphic u-strokedDisk radius = strokedEllipse radius radius---- | Filled disk...----filledDisk :: Num u => u -> LocGraphic u-filledDisk radius = filledEllipse radius radius---- | bordered disk...----borderedDisk :: Num u => u -> LocGraphic u-borderedDisk radius = borderedEllipse radius radius
+ src/Wumpus/Basic/Kernel/Objects/Image.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Image+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Common types and operations.+-- +--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Image+  (+++    Image+  , Graphic ++  , Query++  , DImage+  , DGraphic++  , runImage+  , runQuery++  , stripImage+  , liftQuery++  , emptyImage+  , primGraphic+  , clipImage+++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.WrappedPrimitive+import Wumpus.Basic.Kernel.Objects.Basis++import Wumpus.Core                              -- package: wumpus-core+++import Control.Applicative+import Data.Monoid++--------------------------------------------------------------------------------+++newtype Image u a = Image { +          getImage :: DrawingContext -> (a, CatPrim) }++type instance DUnit (Image u a) = u++type Graphic u = Image u (UNil u)+++-- | Type specialized version of 'Image'.+--+type DImage a       = Image Double a++-- | Type specialized version of 'Graphic'.+--+type DGraphic       = Graphic Double +++newtype Query u a = Query { +          getQuery :: DrawingContext -> a }++type instance DUnit (Query u a) = u++-- Functor++instance Functor (Image u) where+  fmap f ma = Image $ \ctx -> let (a,w1) = getImage ma ctx in (f a, w1)++instance Functor (Query u) where+  fmap f ma = Query $ \ctx -> f $ getQuery ma ctx++-- Applicative++instance Applicative (Image u) where+  pure a    = Image $ \_   -> (a,mempty)+  mf <*> ma = Image $ \ctx -> let (f,w1) = getImage mf ctx +                                  (a,w2) = getImage ma ctx+                              in (f a, w1 `mappend` w2)++instance Applicative (Query u) where+  pure a    = Query $ \_   -> a+  mf <*> ma = Query $ \ctx -> let f = getQuery mf ctx +                                  a = getQuery ma ctx+                              in f a+++-- Monad++instance Monad (Image u) where+  return a = Image $ \_   -> (a,mempty)+  ma >>= k = Image $ \ctx -> let (a,w1) = getImage ma ctx +                                 (b,w2) = getImage (k a) ctx+                             in (b,w1 `mappend` w2)+++instance Monad (Query u) where+  return a = Query $ \_   -> a+  ma >>= k = Query $ \ctx -> let a = getQuery ma ctx in getQuery (k a) ctx++-- Monoid++instance Monoid a => Monoid (Image u a) where+  mempty          = pure mempty+  ma `mappend` mb = Image $ \ctx -> +                      getImage ma ctx `mappend` getImage mb ctx++instance Monoid a => Monoid (Query u a) where+  mempty          = pure mempty+  ma `mappend` mb = Query $ \ctx -> +                      getQuery ma ctx `mappend` getQuery mb ctx+++-- DrawingCtxM+++instance DrawingCtxM (Image u) where+  askDC           = Image $ \ctx -> (ctx, mempty)+  asksDC fn       = Image $ \ctx -> (fn ctx, mempty)+  localize upd ma = Image $ \ctx -> getImage ma (upd ctx)++instance DrawingCtxM (Query u) where+  askDC           = Query $ \ctx -> ctx+  asksDC fn       = Query $ \ctx -> (fn ctx)+  localize upd ma = Query $ \ctx -> getQuery ma (upd ctx)+++runImage :: DrawingContext -> Image u a -> PrimResult u a+runImage ctx ma = getImage ma ctx++runQuery :: DrawingContext -> Query u a -> a+runQuery ctx ma = getQuery ma ctx++++-- | Strip the graphic content from an 'Image' making a 'Query'.+-- +stripImage :: Image u a -> Query u a+stripImage ma = Query $ \ctx -> fst $ getImage ma ctx+++-- | Turn a 'Query' into an 'Image' without graphic content.+--+liftQuery :: Query u a -> Image u a+liftQuery ma = askDC >>= \ctx -> let a = runQuery ctx ma in return a++++-- | Constructor for Primtive graphics.+--+primGraphic :: CatPrim -> Graphic u+primGraphic w = Image $ \_ -> (UNil, w)+++-- | Clip an Image.+-- +clipImage :: PrimPath -> Image u a -> Image u a+clipImage pp ma = Image $ \ctx -> +     let (a,w) = getImage ma ctx in (a, cpmap (clipPrim pp) w)++++instance UConvert Image where+  uconvZ = uconvImageZ+  uconvF = uconvImageF++uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) +            => Image u (t u) -> Image u1 (t u1) +uconvImageF ma = Image $ \ctx -> +    let (a,w) = getImage ma ctx+        a'    = uconvertF (dc_font_size ctx) a+    in (a',w)+++uconvImageZ :: (InterpretUnit u, InterpretUnit u1) +            => Image u a -> Image u1 a+uconvImageZ ma = Image $ \ctx -> getImage ma ctx+++-- | Having /empty/ at the specific 'Image' type is useful.+-- +emptyImage :: Monoid a => Image u a+emptyImage = mempty++--------------------------------------------------------------------------------+++instance Decorate Image where+  decorate      = decorateImage+  elaborate     = elaborateImage  +  obliterate    = obliterateImage+  hyperlink     = hyperlinkImage+  svgId         = svgIdImage  +  svgAnnotate   = svgAnnotateImage ++-- | Decorate Image.+--+decorateImage :: ZOrder -> 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 ZABOVE (a,w1) (_,w2) = (a, w1 `mappend` w2)+    step ZBELOW (a,w1) (_,w2) = (a, w2 `mappend` w1)+++-- | Elaborate Image.+--+elaborateImage :: ZOrder -> 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+      ZABOVE -> (a, w1 `mappend` w2)+      ZBELOW -> (a, w2 `mappend` w1)+++obliterateImage :: Image u a -> Image u a+obliterateImage ma = Image $ \ctx -> +    let (a,_) = getImage ma ctx in (a,mempty)+  +hyperlinkImage :: XLink -> Image u a -> Image u a+hyperlinkImage xl ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (xlinkPrim xl) w)++svgIdImage :: String -> Image u a -> Image u a+svgIdImage ss ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (xidPrim ss) w)++svgAnnotateImage :: [SvgAttr] -> Image u a -> Image u a+svgAnnotateImage attrs ma = Image $ \ctx -> step (getImage ma ctx)+  where+    step (a,w) = (a, cpmap (annotateGroup attrs) w)+++--------------------------------------------------------------------------------+-- Affine instances ++-- +-- Design Note+--+-- Are PrimW instances needed as Image cannot use them?+-- ++instance Rotate a => Rotate (Image u a) where+  rotate ang ma = Image $ \ctx -> +      let (a,w) = getImage ma ctx+      in (rotate ang a, rotate ang w)++instance (RotateAbout a, InterpretUnit u, u ~ DUnit a) => +    RotateAbout (Image u a) where+  rotateAbout ang pt ma = Image $ \ctx -> +      let ptu   = uconvertF (dc_font_size ctx) pt+          (a,w) = getImage ma ctx+      in (rotateAbout ang pt a, rotateAbout ang ptu w)+++instance Scale a => Scale (Image u a) where+  scale sx sy ma = Image $ \ctx -> +      let (a,w) = getImage ma ctx+      in (scale sx sy a, scale sx sy w)+++instance (Translate a, InterpretUnit u, u ~ DUnit a) => +    Translate (Image u a) where+  translate dx dy ma = Image $ \ctx -> +      let sz    = dc_font_size ctx+          ddx   = uconvert1 sz dx+          ddy   = uconvert1 sz dy+          (a,w) = getImage ma ctx+      in (translate dx dy a, translate ddx ddy w)++++
+ src/Wumpus/Basic/Kernel/Objects/LocImage.hs view
@@ -0,0 +1,357 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.LocImage+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- LocImage and LocGraphic types - these are functional types from the +-- DrawingContext and start point to a graphic /primitive/.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.LocImage+   (++     LocImage+   , LocGraphic++   , DLocImage+   , DLocGraphic++   , LocQuery++   , runLocImage+   , runLocQuery++   , stripLocImage+   , liftLocQuery++   , promoteLoc+   , applyLoc+   , supplyLoc+   , qpromoteLoc+   , qapplyLoc++   , emptyLocImage++   , moveStart+   , at++   -- * Composing LocImages+   , distrib+   , distribH +   , distribV+   +   , duplicate+   , duplicateH+   , duplicateV+++   )++   where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image+++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Control.Applicative+import Data.Monoid++++-- | 'LocThetaImage' - function from  start point and +-- DrawingContext to a polymorphic /answer/ and a graphic +-- /primitive/ (PrimW).+--+newtype LocImage u a = LocImage { +          getLocImage :: DPoint2 -> Image u a }++type instance DUnit (LocImage u a) = u++type LocGraphic u = LocImage u (UNil u)+++-- | Type specialized version of 'LocImage'.+--+type DLocImage a        = LocImage Double a++-- | Type specialized version of 'LocGraphic'.+--+type DLocGraphic        = LocGraphic Double ++newtype LocQuery u a = LocQuery { +          getLocQuery :: DPoint2 -> Query u a }++-- Functor++instance Functor (LocImage u) where+  fmap f ma = LocImage $ \pt -> fmap f $ getLocImage ma pt+++instance Functor (LocQuery u) where+  fmap f ma = LocQuery $ \pt -> fmap f $ getLocQuery ma pt++-- Applicative++instance Applicative (LocImage u) where+  pure a    = LocImage $ \_  -> pure a+  mf <*> ma = LocImage $ \pt -> getLocImage mf pt <*> getLocImage ma pt++instance Applicative (LocQuery u) where+  pure a    = LocQuery $ \_  -> pure a+  mf <*> ma = LocQuery $ \pt -> getLocQuery mf pt <*> getLocQuery ma pt+                                +++-- Monad++instance Monad (LocImage u) where+  return a  = LocImage $ \_  -> return a+  ma >>= k  = LocImage $ \pt -> getLocImage ma pt >>= \ans -> +                                  getLocImage (k ans) pt+++instance Monad (LocQuery u) where+  return a  = LocQuery $ \_  -> return a+  ma >>= k  = LocQuery $ \pt -> getLocQuery ma pt >>= \ans -> +                                  getLocQuery (k ans) pt+++-- Monoid++instance Monoid a => Monoid (LocImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocImage $ \pt -> +                      getLocImage ma pt `mappend` getLocImage mb pt ++instance Monoid a => Monoid (LocQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocQuery $ \pt -> +                      getLocQuery ma pt `mappend` getLocQuery mb pt ++-- DrawingCtxM++instance DrawingCtxM (LocImage u) where+  askDC           = LocImage $ \_  -> askDC+  asksDC fn       = LocImage $ \_  -> asksDC fn+  localize upd ma = LocImage $ \pt -> localize upd (getLocImage ma pt)++instance DrawingCtxM (LocQuery u) where+  askDC           = LocQuery $ \_  -> askDC+  asksDC fn       = LocQuery $ \_  -> asksDC fn+  localize upd ma = LocQuery $ \pt -> localize upd (getLocQuery ma pt)++++  +instance Decorate LocImage where+  decorate zo ma mz = LocImage $ \pt -> +    decorate zo (getLocImage ma pt) (getLocImage mz pt)++  elaborate zo ma f = LocImage $ \pt -> +    elaborate zo (getLocImage ma pt) (\a -> getLocImage (f a) pt)++  obliterate ma = LocImage $ \pt -> obliterate $ getLocImage ma pt ++  hyperlink xl ma = LocImage $ \pt -> hyperlink xl $ getLocImage ma pt ++  svgId ss ma = LocImage $ \pt -> svgId ss $ getLocImage ma pt ++  svgAnnotate attrs ma = LocImage $ \pt -> svgAnnotate attrs $ getLocImage ma pt+++runLocImage :: InterpretUnit u +            => DrawingContext -> Point2 u -> LocImage u a -> PrimResult u a+runLocImage ctx pt ma = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runImage ctx $ getLocImage ma dpt++runLocQuery :: InterpretUnit u +            => DrawingContext -> Point2 u -> LocQuery u a -> a+runLocQuery ctx pt ma = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runQuery ctx $ getLocQuery ma dpt+++stripLocImage :: LocImage u a -> LocQuery u a+stripLocImage ma = LocQuery $ \pt -> +    stripImage $ getLocImage ma pt+++liftLocQuery :: LocQuery u a -> LocImage u a+liftLocQuery ma = LocImage $ \pt -> +    liftQuery $ getLocQuery ma pt+++promoteLoc ::  InterpretUnit u => (Point2 u -> Image u a) -> LocImage u a+promoteLoc k = LocImage $ \pt -> dinterpCtxF pt >>= k ++applyLoc :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a+applyLoc ma pt = normalizeCtxF pt >>= getLocImage ma+++-- | Flipped version of 'applyLoc'. +-- +supplyLoc :: InterpretUnit u => Point2 u -> LocImage u a -> Image u a+supplyLoc = flip at+++qpromoteLoc :: InterpretUnit u +            => (Point2 u -> Query u a) -> LocQuery u a+qpromoteLoc k = LocQuery $ \pt -> dinterpCtxF pt >>= k++qapplyLoc :: InterpretUnit u+          => LocQuery u a -> Point2 u -> Query u a+qapplyLoc ma pt = normalizeCtxF pt >>= getLocQuery ma++++--------------------------------------------------------------------------------+-- Affine instances++instance (Real u, Floating u, InterpretUnit u, Rotate a) => +    Rotate (LocImage u a) where+  rotate ang ma = promoteLoc $ \pt -> +      normalizeCtxF pt >>= \dpt ->  +      fmap (rotate ang) $ getLocImage ma (rotate ang dpt)+++instance (Real u, Floating u, InterpretUnit u, RotateAbout a, u ~ DUnit a) => +    RotateAbout (LocImage u a) where+  rotateAbout ang pt ma = promoteLoc $ \p0 ->+      normalizeCtxF p0 >>= \dp0 ->  +      normalizeCtxF pt >>= \dpt ->  +      fmap (rotateAbout ang pt) $ +          getLocImage ma (rotateAbout ang dpt dp0)+++instance (Fractional u, InterpretUnit u, Scale a) => Scale (LocImage u a) where+  scale sx sy ma = promoteLoc $ \pt -> +      normalizeCtxF pt >>= \dpt -> +      fmap (scale sx sy) $ getLocImage ma (scale sx sy dpt)++instance (InterpretUnit u, Translate a, ScalarUnit u, u ~ DUnit a) => +    Translate (LocImage u a) where+  translate dx dy ma = promoteLoc $ \pt -> +      normalizeCtxF pt >>= \dpt -> +      normalizeCtx dx  >>= \ddx ->+      normalizeCtx dy  >>= \ddy ->+      translate dx dy $ getLocImage ma (translate ddx ddy dpt)++--------------------------------------------------------------------------------+++instance UConvert LocImage where+  uconvF = uconvLocImageF+  uconvZ = uconvLocImageZ++-- | Use this to convert 'LocGraphic' or 'LocImage' with Functor +-- answer.+--+uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) +               => LocImage u (t u) -> LocImage u1 (t u1)+uconvLocImageF ma = LocImage $ \pt -> uconvF $ getLocImage ma pt++++-- | Use this to convert 'LocImage' with unit-less answer.+--+uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) +               => LocImage u a -> LocImage u1 a+uconvLocImageZ ma = LocImage $ \pt -> uconvZ $ getLocImage ma pt+++-- | Having /empty/ at the specific 'LocImage' type is useful.+-- +emptyLocImage :: Monoid a => LocImage u a+emptyLocImage = mempty+++++-- Note - maybe this should just be an operator on LocImage...+--++moveStart :: InterpretUnit u => Vec2 u -> LocImage u a -> LocImage u a+moveStart v1 ma = LocImage $ \pt -> +    normalizeCtxF v1 >>= \dv -> getLocImage ma (pt .+^ dv) ++++infixr 1 `at`++-- | Downcast a 'LocImage' function by applying it to the supplied +-- point, making an 'Image'. +-- +-- > infixr 1 `at`+-- +at :: InterpretUnit u => LocImage u a -> Point2 u -> Image u a+at = applyLoc++++--------------------------------------------------------------------------------+-- Combining LocImages ++-- LocImages have no concept of /border/ or /next/, so they can +-- only be combined by manipulating the start point of successive+-- drawings.++-- 'oplus' gives super-imposition - Locimages are drawn at the same+-- start point.++++distrib :: (Monoid a, InterpretUnit u) +        => Vec2 u -> [LocImage u a]  -> LocImage u a+distrib _  []     = mempty+distrib v1 (x:xs) = promoteLoc $ \pt -> +    go (applyLoc x pt) (pt .+^ v1) xs+  where+    go acc _  []     = acc+    go acc pt (a:as) = go (acc `mappend` applyLoc a pt) (pt .+^ v1) as++distribH :: (Monoid a, InterpretUnit u) +         => u -> [LocImage u a]  -> LocImage u a+distribH dx = distrib (hvec dx)++distribV :: (Monoid a, InterpretUnit u) +         => u -> [LocImage u a]  -> LocImage u a+distribV dy = distrib (hvec dy)+++-- | This is analogue to @replicate@ in the Prelude.+--+duplicate :: (Monoid a, InterpretUnit u) +          => Int -> Vec2 u -> LocImage u a -> LocImage u a+duplicate n _ _   | n < 1 = mempty+duplicate n v img         = go img v (n-1)+  where+     go acc _  i | i < 1 = acc+     go acc v1 i         = let img1 = moveStart v1 img+                           in go (acc `mappend` img1) (v1 ^+^ v) (i-1)++duplicateH :: (Monoid a, InterpretUnit u) +           => Int -> u -> LocImage u a -> LocImage u a+duplicateH n dx = duplicate n (hvec dx)++duplicateV :: (Monoid a, InterpretUnit u) +           => Int -> u -> LocImage u a -> LocImage u a+duplicateV n dy = duplicate n (vvec dy)+
+ src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs view
@@ -0,0 +1,294 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.LocThetaImage+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- LocThetaImage and LocThetaGraphic types - these are functional +-- types from the DrawingContext, start point and angle of +-- inclination to a graphic /primitive/.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.LocThetaImage+   (+     LocThetaGraphic+   , LocThetaImage++   , DLocThetaGraphic+   , DLocThetaImage++   , LocThetaQuery++   , runLocThetaImage+   , runLocThetaQuery++   , stripLocThetaImage+   , liftLocThetaQuery+   +   , promoteLocTheta+   , applyLocTheta+   , supplyLocTheta+   , qpromoteLocTheta+   , qapplyLocTheta++   , emptyLocThetaImage++   , incline+   , atIncline+   , supplyIncline+   +   )++   where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.DrawingContext+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Objects.Basis+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+import Data.Monoid++-- | 'LocThetaImage' - function from start point, inclination and+-- DrawingContext to a polymorphic /answer/ and a graphic +-- /primitive/ (PrimW).+--+newtype LocThetaImage u a = LocThetaImage { +          getLocThetaImage :: DPoint2 -> Radian -> Image u a }++type instance DUnit (LocThetaImage u a) = u++type LocThetaGraphic u = LocThetaImage u (UNil u)+++-- | Type specialized version of 'LocThetaImage'.+--+type DLocThetaImage a        = LocThetaImage Double a++-- | Type specialized version of 'LocThetaGraphic'.+--+type DLocThetaGraphic        = LocThetaGraphic Double +++newtype LocThetaQuery u a = LocThetaQuery { +          getLocThetaQuery :: DPoint2 -> Radian -> Query u a }++-- Functor++instance Functor (LocThetaImage u) where+  fmap f ma = LocThetaImage $ \pt ang -> +                fmap f $ getLocThetaImage ma pt ang++instance Functor (LocThetaQuery u) where+  fmap f ma = LocThetaQuery $ \pt ang -> +                fmap f $ getLocThetaQuery ma pt ang+++-- Applicative++instance Applicative (LocThetaImage u) where+  pure a    = LocThetaImage $ \_  _   -> pure a+  mf <*> ma = LocThetaImage $ \pt ang -> +                getLocThetaImage mf pt ang <*> getLocThetaImage ma pt ang++instance Applicative (LocThetaQuery u) where+  pure a    = LocThetaQuery $ \_  _   -> pure a+  mf <*> ma = LocThetaQuery $ \pt ang -> +                getLocThetaQuery mf pt ang <*> getLocThetaQuery ma pt ang+++-- Monad ++instance Monad (LocThetaImage u) where+  return a  = LocThetaImage $ \_  _   -> return a+  ma >>= k  = LocThetaImage $ \pt ang -> +                getLocThetaImage ma pt ang >>= \ans -> +                getLocThetaImage (k ans) pt ang+++instance Monad (LocThetaQuery u) where+  return a  = LocThetaQuery $ \_  _   -> return a+  ma >>= k  = LocThetaQuery $ \pt ang -> +                getLocThetaQuery ma pt ang >>= \ans -> +                getLocThetaQuery (k ans) pt ang++-- Monoid++instance Monoid a => Monoid (LocThetaImage u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocThetaImage $ \pt ang -> +                      getLocThetaImage ma pt ang +                         `mappend` getLocThetaImage mb pt ang++++instance Monoid a => Monoid (LocThetaQuery u a) where+  mempty          = pure mempty+  ma `mappend` mb = LocThetaQuery $ \pt ang -> +                      getLocThetaQuery ma pt ang +                         `mappend` getLocThetaQuery mb pt ang++-- DrawingCtxM++instance DrawingCtxM (LocThetaImage u) where+  askDC           = LocThetaImage $ \_  _   -> askDC+  asksDC fn       = LocThetaImage $ \_  _   -> asksDC fn+  localize upd ma = LocThetaImage $ \pt ang -> +                      localize upd (getLocThetaImage ma pt ang)++instance DrawingCtxM (LocThetaQuery u) where+  askDC           = LocThetaQuery $ \_  _   -> askDC+  asksDC fn       = LocThetaQuery $ \_  _   -> asksDC fn+  localize upd ma = LocThetaQuery $ \pt ang -> +                      localize upd (getLocThetaQuery ma pt ang)++--++instance Decorate LocThetaImage where+  decorate zo ma mz     = LocThetaImage $ \pt ang -> +    decorate zo (getLocThetaImage ma pt ang) (getLocThetaImage mz pt ang)++  elaborate zo ma f     = LocThetaImage $ \pt ang -> +    elaborate zo (getLocThetaImage ma pt ang) +                 (\a -> getLocThetaImage (f a) pt ang)++  obliterate ma         = LocThetaImage $ \pt ang -> +    obliterate $ getLocThetaImage ma pt ang++  hyperlink xl ma       = LocThetaImage $ \pt ang -> +    hyperlink xl $ getLocThetaImage ma pt ang++  svgId ss ma           = LocThetaImage $ \pt ang -> +    svgId ss $ getLocThetaImage ma pt ang++  svgAnnotate attrs ma  = LocThetaImage $ \pt ang -> +    svgAnnotate attrs $ getLocThetaImage ma pt ang+           ++++runLocThetaImage :: InterpretUnit u +                 => DrawingContext -> Point2 u -> Radian+                 -> LocThetaImage u a +                 -> PrimResult u a+runLocThetaImage ctx pt incl ma = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runImage ctx $ getLocThetaImage ma dpt incl+++runLocThetaQuery :: InterpretUnit u +                 => DrawingContext -> Point2 u -> Radian  +                 -> LocThetaQuery u a +                 -> a+runLocThetaQuery ctx pt incl ma = +    let dpt = normalizeF (dc_font_size ctx) pt +    in runQuery ctx $ getLocThetaQuery ma dpt incl++++stripLocThetaImage :: LocThetaImage u a -> LocThetaQuery u a+stripLocThetaImage ma = LocThetaQuery $ \pt ang -> +    stripImage $ getLocThetaImage ma pt ang+++liftLocThetaQuery :: LocThetaQuery u a -> LocThetaImage u a+liftLocThetaQuery ma = LocThetaImage $ \pt ang -> +    liftQuery $ getLocThetaQuery ma pt ang+++++promoteLocTheta ::  InterpretUnit u +                => (Point2 u -> Radian -> Image u a) -> LocThetaImage u a+promoteLocTheta k = LocThetaImage $ \pt ang -> +    dinterpCtxF pt >>= \upt -> k upt ang++applyLocTheta :: InterpretUnit u +              => LocThetaImage u a -> Point2 u -> Radian -> Image u a+applyLocTheta ma pt ang = +    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt ang++supplyLocTheta :: InterpretUnit u +               => Point2 u -> Radian -> LocThetaImage u a -> Image u a+supplyLocTheta pt ang ma = applyLocTheta ma pt ang+++qpromoteLocTheta :: InterpretUnit u +                 => (Point2 u -> Radian -> Query u a) -> LocThetaQuery u a+qpromoteLocTheta k = LocThetaQuery $ \pt ang ->+    dinterpCtxF pt >>= \upt -> k upt ang+++qapplyLocTheta :: InterpretUnit u+               => LocThetaQuery u a -> Point2 u -> Radian -> Query u a+qapplyLocTheta ma pt ang = +    normalizeCtxF pt >>= \dpt -> getLocThetaQuery ma dpt ang+++++instance UConvert LocThetaImage where+  uconvF = uconvLocThetaImageF+  uconvZ = uconvLocThetaImageZ+++-- | Use this to convert 'LocThetaThetaGraphic' or 'LocThetaThetaImage' +-- with Functor answer.+--+uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) +                    => LocThetaImage u (t u) -> LocThetaImage u1 (t u1)+uconvLocThetaImageF ma = LocThetaImage $ \pt ang -> +    uconvF $ getLocThetaImage ma pt ang+++++-- | Use this to convert 'LocThetaImage' with unit-less answer.+--+uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) +                    => LocThetaImage u a -> LocThetaImage u1 a+uconvLocThetaImageZ ma = LocThetaImage $ \pt ang -> +    uconvZ $ getLocThetaImage ma pt ang++++-- | Having /empty/ at the specific 'LocThetaImage' type is useful.+-- +emptyLocThetaImage :: Monoid a => LocThetaImage u a+emptyLocThetaImage = mempty++++++infixr 1 `incline`+++-- | Downcast a 'LocThetaImage' function by applying it to the +-- supplied angle, making a 'LocImage'. +-- +incline :: InterpretUnit u => LocThetaImage u a -> Radian -> LocImage u a+incline ma incl = promoteLoc $ \pt -> +    normalizeCtxF pt >>= \dpt -> getLocThetaImage ma dpt incl++atIncline :: InterpretUnit u +          => LocThetaImage u a -> Point2 u -> Radian -> Image u a+atIncline = applyLocTheta+++-- | Flipped version of 'incline'+--+supplyIncline :: InterpretUnit u => Radian -> LocThetaImage u a -> LocImage u a+supplyIncline = flip incline
+ src/Wumpus/Basic/Kernel/Objects/Orientation.hs view
@@ -0,0 +1,564 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Orientation+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Graphic objects RectAddress and Orientation to model +-- rectangular positioning.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Orientation+  (+++  -- * Components+    RectAddress(..)+  , Orientation(..)++  , vtoRectAddress+  , vtoOrigin+  , orientationBounds+  , orientationWidth+  , orientationHeight++  , rotateOrientation+ +  , extendOrientation+  , extendOLeft+  , extendORight+  , extendODown+  , extendOUp++  , fillHEven+  , fillXMinor+  , fillXMajor+  , fillVEven+  , fillYMajor+  , fillYMinor++  , spineRight+  , spineBelow++  , halignBottomO+  , halignCenterO+  , halignTopO+  , valignLeftO+  , valignCenterO+  , valignRightO++  , spinemoveH+  , spinemoveV+  , binmoveHBottom+  , binmoveHCenter+  , binmoveHTop+  , binmoveVLeft+  , binmoveVCenter+  , binmoveVRight++  ) where++++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'.  +--+-- 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)+++++-- | Utility datatype representing orientation within a +-- rectangular /frame/. RectPos is useful for graphics such as +-- text where the start point is not necessarily at the center +-- (or bottom left).+--+-- > x_minor is the horizontal distance from the left to the start point+-- >+-- > x_major is the horizontal distance from the start point to the right+-- >+-- > y_minor is the vertical distance from the bottom to the start point+-- >+-- > y_major is the vertical distance from the start point to the top+--+-- Values should be not be negative!+--+-- +data Orientation u = Orientation+      { or_x_minor      :: !u+      , or_x_major      :: !u+      , or_y_minor      :: !u+      , or_y_major      :: !u+      }+  deriving (Eq,Ord,Show)+++++--------------------------------------------------------------------------------++instance Functor Orientation where+  fmap f (Orientation xmin xmaj ymin ymaj) = +    Orientation (f xmin) (f xmaj) (f ymin) (f ymaj)+++-- | Concatenation coalesces the origins.+--+instance (Fractional u, Ord u) => Monoid (Orientation u) where+  mempty  = Orientation 0 0 0 0+  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)+                 }+++-- 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 origin ro a 'RectAddress'.+--+vtoRectAddress :: (Fractional u, Ord u) +               => Orientation u -> RectAddress -> Vec2 u+vtoRectAddress (Orientation xmin xmaj ymin ymaj) = go+  where+    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 (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.+-- +orientationBounds :: Num u +                  => Orientation u -> Point2 u -> BoundingBox u+orientationBounds (Orientation xmin xmaj ymin ymaj) (P2 x y) = BBox llc urc+  where+    llc   = P2 (x-xmin) (y-ymin)+    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 +                  => u -> u -> u -> u -> Orientation u -> Orientation u+extendOrientation dxl dxr dyd dyu (Orientation xmin xmaj ymin ymaj) = +    Orientation (xmin+dxl) (xmaj+dxr) (ymin+dyd) (ymaj+dyu)++extendOLeft :: Num u => u -> Orientation u -> Orientation u+extendOLeft u (Orientation xmin xmaj ymin ymaj) = +    Orientation (u+xmin) xmaj ymin ymaj+++extendORight :: Num u => u -> Orientation u -> Orientation u+extendORight u (Orientation xmin xmaj ymin ymaj) = +    Orientation xmin (u+xmaj) ymin ymaj++extendODown :: Num u => u -> Orientation u -> Orientation u+extendODown u (Orientation xmin xmaj ymin ymaj) = +    Orientation xmin xmaj (u+ymin) ymaj++extendOUp :: Num u => u -> Orientation u -> Orientation u+extendOUp u (Orientation xmin xmaj ymin ymaj) = +    Orientation xmin xmaj ymin (u+ymaj)+++--------------------------------------------------------------------------------+-- Note these are fills not pads...+++fillHEven :: (Fractional u, Ord u) +          => u -> Orientation u -> Orientation u+fillHEven w ortt@(Orientation xmin xmaj _ _) = +    if w > ow then ortt { or_x_minor = xmin + hdx+                        , or_x_major = xmaj + hdx } +              else ortt+  where+    ow = xmin + xmaj+    hdx = 0.5 * (w - ow)+++fillXMinor :: (Num u, Ord u) +          => u -> Orientation u -> Orientation u+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++fillXMajor :: (Num u, Ord u)+         => u -> Orientation u -> Orientation u+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++fillVEven :: (Fractional u, Ord u) +          => u -> Orientation u -> Orientation u+fillVEven h ortt@(Orientation _ _ ymin ymaj) = +    if h > oh then ortt { or_y_minor = ymin + hdy+                        , or_y_major = ymaj + hdy } +              else ortt+  where+    oh = ymin + ymaj+    hdy = 0.5 * (h - oh)++fillYMinor :: (Num u, Ord u) +         => u -> Orientation u -> Orientation u+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+++fillYMajor :: (Num u, Ord u) +       => u -> Orientation u -> Orientation u+fillYMajor h ortt@(Orientation _ _ ymin ymaj) = +    if h > oh then ortt { or_y_major = ymaj + dy } else ortt+  where+    oh = ymin + ymaj+    dy = h - oh+++--------------------------------------------------------------------------------+-- Combining Orientation++-- Note - there are lots of concatenations (due to alignment) +-- we need a consistent name scheme...+++-- | Second Orientation is moved /to the right/ of the first along+-- the /spine/ i.e the baseline.+--+spineRight :: (Num u, Ord u) +            => Orientation u -> Orientation u -> Orientation u+spineRight (Orientation xmin0 xmaj0 ymin0 ymaj0) +           (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    Orientation { or_x_minor = xmin0+                , or_x_major = xmaj0 + xmin1 + xmaj1 +                , or_y_minor = max ymin0 ymin1+                , or_y_major = max ymaj0 ymaj1+                }+++-- | Second Orientation is moved /below/ the first along the spine+-- i.e. the vertical point between the left minor and right major+-- (not the same as the horizontal center).+--+spineBelow :: (Num u, Ord u) +           => Orientation u -> Orientation u -> Orientation u+spineBelow (Orientation xmin0 xmaj0 ymin0 ymaj0) +           (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    Orientation { or_x_minor = max xmin0 xmin1+                , or_x_major = max xmaj0 xmaj1+                , or_y_minor = ymin0 + ymaj1 + ymin1+                , or_y_major = ymaj0+                }+++-- | xmin and xmaj same as left.+--+halignBottomO :: (Num u, Ord u) +            => Orientation u -> Orientation u -> Orientation u+halignBottomO (Orientation xmin0 xmaj0 ymin0 ymaj0) +              (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let hr = ymin1 + ymaj1+    in Orientation { or_x_minor = xmin0+                   , or_x_major = xmaj0 + xmin1 + xmaj1+                   , or_y_minor = ymin0+                   , or_y_major = max ymaj0 (hr - ymin0)+                   }++++++-- | xmin same as left.+--+halignCenterO :: (Fractional u, Ord u) +              => Orientation u -> Orientation u -> Orientation u+halignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) +             (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let hl         = ymin0 + ymaj0+        hr         = ymin1 + ymaj1+        half_diff  = 0.5 * (hr - hl)+    in Orientation +          { or_x_minor = xmin0+          , or_x_major = xmaj0 + xmin1 + xmaj1+          , or_y_minor = if hl >= hr then ymin0 else (ymin0 + half_diff)+          , or_y_major = if hl >= hr then ymaj0 else (ymaj0 + half_diff)+          }++++-- | xmin and ymaj same as left.+--+halignTopO :: (Num u, Ord u) +           => Orientation u -> Orientation u -> Orientation u+halignTopO (Orientation xmin0 xmaj0 ymin0 ymaj0) +           (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let hr = ymin1 + ymaj1+    in Orientation { or_x_minor = xmin0+                   , or_x_major = xmaj0 + xmin1 + xmaj1+                   , or_y_minor = max ymin0 (hr - ymaj0)+                   , or_y_major = ymaj0+                   }++-- | Align second below - xmin and ymaj are same as left.+--+valignLeftO :: (Fractional u, Ord u) +            => Orientation u -> Orientation u -> Orientation u+valignLeftO (Orientation xmin0 xmaj0 ymin0 ymaj0) +            (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let wr = xmin1 + xmaj1+    in Orientation { or_x_minor = xmin0+                   , or_x_major = max xmaj0 (wr - xmin0)+                   , or_y_minor = ymin0 + ymin1 + ymaj1+                   , or_y_major = ymaj0+                   }++++-- | Align second below - ymaj same as left.+--+valignCenterO :: (Fractional u, Ord u) +             => Orientation u -> Orientation u -> Orientation u+valignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) +              (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let wl         = xmin0 + xmaj0+        wr         = xmin1 + xmaj1+        half_diff  = 0.5 * (wr - wl)+    in Orientation +          { or_x_minor = if wl >= wr then xmin0 else (xmin0 + half_diff)+          , or_x_major = if wl >= wr then xmaj0 else (xmaj0 + half_diff)+          , or_y_minor = ymin0 + ymin1 + ymaj1+          , or_y_major = ymaj0 +          }+++-- | Align second below - xmaj and ymaj are same as left.+--+valignRightO :: (Fractional u, Ord u) +             => Orientation u -> Orientation u -> Orientation u+valignRightO (Orientation xmin0 xmaj0 ymin0 ymaj0) +             (Orientation xmin1 xmaj1 ymin1 ymaj1) = +    let wr = xmin1 + xmaj1+    in Orientation { or_x_minor = max xmin0 (wr - xmaj0)+                   , or_x_major = xmaj0 +                   , or_y_minor = ymin0 + ymin1 + ymaj1+                   , or_y_major = ymaj0 +                   }+++--------------------------------------------------------------------------------+-- Binary start pos displacement++-- Note - these can be made a lot clearer...++upDown :: Num u => u -> u -> u+upDown u d = u - d++downUp :: Num u => u -> u -> u+downUp d u = negate d + u++-- | Move second right.+--+spinemoveH :: Num u => Orientation u -> Orientation u -> Vec2 u+spinemoveH op0 op1 = V2 hdist 0+  where+    hdist = or_x_major op0 + or_x_minor op1++-- | Move second below.+--+spinemoveV :: Num u => Orientation u -> Orientation u -> Vec2 u+spinemoveV op0 op1 = V2 0 (negate vdist)+  where+    vdist = or_y_minor op0 + or_y_major op1+   +++binmoveHBottom :: Num u => Orientation u -> Orientation u -> Vec2 u+binmoveHBottom op0 op1 = V2 hdist vdist+  where+    hdist = or_x_major op0 + or_x_minor op1+    vdist = downUp (or_y_minor op0) (or_y_minor op1)+   ++binmoveHCenter :: (Fractional u, Ord u) +               => Orientation u -> Orientation u -> Vec2 u+binmoveHCenter (Orientation _     xmaj0 ymin0 ymaj0) +               (Orientation xmin1 _     ymin1 ymaj1) = +    V2 hdist vdist+  where+    h0        = ymin0 + ymaj0+    h1        = ymin1 + ymaj1+    half_diff = abs $ 0.5 * (h1 - h0)+    hdist     = xmaj0 + xmin1+    vdist     = if h0 >= h1 then downUp ymin0 (half_diff + ymin1)+                            else upDown (ymaj0 + half_diff) ymaj1++++binmoveHTop :: Num u => Orientation u -> Orientation u -> Vec2 u+binmoveHTop op0 op1 = V2 hdist vdist+  where+    hdist = or_x_major op0 + or_x_minor op1+    vdist = upDown (or_y_major op0) (or_y_major op1)+++leftRight :: Num u => u -> u -> u+leftRight l r = negate l + r+++rightLeft :: Num u => u -> u -> u+rightLeft r l = r - l+++binmoveVLeft :: Num u => Orientation u -> Orientation u -> Vec2 u+binmoveVLeft op0 op1 = V2 hdist vdist+  where+    hdist = leftRight (or_x_minor op0) (or_x_minor op1)+    vdist = negate $ or_y_minor op0 + or_y_major op1+++binmoveVCenter :: (Fractional u, Ord u) +               => Orientation u -> Orientation u -> Vec2 u+binmoveVCenter (Orientation xmin0 xmaj0 ymin0 _) +               (Orientation xmin1 xmaj1 _     ymaj1) = +    V2 hdist vdist+  where+    w0        = xmin0 + xmaj0+    w1        = xmin1 + xmaj1+    half_diff = abs $ 0.5 * (w1 - w0)+    hdist     = if w0 >= w1 then leftRight xmin0 (half_diff + xmin1)+                            else rightLeft (xmaj0 + half_diff) xmaj1+    vdist     = negate $ ymin0 + ymaj1++++binmoveVRight :: Num u => Orientation u -> Orientation u -> Vec2 u+binmoveVRight op0 op1 = V2 hdist vdist+  where+    hdist = rightLeft (or_x_major op0) (or_x_major op1)+    vdist = negate $ or_y_minor op0 + or_y_major op1+
− src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs 
@@ -1,338 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel.Objects.TraceDrawing--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  unstable--- Portability :  GHC ------ Drawing with /trace/ - a Writer like monad collecting --- intermediate graphics - and /drawing context/ - a reader monad--- of attributes - font_face, fill_colour etc.--------------------------------------------------------------------------------------module Wumpus.Basic.Kernel.Objects.TraceDrawing-  (--    TraceDrawing-  , DTraceDrawing-  , TraceDrawingT-  , DTraceDrawingT--  , runTraceDrawing-  , execTraceDrawing-  , evalTraceDrawing-  , runTraceDrawingT-  , execTraceDrawingT-  , evalTraceDrawingT--  , liftToPictureU-  , liftToPictureMb-  , mbPictureU- --  , query-  , draw-  , xdraw-  , drawi-  , drawi_-  , xdrawi-  , xdrawi_--  , node-  , nodei--  ) where---import Wumpus.Basic.Kernel.Base.BaseDefs-import Wumpus.Basic.Kernel.Base.ContextFun-import Wumpus.Basic.Kernel.Base.DrawingContext-import Wumpus.Basic.Kernel.Base.WrappedPrimitive-import Wumpus.Basic.Kernel.Objects.BaseObjects-import Wumpus.Basic.Kernel.Objects.Graphic--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative-import Control.Monad-import Data.Monoid------ Note - TraceDrawing run \once\ - it is supplied with the starting--- environment (DrawingContext) and returns a Picture.------ Other Wumpus monads (e.g. Turtle) will typically be run inside--- the TraceDrawing monad as a local effect, rather than built into a --- transformer stack.------newtype TraceDrawing u a   = TraceDrawing { -          getTraceDrawing :: DrawingContext -> (a, HPrim u) }--newtype TraceDrawingT u m a = TraceDrawingT { -          getTraceDrawingT :: DrawingContext -> m (a, HPrim u) }---type DTraceDrawing a    = TraceDrawing Double a-type DTraceDrawingT m a = TraceDrawingT Double m a----type instance MonUnit (TraceDrawing u) = u-type instance MonUnit (TraceDrawingT u m) = u------ 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)------ 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 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 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)---instance Monad m => TraceM (TraceDrawingT u m) where-  trace a = TraceDrawingT $ \_ -> return ((), a)------ DrawingCtxM--instance DrawingCtxM (TraceDrawing u) where-  askDC           = TraceDrawing $ \ctx -> (ctx, mempty)-  localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx)----instance Monad m => DrawingCtxM (TraceDrawingT u m) where-  askDC           = TraceDrawingT $ \ctx -> return (ctx,mempty)-  localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx)------ 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 :: 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---- | Run the drawing ignoring the output it produces, return the --- answer from the monadic computation.------ Note - this useful for testing, generally one would want the --- opposite behaviour (return the drawing, ignore than the --- answer).--- -evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a-evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma----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.--- -liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u-liftToPictureU hf = -    let prims = hprimToList hf in if null prims then errK else frame prims-  where-    errK = error "toPictureU - empty prims list."---- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@.------ If the HPrim is empty, then @Nothing@ is returned.--- -liftToPictureMb :: (Real u, Floating u, FromPtSize u) -                => HPrim u -> Maybe (Picture u)-liftToPictureMb hf = let prims = hprimToList hf in -    if null prims then Nothing else Just (frame prims)------ | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@.------ This is equivalent to:------ > fromMaybe (error "empty") $ pic------ This function is solely a convenience, using it saves one --- import and a few characters.------ If the supplied value is @Nothing@ a run-time error is thrown.--- -mbPictureU :: (Real u, Floating u, FromPtSize u) -           => Maybe (Picture u) -> Picture u-mbPictureU Nothing  = error "mbPictureU - empty picture."-mbPictureU (Just a) = a---- Note - need an equivalent to Parsec\`s parseTest that provides--- a very simple way to run graphics without concern for return --- type or initial drawing context.------------------------------------------------------------------------------------query :: DrawingCtxM m => CF a -> m a-query df = askDC >>= \ctx -> return $ runCF ctx df----- | Draw a Graphic taking the drawing style from the --- /drawing context/. ------ This operation is analogeous to @tell@ in a Writer monad.--- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m ()-draw gf = askDC >>= \ctx -> trace (collectH $ snd $ runCF ctx gf)---- | Hyperlink version of 'draw'.----xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) -      => XLink -> Graphic u -> m ()-xdraw xl gf = draw (hyperlink xl gf)------ | Draw an Image taking the drawing style from the --- /drawing context/. ------ The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned.--- -drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a-drawi img = askDC >>= \ctx -> -            let (a,o) = runCF ctx img in trace (collectH o) >> return a---- | Forgetful 'drawi'.----drawi_ ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u) => Image u a -> m ()-drawi_ img = drawi img >> return ()----- | Hyperlink version of 'drawi'.----xdrawi ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u) -       => XLink -> Image u a -> m a-xdrawi xl img = drawi (hyperlink xl img)----- | Forgetful 'xdrawi'.----xdrawi_ ::  (TraceM m, DrawingCtxM m, MonUnit m ~ u)-        => XLink -> Image u a -> m ()-xdrawi_ xl img = xdrawi xl img >> return ()-----node :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) -     => LocGraphic u -> m ()-node gf = askDC    >>= \ctx -> -          position >>= \pt  -> -          let (_,prim) = runCF1 ctx pt gf in trace (collectH prim)---nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) -     => LocImage u a -> m a-nodei imgL = askDC    >>= \ctx -> -             position >>= \pt  -> -             let (a,o) = runCF ctx (apply1R1 imgL pt)-             in trace (collectH o) >> return a-
+ src/Wumpus/Basic/Kernel/Objects/Trail.hs view
@@ -0,0 +1,1042 @@+{-# LANGUAGE TypeFamilies               #-}+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Kernel.Objects.Trial+-- Copyright   :  (c) Stephen Tetley 2011+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- /Trails/ - prototype paths. Less resource heavy than the Path+-- object in Wumpus-Drawing.+-- +-- @CatTrail@ supports concatenation. @AnaTrail@ supports +-- /initial displacement/ - this can account for drawing +-- rectangles from their center, for example.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Kernel.Objects.Trail+  (++  -- * Trail types+    TrailSegment(..)+  , CatTrail+  , AnaTrail++  -- * Trail operations+  , renderAnaTrail+  , renderCatTrail++  , destrAnaTrail+  , destrCatTrail++  , anaCatTrail+  , modifyAna+  +  , trailIterateLocus++  , anaTrailPoints+++  , catline+  , catcurve+  , orthoCatTrail++  , diffCurve+  , diffLines+  ++  -- * Shape trails+  , rectangleTrail+  , diamondTrail+  , polygonTrail+  , wedgeTrail+++  -- * Named Trail constructors+  , trail_up+  , trail_down+  , trail_left+  , trail_right++  , trail_north+  , trail_south+  , trail_east+  , trail_west+  , trail_north_east+  , trail_north_west+  , trail_south_east+  , trail_south_west++  , trail_up_left+  , trail_up_right+  , trail_down_left+  , trail_down_right++  , trail_para+  , trail_perp++  , trail_theta_up+  , trail_theta_down+  , trail_theta_left+  , trail_theta_right++  , trail_theta_north+  , trail_theta_south+  , trail_theta_east+  , trail_theta_west+  , trail_theta_north_east+  , trail_theta_north_west+  , trail_theta_south_east+  , trail_theta_south_west++  , trail_theta_up_left+  , trail_theta_up_right+  , trail_theta_down_left+  , trail_theta_down_right++  , trail_theta_adj_grazing+  , trail_theta_bkwd_adj_grazing++++  , semicircleTrail+  , semiellipseTrail+  , minorCircleSweep+  , circleSweep+  , circularArc++  , sineWave+  , sineWave1+  , squareWave+  , sawtoothWave+  , squiggleWave+  , semicircleWave++  , triCurve+  , rectCurve+  , trapCurve+  , bowCurve+  , wedgeCurve+  , loopCurve++  ) where++import Wumpus.Basic.Kernel.Base.BaseDefs+import Wumpus.Basic.Kernel.Base.QueryDC+import Wumpus.Basic.Kernel.Objects.Displacement+import Wumpus.Basic.Kernel.Objects.DrawingPrimitives+import Wumpus.Basic.Kernel.Objects.Image+import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Utils.HList++import Wumpus.Core                              -- package: wumpus-core++import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace++import Data.List ( unfoldr )+import Data.Monoid+++--------------------------------------------------------------------------------+-- Trail types ++-- | Trail with an initial (undrawn) displacement - an anacrusis.+--+-- This allows trails to represent centered objects.+--+data AnaTrail u = AnaTrail+      { pt_init_vec :: Vec2 u+      , pt_segments :: [TrailSegment u]+      }+  deriving (Eq,Ord,Show)++type instance DUnit (AnaTrail u) = u++-- | Trail supporting concatenation.+--+newtype CatTrail u = CatTrail { getCatTrail :: H (TrailSegment u) }++type instance DUnit (CatTrail u) = u+++-- | Trail segment - trails are /prototype/ paths, so the are +-- built from the usual straight lines and Bezier curves.+--+data TrailSegment u = TLine (Vec2 u)+                    | TCurve (Vec2 u) (Vec2 u) (Vec2 u)+  deriving (Eq,Ord,Show)++type instance DUnit (TrailSegment u) = u+++instance Functor TrailSegment where+  fmap f (TLine v1)        = TLine $ fmap f v1+  fmap f (TCurve v1 v2 v3) = TCurve (fmap f v1) (fmap f v2) (fmap f v3)+++instance Monoid (CatTrail u) where+  mempty        = CatTrail emptyH+  a `mappend` b = CatTrail $ getCatTrail a `appendH` getCatTrail b+++--------------------------------------------------------------------------------+-- Trail operations++-- | Render a 'CatTrail' to make a drawable 'LocGraphic'.+--+renderCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u+renderCatTrail mode (CatTrail ct) = promoteLoc $ \pt -> +    drawTrailBody mode (toListH ct) pt +++-- | Render an 'AnaTrail' to make a drawable 'LocGraphic'.+--+renderAnaTrail :: InterpretUnit u => PathMode -> AnaTrail u -> LocGraphic u+renderAnaTrail mode (AnaTrail v0 xs) = promoteLoc $ \pt -> +    drawTrailBody mode xs (pt .+^ v0)+++-- | Note - this optimizes contiguous lines that share the same +-- direction. +--+drawTrailBody :: InterpretUnit u +              => PathMode -> [TrailSegment u] -> Point2 u -> Graphic u+drawTrailBody mode ts pt = +    normalizeCtxF pt >>= \dpt -> +    mapM normalizeCtxF ts >>= \dxs ->+    dcPath mode $ relPrimPath dpt $ stepA id dxs+  where+    stepA f []                   = toListH f+    stepA f (TLine v1:ys)        = stepB f (vdirection v1) v1 ys+    stepA f (TCurve v1 v2 v3:ys) = stepA (f `snocH` relCurveTo v1 v2 v3) ys++    stepB f dir v0 (TLine v1:ys) +        | vdirection v1 == dir   = stepB f dir (v0 ^+^ v1) ys+    stepB f _   v0 ys            = stepA (f `snocH` relLineTo v0) ys+++-- | /Destructor/ for the opaque 'AnaTrail' type.+--+destrAnaTrail :: AnaTrail u -> (Vec2 u, [TrailSegment u])+destrAnaTrail (AnaTrail v0 ss) = (v0,ss)++-- | /Destructor/ for the opaque 'CatTrail' type.+--+destrCatTrail :: CatTrail u -> [TrailSegment u]+destrCatTrail = toListH . getCatTrail++++-- | Turn a 'CatTrail' into a 'AnaTrail'.+--+anaCatTrail :: Vec2 u -> CatTrail u -> AnaTrail u+anaCatTrail vinit cat = AnaTrail { pt_init_vec = vinit+                                 , pt_segments = getCatTrail cat []+                                 }+++modifyAna :: (Vec2 u -> Vec2 u) -> AnaTrail u -> AnaTrail u+modifyAna upd (AnaTrail v1 body) = AnaTrail (upd v1) body++-- | Create a AnaTrail from the vector list - each vector in the +-- input list iterates to the start point rather then the +-- cumulative tip.+--+-- When the AnaTrail is run, the supplied point is the /locus/ of +-- the path and it does not form part of the path proper.+-- +-- Like 'trailStartIsLocus', this constructor is typically used to +-- make /shape paths/. Some shapes are easier to express as +-- iterated displacements of the center rather than +-- /turtle drawing/. +-- +trailIterateLocus :: Num u => [Vec2 u] -> AnaTrail u+trailIterateLocus []      = AnaTrail zeroVec []+trailIterateLocus (v0:xs) = AnaTrail v0 (step v0 xs)+  where+    step v1 []      = [ TLine (v0 ^-^ v1) ]+    step v1 (v2:vs) = TLine (v2 ^-^ v1) : step v2 vs+++anaTrailPoints :: InterpretUnit u => AnaTrail u -> LocQuery u [Point2 u]+anaTrailPoints (AnaTrail v0 ts) = qpromoteLoc $ \pt -> +    return $ step (pt .+^ v0) ts+  where+    step p1 []                    = [p1]+    step p1 (TLine v1:xs)         = p1 : step (p1 .+^ v1) xs+    step p1 (TCurve v1 v2 v3 :xs) = let p2 = p1 .+^ v1+                                        p3 = p2 .+^ v2+                                        p4 = p3 .+^ v3 +                                    in p1 : p2 : p3 : step p4 xs+++catline :: Vec2 u -> CatTrail u +catline = CatTrail . wrapH . TLine+++-- | Alternative to @catline@, specifying the vector components +-- rather the vector itself.+--+-- (cf. orthoVec from Wumpus-Core)+--+orthoCatTrail :: Floating u => u -> u -> Radian -> CatTrail u +orthoCatTrail x y ang = catline (orthoVec x y ang)+++catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u+catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3++-- | Form a Bezier CatTrail from the vectors between four control +-- points.+--+diffCurve :: Num u +          => Point2 u -> Point2 u -> Point2 u -> Point2 u -> CatTrail u+diffCurve p0 p1 p2 p3 = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)++++-- | Form a CatTrail from the linear segment joining the list of +-- points.+-- +-- Some configurations of vectors seem easier to specify using +-- located points then making them coordinate free by taking +-- the joining vectors.+--+diffLines :: Num u => [Point2 u] -> CatTrail u+diffLines []     = mempty+diffLines (x:xs) = step mempty x xs +  where+    step ac a (b:bs) = step (ac `mappend` catline (pvec a b)) b bs+    step ac _ []     = ac++++--------------------------------------------------------------------------------+-- Shape Trails++-- | 'rectangleTrail' : @ width * height -> AnaTrail @+--+rectangleTrail :: Fractional u => u -> u -> AnaTrail u+rectangleTrail w h = +    AnaTrail { pt_init_vec = ctr_to_bl +             , pt_segments = map TLine spec+             }+  where+    ctr_to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)+    spec      = [ go_right w, go_up h, go_left w, go_down h ]+++++-- | 'diamondTrail' : @ half_width * half_height -> AnaTrail @+--+diamondTrail :: Num u => u -> u -> AnaTrail u+diamondTrail hw hh = trailIterateLocus [ vs,ve,vn,vw ]+  where+    vs = vvec (-hh)+    ve = hvec hw+    vn = vvec hh+    vw = hvec (-hw)+++-- | 'polygonTrail' : @ num_points * radius -> AnaTrail @ +--+polygonTrail :: Floating u => Int -> u -> AnaTrail u+polygonTrail n radius = trailIterateLocus $ unfoldr phi (0,top)+  where+    top                     = 0.5*pi+    theta                   = (2*pi) / fromIntegral n+    +    phi (i,ang) | i < n     = Just (avec ang radius, (i+1,ang+theta))+                | otherwise = Nothing++++-- | wedgeTrail : radius * apex_angle+-- +-- Wedge is drawn at the apex.+--+wedgeTrail :: (Real u, Floating u) +           => u -> Radian -> Radian -> AnaTrail u+wedgeTrail radius ang theta = +    anaCatTrail zeroVec $ line_in `mappend` w_arc `mappend` line_out+  where+    half_ang = 0.5 * ang +    line_in  = catline $ avec (theta + half_ang)   radius+    line_out = catline $ avec (theta - half_ang) (-radius)+    w_arc    = circularArcCW ang radius (theta - half_pi)++++--------------------------------------------------------------------------------+-- Named Trail constructors++trail_up :: Num u => u -> CatTrail u+trail_up = catline . go_up++trail_down :: Num u => u -> CatTrail u+trail_down = catline . go_down++trail_left :: Num u => u -> CatTrail u+trail_left = catline . go_left++trail_right :: Num u => u -> CatTrail u+trail_right = catline . go_right+++trail_north :: Num u => u -> CatTrail u+trail_north = trail_up++trail_south :: Num u => u -> CatTrail u+trail_south = catline . go_down++trail_east :: Num u => u -> CatTrail u+trail_east = catline . go_right++trail_west :: Num u => u -> CatTrail u+trail_west = catline . go_left+++trail_north_east :: Floating u => u -> CatTrail u+trail_north_east = catline . go_north_east++trail_north_west :: Floating u => u -> CatTrail u+trail_north_west = catline . go_north_west++trail_south_east :: Floating u => u -> CatTrail u+trail_south_east = catline . go_south_east++trail_south_west :: Floating u => u -> CatTrail u+trail_south_west = catline . go_south_west+++trail_up_left :: Num u => u -> CatTrail u+trail_up_left = catline . go_up_left++trail_up_right :: Num u => u -> CatTrail u+trail_up_right = catline . go_up_right++trail_down_left :: Num u => u -> CatTrail u+trail_down_left = catline . go_down_left++trail_down_right :: Num u => u -> CatTrail u+trail_down_right = catline . go_down_right+++trail_perp :: Floating u => u -> Radian -> CatTrail u+trail_perp = trail_theta_up++trail_para :: Floating u => u -> Radian -> CatTrail u+trail_para = trail_theta_right+++trail_theta_up :: Floating u => u -> Radian -> CatTrail u+trail_theta_up u = catline . theta_up u++trail_theta_down :: Floating u => u -> Radian -> CatTrail u+trail_theta_down u = catline . theta_down u++trail_theta_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_left u = catline . theta_left u++trail_theta_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_right u = catline . theta_right u+++trail_theta_north :: Floating u => u -> Radian -> CatTrail u+trail_theta_north = trail_theta_up++trail_theta_south :: Floating u => u -> Radian -> CatTrail u+trail_theta_south = trail_theta_down++trail_theta_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_east = trail_theta_right++trail_theta_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_west = trail_theta_left+++trail_theta_north_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_north_east u = catline . theta_north_east u++trail_theta_north_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_north_west u = catline . theta_north_west u++trail_theta_south_east :: Floating u => u -> Radian -> CatTrail u+trail_theta_south_east u = catline . theta_south_east u++trail_theta_south_west :: Floating u => u -> Radian -> CatTrail u+trail_theta_south_west u = catline . theta_south_west u+++trail_theta_up_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_up_left u = catline . theta_up_left u++trail_theta_up_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_up_right u = catline . theta_up_right u++trail_theta_down_left :: Floating u => u -> Radian -> CatTrail u+trail_theta_down_left u = catline . theta_down_left u++trail_theta_down_right :: Floating u => u -> Radian -> CatTrail u+trail_theta_down_right u = catline . theta_down_right u++++-- | Return the line @a-o@ when supplied length of @b-o@ and the +-- grazing angle @boa@:+--+-- >    a+-- >    .\+-- >    . \+-- >  ..b..o+--+-- This is useful for building arrowhead vectors.+--+trail_theta_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u +trail_theta_adj_grazing adj_len ang = +    catline . theta_adj_grazing adj_len ang+++-- | Return the line @o-c@ when supplied length of @b-o@ and the +-- grazing angle @boc@:+--+--+-- >  ..b..o+-- >    . /+-- >    ./+-- >    c+--+-- This is useful for building arrowhead vectors.+--+trail_theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u +trail_theta_bkwd_adj_grazing adj_len ang = +    catline . theta_bkwd_adj_grazing adj_len ang +++--------------------------------------------------------------------------------++--+-- DESIGN NOTE+--+-- Angle, unit width and number of repetitions (plus height etc.) +-- seems the best API, although this make fitting an issue.+--+++sineWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u+sineWave i unit ang = +    mconcat $ replicate i $ sineWave1 (0.25 * unit) unit ang+++-- | One-phase sine wave. Height is parametric.+--+sineWave1 :: (Real u, Floating u)+              => u -> u -> Radian -> CatTrail u+sineWave1 h unit ang = +              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)+  where+    base1 = unit / 12+    h2    = h * (pi / 6)+    v1    = orthoVec     base1    h2  ang+    v2    = orthoVec  (2*base1)   h   ang+    v3    = orthoVec  (3*base1)   h   ang+    v4    = orthoVec  (4*base1)   h   ang+    v5    = orthoVec  (5*base1)   h2  ang+    v6    = orthoVec  (6*base1)   0   ang+    v7    = orthoVec  (7*base1) (-h2) ang+    v8    = orthoVec  (8*base1) (-h)  ang+    v9    = orthoVec  (9*base1) (-h)  ang+    v10   = orthoVec (10*base1) (-h)  ang+    v11   = orthoVec (11*base1) (-h2) ang+    v12   = orthoVec (12*base1)   0   ang++++kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3)+++--+-- DESIGN NOTE +--+-- The API seems better exposing ClockDirection as an argument +-- rather than providing two different functions for CW and CCW +-- (even though some functions are defined by independent CW and +-- CCW versions).+--+++-- | 'semicircleCW' : @ base_vector -> CatTrail @ +-- +-- Make an open semicircle from two Bezier curves. +--+-- Although this function produces an approximation of a +-- semicircle, the approximation seems fine in practice.+--+semicircleTrail :: (Real u, Floating u) +                => ClockDirection -> Vec2 u -> CatTrail u+semicircleTrail CW = semicircleCW+semicircleTrail _  = semicircleCCW++-- | 'semicircleCW' : @ base_vector -> CatTrail @ +-- +-- Make a clockwise semicircle from two Bezier curves. Although +-- this function produces an approximation of a semicircle, the +-- approximation seems fine in practice.+--+semicircleCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+semicircleCW base_vec =+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)+  where+    circum  = vlength base_vec+    radius  = 0.5 * circum+    ang     = vdirection base_vec+    rl      = radius * kappa+    +    v1      = orthoVec 0 rl ang+    v2      = orthoVec (radius - rl) radius ang+    v3      = orthoVec radius radius ang++    v4      = orthoVec (radius + rl) radius ang+    v5      = orthoVec circum rl ang+    v6      = orthoVec circum 0 ang+++-- | 'semicircleCCW' : @ base_vector_vector -> CatTrail @ +-- +-- Make a counter-clockwise semicircle from two Bezier curves. +-- Although this function produces an approximation of a +-- semicircle, the approximation seems fine in practice.+--+semicircleCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u+semicircleCCW base_vec =+              catcurve  v1           (vdiff v1 v2) (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4) (vdiff v4 v5) (vdiff v5 v6)+  where+    circum  = vlength base_vec+    radius  = 0.5 * circum+    ang     = vdirection base_vec+    rl      = radius * kappa+    +    v1      = orthoVec 0 (-rl) ang+    v2      = orthoVec (radius - rl) (-radius) ang+    v3      = orthoVec radius (-radius) ang++    v4      = orthoVec (radius + rl) (-radius) ang+    v5      = orthoVec circum (-rl) ang+    v6      = orthoVec circum 0 ang+++-- | 'semicircleTrail' : @ clock_direction * ry * base_vector -> CatTrail @ +-- +-- Make an open semiellipse from two Bezier curves. +--+-- Although this function produces an approximation of a +-- semiellipse, the approximation seems fine in practice.+--+semiellipseTrail :: (Real u, Floating u) +               => ClockDirection -> u -> Vec2 u -> CatTrail u+semiellipseTrail CW = semiellipseBasis theta_up+semiellipseTrail _  = semiellipseBasis theta_down++++-- | theta_up for CW, theta_down for CCW...+--+semiellipseBasis :: (Real u, Floating u) +                 => (u -> Radian -> Vec2 u) -> u -> Vec2 u -> CatTrail u+semiellipseBasis perpfun ry base_vec = +              catcurve (pvec p00 c01) (pvec c01 c02) (pvec c02 p03)+    `mappend` catcurve (pvec p03 c04) (pvec c04 c05) (pvec c05 p06) +  where+    rx    = 0.5 * vlength base_vec+    ang   = vdirection base_vec+    lrx   = rx * kappa+    lry   = ry * kappa+    para  = theta_right `flip` ang+    perp  = perpfun `flip` ang++    p00   = zeroPt .+^ theta_left rx ang+    c01   = p00 .+^ perp lry+    c02   = p03 .+^ para (-lrx)++    p03   = zeroPt .+^ perpfun ry ang  +    c04   = p03 .+^ para lrx+    c05   = p06 .+^ perp lry++    p06   = zeroPt .+^ theta_right rx ang+++-- | 'minorCircleSweep' : @ clock_direction * angle * radius +--      * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweep :: (Real u, Floating u)+                 => ClockDirection -> Radian -> u -> Radian -> CatTrail u+minorCircleSweep CW = minorCircleSweepCW +minorCircleSweep _  = minorCircleSweepCCW+++-- | 'minorCircleSweepCW' : @ angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweepCW :: (Real u, Floating u)+                   => Radian -> u -> Radian -> CatTrail u+minorCircleSweepCW ang radius theta = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ theta + (half_pi - ang)++    p0      = displace (theta_up    radius theta) zeroPt+    p1      = displace (theta_right rl     theta) p0+    p2      = displace (theta_up    rl     totang) p3+    p3      = displace (avec totang radius) zeroPt+++-- | 'minorCircleSweepCCW' : @ angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweepCCW :: (Real u, Floating u)+                    => Radian -> u -> Radian -> CatTrail u+minorCircleSweepCCW ang radius theta = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ theta - half_pi + ang++    p0      = displace (theta_down  radius theta) zeroPt+    p1      = displace (theta_right rl     theta) p0+    p2      = displace (theta_down  rl     totang) p3+    p3      = displace (avec totang radius) zeroPt+++-- | 'circleSweep' : @ clock_direction * apex_angle * radius +--      * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweep :: (Real u, Floating u)+            => ClockDirection -> Radian -> u -> Radian -> CatTrail u+circleSweep CW = circleSweepCW+circleSweep _  = circleSweepCCW+++-- | 'circleSweepCW' : @ apex_angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweepCW :: (Real u, Floating u)+              => Radian -> u -> Radian -> CatTrail u+circleSweepCW ang radius theta = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a =           minorCircleSweepCW a radius theta++    wedge2 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta-a)++    wedge3 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta - a)+               `mappend` minorCircleSweepCW a radius (theta - 2*a)+  +    wedge4 a =           minorCircleSweepCW a radius theta+               `mappend` minorCircleSweepCW a radius (theta - a)+               `mappend` minorCircleSweepCW a radius (theta - 2*a)+               `mappend` minorCircleSweepCW a radius (theta - 3*a)+++++-- | 'circleSweepCCW' : @ apex_angle * radius * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweepCCW :: (Real u, Floating u)+               => Radian -> u -> Radian -> CatTrail u+circleSweepCCW ang radius theta = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a =           minorCircleSweepCCW a radius theta++    wedge2 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)++    wedge3 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a)+  +    wedge4 a =           minorCircleSweepCCW a radius theta+               `mappend` minorCircleSweepCCW a radius (theta+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a)+               `mappend` minorCircleSweepCCW a radius (theta+a+a+a)++circularArc :: (Real u, Floating u) +            => ClockDirection -> Radian -> u -> Radian -> CatTrail u +circularArc CW = circularArcCW+circularArc _  = circularArcCCW+++-- | inclination is the inclination of the chord.+--+circularArcCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u +circularArcCW apex_ang radius inclin = +    circleSweepCW apex_ang radius (inclin + 0.5 * apex_ang)+++-- | inclination is the inclination of the chord.+--+circularArcCCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u +circularArcCCW apex_ang radius inclin = +    circleSweepCCW apex_ang radius (inclin - 0.5 * apex_ang)+++-- | Proper semicircles do not make a good squiggle (it needs a +-- bit of pinch).+--+squiggleWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u+squiggleWave i unit ang = mconcat $ replicate i $ squiggle1 unit ang+    +squiggle1 :: (Real u, Floating u) => u -> Radian -> CatTrail u+squiggle1 unit ang = +              catcurve  v1            (vdiff v1 v2)   (vdiff v2 v3)+    `mappend` catcurve (vdiff v3 v4)  (vdiff v4 v5)   (vdiff v5 v6)+    `mappend` catcurve (vdiff v6 v7)  (vdiff v7 v8)   (vdiff v8 v9)+    `mappend` catcurve (vdiff v9 v10) (vdiff v10 v11) (vdiff v11 v12)+  where+    four_radius   = unit+    radius        = 0.25 * four_radius+    two_radius    = 0.5  * four_radius+    three_radius  = 0.75 * four_radius+    rl            = radius * kappa+    micro         = 0.33 * rl           -- seems good+    +    v1            = orthoVec micro rl ang+    v2            = orthoVec (radius - rl) radius ang+    v3            = orthoVec radius radius ang++    v4            = orthoVec (radius + rl) radius ang+    v5            = orthoVec (two_radius - micro) rl ang+    v6            = orthoVec two_radius  0 ang++    v7            = orthoVec (two_radius + micro) (-rl) ang+    v8            = orthoVec (three_radius - rl) (-radius) ang+    v9            = orthoVec three_radius (-radius) ang++    v10           = orthoVec (three_radius + rl) (-radius) ang+    v11           = orthoVec (four_radius - micro) (-rl) ang+    v12           = orthoVec four_radius 0 ang++    ++squareWave :: Floating u => Int -> u -> Radian -> CatTrail u +squareWave n unit ang +    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin+    | otherwise = mempty+  where+    up_half     = catline $ theta_up    (0.25 * unit) ang+    up_one      = catline $ theta_up    (0.5  * unit) ang+    down_one    = catline $ theta_down  (0.5  * unit) ang+    right_half  = catline $ theta_right (0.5  * unit) ang++    kont        = right_half `mappend` down_one `mappend` right_half+                             `mappend` up_one++    fin         = right_half `mappend` down_one `mappend` right_half+                             `mappend` up_half+++++-- |+--  +sawtoothWave :: (Real u, Floating u) => Int -> u -> Radian -> CatTrail u +sawtoothWave n unit ang +    | n >  0    = monPreRepeatPost up_half (n - 1,kont) fin+    | otherwise = mempty+  where+    up_half  = catline $ theta_up_right (0.25 * unit) ang+    up_one   = catline $ theta_up_right (0.5  * unit) ang+    down_one = catline $ theta_down_right (0.5 * unit) ang++    kont     = down_one `mappend` up_one+    fin      = down_one `mappend` up_half++++semicircleWave :: (Real u, Floating u) +               => ClockDirection -> Int -> u -> Radian -> CatTrail u+semicircleWave cdir i unit ang = +    mconcat $ replicate i $ fn cdir (avec ang unit)+  where+    fn CCW = semicircleCCW+    fn _   = semicircleCW++++--------------------------------------------------------------------------------++-- | 'triCurve' : @ clock_direction * base_width * height * +--      base_inclination -> CatTrail @+-- +-- Curve in a triangle - base_width and height are expected to +-- be positive.+-- +triCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u+triCurve CW  bw h ang = ctriCW bw h ang+triCurve CCW bw h ang = ctriCW bw (-h) ang+++-- | Curve in a triangle.+-- +ctriCW :: Floating u => u -> u -> Radian -> CatTrail u+ctriCW bw h ang = catcurve v1 zeroVec v2+  where+    v1 = orthoVec (0.5 * bw) h ang+    v2 = orthoVec (0.5 * bw) (-h) ang+++-- | 'rectCurve' : @ clock_direction * base_width * height * +--      base_inclination -> CatTrail @+-- +-- Curve in a rectangle.+-- +rectCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u+rectCurve CW  bw h ang = crectCW bw h ang+rectCurve CCW bw h ang = crectCW bw (-h) ang+++-- | Curve in a rectangle.+-- +crectCW :: Floating u => u -> u -> Radian -> CatTrail u+crectCW bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec 0    h  ang+    v2 = orthoVec bw   0  ang+    v3 = orthoVec 0  (-h) ang++++-- | Curve in a trapezium.+-- +trapCurve :: Floating u +          => ClockDirection -> u -> u -> Radian -> Radian -> CatTrail u+trapCurve CW  = ctrapCW+trapCurve CCW = ctrapCCW++-- | Curve in a trapezium (CW).+-- +-- h must be positive.+--+ctrapCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+ctrapCW bw h interior_ang ang = catcurve v1 v2 v3+  where+    minor_bw = h / (fromRadian $ tan interior_ang)+    v1       = orthoVec minor_bw                h  ang+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang+    v3       = orthoVec minor_bw              (-h) ang++-- | Curve in a trapezium (CCW).+-- +-- h must be positive.+--+ctrapCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+ctrapCCW bw h interior_ang ang = catcurve v1 v2 v3+  where+    minor_bw = h / (fromRadian $ tan interior_ang)+    v1       = orthoVec minor_bw              (-h)  ang+    v2       = orthoVec (bw - (2 * minor_bw))   0  ang+    v3       = orthoVec minor_bw                h ang++-- | Curve in half a /bowtie/.+-- +bowCurve :: Floating u +         => ClockDirection -> u -> u -> Radian -> CatTrail u+bowCurve CW  bw h ang = cbowCW bw h ang+bowCurve CCW bw h ang = cbowCW bw (-h) ang++-- | Curve in half a /bowtie/.+-- +cbowCW :: Floating u => u -> u -> Radian -> CatTrail u+cbowCW bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec 0    h  ang+    v2 = orthoVec bw (-h)  ang+    v3 = orthoVec 0    h ang+++-- | Wedge curve formed inside a bowtie rotated by 90deg.+-- +wedgeCurve :: Floating u +           => ClockDirection -> u -> u -> Radian -> CatTrail u+wedgeCurve CW  bw h ang = cwedgeCW bw h ang+wedgeCurve CCW bw h ang = cwedgeCW bw (-h) ang++-- | Wedge curve clockwise.+-- +cwedgeCW :: Floating u => u -> u -> Radian -> CatTrail u+cwedgeCW bw h ang = catcurve v1 v2 v3+  where+    v1 = orthoVec   bw    h  ang+    v2 = orthoVec (-bw)   0  ang+    v3 = orthoVec   bw  (-h) ang+++-- | Variation of wedge curve that draws a loop.+-- +loopCurve :: Floating u +          => ClockDirection -> u -> u -> Radian -> CatTrail u+loopCurve CW  bw h ang = cloopCW bw h ang+loopCurve CCW bw h ang = cloopCW bw (-h) ang+++-- | loop curve clockwise.+-- +cloopCW :: Floating u => u -> u -> Radian -> CatTrail u+cloopCW bw h ang = catcurve v1 v2 v3+  where+    ww = 2.0 * bw +    v1 = orthoVec  (1.5 * bw)    h  ang+    v2 = orthoVec  (-ww)         0  ang+    v3 = orthoVec  (1.5 * bw)  (-h) ang
+ src/Wumpus/Basic/System/FontLoader.hs view
@@ -0,0 +1,143 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader+-- Copyright   :  (c) Stephen Tetley 2011-2012+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Top level module for font loading...+--+--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader+  (+    FontLoader+  , afmLoaderByEnv+  , gsLoaderByEnv+  , simpleFontLoader++  , default_font_loader_help++  ) where++import Wumpus.Basic.Kernel.Base.FontSupport  +import Wumpus.Basic.System.FontLoader.AfmTopLevel+import Wumpus.Basic.System.FontLoader.GSTopLevel++import Control.Monad+import Control.Exception ( try )+import System.Environment+-- import System.IO.Error+++++-- | A FontLoader is an action from a list of fonts to a+-- 'FontLoadResult' returned in @IO@.+-- +-- Fonts are supplied in a list of @Either FontDef FontFamily@,+-- this is a little cumbersome but it allows the loader to load+-- individual fonts and \/ or a whole families with a single API+-- call.+--+type FontLoader = [Either FontDef FontFamily] -> IO FontLoadResult++++++-- | Environment variable pointing to the GhostScript font+-- directory.+-- +-- > WUMPUS_GS_FONT_DIR+--+wumpus_gs_font_dir :: String+wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR"+++-- | Environment variable pointing to the diretory containing +-- the Adobe Font Metrics files.+-- +-- > WUMPUS_AFM_FONT_DIR+--+wumpus_afm_font_dir :: String+wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR"++++afmLoaderByEnv :: IO (Maybe FontLoader)+afmLoaderByEnv = do +    mb <- envLookup wumpus_afm_font_dir+    case mb of +      Nothing   -> return Nothing+      Just path -> return $ Just (\xs -> loadAfmFontMetrics path $ fontList xs)+++gsLoaderByEnv :: IO (Maybe FontLoader)+gsLoaderByEnv = do+    mb <- envLookup wumpus_gs_font_dir+    case mb of+      Nothing   -> return Nothing+      Just path -> return $ Just (\xs -> loadGSFontMetrics path $ fontList xs)+++-- | Tries to find the GhostScript metrics first...+--+-- Runs the IO action on the loader if it finds one.+--+-- Either of one of the environment variables +-- @WUMPUS_AFM_FONT_DIR@ or @WUMPUS_GS_FONT_DIR@ must be defined+-- and point to their respective directory. +-- +simpleFontLoader :: (FontLoader -> IO a) ->  IO (Maybe a)+simpleFontLoader mf = +    gsLoaderByEnv >>= maybe fk1 sk +  where+   fk1       = afmLoaderByEnv >>= maybe fk2 sk+   fk2       = putStrLn default_font_loader_help >> return Nothing+   sk loader = mf loader >>= return . Just+++envLookup :: String -> IO (Maybe String)+envLookup name = liftM fn $ try $ getEnv name+  where+    fn :: Either IOError String -> Maybe String+    fn (Left _)  = Nothing+    fn (Right a) = Just a++   ++fontList :: [Either FontDef FontFamily] -> [FontDef]+fontList = foldr fn []+  where+    fn (Left a)  acc = a:acc+    fn (Right b) acc = let f1 = maybe id (\a -> (a:)) $ ff_bold b+                           f2 = maybe id (\a -> (a:)) $ ff_italic b+                           f3 = maybe id (\a -> (a:)) $ ff_bold_italic b+                     in ff_regular b : (f1 $ f2 $ f3 acc)+++default_font_loader_help :: String+default_font_loader_help = unlines $ +    [ "This example uses glyph metrics loaded at runtime."+    , "It can use either the metrics files supplied with GhostScript,"+    , "or the AFM v4.1 metrics for the Core 14 fonts available from"+    , "Adobe's website."+    , "" +    , "To use GhostScripts font metrics set the environemt variable"+    , wumpus_gs_font_dir ++ " to point to the GhostScript fonts"+    , "directory (e.g. /usr/share/ghostscript/fonts)."+    , ""+    , "To use the Adode Core 14 font metrics download the archive from"+    , "the Adobe website and set the environment variable "+    , wumpus_afm_font_dir ++ " to point to it."+    , ""+    , "If you have both environment variables set, the GhostScript loader"+    , "will be used."+    ]+
− src/Wumpus/Basic/System/FontLoader/Afm.hs 
@@ -1,82 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Afm--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Font loader / import shim for the Adobe \"Core 14\" glyph --- metrics.------ Use this loader if you have the Adode glyph metrics set--- (AFM v4.1). This metrics set is avaiable from the Adobe --- website.--------------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Afm-  ( -    loadAfmMetrics-  -  ) where--import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser-import Wumpus.Basic.System.FontLoader.Base.Datatypes-import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad---import Wumpus.Core                              -- package: wumpus-core--import Control.Monad-import Data.Monoid---- The file names of the Afm fonts match there PostScript names,--- the only difference is the addition of a @.afm@ extension.------- | 'loadAfmMetrics' : --- @ path_to_afm_fonts * [font_name] -> IO (metrics, messages) @ --- --- Load the supplied list of fonts. --- --- Note - if a font fails to load a message is written to the --- log and monospaced /fallback metrics/ are used.----loadAfmMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String])-loadAfmMetrics font_dir_path ns = -    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns-  where-    mkFun = afmLoadFontCalcs font_dir_path  - -    post (Left err,ss) = (mempty, ss ++ [err])      -- unreachable...-    post (Right xs,ss) = (foldr insertFont mempty xs, ss)-----afmLoadFontCalcs :: FilePath -> FontName -> FontLoadIO FontMetricsOps-afmLoadFontCalcs font_dir_path name = do-    logLoadMsg  $ "Loading " ++ name-    path        <- checkFontPath font_dir_path (name ++ ".afm")-    ans         <- runParserFLIO path afmV4Dot1Parser-    props       <- buildAfmFontProps  afm_mono_defaults_4_1 ans-    return $ FontMetricsOps name (buildMetricsOps afmUnitScale props)------ | These are values extracted from Courier in the core 14 fonts.----afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit-afm_mono_defaults_4_1 = -    MonospaceDefaults { default_letter_bbox  = bbox-                      , default_cap_height   = 562-                      , default_char_width   = V2 600 0-                      }-  where-    bbox = BBox (P2 (-23) (-250)) (P2 715 805)
+ src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs view
@@ -0,0 +1,225 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.AfmParserBase+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Common parsers for AFM files.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.AfmParserBase+  ( ++    afmFileParser+  , runQuery+  , textQuery++  , getFontBBox+  , getEncodingScheme+  , getCapHeight+  +  , charBBox+  , metric+  , keyStringPair+  , versionNumber  +  , startCharMetrics++  , keyName+  , newlineOrEOF+  , name+  , name1+  , semi+  , uptoNewline+  , number+  , cint+  , hexInt+  , octInt++  , lexeme+  , symbol+  , integer+  , int+  , double++  ) where++import Wumpus.Basic.System.FontLoader.Datatypes++import Wumpus.Basic.Utils.ParserCombinators+import qualified Wumpus.Basic.Utils.TokenParsers as P++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative++import Data.Char+import qualified Data.Map               as Map+++afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile+afmFileParser pgm = do +    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_underline_position  = getUlPosition     info+              , afm_underline_thickness = getUlThickness    info+              , afm_glyph_metrics       = cms+              }++globalInfo :: CharParser GlobalInfo+globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) +               <$> manyTill keyStringPair (peek startCharMetrics)+++ +runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a+runQuery field_name p table = +    Map.lookup field_name table >>= extr . runParser p+  where+    extr (Okay a _) = Just a+    extr _          = Nothing++textQuery :: String -> GlobalInfo -> Maybe String+textQuery = Map.lookup+++-- | Strictly speaking a fontBBox is measured in integer units.+--+getFontBBox            :: GlobalInfo -> Maybe AfmBoundingBox+getFontBBox            = runQuery "FontBBox" fontBBox++getEncodingScheme      :: GlobalInfo -> Maybe String+getEncodingScheme      = textQuery "EncodingScheme"++getCapHeight           :: GlobalInfo -> Maybe AfmUnit+getCapHeight           = runQuery "CapHeight" number++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+charBBox = symbol "B" *> fontBBox <* semi++fontBBox :: CharParser AfmBoundingBox+fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury))+              <$> number <*> number <*> number <*> number++++metric :: String -> a -> CharParser a -> CharParser a+metric iden dfault p = option dfault go+  where+    go = symbol iden *> p <* semi++++keyStringPair :: CharParser (AfmKey,String)+keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF +             <?> "key-value line"++versionNumber :: CharParser String+versionNumber = +    symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF+      <?> "StartFontMetrics"+++startCharMetrics :: CharParser Int+startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF+                <?> "StartCharMetrics failed"++++--------------------------------------------------------------------------------+++keyName :: CharParser AfmKey+keyName = lexeme (many1 $ satisfy isAlphaNum) +++newlineOrEOF :: CharParser ()+newlineOrEOF = skipOne (lexeme newline) <|> eof+++uptoNewline :: CharParser String+uptoNewline = many1 (noneOf ['\n'])+++name :: CharParser String+name = lexeme $ many (noneOf ";\n")++name1 :: CharParser String+name1 = lexeme $ many (noneOf "; \t\n")++++semi :: CharParser Char+semi = lexeme $ char ';'+++++number :: CharParser AfmUnit+number = liftA realToFrac double+++cint :: CharParser Int+cint = hexInt <|> octInt <|> int+++hexInt :: CharParser Int+hexInt = lexeme $ between (char '<') (char '>') P.hexBase+++octInt :: CharParser Int+octInt = lexeme $ char '\\' *> P.octBase++++--------------------------------------------------------------------------------++-- no newline in whitespace+++lp :: P.LexemeParser+lp = P.commentLineLexemeParser "Comment" [' ', '\t']+++lexeme          :: CharParser a -> CharParser a+lexeme          = P.lexeme lp++symbol          :: String -> CharParser String+symbol          = lexeme . string++-- whiteSpace      :: CharParser ()+-- whiteSpace      = P.whiteSpace lp+++integer         :: CharParser Integer+integer         = lexeme P.integer++int             :: CharParser Int+int             = fromIntegral <$> integer++double          :: CharParser Double+double          = lexeme P.double
+ src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.AfmTopLevel+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Top-level AFM V4.1 font loader. +--+-- Use this module to build a font loader if you want to work with +-- the Adobe metrics sets, but find the @simpleFontLoader@ in +-- @Wumpus.Basic.System.FontLoader@ too inflexible.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.AfmTopLevel+  ( ++    loadAfmFontMetrics++  , loadAfmFont1  ++  ) where++import Wumpus.Basic.Kernel+import Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser+import Wumpus.Basic.System.FontLoader.Datatypes+import Wumpus.Basic.System.FontLoader.FontLoadMonad+++import Wumpus.Core                              -- package: wumpus-core++import Control.Monad+import Data.Monoid++-- The file names of the Afm fonts match there PostScript names,+-- the only difference is the addition of a @.afm@ extension.+--++-- | 'loadAfmFontMetrics' : +-- @ path_to_afm_fonts * [font_name] -> IO FontLoadResult @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used.+--+loadAfmFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult+loadAfmFontMetrics font_dir_path ds = +    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds+  where+    mkFun                = afmLoadFontMetrics font_dir_path  + +    post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs+                           in FontLoadResult mempty errs+    post (Right xs,msgs) = let body = foldr fn mempty xs+                           in FontLoadResult body msgs+    +    fn (name,metrics) table = insertFont name metrics table+++-- TODO - need a one font version...+++-- | 'loadAfmFont1' : +-- @ path_to_afm_fonts * font_def -> IO FontLoadResult @ +-- +-- Load a single AFM font. +-- +-- Note - if the font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used.+--+loadAfmFont1 :: FilePath -> FontDef -> IO FontLoadResult+loadAfmFont1 font_dir_path font_def =+    liftM post $ runFontLoadIO $ afmLoadFontMetrics font_dir_path font_def+  where+    post (Left err,msgs)    = let errs = fontLoadMsg err `mappend` msgs+                              in FontLoadResult mempty errs+    post (Right (a,b),msgs) = let body = insertFont a b mempty+                              in FontLoadResult body msgs+    +++afmLoadFontMetrics :: FilePath -> FontDef -> FontLoadIO (FontName,FontMetrics)+afmLoadFontMetrics font_dir_path font_def = do+    tellLoadMsg  $ "Loading " ++ afm_file+    path        <- checkFontPath font_dir_path afm_file+    ans         <- runParserFLIO path afmV4Dot1Parser+    props       <- buildAfmFontProps  afm_mono_defaults_4_1 ans+    return (name, buildMetricsOps afmValue props)+  where+    afm_file    = afm_file_name font_def+    name        = ps_font_name $ font_def_face font_def+++-- | These are values extracted from Courier in the core 14 fonts.+--+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_underline_position  = (-100)+                      , default_underline_thickness = 50 +                      , default_char_width          = V2 600 0+                      }+  where+    bbox = BBox (P2 (-23) (-250)) (P2 715 805)
+ src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.AfmV2Parser+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- AFM file parser for Version 2.0.+--+-- Note - AFM Version 2.0 used by GhostScript and Version 3.0++-- have numerous differences. +-- +--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.AfmV2Parser+  ( +    afmV2Parser++  ) where++import Wumpus.Basic.System.FontLoader.AfmParserBase+import Wumpus.Basic.System.FontLoader.Datatypes+import Wumpus.Basic.Utils.ParserCombinators++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++++--------------------------------------------------------------------------------+-- parser+++afmV2Parser :: CharParser AfmFile+afmV2Parser = afmFileParser charMetricsV2+++charMetricsV2 :: CharParser AfmGlyphMetrics+charMetricsV2 = AfmGlyphMetrics <$>+        metric "C" (-1) cint+    <*> widthVector+    <*> metric "N" "" name1+    <*  charBBox+    <*  many (symbol "L" *> ligature_body <* semi)+    <*  newlineOrEOF+  where+    ligature_body = ((,) <$> name <*> name)+    +widthVector :: CharParser (Vec2 AfmUnit)+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)+++--------------------------------------------------------------------------------++++
+ src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs view
@@ -0,0 +1,63 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- AFM file parser for Version 4.1.+--+-- Adobe distributes font metrics for the /Core 14/ fonts as+-- AFM Version 4.1 files.  +--+--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser+  ( +    +    afmV4Dot1Parser  +  ) where++import Wumpus.Basic.System.FontLoader.AfmParserBase+import Wumpus.Basic.System.FontLoader.Datatypes+import Wumpus.Basic.Utils.ParserCombinators++import Wumpus.Core                              -- package: wumpus-core++import Control.Applicative+++afmV4Dot1Parser :: CharParser AfmFile+afmV4Dot1Parser = afmFileParser charMetricsV4Dot1+++charMetricsV4Dot1 :: CharParser AfmGlyphMetrics+charMetricsV4Dot1 = AfmGlyphMetrics <$>+        characterCode+    <*> widthVector+    <*> metric "N" "" name1+    <*  charBBox+    <*  many (symbol "L" *> ligature_body <* semi)+    <*  newlineOrEOF+  where+    ligature_body = ((,) <$> name <*> name)+++-- Note - there are many variants for width vectors in in 4.1.+-- Wumpus needs some thought about what to do for them, it also+-- needs some facility to tell how successful the parse has been.+    +widthVector :: CharParser (Vec2 AfmUnit)+widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)+           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)+++-- V4.1 allows C int or CH \<hex\>+--+characterCode :: CharParser Int+characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint
− src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs 
@@ -1,210 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Base.AfmParserBase--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Common parsers for AFM files.--- -----------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.AfmParserBase-  ( --    afmFileParser-  , runQuery-  , textQuery--  , getFontBBox-  , getEncodingScheme-  , getCapHeight-  -  , charBBox-  , metric-  , keyStringPair-  , versionNumber  -  , startCharMetrics--  , keyName-  , newlineOrEOF-  , name-  , name1-  , semi-  , uptoNewline-  , number-  , cint-  , hexInt-  , octInt--  , lexeme-  , symbol-  , integer-  , int-  , double--  ) where--import Wumpus.Basic.System.FontLoader.Base.Datatypes--import Wumpus.Basic.Utils.ParserCombinators-import qualified Wumpus.Basic.Utils.TokenParsers as P--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative--import Data.Char-import qualified Data.Map               as Map---afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile-afmFileParser pgm = do -    info <- (versionNumber    *> globalInfo) -    cms  <- (startCharMetrics *> many pgm)-    return $ AfmFile -              { afm_encoding        = getEncodingScheme info-              , afm_letter_bbox     = getFontBBox       info-              , afm_cap_height      = getCapHeight      info-              , afm_glyph_metrics   = cms-              }--globalInfo :: CharParser GlobalInfo-globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) -               <$> manyTill keyStringPair (peek startCharMetrics)--- -runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a-runQuery field_name p table = -    Map.lookup field_name table >>= extr . runParser p-  where-    extr (Okay a _) = Just a-    extr _          = Nothing--textQuery :: String -> GlobalInfo -> Maybe String-textQuery = Map.lookup----- | Strictly speaking a fontBBox is measured in integer units.----getFontBBox            :: GlobalInfo -> Maybe AfmBoundingBox-getFontBBox            = runQuery "FontBBox" fontBBox--getEncodingScheme      :: GlobalInfo -> Maybe String-getEncodingScheme      = textQuery "EncodingScheme"--getCapHeight           :: GlobalInfo -> Maybe AfmUnit-getCapHeight           = runQuery "CapHeight" number---charBBox :: CharParser AfmBoundingBox-charBBox = symbol "B" *> fontBBox <* semi--fontBBox :: CharParser AfmBoundingBox-fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury))-              <$> number <*> number <*> number <*> number----metric :: String -> a -> CharParser a -> CharParser a-metric iden dfault p = option dfault go-  where-    go = symbol iden *> p <* semi----keyStringPair :: CharParser (AfmKey,String)-keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF -             <?> "key-value line"--versionNumber :: CharParser String-versionNumber = -    symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF-      <?> "StartFontMetrics"---startCharMetrics :: CharParser Int-startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF-                <?> "StartCharMetrics failed"---------------------------------------------------------------------------------------keyName :: CharParser AfmKey-keyName = lexeme (many1 $ satisfy isAlphaNum) ---newlineOrEOF :: CharParser ()-newlineOrEOF = skipOne (lexeme newline) <|> eof---uptoNewline :: CharParser String-uptoNewline = many1 (noneOf ['\n'])---name :: CharParser String-name = lexeme $ many (noneOf ";\n")--name1 :: CharParser String-name1 = lexeme $ many (noneOf "; \t\n")----semi :: CharParser Char-semi = lexeme $ char ';'-----number :: CharParser AfmUnit-number = liftA realToFrac double---cint :: CharParser Int-cint = hexInt <|> octInt <|> int---hexInt :: CharParser Int-hexInt = lexeme $ between (char '<') (char '>') P.hexBase---octInt :: CharParser Int-octInt = lexeme $ char '\\' *> P.octBase---------------------------------------------------------------------------------------- no newline in whitespace---lp :: P.LexemeParser-lp = P.commentLineLexemeParser "Comment" [' ', '\t']---lexeme          :: CharParser a -> CharParser a-lexeme          = P.lexeme lp--symbol          :: String -> CharParser String-symbol          = lexeme . string---- whiteSpace      :: CharParser ()--- whiteSpace      = P.whiteSpace lp---integer         :: CharParser Integer-integer         = lexeme P.integer--int             :: CharParser Int-int             = fromIntegral <$> integer--double          :: CharParser Double-double          = lexeme P.double
− src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs 
@@ -1,65 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Internal.AfmV2Parser--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ AFM file parser for Version 2.0.------ Note - AFM Version 2.0 used by GhostScript and Version 3.0+--- have numerous differences. --- -----------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.AfmV2Parser-  ( -    afmV2Parser--  ) where--import Wumpus.Basic.System.FontLoader.Base.AfmParserBase-import Wumpus.Basic.System.FontLoader.Base.Datatypes-import Wumpus.Basic.Utils.ParserCombinators--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative---------------------------------------------------------------------------------------- parser---afmV2Parser :: CharParser AfmFile-afmV2Parser = afmFileParser charMetricsV2---charMetricsV2 :: CharParser AfmGlyphMetrics-charMetricsV2 = AfmGlyphMetrics <$>-        metric "C" (-1) cint-    <*> widthVector-    <*> metric "N" "" name1-    <*  charBBox-    <*  many (symbol "L" *> ligature_body <* semi)-    <*  newlineOrEOF-  where-    ligature_body = ((,) <$> name <*> name)-    -widthVector :: CharParser (Vec2 AfmUnit)-widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)-           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)---------------------------------------------------------------------------------------
− src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs 
@@ -1,63 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ AFM file parser for Version 4.1.------ Adobe distributes font metrics for the /Core 14/ fonts as--- AFM Version 4.1 files.  --------------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser-  ( -    -    afmV4Dot1Parser  -  ) where--import Wumpus.Basic.System.FontLoader.Base.AfmParserBase-import Wumpus.Basic.System.FontLoader.Base.Datatypes-import Wumpus.Basic.Utils.ParserCombinators--import Wumpus.Core                              -- package: wumpus-core--import Control.Applicative---afmV4Dot1Parser :: CharParser AfmFile-afmV4Dot1Parser = afmFileParser charMetricsV4Dot1---charMetricsV4Dot1 :: CharParser AfmGlyphMetrics-charMetricsV4Dot1 = AfmGlyphMetrics <$>-        characterCode-    <*> widthVector-    <*> metric "N" "" name1-    <*  charBBox-    <*  many (symbol "L" *> ligature_body <* semi)-    <*  newlineOrEOF-  where-    ligature_body = ((,) <$> name <*> name)----- Note - there are many variants for width vectors in in 4.1.--- Wumpus needs some thought about what to do for them, it also--- needs some facility to tell how successful the parse has been.-    -widthVector :: CharParser (Vec2 AfmUnit)-widthVector =  (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi)-           <|> (symbol "W"  *> (vec <$> number <*> number)  <* semi)----- V4.1 allows C int or CH \<hex\>----characterCode :: CharParser Int-characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint
− src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs 
@@ -1,178 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Base.Datatypes--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Datatypes--- -----------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.Datatypes-  (--  -- * Afm Unit-    AfmUnit-  , afmValue-  , afmUnitScale-  -  -- * Glyph metrics--  , PSCharCode-  , PSEncodingScheme-  , AfmBoundingBox--  , AfmKey-  , GlobalInfo-  , AfmFile(..)-  , AfmGlyphMetrics(..)--  , MonospaceDefaults(..)--  , FontProps(..)-  , buildMetricsOps-  -  ) where---import Wumpus.Basic.Kernel.Base.GlyphMetrics--import Wumpus.Core                              -- package: wumpus-core--import qualified Data.IntMap   as IntMap-import qualified Data.Map as Map------ | Wrapped Double representing 1\/1000 of the scale factor--- (Point size) of a font. AFM files encode all measurements --- as these units. --- -newtype AfmUnit = AfmUnit { getAfmUnit :: Double } -  deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat)--instance Show AfmUnit where-  showsPrec p d = showsPrec p (getAfmUnit d)----- | Compute the size of a measurement in Afm units scaled by the--- point size of the font.----afmValue :: FromPtSize u => AfmUnit -> PtSize -> u-afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000)--afmUnitScale :: AfmUnit -> PtSize -afmUnitScale u = (realToFrac $ getAfmUnit u / 1000)--------------------------------------------------------------------------------------- | Afm files index glyphs by /PostScript character code/. This --- is not the same as Unicode, ASCII...------ It is expected to be determined by @EncodingScheme@ in the--- Global Font Information Section.----type PSCharCode         = Int--type PSEncodingScheme   = String--type AfmBoundingBox     = BoundingBox AfmUnit--type AfmKey         = String-type GlobalInfo     = Map.Map AfmKey String------ | Wumpus needs a very small subset of AFM files, common to both--- version 2.0 and version 4.1.------ Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1--- --- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus --- uses cap height in calculations, glyph metrics must be build --- with an arbitrary value if it is not present.------ 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_glyph_metrics   :: [AfmGlyphMetrics]-      }-  deriving (Show) -  --- Note - for AfmFile BBox is a required field for version 4.1, --- but it appears to be optional for version 2.0.------data AfmGlyphMetrics = AfmGlyphMetrics-      { afm_char_code       :: !PSCharCode-      , afm_width_vector    :: !(Vec2 AfmUnit)-      , afm_char_name       :: !String-      }-  deriving (Eq,Show)----- | Monospace defaults are used if the font loader fails to --- extract the necessary fields.--- --- The values are taken from the font correpsonding to Courier --- in the distributed font files.----data MonospaceDefaults cu = MonospaceDefaults -      { default_letter_bbox  :: BoundingBox cu-      , default_cap_height   :: cu-      , default_char_width   :: Vec2 cu-      }-  deriving (Eq,Show)------ | The metrics read from a font file by a font loader. --- --- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and --- not on the usual @u@. A typical character unit is 'AfmUnit', --- the unit of measurement for AFM files (1000th of a point).------ The is the initial representation used by Wumpus-Basic as an--- syntax tree when loading font files. ----data FontProps cu = FontProps-       { fp_bounding_box        :: BoundingBox cu -       , fp_default_adv_vec     :: Vec2 cu-       , fp_adv_vecs            :: IntMap.IntMap (Vec2 cu)-       , fp_cap_height          :: cu-       }----- | Build a MetricsOps function table, from a character unit--- scaling function and FontProps read from a file.----buildMetricsOps :: (cu -> PtSize) -> FontProps cu -> MetricsOps-buildMetricsOps fn (FontProps (BBox ll ur) (V2 vx vy) -                              vec_table    cap_height) = -    MetricsOps-      { get_bounding_box  = \sz -> BBox (scalePt sz ll) (scalePt sz ur)-      , get_cw_table      = \sz i -> -            maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table -      , get_cap_height    = \sz -> upscale sz (fn cap_height)-      }-  where-    upscale sz d            = fromPtSize $ sz * d - -    defaultAV sz            = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) -    scalePt  sz (P2 cx cy)  = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) -    scaleVec sz (V2 cx cy)  = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) ---
− src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs 
@@ -1,205 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Base.FontLoadMonad--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Font load monad handling IO (file system access), failure and --- logging.--------------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.FontLoadMonad-  (-    FontLoadErr-  , FontLoadIO-  , runFontLoadIO-  , evalFontLoadIO-  , loadError-  , logLoadMsg-  , promoteIO-  , promoteEither-  , runParserFLIO--  , sequenceAll--  -- * Font loading--  , buildAfmFontProps-  , checkFontPath-  -  ) where--import Wumpus.Basic.System.FontLoader.Base.Datatypes-import Wumpus.Basic.Utils.HList-import Wumpus.Basic.Utils.ParserCombinators---import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Text.GlyphIndices---import Control.Monad-import qualified Data.IntMap            as IntMap-import qualified Data.Map as Map-import Data.Monoid-import System.Directory-import System.FilePath--------------------------------------------------------------------------------------- FontLoadIO monad - IO plus Error----type FontLoadErr        = String--newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H String }---instance Monoid FontLoadLog where-  mempty        = FontLoadLog $ emptyH-  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b----newtype FontLoadIO a = FontLoadIO { -          getFontLoadIO :: IO (Either FontLoadErr a, FontLoadLog ) }--instance Functor FontLoadIO where-  fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w)- -instance Monad FontLoadIO where-  return a = FontLoadIO $ return (Right a, mempty)-  m >>= k  = FontLoadIO $ getFontLoadIO m >>= fn -              where-                fn (Left err, w) = return (Left err, w)-                fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> -                                   return (b, w1 `mappend` w2)--runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a,[String])-runFontLoadIO ma = liftM post $ getFontLoadIO ma -  where-    post (ans,w) = (ans, toListH $ getFontLoadLog w)---evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a)-evalFontLoadIO ma = liftM post $ getFontLoadIO ma-  where-    post (ans,_) = ans---loadError :: FontLoadErr -> FontLoadIO a-loadError msg = FontLoadIO $ return (Left msg, mempty)--logLoadMsg :: String -> FontLoadIO ()-logLoadMsg msg = FontLoadIO $ return (Right (), message1 msg ) ---message1 :: String -> FontLoadLog -message1 = FontLoadLog . wrapH----- | aka liftIO-promoteIO :: IO a -> FontLoadIO a-promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty)--promoteEither :: Either FontLoadErr a -> FontLoadIO a-promoteEither = either loadError return --runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a-runParserFLIO filepath p = -   promoteIO (readFile filepath) >>= promoteEither . runParserEither p----- | The standard monadic @sequence@ would finish on first fail--- for the FontLoadIO monad. As we want to be able to sequence--- the loading of a list of fonts, this is not really the --- behaviour we want for Wumpus. Instead we prefer to use fallback --- metrics and produce an inaccurate drawing on a font load error--- rather than fail and produce no drawing.----sequenceAll :: [FontLoadIO a] -> FontLoadIO [a]-sequenceAll = FontLoadIO . step-   where-    step []     = return (Right [], mempty)-    step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) --cons :: (Either FontLoadErr a, FontLoadLog)-     -> (Either FontLoadErr [a], FontLoadLog)-     -> (Either FontLoadErr [a], FontLoadLog)-cons (Right a, w1)  (Right as, w2) = -    (Right $ a:as,  w1 `mappend` w2)--cons (Right a, w1)  (Left e2, w2) = -    (Right [a], w1 `mappend` w2 `mappend` message1 e2)--cons (Left e1, w1)  (Right as, w2) = -    (Right as, w1 `mappend` message1 e1 `mappend` w2)--cons (Left e1, w1)  (Left e2,  w2) = -    (Right [], w1 `mappend` message1 e1 `mappend` w2 `mappend` message1 e2)----------------------------------------------------------------------------------------- | Afm files do not have a default advance vec so use the --- monospace default.--- --- Afm files hopefully have @CapHeight@ and @FontBBox@ properties--- in the header. Use the monospace default only if they are --- missing.--- -buildAfmFontProps :: MonospaceDefaults AfmUnit -                  -> AfmFile -                  -> FontLoadIO (FontProps AfmUnit)-buildAfmFontProps defaults afm = do -    cap_height <- extractCapHeight 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-               }  -  where-    char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm- -    fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of-                                          Nothing -> table-                                          Just i  -> IntMap.insert i v table---extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit-extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm-  where-    errk = logLoadMsg "WARNING - Could not extract CapHeight" >> -           return (default_cap_height defaults)---extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile -                -> FontLoadIO (BoundingBox AfmUnit)-extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm-  where-    errk = logLoadMsg "WARNING - Could not extract CapHeight" >> -           return (default_letter_bbox defaults)----checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath-checkFontPath path_root font_file_name = -    let full_path = normalise (path_root </> font_file_name)-    in do { check <- promoteIO (doesFileExist full_path)-          ; if check then return full_path-                     else loadError $ "Could not resolve path: " ++ full_path-          }
− src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs 
@@ -1,108 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.Base.GSFontMap--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ GhostScript Font map.------ GhostScript aliases the /Core 14/ PostScript fonts to fonts--- it can freely distribute. This module provides aliases to --- Wumpus so the font loader can find the equivalent GhostScript--- files to the Core 14 set.------ The data in this file matches GhostScript 8.63. Other versions--- of GhostScript may need different aliases.--- -----------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.Base.GSFontMap-  (-   -    GSFontMap(..)-  , gsMetricsFile-  , gsFontAlias-  , gsVersionNumber-  , ghostscript_fontmap_8_54--  ) where---import Data.Map ( Map )-import qualified Data.Map as Map----- | GhostScript version that the aliases were derived from.--- --- ghostscript_version :: String--- ghostscript_version = "gs8.54"----- | A map from standard /Adode PostScript/ font name to the--- equivalent GhostScript font and AFM file name.------ It is expected that all GhostScript AFM files will be located--- in the same directory.----data GSFontMap = GSFontMap-      { ghostscript_version :: String-      , ghostscript_fontmap :: Map String (String, FilePath)-      }----- | Get the @.afm@ metrics file.------ Note this return only the file name and not the path to it.--- The full path must be resolved in client code.----gsMetricsFile :: GSFontMap -> String -> Maybe FilePath-gsMetricsFile mp name = fmap snd $ Map.lookup name (ghostscript_fontmap mp)---- | Get the GhostScript font name alias.----gsFontAlias :: GSFontMap -> String -> Maybe String-gsFontAlias mp name = fmap fst $ Map.lookup name (ghostscript_fontmap mp)----- | Get the GhostScript version number that the FontMap --- represents.----gsVersionNumber :: GSFontMap -> String-gsVersionNumber = ghostscript_version ----- | Map from PostScript font name to the corresponding --- GhostScript name and file.------ Naming is correct for GhostSCript version 8.54.--- -ghostscript_fontmap_8_54 :: GSFontMap-ghostscript_fontmap_8_54 = GSFontMap "8.54" body-  where-    body = Map.fromList $ -            [ ("Courier",                 ("NimbusMonL-Regu",         "n022003l.afm"))-            , ("Courier-Oblique",         ("NimbusMonL-ReguObli",     "n022023l.afm"))-            , ("Courier-Bold",            ("NimbusMonL-Bold",         "n022004l.afm"))-            , ("Courier-BoldOblique",     ("NimbusMonL-BoldObli",     "n022024l.afm"))-  -            , ("Helvetica",               ("NimbusSanL-Regu",         "n019003l.afm"))-            , ("Helvetica-Oblique",       ("NimbusSanL-ReguItal",     "n019023l.afm"))-            , ("Helvetica-Bold",          ("NimbusSanL-Bold",         "n019004l.afm"))-            , ("Helvetica-BoldOblique",   ("NimbusSanL-BoldItal",     "n019024l.afm"))--            , ("Times-Roman",             ("NimbusRomNo9L-Regu",      "n021003l.afm"))-            , ("Times-Italic",            ("NimbusRomNo9L-ReguItal",  "n021023l.afm"))-            , ("Times-Bold",              ("NimbusRomNo9L-Medi",      "n021004l.afm"))-            , ("Times-BoldItalic",        ("NimbusRomNo9L-MediItal",  "n021024l.afm"))--            , ("Symbol",                  ("StandardSymL",            "s050000l.afm"))--            , ("ZapfDingbats",            ("Dingbats",                "d050000l.afm"))-            ]-
+ src/Wumpus/Basic/System/FontLoader/Datatypes.hs view
@@ -0,0 +1,166 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.Datatypes+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Datatypes+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.Datatypes+  (+  +  -- * Glyph metrics++    PSCharCode+  , PSEncodingScheme+  , AfmBoundingBox++  , AfmKey+  , GlobalInfo+  , AfmFile(..)+  , AfmGlyphMetrics(..)++  , MonospaceDefaults(..)++  , FontProps(..)+  , buildMetricsOps+  +  ) where+++import Wumpus.Basic.Kernel.Base.FontSupport++import Wumpus.Core                              -- package: wumpus-core++import qualified Data.IntMap   as IM+import qualified Data.Map      as M+++++++++--------------------------------------------------------------------------------++-- | Afm files index glyphs by /PostScript character code/. This +-- is not the same as Unicode, ASCII...+--+-- It is expected to be determined by @EncodingScheme@ in the+-- Global Font Information Section.+--+type PSCharCode         = Int++type PSEncodingScheme   = String++type AfmBoundingBox     = BoundingBox AfmUnit++type AfmKey         = String+type GlobalInfo     = M.Map AfmKey String++++-- | Wumpus needs a very small subset of AFM files, common to both+-- version 2.0 and version 4.1.+--+-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1+-- +-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus +-- uses cap height in calculations, glyph metrics must be build +-- with an arbitrary value if it is not present.+--+-- 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_underline_position      :: Maybe AfmUnit+      , afm_underline_thickness     :: Maybe AfmUnit+      , afm_glyph_metrics           :: [AfmGlyphMetrics]+      }+  deriving (Show) +  +-- Note - for AfmFile BBox is a required field for version 4.1, +-- but it appears to be optional for version 2.0.+--+++data AfmGlyphMetrics = AfmGlyphMetrics+      { afm_char_code       :: !PSCharCode+      , afm_width_vector    :: !(Vec2 AfmUnit)+      , afm_char_name       :: !String+      }+  deriving (Eq,Show)+++-- | Monospace defaults are used if the font loader fails to +-- extract the necessary fields.+-- +-- The values are taken from the font correpsonding to Courier +-- in the distributed font files.+--+data MonospaceDefaults cu = MonospaceDefaults +      { 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)++++-- | The metrics read from a font file by a font loader. +-- +-- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and +-- not on the usual @u@. A typical character unit is 'AfmUnit', +-- the unit of measurement for AFM files (1000th of a point).+--+-- The is the initial representation used by Wumpus-Basic as an+-- syntax tree when loading font files. +--+data FontProps cu = FontProps+       { fp_bounding_box        :: BoundingBox cu +       , fp_default_adv_vec     :: Vec2 cu+       , fp_adv_vecs            :: IM.IntMap (Vec2 cu)+       , fp_cap_height          :: cu+       , fp_descender           :: cu+       , fp_underline_position  :: cu+       , fp_underline_thickness :: cu+       }+++-- | Build a MetricsOps function table, from a character unit+-- scaling function and FontProps read from a file.+--+buildMetricsOps :: (FontSize -> cu -> Double) -> FontProps cu -> FontMetrics+buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur+                                   , fp_default_adv_vec = V2 vx vy }) = +    FontMetrics+      { get_bounding_box  = \sz -> BBox (scalePt sz ll) (scalePt sz ur)+      , get_cw_table      = \sz i -> +            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) +    scalePt  sz (P2 cx cy)  = P2 (fn sz cx) (fn sz cy) +    scaleVec sz (V2 cx cy)  = V2 (fn sz cx) (fn sz cy) +++
+ src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs view
@@ -0,0 +1,218 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.FontLoadMonad+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Font load monad handling IO (file system access), failure and +-- logging.+--+--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.FontLoadMonad+  (+    FontLoadIO+  , runFontLoadIO+  , evalFontLoadIO+  , loadError+  , tellLoadMsg+  , promoteIO+  , promoteEither+  , runParserFLIO++  , sequenceAll++  -- * Font loading++  , buildAfmFontProps+  , checkFontPath+  +  ) where++import Wumpus.Basic.Kernel+import Wumpus.Basic.System.FontLoader.Datatypes+import Wumpus.Basic.Utils.ParserCombinators+++import Wumpus.Core                              -- package: wumpus-core+import Wumpus.Core.Text.GlyphIndices+++import Control.Monad+import qualified Data.IntMap            as IntMap+import qualified Data.Map as Map+import Data.Monoid+import System.Directory+import System.FilePath++++--------------------------------------------------------------------------------+-- FontLoadIO monad - IO plus Error++++newtype FontLoadIO a = FontLoadIO { +          getFontLoadIO :: IO (Either FontLoadMsg a, FontLoadLog ) }++instance Functor FontLoadIO where+  fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w)+ +instance Monad FontLoadIO where+  return a = FontLoadIO $ return (Right a, mempty)+  m >>= k  = FontLoadIO $ getFontLoadIO m >>= fn +              where+                fn (Left err, w) = return (Left err, w)+                fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> +                                   return (b, w1 `mappend` w2)++runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a, FontLoadLog)+runFontLoadIO ma = getFontLoadIO ma +++evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a)+evalFontLoadIO ma = liftM post $ getFontLoadIO ma+  where+    post (ans,_) = ans+++loadError :: FontLoadMsg -> FontLoadIO a+loadError msg = FontLoadIO $ return (Left msg, mempty)++tellLoadMsg :: String -> FontLoadIO ()+tellLoadMsg msg = FontLoadIO $ return (Right (), fontLoadMsg msg ) ++++-- | Promote an @IO@ action into the the @FontLoadIO@ monad.+--+-- This function is equivalent to @liftIO@.+--+promoteIO :: IO a -> FontLoadIO a+promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty)++promoteEither :: Either FontLoadMsg a -> FontLoadIO a+promoteEither = either loadError return ++runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a+runParserFLIO filepath p = +   promoteIO (readFile filepath) >>= promoteEither . runParserEither p+++-- | The standard monadic @sequence@ would finish on first fail+-- for the FontLoadIO monad. As we want to be able to sequence+-- the loading of a list of fonts, this is not really the +-- behaviour we want for Wumpus. Instead we prefer to use fallback +-- metrics and produce an inaccurate drawing on a font load error+-- rather than fail and produce no drawing.+--+sequenceAll :: [FontLoadIO a] -> FontLoadIO [a]+sequenceAll = FontLoadIO . step+   where+    step []     = return (Right [], mempty)+    step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) ++cons :: (Either FontLoadMsg a, FontLoadLog)+     -> (Either FontLoadMsg [a], FontLoadLog)+     -> (Either FontLoadMsg [a], FontLoadLog)+cons (Right a, w1)  (Right as, w2) = +    (Right $ a:as,  w1 `mappend` w2)++cons (Right a, w1)  (Left e2, w2) = +    (Right [a], w1 `mappend` w2 `mappend` fontLoadMsg e2)++cons (Left e1, w1)  (Right as, w2) = +    (Right as, w1 `mappend` fontLoadMsg e1 `mappend` w2)++cons (Left e1, w1)  (Left e2,  w2) = +    (Right [], w1 `mappend` fontLoadMsg e1 `mappend` w2 `mappend` fontLoadMsg e2)++++--------------------------------------------------------------------------------+++-- | Afm files do not have a default advance vec so use the +-- monospace default.+-- +-- Afm files hopefully have @CapHeight@ and @FontBBox@ properties+-- in the header. Use the monospace default only if they are +-- missing.+-- +buildAfmFontProps :: MonospaceDefaults AfmUnit +                  -> AfmFile +                  -> FontLoadIO (FontProps AfmUnit)+buildAfmFontProps defaults afm = do +    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_underline_position  = ul_position+               , fp_underline_thickness = ul_thickness+               }  +  where+    char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm+ +    fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of+                                          Nothing -> table+                                          Just i  -> IntMap.insert i v table+++extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit+extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm+  where+    errk = tellLoadMsg "WARNING - Could not extract CapHeight" >> +           return (default_cap_height defaults)++++extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit+extractDescender defaults afm = maybe errk return $ afm_descender afm+  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 +                -> FontLoadIO (BoundingBox AfmUnit)+extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm+  where+    errk = tellLoadMsg "WARNING - Could not extract CapHeight" >> +           return (default_letter_bbox defaults)++++checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath+checkFontPath path_root font_file_name = +    let full_path = normalise (path_root </> font_file_name)+    in do { check <- promoteIO (doesFileExist full_path)+          ; if check then return full_path+                     else loadError $ "Could not resolve path: " ++ full_path+          }
+ src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs view
@@ -0,0 +1,110 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.System.FontLoader.GSTopLevel+-- Copyright   :  (c) Stephen Tetley 2010-2011+-- License     :  BSD3+--+-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>+-- Stability   :  highly unstable+-- Portability :  GHC+--+-- Top-level GhostScript font loader. +--+-- Use this module to build a font loader if you want to work with +-- GhostScript, but find the @simpleFontLoader@ in +-- @Wumpus.Basic.System.FontLoader@ too inflexible.+-- +--------------------------------------------------------------------------------++module Wumpus.Basic.System.FontLoader.GSTopLevel+  ( ++    loadGSFontMetrics++  , loadGSFont1 +   +  ) where++import Wumpus.Basic.Kernel+import Wumpus.Basic.System.FontLoader.AfmV2Parser+import Wumpus.Basic.System.FontLoader.Datatypes+import Wumpus.Basic.System.FontLoader.FontLoadMonad++import Wumpus.Core                              -- package: wumpus-core++import Control.Monad+import Data.Monoid+++-- | 'loadGSFontMetrics' : +-- @ path_to_gs_fonts * [font_name] -> IO FontLoadResult @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used.+--+loadGSFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult+loadGSFontMetrics font_dir_path ds = +    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds+  where+    mkFun = gsLoadFontMetrics font_dir_path  ++    post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs+                           in FontLoadResult mempty errs +    post (Right xs,msgs) = let body = foldr fn mempty xs+                           in FontLoadResult body msgs++    fn (name,metrics) table = insertFont name metrics table+++-- | 'loadGSFont1' : +-- @ path_to_gs_fonts * font_name -> IO FontLoadResult @ +-- +-- Load a single GhostScript font. +-- +-- Note - if the font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used.+--+loadGSFont1 :: FilePath -> FontDef -> IO FontLoadResult+loadGSFont1 font_dir_path font_def = +   liftM post $ runFontLoadIO $ gsLoadFontMetrics font_dir_path font_def+  where+    post (Left err,msgs)    = let errs = fontLoadMsg err `mappend` msgs+                              in FontLoadResult mempty errs +    post (Right (a,b),msgs) = let body = insertFont a b mempty+                              in FontLoadResult body msgs++++gsLoadFontMetrics :: FilePath -> FontDef+                  -> FontLoadIO (FontName,FontMetrics)+gsLoadFontMetrics font_dir_path font_def = do+    tellLoadMsg  $ "Loading " ++ gs_file+    path        <- checkFontPath font_dir_path gs_file+    ans         <- runParserFLIO path afmV2Parser+    props       <- buildAfmFontProps  ghostscript_mono_defaults_8_54 ans+    return (name, buildMetricsOps afmValue props)+  where+    gs_file     = gs_file_name font_def+    name        = ps_font_name $ font_def_face font_def++++-- | These are values extracted from the file @n022003l.afm@+-- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent +-- font for the core 14 font Courier.+--+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_underline_position  = (-100)+                      , default_underline_thickness = 50 +                      , default_char_width          = V2 600 0+                      }+  where+    bbox = BBox (P2 (-46) (-273)) (P2 650 820)
− src/Wumpus/Basic/System/FontLoader/GhostScript.hs 
@@ -1,86 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.System.FontLoader.GhostScript--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Font loader / import shim for GhostScript glyph metrics.------ Use this loader if you have GhostScript installed and you want --- to use the (AFM v2.0) metrics that are distributed with --- GhostScript.--- -----------------------------------------------------------------------------------module Wumpus.Basic.System.FontLoader.GhostScript-  ( --    loadGSMetrics-  -  ) where--import Wumpus.Basic.Kernel-import Wumpus.Basic.System.FontLoader.Base.AfmV2Parser-import Wumpus.Basic.System.FontLoader.Base.Datatypes-import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad-import Wumpus.Basic.System.FontLoader.Base.GSFontMap--import Wumpus.Core                              -- package: wumpus-core--import Control.Monad-import Data.Monoid----- | 'loadGSMetrics' : --- @ path_to_gs_fonts * [font_name] -> IO (metrics, messages) @ --- --- Load the supplied list of fonts. --- --- Note - if a font fails to load a message is written to the --- log and monospaced /fallback metrics/ are used.----loadGSMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String])-loadGSMetrics font_dir_path ns = -    liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns-  where-    mkFun = gsLoadFontCalcs font_dir_path ghostscript_fontmap_8_54 -    -    post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable...-    post (Right xs,ss) = (foldr insertFont mempty xs, ss)---gsLoadFontCalcs :: FilePath -> GSFontMap -> FontName -                -> FontLoadIO FontMetricsOps-gsLoadFontCalcs font_dir_path fm name = do-    logLoadMsg  $ "Loading " ++ name-    font_file   <- resolveFontFile fm name -    path        <- checkFontPath font_dir_path font_file-    ans         <- runParserFLIO path afmV2Parser-    props       <- buildAfmFontProps  ghostscript_mono_defaults_8_54 ans-    return $ FontMetricsOps name (buildMetricsOps afmUnitScale props)---resolveFontFile :: GSFontMap -> FontName -> FontLoadIO FilePath-resolveFontFile fm name = maybe errk return $ gsMetricsFile fm name-  where-    errk = loadError $ "Could note resolve GhostScript alias for " ++ name----- | These are values extracted from the file @n022003l.afm@--- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent --- font for the core 14 font Courier.----ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit-ghostscript_mono_defaults_8_54 = -    MonospaceDefaults { default_letter_bbox  = bbox-                      , default_cap_height   = 563-                      , default_char_width   = V2 600 0-                      }-  where-    bbox = BBox (P2 (-46) (-273)) (P2 650 820)
− src/Wumpus/Basic/Utils/FormatCombinators.hs 
@@ -1,430 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Utils.FormatCombinators--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Formatting combinators - pretty printers without the fitting.------ Note - indentation support is very limited. Generally one --- should use a proper pretty printing library.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Utils.FormatCombinators-  (-    Doc-  , DocS-  , Format(..)-  , empty-  , showsDoc-  , (<>)-  , (<+>)  -  , vconcat-  , separate-  , hcat-  , hsep-  , vcat--  , text-  , char-  , int-  , integer-  , integral-  , float-  , double-  , hex4--  , space-  , comma-  , semicolon-  , line--  , fill-  , fillStringR-  , fillStringL--  , punctuate-  , enclose-  , squotes-  , dquotes-  , parens-  , brackets-  , braces-  , angles--  , lparen-  , rparen-  , lbracket-  , rbracket-  , lbrace-  , rbrace-  , langle-  , rangle--  , list-  , tupled-  , semiBraces--  , indent--  , writeDoc-    -  ) where--import Data.Monoid-import Numeric---- | Doc is a Join List ...----data Doc = Doc1   ShowS -         | Join   Doc   Doc-         | Line-         | Indent !Int  Doc ---type DocS = Doc -> Doc----- Join could be improved...----unDoc :: Doc -> ShowS-unDoc = step 0 id-  where-   step _ acc (Doc1 sf)    = acc . sf-   step n acc (Join a b)   = let acc' = step n acc a in step n acc' b-   step n acc Line         = acc . showChar '\n' . indentS n-   step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d---indentS :: Int -> ShowS-indentS i | i < 1     = id-          | otherwise = showString $ replicate i ' '--runDoc :: Doc -> String-runDoc = ($ "") . unDoc---instance Show Doc where-  show = runDoc--instance Monoid Doc where-  mempty = empty-  mappend = (<>)---class Format a where format :: a -> Doc-----------------------------------------------------------------------------------        -infixr 6 <>, <+>------ | Create an empty, zero length document.----empty :: Doc-empty = Doc1 id---- | Create a document from a ShowS function.----showsDoc :: ShowS -> Doc-showsDoc = Doc1----- | Horizontally concatenate two documents with no space --- between them.--- -(<>) :: Doc -> Doc -> Doc-a <> b = Join a b ----- | Horizontally concatenate two documents with a single space --- between them.--- -(<+>) :: Doc -> Doc -> Doc-a <+> b = Join a (Join space b)---- | Vertical concatenate two documents with a line break.--- -vconcat :: Doc -> Doc -> Doc-vconcat a b = a <> Line <> b----separate :: Doc -> [Doc] -> Doc-separate _   []     = empty-separate sep (a:as) = step a as-  where-    step acc []     = acc-    step acc (x:xs) = step (acc <> sep <> x) xs---- | Horizontally concatenate a list of documents with @(\<\>)@.----hcat :: [Doc] -> Doc-hcat = foldr (<>) empty---- | Horizontally concatenate a list of documents with @(\<+\>)@.----hsep :: [Doc] -> Doc-hsep = separate space---- | Vertically concatenate a list of documents, with a line --- break between each doc.----vcat :: [Doc] -> Doc-vcat []     = empty-vcat (x:xs) = step x xs -  where-    step acc (z:zs) = step (acc `vconcat` z) zs-    step acc []     = acc---- | Create a document from a literal string.--- --- The string should not contain newlines (though this is not --- enforced). ----text :: String -> Doc-text = Doc1 . showString----- | Create a document from a literal character.------ The char should not be a tab or newline. ----char :: Char -> Doc-char = Doc1 . showChar---- | Show the Int as a Doc.------ > int  = text . show----int :: Int -> Doc-int  = Doc1 . showInt---- | Show the Integer as a Doc.----integer :: Integer -> Doc-integer = Doc1 . showInt---- | Show an \"integral value\" as a Doc via 'fromIntegral'.----integral :: Integral a => a -> Doc-integral = Doc1 . showInt---- | Show the Float as a Doc.----float :: Double -> Doc-float = Doc1 . showFloat---- | Show the Double as a Doc.----double :: Double -> Doc-double = Doc1 . showFloat---- | Show the Int as hexadecimal, padding up to 4 digits if --- necessary.------ No trucation occurs if the value has more than 4 digits.----hex4 :: Int -> Doc-hex4 n | n < 0x0010 = text "000" <> showsDoc (showHex n)-       | n < 0x0100 = text "00"  <> showsDoc (showHex n)-       | n < 0x1000 = text "0"   <> showsDoc (showHex n)-       | otherwise  = showsDoc (showHex n)- --- | Create a Doc containing a single space character.----space :: Doc-space = char ' '---- | Create a Doc containing a comma, \",\".----comma :: Doc-comma = char ','---- | Create a Doc containing a semi colon, \";\".----semicolon :: Doc-semicolon = char ';'---- | Create a Doc containing newline, \"\\n\".----line :: Doc -line = char '\n'--------------------------------------------------------------------------------------- | Fill a doc to the supplied length, padding the right-hand--- side with spaces.------ Note - this function is expensive - it unrolls the functional--- representation of the String. --- --- Also it should only be used for single line Doc\'s.--- -fill :: Int -> Doc -> Doc-fill i d = Doc1 (padr i ' ' $ unDoc d) --padr :: Int -> Char -> ShowS -> ShowS-padr i c df = step (length $ df []) -  where-    step len | len >= i  = df-             | otherwise = df . showString (replicate (i-len) c)---- | String version of 'fill'.------ This is more efficient than 'fill' as the input is a string--- so its length is more accesible.------ Padding is the space character appended to the right.--- -fillStringR :: Int -> String -> Doc-fillStringR i s = step (length s)-  where-    step n | n >= i = text s-    step n          = text s <> text (replicate (i-n) ' ')---- | Left-padding version of 'fillStringR'.----fillStringL :: Int -> String -> Doc-fillStringL i s = step (length s)-  where-    step n | n >= i = text s-    step n          = text (replicate (i-n) ' ') <> text s-------------------------------------------------------------------------------------- | Punctuate the Doc list with the separator, producing a Doc. ----punctuate :: Doc -> [Doc] -> Doc-punctuate _ []     = empty-punctuate _ [x]    = x-punctuate s (x:xs) = x <> s <> punctuate s xs----- | Enclose the final Doc within the first two.------ There are no spaces between the documents:------ > enclose l r d = l <> d <> r----enclose :: Doc -> Doc -> Doc -> Doc-enclose l r d = l <> d <> r------ | Enclose the Doc within single quotes.----squotes :: Doc -> Doc-squotes = enclose (char '\'') (char '\'')---- | Enclose the Doc within double quotes.----dquotes :: Doc -> Doc-dquotes = enclose (char '"') (char '"')---- | Enclose the Doc within parens @()@.----parens :: Doc -> Doc-parens = enclose lparen rparen---- | Enclose the Doc within square brackets @[]@.----brackets :: Doc -> Doc-brackets = enclose lbracket rbracket---- | Enclose the Doc within curly braces @{}@.----braces :: Doc -> Doc-braces = enclose lbrace rbrace---- | Enclose the Doc within angle brackets @\<\>@.----angles :: Doc -> Doc-angles = enclose langle rangle------ | Create a Doc containing a left paren, \'(\'.----lparen :: Doc-lparen = char '('---- | Create a Doc containing a right paren, \')\'.----rparen :: Doc-rparen = char ')'---- | Create a Doc containing a left square bracket, \'[\'.----lbracket :: Doc-lbracket = char '['---- | Create a Doc containing a right square bracket, \']\'.----rbracket :: Doc-rbracket = char ']'---- | Create a Doc containing a left curly brace, \'{\'.----lbrace :: Doc-lbrace = char '{'---- | Create a Doc containing a right curly brace, \'}\'.----rbrace :: Doc-rbrace = char '}'---- | Create a Doc containing a left angle bracket, \'\<\'.----langle :: Doc-langle = char '<'---- | Create a Doc containing a right angle bracket, \'\>\'.----rangle :: Doc-rangle = char '>'---- | Comma separate the list of documents and enclose in square--- brackets.----list :: [Doc] -> Doc-list = brackets . punctuate comma---- | Comma separate the list of documents and enclose in parens.----tupled :: [Doc] -> Doc-tupled = parens . punctuate comma---- | Separate the list with a semicolon and enclose in curly --- braces.----semiBraces :: [Doc] -> Doc-semiBraces = braces . punctuate semicolon----- | Horizontally indent a Doc.------ Note - this space-prefixes the Doc on /the current line/. It--- does not indent subsequent lines if the Doc spans multiple --- lines.----indent :: Int -> Doc -> Doc-indent i d | i < 1     = d-           | otherwise = Indent i d--------------------------------------------------------------------------------------- | Write a Doc to file.----writeDoc :: FilePath -> Doc -> IO ()-writeDoc filepath d = writeFile filepath $ show d
src/Wumpus/Basic/Utils/HList.hs view
@@ -29,6 +29,7 @@   , concatH    , toListH+  , prefixListH   , fromListH  @@ -79,6 +80,9 @@  toListH :: H a -> [a] toListH = ($ [])++prefixListH :: H a -> [a] -> [a]+prefixListH hf xs = hf $ xs  fromListH :: [a] -> H a fromListH xs = (xs++)
src/Wumpus/Basic/Utils/JoinList.hs view
@@ -135,7 +135,7 @@ -- | Convert a join list to a regular list. -- toList :: JoinList a -> [a]-toList = joinfoldl (flip (:)) []+toList = joinfoldr (:) []
src/Wumpus/Basic/VersionNumber.hs view
@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -23,7 +23,7 @@  -- | Version number ----- > (0,15,0)+-- > (0,24,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,15,0)+wumpus_basic_version = (0,24,0)
wumpus-basic.cabal view
@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.15.0+version:          0.24.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -9,8 +9,8 @@ synopsis:         Basic objects and system code built on Wumpus-Core. description:   .-  Kernel code for higher-level drawing built on Wumpus-Core.-  This package provides font loader code (limited to AFM font +  Kernel code for higher-level drawing built on Wumpus-Core. This +  package provides font loader code (currently limited to AFM font    files) and a various /drawing objects/ intended to be a    higher-level basis to make vector drawings than the primitives    (paths, text labels) provided by Wumpus-Core. @@ -29,29 +29,76 @@   .   .   Changelog:+  . +  v0.23.0 to v0.24.0:   .-  v0.14.0 to v0.15.0:+  * Changes to type funs to work with GHC 7.4.   . -  * Split previous @Wumpus-Basic@ package into two packages:-    @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move -    to separate the developed (although not yet polished) @Kernel@ -    and @FontLoader@ code from the prototypical @Drawing@ code.+  * Removed FormatCombinators module.   .-  * Renamed the @Drawing@ object to @CtxPicture@. Although -    @CtxPicture@ is a less pleasant name, it should be less -    confusing. A @CtxPicture@ is the essentially the @Picture@ -    type from Wumpus-Core with an implicit context - -    @ContextPicture@ is simply too long and @CtxPicture@ is -    almost jibberish but the previous unrelated name @Drawing@ -    was not helpful.+  v0.22.0 to v0.23.0:   .-  * @Kernel.Base.ScalingContext@ has been simplified. -    ScalingContexts are no longer manipulated via a custom Reader-    monad or transformer as the type signatures were too unwieldy.+  * Re-worked the Chain module and API.   .-  * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing -    can now calculate more appealing bounding boxes for text.+  * Replaced @ZDeco@ enumeration with @ZOrder@.   .+  * Removed the @Basic.Geometry@ modules, they are superseded in +    Wumpus-Drawing. Some of the equivalent functionality is now+    internal to the respective modules in Wumpus-Drawing - Wumpus+    has scaled back the amount of /geometric/ types and operations+    it wants to expose.  +  .+  * Renamed the @PlacedTrail@ object to @AnaTrail@ - the prefix +    vector is considered an /anacrusis/. Tidied up the API of the +    @Trail@ module.+  .+  * Moved @bezierArcPoints@ and @BezierMinorArc@ from +    @Basic.Geometry@ and marked the @Basic.Geometry@ code as +    obsolute.+  .+  v0.21.0 to v0.22.0:+  .+  * Reverted argument order of @run@ functions they back to the +    @monadLib@ style (args * monadic_operation) rather than @MTL@+    style (monadic_operation * args). Typographically this seems +    better.+  .+  * Removed module @Geometry.Paths@ it is superseded in+    Wumpus-Drawing.+  .+  * Added user state to PosObject and moved it into +    @Kernel.Drawing@.+  .+  * Changed the enumeration @DrawStyle@ to @DrawMode@. Added +    another enumeration @PathMode@.+  .+  * Changed Chain so that first item in the chain is the start +    point (previously the start point was iterated by the chain).+  .+  * Removed @ConnectorProps@ from the @DrawingContext@ , they are +    now used \"locally\" in Wumpus-Drawing.+  .+  * Added more vector constructors to +    @Kernel.Objects.Displacement@. +  .+  * Added extra methods to the @Decorate@ class for annotating +    SVG elements.+  .+  v0.20.0 to v0.21.0:+  .+  * The code from the @Kernel.Base.UserState@ module has been +    moved to the module @Kernel.Drawing.Basis@.+  .+  * Moved @Image@ and @Query@ from @Objects.Basis@ to new module+    @Objects.Image@. Moved @Chain@, @CtxPicture@ and +    @TraceDrawing@ into the new @Drawing@ folder.+  .+  * Added @Wumpus.Basic.Kernel.Drawing.LocDrawing@ module.+  . +  * Rationalized the combinators exported by the drawing objects +    @Image@, @LocImage@, @LocThetaImage@ and @Connector@.+  . +  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2@@ -59,7 +106,10 @@ extra-source-files:   CHANGES,   LICENSE,-  demo/FontDeltaPic.hs+  demo/AltUnits.hs,+  demo/FontDeltaPic.hs,+  demo/SimpleAdvGraphic.hs,+  demo/SimplePosObject.hs  library   hs-source-dirs:     src@@ -68,37 +118,47 @@                       directory       >= 1.0     && <  2.0,                        filepath        >= 1.1     && <  2.0,                       vector-space    >= 0.6     && <  1.0,-                      wumpus-core     >= 0.42.0  && <  0.43.0+                      wumpus-core     >= 0.52.0  && <  0.53.0       exposed-modules:     Wumpus.Basic.Kernel,-    Wumpus.Basic.Kernel.Base.Anchors,     Wumpus.Basic.Kernel.Base.BaseDefs,-    Wumpus.Basic.Kernel.Base.ContextFun,     Wumpus.Basic.Kernel.Base.DrawingContext,-    Wumpus.Basic.Kernel.Base.GlyphMetrics,+    Wumpus.Basic.Kernel.Base.FontSupport,     Wumpus.Basic.Kernel.Base.QueryDC,-    Wumpus.Basic.Kernel.Base.ScalingContext,+    Wumpus.Basic.Kernel.Base.Units,     Wumpus.Basic.Kernel.Base.UpdateDC,     Wumpus.Basic.Kernel.Base.WrappedPrimitive,-    Wumpus.Basic.Kernel.Objects.AdvanceGraphic,-    Wumpus.Basic.Kernel.Objects.BaseObjects,+    Wumpus.Basic.Kernel.Drawing.Basis,+    Wumpus.Basic.Kernel.Drawing.Chain,+    Wumpus.Basic.Kernel.Drawing.CtxPicture,+    Wumpus.Basic.Kernel.Drawing.LocDrawing,+    Wumpus.Basic.Kernel.Drawing.LocTrace,+    Wumpus.Basic.Kernel.Drawing.PosObject,+    Wumpus.Basic.Kernel.Drawing.TraceDrawing,+    Wumpus.Basic.Kernel.Objects.AdvObject,+    Wumpus.Basic.Kernel.Objects.Anchors,+    Wumpus.Basic.Kernel.Objects.Basis,     Wumpus.Basic.Kernel.Objects.Bounded,+    Wumpus.Basic.Kernel.Objects.Concat,     Wumpus.Basic.Kernel.Objects.Connector,-    Wumpus.Basic.Kernel.Objects.CtxPicture,-    Wumpus.Basic.Kernel.Objects.Graphic,-    Wumpus.Basic.Kernel.Objects.TraceDrawing,-    Wumpus.Basic.System.FontLoader.Afm,-    Wumpus.Basic.System.FontLoader.GhostScript,-    Wumpus.Basic.System.FontLoader.Base.AfmParserBase,-    Wumpus.Basic.System.FontLoader.Base.AfmV2Parser,-    Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser,-    Wumpus.Basic.System.FontLoader.Base.Datatypes,-    Wumpus.Basic.System.FontLoader.Base.FontLoadMonad,-    Wumpus.Basic.System.FontLoader.Base.GSFontMap,+    Wumpus.Basic.Kernel.Objects.Displacement,+    Wumpus.Basic.Kernel.Objects.DrawingPrimitives,+    Wumpus.Basic.Kernel.Objects.Image,+    Wumpus.Basic.Kernel.Objects.LocImage,+    Wumpus.Basic.Kernel.Objects.LocThetaImage,+    Wumpus.Basic.Kernel.Objects.Orientation,+    Wumpus.Basic.Kernel.Objects.Trail,+    Wumpus.Basic.System.FontLoader,+    Wumpus.Basic.System.FontLoader.AfmParserBase,+    Wumpus.Basic.System.FontLoader.AfmTopLevel,+    Wumpus.Basic.System.FontLoader.AfmV2Parser,+    Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser,+    Wumpus.Basic.System.FontLoader.Datatypes,+    Wumpus.Basic.System.FontLoader.FontLoadMonad,+    Wumpus.Basic.System.FontLoader.GSTopLevel,     Wumpus.Basic.Utils.HList,-    Wumpus.Basic.Utils.FormatCombinators,     Wumpus.Basic.Utils.JoinList,     Wumpus.Basic.Utils.ParserCombinators,     Wumpus.Basic.Utils.TokenParsers,