diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -1,87 +1,59 @@ {-# OPTIONS -Wall #-} -module ColourCharts where +module ColourChart where import ColourDefns -import Wumpus.Core -import Wumpus.Basic.Colour.SVGColours ( black ) import Wumpus.Basic.Graphic -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Utils.HList -import Data.AffineSpace - -import Data.List -import Data.Maybe +import Wumpus.Core -- package: wumpus-core import System.Directory + main :: IO () -main = do - createDirectoryIfMissing True "./out/" - test01 - -test01 :: IO () -test01 = do +main = do + createDirectoryIfMissing True "./out/" writeEPS_latin1 "./out/SVGcolours.eps" svg writeSVG_latin1 "./out/SVGcolours.svg" svg writeEPS_latin1 "./out/X11colours.eps" $ uniformScale 0.75 x11_portrait writeSVG_latin1 "./out/X11colours.svg" x11_landscape svg :: Picture Double -svg = mkPic all_svg_colours (ixDownLeftRight 4 60 (scalePt 160)) +svg = makePicture 60 160 all_svg_colours x11_landscape :: Picture Double -x11_landscape = mkPic all_x11_colours (ixDownLeftRight 6 60 (scalePt 140)) +x11_landscape = makePicture 60 140 all_x11_colours x11_portrait :: Picture Double -x11_portrait = mkPic all_x11_colours (ixDownLeftRight 5 72 (scalePt 140)) - - --- Note - this is code from an old project that needs tidying up... - -mkPic :: [(String,RGBi)] -> [DPoint2] -> DPicture -mkPic cs pts = fromMaybe errK $ - drawGraphic $ concatH $ zipWith colourSample cs pts - where - errK = error "Empty Picture" - -scalePt :: Num u => u -> Point2 u -> Point2 u -scalePt w (P2 x y) = P2 (x*w) (y*12) - -colourSample :: (Fractional u, Floating u, Ord u) - => (String,RGBi) -> GraphicF u -colourSample (name,rgb) = block `cc` lbl - where - block = filledRectangle rgb 15 10 - lbl = textline black (FontAttr 10 courier) name . (.+^ hvec 18) +x11_portrait = makePicture 72 140 all_x11_colours +makePicture :: Int -> Double -> [(String,RGBi)] -> DPicture +makePicture row_count unit_width xs = + liftToPictureU $ execDrawing (standardContext 10) $ + downLeftRight row_count unit_width $ mapM_ fn xs + where + fn (name,rgb) = colourSample name rgb ---------------------------- - --- | Generate points in a grid - move down a whole column, move --- right one, move down the next column. --- --- Points are generated from count-1 to 0, but can be scaled --- or have the offest shifted with the point transformer function. +-- Note - cannot use node twice as it increments the point supply. -- -ixDownLeftRight :: (Num u) - => Int -> Int -> (Point2 u -> Point2 u) -> [Point2 u] -ixDownLeftRight row_count col_count fn = - [fn $ P2 x y | x <- countup (row_count - 1) - , y <- countdown (col_count - 1) ] +colourSample :: String -> RGBi -> ChainT Double (Drawing Double) () +colourSample name rgb = localCtx (secondaryColour rgb) $ do + { pt <- position + ; drawAt pt (borderedRectangle 15 10) + ; drawAt (displace 20 2 pt) (textline name) + } --- | Countdown from n to 0. -countdown :: Num u => Int -> [u] -countdown = unfoldr phi where - phi i | i < 0 = Nothing - phi i = Just (fromIntegral i,i-1) --- | Count up to n from 0. -countup :: Num u => Int -> [u] -countup n = unfoldr phi 0 where - phi i | i > n = Nothing - phi i = Just (fromIntegral i,i+1) +downLeftRight :: (Monad m, Num u, Ord u) + => Int -> u -> ChainT u m a -> m a +downLeftRight row_count width ma = runChainT fn start_pt ma + where + y_top = 12 * fromIntegral row_count + start_pt = P2 0 y_top + + fn (P2 x y) | y < 0 = P2 (x+width) y_top + | otherwise = P2 x (y - 12) + diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -4,11 +4,9 @@ import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Dots.Base +import Wumpus.Basic.Dots import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Basic.PictureLanguage -import Wumpus.Basic.Utils.HList import Wumpus.Core -- package: wumpus-core @@ -52,22 +50,27 @@ p16 = makeDotPic dotFDiamond points p17 = makeDotPic (dotText "AA") points -std_attr :: DrawingAttr -std_attr = standardAttr 12 +std_ctx :: DrawingContext +std_ctx = secondaryColour peru $ standardContext 12 points :: [Point2 Double] points = [P2 0 0, P2 32 10, P2 64 0, P2 96 10] + +-- Note - order of drawing is may need to change with future +-- revisions. +-- makeDotPic :: (Real u, Floating u, FromPtSize u) - => (DrawingAttr -> GraphicF u) -> [Point2 u] -> Picture u -makeDotPic fn xs = drawGraphicU $ veloH (fn std_attr) xs . dashline + => DotLocImage u -> [Point2 u] -> Picture u +makeDotPic dotImg xs = liftToPictureU $ execDrawing std_ctx $ do + dashline + mapM_ (\pt -> drawAtImg pt dotImg) xs where - dashline = wrapG $ ostroke cadet_blue attr $ vertexPath xs - attr = default_stroke_attr { dash_pattern = evenDashes 1 } + dashline = localCtx attrUpd (draw $ openStroke $ vertexPath xs) + attrUpd :: DrawingContext -> DrawingContext + attrUpd = dashPattern (evenDashes 1) . primaryColour cadet_blue -errK :: a -errK = error "no picture" diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -29,15 +29,15 @@ writeSVG_latin1 "./out/font_symbol.svg" symbol_pic -makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimitive +makeFontLabel :: RGBi -> FontAttr -> DPoint2 -> DPrimElement makeFontLabel rgb fa = textlabel rgb fa msg where msg = unwords [ font_name $ font_face fa, (show $ font_size fa) ++ "pt"] -blueLabel :: FontFace -> Int -> DPoint2 -> DPrimitive +blueLabel :: FontFace -> Int -> DPoint2 -> DPrimElement blueLabel ff i = makeFontLabel steel_blue (FontAttr i ff) -redLabel :: FontFace -> Int -> DPoint2 -> DPrimitive +redLabel :: FontFace -> Int -> DPoint2 -> DPrimElement redLabel ff i = makeFontLabel indian_red1 (FontAttr i ff) diff --git a/demo/Picture.hs b/demo/Picture.hs --- a/demo/Picture.hs +++ b/demo/Picture.hs @@ -5,7 +5,6 @@ import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Graphic import Wumpus.Basic.PictureLanguage -import Wumpus.Basic.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -124,25 +123,29 @@ -------------------------------------------------------------------------------- +pic_drawing_ctx :: DrawingContext +pic_drawing_ctx = standardContext 14 + picAnno :: DPicture -> String -> DPicture picAnno pic msg = alignHSep HCenter 30 pic lbl where - lbl = drawGraphicU $ supply (P2 0 0) $ - textline black (FontAttr 14 courier) msg + lbl = liftToPictureU $ execDrawing pic_drawing_ctx $ + drawAt zeroPt (textline msg) rect_red :: DPicture -rect_red = drawGraphicU $ supply (P2 0 10) $ - strokedRectangle black zeroSA 30 10 `cc` filledRectangle indian_red 30 10 - +rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $ + localCtx (secondaryColour indian_red) + (drawAt (P2 0 10) $ borderedRectangle 30 10) + rect_green :: DPicture -rect_green = drawGraphicU $ supply (P2 10 10) $ - strokedRectangle black zeroSA 15 15 `cc` filledRectangle olive_drab 15 15 +rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $ + localCtx (secondaryColour olive_drab) + (drawAt (P2 10 10) $ borderedRectangle 15 15) rect_blue :: DPicture -rect_blue = drawGraphicU $ supply (P2 10 0) $ - strokedRectangle black zeroSA 20 30 `cc` filledRectangle powder_blue 20 30 +rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $ + localCtx (secondaryColour powder_blue) + (drawAt (P2 10 0) $ borderedRectangle 20 30) -zeroSA :: StrokeAttr -zeroSA = default_stroke_attr diff --git a/src/Wumpus/Basic/Arrows.hs b/src/Wumpus/Basic/Arrows.hs --- a/src/Wumpus/Basic/Arrows.hs +++ b/src/Wumpus/Basic/Arrows.hs @@ -21,6 +21,7 @@ ( line + , arrowTri90 , arrowTri60 , arrowTri45 @@ -38,124 +39,129 @@ import Wumpus.Basic.Arrows.Tips import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.Drawing import Wumpus.Basic.Paths import Wumpus.Basic.Paths.Base import Wumpus.Basic.Utils.Intersection ( langle ) import Wumpus.Core -- package: wumpus-core +import Control.Applicative +liftPathF :: PathF u -> ConnDrawingObject u (Path u) +liftPathF pF p1 p2 = DrawingObject $ \ _ -> pF p1 p2 -arrowWidth :: FromPtSize u => DrawingAttr -> u -arrowWidth = fromPtSize . xcharHeight . font_size . font_props +line :: Num u => PathF u -> ConnImage u (Path u) +line pathF = intoConnImage (liftPathF pathF) (pathGraphic pathF) -line :: Num u => PathF u -> AConnector u (Path u) -line pathF p0 p1 = AGraphic df mf +-- Here the path is already shortened - we have accounted for the +-- points already, so it is just a graphic. +lineTipR :: Num u => Path u -> Graphic u -> Graphic u +lineTipR bpath tip = openStroke (toPrimPathU bpath) `appendGraphic` tip + + + + +-- | Returns two items: +-- +-- 1. Shorten the line by the line width - this stops the path +-- tip puncturing the arrow head (particulary visible on open +-- triangle tips). +-- +-- 2. Calculate the direction back along the line at half the +-- lower_x_height - this gets a good angle for the tip on curved +-- path segments. +-- +rightPathProps :: (Real u, Floating u, FromPtSize u) + => PathF u -> ConnDrawingObject u (Path u,Radian) +rightPathProps pathF p1 p2 = + (\h sw -> (shortenPath h sw, calcTheta h)) + <$> asksObj lowerxHeight <*> asksObj (line_width . stroke_props) where - df attr () = pathGraphic (pathF p0 p1) attr - mf _ () = pathF p0 p1 + long_path = pathF p1 p2 + shortenPath lxh sw = shortenR (lxh + (realToFrac sw)) long_path + calcTheta lxh = directionR $ shortenR (0.5*lxh) long_path +triTipRight :: (Real u, Floating u, FromPtSize u) + => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) +triTipRight pathF tipF p1 p2 = + rightPathProps pathF p1 p2 >>= \(shortF,theta) -> + lineTipR shortF (tipF theta p2) >>= \arrow_pic -> + return (pathF p1 p2, arrow_pic) + + + + +-- This version does not /retract/ the path... +-- +barbTipRight :: (Real u, Floating u, FromPtSize u) + => PathF u -> (Radian -> LocGraphic u) -> ConnImage u (Path u) +barbTipRight pathF tipF p1 p2 = + rightPathProps pathF p1 p2 >>= \(_,theta) -> + lineTipR path_zero (tipF theta p2) >>= \arrow_pic -> + return (path_zero, arrow_pic) + where + path_zero = pathF p1 p2 + + + arrowTri90 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowTri90 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF tri90 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowTri90 pathF = triTipRight pathF tri90 + + + arrowTri60 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowTri60 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF tri60 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowTri60 pathF = triTipRight pathF tri60 + arrowTri45 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowTri45 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF tri45 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowTri45 pathF = triTipRight pathF tri45 + arrowOTri90 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowOTri90 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF otri90 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowOTri90 pathF = triTipRight pathF otri90 + arrowOTri60 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowOTri60 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF otri60 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowOTri60 pathF = triTipRight pathF otri60 + arrowOTri45 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowOTri45 pathF = \p0 p1 -> - AGraphic (\attr () -> triTipRight pathF otri45 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowOTri45 pathF = triTipRight pathF otri45 + arrowBarb90 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowBarb90 pathF = \p0 p1 -> - AGraphic (\attr () -> barbTipRight pathF barb90 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowBarb90 pathF = barbTipRight pathF barb90 arrowBarb60 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowBarb60 pathF = \p0 p1 -> - AGraphic (\attr () -> barbTipRight pathF barb60 p0 p1 attr) - (\_ () -> pathF p0 p1) + => PathF u -> ConnImage u (Path u) +arrowBarb60 pathF = barbTipRight pathF barb60 arrowBarb45 :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowBarb45 pathF = \p0 p1 -> - AGraphic (\attr () -> barbTipRight pathF barb45 p0 p1 attr) - (\_ () -> pathF p0 p1) - + => PathF u -> ConnImage u (Path u) +arrowBarb45 pathF = barbTipRight pathF barb45 -triTipRight :: (Real u, Floating u, FromPtSize u) - => PathF u - -> (Radian -> DrawingAttr -> GraphicF u) - -> Point2 u -> Point2 u -> DrawingAttr - -> Graphic u -triTipRight pathF tipF p0 p1 attr = - pathGraphic short_path attr . tipF theta attr p1 - where - sz = arrowWidth 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 - theta = directionR mid_short_path - - -barbTipRight :: (Real u, Floating u, FromPtSize u) - => PathF u - -> (Radian -> DrawingAttr -> GraphicF u) - -> Point2 u -> Point2 u -> DrawingAttr - -> Graphic u -barbTipRight pathF tipF p0 p1 attr = - pathGraphic long_path attr . tipF theta attr p1 - where - sz = arrowWidth attr - long_path = pathF p0 p1 - mid_short_path = shortenR (0.5*sz) long_path - theta = directionR mid_short_path - - arrowPerp :: (Real u, Floating u, FromPtSize u) - => PathF u -> AConnector u (Path u) -arrowPerp pathF p0 p1 = AGraphic df mf + => PathF u -> ConnImage u (Path u) +arrowPerp pathF p1 p2 = + lineTipR path_zero perp_tip >>= \arrow_pic -> return (path_zero, arrow_pic) where - df attr () = let theta = langle p0 p1 in - pathGraphic (pathF p0 p1) attr . perp theta attr p1 - mf _ () = pathF p0 p1 - + path_zero = pathF p1 p2 + theta = langle p1 p2 + perp_tip = perp theta p2 diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs --- a/src/Wumpus/Basic/Arrows/Tips.hs +++ b/src/Wumpus/Basic/Arrows/Tips.hs @@ -20,6 +20,7 @@ module Wumpus.Basic.Arrows.Tips ( + tri90 , tri60 , tri45 @@ -36,21 +37,25 @@ ) where import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space +import Control.Applicative -tripoints :: Floating u - => Radian -> u -> Radian -> Point2 u -> (Point2 u, Point2 u) -tripoints triang xchar_height theta tip = (tip .-^ v1, tip .-^ v2) +-- | tripoints takes dimensions from the xlowerHeight. +-- +tripoints :: (Floating u, FromPtSize u) + => Radian -> Radian -> LocDrawingObject u (Point2 u, Point2 u) +tripoints triang theta tip = + (\h -> let d = h / (fromRadian $ cos halfang) + in (tip .-^ v1 d, tip .-^ v2 d)) + <$> asksObj lowerxHeight where halfang = 0.5 * triang - d = xchar_height / (fromRadian $ cos halfang) - v1 = avec (theta + halfang) d - v2 = avec (theta - halfang) d + v1 d = avec (theta + halfang) d + v2 d = avec (theta - halfang) d @@ -59,73 +64,67 @@ triAng :: (Floating u, Real u, FromPtSize u) => Radian - -> (PrimPath u -> DrawingAttr -> Primitive u) - -> Radian -> DrawingAttr -> GraphicF u -triAng ang fn theta attr pt = wrapG $ fn (vertexPath [pt,u,v]) attr - where - sz = fromPtSize $ xcharHeight $ font_size $ font_props attr - (u,v) = tripoints ang sz theta pt + -> Radian + -> (PrimPath u -> Graphic u) + -> LocGraphic u +triAng triang theta gf pt = + tripoints triang theta pt >>= \(u,v) -> gf (vertexPath [pt,u,v]) --- The arg order should be: --- Radian -> DrawingAttr -> GraphicF u --- as DrawingAttr is a 'static' arg. +-- TODO - maybe filling needs to use swapColours tri90 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -tri90 = triAng (pi/2) (\p a -> fill (stroke_colour a) p) + => Radian -> LocGraphic u +tri90 theta = triAng (pi/2) theta filledPath tri60 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -tri60 = triAng (pi/3) (\p a -> fill (stroke_colour a) p) + => Radian -> LocGraphic u +tri60 theta = triAng (pi/3) theta filledPath + tri45 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -tri45 = triAng (pi/4) (\p a -> fill (stroke_colour a) p) + => Radian -> LocGraphic u +tri45 theta = triAng (pi/4) theta filledPath otri90 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -otri90 = triAng (pi/2) (\p a -> cstroke (stroke_colour a) (stroke_props a) p) + => Radian -> LocGraphic u +otri90 theta = triAng (pi/2) theta closedStroke + otri60 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -otri60 = triAng (pi/3) (\p a -> cstroke (stroke_colour a) (stroke_props a) p) + => Radian -> LocGraphic u +otri60 theta = triAng (pi/3) theta closedStroke otri45 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u -otri45 = triAng (pi/4) (\p a -> cstroke (stroke_colour a) (stroke_props a) p) - + => Radian -> LocGraphic u +otri45 theta = triAng (pi/4) theta closedStroke barbAng :: (Floating u, Real u, FromPtSize u) - => Radian -> Radian -> DrawingAttr -> GraphicF u -barbAng ang theta attr pt = - 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 + => Radian -> Radian -> LocGraphic u +barbAng ang theta pt = + tripoints ang theta pt >>= \(u,v) -> openStroke (vertexPath [u,pt,v]) barb90 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u + => Radian -> LocGraphic u barb90 = barbAng (pi/2) barb60 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u + => Radian -> LocGraphic u barb60 = barbAng (pi/3) barb45 :: (Floating u, Real u, FromPtSize u) - => Radian -> DrawingAttr -> GraphicF u + => Radian -> LocGraphic u barb45 = barbAng (pi/4) -perp :: (Floating u, FromPtSize u) => Radian -> DrawingAttr -> GraphicF u -perp theta attr = \pt -> - wrapG $ ostroke (stroke_colour attr) (stroke_props attr) - $ vertexPath [ pt .+^ v, pt .-^ v] +perp :: (Floating u, FromPtSize u) => Radian -> LocGraphic u +perp theta pt = + asksObj lowerxHeight >>= \ h -> + let v = makeV h in openStroke $ vertexPath [ pt .+^ v, pt .-^ v] where - half_sz = 0.5 * (fromPtSize $ xcharHeight $ font_size $ font_props attr) - v = avec (theta + pi/2) half_sz + makeV h = avec (theta + pi/2) (0.5 * h) diff --git a/src/Wumpus/Basic/Dots.hs b/src/Wumpus/Basic/Dots.hs --- a/src/Wumpus/Basic/Dots.hs +++ b/src/Wumpus/Basic/Dots.hs @@ -15,6 +15,10 @@ -- -- Dots with anchors. -- +-- In many cases a surrounding circle is used to locate anchor +-- points - this could be improved to use the actual dot border +-- at some point. +-- -------------------------------------------------------------------------------- module Wumpus.Basic.Dots @@ -22,26 +26,44 @@ -- * Existential anchor type DotAnchor + + , DotLocImage + , DDotLocImage -- * Dots with anchor points - , dotCircle - , dotDisk - , dotSquare , dotChar , dotText + , dotHLine + , dotVLine + , dotX + , dotPlus + , dotCross + , dotDiamond + , dotFDiamond + , dotDisk + , dotSquare + , dotCircle + , dotPentagon + , dotStar + + , dotAsterisk + , dotOPlus + , dotOCross + , dotFOCross + ) where import Wumpus.Basic.Anchors -import qualified Wumpus.Basic.Dots.Base as BD -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.Drawing +import Wumpus.Basic.Dots.Primitive +import Wumpus.Basic.Graphic import Wumpus.Basic.Utils.Intersection import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space +import Control.Applicative -- An existential thing that supports anchors. @@ -82,14 +104,6 @@ northwest (DotAnchor _ _ c1) = c1 NW -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u -circleAnchor rad ctr = DotAnchor ctr - (\theta -> ctr .+^ (avec theta rad)) - (radialCardinal rad ctr) - - - - radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u radialCardinal rad ctr NN = ctr .+^ (avec (pi/2) rad) radialCardinal rad ctr NE = ctr .+^ (avec (pi/4) rad) @@ -115,7 +129,7 @@ rectCardinal hw hh ctr NW = ctr .+^ (vec (-hw) hh) -rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u +rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr = DotAnchor { center_anchor = ctr , radial_anchor = fn @@ -124,36 +138,94 @@ fn theta = maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh +rectangleLDO :: (Real u, Floating u) + => u -> u -> LocDrawingObject u (DotAnchor u) +rectangleLDO w h pt = liftDrawingObject $ rectangleAnchor (w*0.5) (h*0.5) pt -dotCircle :: (Floating u, FromPtSize u) => ANode u (DotAnchor u) -dotCircle = AGraphic (BD.dotCircle) mkF - where - mkF attr pt = circleAnchor (0.5 * markHeight attr) pt +circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u +circleAnchor rad ctr = DotAnchor ctr + (\theta -> ctr .+^ (avec theta rad)) + (radialCardinal rad ctr) +circleLDO :: (Floating u, FromPtSize u) => LocDrawingObject u (DotAnchor u) +circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> asksObj markHeight -dotDisk :: (Floating u, FromPtSize u) => ANode u (DotAnchor u) -dotDisk = AGraphic (BD.dotDisk) mkF - where - mkF attr pt = circleAnchor (0.5 * markHeight attr) pt -dotSquare :: (Floating u, Real u, FromPtSize u) => ANode u (DotAnchor u) -dotSquare = AGraphic (BD.dotSquare) mkF - where - mkF attr pt = let h = markHeight attr in - rectangleAnchor (0.5*h) (0.5*h) pt +-------------------------------------------------------------------------------- +type DotLocImage u = LocImage u (DotAnchor u) +type DDotLocImage = DotLocImage Double + dotChar :: (Floating u, Real u, FromPtSize u) - => Char -> ANode u (DotAnchor u) -dotChar ch = dotText [ch] + => Char -> DotLocImage u +dotChar ch pt = asksObj (textDimensions [ch]) >>= \(w,h) -> + intoLocImage (rectangleLDO w h) (markChar ch) pt + dotText :: (Floating u, Real u, FromPtSize u) - => String -> ANode u (DotAnchor u) -dotText str = AGraphic (BD.dotText str) mkF - where - mkF attr pt = let (w,h) = textDimensions str attr in - rectangleAnchor (0.5*w) (0.5*h) pt + => String -> DotLocImage u +dotText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> + intoLocImage (rectangleLDO w h) (markText ss) pt +dotHLine :: (Floating u, FromPtSize u) => DotLocImage u +dotHLine = intoLocImage circleLDO markHLine + + +dotVLine :: (Floating u, FromPtSize u) => DotLocImage u +dotVLine = intoLocImage circleLDO markVLine + + +dotX :: (Floating u, FromPtSize u) => DotLocImage u +dotX = intoLocImage circleLDO markX + +dotPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotPlus = intoLocImage circleLDO markPlus + +dotCross :: (Floating u, FromPtSize u) => DotLocImage u +dotCross = intoLocImage circleLDO markCross + +dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotDiamond = intoLocImage circleLDO markDiamond + +dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotFDiamond = intoLocImage circleLDO markFDiamond + + + +dotDisk :: (Floating u, FromPtSize u) => DotLocImage u +dotDisk = intoLocImage circleLDO markDisk + + +dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u +dotSquare pt = asksObj markHeight >>= \ h -> + intoLocImage (rectangleLDO h h) markSquare pt + + + + +dotCircle :: (Floating u, FromPtSize u) => DotLocImage u +dotCircle = intoLocImage circleLDO markCircle + + +dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u +dotPentagon = intoLocImage circleLDO markPentagon + +dotStar :: (Floating u, FromPtSize u) => DotLocImage u +dotStar = intoLocImage circleLDO markStar + + +dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u +dotAsterisk = intoLocImage circleLDO markAsterisk + +dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotOPlus = intoLocImage circleLDO markOPlus + +dotOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotOCross = intoLocImage circleLDO markOCross + +dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotFOCross = intoLocImage circleLDO markFOCross diff --git a/src/Wumpus/Basic/Dots/Base.hs b/src/Wumpus/Basic/Dots/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Dots/Base.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Dots.Base --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC with TypeFamilies and more --- --- Dots --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Dots.Base - ( - - - -- * Dots - dotChar - , dotText - , dotHLine - , dotVLine - , dotX - , dotPlus - , dotCross - , dotDiamond - , dotFDiamond - , dotDisk - , dotSquare - , dotCircle - , dotPentagon - , dotStar - , dotAsterisk - , dotOPlus - , dotOCross - , dotFOCross - - ) where - - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Graphic.PointSupply -import Wumpus.Basic.Utils.HList - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - --- Marks should be the height of a lower-case letter... - --- NOTES --- --- 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 (stroke_colour attr) (font_props attr) str pt - where - 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 :: 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] - - - - - --- Better would be a version of straightLine where the point is --- the center not the start... --- -dotHLine :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotHLine attr = let w = markHeight attr in - 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 (stroke_colour attr) (stroke_props attr) (vvec h) - - -dotX :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotX attr = ls1 `cc` ls2 - where - h = markHeight attr - w = 0.75 * 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 -dotPlus attr = dotVLine attr `cc` dotHLine attr - - -dotCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotCross attr = ls1 `cc` ls2 - where - z = markHeight attr - 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... - -pathDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> PathF u -pathDiamond attr = vertexPath . sequence [dvs,dve,dvn,dvw] - where - hh = 0.66 * markHeight attr - hw = 0.5 * markHeight attr - dvs = (.+^ vvec (-hh)) - dve = (.+^ hvec hw) - dvn = (.+^ vvec hh) - dvw = (.+^ hvec (-hw)) - -type PathF u = Point2 u -> PrimPath u - -dotDiamond :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotDiamond 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 (fill_colour attr) . pathDiamond attr - - - --- | Note disk is filled. --- -dotDisk :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotDisk attr = disk (fill_colour attr) (0.5*markHeight attr) - - -dotSquare :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotSquare attr = let u = markHeight attr in - strokedRectangle (stroke_colour attr) (stroke_props attr) u u - - - -dotCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -dotCircle attr = disk (stroke_colour attr) (0.5*markHeight attr) - - -dotPentagon :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotPentagon attr = - wrapG . cstroke (stroke_colour attr) (stroke_props attr) - . vertexPath . polygonPointsV 5 hh - where - hh = 0.5 * markHeight attr - - - -dotStar :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotStar attr = \pt -> veloH (fn pt) $ polygonPointsV 5 hh pt - where - hh = 0.5 * markHeight attr - fn pt pt' = wrapG $ cstroke (stroke_colour attr) (stroke_props attr) - $ path pt [lineTo pt'] - - - - -dotAsterisk :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotAsterisk attr = ls1 `cc` ls2 `cc` ls3 - where - 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 -dotOPlus attr = dotCircle attr `cc` dotPlus attr - - -dotOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotOCross attr = dotCircle attr `cc` dotCross attr - - -dotFOCross :: (Floating u, FromPtSize u) => DrawingAttr -> GraphicF u -dotFOCross attr = dotCircle attr `cc` dotCross attr `cc` bkCircle attr - -bkCircle :: (Fractional u, FromPtSize u) => DrawingAttr -> GraphicF u -bkCircle attr = disk (fillAttr attr) (0.5*markHeight attr) diff --git a/src/Wumpus/Basic/Dots/Primitive.hs b/src/Wumpus/Basic/Dots/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Dots/Primitive.hs @@ -0,0 +1,231 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Dots.Primitive +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC with TypeFamilies and more +-- +-- Marks - dots without anchor handles. +-- +-- \*\* WARNING \*\* - names are expected to change - filled and +-- background-filled marks need a naming convention. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Dots.Primitive + ( + + + -- * Marks + markChar + , markText + + , markHLine + , markVLine + , markX + , markPlus + , markCross + , markDiamond + , markFDiamond + , markBDiamond + , markDisk + , markSquare + , markCircle + , markPentagon + , markStar + , markAsterisk + , markOPlus + , markOCross + , markFOCross + + + ) where + + +import Wumpus.Basic.Graphic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.List + +-- Marks should be the height of a lower-case letter... + +-- NOTES +-- +-- TikZ has both stroked and bordered (filled and outline-stroked) +-- marks e.g. square and square* +-- + + +-- | 'polygonPoints' : @ num_points * radius * center -> [point] @ +-- +polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u] +polygonPoints n radius ctr = unfoldr phi (0,(pi*0.5)) + where + theta = (pi*2) / fromIntegral n + + phi (i,ang) | i < n = Just (ctr .+^ avec ang radius, (i+1,ang+theta)) + | otherwise = Nothing + + + +-- | A mark is the height of a lowercase \'x\'. +-- +standardSize :: FromPtSize u => (u -> LocGraphic u) -> LocGraphic u +standardSize f = \pt -> asksObj markHeight >>= \h -> f h pt + +halfHeightSize :: (Fractional u, FromPtSize u) + => (u -> LocGraphic u) -> LocGraphic u +halfHeightSize f = \pt -> asksObj markHeight >>= \h -> f (h * 0.5) pt + + + +shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u +shiftOrigin dx dy f = \pt -> f (displace dx dy pt) + +markChar :: (Fractional u, FromPtSize u) => Char -> LocGraphic u +markChar ch = markText [ch] + + + + +-- Note - eta-expanded (?) +-- +markText :: (Fractional u, FromPtSize u) => String -> LocGraphic u +markText ss pt = asksObj (textDimensions ss) >>= \(w,h) -> + shiftOrigin (0.5 * (-w)) (0.5 * (-h)) (textline ss) pt + + + + + +-- | Supplied point is the center. +-- +axialLine :: Fractional u => Vec2 u -> LocGraphic u +axialLine v = localPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v) + + + +markHLine :: (Fractional u, FromPtSize u) => LocGraphic u +markHLine = standardSize (\h -> axialLine (hvec h)) + + +markVLine :: (Fractional u, FromPtSize u) => LocGraphic u +markVLine = standardSize (\h -> axialLine (vvec h)) + + +markX :: (Fractional u, FromPtSize u) => LocGraphic u +markX = standardSize (\h -> let w = 0.75 * h in + axialLine (vec w h) `appendAt` axialLine (vec (-w) h)) + + + +markPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markPlus = markVLine `appendAt` markHLine + + +markCross :: (Floating u, FromPtSize u) => LocGraphic u +markCross = standardSize + (\h -> axialLine (avec ang h) `appendAt` axialLine (avec (-ang) h)) + where + ang = pi*0.25 + + + +-- needs horizontal pinch... + +pathDiamond :: (Fractional u, FromPtSize u) + => Point2 u -> DrawingObject (PrimPath u) +pathDiamond pt = (\h -> let hh = 0.66 * h; hw = 0.5 * h + in vertexPath [dvs hh, dve hw,dvn hh, dvw hw]) + <$> asksObj markHeight + where + dvs hh = pt .+^ vvec (-hh) + dve hw = pt .+^ hvec hw + dvn hh = pt .+^ vvec hh + dvw hw = pt .+^ hvec (-hw) + + + +markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markDiamond = \pt -> pathDiamond pt >>= closedStroke + +markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markFDiamond = \pt -> pathDiamond pt >>= filledPath + +markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markBDiamond = \pt -> pathDiamond pt >>= borderedPath + + +-- | Note disk is filled. +-- +markDisk :: (Fractional u, FromPtSize u) => LocGraphic u +markDisk = halfHeightSize filledDisk + + + +markSquare :: (Fractional u, FromPtSize u) => LocGraphic u +markSquare = standardSize (\h -> let d = 0.5*(-h) in + shiftOrigin d d $ strokedRectangle h h) + + + +markCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markCircle = halfHeightSize strokedDisk + + +markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markBCircle = halfHeightSize borderedDisk + + + +markPentagon :: (Floating u, FromPtSize u) => LocGraphic u +markPentagon pt = asksObj markHeight >>= \h -> + closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt + + + + +markStar :: (Floating u, FromPtSize u) => LocGraphic u +markStar pt = asksObj markHeight >>= \h -> + let (p:ps) = polygonPoints 5 (0.5*h) pt in gcat (fn p) $ map fn ps + where + fn p1 = openStroke $ path pt [lineTo p1] + + + + +markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u +markAsterisk = standardSize (\h -> lineF1 h `appendAt` lineF2 h `appendAt` lineF3 h) + where + ang = (pi*2) / 6 + lineF1 z = axialLine (vvec z) + lineF2 z = axialLine (avec ((pi*0.5) + ang) z) + lineF3 z = axialLine (avec ((pi*0.5) + ang + ang) z) + + + +markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markOPlus = markCircle `appendAt` markPlus + + +markOCross :: (Floating u, FromPtSize u) => LocGraphic u +markOCross = markCircle `appendAt` markCross + + +markFOCross :: (Floating u, FromPtSize u) => LocGraphic u +markFOCross = markCross `appendAt` markBCircle + + +-- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u +-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) + diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs --- a/src/Wumpus/Basic/Graphic.hs +++ b/src/Wumpus/Basic/Graphic.hs @@ -10,19 +10,24 @@ -- Stability : highly unstable -- Portability : GHC -- --- Import shim for @Wumpus.Basic.Graphic.Primitive@. --- --- \*\* WARNING \*\* - this module is highly experimental, and --- may change significantly or even be dropped from future --- revisions. +-- Import shim for @Wumpus.Basic.Graphic@ modules. -- -- -------------------------------------------------------------------------------- module Wumpus.Basic.Graphic ( - module Wumpus.Basic.Graphic.Primitive - + module Wumpus.Basic.Graphic.BaseClasses + , module Wumpus.Basic.Graphic.BaseTypes + , module Wumpus.Basic.Graphic.Chain + , module Wumpus.Basic.Graphic.Drawing + , module Wumpus.Basic.Graphic.DrawingContext + , module Wumpus.Basic.Graphic.PrimGraphic ) where -import Wumpus.Basic.Graphic.Primitive +import Wumpus.Basic.Graphic.BaseClasses +import Wumpus.Basic.Graphic.BaseTypes +import Wumpus.Basic.Graphic.Chain +import Wumpus.Basic.Graphic.Drawing +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Graphic.PrimGraphic diff --git a/src/Wumpus/Basic/Graphic/BaseClasses.hs b/src/Wumpus/Basic/Graphic/BaseClasses.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/BaseClasses.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.BaseClasses +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Base classes and type families. +-- +-- Drawing is always built on TraceM and DrawingCtxM, it may use +-- PointSupplyM for chains or turtle drawing. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.BaseClasses + ( + MonUnit + , TraceM(..) + , DrawingCtxM(..) + , asksCtx + + , PointSupplyM(..) + + ) where + +import Wumpus.Basic.Graphic.BaseTypes ( HPrim ) +import Wumpus.Basic.Graphic.DrawingContext + + +import Wumpus.Core -- package: wumpus-core + + + + +-- DUnit is always for fully saturated types, so (seemingly) an equivalent +-- type family is needed. + +type family MonUnit m :: * + + +-- | Collect elementary graphics as part of a larger drawing. +-- +-- TraceM works much like a writer monad. +-- +class Monad m => TraceM (m :: * -> *) where + trace :: HPrim (MonUnit m) -> m () + +class Monad m => DrawingCtxM (m :: * -> *) where + askCtx :: m DrawingContext + localCtx :: (DrawingContext -> DrawingContext) -> m a -> m a + + +-- | Project a value out of a context. +-- +asksCtx :: DrawingCtxM m => (DrawingContext -> a) -> m a +asksCtx f = askCtx >>= (return . f) + + +-- | A monad that supplies points, e.g. a turtle monad. +-- +class Monad m => PointSupplyM (m :: * -> *) where + position :: u ~ MonUnit m => m (Point2 u) + diff --git a/src/Wumpus/Basic/Graphic/BaseTypes.hs b/src/Wumpus/Basic/Graphic/BaseTypes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/BaseTypes.hs @@ -0,0 +1,246 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.Image +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Base types for Drawing Objects, Graphics / Images (a Graphic +-- that also returns an answer), etc. +-- +-- \*\* WARNING \*\* - some names are expected to change +-- particularly the naming of the /append/ and /concat/ functions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.BaseTypes + ( + + + HPrim + , Point2T + , DPoint2T + + , DrawingObject(..) + , LocDrawingObject + , DLocDrawingObject + + , liftDrawingObject + + , Graphic + , DGraphic + , appendGraphic + , gcat + + , asksObj + , localCtxObj + + , runGraphic + + , LocGraphic + , DLocGraphic + , appendAt + + , Image + , DImage + , LocImage + , DLocImage + + , runImage + , intoImage + , intoLocImage + + , ConnDrawingObject + , DConnDrawingObject + , ConnGraphic + , DConnGraphic + , ConnImage + , DConnImage + + , intoConnImage + + ) where + +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Utils.HList + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + + + + + + +-- | 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. +-- +type HPrim u = H (PrimElement u) + + +-- | Point transformation function. +-- +type Point2T u = Point2 u -> Point2 u + +type DPoint2T = Point2T Double + + +newtype DrawingObject a = DrawingObject { + getDrawingObject :: DrawingContext -> a } + + + +type LocDrawingObject u a = Point2 u -> DrawingObject a + +type DLocDrawingObject a = LocDrawingObject Double a + + + +instance Functor DrawingObject where + fmap f ma = DrawingObject $ \ctx -> f $ getDrawingObject ma ctx + + +-- Applicative + +instance Applicative DrawingObject where + pure a = DrawingObject $ \_ -> a + mf <*> ma = DrawingObject $ \ctx -> let f = getDrawingObject mf ctx + a = getDrawingObject ma ctx + in f a + +-- Monad + +instance Monad DrawingObject where + return a = DrawingObject $ \_ -> a + ma >>= k = DrawingObject $ \ctx -> let a = getDrawingObject ma ctx + in (getDrawingObject . k) a ctx + + +liftDrawingObject :: a -> DrawingObject a +liftDrawingObject a = DrawingObject $ \ _ctx -> a + +-- Simple drawing - representing one or more prims + +type Graphic u = DrawingObject (HPrim u) + +type DGraphic = Graphic Double + + +appendGraphic :: Graphic u -> Graphic u -> Graphic u +appendGraphic gf1 gf2 = DrawingObject $ \ctx -> + (getDrawingObject gf1 ctx) `appendH` (getDrawingObject gf2 ctx) + +gcat :: Graphic u -> [Graphic u] -> Graphic u +gcat a = step a + where + step ac [] = ac + step ac (x:xs) = step (ac `appendGraphic` x) xs + + +asksObj :: (DrawingContext -> a) -> DrawingObject a +asksObj fn = DrawingObject $ \ctx -> fn ctx + +localCtxObj :: (DrawingContext -> DrawingContext) + -> DrawingObject a -> DrawingObject a +localCtxObj upd gf = DrawingObject $ \ctx -> getDrawingObject gf (upd ctx) + +runGraphic :: DrawingContext -> Graphic u -> HPrim u +runGraphic ctx gf = (getDrawingObject gf) ctx + + +-------------------------------------------------------------------------------- + + +-- | Commonly graphics take a start point as well as a drawing +-- context. +-- +-- Here they are called a LocGraphic - graphic with a (starting) +-- location. +-- +type LocGraphic u = Point2 u -> Graphic u + +type DLocGraphic = LocGraphic Double + + + + +-- | Composition operator for LocGraphic - both LocGraphics +-- are drawn at the same origin and the results concatenated. +-- +-- +appendAt :: LocGraphic u -> LocGraphic u -> LocGraphic u +appendAt f g = \pt -> f pt `appendGraphic` g pt + + +-------------------------------------------------------------------------------- + + +-- | Images return a value as well as drawing. A /node/ is a +-- typical example - nodes are drawing but the also support +-- taking anchor points. +-- +type Image u a = DrawingObject (a, HPrim u) + +type DImage a = Image Double a + +type LocImage u a = Point2 u -> Image u a + +type DLocImage a = LocImage Double a + +runImage :: DrawingContext -> Image u a -> (a,HPrim u) +runImage ctx img = (getDrawingObject img) ctx + + +intoImage :: DrawingObject a -> Graphic u -> Image u a +intoImage f g = DrawingObject $ \ctx -> + let a = getDrawingObject f ctx; o = getDrawingObject g ctx in (a,o) + + +intoLocImage :: LocDrawingObject u a -> LocGraphic u -> LocImage u a +intoLocImage f g pt = DrawingObject $ \ctx -> + let a = getDrawingObject (f pt) ctx + o = getDrawingObject (g pt) ctx + in (a,o) + +type ConnDrawingObject u a = Point2 u -> Point2 u -> DrawingObject a + +type DConnDrawingObject a = ConnDrawingObject Double a + +-- | ConnGraphic is a connector drawn between two points +-- contructing a Graphic. +-- +type ConnGraphic u = Point2 u -> Point2 u -> Graphic u + +type DConnGraphic = ConnGraphic Double + +-- | ConImage is a connector drawn between two points +-- constructing an Image. +-- +type ConnImage u a = Point2 u -> Point2 u -> Image u a + +type DConnImage a = ConnImage Double a + + +intoConnImage :: ConnDrawingObject u a -> ConnGraphic u -> ConnImage u a +intoConnImage f g p1 p2 = DrawingObject $ \ctx -> + let a = getDrawingObject (f p1 p2) ctx + o = getDrawingObject (g p1 p2) ctx + in (a,o) diff --git a/src/Wumpus/Basic/Graphic/Chain.hs b/src/Wumpus/Basic/Graphic/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/Chain.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.Chain +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Supply points in an iterated chain. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.Chain + ( + + ChainT + , runChainT + , horizontal + + ) where + +import Wumpus.Basic.Graphic.BaseClasses +import Wumpus.Basic.Graphic.BaseTypes + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Control.Monad + + + +newtype ChainT u m a = ChainT { + getChainT :: Point2T u -> Point2 u -> m (a, Point2 u) } + + +type instance MonUnit (ChainT u m) = u + + + +instance Monad m => Functor (ChainT u m) where + fmap f ma = ChainT $ \rf s -> + getChainT ma rf s >>= \(a,s1) -> return (f a, s1) + + +instance Monad m => Applicative (ChainT u m) where + pure a = ChainT $ \_ s -> return (a,s) + mf <*> ma = ChainT $ \rf s -> getChainT mf rf s >>= \(f,s1) -> + getChainT ma rf s1 >>= \(a,s2) -> + return (f a, s2) + + +instance Monad m => Monad (ChainT u m) where + return a = ChainT $ \_ s -> return (a,s) + m >>= k = ChainT $ \rf s -> getChainT m rf s >>= \(a,s1) -> + (getChainT . k) a rf s1 + + + +instance Monad m => PointSupplyM (ChainT u m) where + position = ChainT $ \rf s -> return (s, rf s) + +runChainT :: Monad m + => Point2T u -> Point2 u -> ChainT u m a -> m a +runChainT f pt0 ma = liftM fst $ getChainT ma f pt0 + +horizontal :: (Num u, Monad m) + => Point2 u -> u -> ChainT u m a -> m a +horizontal pt0 dx ma = runChainT f pt0 ma + where + f (P2 x y) = P2 (x+dx) y + + +instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ChainT u m) where + trace a = ChainT $ \_ s -> trace a >> return ((), s) + + +instance (Monad m, DrawingCtxM m) => DrawingCtxM (ChainT u m) where + askCtx = ChainT $ \_ s -> askCtx >>= \ctx -> return (ctx, s) + localCtx cF ma = ChainT $ \r s -> localCtx cF (getChainT ma r s) diff --git a/src/Wumpus/Basic/Graphic/Drawing.hs b/src/Wumpus/Basic/Graphic/Drawing.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/Drawing.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.Drawing +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Drawing with trace and drawing context (i.e. reader monad +-- of attributes - fill_colour etc.). +-- +-- \*\* WARNING \*\* - some names are expected to change +-- particularly the naming of the @draw@, @drawAt@, @node@, @...@ +-- functions. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.Drawing + ( + + Drawing + , DrawingT + , runDrawing + , execDrawing + , runDrawingT + , execDrawingT + , liftToPictureU + + , draw + , drawAt + , drawAtImg + , drawConn + , drawConnImg + , node + + ) where + + +import Wumpus.Basic.Graphic.BaseClasses +import Wumpus.Basic.Graphic.BaseTypes +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Utils.HList + + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Control.Monad + + + + +-- Note - Drawing 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 Drawing monad as a local effect, rather than built into a +-- transformer stack. +-- + + +newtype Drawing u a = Drawing { + getDrawing :: DrawingContext -> HPrim u -> (a, HPrim u) } + +newtype DrawingT u m a = DrawingT { + getDrawingT :: DrawingContext -> HPrim u -> m (a, HPrim u) } + + + +type instance MonUnit (Drawing u) = u +type instance MonUnit (DrawingT u m) = u + + + +-- Functor + +instance Functor (Drawing u) where + fmap f ma = Drawing $ \ctx s -> + let (a,s1) = getDrawing ma ctx s in (f a,s1) + + +instance Monad m => Functor (DrawingT u m) where + fmap f ma = DrawingT $ \ctx s -> + getDrawingT ma ctx s >>= \(a,s1) -> return (f a,s1) + + + +-- Applicative + +instance Applicative (Drawing u) where + pure a = Drawing $ \_ s -> (a, s) + mf <*> ma = Drawing $ \ctx s -> let (f,s1) = getDrawing mf ctx s + (a,s2) = getDrawing ma ctx s1 + in (f a, s2) + + +instance Monad m => Applicative (DrawingT u m) where + pure a = DrawingT $ \_ s -> return (a, s) + mf <*> ma = DrawingT $ \ctx s -> getDrawingT mf ctx s >>= \(f,s1) -> + getDrawingT ma ctx s1 >>= \(a,s2) -> + return (f a, s2) + +-- Monad + +instance Monad (Drawing u) where + return a = Drawing $ \_ s -> (a, s) + ma >>= k = Drawing $ \ctx s -> let (a,s1) = getDrawing ma ctx s + in (getDrawing . k) a ctx s1 + + + + +instance Monad m => Monad (DrawingT u m) where + return a = DrawingT $ \_ s -> return (a, s) + ma >>= k = DrawingT $ \ctx s -> getDrawingT ma ctx s >>= \(a,s1) -> + (getDrawingT . k) a ctx s1 + + + + +-- TraceM +-- +-- Note - @ state `appendH` a @ means the first expression in a +-- monadic drawing is top of the Z-Order. +-- +-- This is the matches a list of Prims in Wumpus-Core where the +-- first element is drawn on top, however is not necessarily +-- intuitive if you regard the do-block as a sequence of +-- /actions/. +-- +-- Ideally some control over the Z-Order, possibly adding +-- /layers/ to the drawing model would be valuable. +-- + +instance TraceM (Drawing u) where + trace a = Drawing $ \_ s -> ((),s `appendH` a) + + +instance Monad m => TraceM (DrawingT u m) where + trace a = DrawingT $ \_ s -> return ((),s `appendH` a) + + + +-- DrawingCtxM + +instance DrawingCtxM (Drawing u) where + askCtx = Drawing $ \ctx s -> (ctx, s) + localCtx cF ma = Drawing $ \ctx s -> getDrawing ma (cF ctx) s + + + +instance Monad m => DrawingCtxM (DrawingT u m) where + askCtx = DrawingT $ \ctx s -> return (ctx,s) + localCtx cF ma = DrawingT $ \ctx s -> getDrawingT ma (cF ctx) s + + + +-- Note - the result type of runDrawing 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. +-- + + +runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u) +runDrawing ctx ma = getDrawing ma ctx emptyH + +execDrawing :: DrawingContext -> Drawing u a -> HPrim u +execDrawing ctx ma = snd $ runDrawing ctx ma + + + +runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) +runDrawingT ctx ma = getDrawingT ma ctx emptyH + +execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u) +execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma + + +liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u +liftToPictureU hf = let prims = toListH hf in + if null prims then errK else frame prims + where + errK = error "liftToPictureU - empty prims list." + +-------------------------------------------------------------------------------- + +draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () +draw gf = askCtx >>= \ctx -> trace (runGraphic ctx gf) + +drawAt :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => Point2 u ->LocGraphic u -> m () +drawAt pt gfL = askCtx >>= \ctx -> trace (runGraphic ctx (gfL pt)) + +drawAtImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => Point2 u -> LocImage u a -> m a +drawAtImg pt imgL = askCtx >>= \ctx -> + let (a,o) = runImage ctx (imgL pt) + in trace o >> return a + + + +drawConn :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => Point2 u -> Point2 u -> ConnGraphic u -> m () +drawConn p1 p2 connL = askCtx >>= \ctx -> trace (runGraphic ctx (connL p1 p2)) + +drawConnImg :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => Point2 u -> Point2 u -> ConnImage u a -> m a +drawConnImg p1 p2 connL = askCtx >>= \ctx -> + let (a,o) = runImage ctx (connL p1 p2) + in trace o >> return a + + + +node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) + => LocGraphic u -> m () +node gfL = askCtx >>= \ctx -> + position >>= \pt -> trace (runGraphic ctx $ gfL pt) + + diff --git a/src/Wumpus/Basic/Graphic/DrawingAttr.hs b/src/Wumpus/Basic/Graphic/DrawingAttr.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/DrawingAttr.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.DrawingAttr --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC with TypeFamilies and more --- --- Drawing attributes --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.DrawingAttr - ( - - -- * Drawing attributes - DrawingAttr(..) - - , standardAttr - , strokeAttr - , fillAttr - , textAttr - , markHeight - - , textDimensions - - -- * Line widths - , thick - , ultrathick - , thin - - -- * Font properties - , fontsize - , fontface - - ) where - - -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Utils.Combinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - -data DrawingAttr = DrawingAttr - { stroke_props :: StrokeAttr - , font_props :: FontAttr - , stroke_colour :: RGBi - , fill_colour :: RGBi - } - deriving (Eq,Show) - -standardAttr :: FontSize -> DrawingAttr -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 stroke_props - -fillAttr :: DrawingAttr -> RGBi -fillAttr = fill_colour - -textAttr :: DrawingAttr -> (RGBi,FontAttr) -textAttr = liftA2 (,) stroke_colour font_props - --- | A Mark is consider to be the height of a lowercase letter --- in the current font. --- -markHeight :: FromPtSize u => DrawingAttr -> u -markHeight = fromPtSize . xcharHeight . font_size . font_props - - --- | textDimensions : text -> DrawingAttr -> (width,height) --- -textDimensions :: FromPtSize u => String -> DrawingAttr -> (u,u) -textDimensions str attr = (w,h) - where - sz = font_size $ font_props attr - w = fromPtSize $ textWidth sz (1 + length str) - h = fromPtSize $ textHeight sz - - - --------------------------------------------------------------------------------- --- line widths - --- Note - some care might be needed if we ever define other unit --- types... - --- std_line_width :: Double --- std_line_width = 1.0 - -thick_line :: Double -thick_line = 2.0 - -ultra_thick_line :: Double -ultra_thick_line = 4.0 - -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 = setLineWidth thick_line - -ultrathick :: DrawingAttr -> DrawingAttr -ultrathick = setLineWidth ultra_thick_line - -thin :: DrawingAttr -> DrawingAttr -thin = setLineWidth thin_line - - -fontface :: FontFace -> DrawingAttr -> DrawingAttr -fontface ff = star (\s i -> s { font_props = upd i }) font_props - where - upd (FontAttr sz _) = FontAttr sz ff - -fontsize :: Int -> DrawingAttr -> DrawingAttr -fontsize sz = star (\s i -> s { font_props = upd i }) font_props - where - upd (FontAttr _ ff) = FontAttr sz ff diff --git a/src/Wumpus/Basic/Graphic/DrawingContext.hs b/src/Wumpus/Basic/Graphic/DrawingContext.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/DrawingContext.hs @@ -0,0 +1,180 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.DrawingAttr +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC with TypeFamilies and more +-- +-- 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. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.DrawingContext + ( + + -- * Drawing context + DrawingContext(..) + + , standardContext + , textAttr + , markHeight + , lowerxHeight + , textDimensions + + -- * Modifiers + -- ** Line widths + , thick + , ultrathick + , thin + + -- ** Dash Pattern + , dashPattern + + -- ** Font properties + , fontsize + , fontface + + -- ** Colour + , swapColours + , primaryColour + , secondaryColour + + + + + ) where + + +import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Colour.SVGColours + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +data DrawingContext = DrawingContext + { stroke_props :: StrokeAttr + , font_props :: FontAttr + , primary_colour :: RGBi -- usually the stroke colour + , secondary_colour :: RGBi -- usually the fill colour + } + deriving (Eq,Show) + +standardContext :: FontSize -> DrawingContext +standardContext sz = DrawingContext { stroke_props = default_stroke_attr + , font_props = FontAttr sz courier + , primary_colour = black + , secondary_colour = light_gray } + + + +textAttr :: DrawingContext -> (RGBi,FontAttr) +textAttr = liftA2 (,) primary_colour font_props + + +-- | A Mark is consider to be the height of a lowercase letter +-- in the current font. +-- +-- Note better to use xlowerHeight +-- +markHeight :: FromPtSize u => DrawingContext -> u +markHeight = fromPtSize . xcharHeight . font_size . font_props + + +-- | Height of a lower case \'x\' in Courier. +-- +-- \'x\' has no ascenders or descenders. +-- +lowerxHeight :: FromPtSize u => DrawingContext -> u +lowerxHeight = fromPtSize . xcharHeight . font_size . font_props + + +-- | textDimensions : text -> DrawingContext -> (width,height) +-- +textDimensions :: FromPtSize u => String -> DrawingContext -> (u,u) +textDimensions str attr = (w,h) + where + sz = font_size $ font_props attr + w = fromPtSize $ textWidth sz (charCount str) + h = fromPtSize $ numeralHeight sz + + + +updateStrokeProps :: (StrokeAttr -> StrokeAttr) + -> DrawingContext -> DrawingContext +updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props + +updateFontProps :: (FontAttr -> FontAttr) + -> DrawingContext -> DrawingContext +updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props + + +-------------------------------------------------------------------------------- +-- line widths + +-- Note - some care might be needed if we ever define other unit +-- types... + +-- std_line_width :: Double +-- std_line_width = 1.0 + +thick_line :: Double +thick_line = 2.0 + +ultra_thick_line :: Double +ultra_thick_line = 4.0 + +thin_line :: Double +thin_line = 0.5 + +setLineWidth :: Double -> DrawingContext -> DrawingContext +setLineWidth d = updateStrokeProps (\s -> s { line_width = d }) + + +thick :: DrawingContext -> DrawingContext +thick = setLineWidth thick_line + +ultrathick :: DrawingContext -> DrawingContext +ultrathick = setLineWidth ultra_thick_line + +thin :: DrawingContext -> DrawingContext +thin = setLineWidth thin_line + + +dashPattern :: DashPattern -> DrawingContext -> DrawingContext +dashPattern d = updateStrokeProps (\s -> s { dash_pattern = d }) + +-------------------------------------------------------------------------------- + + +fontface :: FontFace -> DrawingContext -> DrawingContext +fontface ff = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff) + +fontsize :: Int -> DrawingContext -> DrawingContext +fontsize sz = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) + +-------------------------------------------------------------------------------- + +swapColours :: DrawingContext -> DrawingContext +swapColours = + (\s a b -> s { primary_colour = b, secondary_colour = a }) + <*> primary_colour <*> secondary_colour + +primaryColour :: RGBi -> DrawingContext -> DrawingContext +primaryColour rgb = \s -> s { primary_colour = rgb } + + +secondaryColour :: RGBi -> DrawingContext -> DrawingContext +secondaryColour rgb = \s -> s { secondary_colour = rgb } + diff --git a/src/Wumpus/Basic/Graphic/PointSupply.hs b/src/Wumpus/Basic/Graphic/PointSupply.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/PointSupply.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.PointSupply --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- --- \*\* WARNING \*\* - function names likely to change. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.PointSupply - ( - -- * Constants (might move from this module) - two_pi - , half_pi - - -- * Generate points. - , polygonPointsV - , hpoints - , vpoints - - ) where - - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Data.List - -two_pi :: Radian -two_pi = 2.0 * pi - -half_pi :: Radian -half_pi = 0.5 * pi - - --- | 'polygonPointsV' : @ num_points * radius * center -> [point] @ --- -polygonPointsV :: Floating u => Int -> u -> Point2 u -> [Point2 u] -polygonPointsV n radius = sequence vecs - where - theta = two_pi / fromIntegral n - vecs = unfoldr phi (0,half_pi) - - phi (i,ang) | i < n = Just ((.+^ avec ang radius), (i+1,ang+theta)) - | otherwise = Nothing - - - --- | 'hpoints' : @ ypos * step * (x0,x1) -> [point] @ --- --- Generate points in a horizontal line between x0 and x1. --- --- Note - the step increment is w.r.t. 0 rather than x0. x0 and --- x1 are just the range. An example: --- --- > hpoints 0 10 (5,35) --- --- > [P2 10 0, P2 20 0, P2 30 0] --- -hpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u] -hpoints y step (x0,x1) = unfoldr phi start - where - start = initial step x0 - phi st | st < x1 = Just (P2 st y, st+step) - | otherwise = Nothing - - --- | 'vpoints' : @ xpos * step * (y0,y1) -> [point] @ --- --- Generate points in a vertical line between y0 and y1. --- --- Note - the step increment is w.r.t. 0 rather than y0. y0 and --- y1 are just the range. An example: --- --- > vpoints 5 100 (50,500) --- --- > [P2 5 100, P2 5 200, P2 5 300, P2 5 400] --- -vpoints :: RealFrac u => u -> u -> (u,u) -> [Point2 u] -vpoints x step (y0,y1) = unfoldr phi start - where - start = initial step y0 - phi st | st < y1 = Just (P2 x st, st+step) - | otherwise = Nothing - - - -initial :: RealFrac a => a -> a -> a -initial step minval = step * (fn $ minval / step) - where - fn x | x < 0 = fromIntegral $ ceilingi x - | otherwise = fromIntegral $ 1 + floori x - - - -ceilingi :: RealFrac a => a -> Integer -ceilingi = ceiling - -floori :: RealFrac a => a -> Integer -floori = floor diff --git a/src/Wumpus/Basic/Graphic/PrimGraphic.hs b/src/Wumpus/Basic/Graphic/PrimGraphic.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/PrimGraphic.hs @@ -0,0 +1,233 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.PrimGraphic +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Elementary functions for the Graphic and LocGraphic types. +-- +-- The functions here are generally analogeous to the Picture +-- API in @Wumpus.Core@, but here they exploit the implicit +-- @DrawingContext@. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.PrimGraphic + ( + drawGraphic + , drawGraphicU + + + , openStroke + , closedStroke + , filledPath + , borderedPath + , textline + , strokedEllipse + , filledEllipse + , borderedEllipse + + , supplyPt + , localDrawingContext + , localPoint + , displace + + , straightLine + + , strokedRectangle + , filledRectangle + , borderedRectangle + + + , strokedCircle + , filledCircle + , borderedCircle + + , strokedDisk + , filledDisk + , borderedDisk + + + ) where + +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Graphic.BaseTypes +import Wumpus.Basic.Utils.HList + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + +drawGraphic :: (Real u, Floating u, FromPtSize u) + => DrawingContext -> Graphic u -> Maybe (Picture u) +drawGraphic ctx gf = post $ runGraphic ctx gf + where + post hf = let xs = toListH hf in + if null xs then Nothing else Just (frame xs) + +drawGraphicU :: (Real u, Floating u, FromPtSize u) + => DrawingContext -> Graphic u -> Picture u +drawGraphicU ctx gf = post $ runGraphic ctx gf + where + post hf = let xs = toListH hf in + if null xs then errK else frame xs + errK = error "drawGraphicU - empty Graphic." + + +-- having the same names is actually not so useful... + +openStroke :: Num u => PrimPath u -> Graphic u +openStroke pp = (\rgb attr -> wrapH $ ostroke rgb attr pp) + <$> asksObj primary_colour <*> asksObj stroke_props + + +closedStroke :: Num u => PrimPath u -> Graphic u +closedStroke pp = (\rgb attr -> wrapH $ cstroke rgb attr pp) + <$> asksObj primary_colour <*> asksObj stroke_props + + +filledPath :: Num u => PrimPath u -> Graphic u +filledPath pp = (\rgb -> wrapH $ fill rgb pp) + <$> asksObj secondary_colour + + +borderedPath :: Num u => PrimPath u -> Graphic u +borderedPath pp = + (\frgb attr srgb -> wrapH $ fillStroke frgb attr srgb pp) + <$> asksObj secondary_colour <*> asksObj stroke_props <*> asksObj primary_colour + + +textline :: Num u => String -> LocGraphic u +textline ss baseline_left = + (\(rgb,attr) -> wrapH $ textlabel rgb attr ss baseline_left) + <$> asksObj textAttr + + +strokedEllipse :: Num u => u -> u -> LocGraphic u +strokedEllipse hw hh pt = + (\rgb attr -> wrapH $ strokeEllipse rgb attr hw hh pt) + <$> asksObj primary_colour <*> asksObj stroke_props + +filledEllipse :: Num u => u -> u -> LocGraphic u +filledEllipse hw hh pt = + (\rgb -> wrapH $ fillEllipse rgb hw hh pt) + <$> asksObj secondary_colour + +borderedEllipse :: Num u => u -> u -> LocGraphic u +borderedEllipse hw hh pt = + (\frgb attr srgb -> wrapH $ fillStrokeEllipse frgb attr srgb hw hh pt) + <$> asksObj secondary_colour <*> asksObj stroke_props + <*> asksObj primary_colour + + +-------------------------------------------------------------------------------- + + +-- | Supplying a point to a 'CFGraphic' takes it to a regular +-- 'Graphic'. +-- +supplyPt :: Point2 u -> LocGraphic u -> Graphic u +supplyPt pt gf = gf pt + + +displace :: Num u => u -> u -> Point2 u -> Point2 u +displace dx dy (P2 x y) = P2 (x+dx) (y+dy) + + +localDrawingContext :: + (DrawingContext -> DrawingContext) -> LocGraphic u -> LocGraphic u +localDrawingContext upd img = \pt -> localCtxObj upd (img pt) + +localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u +localPoint upd gf = \pt -> gf (upd pt) + + +-------------------------------------------------------------------------------- + + +straightLine :: Fractional u => Vec2 u -> LocGraphic u +straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v] + + +-- | Supplied point is /bottom-left/. +-- +rectangle :: Num u => u -> u -> Point2 u -> PrimPath u +rectangle w h bl = path 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 = closedStroke . rectangle w h + + + +-- | Supplied point is /bottom left/. +-- +filledRectangle :: Fractional u => u -> u -> LocGraphic u +filledRectangle w h = filledPath . rectangle w h + + +-- | Supplied point is /bottom left/. +-- +borderedRectangle :: Fractional u => u -> u -> LocGraphic u +borderedRectangle w h = borderedPath . rectangle w h + +-------------------------------------------------------------------------------- + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +strokedCircle :: Floating u => Int -> u -> LocGraphic u +strokedCircle n r = closedStroke . curvedPath . bezierCircle n r + + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +filledCircle :: Floating u => Int -> u -> LocGraphic u +filledCircle n r = filledPath . curvedPath . bezierCircle n r + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +borderedCircle :: Floating u => Int -> u -> LocGraphic u +borderedCircle n r = borderedPath . 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. +-- +strokedDisk :: Num u => u -> LocGraphic u +strokedDisk radius = strokedEllipse radius radius + + +filledDisk :: Num u => u -> LocGraphic u +filledDisk radius = filledEllipse radius radius + +borderedDisk :: Num u => u -> LocGraphic u +borderedDisk radius = borderedEllipse radius radius diff --git a/src/Wumpus/Basic/Graphic/Primitive.hs b/src/Wumpus/Basic/Graphic/Primitive.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/Primitive.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# 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) - - - diff --git a/src/Wumpus/Basic/Monads/Drawing.hs b/src/Wumpus/Basic/Monads/Drawing.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/Drawing.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.Drawing --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Graphic types and lifters... --- --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.Drawing - ( - - AGraphic(..) - , ANode - , AFreeGraphic - , AConnector - - , node - , nodeAt - , at - , liftAFG - , connect - , connect_ - , props - - -- doodle - , thick - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.DrawingCtxClass -import Wumpus.Basic.Monads.TraceClass -import Wumpus.Basic.Monads.TurtleClass - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - --- | AGraphic --- --- param typically @Point2 u@ or @()@ --- --- If the param is a point it will be supplied by the drawing --- mode / drawing monad (e.g. the Turtle monad which supplies --- the current point). --- -data AGraphic param u a = AGraphic - { agDrawF :: DrawingAttr -> param -> Graphic u - , agMakeF :: DrawingAttr -> param -> a - } - - --- | ANode is drawn a a point supplied by the drawing --- (e.g. current node of Turtle). --- -type ANode u a = AGraphic (Point2 u) u a - --- /Free/ graphic --- -type AFreeGraphic u a = AGraphic () u a - -type AConnector u a = Point2 u -> Point2 u -> AFreeGraphic u a - -instance Functor (AGraphic pm u) where - fmap f (AGraphic df mf) = AGraphic df (\pt attr -> f $ mf pt attr) - -instance Applicative (AGraphic pm u) where - pure a = AGraphic (\_ _ -> id) (\_ _ -> a) - (AGraphic df1 mf1) <*> (AGraphic df2 mf2) = AGraphic df mf - where - df attr pt = df2 attr pt . df1 attr pt - mf attr pt = mf1 attr pt $ mf2 attr pt - - --- This doesn't work like at on MGraphicF, as the point is not --- scaled w.r.t. TurtleScaleM ... --- -at :: ANode u a -> Point2 u -> ANode u a -at (AGraphic df mf) pt = AGraphic (\attr _ -> df attr pt) - (\attr _ -> mf attr pt) - - - --- getPos should be a class method outside of Turtle --- those Bivariate context from PSC could implement it... - -node :: (Num u, TraceM m u, DrawingCtxM m, TurtleScaleM m u) - => ANode u a -> m a -node (AGraphic df mf) = - askDrawingCtx >>= \attr -> - getPos >>= \pt -> - trace (df attr pt) >> return (mf attr pt) - -nodeAt :: (Num u, TraceM m u, DrawingCtxM m) - => ANode u a -> Point2 u -> m a -nodeAt (AGraphic df mf) pt = - askDrawingCtx >>= \attr -> - trace (df attr pt) >> return (mf attr pt) - - -liftAFG :: (Num u, TraceM m u, DrawingCtxM m) - => AFreeGraphic u a -> m a -liftAFG (AGraphic df mf) = - askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ()) - - - -connect :: (Num u, TraceM m u, DrawingCtxM m) - => AConnector u a -> Point2 u -> Point2 u -> m a -connect conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in - askDrawingCtx >>= \attr -> trace (df attr ()) >> return (mf attr ()) - - --- This is a bit unfortunate - with a connector we can\'t touch --- the drawingAttr inside the AGraphic becase a connecter is --- --- > pt -> pt -> AGraphic --- --- and not --- --- > AGraphic --- --- --- Maybe AGraphic shouldn\'t have the agAttrF field? --- --- --- -connect_ :: (Num u, TraceM m u, DrawingCtxM m) - => (DrawingAttr -> DrawingAttr) - -> AConnector u a -> Point2 u -> Point2 u -> m a -connect_ fn conn p1 p2 = let (AGraphic df mf) = conn p1 p2 in - askDrawingCtx >>= \a0 -> - let attr = fn $ a0 in trace (df attr ()) >> return (mf attr ()) - - - - -infixr 7 `props` - -props :: AGraphic pm u a -> (DrawingAttr -> DrawingAttr) -> AGraphic pm u a -props (AGraphic df mf) upd = AGraphic (\attr p -> df (upd attr) p) - (\attr p -> mf (upd attr) p) - - - diff --git a/src/Wumpus/Basic/Monads/DrawingCtxClass.hs b/src/Wumpus/Basic/Monads/DrawingCtxClass.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/DrawingCtxClass.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.DrawingCtxClass --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Class. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.DrawingCtxClass - ( - - - -- * DrawingCtx class - - DrawingCtxM(..) - , withinModifiedCtx - - ) where - -import Wumpus.Basic.Graphic.DrawingAttr - - -class Monad m => DrawingCtxM m where - askDrawingCtx :: m DrawingAttr - localCtx :: DrawingAttr -> m a -> m a - - - -withinModifiedCtx :: DrawingCtxM m - => (DrawingAttr -> DrawingAttr) -> m a -> m a -withinModifiedCtx upd ma = askDrawingCtx >>= \ctx -> localCtx (upd ctx) ma - - diff --git a/src/Wumpus/Basic/Monads/DrawingMonad.hs b/src/Wumpus/Basic/Monads/DrawingMonad.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/DrawingMonad.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.DrawingMonad --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Drawing with trace and drawing context (i.e. reader monad --- of attributes - fill_colour etc.). --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.DrawingMonad - ( - - Drawing - , DrawingT - , runDrawing - , execDrawing - , runDrawingT - , execDrawingT - - , module Wumpus.Basic.Graphic.DrawingAttr - , module Wumpus.Basic.Monads.DrawingCtxClass - , module Wumpus.Basic.Monads.TraceClass - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr -import Wumpus.Basic.Monads.DrawingCtxClass -import Wumpus.Basic.Monads.TraceClass - - --- import Wumpus.Core -- package: wumpus-core - -import Control.Applicative -import Control.Monad - - - -newtype Drawing u a = Drawing { - getDrawing :: DrawingAttr -> (a, Graphic u) } - -newtype DrawingT u m a = DrawingT { - getDrawingT :: DrawingAttr -> m (a, Graphic u) } - --- Functor - -instance Functor (Drawing u) where - fmap f ma = Drawing $ \attr -> - let (a,w) = getDrawing ma attr in (f a,w) - - -instance Monad m => Functor (DrawingT u m) where - fmap f ma = DrawingT $ \attr -> - getDrawingT ma attr >>= \(a,w) -> return (f a,w) - --- Applicative - -instance Applicative (Drawing u) where - pure a = Drawing $ \_ -> (a, emptyG) - mf <*> ma = Drawing $ \attr -> let (f,w1) = getDrawing mf attr - (a,w2) = getDrawing ma attr - in (f a, w2 . w1) - -instance Monad m => Applicative (DrawingT u m) where - pure a = DrawingT $ \_ -> return (a, emptyG) - mf <*> ma = DrawingT $ \attr -> getDrawingT mf attr >>= \(f,w1) -> - getDrawingT ma attr >>= \(a,w2) -> - return (f a, w2 . w1) - --- Monad - -instance Monad (Drawing u) where - return a = Drawing $ \_ -> (a, emptyG) - ma >>= k = Drawing $ \attr -> let (a,w1) = getDrawing ma attr - (b,w2) = (getDrawing . k) a attr - in (b, w2 . w1) - - - -instance Monad m => Monad (DrawingT u m) where - return a = DrawingT $ \_ -> return (a, emptyG) - ma >>= k = DrawingT $ \attr -> getDrawingT ma attr >>= \(a,w1) -> - (getDrawingT . k) a attr >>= \(b,w2) -> - return (b, w2 . w1) - --- TraceM - -instance TraceM (Drawing u) u where - trace a = Drawing $ \_ -> ((),a) - -instance Monad m => TraceM (DrawingT u m) u where - trace a = DrawingT $ \_ -> return ((),a) - - --- DrawingCtxM - -instance DrawingCtxM (Drawing u) where - askDrawingCtx = Drawing $ \attr -> (attr,emptyG) - localCtx ctx ma = Drawing $ \_ -> getDrawing ma ctx - - - -instance Monad m => DrawingCtxM (DrawingT u m) where - askDrawingCtx = DrawingT $ \attr -> return (attr,emptyG) - localCtx ctx ma = DrawingT $ \_ -> getDrawingT ma ctx - - - - - -runDrawing :: DrawingAttr -> Drawing u a -> (a, Graphic u) -runDrawing attr ma = getDrawing ma attr - -execDrawing :: DrawingAttr -> Drawing u a -> Graphic u -execDrawing attr ma = snd $ runDrawing attr ma - -runDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (a, Graphic u) -runDrawingT attr ma = getDrawingT ma attr - -execDrawingT :: Monad m => DrawingAttr -> DrawingT u m a -> m (Graphic u) -execDrawingT attr ma = liftM snd $ runDrawingT attr ma diff --git a/src/Wumpus/Basic/Monads/TraceClass.hs b/src/Wumpus/Basic/Monads/TraceClass.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/TraceClass.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.TraceClass --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Tracing class covers both cons and snoc tracing --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.TraceClass - ( - - TraceM(..) - - - ) where - - -import Wumpus.Basic.Graphic - - -class TraceM m u | m -> u where - trace :: Graphic u -> m () - diff --git a/src/Wumpus/Basic/Monads/TurtleMonad.hs b/src/Wumpus/Basic/Monads/TurtleMonad.hs --- a/src/Wumpus/Basic/Monads/TurtleMonad.hs +++ b/src/Wumpus/Basic/Monads/TurtleMonad.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -14,7 +15,7 @@ -- Stability : unstable -- Portability : GHC -- --- Turtle monad and monad transformer. +-- Turtle monad transformer. -- -- The Turtle monad embodies the LOGO style of imperative -- drawing - sending commands to update the a cursor. @@ -23,29 +24,28 @@ -- \"coordinate-free\" style of drawing, some types of -- diagram are more easily expressed in the LOGO style. -- +-- Turtle is only a transformer - it is intended to be run within +-- a 'Drawing'. +-- -------------------------------------------------------------------------------- module Wumpus.Basic.Monads.TurtleMonad ( - + -- * Re-exports + module Wumpus.Basic.Monads.TurtleClass - Turtle + -- * Turtle transformer , TurtleT - - , runTurtle , runTurtleT + -- * Turtle combined with Drawing , TurtleDrawing , runTurtleDrawing , execTurtleDrawing - - , module Wumpus.Basic.Monads.DrawingMonad - , module Wumpus.Basic.Monads.TurtleClass ) where import Wumpus.Basic.Graphic -import Wumpus.Basic.Monads.DrawingMonad import Wumpus.Basic.Monads.TurtleClass @@ -66,30 +66,20 @@ , _current_coord :: (Int,Int) } -newtype Turtle u a = Turtle { - getTurtle :: TurtleConfig u -> TurtleState -> (a, TurtleState) } - newtype TurtleT u m a = TurtleT { getTurtleT :: TurtleConfig u -> TurtleState -> m (a, TurtleState) } +type instance MonUnit (TurtleT u m) = u -- Functor -instance Functor (Turtle u) where - fmap f m = Turtle $ \r s -> let (a,s') = getTurtle m r s in (f a, s') instance Monad m => Functor (TurtleT u m) where fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') -> return (f a, s') -- Applicative -instance Applicative (Turtle u) where - pure a = Turtle $ \_ s -> (a,s) - mf <*> ma = Turtle $ \r s -> let (f,s') = getTurtle mf r s - (a,s'') = getTurtle ma r s' - in (f a,s'') - instance Monad m => Applicative (TurtleT u m) where pure a = TurtleT $ \_ s -> return (a,s) mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s >>= \(f,s') -> @@ -99,11 +89,6 @@ -- Monad -instance Monad (Turtle u) where - return a = Turtle $ \_ s -> (a,s) - m >>= k = Turtle $ \r s -> let (a,s') = getTurtle m r s - in (getTurtle . k) a r s' - instance Monad m => Monad (TurtleT u m) where return a = TurtleT $ \_ s -> return (a,s) m >>= k = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') -> @@ -112,17 +97,7 @@ -instance TurtleM (Turtle u) where - getLoc = Turtle $ \_ s@(TurtleState _ c) -> (c,s) - setLoc c = Turtle $ \_ (TurtleState o _) -> ((),TurtleState o c) - getOrigin = Turtle $ \_ s@(TurtleState o _) -> (o,s) - setOrigin o = Turtle $ \_ (TurtleState _ c) -> ((),TurtleState o c) -instance TurtleScaleM (Turtle u) u where - xStep = Turtle $ \r s -> (xstep r,s) - yStep = Turtle $ \r s -> (ystep r,s) - - instance Monad m => TurtleM (TurtleT u m) where getLoc = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s) setLoc c = TurtleT $ \_ (TurtleState o _) -> return ((),TurtleState o c) @@ -136,9 +111,6 @@ -- Run functions discard the state... -runTurtle :: Num u => TurtleConfig u -> (Int,Int) -> Turtle u a -> a -runTurtle cfg ogin mf = fst $ getTurtle mf cfg (TurtleState ogin ogin) - runTurtleT :: (Monad m, Num u) => TurtleConfig u -> (Int,Int) -> TurtleT u m a -> m a runTurtleT cfg ogin mf = liftM fst $ getTurtleT mf cfg (TurtleState ogin ogin) @@ -146,25 +118,31 @@ + ---------------------------------------------------------------------------------- -- Cross instances instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where - askDrawingCtx = TurtleT $ \_ s -> askDrawingCtx >>= \ ctx -> return (ctx,s) + askCtx = TurtleT $ \_ s -> askCtx >>= \ ctx -> return (ctx,s) localCtx ctx mf = TurtleT $ \r s -> localCtx ctx (getTurtleT mf r s) -- This needs undecidable instances... -instance (Monad m, TraceM m i) => TraceM (TurtleT u m) i where +instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where trace a = TurtleT $ \_ s -> trace a >> return ((),s) -------------------------------------------------------------------------------- + newtype TurtleDrawing u a = TurtleDrawing { getTurtleDrawing :: TurtleT u (Drawing u) a } + +type instance MonUnit (TurtleDrawing u) = u + + instance Functor (TurtleDrawing u) where fmap f = TurtleDrawing . fmap f . getTurtleDrawing @@ -196,7 +174,7 @@ -- Lifters no longer supplied... -- TraceM -instance TraceM (TurtleDrawing u) u where +instance TraceM (TurtleDrawing u) where trace a = TurtleDrawing $ trace a @@ -204,26 +182,24 @@ -- DrawingCtxM instance DrawingCtxM (TurtleDrawing u) where - askDrawingCtx = TurtleDrawing $ askDrawingCtx + askCtx = TurtleDrawing $ askCtx localCtx ctx ma = TurtleDrawing $ localCtx ctx (getTurtleDrawing ma) runTurtleDrawing :: Num u => TurtleConfig u -> (Int,Int) - -> DrawingAttr + -> DrawingContext -> TurtleDrawing u a - -> (a, Graphic u) -runTurtleDrawing cfg ogin attr mf = - runDrawing attr ( runTurtleT cfg ogin $ getTurtleDrawing mf) + -> (a, HPrim u) +runTurtleDrawing cfg ogin ctx mf = + runDrawing ctx ( runTurtleT cfg ogin $ getTurtleDrawing mf) execTurtleDrawing :: Num u => TurtleConfig u -> (Int,Int) - -> DrawingAttr + -> DrawingContext -> TurtleDrawing u a - -> Graphic u -execTurtleDrawing cfg ogin attr mf = - snd $ runTurtleDrawing cfg ogin attr mf - + -> HPrim u +execTurtleDrawing cfg ogin ctx mf = snd $ runTurtleDrawing cfg ogin ctx mf diff --git a/src/Wumpus/Basic/Paths.hs b/src/Wumpus/Basic/Paths.hs --- a/src/Wumpus/Basic/Paths.hs +++ b/src/Wumpus/Basic/Paths.hs @@ -34,7 +34,6 @@ ) where import Wumpus.Basic.Graphic -import Wumpus.Basic.Graphic.DrawingAttr import Wumpus.Basic.Paths.Base import Wumpus.Basic.Paths.Construction @@ -53,9 +52,8 @@ -- This one might be more useful... -pathGraphic :: Num u => Path u -> DrawingAttr -> Graphic u -pathGraphic bpath attr = - wrapG $ ostroke (stroke_colour attr) (stroke_props attr) $ toPrimPathU bpath +pathGraphic :: Num u => PathF u -> ConnGraphic u +pathGraphic bpath = \p1 p2 -> openStroke $ toPrimPathU $ bpath p1 p2 diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs --- a/src/Wumpus/Basic/Paths/Base.hs +++ b/src/Wumpus/Basic/Paths/Base.hs @@ -43,6 +43,7 @@ ) where + import Wumpus.Core -- package: wumpus-core import Data.AffineSpace @@ -52,7 +53,9 @@ import Data.Sequence ( Seq, ViewL(..), viewl, (|>) ) import qualified Data.Sequence as S - +-- Note - path doesn\'t need a drawing context for +-- construction... +-- type PathF u = Point2 u -> Point2 u -> Path u diff --git a/src/Wumpus/Basic/Text/LRSymbol.hs b/src/Wumpus/Basic/Text/LRSymbol.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Text/LRSymbol.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Text.LRSymbol --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Named literals from Symbol font, drawn with the LRText monad. --- --- Note - currently the techinique used here generates adequate --- PostScript, but very ineficient SVG. --- --- Also uUpsilon is not mapped to the correct character... --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Text.LRSymbol - ( - - -- * Lower case - - alpha - , beta - , gamma - , delta - , epsilon - , zeta - , eta - , theta - , iota - , kappa - , lambda - , mu - , nu - , xi - , pi - , rho - , sigma - , tau - , upsilon - , phi - , chi - , psi - , omega - - -- * Upper case - , uGamma - , uDelta - , uTheta - , uLambda - , uXi - , uPi - , uSigma - , uUpsilon - , uPhi - , uPsi - , uOmega - - ) where - - -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Text.LRText - -import Wumpus.Core -- package: wumpus-core - -import Data.Char ( chr ) -import Prelude hiding ( pi ) - --- Note - due to a optimization in Wumpus-Core, the PostScript --- generated by the techinique here - writing a --- (single-character) label one at a time - isn\'t too bad as --- Wumpus-Core only issues a findfont command when the font --- changes. --- --- However for SVG the result is very poor - one text element --- including an orientation changing matrix transforming for --- each character. --- --- Wumpus-Core\'s SVG rendering will work at some point. --- - -useSymbol :: TextM u a -> TextM u a -useSymbol = bracketFontFace symbol - - --------------------------------------------------------------------------------- --- lower case - - -alpha :: (Num u, FromPtSize u) => TextM u () -alpha = useSymbol $ char 'a' - -beta :: (Num u, FromPtSize u) => TextM u () -beta = useSymbol $ char 'b' - -gamma :: (Num u, FromPtSize u) => TextM u () -gamma = useSymbol $ char 'g' - -delta :: (Num u, FromPtSize u) => TextM u () -delta = useSymbol $ char 'd' - -epsilon :: (Num u, FromPtSize u) => TextM u () -epsilon = useSymbol $ char 'e' - -zeta :: (Num u, FromPtSize u) => TextM u () -zeta = useSymbol $ char 'z' - -eta :: (Num u, FromPtSize u) => TextM u () -eta = useSymbol $ char 'h' - -theta :: (Num u, FromPtSize u) => TextM u () -theta = useSymbol $ char 'q' - -iota :: (Num u, FromPtSize u) => TextM u () -iota = useSymbol $ char 'i' - -kappa :: (Num u, FromPtSize u) => TextM u () -kappa = useSymbol $ char 'k' - -lambda :: (Num u, FromPtSize u) => TextM u () -lambda = useSymbol $ char 'l' - -mu :: (Num u, FromPtSize u) => TextM u () -mu = useSymbol $ char 'm' - -nu :: (Num u, FromPtSize u) => TextM u () -nu = useSymbol $ char 'n' - -xi :: (Num u, FromPtSize u) => TextM u () -xi = useSymbol $ char 'x' - -pi :: (Num u, FromPtSize u) => TextM u () -pi = useSymbol $ char 'p' - -rho :: (Num u, FromPtSize u) => TextM u () -rho = useSymbol $ char 'r' - -sigma :: (Num u, FromPtSize u) => TextM u () -sigma = useSymbol $ char 's' - -tau :: (Num u, FromPtSize u) => TextM u () -tau = useSymbol $ char 't' - -upsilon :: (Num u, FromPtSize u) => TextM u () -upsilon = useSymbol $ char 'u' - -phi :: (Num u, FromPtSize u) => TextM u () -phi = useSymbol $ char 'j' - -chi :: (Num u, FromPtSize u) => TextM u () -chi = useSymbol $ char 'c' - -psi :: (Num u, FromPtSize u) => TextM u () -psi = useSymbol $ char 'y' - -omega :: (Num u, FromPtSize u) => TextM u () -omega = useSymbol $ char 'w' - - --------------------------------------------------------------------------------- --- upper case - -uGamma :: (Num u, FromPtSize u) => TextM u () -uGamma = useSymbol $ char 'G' - -uDelta :: (Num u, FromPtSize u) => TextM u () -uDelta = useSymbol $ char 'D' - -uTheta :: (Num u, FromPtSize u) => TextM u () -uTheta = useSymbol $ char 'Q' - -uLambda :: (Num u, FromPtSize u) => TextM u () -uLambda = useSymbol $ char 'L' - -uXi :: (Num u, FromPtSize u) => TextM u () -uXi = useSymbol $ char 'X' - -uPi :: (Num u, FromPtSize u) => TextM u () -uPi = useSymbol $ char 'P' - -uSigma :: (Num u, FromPtSize u) => TextM u () -uSigma = useSymbol $ char 'S' - --- | Not working, though 161 should be uUpsilon. --- -uUpsilon :: (Num u, FromPtSize u) => TextM u () -uUpsilon = useSymbol $ char $ chr 161 - -uPhi :: (Num u, FromPtSize u) => TextM u () -uPhi = useSymbol $ char 'F' - -uPsi :: (Num u, FromPtSize u) => TextM u () -uPsi = useSymbol $ char 'Y' - -uOmega :: (Num u, FromPtSize u) => TextM u () -uOmega = useSymbol $ char 'W' - diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Text/LRText.hs +++ /dev/null @@ -1,192 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Text.LRText --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- 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 - ( - TextM - , runTextM - - , text - , char - , kern - , newline - , bracketFontFace - - ) where - - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Utils.Combinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - --- Need a note in wumpus-core and here about space:preserve - - --- Graphic or GraphicF ? ans. GraphicF - --- Note - should be compatible with free-label and shape labels. --- This seems to favour GraphicF. - --- Not quite the same as a trace monad because it needs the --- result to a function \"from Point -> ... \" - - -data Idx = Idx { idx_x :: !Int, idx_y :: !Int } - deriving (Eq,Ord,Show) - - -rightn :: Int -> Idx -> Idx -rightn n = star (\s i -> s { idx_x = i+n }) idx_x - -down1 :: Idx -> Idx -down1 = star (\s i -> s { idx_y = i-1, idx_x =0 }) idx_y - --- can track the /user vectors so far/ in the state... - - -data St u = St - { xy_pos :: Idx - , font_desc :: FontAttr - , horizontal_disp :: PtSize - , acc_graphic :: TGraphicF u - } - --- Vertical distance between baselines. -type VDist = PtSize - -type Env = (VDist, RGBi) - -newtype TextM u a = TextM { getTextM :: Env -> St u -> (a, St u) } - --- wrap GraphicF as it has /special/ construction. --- -newtype TGraphicF u = TGraphicF { getTGraphicF :: GraphicF u } - -consT :: Num u => (Vec2 u, GraphicF u) -> TGraphicF u -> TGraphicF u -consT (V2 x y, f) tg = TGraphicF $ (f . disp x y) `cc` (getTGraphicF tg) - - -instance Functor (TextM u) where - fmap f mf = TextM $ \r s -> let (a,s') = getTextM mf r s in (f a,s') - -instance Applicative (TextM u) where - pure a = TextM $ \_ s -> (a,s) - mf <*> ma = TextM $ \r s -> let (f,s') = getTextM mf r s - (a,s'') = getTextM ma r s' - in (f a,s'') - -instance Monad (TextM u) where - return a = TextM $ \_ s -> (a,s) - m >>= k = TextM $ \r s -> let (a,s') = getTextM m r s - in (getTextM . k) a r s' - --- Note - post has to displace in the vertical to get the bottom --- line at the base line... - -runTextM :: (Num u, FromPtSize u) - => PtSize -> (RGBi,FontAttr) -> (TextM u a) -> (a,GraphicF u) -runTextM vdistance (rgb,font) ma = post $ getTextM ma env st - where - post (a,s) = let gf = getTGraphicF $ acc_graphic s - h = fromIntegral $ idx_y $ xy_pos s - in (a, gf . vdisp (negate $ h * fromPtSize vdistance)) - - env = (vdistance,rgb) - - st = St { xy_pos = Idx 0 0 - , font_desc = font - , horizontal_disp = 0 - , acc_graphic = TGraphicF (const emptyG) } - - --------------------------------------------------------------------------------- --- State monad ops. --- Note - not all the state should be accessible. - -setFontAttr :: FontAttr -> TextM u () -setFontAttr fa = TextM $ \_ s -> ((), s { font_desc = fa }) - -setsFontAttr :: (FontAttr -> FontAttr) -> TextM u () -setsFontAttr fn = TextM $ \_ st -> ((), upd st) - where - upd = star (\s i -> s { font_desc = fn i} ) font_desc - -getFontAttr :: TextM u FontAttr -getFontAttr = TextM $ \_ s -> (font_desc s,s) - - --------------------------------------------------------------------------------- - -makeDisplacement :: (Num u, FromPtSize u) - => FontSize -> PtSize -> PtSize -> Idx -> (Vec2 u) -makeDisplacement font_sz lefth vdist (Idx x y) = - vec (txt_width + fromPtSize lefth) - (fromPtSize vdist * fromIntegral y) - where - txt_width = fromPtSize $ textWidth font_sz x - - -text :: (Num u, FromPtSize u) => String -> TextM u () -text str = TextM $ \r s -> ((), upd r s) - where - upd (vdist,rgb) s@(St idx font h acc) = - 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 } - - -char :: (Num u, FromPtSize u) => Char -> TextM u () -char ch = TextM $ \r s -> ((), upd r s) - where - upd (vdist,rgb) s@(St idx font h acc) = - 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 } - - -kern :: (Num u, FromPtSize u) => PtSize -> TextM u () -kern h = TextM $ \_ s -> ((), upd s) - where - upd = star (\s i -> s { horizontal_disp = i + h }) horizontal_disp - - - - -newline :: TextM u () -newline = TextM $ \_ s -> ((), upd s) - where - upd = star (\s idx -> s { xy_pos = down1 idx, horizontal_disp = 0}) - xy_pos - - - -bracketFontFace :: FontFace -> TextM u a -> TextM u a -bracketFontFace face mf = do - old <- getFontAttr - setsFontAttr fn - ans <- mf - setFontAttr old - return ans - where - fn attr = attr { font_face = face } diff --git a/src/Wumpus/Basic/Utils/Combinators.hs b/src/Wumpus/Basic/Utils/Combinators.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Utils/Combinators.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Utils.Combinators --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Combinators... --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Utils.Combinators - ( - - -- * Starlings... - star - , star2 - , star3 - , star4 - - ) where - --- starlings... - --- Note - this is the correct argument order for a starling. --- I\'ve used these combinators elsewhere with arguments of the --- \"combiner\" in the wrong order. - -star :: (r -> a -> ans) - -> (r -> a) - -> r -> ans -star f fa x = f x (fa x) - -star2 :: (r -> a -> b -> ans) - -> (r -> a) - -> (r -> b) - -> r -> ans -star2 f fa fb x = f x (fa x) (fb x) - -star3 :: (r -> a -> b -> c -> ans) - -> (r -> a) - -> (r -> b) - -> (r -> c) - -> r -> ans -star3 f fa fb fc x = f x (fa x) (fb x) (fc x) - -star4 :: (r -> a -> b -> c -> d -> ans) - -> (r -> a) - -> (r -> b) - -> (r -> c) - -> (r -> d) - -> r -> ans -star4 f fa fb fc fd x = f x (fa x) (fb x) (fc x) (fd x) - - diff --git a/src/Wumpus/Basic/Utils/HList.hs b/src/Wumpus/Basic/Utils/HList.hs --- a/src/Wumpus/Basic/Utils/HList.hs +++ b/src/Wumpus/Basic/Utils/HList.hs @@ -35,6 +35,7 @@ ) where + -------------------------------------------------------------------------------- -- Hughes list diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs --- a/src/Wumpus/Basic/VersionNumber.hs +++ b/src/Wumpus/Basic/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,6,0) +-- > (0,7,0) -- wumpus_basic_version :: (Int,Int,Int) -wumpus_basic_version = (0,6,0) +wumpus_basic_version = (0,7,0) diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal --- a/wumpus-basic.cabal +++ b/wumpus-basic.cabal @@ -1,5 +1,5 @@ name: wumpus-basic -version: 0.6.0 +version: 0.7.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -9,9 +9,10 @@ synopsis: Common drawing utilities built on wumpus-core. description: . - \*\* WARNING \*\* - this package is sub-alpha. It is only on - Hackage to support other packages (Wumpus-Tree, - Wumpus-Microprint) that are slighly more stable. + \*\* WARNING \*\* - this package is sub-alpha. It was released + to Hackage prematurely - designing a higher-level drawing + library turns out to be much more demanding than designing a + low-level one (Wumpus-Core). . A few of the modules (SafeFonts, SVGColours, X11Colours) are fairly stable others simply aren\'t and may even disappear in @@ -20,6 +21,23 @@ . Changelog: . + 0.6.0 to 0.7.0: + . + * Major rework of Graphic types, the old types (AGraphic, + GraphicF etc.) and the old drawing monads have been removed. + The new types are based on the AGraphic and related types but + their implementation is different. The new types track the + /graphics state/ within the type (the DrawingContext) plus + how to draw themselves. For real drawings, graphics are + collected with a Writer-like monad the @Basic.Graphic.Drawing@ + monad which replaces the DrawingCtx and Trace monads. The + Turtle monad remains and has been updated to work with the new + drawing monads. + . + * LRText and LRSymbol modules temporarily removed as they + contradict the new, optimized kerning functionality in + @Wumpus.Core@. + . 0.5.0 to 0.6.0: . * Updates to work with wumpus-core-0.30.0. @@ -58,7 +76,7 @@ build-depends: base < 5, containers >= 0.3 && <= 0.4, vector-space >= 0.6, - wumpus-core == 0.31.0 + wumpus-core == 0.32.0 exposed-modules: @@ -68,24 +86,20 @@ Wumpus.Basic.Colour.SVGColours, Wumpus.Basic.Colour.X11Colours, Wumpus.Basic.Dots, - Wumpus.Basic.Dots.Base, + Wumpus.Basic.Dots.Primitive, Wumpus.Basic.Graphic, - Wumpus.Basic.Graphic.DrawingAttr, - Wumpus.Basic.Graphic.Primitive, - Wumpus.Basic.Graphic.PointSupply, - Wumpus.Basic.Monads.Drawing, - Wumpus.Basic.Monads.DrawingMonad, - Wumpus.Basic.Monads.DrawingCtxClass, - Wumpus.Basic.Monads.TraceClass, + Wumpus.Basic.Graphic.BaseClasses, + Wumpus.Basic.Graphic.BaseTypes, + Wumpus.Basic.Graphic.Chain, + Wumpus.Basic.Graphic.Drawing, + Wumpus.Basic.Graphic.DrawingContext, + Wumpus.Basic.Graphic.PrimGraphic, Wumpus.Basic.Monads.TurtleClass, Wumpus.Basic.Monads.TurtleMonad, Wumpus.Basic.Paths, Wumpus.Basic.Paths.Base, Wumpus.Basic.Paths.Construction, Wumpus.Basic.SafeFonts, - Wumpus.Basic.Text.LRSymbol, - Wumpus.Basic.Text.LRText, - Wumpus.Basic.Utils.Combinators, Wumpus.Basic.Utils.HList, Wumpus.Basic.Utils.Intersection, Wumpus.Basic.VersionNumber,