wumpus-basic 0.5.0 → 0.6.0

raw patch · 15 files changed

+428/−361 lines, 15 filesdep ~wumpus-corePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: wumpus-core

API changes (from Hackage documentation)

Files

• CHANGES +42/−0
• demo/ColourCharts.hs +2/−1
• demo/DotPic.hs +2/−2
• demo/FontPic.hs +1/−1
• demo/Picture.hs +9/−8
• src/Wumpus/Basic/Arrows.hs +1/−1
• src/Wumpus/Basic/Arrows/Tips.hs +6/−5
• src/Wumpus/Basic/Dots/Base.hs +28/−27
• src/Wumpus/Basic/Graphic.hs +4/−267
• src/Wumpus/Basic/Graphic/DrawingAttr.hs +14/−8
• src/Wumpus/Basic/Graphic/Primitive.hs +297/−0
• src/Wumpus/Basic/Paths.hs +2/−1
• src/Wumpus/Basic/Text/LRText.hs +5/−2
• src/Wumpus/Basic/VersionNumber.hs +2/−2
• wumpus-basic.cabal +13/−36

@@ -1,5 +1,47 @@ +0.4.0 to 0.5.0: +  * Re-worked the PictureLanguage module.++  * SVGColours and X11Colours moved into @Wumpus.Basic.Colour@.+    Naming scheme for colours changed to use underscore between +    words rather than camelCase.+ +  * Updates to work with wumpus-core-0.30.0.+ +0.3.0 to 0.4.0:++  * Reworked the monads. Monads.DrawingMonad replaces +    Monads.Trace, Monads.DrawingCtx, Monads.ConsDrawing. The +    SnocDrawing monads have been removed as they were a design+    mistake.++  * Removed MGraphicF type, added AGraphic.++  * Initial work on arrow drawing and extended text drawing.++0.2.0 to 0.3.0 :+ +  * Added the anchors, monads, drawingAttrs...++  * Added the module @PictureLanguage@ from Wumpus-Core.+    It is located with the path prefix @Wumpus.Deprecated@.+    At some point it will be replaced...++  * Basic.Graphic - rectangles and lines now take the supplied+    point to be the center rather than the bottom-left corner.+    Name changes - @circle@ changed to @disk@, @text@ changed to +    @textline@.++0.1.1 to 0.2.0:++  * Added the module @Wumpus.Basic.Graphic@.++  * SafeFonts changed to be size neutral. PostScript\'s +    @scalefont@ command (which wumpus-core uses in the generated+    output) should be able to scale to any integer size.++  * New demo @ColourCharts.hs@.  0.1.0 to 0.1.1: 

@@ -5,6 +5,7 @@ import ColourDefns  import Wumpus.Core+import Wumpus.Basic.Colour.SVGColours ( black ) import Wumpus.Basic.Graphic import Wumpus.Basic.SafeFonts import Wumpus.Basic.Utils.HList@@ -54,7 +55,7 @@ colourSample (name,rgb) = block `cc` lbl    where     block = filledRectangle rgb  15 10-    lbl   = textline (FontAttr 10 courier) name . (.+^ hvec 18)+    lbl   = textline black (FontAttr 10 courier) name . (.+^ hvec 18)   

@@ -62,8 +62,8 @@            => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline   where-    dashline = wrapG $ ostroke attr $ vertexPath xs-    attr     = (cadet_blue, DashPattern $ evenDashes 1)+    dashline = wrapG $ ostroke cadet_blue attr $ vertexPath xs+    attr     = default_stroke_attr { dash_pattern = evenDashes 1 }   errK :: a

@@ -30,7 +30,7 @@   makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimitive-makeFontLabel c fa = textlabel (c,fa) msg+makeFontLabel rgb fa = textlabel rgb fa msg   where     msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"] 

@@ -37,7 +37,7 @@   pic3 :: DPicture -pic3 = picAnno pic "rect_red `centerOver` rect_green `centerOver` rect_blue"+pic3 = picAnno pic "red `centerOver` green `centerOver` blue"   where     pic :: DPicture     pic = illustrateBounds blue $ @@ -46,7 +46,7 @@ -- Note - nextToH only moves pictures in the horizontal. -- pic4 :: DPicture -pic4 = picAnno pic "rect_red `nextToH` rect_green `nextToH` rect_blue"+pic4 = picAnno pic "red `nextToH` green `nextToH` blue"   where     pic :: DPicture     pic = illustrateBounds blue $ @@ -55,7 +55,7 @@ -- Note - nextToV only moves pictures in the vertical. -- pic5 :: DPicture -pic5 = picAnno pic "rect_red `nextToV` rect_green `nextToV` rect_blue"+pic5 = picAnno pic "red `nextToV` green `nextToV` blue"   where     pic :: DPicture     pic = illustrateBounds blue $ @@ -128,20 +128,21 @@ picAnno pic msg = alignHSep HCenter 30 pic lbl   where     lbl = drawGraphicU $ supply (P2 0 0) $ -            textline (black,FontAttr 14 courier) msg+            textline black (FontAttr 14 courier) msg   rect_red :: DPicture rect_red = drawGraphicU $ supply (P2 0 10) $ -          strokedRectangle black 30 10 `cc` filledRectangle indian_red 30 10+          strokedRectangle black zeroSA 30 10 `cc` filledRectangle indian_red 30 10  rect_green :: DPicture rect_green = drawGraphicU $ supply (P2 10 10) $ -    strokedRectangle black 15 15 `cc` filledRectangle olive_drab 15 15+    strokedRectangle black zeroSA 15 15 `cc` filledRectangle olive_drab 15 15   rect_blue :: DPicture rect_blue = drawGraphicU $ supply (P2 10 0) $ -    strokedRectangle black 20 30 `cc` filledRectangle powder_blue 20 30-+    strokedRectangle black zeroSA 20 30 `cc` filledRectangle powder_blue 20 30 +zeroSA :: StrokeAttr+zeroSA = default_stroke_attr

@@ -129,7 +129,7 @@     pathGraphic short_path attr . tipF theta attr p1   where     sz              = arrowWidth attr-    line_unit       = realToFrac $ (line_width attr)+    line_unit       = realToFrac $ (line_width $ stroke_props attr)     long_path       = pathF p0 p1     short_path      = shortenR (sz+line_unit) long_path     mid_short_path  = shortenR (0.5*sz) long_path

@@ -88,21 +88,21 @@  otri90 :: (Floating u, Real u, FromPtSize u)       => Radian -> DrawingAttr -> GraphicF u-otri90 = triAng (pi/2) (\p a -> cstroke (strokeAttr a) p)+otri90 = triAng (pi/2) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)  otri60 :: (Floating u, Real u, FromPtSize u)       => Radian -> DrawingAttr -> GraphicF u-otri60 = triAng (pi/3) (\p a -> cstroke (strokeAttr a) p)+otri60 = triAng (pi/3) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)  otri45 :: (Floating u, Real u, FromPtSize u)       => Radian -> DrawingAttr -> GraphicF u-otri45 = triAng (pi/4) (\p a -> cstroke (strokeAttr a) p)+otri45 = triAng (pi/4) (\p a -> cstroke (stroke_colour a) (stroke_props a) p)   barbAng :: (Floating u, Real u, FromPtSize u)       => Radian -> Radian -> DrawingAttr -> GraphicF u barbAng ang theta attr pt = -    wrapG $ ostroke (strokeAttr attr) $ vertexPath [u,pt,v]+    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ vertexPath [u,pt,v]   where     sz    = fromPtSize $ xcharHeight $ font_size $ font_props attr     (u,v) = tripoints ang sz theta  pt@@ -124,7 +124,8 @@  perp :: (Floating u, FromPtSize u) => Radian -> DrawingAttr -> GraphicF u perp theta attr = \pt -> -    wrapG $ ostroke (strokeAttr attr) $ vertexPath [ pt .+^ v, pt .-^ v]+    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) +          $ vertexPath [ pt .+^ v, pt .-^ v]   where     half_sz = 0.5 * (fromPtSize $ xcharHeight $ font_size $ font_props attr)     v       = avec (theta + pi/2) half_sz

@@ -55,28 +55,27 @@  -- NOTES ----- Affine transforming Points, LineSegments etc. before--- they become pictures is _GOOD_! The calculations are done in --- Wumpus and so don't cause extra (gsave... grestore) in --- PostScript.+-- TikZ has both stroked and bordered (filled and outline-stroked)+-- marks e.g. square and square* -- + dotChar :: (Fractional u, FromPtSize u) => Char -> DrawingAttr -> GraphicF u dotChar ch = dotText [ch]  dotText :: (Fractional u, FromPtSize u) => String -> DrawingAttr -> GraphicF u dotText str attr = \ctr -> let pt = disp (-hw) (-hh) ctr in-    wrapG $ textlabel (textAttr attr) str pt+    wrapG $ textlabel (stroke_colour attr) (font_props attr) str pt   where-    sz = font_size $ font_props attr+    sz = font_size  $ font_props attr     hh = fromPtSize $ 0.5 * numeralHeight sz     hw = fromPtSize $ 0.5 * textWidth sz (length str)   -- | Supplied point is the center. ---axialLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u-axialLine t v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in-    wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]+axialLine :: Fractional u => RGBi -> StrokeAttr -> Vec2 u -> GraphicF u+axialLine rgb attr v = \ctr -> let pt = ctr .-^ (0.5 *^ v) in+    wrapG $ ostroke rgb attr $ path pt [lineTo $ pt .+^ v]    @@ -87,12 +86,12 @@ --  dotHLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u  dotHLine attr = let w = markHeight attr in -    axialLine (strokeAttr attr) (hvec w)+    axialLine (stroke_colour attr) (stroke_props attr) (hvec w)       dotVLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u  dotVLine attr = let h = markHeight attr in -    axialLine (strokeAttr attr) (vvec h)+    axialLine (stroke_colour attr) (stroke_props attr) (vvec h)   dotX :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u@@ -100,8 +99,8 @@   where     h        = markHeight attr     w        = 0.75 * h-    ls1      = axialLine (strokeAttr attr) (vec w    h)-    ls2      = axialLine (strokeAttr attr) (vec (-w) h)+    ls1      = axialLine (stroke_colour attr) (stroke_props attr) (vec w h)+    ls2      = axialLine (stroke_colour attr) (stroke_props attr) (vec (-w) h)   dotPlus :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u@@ -112,8 +111,8 @@ dotCross attr = ls1 `cc` ls2   where     z        = markHeight attr-    ls1      = axialLine (strokeAttr attr) (avec (pi*0.25)    z)-    ls2      = axialLine (strokeAttr attr) (avec (negate $ pi*0.25) z)+    ls1      = axialLine (stroke_colour attr) (stroke_props attr) (avec (pi*0.25) z)+    ls2      = axialLine (stroke_colour attr) (stroke_props attr) (avec (negate $ pi*0.25) z)   -- needs horizontal pinch...@@ -132,12 +131,12 @@  dotDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u dotDiamond attr = -    wrapG . cstroke (strokeAttr attr) . pathDiamond attr+    wrapG . cstroke (stroke_colour attr) (stroke_props attr) . pathDiamond attr  dotFDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u dotFDiamond attr = dotDiamond attr `cc` filled    where-    filled = wrapG . fill (fillAttr attr) . pathDiamond attr+    filled = wrapG . fill (fill_colour attr) . pathDiamond attr   @@ -149,17 +148,18 @@  dotSquare :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u dotSquare attr = let u = markHeight attr in-     strokedRectangle (strokeAttr attr) u u +     strokedRectangle (stroke_colour attr) (stroke_props attr) u u         dotCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u-dotCircle attr = disk (strokeAttr attr) (0.5*markHeight attr) +dotCircle attr = disk (stroke_colour attr) (0.5*markHeight attr)    dotPentagon :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u dotPentagon attr = -    wrapG . cstroke (strokeAttr attr) . vertexPath . polygonPointsV 5 hh+    wrapG . cstroke (stroke_colour attr) (stroke_props attr) +          . vertexPath . polygonPointsV 5 hh   where     hh      = 0.5 * markHeight attr @@ -169,7 +169,8 @@ dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt   where     hh        = 0.5 * markHeight attr-    fn pt pt' = wrapG $ cstroke (strokeAttr attr) $ path pt [lineTo pt'] +    fn pt pt' = wrapG $ cstroke (stroke_colour attr) (stroke_props attr) +                      $ path pt [lineTo pt']    @@ -177,12 +178,12 @@ dotAsterisk :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u dotAsterisk attr = ls1 `cc` ls2 `cc` ls3   where-    z        = markHeight attr-    props    = strokeAttr attr-    ang      = two_pi / 6-    ls1      = axialLine props (vvec z)-    ls2      = axialLine props (avec (half_pi + ang)    z)-    ls3      = axialLine props (avec (half_pi + ang + ang) z)+    z         = markHeight attr+    (rgb,sa)  = strokeAttr attr+    ang       = two_pi / 6+    ls1       = axialLine rgb sa (vvec z)+    ls2       = axialLine rgb sa (avec (half_pi + ang)    z)+    ls3       = axialLine rgb sa (avec (half_pi + ang + ang) z)   dotOPlus :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u

@@ -10,7 +10,7 @@ -- Stability   :  highly unstable -- Portability :  GHC  ----- Graphic type and opertations+-- Import shim for @Wumpus.Basic.Graphic.Primitive@. -- -- \*\* WARNING \*\* - this module is highly experimental, and  -- may change significantly or even be dropped from future @@ -21,271 +21,8 @@  module Wumpus.Basic.Graphic   (-  -- * Type aliases-    Graphic  -  , DGraphic--  , GraphicF-  , DGraphicF---  -- * General combinators-  , cc-  , supply--  -- * Operations-  , drawGraphic-  , drawGraphicU--  , wrapG-  , emptyG --  -- * Graphic primitives-  , textline-  , straightLine-  , strokedRectangle-  , filledRectangle-  , rectanglePath-  , strokedCircle-  , filledCircle-  , disk--  -- * Displacement-  , Point2T-  , DPoint2T -  , positionWith-  , disp-  , vdisp-  , hdisp--  -- * Grid-  , Rectangle(..)-  , DRectangle-  , grid-  , border--  , RectangleLoc-  , DRectangleLoc-  , withinRectangleLoc-+    module Wumpus.Basic.Graphic.Primitive+     ) where -import Wumpus.Basic.Graphic.PointSupply-import Wumpus.Basic.Utils.HList--import Wumpus.Core                      -- package: wumpus-core--import Data.AffineSpace                 -- package: vector-space--import Data.Maybe------ | Note - this representation allows for zero, one or more--- Primitives to be collected together.----type Graphic u          = H (Primitive u)--type DGraphic           = Graphic Double--type GraphicF u         = Point2 u -> Graphic u--type DGraphicF          = GraphicF Double-------------------------------------------------------------------------------------- Combinators...--infixr 9 `cc`---- | Composition operator...------ > cc f g = \x y -> f x (g x y)----cc :: (r1 -> a -> ans) -> (r1 -> r2 -> a) -> r1 -> r2 -> ans-cc f g = \x y -> f x (g x y)----- | Reverse application.----supply :: u -> (u -> a) -> a -supply u f = f u--------------------------------------------------------------------------------------- | Note - a Picture cannot be empty whereas a Graphic can.--- Hence this function returns via Maybe.----drawGraphic :: (Real u, Floating u, FromPtSize u) -            => Graphic u -> Maybe (Picture u)-drawGraphic f = post $ f []-  where-    post [] = Nothing-    post xs = Just $ frame xs ----- | /Unsafe/ version of 'drawGraphic' - this function throws --- an error when the graphic is empty.----drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u-drawGraphicU = fromMaybe errK . drawGraphic-  where-    errK = error "drawGraphic - empty Graphic."----- | Lift a Primitive to a Graphic----wrapG :: Primitive u -> Graphic u-wrapG = wrapH ---- | The empty graphic.----emptyG :: Graphic u-emptyG = emptyH-------------------------------------------------------------------------------------- | Text should not contain newlines.------ Note the supplied point is the \'left-baseline\'.----textline :: (TextLabel t, Num u) => t -> String -> GraphicF u-textline t ss = wrapG . textlabel t ss ----- | Vector is applied to the point.----straightLine :: (Stroke t, Fractional u) => t -> Vec2 u -> GraphicF u-straightLine t v = \pt -> wrapG $ ostroke t $ path pt [lineTo $ pt .+^ v]- ---- | Supplied point is center.----strokedRectangle :: (Stroke t, Fractional u) => t -> u -> u -> GraphicF u-strokedRectangle t w h = wrapG . cstroke t . rectangle w h---- | Supplied point is center.----filledRectangle :: (Fill t, Fractional u) => t -> u -> u -> GraphicF u-filledRectangle t w h = wrapG . fill t . rectangle w h--rectangle :: Fractional u => u -> u -> Point2 u -> PrimPath u-rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))---- | Supplied point is /bottom-left/.----rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u-rectanglePath w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]-  where-    br = bl .+^ hvec w-    tr = br .+^ vvec h-    tl = bl .+^ vvec h ----- | 'strokedCircle' : @ stroked_props * num_subs * radius -> GraphicF @------ Draw a stroked circle made from Bezier curves. @num_subs@ is --- the number of subdivisions per quadrant.------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is the center. --- -strokedCircle :: (Stroke t, Floating u) => t -> Int -> u -> GraphicF u-strokedCircle t n r = wrapG . cstroke t . curvedPath . bezierCircle n r----- | 'filledCircle' : @ fill_props * num_subs * radius -> GraphicF @------ Draw a filled circle made from Bezier curves. @num_subs@ is --- the number of subdivisions per quadrant.------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is the center. ----filledCircle :: (Fill t, Floating u) => t -> Int -> u -> GraphicF u-filledCircle t n r = wrapG . fill t . curvedPath . bezierCircle n r------ | '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 scaled, consider making the --- circle from Bezier curves.----disk :: (Ellipse t, Fractional u) => t -> u -> GraphicF u-disk t radius = wrapG . ellipse t radius radius -------------------------------------------------------------------------------------- Transforming points...---type Point2T    u = Point2 u -> Point2 u--type DPoint2T     = Point2T Double--positionWith :: Point2T u -> (Point2 u -> a) -> (Point2 u -> a)-positionWith displacer gf  = gf . displacer ---disp :: Num u => u -> u -> Point2T u-disp x y = (.+^ V2 x y)--hdisp :: Num u => u -> Point2T u-hdisp x = disp x 0--vdisp :: Num u => u -> Point2T u-vdisp y = disp 0 y------------------------------------------------------------------------------------- need a border / frame abstraction...--data Rectangle u = Rectangle -      { rect_width     :: !u-      , rect_height    :: !u -      }  -  deriving (Eq,Ord,Show)--type DRectangle = Rectangle Double---- | 'grid' : @ stroke_props * xstep * ystep * boundary_rect -> GraphicF @------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is bottom-left. ----grid :: (Stroke t, RealFrac u) => t -> u -> u -> Rectangle u -> GraphicF u -grid t xstep ystep (Rectangle w h) = \pt ->-    vlines pt . hlines pt-  where-    vlines (P2 x y) = veloH (straightLine t (vvec h)) $ hpoints y xstep (x,x+w)-    hlines (P2 x y) = veloH (straightLine t (hvec w)) $ vpoints x ystep (y,y+h)-    ---- | 'border' : @ stroke_props * boundary_rect -> GraphicF @------ The result is a HOF (GraphicF :: Point -> Graphic) where the --- point is bottom-left. ----border :: (Stroke t, Num u) => t -> Rectangle u -> GraphicF u-border t (Rectangle w h) = wrapG . cstroke t . rectanglePath w h----type RectangleLoc u = (Rectangle u, Point2 u)--type DRectangleLoc = RectangleLoc Double---withinRectangleLoc :: (Num u, Ord u) => Point2 u -> RectangleLoc u -> Bool-withinRectangleLoc (P2 x y) (Rectangle w h, P2 ox oy) = -   ox <= x && x <= (ox+w) && oy <= y && y <= (oy+h)---+import Wumpus.Basic.Graphic.Primitive

@@ -49,7 +49,7 @@ import Control.Applicative  data DrawingAttr = DrawingAttr -      { line_width         :: Double+      { stroke_props       :: StrokeAttr       , font_props         :: FontAttr       , stroke_colour      :: RGBi       , fill_colour        :: RGBi@@ -57,14 +57,14 @@   deriving (Eq,Show)  standardAttr :: FontSize -> DrawingAttr-standardAttr sz = DrawingAttr { line_width         = std_line_width+standardAttr sz = DrawingAttr { stroke_props       = default_stroke_attr                               , font_props         = FontAttr sz courier                               , stroke_colour      = black                               , fill_colour        = gold  }    strokeAttr :: DrawingAttr -> (RGBi, StrokeAttr)-strokeAttr = liftA2 (,) stroke_colour (LineWidth . line_width)+strokeAttr = liftA2 (,) stroke_colour stroke_props  fillAttr :: DrawingAttr -> RGBi fillAttr = fill_colour@@ -96,8 +96,8 @@ -- Note - some care might be needed if we ever define other unit  -- types... -std_line_width      :: Double-std_line_width      = 1.0+-- std_line_width      :: Double+-- std_line_width      = 1.0  thick_line          :: Double thick_line          = 2.0@@ -108,14 +108,20 @@ thin_line           :: Double thin_line           = 0.5 +setLineWidth       :: Double -> DrawingAttr -> DrawingAttr+setLineWidth d      = star (\s i -> s { stroke_props = upd i} ) stroke_props+  where+   upd attrs        = attrs { line_width = d }++ thick               :: DrawingAttr -> DrawingAttr-thick attr          = attr { line_width = thick_line }+thick               = setLineWidth thick_line  ultrathick          :: DrawingAttr -> DrawingAttr-ultrathick attr     = attr { line_width = ultra_thick_line }+ultrathick          = setLineWidth ultra_thick_line  thin                :: DrawingAttr -> DrawingAttr-thin attr           = attr { line_width = thin_line }+thin                = setLineWidth thin_line   fontface            :: FontFace -> DrawingAttr -> DrawingAttr

@@ -0,0 +1,297 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module      :  Wumpus.Basic.Graphic.Primitive+-- Copyright   :  (c) Stephen Tetley 2010+-- License     :  BSD3+--+-- Maintainer  :  stephen.tetley@gmail.com+-- Stability   :  highly unstable+-- Portability :  GHC +--+-- Graphic types and operations.+--+-- \*\* WARNING \*\* - this due a major revision and will change+-- significantly (or disappear...).+--+--+--------------------------------------------------------------------------------++module Wumpus.Basic.Graphic.Primitive+  (+  -- * Type aliases+    Graphic  +  , DGraphic++  , GraphicF+  , DGraphicF+++  -- * General combinators+  , cc+  , supply++  -- * Operations+  , drawGraphic+  , drawGraphicU++  , wrapG+  , emptyG ++  -- * Graphic primitives+  , textline+  , xtextline+  , straightLine+  , strokedRectangle+  , filledRectangle+  , rectanglePath+  , strokedCircle+  , filledCircle+  , disk++  -- * Displacement+  , Point2T+  , DPoint2T +  , positionWith+  , disp+  , vdisp+  , hdisp++  -- * Grid+  , Rectangle(..)+  , DRectangle+  , grid+  , border++  , RectangleLoc+  , DRectangleLoc+  , withinRectangleLoc++  ) where++import Wumpus.Basic.Graphic.PointSupply+import Wumpus.Basic.Utils.HList++import Wumpus.Core                      -- package: wumpus-core++import Data.AffineSpace                 -- package: vector-space++import Data.Maybe++++-- | Note - this representation allows for zero, one or more+-- Primitives to be collected together.+--+type Graphic u          = H (Primitive u)++type DGraphic           = Graphic Double++type GraphicF u         = Point2 u -> Graphic u++type DGraphicF          = GraphicF Double+++--------------------------------------------------------------------------------+-- Combinators...++infixr 9 `cc`++-- | Composition operator...+--+-- > cc f g = \x y -> f x (g x y)+--+cc :: (r1 -> a -> ans) -> (r1 -> r2 -> a) -> r1 -> r2 -> ans+cc f g = \x y -> f x (g x y)+++-- | Reverse application.+--+supply :: u -> (u -> a) -> a +supply u f = f u+++--------------------------------------------------------------------------------++-- | Note - a Picture cannot be empty whereas a Graphic can.+-- Hence this function returns via Maybe.+--+drawGraphic :: (Real u, Floating u, FromPtSize u) +            => Graphic u -> Maybe (Picture u)+drawGraphic f = post $ f []+  where+    post [] = Nothing+    post xs = Just $ frame xs +++-- | /Unsafe/ version of 'drawGraphic' - this function throws +-- an error when the graphic is empty.+--+drawGraphicU :: (Real u, Floating u, FromPtSize u) => Graphic u -> Picture u+drawGraphicU = fromMaybe errK . drawGraphic+  where+    errK = error "drawGraphic - empty Graphic."+++-- | Lift a Primitive to a Graphic+--+wrapG :: Primitive u -> Graphic u+wrapG = wrapH ++-- | The empty graphic.+--+emptyG :: Graphic u+emptyG = emptyH++--------------------------------------------------------------------------------++-- | Text should not contain newlines.+--+-- Note the supplied point is the \'left-baseline\'.+--+textline :: Num u => RGBi -> FontAttr -> String -> GraphicF u+textline rgb attr ss = wrapG . textlabel rgb attr ss ++xtextline :: Num u => RGBi -> FontAttr -> XLink -> String -> GraphicF u+xtextline rgb attr xl ss = wrapG . xtextlabel rgb attr xl ss ++++-- | Vector is applied to the point.+--+straightLine :: Fractional u => RGBi -> StrokeAttr -> Vec2 u -> GraphicF u+straightLine rgb attr v = +    \pt -> wrapG $ ostroke rgb attr $ path pt [lineTo $ pt .+^ v]+ ++-- | Supplied point is center.+--+strokedRectangle :: Fractional u => RGBi -> StrokeAttr -> u -> u -> GraphicF u+strokedRectangle rgb attr w h = wrapG . cstroke rgb attr . rectangle w h++-- | Supplied point is center.+--+filledRectangle :: Fractional u => RGBi -> u -> u -> GraphicF u+filledRectangle rgb w h = wrapG . fill rgb . rectangle w h++rectangle :: Fractional u => u -> u -> Point2 u -> PrimPath u+rectangle w h ctr = rectanglePath w h (ctr .-^ vec (0.5*w) (0.5*h))++-- | Supplied point is /bottom-left/.+--+rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u+rectanglePath w h bl = path bl [ lineTo br, lineTo tr, lineTo tl ]+  where+    br = bl .+^ hvec w+    tr = br .+^ vvec h+    tl = bl .+^ vvec h +++-- | 'strokedCircle' : @ stroked_props * num_subs * radius -> GraphicF @+--+-- Draw a stroked circle made from Bezier curves. @num_subs@ is +-- the number of subdivisions per quadrant.+--+-- The result is a HOF (GraphicF :: Point -> Graphic) where the +-- point is the center. +-- +strokedCircle :: Floating u => RGBi -> StrokeAttr -> Int -> u -> GraphicF u+strokedCircle rgb attr n r = +    wrapG . cstroke rgb attr . curvedPath . bezierCircle n r+++-- | 'filledCircle' : @ fill_props * num_subs * radius -> GraphicF @+--+-- Draw a filled circle made from Bezier curves. @num_subs@ is +-- the number of subdivisions per quadrant.+--+-- The result is a HOF (GraphicF :: Point -> Graphic) where the +-- point is the center. +--+filledCircle :: Floating u => RGBi -> Int -> u -> GraphicF u+filledCircle rgb n r = wrapG . fill rgb . curvedPath . bezierCircle n r++++-- | '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 scaled, consider making the +-- circle from Bezier curves.+--+disk :: Fractional u => RGBi -> u -> GraphicF u+disk rgb radius = wrapG . fillEllipse rgb radius radius +++--------------------------------------------------------------------------------+-- Transforming points...+++type Point2T    u = Point2 u -> Point2 u++type DPoint2T     = Point2T Double++positionWith :: Point2T u -> (Point2 u -> a) -> (Point2 u -> a)+positionWith displacer gf  = gf . displacer +++disp :: Num u => u -> u -> Point2T u+disp x y = (.+^ V2 x y)++hdisp :: Num u => u -> Point2T u+hdisp x = disp x 0++vdisp :: Num u => u -> Point2T u+vdisp y = disp 0 y++--------------------------------------------------------------------------------+-- need a border / frame abstraction...++data Rectangle u = Rectangle +      { rect_width     :: !u+      , rect_height    :: !u +      }  +  deriving (Eq,Ord,Show)++type DRectangle = Rectangle Double++-- | 'grid' : @ stroke_props * xstep * ystep * boundary_rect -> GraphicF @+--+-- The result is a HOF (GraphicF :: Point -> Graphic) where the +-- point is bottom-left. +--+grid :: RealFrac u => RGBi -> StrokeAttr -> u -> u -> Rectangle u -> GraphicF u +grid rgb attr xstep ystep (Rectangle w h) = \pt ->+    vlines pt . hlines pt+  where+    vlines (P2 x y) = veloH (straightLine rgb attr (vvec h)) $ hpoints y xstep (x,x+w)+    hlines (P2 x y) = veloH (straightLine rgb attr (hvec w)) $ vpoints x ystep (y,y+h)+    ++-- | 'border' : @ stroke_props * boundary_rect -> GraphicF @+--+-- The result is a HOF (GraphicF :: Point -> Graphic) where the +-- point is bottom-left. +--+border :: Num u => RGBi -> StrokeAttr -> Rectangle u -> GraphicF u+border rgb attr (Rectangle w h) = wrapG . cstroke rgb attr . rectanglePath w h++++type RectangleLoc u = (Rectangle u, Point2 u)++type DRectangleLoc = RectangleLoc Double+++withinRectangleLoc :: (Num u, Ord u) => Point2 u -> RectangleLoc u -> Bool+withinRectangleLoc (P2 x y) (Rectangle w h, P2 ox oy) = +   ox <= x && x <= (ox+w) && oy <= y && y <= (oy+h)+++

@@ -54,7 +54,8 @@ -- This one might be more useful...  pathGraphic :: Num u => Path u -> DrawingAttr -> Graphic u-pathGraphic bpath attr = wrapG $ ostroke (strokeAttr attr) $ toPrimPathU bpath+pathGraphic bpath attr = +    wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ toPrimPathU bpath   

@@ -12,6 +12,9 @@ -- -- LRText monad - left-to-right text. -- +-- \*\* WARNING \*\* - This is out dated now that Wumpus-Core has+-- support for /kerned/ labels.+-- --------------------------------------------------------------------------------  module Wumpus.Basic.Text.LRText@@ -146,7 +149,7 @@ text str = TextM $ \r s -> ((), upd r s)   where     upd (vdist,rgb) s@(St idx font h acc) = -        let g1  = textline (rgb,font) str +        let g1  = textline rgb font str              v   = makeDisplacement (font_size font) h vdist idx         in s { xy_pos      = rightn (length str) idx              , acc_graphic = (v,g1) `consT` acc      }@@ -156,7 +159,7 @@ char ch = TextM $ \r s -> ((), upd r s)   where     upd (vdist,rgb) s@(St idx font h acc) = -        let g1  = textline (rgb,font) [ch] +        let g1  = textline rgb font [ch]              v   = makeDisplacement (font_size font) h vdist idx         in s { xy_pos      = rightn 1 idx              , acc_graphic = (v,g1) `consT` acc }

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

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.5.0+version:          0.6.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -20,6 +20,15 @@   .   Changelog:   .+  0.5.0 to 0.6.0:+  .+  * Updates to work with wumpus-core-0.30.0.+  .+  * The code from @Basic.Graphic@ has been moved in to +    @Basic.Graphic.Primitive@ - this module is due a major +    overhaul. @Basic.Graphic@ is now an /import/ shim for+    @Basic.Graphic.Primitive@.+  .   0.4.0 to 0.5.0:   .   * Re-worked the PictureLanguage module.@@ -30,40 +39,7 @@   .   * Updates to work with wumpus-core-0.30.0.   .-  0.3.0 to 0.4.0:   .-  * Reworked the monads. Monads.DrawingMonad replaces -    Monads.Trace, Monads.DrawingCtx, Monads.ConsDrawing. The -    SnocDrawing monads have been removed as they were a design-    mistake.-  .-  * Removed MGraphicF type, added AGraphic.-  .-  * Initial work on arrow drawing and extended text drawing.-  .-  0.2.0 to 0.3.0 :-  . -  * Added the anchors, monads, drawingAttrs...-  .-  * Added the module @PictureLanguage@ from Wumpus-Core.-    It is located with the path prefix @Wumpus.Deprecated@.-    At some point it will be replaced...-  .-  * Basic.Graphic - rectangles and lines now take the supplied-    point to be the center rather than the bottom-left corner.-    Name changes - @circle@ changed to @disk@, @text@ changed to -    @textline@.-  .-  0.1.1 to 0.2.0:-  .-  * Added the module @Wumpus.Basic.Graphic@.-  .-  * SafeFonts changed to be size neutral. PostScript\'s -    @scalefont@ command (which wumpus-core uses in the generated-    output) should be able to scale to any integer size.-  .-  * New demo @ColourCharts.hs@.-  . build-type:         Simple stability:          highly unstable cabal-version:      >= 1.2@@ -72,9 +48,9 @@   CHANGES,   LICENSE,   demo/DotPic.hs,-  demo/FontPic.hs,   demo/ColourCharts.hs,   demo/ColourDefns.hs,+  demo/FontPic.hs,   demo/Picture.hs  library@@ -82,7 +58,7 @@   build-depends:      base            <  5,                        containers      >= 0.3     && <= 0.4,                        vector-space    >= 0.6,-                      wumpus-core     >= 0.30.0+                      wumpus-core     == 0.31.0       exposed-modules:@@ -95,6 +71,7 @@     Wumpus.Basic.Dots.Base,     Wumpus.Basic.Graphic,     Wumpus.Basic.Graphic.DrawingAttr,+    Wumpus.Basic.Graphic.Primitive,     Wumpus.Basic.Graphic.PointSupply,     Wumpus.Basic.Monads.Drawing,     Wumpus.Basic.Monads.DrawingMonad,