diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,30 @@ + +0.2.0 to 0.3.0: + + * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@ + name-space. Modules here are considered sketches. + + * Re-implemented arrowheads and connectors. + + * Re-implemented monadic path construction. This is now + essentially \"turtle drawing\" with a path trace. + + * Removed chains - a simplified implementation is now + provided by Wumpus-Basic. + + * Re-implemented and expanded Text. + +0.1.0 to 0.2.0: + + * Added new Shapes. + + * Move Geometry modules to Wumpus-Basic. + + * Re-implemented Chains. + + * Re-implemented LR-Text. Added CatText. + 0.1.0: * Initial release - this is a split from @Wumpus-Basic@ making diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -13,7 +13,7 @@ import Wumpus.Core -- package: wumpus-core - +import Data.Monoid import System.Directory main :: IO () @@ -38,7 +38,7 @@ arrow_drawing = drawTracing $ localize dotted_line $ tableGraphic arrtable -arrtable :: [(String, ArrowTip Double)] +arrtable :: [(String, ArrowTip)] arrtable = [ ("tri90", tri90) , ("tri60", tri60) @@ -74,7 +74,7 @@ -tableGraphic :: [(String, ArrowTip Double)] -> TraceDrawing Double () +tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = drawl start $ chain_ chn_alg (map makeArrowDrawing tips) where @@ -87,12 +87,12 @@ -makeArrowDrawing :: (String, ArrowTip Double) -> LocGraphic Double -makeArrowDrawing (name, utip) = aconn `oplus` lbl +makeArrowDrawing :: (String, ArrowTip) -> LocGraphic Double +makeArrowDrawing (name, utip) = aconn `mappend` lbl where - aconn = promoteR1 $ \pt -> fmap ignoreAns $ - connect (uniformArrow utip connline) pt (displaceH 60 pt) + aconn = ignoreAns $ promoteLoc $ \pt -> + connect pt (displace (hvec 60) pt) (uniformArrow utip connline) - lbl = promoteR1 $ \pt -> fmap ignoreAns $ - atStartAddr (textline name) (displaceH 66 pt) WW + lbl = ignoreAns $ promoteLoc $ \pt -> + textline name WW `at` (displace (hvec 66) pt) diff --git a/demo/Automata.hs b/demo/Automata.hs --- a/demo/Automata.hs +++ b/demo/Automata.hs @@ -4,6 +4,7 @@ module Automata where import Wumpus.Drawing.Connectors +import Wumpus.Drawing.Extras.Loop import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero @@ -57,11 +58,12 @@ return () - +-- Monadic at - this is a hack that needs a rethink... +-- infixr 1 `mat` -mat :: LocImage u a -> Query (Point2 u) -> Image u a -mat img mq = mq >>= \pt -> img `at` pt +mat :: LocImage u a -> Query u (Point2 u) -> Image u a +mat img mq = zapQuery mq >>= \pt -> img `at` pt state :: String -> DLocImage DCircle state ss = @@ -84,12 +86,12 @@ => a -> b -> Image u (AbsPath u) straightconn a b = let (p0,p1) = radialConnectorPoints a b - in connect (rightArrow tri45 connline) p0 p1 + in connect p0 p1 (rightArrow tri45 connline) astraightconn :: ( Real u, Floating u, InterpretUnit u) => Anchor u -> Anchor u -> Image u (AbsPath u) -astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1 +astraightconn p0 p1 = connect p0 p1 (rightArrow tri45 connline) -- Note - there is a problem with @rightArrow@ as @loop@ @@ -97,7 +99,13 @@ -- arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Anchor u -> Anchor u -> Image u (AbsPath u) -arrloop p0 p1 = connect (rightArrow barb45 loop) p0 p1 +arrloop ctr p1 = + zapQuery (loop zradius ctr zincl) >>= \absp -> + rightArrowPath tri45 absp + where + v1 = pvec ctr p1 + zradius = vlength v1 + zincl = vdirection v1 diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -13,7 +13,8 @@ module ClipPic where import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Extras.Clip +import Wumpus.Drawing.Paths.Relative import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -22,13 +23,14 @@ import Data.AffineSpace -- package: vector-space +import Data.Monoid import System.Directory main :: IO () main = do createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_ctx $ top_pic `vconcat` clip_pic + let pic1 = runCtxPictureU std_ctx clip_pic writeEPS "./out/clip_pic.eps" pic1 writeSVG "./out/clip_pic.svg" pic1 @@ -37,74 +39,72 @@ std_ctx = standardContext 14 -top_pic :: CtxPicture -top_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do - draw $ toPrimPath path01 >>= filledPath - draw $ localize (fill_colour powder_blue) $ toPrimPath path02 >>= filledPath - draw $ toPrimPath path03 >>= filledPath - draw $ toPrimPath path04 >>= filledPath - clip_pic :: CtxPicture -clip_pic = drawTracing $ do - mapM_ draw $ [ clip1, clip2, clip3, clip4 ] +clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do + drawl (P2 0 320) $ closedRelPath FILL path01 + drawl (P2 112 320) $ localize (fill_colour powder_blue) $ closedRelPath FILL path02 + drawl (P2 384 416) $ closedRelPath FILL path03 + drawl (P2 328 512) $ closedRelPath FILL path04 + drawl (P2 0 0) $ clip1 + drawl (P2 112 0) $ clip2 + drawl (P2 384 96) $ clip3 + drawl (P2 328 192) $ clip4 -background :: RGBi -> Graphic Double -background rgb = - fmap ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 +background :: RGBi -> LocGraphic Double +background rgb = promoteLoc $ \_ -> + ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 where ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell) --- Wumpus-Basic needs a clip function, but is this the most --- satisfactory definition? --- -clipGraphic :: PrimPath -> Graphic u -> Graphic u -clipGraphic cp = fmap (clipObject cp) -clip1 :: Graphic Double -clip1 = toPrimPath path01 >>= \pp -> clipGraphic pp (background black) +clip1 :: LocGraphic Double +clip1 = locClip path01 $ background black -clip2 :: Graphic Double -clip2 = toPrimPath path02 >>= \pp -> clipGraphic pp (background medium_violet_red) +clip2 :: LocGraphic Double +clip2 = locClip path02 $ background medium_violet_red -clip3 :: Graphic Double -clip3 = toPrimPath path03 >>= \pp -> clipGraphic pp (background black) +clip3 :: LocGraphic Double +clip3 = locClip path03 $ background black -clip4 :: Graphic Double -clip4 = toPrimPath path04 >>= \pp -> clipGraphic pp (background black) +clip4 :: LocGraphic Double +clip4 = locClip path04 $ background black iheartHaskell :: LocGraphic Double -iheartHaskell = promoteR1 $ \pt -> - let body = plainTextLine "I Haskell" `at` pt +iheartHaskell = promoteLoc $ \pt -> + let body = dcTextlabel "I Haskell" `at` pt heart = localize (set_font symbol) $ - plainTextLine "&heart;" `at` (pt .+^ hvec 7) - in body `oplus` heart + dcTextlabel "&heart;" `at` (pt .+^ hvec 7) + in body `mappend` heart -path01 :: AbsPath Double -path01 = evalAbsBuild zeroPt $ hline 80 - >> relline (vec 112 160) - >> relline (vec (-112) 160) - >> hline (-80) - >> relline (vec 112 (-160)) - >> relline (vec (-112) (-160)) +-- zeroPt +path01 :: RelPath Double +path01 = evalPathSpec $ hline 80 + >> line (vec 112 160) + >> line (vec (-112) 160) + >> hline (-80) + >> line (vec 112 (-160)) + >> line (vec (-112) (-160)) - -path02 :: AbsPath Double -path02 = evalAbsBuild (P2 112 0) $ hline 80 - >> relline (vec 72 112) - >> relline (vec 72 (-112)) - >> hline 80 - >> relline (vec (-224) 320) - >> hline (-80) - >> relline (vec 112 (-160)) - >> relline (vec (-112) (-160)) +-- (P2 112 0) +path02 :: RelPath Double +path02 = evalPathSpec $ hline 80 + >> line (vec 72 112) + >> line (vec 72 (-112)) + >> hline 80 + >> line (vec (-224) 320) + >> hline (-80) + >> line (vec 112 (-160)) + >> line (vec (-112) (-160)) -path03 :: AbsPath Double -path03 = evalAbsBuild (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) +-- (P2 384 96) +path03 :: RelPath Double +path03 = evalPathSpec $ hline 96 >> vline 56 >> hline (-136) -path04 :: AbsPath Double -path04 = evalAbsBuild (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) +-- (P2 328 192) +path04 :: RelPath Double +path04 = evalPathSpec $ hline 152 >> vline 56 >> hline (-192) diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -4,11 +4,13 @@ import ColourChartUtils +import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core +import Data.Monoid import System.Directory @@ -44,14 +46,14 @@ tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt where chn = tableDown row_count (152,11) - pt = displaceV (fromIntegral $ 11 * row_count) zeroPt + pt = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt gs = map (uncurry colourSample) xs colourSample :: String -> RGBi -> LocGraphic Double colourSample name rgb = localize (fill_colour rgb) $ - promoteR1 $ \pt -> - oplus (borderedRectangle 15 10 `at` pt) - (plainTextLine name `at` displace 20 2 pt) + promoteLoc $ \pt -> + mappend (blRectangle FILL_STROKE 15 10 `at` pt) + (dcTextlabel name `at` displace (vec 20 2) pt) diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -13,7 +13,7 @@ import Wumpus.Core -- package: wumpus-core - +import Data.Monoid import System.Directory @@ -76,13 +76,13 @@ makeConnDrawing :: (String, Connector Double) -> DLocGraphic makeConnDrawing (ss,conn) = - promoteR1 $ \p0 -> fn p0 (displace 60 40 p0) + promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0) where - fn p0 p1 = disk p0 `oplus` disk p1 `oplus` dcon p0 p1 `oplus` lbl p1 + fn p0 p1 = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1] - disk pt = localize (fill_colour red) $ filledDisk 2 `at` pt - dcon p0 p1 = fmap ignoreAns $ connect (uniformArrow curveTip conn) p0 p1 + disk pt = localize (fill_colour red) $ dcDisk FILL 2 `at` pt + dcon p0 p1 = ignoreAns $ connect p0 p1 (uniformArrow curveTip conn) - lbl pt = fmap ignoreAns $ atStartAddr (textline ss) (displaceH 10 pt) WW + lbl pt = ignoreAns $ textline ss WW `at` (displace (hvec 10) pt) diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -4,6 +4,8 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots +import Wumpus.Drawing.Paths.Relative +import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -11,8 +13,7 @@ import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space - +import Data.Monoid import System.Directory main :: IO () @@ -30,68 +31,66 @@ makeCtx :: FontLoadResult -> DrawingContext -makeCtx = fill_colour peru . set_font helvetica . metricsContext 24 +makeCtx = fill_colour peru . set_font helvetica . metricsContext 14 dot_pic :: CtxPicture -dot_pic = drawTracing $ tableGraphic $ - [ dotHLine - , dotVLine - , dotX - , dotPlus - , dotCross - , dotDiamond - , dotDisk - , dotSquare - , dotCircle - , dotPentagon - , dotStar - , dotAsterisk - , dotOPlus - , dotOCross - , dotFOCross - , dotFDiamond - , dotText "%" - , dotTriangle +dot_pic = drawTracing $ tableGraphic dottable + + +dottable :: [(String, DotLocImage Double)] +dottable = + [ ("smallDisk", smallDisk) + , ("largeDisk", largeDisk) + , ("smallCirc", smallCirc) + , ("largeCirc", largeCirc) + , ("dotNone", dotNone) + , ("dotHLine", dotHLine) + , ("dotVLine", dotVLine) + , ("dotX", dotX) + , ("dotPlus", dotPlus) + , ("dotCross", dotCross) + , ("dotDiamond", dotDiamond) + , ("dotDisk", dotDisk) + , ("dotSquare", dotSquare) + , ("dotCircle", dotCircle) + , ("dotPentagon", dotPentagon) + , ("dotStar", dotStar) + , ("dotAsterisk", dotAsterisk) + , ("dotOPlus", dotOPlus) + , ("dotOCross", dotOCross) + , ("dotFOCross", dotFOCross) + , ("dotFDiamond", dotFDiamond) + , ("dotText" , dotText "%") + , ("dotTriangle", dotTriangle) ] -tableGraphic :: [DotLocImage Double] -> TraceDrawing Double () + +tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt where - row_count = length imgs - chn_alg = tableDown row_count (1,36) - pt = displaceV (fromIntegral $ 36 * row_count) zeroPt + row_count = 18 + chn_alg = tableDown row_count (180,36) + pt = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt --- This is a bit convoluted - maybe there should be chain-run --- functions for TraceDrawings as well as LocGraphics? -makeDotDrawing :: (Real u, Floating u, InterpretUnit u) - => DotLocImage u -> LocGraphic u -makeDotDrawing dotF = - promoteR1 $ \pt -> - let all_points = map (pt .+^) displacements - in oconcat (dashline all_points) - (map (\p1 -> fmap ignoreAns $ dotF `at` p1) all_points) +makeDotDrawing :: (String, DotLocImage Double) -> DLocGraphic +makeDotDrawing (name,df) = + drawing `mappend` moveStart (vec 86 14) lbl where - dashline = \ps -> localize attrUpd $ vertexPP ps >>= openStroke - - attrUpd :: DrawingContext -> DrawingContext - attrUpd = packed_dotted . stroke_colour cadet_blue - -displacements :: Num u => [Vec2 u] -displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20] - + drawing = execPathSpec $ + updatePen path_style >> + insertl dot >> mapM (\v -> line v >> insertl dot) steps --- Should these produce a DashPattern or a StrokeAttr? + lbl = ignoreAns $ promoteLoc $ \pt -> + textline name WW `at` pt -evenDashes :: Int -> DashPattern -evenDashes n = Dash 0 [(n,n)] + steps = [V2 25 15, V2 25 (-15), V2 25 15] + dot = ignoreAns df + path_style = packed_dotted . stroke_colour cadet_blue -dashOffset :: Int -> DashPattern -> DashPattern -dashOffset _ Solid = Solid -dashOffset n (Dash _ xs) = Dash n xs diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -87,12 +87,12 @@ connWith :: ( Real u, Floating u, InterpretUnit u ) - => ArrowTip u -> Box u -> Box u -> TraceDrawing u (AbsPath u) + => ArrowTip -> Box u -> Box u -> TraceDrawing u (AbsPath u) connWith arrh b0 b1 = do lw <- getLineWidth let p0 = south b0 let p1 = projectAnchor north (realToFrac lw) b1 - drawi $ connect (rightArrow arrh connline) p0 p1 + drawi $ connect p0 p1 (rightArrow arrh connline) infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -42,7 +42,7 @@ makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic -makeLabel rgb ft sz = localize upd (plainTextLine $ fontMsg ft sz) +makeLabel rgb ft sz = localize upd (dcTextlabel $ fontMsg ft sz) where upd = text_colour rgb . font_attr ft sz @@ -59,14 +59,14 @@ pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2 pointChain fn = chain chn_alg $ map fn point_sizes where - chn_alg = linear $ iterationScheme start step + chn_alg = linearChain $ iterationScheme start step start = \pt -> (pt,point_sizes) - step (pt,[]) = ((displaceV 50 pt, []), pt) - step (pt,(y:ys)) = ((displaceV (fromIntegral $ 2 + y) pt, ys), pt) + step (pt,[]) = ((displace (vvec 50) pt, []), pt) + step (pt,(y:ys)) = ((displace (vvec $ fromIntegral $ 2 + y) pt, ys), pt) fontGraphic :: RGBi -> FontDef -> DLocGraphic -fontGraphic rgb ft = locGraphic_ $ pointChain mkGF +fontGraphic rgb ft = ignoreAns $ pointChain mkGF where mkGF sz = makeLabel rgb ft sz diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs --- a/demo/LeftRightText.hs +++ b/demo/LeftRightText.hs @@ -1,23 +1,12 @@ {-# OPTIONS -Wall #-} --- Note - @main@ is more convoluted than would normally be --- expected as it supports both sources of glyph metrics - the --- GhostScript distribution or the Core 14 metrics from Adobe. --- --- \"Real\" applications would be expected to choose one source. --- --- I-am-not-a-lawyer, but it does look as though the Adobe font --- metrics are redistributable, the GhostScript metrics are --- seemingly redistributable under the same terms as the larger --- GhostScript distribution. --- module LeftRightText where import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -84,47 +73,47 @@ fn = illustrateBoundedLocGraphic redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u -redPlus = localize (stroke_colour red) markPlus +redPlus = localize (stroke_colour red) dotPlus -- single line -- ne_oneline :: BoundedLocGraphic Double -ne_oneline = textline "north east" `startAddr` NE +ne_oneline = textline "north east" NE -- single line -- se_oneline :: BoundedLocGraphic Double -se_oneline = textline "south east" `startAddr` SE +se_oneline = textline "south east" SE -- single line -- ss_oneline :: BoundedLocGraphic Double -ss_oneline = textline "south" `startAddr` SS +ss_oneline = textline "south" SS -- single line -- sw_oneline :: BoundedLocGraphic Double -sw_oneline = textline "south west" `startAddr` SW +sw_oneline = textline "south west" SW -- single line rot -- ssr_single :: BoundedLocGraphic Double -ssr_single = rtextline (0.25*pi) "south rot45" `startAddr` SS +ssr_single = rtextline (0.25*pi) "south rot45" SS -- single line rot -- swr_single :: BoundedLocGraphic Double -swr_single = rtextline (0.25*pi) "south west rot45" `startAddr` SW +swr_single = rtextline (0.25*pi) "south west rot45" SW -- single line rot -- ner_single :: BoundedLocGraphic Double -ner_single = rtextline (0.25*pi) "north east rot45" `startAddr` NE +ner_single = rtextline (0.25*pi) "north east rot45" NE cc_oneline :: BoundedLocGraphic Double @@ -136,14 +125,14 @@ left_text :: BoundedLocGraphic Double -left_text = multiAlignLeft dummy_text `startAddr` CENTER +left_text = multiAlignLeft dummy_text CENTER right_text :: BoundedLocGraphic Double -right_text = multiAlignRight dummy_text `startAddr` CENTER +right_text = multiAlignRight dummy_text CENTER center_text :: BoundedLocGraphic Double -center_text = multiAlignCenter dummy_text `startAddr` CENTER +center_text = multiAlignCenter dummy_text CENTER dummy_text :: String dummy_text = unlines $ [ "The quick brown" diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs --- a/demo/PetriNet.hs +++ b/demo/PetriNet.hs @@ -100,39 +100,39 @@ straightconn :: ConnectorGraphic Double -straightconn = connectorGraphic_ $ rightArrow tri45 connline +straightconn = ignoreAns $ rightArrow tri45 connline connectorC :: ConnectorGraphic Double connectorC = - connectorGraphic_ $ localize (uniform_arm_len (30::Double)) - $ rightArrow tri45 connbbar + ignoreAns $ localize (uniform_arm_len (30::Double)) + $ rightArrow tri45 connbbar connectorC' :: ConnectorGraphic Double connectorC' = - connectorGraphic_ $ localize (uniform_arm_len (30::Double)) + ignoreAns $ localize (uniform_arm_len (30::Double)) $ rightArrow tri45 connabar connectorD :: ConnectorGraphic Double -connectorD = connectorGraphic_ $ rightArrow tri45 connarc +connectorD = ignoreAns $ rightArrow tri45 connarc connectorD' :: ConnectorGraphic Double connectorD' = - connectorGraphic_ $ localize (conn_arc_angle $ negate $ pi / 12) + ignoreAns $ localize (conn_arc_angle $ negate $ pi / 12) $ rightArrow tri45 connarc lblParensParens :: DLocGraphic lblParensParens = - locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),()" + ignoreAns $ localize (set_font helvetica) $ ccTextline "(),()" lblParensParensParens :: DLocGraphic lblParensParensParens = - locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),(),()" + ignoreAns $ localize (set_font helvetica) $ ccTextline "(),(),()" lblBold :: String -> DLocGraphic lblBold ss = - locGraphic_ $ localize (set_font helvetica_bold) $ ccTextline ss + ignoreAns $ localize (set_font helvetica_bold) $ ccTextline ss diff --git a/demo/SampleShapes.hs b/demo/SampleShapes.hs --- a/demo/SampleShapes.hs +++ b/demo/SampleShapes.hs @@ -7,7 +7,7 @@ import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -18,6 +18,7 @@ import Wumpus.Core -- package: wumpus-core import Control.Monad +import Data.Monoid import System.Directory main :: IO () @@ -67,7 +68,7 @@ , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150) , ( "trapezium" , shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ - ztrapezium 300 150) + trapezium 300 200 150) , ( "triangle" , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ triangle 300 150 ) @@ -154,7 +155,8 @@ return () where shape = strokedShape $ setDecoration textF sh - textF = lift1R2 $ locGraphic_ (startAddr (multiAlignCenter name) CENTER) + textF = promoteLocTheta $ \pt _ -> + ignoreAns (multiAlignCenter name CENTER) `at` pt deg10 = d2r (10::Double) deg110 = d2r (110::Double) @@ -171,19 +173,19 @@ label :: (Real u, Floating u, InterpretUnit u) => Cardinal -> String -> LocGraphic u -label cpos ss = markX `oplus` msg +label cpos ss = dotX `mappend` msg where (rpos,fn) = go cpos - msg = locGraphic_ $ moveStart (fn 10) $ - startAddr (multiAlignCenter ss) rpos + msg = ignoreAns $ moveStart (fn 10) $ + multiAlignCenter ss rpos - go NORTH = (SS, disp_north) - go NORTH_EAST = (SW, disp_northeast) - go EAST = (WW, disp_east) - go SOUTH_EAST = (NW, disp_southeast) - go SOUTH = (NN, disp_south) - go SOUTH_WEST = (NE, disp_southwest) - go WEST = (EE, disp_west) - go NORTH_WEST = (SE, disp_northwest) + go NORTH = (SS, go_north) + go NORTH_EAST = (SW, go_north_east) + go EAST = (WW, go_east) + go SOUTH_EAST = (NW, go_south_east) + go SOUTH = (NN, go_south) + go SOUTH_WEST = (NE, go_south_west) + go WEST = (EE, go_west) + go NORTH_WEST = (SE, go_north_west) diff --git a/demo/SingleChar.hs b/demo/SingleChar.hs --- a/demo/SingleChar.hs +++ b/demo/SingleChar.hs @@ -5,7 +5,7 @@ import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Dots.SimpleDots import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -62,9 +62,9 @@ draw $ redPlus `at` P2 200 0 where - fn addr obj = illustrateBoundedLocGraphic (runPosObjectR2 obj `startAddr` addr) + fn addr obj = illustrateBoundedLocGraphic $ (runPosObject addr obj) redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u -redPlus = localize (stroke_colour red) markPlus +redPlus = localize (stroke_colour red) dotPlus diff --git a/demo/SingleLine.hs b/demo/SingleLine.hs --- a/demo/SingleLine.hs +++ b/demo/SingleLine.hs @@ -12,6 +12,7 @@ import Wumpus.Core -- package: wumpus-core +import Data.Monoid import System.Directory @@ -52,9 +53,9 @@ testDraw :: RectAddress -> LocGraphic Double -testDraw rpos = filledDisk 2 `oplus` (locGraphic_ ans) +testDraw rpos = dcDisk FILL 2 `mappend` (ignoreAns ans) where - ans = textline "Qwerty" `startAddr` rpos + ans = textline "Qwerty" rpos diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -36,8 +36,8 @@ where chn_alg = tableDown 30 (100,20) start = P2 0 (30*20) - sdraw (s,_) = plainTextLine s - ldraw (_,name) = moveStart (displaceH 16) (plainTextLine name) + sdraw (s,_) = dcTextlabel s + ldraw (_,name) = moveStart (hvec 16) (dcTextlabel name) all_letters :: [(String, String)] diff --git a/demo/TableChains.hs b/demo/TableChains.hs deleted file mode 100644 --- a/demo/TableChains.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS -Wall #-} - -module TableChains where - - -import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Extras.Grids - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core - -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_ctx table_drawing - writeEPS "./out/table_chains01.eps" pic1 - writeSVG "./out/table_chains01.svg" pic1 - -std_ctx :: DrawingContext -std_ctx = fill_colour peru $ standardContext 18 - -table_drawing :: CtxPicture -table_drawing = udrawTracing (0::Double) $ do - draw $ grid (grid_minor_colour cornflower_blue) (0,0) (4,2) diff --git a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs @@ -0,0 +1,136 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.DrawingPrimitives +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Alternative to the @DrawingPrimitives@ module in Wumpus-Basic. +-- +-- The drawing primitives here are either slightly higher level or +-- less general (more quirky). +-- +-- This module is expected to be imported qualified - other modules +-- (e.g. shapes and paths) are likely to export conflicting names. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.DrawingPrimitives + ( + + + -- * Lines + + hline + , vline + , pivotLine + + -- * Rectangles + , blRectangle + , ctrRectangle + + + -- * Arc and wedge + , arc + , wedge + + ) + + where + +import Wumpus.Basic.Geometry -- package: wumpus-basic +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +-------------------------------------------------------------------------------- +-- Lines + +-- | Draw a vertical line. +-- +vline :: InterpretUnit u => u -> LocGraphic u +vline len = locStraightLine $ vvec len + +-- | Draw a horizontal line. +-- +hline :: InterpretUnit u => u -> LocGraphic u +hline len = locStraightLine $ hvec len + + + +-- | @pivotLine@ : @ left_length * right_length * incline -> LocGraphic @ +-- +-- Draw a /pivot/ line. The start point is a pivot along the line, +-- not the end. The left and right distances are the extension of +-- the line from the pivot. +-- +pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u +pivotLine lu ru ang = promoteLoc $ \pt -> + straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru) + + +-------------------------------------------------------------------------------- +-- Rectangles + + + +-- | Draw a rectangle, start point is bottom left. +-- +blRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u +blRectangle = dcRectangle + + +-- | Draw a rectangle, start point is bottom left. +-- +ctrRectangle :: (Fractional u, InterpretUnit u) + => DrawStyle -> u -> u -> LocGraphic u +ctrRectangle sty w h = + moveStart (vec (-hw) (-hh)) $ dcRectangle sty w h + where + hw = 0.5 * w + hh = 0.5 * h + + + + +-------------------------------------------------------------------------------- +-- Wedge + + +-- | arc : radius * apex_angle +-- +arc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u +arc radius ang = promoteLocTheta $ \pt inclin -> + let ps = bezierArcPoints ang radius inclin pt + in zapQuery (curvePP ps) >>= dcOpenPath + +-- | wedge : radius * apex_angle +-- +wedge :: (Floating u, InterpretUnit u) + => DrawStyle -> u -> Radian -> LocThetaGraphic u +wedge sty radius ang = promoteLocTheta $ \pt inclin -> + let ps = bezierArcPoints ang radius inclin pt + in uconvertCtxF pt >>= \dpt -> + mapM uconvertCtxF ps >>= \dps -> + dcClosedPath sty (build dpt dps) + where + -- Note - this relies on an implicit straight line cycle back + -- to the start point. + -- + build :: DPoint2 -> [DPoint2] -> PrimPath + build pt [] = emptyPrimPath pt + build pt (p1:ps) = let cs = curves ps + in absPrimPath pt (absLineTo p1 : cs) + + curves (a:b:c:ps) = absCurveTo a b c : curves ps + curves _ = [] + diff --git a/src/Wumpus/Drawing/Basis/LocTrace.hs b/src/Wumpus/Drawing/Basis/LocTrace.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/LocTrace.hs @@ -0,0 +1,252 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.LocTrace +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.LocTrace + ( + + -- * LocTrace monads + LocTrace + , LocTraceT + + , runLocTrace + , evalLocTrace + , execLocTrace + + , runLocTraceT + , evalLocTraceT + , execLocTraceT + + , liftLocTraceT + + -- * LocTrace classes + , LocTraceM(..) + , LocForkTraceM(..) + + -- * Derived operations + , hmoveBy + , vmoveBy + + ) + + where + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.VectorSpace -- package: vector-space + +import Control.Applicative +import Control.Monad +import Data.Monoid + +-- | LocTrace is a writer state monad. +-- +-- The writer accumulates a LocGraphic the state is a cumulative +-- displacement vector (called a cursor below). +-- +newtype LocTrace u a = LocTrace { + getLocTrace :: Vec2 u -> (a, Vec2 u, LocGraphic u )} + + +type instance DUnit (LocTrace u a) = u + + +-- Do we need a transformer version +-- | LocTrace is a writer state monad. +-- +-- The writer accumulates a LocGraphic the state is a cumulative +-- displacement vector. +-- +newtype LocTraceT u m a = LocTraceT { + getLocTraceT :: Vec2 u -> m (a, Vec2 u, LocGraphic u )} + + +type instance DUnit (LocTraceT u m a) = u + + +type instance MonUnit (LocTrace u a) = u +type instance MonUnit (LocTraceT u m a) = u + + +-- Functor + +instance Functor (LocTrace u) where + fmap f ma = LocTrace $ \v0 -> let (a,v1,o) = getLocTrace ma v0 + in (f a, v1, o) + +instance Monad m => Functor (LocTraceT u m) where + fmap f ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,v1,o) -> + return (f a, v1, o) + +-- Applicative + +instance Applicative (LocTrace u) where + pure a = LocTrace $ \v0 -> (a, v0, mempty) + mf <*> ma = LocTrace $ \v0 -> + let (f,v1,o1) = getLocTrace mf v0 + (a,v2,o2) = getLocTrace ma v1 + in (f a, v2, o1 `mappend` o2) + + + + +instance Monad m => Applicative (LocTraceT u m) where + pure a = LocTraceT $ \v0 -> return (a, v0, mempty) + mf <*> ma = LocTraceT $ \v0 -> + getLocTraceT mf v0 >>= \(f,v1,o1) -> + getLocTraceT ma v1 >>= \(a,v2,o2) -> + return (f a, v2, o1 `mappend` o2) + + + +-- Monad + +instance Monad (LocTrace u) where + return a = LocTrace $ \v0 -> (a, v0, mempty) + ma >>= k = LocTrace $ \v0 -> + let (a,v1,o1) = getLocTrace ma v0 + (b,v2,o2) = (getLocTrace . k) a v1 + in (b, v2, o1 `mappend` o2) + +instance Monad m => Monad (LocTraceT u m) where + return a = LocTraceT $ \v0 -> return (a, v0, mempty) + ma >>= k = LocTraceT $ \v0 -> + getLocTraceT ma v0 >>= \(a,v1,o1) -> + (getLocTraceT . k) a v1 >>= \(b,v2,o2) -> + return (b, v2, o1 `mappend` o2) + + + +runLocTrace :: Num u => LocTrace u a -> (a, Vec2 u, LocGraphic u) +runLocTrace mf = getLocTrace mf (V2 0 0) + + +-- | Forget the generated LocImage, just return the /answer/. +-- +evalLocTrace :: Num u => LocTrace u a -> a +evalLocTrace = post . runLocTrace + where + post (a,_,_) = a + +-- | Forget the /answer/, just return the generated LocImage. +-- +execLocTrace :: Num u => LocTrace u a -> LocGraphic u +execLocTrace = post . runLocTrace + where + post (_,_,o) = o + + + +runLocTraceT :: (Monad m, Num u) + => LocTraceT u m a -> m (a, Vec2 u, LocGraphic u) +runLocTraceT mf = getLocTraceT mf (V2 0 0) + + +-- | Forget the generated LocImage, just return the /answer/. +-- +evalLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m a +evalLocTraceT = liftM post . runLocTraceT + where + post (a,_,_) = a + +-- | Forget the /answer/, just return the generated LocImage. +-- +execLocTraceT :: (Monad m, Num u) => LocTraceT u m a -> m (LocGraphic u) +execLocTraceT = liftM post . runLocTraceT + where + post (_,_,o) = o + + + +liftLocTraceT :: Monad m => m a -> LocTraceT u m a +liftLocTraceT ma = LocTraceT $ \v0 -> + ma >>= \a -> return (a,v0,mempty) + + + + +-- | 'insertl' analogue to Writer monad @tell@. +-- +class Monad m => LocTraceM (m :: * -> *) where + insertl :: MonUnit (m ()) ~ u => LocGraphic u -> m () + insertl_ :: MonUnit (m ()) ~ u => LocImage u a -> m () + + moveBy :: MonUnit (m ()) ~ u => Vec2 u -> m () + location :: MonUnit (m ()) ~ u => m (Vec2 u) + + + insertl_ = insertl . ignoreAns + + + +-- Note - @reset@ steals a too general name. +-- It needs changing... + +-- | Add operations for branching (fork at the current point) +-- and resetting to the start point. +-- +-- Not all drawings that support tracing support branching. For +-- instance Paths can be built by tracing but they always need +-- a cumulative progression of /next point/ they cannot resrt to +-- the start point and go in a differnt direction. +-- +class LocTraceM m => LocForkTraceM (m :: * -> *) where + reset :: m () + + -- Branch is like @local@ in the Reader monad. + branch :: m a -> m a + + + + +instance Num u => LocTraceM (LocTrace u) where + insertl gf = LocTrace $ \v0 -> ((), v0, moveStart v0 gf) + moveBy v = LocTrace $ \v0 -> ((), v0 ^+^ v, mempty) + location = LocTrace $ \v0 -> (v0, v0, mempty) + +instance Num u => LocForkTraceM (LocTrace u) where + reset = LocTrace $ \_ -> ((), V2 0 0, mempty) + branch ma = LocTrace $ \v0 -> let (a,_,o) = getLocTrace ma v0 in (a,v0,o) + + +instance (Monad m, Num u) => LocTraceM (LocTraceT u m) where + insertl gf = LocTraceT $ \v0 -> return ((), v0, moveStart v0 gf) + moveBy v = LocTraceT $ \v0 -> return ((), v0 ^+^ v, mempty) + location = LocTraceT $ \v0 -> return (v0, v0, mempty) + +instance (LocTraceM m, Num u) => LocForkTraceM (LocTraceT u m) where + reset = LocTraceT $ \_ -> return ((), V2 0 0, mempty) + branch ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,_,o) -> + return (a,v0,o) + + +-------------------------------------------------------------------------------- +-- Derived operations + + +-- | Move the /cursor/ horizontally. +-- +hmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m () +hmoveBy dx = moveBy (hvec dx) + +-- | Move the /cursor/ vertically. +-- +vmoveBy :: (LocTraceM m, Num u, u ~ MonUnit (m ())) => u -> m () +vmoveBy dx = moveBy (vvec dx) diff --git a/src/Wumpus/Drawing/Basis/RefTrace.hs b/src/Wumpus/Drawing/Basis/RefTrace.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/RefTrace.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.RefTrace +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Writer monad with imperative /turtle/ style movement to build +-- LocGraphics and /references/ allowing connectors between +-- objects. +-- +-- Note - references are not /feedback/. Subsequent nodes cannot +-- be place at anchors of previous nodes - anchors only allow +-- connectors to be drawn between located nodes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.RefTrace + ( + + -- * Re-exports + LocTraceM(..) + + , RefTrace + , RefTraceT + + , Ref + , RefTraceM(..) + + , runRefTrace + , runRefTraceT + + , unaryLink + , binaryLink + , multiwayLink + ) + + where + +import Wumpus.Drawing.Basis.LocTrace + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import qualified Wumpus.Basic.Utils.JoinList as JL + +import Wumpus.Core -- package: wumpus-core + +import Data.VectorSpace -- package: vector-space + +import Control.Applicative +import Control.Monad +import qualified Data.IntMap as IntMap +import Data.Maybe +import Data.Monoid + + + + +newtype RefTrace u z a = RefTrace { + getRefTrace :: RefSt u z -> (a, RefSt u z) } + + +type instance MonUnit (RefTrace u z a) = u + +newtype RefTraceT u z m a = RefTraceT { + getRefTraceT :: RefSt u z -> m (a, RefSt u z) } + + +type instance MonUnit (RefTraceT u z m a) = u + + +newtype Ref = Ref { getRefUid :: Int } + + +-- GRAPHIC or LOC_GRAPHIC? cf. connectors... +-- +-- TODO - make this an newtype and only export an arity family of +-- constructors. +-- +-- Maybe we only support the arity2 (connector) and list (path) cases? +-- +-- type Elaboration u ans = IntMap.IntMap ans -> Graphic u + +data LinkRef u ans = + Unary { refU :: Ref + , ancrU :: ans -> Point2 u + , drawU :: LocGraphic u + } + | Binary { refB1 :: Ref + , refB2 :: Ref + , ancrB1 :: ans -> Point2 u + , ancrB2 :: ans -> Point2 u + , drawB :: ConnectorGraphic u + } + | Multiway { refLs :: [Ref] + , ancrM :: ans -> Point2 u + , drawM :: [Point2 u] -> Graphic u + } + +data RefSt u z = RefSt + { uid_count :: Int + , current_tip :: Vec2 u + , ref_acc :: LocImage u (IntMap.IntMap z) + , ref_links :: JL.JoinList (LinkRef u z) + } + + + +type instance DUnit (RefSt u z) = u + +type RefStF u z = RefSt u z -> RefSt u z + + +zeroRefSt :: Num u => RefSt u z +zeroRefSt = RefSt { uid_count = 0 + , current_tip = V2 0 0 + , ref_acc = mempty + , ref_links = mempty + } + + + + +-- Functor + +instance Functor (RefTrace u z) where + fmap f ma = RefTrace $ \s0 -> let (a,s1) = getRefTrace ma s0 in (f a, s1) + +instance Monad m => Functor (RefTraceT u z m) where + fmap f ma = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) -> + return (f a, s1) + + + +-- Applicative + +instance Applicative (RefTrace u z) where + pure a = RefTrace $ \s0 -> (a, s0) + mf <*> ma = RefTrace $ \s0 -> + let (f,s1) = getRefTrace mf s0 + (a,s2) = getRefTrace ma s1 + in (f a, s2) + + + +instance Monad m => Applicative (RefTraceT u z m) where + pure a = RefTraceT $ \s0 -> return (a, s0) + mf <*> ma = RefTraceT $ \s0 -> getRefTraceT mf s0 >>= \(f,s1) -> + getRefTraceT ma s1 >>= \(a,s2) -> + return (f a, s2) + + + +-- Monad + +instance Monad (RefTrace u z) where + return a = RefTrace $ \s0 -> (a, s0) + ma >>= k = RefTrace $ \s0 -> + let (a,s1) = getRefTrace ma s0 + in (getRefTrace . k) a s1 + + +instance Monad m => Monad (RefTraceT u z m) where + return a = RefTraceT $ \s0 -> return (a, s0) + ma >>= k = RefTraceT $ \s0 -> getRefTraceT ma s0 >>= \(a,s1) -> + (getRefTraceT . k) a s1 + + + + +-- LocTraceM + +instance Num u => LocTraceM (RefTrace u z) where + insertl gf = RefTrace $ \s0 -> ((), insertSt gf s0) + moveBy v = RefTrace $ \s0 -> ((), moveSt v s0) + location = RefTrace $ \s0 -> (current_tip s0, s0) + + +instance (Monad m, Num u) => LocTraceM (RefTraceT u z m) where + insertl gf = RefTraceT $ \s0 -> return ((), insertSt gf s0) + moveBy v = RefTraceT $ \s0 -> return ((), moveSt v s0) + location = RefTraceT $ \s0 -> return (current_tip s0, s0) + + + +-- Run functions + +runRefTrace :: Num u => RefTrace u ans a -> LocImage u a +runRefTrace mf = post $ getRefTrace mf zeroRefSt + where + post (a,st) = replaceAns a $ reconcileRefSt st + + +runRefTraceT :: (Monad m, Num u) => RefTraceT u ans m a -> m (LocImage u a) +runRefTraceT mf = liftM post $ getRefTraceT mf zeroRefSt + where + post (a,st) = replaceAns a $ reconcileRefSt st + + + +-- Note we have to drop the vector + +reconcileRefSt :: RefSt u z -> LocGraphic u +reconcileRefSt st = + step (ref_acc st) (JL.toList $ ref_links st) + where + step img xs = ignoreAns $ elaborate img (\a -> mconcat $ map (fn a) xs) + + fn im (Unary r1 ar1 gf) = + maybe mempty (\pt -> promoteLoc $ \_ -> applyLoc gf pt) (projectRef r1 ar1 im) + + fn im (Binary r1 r2 ar1 ar2 conn) = + case (projectRef r1 ar1 im, projectRef r2 ar2 im) of + (Just p1, Just p2) -> promoteLoc $ \_ -> applyConn conn p1 p2 + _ -> mempty + + + fn im (Multiway rs ar1 gf) = + let ps = catMaybes $ map (\a -> projectRef a ar1 im) rs + in promoteLoc $ \_ -> gf ps + + + +projectRef :: Ref -> (ans -> Point2 u) -> IntMap.IntMap ans -> Maybe (Point2 u) +projectRef r ancr im = ancr <$> IntMap.lookup (getRefUid r) im + +-- Note - probably this supports Tree which is not a Trace monad... + +class Monad m => RefTraceM (m :: * -> *) where + type MonRef m :: * + insertRef :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LocImage u a -> m Ref + linkRef :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LinkRef u a -> m () + +instance Num u => RefTraceM (RefTrace u z) where + type MonRef (RefTrace u z) = z + insertRef img = RefTrace $ \s0 -> let (ix,s1) = incrementSt img s0 + in (Ref ix, s1) + + linkRef fn = RefTrace $ \s0 -> ((), snocLink fn s0) + + +moveSt :: Num u => Vec2 u -> RefStF u z +moveSt v = (\s i -> s { current_tip = i ^+^ v }) + <*> current_tip + +insertSt :: Num u => LocImage u z2 -> RefStF u ans +insertSt gf = (\s ac v1 -> let g1 = ignoreAns $ moveStart v1 gf + in s { ref_acc = decorate ac g1 }) + <*> ref_acc <*> current_tip + +snocLink :: LinkRef u ans -> RefStF u ans +snocLink fn = (\s i -> s { ref_links = JL.snoc i fn }) + <*> ref_links + + +incrementSt :: Num u + => LocImage u ans -> RefSt u ans -> (Int, RefSt u ans) +incrementSt img s0 = (uid_count s0, upd s0) + where + upd = (\s ac v1 ix -> let img1 = moveStart v1 img + in s { ref_acc = fn ix ac img1 + , uid_count = ix+1 }) + <*> ref_acc <*> current_tip <*> uid_count + + fn ix ac gf = fmap (\(a,b) -> IntMap.insert ix b a) $ both ac gf + + + +unaryLink :: (ans -> Point2 u) -> LocGraphic u -> Ref -> LinkRef u ans +unaryLink f gf = \r1 -> Unary { refU = r1 + , ancrU = f + , drawU = gf + } + +binaryLink :: (ans -> Point2 u) -> (ans -> Point2 u) + -> ConnectorGraphic u -> Ref -> Ref + -> LinkRef u ans +binaryLink f g conn = \r1 r2 -> Binary { refB1 = r1 + , refB2 = r2 + , ancrB1 = f + , ancrB2 = g + , drawB = conn + } + + +multiwayLink :: (ans -> Point2 u) -> ([Point2 u] -> Graphic u) -> [Ref] + -> LinkRef u ans +multiwayLink f gf = \rs -> Multiway { refLs = rs + , ancrM = f + , drawM = gf + } diff --git a/src/Wumpus/Drawing/Basis/TraceGraphic.hs b/src/Wumpus/Drawing/Basis/TraceGraphic.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/TraceGraphic.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.TraceGraphic +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Build multi-part Graphics with an accumulator (i.e. a Writer +-- monad). +-- +-- Note - the run functions for the transformer and the plain +-- monad are quite different. This is mandated by the need to +-- single-thread the DrawingContext through the transformer. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.TraceGraphic + ( + TraceGraphic + , TraceGraphicT + + , TraceGraphicM(..) + + , runTraceGraphic + , runTraceGraphicT + + , liftTraceGraphicT + + ) where + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Control.Applicative +import Data.Monoid + + + +newtype TraceGraphic u a = TraceGraphic { + getTraceGraphic :: DrawingContext -> (a, CatPrim) } + + +newtype TraceGraphicT u m a = TraceGraphicT { + getTraceGraphicT :: DrawingContext -> m (a, CatPrim) } + + +type instance MonUnit (TraceGraphic u a) = u +type instance MonUnit (TraceGraphicT u m a) = u + + +-- Functor + +instance Functor (TraceGraphic u) where + fmap f ma = TraceGraphic $ \ctx -> let (a,w1) = getTraceGraphic ma ctx + in (f a,w1) + + +instance Monad m => Functor (TraceGraphicT u m) where + fmap f ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma ctx >>= \(a,w1) -> + return (f a,w1) + + +-- Applicative + +instance Applicative (TraceGraphic u) where + pure a = TraceGraphic $ \_ -> (a, mempty) + mf <*> ma = TraceGraphic $ \ctx -> + let (f,w1) = getTraceGraphic mf ctx + (a,w2) = getTraceGraphic ma ctx + in (f a,w1 `mappend` w2) + + +instance Monad m => Applicative (TraceGraphicT u m) where + pure a = TraceGraphicT $ \_ -> return (a, mempty) + mf <*> ma = TraceGraphicT $ \ctx -> + getTraceGraphicT mf ctx >>= \(f,w1) -> + getTraceGraphicT ma ctx >>= \(a,w2) -> + return (f a,w1 `mappend` w2) + + + +-- Monad + +instance Monad (TraceGraphic u) where + return a = TraceGraphic $ \_ -> (a, mempty) + ma >>= k = TraceGraphic $ \ctx -> + let (a,w1) = getTraceGraphic ma ctx + (b,w2) = (getTraceGraphic . k) a ctx + in (b, w1 `mappend` w2) + + +instance Monad m => Monad (TraceGraphicT u m) where + return a = TraceGraphicT $ \_ -> return (a, mempty) + ma >>= k = TraceGraphicT $ \ctx -> + getTraceGraphicT ma ctx >>= \(a,w1) -> + (getTraceGraphicT . k) a ctx >>= \(b,w2) -> + return (b, w1 `mappend` w2) + + + +-- DrawingCtxM + +instance DrawingCtxM (TraceGraphic u) where + askDC = TraceGraphic $ \ctx -> (ctx, mempty) + asksDC f = TraceGraphic $ \ctx -> (f ctx, mempty) + localize upd ma = TraceGraphic $ \ctx -> getTraceGraphic ma (upd ctx) + + + +instance Monad m => DrawingCtxM (TraceGraphicT u m) where + askDC = TraceGraphicT $ \ctx -> return (ctx, mempty) + asksDC f = TraceGraphicT $ \ctx -> return (f ctx, mempty) + localize upd ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma (upd ctx) + + + +-- TraceGraphicM + +class Monad m => TraceGraphicM m where + tellImage :: MonUnit (m ()) ~ u => Image u a -> m a + tellImage_ :: MonUnit (m ()) ~ u => Image u a -> m () + + tellImage_ ma = tellImage ma >> return () + + +instance TraceGraphicM (TraceGraphic u) where + tellImage img = TraceGraphic $ \ctx -> + let (PrimW o a) = runImage ctx img in (a,o) + + tellImage_ img = TraceGraphic $ \ctx -> + let (PrimW o _) = runImage ctx img in ((),o) + + +instance Monad m => TraceGraphicM (TraceGraphicT u m) where + tellImage img = TraceGraphicT $ \ctx -> + let (PrimW o a) = runImage ctx img in return (a,o) + + tellImage_ img = TraceGraphicT $ \ctx -> + let (PrimW o _) = runImage ctx img in return ((),o) + + +runTraceGraphic :: TraceGraphic u a -> Image u a +runTraceGraphic mf = askDC >>= \ctx -> let (a,o) = getTraceGraphic mf ctx + in replaceAns a $ primGraphic o + + +-- | Note - this needs DrawingContext as an explicit parameter, +-- and hence it returns a pair of @(a, HPrim u)@ rather than an +-- Image. +-- +-- It is expected this will be wrapped in to form a specific +-- TraceDrawing /draw/ function for the amalgamated monad. +-- +runTraceGraphicT :: Monad m + => DrawingContext -> TraceGraphicT u m a -> m (a, HPrim u) +runTraceGraphicT ctx mf = + getTraceGraphicT mf ctx >>= \(a,o) -> return (a, singleH o) + + +liftTraceGraphicT :: Monad m => m a -> TraceGraphicT u m a +liftTraceGraphicT ma = TraceGraphicT $ \_ -> ma >>= \a -> return (a,mempty) + diff --git a/src/Wumpus/Drawing/Connectors.hs b/src/Wumpus/Drawing/Connectors.hs --- a/src/Wumpus/Drawing/Connectors.hs +++ b/src/Wumpus/Drawing/Connectors.hs @@ -20,7 +20,6 @@ , module Wumpus.Drawing.Connectors.Base , module Wumpus.Drawing.Connectors.BoxConnectors , module Wumpus.Drawing.Connectors.ConnectorPaths - , module Wumpus.Drawing.Connectors.Loop ) where @@ -28,4 +27,3 @@ import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Connectors.BoxConnectors import Wumpus.Drawing.Connectors.ConnectorPaths -import Wumpus.Drawing.Connectors.Loop diff --git a/src/Wumpus/Drawing/Connectors/Arrowheads.hs b/src/Wumpus/Drawing/Connectors/Arrowheads.hs --- a/src/Wumpus/Drawing/Connectors/Arrowheads.hs +++ b/src/Wumpus/Drawing/Connectors/Arrowheads.hs @@ -69,7 +69,6 @@ import Data.AffineSpace -- package: vector-space import Data.VectorSpace -import Control.Applicative @@ -85,20 +84,23 @@ filledTipPath :: PointGen -> LocThetaGraphic En filledTipPath fn = - localize fill_use_stroke_colour $ promoteR2 $ \pt theta -> - let vs = fn theta in vertexPP (map (pt .+^) vs) >>= filledPath + localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta -> + let vs = fn theta + in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath FILL closedTipPath :: PointGen -> LocThetaGraphic En closedTipPath fn = - localize solid_stroke_tip $ promoteR2 $ \pt theta -> - let vs = fn theta in vertexPP (map (pt .+^) vs) >>= closedStroke + localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> + let vs = fn theta + in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath STROKE openTipPath :: PointGen -> LocThetaGraphic En openTipPath fn = - localize solid_stroke_tip $ promoteR2 $ \pt theta -> - let vs = fn theta in vertexPP (map (pt .+^) vs) >>= openStroke + localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> + let vs = fn theta + in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcOpenPath @@ -145,9 +147,6 @@ -zeroVec :: Vec2 En -zeroVec = V2 0 0 - ang90 :: Radian ang90 = pi / 2 @@ -158,153 +157,165 @@ ang45 = pi / 4 -len_one :: InterpretUnit u => Query u -len_one = uconvertCtx1 (1::En) -len_two :: InterpretUnit u => Query u -len_two = uconvertCtx1 (2::En) -len_half :: InterpretUnit u => Query u -len_half = uconvertCtx1 (0.5::En) - -len_zero :: InterpretUnit u => Query u -len_zero = pure 0 - -retract_one :: InterpretUnit u => Query u -retract_one = uconvertCtx1 (1::En) - -retract_two :: InterpretUnit u => Query u -retract_two = uconvertCtx1 (2::En) - - --- retract_half :: InterpretUnit u => Query u --- retract_half = uconvertCtx1 (0.5::En) - -retract_zero :: InterpretUnit u => Query u -retract_zero = pure 0 - - - -filledTri :: InterpretUnit u => Radian -> ArrowTip u +filledTri :: Radian -> ArrowTip filledTri ang = - makeArrowTip retract_one len_one (filledTipPath spec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = filledTipPath spec + } where spec theta = let (v1,v2) = tripointsFromTip 1 ang theta in [zeroVec, v1, v2] - -tri90 :: InterpretUnit u => ArrowTip u +-- | Filled triangle - apex is 90 deg. +-- +tri90 :: ArrowTip tri90 = filledTri ang90 -tri60 :: InterpretUnit u => ArrowTip u +-- | Filled triangle - apex is 60 deg. +-- +tri60 :: ArrowTip tri60 = filledTri ang60 -tri45 :: InterpretUnit u => ArrowTip u +-- | Filled triangle - apex is 45 deg. +-- +tri45 :: ArrowTip tri45 = filledTri ang45 -strokedClosedTri :: InterpretUnit u => Radian -> ArrowTip u +strokedClosedTri :: Radian -> ArrowTip strokedClosedTri ang = - makeArrowTip retract_one len_one (closedTipPath spec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = closedTipPath spec + } where spec theta = let (v1,v2) = tripointsFromTip 1 ang theta in [zeroVec, v1, v2] -otri90 :: InterpretUnit u => ArrowTip u +otri90 :: ArrowTip otri90 = strokedClosedTri ang90 -otri60 :: InterpretUnit u => ArrowTip u +otri60 :: ArrowTip otri60 = strokedClosedTri ang60 -otri45 :: InterpretUnit u => ArrowTip u +otri45 :: ArrowTip otri45 = strokedClosedTri ang45 -filledRevTri :: InterpretUnit u => Radian -> ArrowTip u +filledRevTri :: Radian -> ArrowTip filledRevTri ang = - makeArrowTip retract_one len_one (filledTipPath spec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = filledTipPath spec + } where spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta in [v0, v1, v2] -revtri90 :: InterpretUnit u => ArrowTip u +revtri90 :: ArrowTip revtri90 = filledRevTri ang90 -revtri60 :: InterpretUnit u => ArrowTip u +revtri60 :: ArrowTip revtri60 = filledRevTri ang60 -revtri45 :: InterpretUnit u => ArrowTip u +revtri45 :: ArrowTip revtri45 = filledRevTri ang45 -strokedClosedRevTri :: InterpretUnit u => Radian -> ArrowTip u +strokedClosedRevTri :: Radian -> ArrowTip strokedClosedRevTri ang = - makeArrowTip retract_one len_one (closedTipPath spec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = closedTipPath spec + } where spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta in [v0, v1, v2] -orevtri90 :: InterpretUnit u => ArrowTip u +orevtri90 :: ArrowTip orevtri90 = strokedClosedRevTri ang90 -orevtri60 :: InterpretUnit u => ArrowTip u +orevtri60 :: ArrowTip orevtri60 = strokedClosedRevTri ang60 -orevtri45 :: InterpretUnit u => ArrowTip u +orevtri45 :: ArrowTip orevtri45 = strokedClosedRevTri ang45 -strokedBarb :: InterpretUnit u => Radian -> ArrowTip u +strokedBarb :: Radian -> ArrowTip strokedBarb ang = - makeArrowTip retract_zero len_one (openTipPath spec) + ArrowTip + { retract_distance = const 0 + , tip_half_len = 0.5 + , tip_deco = openTipPath spec + } where spec theta = let (v1,v2) = tripointsFromTip 1 ang theta in [v1,zeroVec,v2] -barb90 :: InterpretUnit u => ArrowTip u +barb90 :: ArrowTip barb90 = strokedBarb ang90 -barb60 :: InterpretUnit u => ArrowTip u +barb60 :: ArrowTip barb60 = strokedBarb ang60 -barb45 :: InterpretUnit u => ArrowTip u +barb45 :: ArrowTip barb45 = strokedBarb ang45 -strokedRevBarb :: InterpretUnit u => Radian -> ArrowTip u +strokedRevBarb :: Radian -> ArrowTip strokedRevBarb ang = - makeArrowTip retract_one len_one (openTipPath spec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = openTipPath spec + } where spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta in [v1,v0,v2] -revbarb90 :: InterpretUnit u => ArrowTip u +revbarb90 :: ArrowTip revbarb90 = strokedRevBarb ang90 -revbarb60 :: InterpretUnit u => ArrowTip u +revbarb60 :: ArrowTip revbarb60 = strokedRevBarb ang60 -revbarb45 :: InterpretUnit u => ArrowTip u +revbarb45 :: ArrowTip revbarb45 = strokedRevBarb ang45 -perp :: InterpretUnit u => ArrowTip u +perp :: ArrowTip perp = - makeArrowTip retract_zero len_zero (openTipPath spec) + ArrowTip + { retract_distance = const 0 + , tip_half_len = 0 + , tip_deco = openTipPath spec + } where spec theta = let oa = avec (theta + ang90) 0.5 ob = avec (theta - ang90) 0.5 in [oa, ob] -bracket :: InterpretUnit u => ArrowTip u +bracket :: ArrowTip bracket = - makeArrowTip retract_zero len_half (openTipPath spec) + ArrowTip + { retract_distance = const 0 + , tip_half_len = 0.5 + , tip_deco = openTipPath spec + } where spec theta = let oa = avec (theta + ang90) 0.5 ob = avec (theta - ang90) 0.5 @@ -313,26 +324,32 @@ -diskTip :: InterpretUnit u => ArrowTip u +diskTip :: ArrowTip diskTip = - makeArrowTip retract_one len_one - (promoteR2 $ \pt theta -> body theta `at` pt) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = promoteLocTheta $ \pt theta -> body theta `at` pt + } where body :: Radian -> LocGraphic En body theta = let v1 = avec theta (-0.5) in localize fill_use_stroke_colour $ - moveStart (displaceVec v1) (filledDisk 0.5) + moveStart v1 (dcDisk FILL 0.5) -odiskTip :: InterpretUnit u => ArrowTip u +odiskTip :: ArrowTip odiskTip = - makeArrowTip retract_one len_one - (promoteR2 $ \pt theta -> body theta `at` pt) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = promoteLocTheta $ \pt theta -> body theta `at` pt + } where body :: Radian -> LocGraphic En body theta = let v1 = avec theta (-0.5) in localize solid_stroke_tip $ - moveStart (displaceVec v1) (strokedDisk 0.5) + moveStart v1 (dcDisk STROKE 0.5) -- | squareSpec: @@ -352,13 +369,21 @@ ov = avec theta (-1) -squareTip :: InterpretUnit u => ArrowTip u +squareTip :: ArrowTip squareTip = - makeArrowTip retract_one len_one (filledTipPath squareSpec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = filledTipPath squareSpec + } -osquareTip :: InterpretUnit u => ArrowTip u +osquareTip :: ArrowTip osquareTip = - makeArrowTip retract_one len_one (closedTipPath squareSpec) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = closedTipPath squareSpec + } @@ -380,22 +405,38 @@ ob = ov ^+^ avec (theta - ang90) 0.5 -diamondTip :: InterpretUnit u => ArrowTip u +diamondTip :: ArrowTip diamondTip = - makeArrowTip retract_one len_one (filledTipPath $ diamondSpec 1) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = filledTipPath (diamondSpec 1) + } -odiamondTip :: InterpretUnit u => ArrowTip u +odiamondTip :: ArrowTip odiamondTip = - makeArrowTip retract_one len_one (closedTipPath $ diamondSpec 1) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = closedTipPath (diamondSpec 1) + } -diamondWideTip :: InterpretUnit u => ArrowTip u +diamondWideTip :: ArrowTip diamondWideTip = - makeArrowTip retract_two len_two (filledTipPath $ diamondSpec 2) + ArrowTip + { retract_distance = const 2 + , tip_half_len = 1.0 + , tip_deco = filledTipPath (diamondSpec 2) + } -odiamondWideTip :: InterpretUnit u => ArrowTip u +odiamondWideTip :: ArrowTip odiamondWideTip = - makeArrowTip retract_two len_two (closedTipPath $ diamondSpec 2) + ArrowTip + { retract_distance = const 2 + , tip_half_len = 1.0 + , tip_deco = closedTipPath (diamondSpec 2) + } curveTipPath :: Point2 En -> Radian -> AbsPath En @@ -410,12 +451,17 @@ (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt -curveTip :: InterpretUnit u => ArrowTip u +curveTip :: ArrowTip curveTip = - makeArrowTip retract_zero len_one - (promoteR2 $ \pt theta -> - localize (join_bevel . solid_stroke_tip) $ - toPrimPath (curveTipPath pt theta) >>= openStroke) + ArrowTip + { retract_distance = const 0 + , tip_half_len = 0.5 + , tip_deco = body + } + where + body = promoteLocTheta $ \pt theta -> + localize (join_bevel . solid_stroke_tip) $ + zapQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath @@ -431,12 +477,17 @@ (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x -revcurveTip :: InterpretUnit u => ArrowTip u +revcurveTip :: ArrowTip revcurveTip = - makeArrowTip retract_one len_one - (promoteR2 $ \pt theta -> - localize (join_bevel . solid_stroke_tip) $ - toPrimPath (curveTipRevPath pt theta) >>= openStroke) + ArrowTip + { retract_distance = const 1 + , tip_half_len = 0.5 + , tip_deco = body + } + where + body = promoteLocTheta $ \pt theta -> + localize (join_bevel . solid_stroke_tip) $ + zapQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath @@ -458,7 +509,7 @@ base_len = vlength base_vec theta = vdirection base_vec half_ulen = 0.5 * ratio_to_base * base_len - base_mid = displaceParallel (0.5 * base_len) theta p1 - ubase_mid = displacePerpendicular u theta base_mid - cp1 = displaceParallel (-half_ulen) theta ubase_mid - cp2 = displaceParallel half_ulen theta ubase_mid + base_mid = dispParallel (0.5 * base_len) theta p1 + ubase_mid = dispPerpendicular u theta base_mid + cp1 = dispParallel (-half_ulen) theta ubase_mid + cp2 = dispParallel half_ulen theta ubase_mid diff --git a/src/Wumpus/Drawing/Connectors/Base.hs b/src/Wumpus/Drawing/Connectors/Base.hs --- a/src/Wumpus/Drawing/Connectors/Base.hs +++ b/src/Wumpus/Drawing/Connectors/Base.hs @@ -18,16 +18,19 @@ ( Connector + + , ArrowTip(..) , ArrowConnector - , ArrowTip - , makeArrowTip , leftArrow , rightArrow , leftRightArrow , uniformArrow + + , rightArrowPath + - , promoteConn + , buildConn ) where @@ -39,91 +42,143 @@ import Data.AffineSpace -- package: vector-space - -import Control.Applicative - +import Data.Monoid -- | The type of Connectors - a query from start and end point to -- a Path. -- type Connector u = ConnectorQuery u (AbsPath u) +-- | Arrowhead /algorithm/ - the components of an arrowhead. +-- +-- Retract distance may have to account for line width. +-- +data ArrowTip = ArrowTip + { retract_distance :: Double -> En + , tip_half_len :: En + , tip_deco :: LocThetaGraphic En + } +-- Ideally there should be a plus operation to combine tips +-- allowing double tips. +-- type ArrowConnector u = ConnectorImage u (AbsPath u) -type TipDraw = Point2 En -> Radian -> GraphicAns En --- | TipAns - retract_distance * tip length * TipDraw --- -type TipAns u = (u, u, TipDraw) +runArrowTip :: InterpretUnit u => ArrowTip -> Query u (u, u, LocThetaGraphic u) +runArrowTip (ArrowTip df len deco) = + getLineWidth >>= \lw -> + uconvertCtx1 (df lw) >>= \uretd -> + uconvertCtx1 len >>= \ulen -> + return (uretd, ulen, uconvF deco) -data ArrowTip u = ArrowTip { getArrowTip :: CF (TipAns u) } +-- | Connector with an arrow tip at the end point (i.e right). +-- +rightArrow :: (Real u, Floating u, InterpretUnit u) + => ArrowTip -> Connector u -> ArrowConnector u +rightArrow alg conn = promoteConn $ \p0 p1 -> + zapConnectorQuery conn p0 p1 >>= \full_path -> + rightArrowPath alg full_path -- | Connector with an arrow tip at the start point (i.e left). -- leftArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip u -> Connector u -> ArrowConnector u -leftArrow tipl conn = promoteR2 $ \p0 p1 -> - apply2R2 conn p0 p1 >>= \full_path -> - getArrowTip tipl >>= \(dxl,wl,mkl) -> - uconvertCtxF p0 >>= \emp0 -> - let angl = tipDirectionL wl full_path - short_path = shortenL dxl full_path - deco = convertTipAns $ mkl emp0 angl - in fmap (replaceAns full_path) $ - decorateR0 deco $ toPrimPath short_path >>= openStroke - --- | Connector with an arrow tip at the end point (i.e right). --- -rightArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip u -> Connector u -> ArrowConnector u -rightArrow tipr conn = promoteR2 $ \p0 p1 -> - apply2R2 conn p0 p1 >>= \full_path -> - getArrowTip tipr >>= \(dxr,wr,mkl) -> - uconvertCtxF p1 >>= \emp1 -> - let angr = tipDirectionR wr full_path - short_path = shortenR dxr full_path - deco = convertTipAns $ mkl emp1 angr - in fmap (replaceAns full_path) $ - decorateR0 deco $ toPrimPath short_path >>= openStroke + => ArrowTip -> Connector u -> ArrowConnector u +leftArrow alg conn = promoteConn $ \p0 p1 -> + zapConnectorQuery conn p0 p1 >>= \full_path -> + leftArrowPath alg full_path --- | Connector with two arrow tips, possibly different. +-- | Connector with different arrow tips at the start point and +-- end points. -- leftRightArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip u -> ArrowTip u -> Connector u - -> ArrowConnector u -leftRightArrow tipl tipr conn = promoteR2 $ \p0 p1 -> - apply2R2 conn p0 p1 >>= \full_path -> - getArrowTip tipl >>= \(dxl,wl,mkl) -> - getArrowTip tipr >>= \(dxr,wr,mkr) -> - uconvertCtxF p0 >>= \emp0 -> - uconvertCtxF p1 >>= \emp1 -> - let angl = tipDirectionL wl full_path - angr = tipDirectionR wr full_path - short_path = shortenPath dxl dxr full_path - deco = convertTipAns $ mkl emp0 angl `oplus` mkr emp1 angr - in fmap (replaceAns full_path) $ - decorateR0 deco $ toPrimPath short_path >>= openStroke + => ArrowTip -> ArrowTip -> Connector u -> ArrowConnector u +leftRightArrow algl algr conn = promoteConn $ \p0 p1 -> + zapConnectorQuery conn p0 p1 >>= \full_path -> + leftRightArrowPath algl algr full_path --- | Connector with the same arrow tip at both ends. + +-- | Connector with the same arrow tip at the start point and +-- end points. -- uniformArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip u -> Connector u -> ArrowConnector u -uniformArrow utip conn = leftRightArrow utip utip conn + => ArrowTip -> Connector u -> ArrowConnector u +uniformArrow alg conn = promoteConn $ \p0 p1 -> + zapConnectorQuery conn p0 p1 >>= \full_path -> + leftRightArrowPath alg alg full_path +-- TODO - possible there are opportunities to be more +-- compositional here. -convertTipAns :: InterpretUnit u => GraphicAns En -> Graphic u -convertTipAns = uconvImageF . pure +-- | Path with an arrow tip at the start point (i.e left). +-- +-- TODO - shortening a curve does not seem to be working properly... +-- +-- +leftArrowPath :: (Real u, Floating u, InterpretUnit u) + => ArrowTip -> AbsPath u -> Image u (AbsPath u) +leftArrowPath alg full_path = + zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> + let short_path = if retract > 0 then shortenL retract full_path + else full_path + mid_ang = tipDirectionL len full_path + tip = applyLocTheta deco (tipL full_path) mid_ang + in replaceAns full_path $ + decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath + + + +-- | Path with an arrow tip at the end point (i.e right). +-- +-- TODO - shortening a curve does not seem to be working properly... +-- +-- +rightArrowPath :: (Real u, Floating u, InterpretUnit u) + => ArrowTip -> AbsPath u -> Image u (AbsPath u) +rightArrowPath alg full_path = + zapQuery (runArrowTip alg) >>= \(retract, len, deco) -> + let short_path = if retract > 0 then shortenR retract full_path + else full_path + mid_ang = tipDirectionR len full_path + tip = applyLocTheta deco (tipR full_path) mid_ang + in replaceAns full_path $ + decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath + + + + +-- | Path with an arrow tip at the end point (i.e right). +-- +-- TODO - shortening a curve does not seem to be working properly... +-- +-- +leftRightArrowPath :: (Real u, Floating u, InterpretUnit u) + => ArrowTip -> ArrowTip -> AbsPath u -> Image u (AbsPath u) +leftRightArrowPath algl algr full_path = + zapQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> + zapQuery (runArrowTip algr) >>= \(retractr, lenr, decor) -> + let short_path = shortenPath retractl retractr full_path + mid_angl = tipDirectionL lenl full_path + mid_angr = tipDirectionR lenr full_path + tipl = applyLocTheta decol (tipL full_path) mid_angl + tipr = applyLocTheta decor (tipR full_path) mid_angr + in replaceAns full_path $ + decorate (tipl `mappend` tipr) $ + zapQuery (toPrimPath short_path) >>= dcOpenPath + + + + -- | Helper - direction looks best at half the retract distance. -- tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian @@ -136,37 +191,28 @@ -makeArrowTip :: Query u -> Query u -> LocThetaGraphic En -> ArrowTip u -makeArrowTip retractq lengthq gf = ArrowTip body - where - body = drawingCtx >>= \ctx -> - let rdist = runCF ctx retractq - tlen = runCF ctx lengthq - drawf = runCF ctx gf - in return (rdist,tlen,drawf) - -- | Promote a function from source and dest points to a connector -- function accounting for the separator values in the -- DrawingContext. -- --- This should be used instead of @promoteR2@ for functions +-- This should be used instead of @promoteConn@ for functions -- building connectors. -- -promoteConn :: (Real u, Floating u, InterpretUnit u) - => (Point2 u -> Point2 u -> CF a) - -> CF (Point2 u -> Point2 u -> a) -promoteConn fn = promoteR2 $ \p0 p1 -> +buildConn :: (Real u, Floating u, InterpretUnit u) + => (Point2 u -> Point2 u -> Image u a) + -> ConnectorImage u a +buildConn fn = promoteConn $ \p0 p1 -> connectorSrcSpace >>= \sep0 -> connectorDstSpace >>= \sep1 -> connectorSrcOffset >>= \off0 -> connectorDstOffset >>= \off1 -> let ang = vdirection $ pvec p0 p1 - in fn (displacePerpendicular off0 ang $ p0 .+^ avec ang sep0) - (displacePerpendicular off1 ang $ p1 .-^ avec ang sep1) + in fn (dispPerpendicular off0 ang $ p0 .+^ avec ang sep0) + (dispPerpendicular off1 ang $ p1 .-^ avec ang sep1) -- --- CAUTION - promoteConn projects the spacers along the (straight) +-- CAUTION - buildConn projects the spacers along the (straight) -- connector line. This might not be what is wanted for jointed -- connectors. -- diff --git a/src/Wumpus/Drawing/Connectors/BoxConnectors.hs b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs --- a/src/Wumpus/Drawing/Connectors/BoxConnectors.hs +++ b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs @@ -54,12 +54,12 @@ -- connbox :: (Real u, Floating u, InterpretUnit u) => ConnectorBox u -connbox = promoteR2 $ \p0 p1 -> +connbox = promoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> let ang = vdirection $ pvec p0 p1 - bl = displaceOrtho (V2 (-src_arm) (-src_arm)) ang p0 - tl = displaceOrtho (V2 (-src_arm) src_arm ) ang p0 - br = displaceOrtho (V2 dst_arm (-src_arm)) ang p1 - tr = displaceOrtho (V2 dst_arm src_arm ) ang p1 - in vertexPP [ bl, br, tr, tl ] >>= closedStroke + bl = dispOrtho (V2 (-src_arm) (-src_arm)) ang p0 + tl = dispOrtho (V2 (-src_arm) src_arm ) ang p0 + br = dispOrtho (V2 dst_arm (-src_arm)) ang p1 + tr = dispOrtho (V2 dst_arm src_arm ) ang p1 + in zapQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE diff --git a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs --- a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +++ b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs @@ -51,7 +51,7 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Basic.Geometry.Quadrant -- package: wumpus-basic -import Wumpus.Basic.Kernel hiding ( promoteR2 ) +import Wumpus.Basic.Kernel hiding ( promoteConn ) import Wumpus.Core -- package: wumpus-core @@ -65,7 +65,7 @@ -- | Straight line connector. -- connline :: (Real u, Floating u, InterpretUnit u) => Connector u -connline = promoteConn $ \p0 p1 -> return $ line1 p0 p1 +connline = qpromoteConn $ \p0 p1 -> return $ line1 p0 p1 @@ -81,7 +81,7 @@ -- connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) => Connector u -connarc = promoteConn $ \p0 p1 -> +connarc = qpromoteConn $ \p0 p1 -> connectorArcAngle >>= \arc_ang -> let v1 = pvec p0 p1 hlen = 0.5 * vlength v1 @@ -104,7 +104,7 @@ -- connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connhdiagh = promoteConn $ \p0 p1 -> +connhdiagh = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of @@ -133,7 +133,7 @@ -- connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connvdiagv = promoteConn $ \p0 p1 -> +connvdiagv = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of @@ -161,7 +161,7 @@ -- conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -conndiagh = promoteConn $ \p0 p1 -> +conndiagh = qpromoteConn $ \p0 p1 -> connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> right p0 p1 dst_arm @@ -186,7 +186,7 @@ -- conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -conndiagv = promoteConn $ \p0 p1 -> +conndiagv = qpromoteConn $ \p0 p1 -> connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> up p0 p1 dst_arm @@ -211,7 +211,7 @@ -- connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connhdiag = promoteConn $ \p0 p1 -> +connhdiag = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> right p0 p1 src_arm @@ -236,7 +236,7 @@ -- connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connvdiag = promoteConn $ \p0 p1 -> +connvdiag = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> up p0 p1 src_arm @@ -263,12 +263,12 @@ -- connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connabar = promoteConn $ \p0 p1 -> +connabar = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> let ang = vdirection $ pvec p0 p1 - in return $ vertexPath [ p0, adisp_north src_arm ang p0 - , adisp_north dst_arm ang p1, p1 ] + in return $ vertexPath [ p0, dispDirectionTheta UP src_arm ang p0 + , dispDirectionTheta UP dst_arm ang p1, p1 ] -- | Bar connector. @@ -281,12 +281,12 @@ -- connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connbbar = promoteConn $ \p0 p1 -> +connbbar = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> let ang = vdirection $ pvec p0 p1 - in return $ vertexPath [ p0, adisp_south src_arm ang p0 - , adisp_south dst_arm ang p1, p1 ] + in return $ vertexPath [ p0, dispDirectionTheta DOWN src_arm ang p0 + , dispDirectionTheta DOWN dst_arm ang p1, p1 ] @@ -300,7 +300,7 @@ -- connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connaright = promoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> +connaright = qpromoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1] @@ -314,7 +314,7 @@ -- connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connbright = promoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> +connbright = qpromoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1] @@ -341,7 +341,7 @@ -- connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connhrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> +connhrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> fmap (directional x0 x1) connectorSrcArm >>= \ src_arm -> let a0 = p0 .+^ hvec src_arm a1 = a0 .+^ vvec (y1 - y0) @@ -361,7 +361,7 @@ -- connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connrrh = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> +connrrh = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> fmap (directional x0 x1) connectorDstArm >>= \ dst_arm -> let a1 = p1 .-^ hvec dst_arm a0 = a1 .-^ vvec (y1 - y0) @@ -378,7 +378,7 @@ -- connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connvrr = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> +connvrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> fmap (directional y0 y1) connectorSrcArm >>= \ src_arm -> let a0 = p0 .+^ vvec src_arm a1 = a0 .+^ hvec (x1 - x0) @@ -395,7 +395,7 @@ -- connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) => Connector u -connrrv = promoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> +connrrv = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> fmap (directional y0 y1) connectorDstArm >>= \ dst_arm -> let a1 = p1 .-^ vvec dst_arm a0 = a1 .-^ hvec (x1 - x0) @@ -432,15 +432,15 @@ -- loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u) => (u -> u) -> Connector u -loopbody fn = promoteConn $ \p0 p1 -> +loopbody fn = qpromoteConn $ \p0 p1 -> connectorSrcArm >>= \src_arm -> connectorDstArm >>= \dst_arm -> connectorLoopSize >>= \loop_len -> let ang = vdirection $ pvec p0 p1 - a0 = displaceParallel (negate src_arm) ang p0 - a1 = displacePerpendicular (fn loop_len) ang a0 - z0 = displaceParallel dst_arm ang p1 - z1 = displacePerpendicular (fn loop_len) ang z0 + a0 = dispParallel (negate src_arm) ang p0 + a1 = dispPerpendicular (fn loop_len) ang a0 + z0 = dispParallel dst_arm ang p1 + z1 = dispPerpendicular (fn loop_len) ang z0 in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ] -- | Bezier curve connector - the control points are positioned @@ -456,7 +456,7 @@ -- connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) => Connector u -connhbezier = promoteConn $ \p0 p1 -> +connhbezier = qpromoteConn $ \p0 p1 -> fmap (2*) connectorSrcArm >>= \src_arm -> fmap (2*) connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of @@ -483,7 +483,7 @@ -- connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) => Connector u -connvbezier = promoteConn $ \p0 p1 -> +connvbezier = qpromoteConn $ \p0 p1 -> fmap (2*) connectorSrcArm >>= \src_arm -> fmap (2*) connectorDstArm >>= \dst_arm -> case quadrant $ vdirection $ pvec p0 p1 of diff --git a/src/Wumpus/Drawing/Connectors/Loop.hs b/src/Wumpus/Drawing/Connectors/Loop.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Connectors/Loop.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Connectors.Loop --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Open loop for a circle (useful for automata diagrams). --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Connectors.Loop - ( - loop - , loopPoints - ) where - - -import Wumpus.Drawing.Paths.Absolute - -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Kernel -import Wumpus.Core -- package: wumpus-core - - -import Data.AffineSpace -- package: vector-space - - - --- | Note this has problems vis adding tips as the actual start --- and end points are synthesized. --- -loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => ConnectorQuery u (AbsPath u) -loop = promoteR2 $ \ctr radpt -> - let incl = lineDirection ctr radpt - radius = abs $ vlength $ pvec ctr radpt - ps = loopPoints radius ctr incl - in return $ curvePath ps - --- | Note - intermediate names and quadrants represent a loop --- drawn upwards. --- -loopPoints :: (Real u, Floating u) => u -> Point2 u -> Radian -> [Point2 u] -loopPoints circ_radius circ_ctr incl = - [ startl, cp1, cp2, kitel, cp3, cp4, top, cp5, cp6, kiter, cp7, cp8, startr ] - where - hw = 1.25 * circ_radius - height = 3.8 * circ_radius - hminor = 2.72 * circ_radius - hbase = circ_radius / 3 - theta = toRadian $ asin $ hbase / circ_radius - start_vec = avec (circularModulo $ incl - quarter_pi) (0.26 * circ_radius) - end_vec = avec (circularModulo $ incl + quarter_pi) (0.26 * circ_radius) - minor_down = negate $ 0.8 * circ_radius - major_up = 0.52 * circ_radius - top_right = negate $ 0.8 * circ_radius - top_left = 0.8 * circ_radius - - top = displaceParallel height incl circ_ctr - kiter = displaceOrtho (V2 hminor (-hw)) incl circ_ctr - kitel = displaceOrtho (V2 hminor (hw) ) incl circ_ctr - - startr = circ_ctr .+^ avec (circularModulo $ incl - theta) circ_radius - startl = circ_ctr .+^ avec (circularModulo $ incl + theta) circ_radius - - -- quadrant III - cp1 = startl .+^ end_vec - cp2 = displaceParallel minor_down incl kitel - - -- quadrant II - cp3 = displaceParallel major_up incl kitel - cp4 = displacePerpendicular top_left incl top - - -- quadrant I - cp5 = displacePerpendicular top_right incl top - cp6 = displaceParallel major_up incl kiter - - -- quadrant IV - cp7 = displaceParallel minor_down incl kiter - cp8 = startr .+^ start_vec diff --git a/src/Wumpus/Drawing/Dots/AnchorDots.hs b/src/Wumpus/Drawing/Dots/AnchorDots.hs --- a/src/Wumpus/Drawing/Dots/AnchorDots.hs +++ b/src/Wumpus/Drawing/Dots/AnchorDots.hs @@ -1,7 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -32,6 +29,14 @@ , DDotLocImage -- * Dots with anchor points + , smallDisk + , largeDisk + + , smallCirc + , largeCirc + + + , dotNone , dotChar , dotText , dotHLine @@ -58,13 +63,11 @@ ) where -import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Dots.SimpleDots ( MarkSize ) +import qualified Wumpus.Drawing.Dots.SimpleDots as SD import Wumpus.Drawing.Text.Base.RotTextZero -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Intersection -import Wumpus.Basic.Geometry.Paths -import Wumpus.Basic.Geometry.Quadrant +import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -74,17 +77,15 @@ import Control.Applicative --- An existential thing that supports anchors. --- This means any dot can retun the same (opaque) structure --- --- But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one. --- Supporting north, southeast etc. will also be tedious... + +-- | All dots return the same thing a 'DotAnchor' which supports +-- the same (limited) see of anchors. -- -data DotAnchor u = forall s. - DotAnchor { center_anchor :: Point2 u - , radial_anchor :: Radian -> Point2 u - , cardinal_anchor :: Cardinal -> Point2 u } +data DotAnchor u = DotAnchor + { center_anchor :: Point2 u + , radial_anchor :: Radian -> Point2 u + , cardinal_anchor :: Cardinal -> Point2 u + } type instance DUnit (DotAnchor u) = u @@ -144,16 +145,33 @@ polyCardinal f NORTH_WEST = f (0.75 * pi) +-- | All anchors are the center! +-- +zeroAnchor :: Point2 u -> DotAnchor u +zeroAnchor ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = const ctr + , cardinal_anchor = const ctr } + rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr = DotAnchor { center_anchor = ctr , radial_anchor = fn , cardinal_anchor = rectCardinal hw hh ctr } where - fn theta = displaceVec (rectRadialVector hw hh theta) ctr + fn theta = displace (rectRadialVector hw hh theta) ctr +circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u +circleAnchor rad ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = fn + , cardinal_anchor = radialCardinal rad ctr } + where + fn theta = displace (avec theta rad) ctr + + polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr = @@ -172,33 +190,41 @@ hh = 0.5 * (y2 - y1) in rectangleAnchor hw hh (bl .+^ vec hw hh) -rectangleLDO :: (Real u, Floating u) - => u -> u -> LocQuery u (DotAnchor u) -rectangleLDO w h = - promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt +zeroLDO :: LocQuery u (DotAnchor u) +zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u -circleAnchor rad ctr = DotAnchor ctr - (\theta -> ctr .+^ (avec theta rad)) - (radialCardinal rad ctr) +rectangleLDO :: (Real u, Floating u, InterpretUnit u) + => MarkSize -> MarkSize -> LocQuery u (DotAnchor u) +rectangleLDO w h = qpromoteLoc $ \pt -> + (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) + <$> uconvertCtx1 w <*> uconvertCtx1 h -circleLDO :: (Floating u, InterpretUnit u) => LocQuery u (DotAnchor u) -circleLDO = - promoteR1 $ \pt -> - markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt --- This might be better taking a function: ctr -> poly_points --- ... --- -polygonLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => (u -> Point2 u -> [Point2 u]) -> LocQuery u (DotAnchor u) -polygonLDO mk = - promoteR1 $ \ctr -> - markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr +circleLDO :: (Floating u, InterpretUnit u) + => MarkSize -> LocQuery u (DotAnchor u) +circleLDO rad = qpromoteLoc $ \pt -> + uconvertCtx1 rad >>= \urad -> pure $ circleAnchor urad pt +-- Probably better just using bounding circle for polygons +-- If you really care about anchors use shapes +-- + +-- Triangle probably benefits proper calculation... + +triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => MarkSize -> LocQuery u (DotAnchor u) +triangleLDO h = qpromoteLoc $ \pt -> + uconvertCtx1 h >>= \uh -> + let alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices uh + ps = runPathAlgPoint pt alg + in return $ polygonAnchor ps pt + where + fn3 (a,b,c) = [a,b,c] + + -------------------------------------------------------------------------------- @@ -206,6 +232,27 @@ type DDotLocImage = DotLocImage Double + +dotNone :: InterpretUnit u => DotLocImage u +dotNone = intoLocImage zeroLDO SD.dotNone + + + +smallDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u +smallDisk = intoLocImage (circleLDO 0.25) SD.smallDisk + + +largeDisk :: (Floating u, Real u, InterpretUnit u) => DotLocImage u +largeDisk = intoLocImage (circleLDO 1.00) SD.largeDisk + +smallCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u +smallCirc = intoLocImage (circleLDO 0.25) SD.smallCirc + + +largeCirc :: (Floating u, Real u, InterpretUnit u) => DotLocImage u +largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc + + dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u dotChar ch = dotText [ch] @@ -218,73 +265,77 @@ dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u -dotText ss = pushR1 (mapAns bboxRectAnchor) $ ccTextline ss +dotText ss = fmap bboxRectAnchor $ ccTextline ss -- Note - maybe Wumpus-Basic should have a @swapAns@ function? dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u -dotHLine = intoLocImage circleLDO markHLine +dotHLine = intoLocImage (circleLDO 0.5) SD.dotHLine dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u -dotVLine = intoLocImage circleLDO markVLine +dotVLine = intoLocImage (circleLDO 0.5) SD.dotVLine dotX :: (Floating u, InterpretUnit u) => DotLocImage u -dotX = intoLocImage circleLDO markX +dotX = intoLocImage (circleLDO 0.5) SD.dotX dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u -dotPlus = intoLocImage circleLDO markPlus +dotPlus = intoLocImage (circleLDO 0.5) SD.dotPlus dotCross :: (Floating u, InterpretUnit u) => DotLocImage u -dotCross = intoLocImage circleLDO markCross +dotCross = intoLocImage (circleLDO 0.5) SD.dotCross dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u -dotDiamond = intoLocImage circleLDO markDiamond +dotDiamond = intoLocImage (circleLDO 0.5) SD.dotDiamond dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u -dotFDiamond = intoLocImage circleLDO markFDiamond +dotFDiamond = intoLocImage (circleLDO 0.5) SD.dotFDiamond dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u -dotDisk = intoLocImage circleLDO markDisk +dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u -dotSquare = - markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare +dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u -dotCircle = intoLocImage circleLDO markCircle +dotCircle = intoLocImage (circleLDO 0.5) SD.dotCircle dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u -dotPentagon = intoLocImage circleLDO markPentagon +dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon dotStar :: (Floating u, InterpretUnit u) => DotLocImage u -dotStar = intoLocImage circleLDO markStar +dotStar = intoLocImage (circleLDO 0.5) SD.dotStar dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u -dotAsterisk = intoLocImage circleLDO markAsterisk +dotAsterisk = intoLocImage (circleLDO 0.5) SD.dotAsterisk dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u -dotOPlus = intoLocImage circleLDO markOPlus +dotOPlus = intoLocImage (circleLDO 0.5) SD.dotOPlus dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u -dotOCross = intoLocImage circleLDO markOCross +dotOCross = intoLocImage (circleLDO 0.5) SD.dotOCross dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u -dotFOCross = intoLocImage circleLDO markFOCross +dotFOCross = intoLocImage (circleLDO 0.5) SD.dotFOCross dotTriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => DotLocImage u -dotTriangle = intoLocImage (polygonLDO fn) markTriangle - where - fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top] +dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle + + +intoLocImage :: LocQuery u a -> LocImage u z -> LocImage u a +intoLocImage mq gf = promoteLoc $ \pt -> + askDC >>= \ctx -> + let ans = runLocQuery pt ctx mq + in replaceAns ans $ applyLoc gf pt diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Dots/Marks.hs +++ /dev/null @@ -1,242 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Dots.Marks --- Copyright : (c) Stephen Tetley 2010-2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Marks - dots without anchor handles. --- --- The text and char marks need loaded glyph metrics for proper --- centering. --- --- \*\* WARNING \*\* - names are expected to change - filled and --- background-filled marks need a naming convention. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Dots.Marks - ( - - - -- * Marks - markChar - , markText - - , markHLine - , markVLine - , markX - , markPlus - , markCross - , markDiamond - , markFDiamond - , markBDiamond - , markDisk - , markSquare - , markCircle - , markPentagon - , markStar - , markAsterisk - , markOPlus - , markOCross - , markFOCross - , markTriangle - - ) where - - -import Wumpus.Drawing.Text.Base.RotTextZero - -import Wumpus.Basic.Geometry.Paths -- package: wumpus-basic -import Wumpus.Basic.Kernel - -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* --- - - - - -infixr 9 `renderPathWith` - -renderPathWith :: LocQuery u PrimPath - -> (PrimPath -> Graphic u) - -> LocGraphic u -renderPathWith qy mk = promoteR1 $ \pt -> apply1R1 qy pt >>= mk - - - -markChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u -markChar ch = markText [ch] - - - - -markText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u -markText ss = pushR1 ignoreAns $ ccTextline ss - - - - --- | Supplied point is the center. --- -axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u -axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (locStraightLine v) - - -markHLine :: (Fractional u, InterpretUnit u) => LocGraphic u -markHLine = markHeight >>= \h -> axialLine (hvec h) - - -markVLine :: (Fractional u, InterpretUnit u) => LocGraphic u -markVLine = markHeight >>= \h -> axialLine (vvec h) - - -markX :: (Fractional u, InterpretUnit u) => LocGraphic u -markX = markHeight >>= mkX - where - mkX h = let w = 0.75 * h - in axialLine (vec w h) `oplus` axialLine (vec (-w) h) - - - -markPlus :: (Fractional u, InterpretUnit u) => LocGraphic u -markPlus = markVLine `oplus` markHLine - - -markCross :: (Floating u, InterpretUnit u) => LocGraphic u -markCross = markHeight >>= mkCross - where - mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h) - ang = pi*0.25 - --- Note - height is extended slightly to look good... - -pathDiamond :: (Fractional u, InterpretUnit u) - => LocQuery u PrimPath -pathDiamond = promoteR1 $ \pt -> - markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) - in coordinatePrimPath cp pt - - - --- closedStroke :: (a -> ctx -> prim) --- pathDiamond :: (ctx -> pt -> a) --- ans :: (ctx -> pt -> prim) - -markDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -markDiamond = pathDiamond `renderPathWith` closedStroke - -markFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -markFDiamond = pathDiamond `renderPathWith` filledPath - - --- Note - the (const . fn) composition doesn\'t /tell/ much about --- what is going on - though obviously it can be decoded - make --- the function obvious to the second argument. --- --- A named combinator might be better. --- - -markBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -markBDiamond = pathDiamond `renderPathWith` borderedPath - - --- | Note disk is filled. --- -markDisk :: (Fractional u, InterpretUnit u) => LocGraphic u -markDisk = markHalfHeight >>= filledDisk - - - -markSquare :: (Fractional u, InterpretUnit u) => LocGraphic u -markSquare = - markHeight >>= \h -> - let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h - - - -markCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -markCircle = markHalfHeight >>= strokedDisk - - -markBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -markBCircle = markHalfHeight >>= borderedDisk - - - -markPentagon :: (Floating u, InterpretUnit u) => LocGraphic u -markPentagon = promoteR1 $ \pt -> - pentagonPath pt >>= closedStroke - where - pentagonPath pt = markHalfHeight >>= \hh -> - coordinatePrimPath (polygonCoordPath 5 hh) pt - - - - -markStar :: (Floating u, InterpretUnit u) => LocGraphic u -markStar = markHeight >>= \h -> starLines (0.5*h) - -starLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u -starLines hh = promoteR1 $ \ctr -> - let cp = polygonCoordPath 5 hh - in step $ map (fn ctr) $ cp ctr - where - fn p0 p1 = straightLine p0 p1 - step (x:xs) = oconcat x xs - step _ = error "starLines - unreachable" - - -markAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u -markAsterisk = markHeight >>= asteriskLines - -asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u -asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3 - where - ang = (pi*2) / 6 - lineF1 = axialLine (vvec h) - lineF2 = axialLine (avec ((pi*0.5) + ang) h) - lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h) - - -markOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u -markOPlus = markCircle `oplus` markPlus - - -markOCross :: (Floating u, InterpretUnit u) => LocGraphic u -markOCross = markCircle `oplus` markCross - - -markFOCross :: (Floating u, InterpretUnit u) => LocGraphic u -markFOCross = markCross `oplus` markBCircle - - --- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u --- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) - - - -markTriangle :: (Floating u, InterpretUnit u) => LocGraphic u -markTriangle = tripath `renderPathWith` closedStroke - where - tripath = promoteR1 $ \pt -> - markHeight >>= \h -> - let cp = equilateralTriangleCoordPath h - in coordinatePrimPath cp pt - diff --git a/src/Wumpus/Drawing/Dots/SimpleDots.hs b/src/Wumpus/Drawing/Dots/SimpleDots.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Dots/SimpleDots.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Dots.SimpleDots +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Simple dots - no anchor handles. +-- +-- Use these where you just want to draw Dots, and do not need +-- connectors between them. +-- +-- The text and char marks need loaded glyph metrics for proper +-- centering. +-- +-- \*\* WARNING \*\* - names are expected to change - filled and +-- background-filled marks need a naming convention. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Dots.SimpleDots + ( + + -- * Unit for marks (0.75 the font size) + MarkSize + + , smallDisk + , largeDisk + , smallCirc + , largeCirc + + + + -- * Dots + , dotNone + + , dotChar + , dotText + + , dotHLine + , dotVLine + , dotX + , dotPlus + , dotCross + , dotDiamond + , dotFDiamond + , dotBDiamond + , dotDisk + , dotSquare + , dotCircle + , dotPentagon + , dotStar + , dotAsterisk + , dotOPlus + , dotOCross + , dotFOCross + , dotTriangle + + ) where + + +import Wumpus.Drawing.Text.Base.RotTextZero + +import Wumpus.Basic.Geometry -- package: wumpus-basic +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import Data.VectorSpace -- package: vector-space + +import Data.Monoid + +-- 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* +-- + +-- Cap height is a good size for Dots. + + +-- | MarkUnit is a contextual unit like 'Em' and 'En'. +-- +-- It is 3\/4 of the current font size. +-- +newtype MarkSize = MarkSize { getMarkSize :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + +instance Show MarkSize where + showsPrec p d = showsPrec p (getMarkSize d) + + +instance InterpretUnit MarkSize where + normalize sz a = (realToFrac a) * 0.75 * fromIntegral sz + dinterp sz d = (4/3) * (realToFrac d) / (fromIntegral sz) + + +umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u +umark = uconvF + + +-- | Filled disk - radius 0.25 MarkSize. +-- +smallDisk :: InterpretUnit u => LocGraphic u +smallDisk = umark $ dcDisk FILL 0.25 + + +-- | Filled disk - radius 1.0 MarkSize. +-- +largeDisk :: InterpretUnit u => LocGraphic u +largeDisk = umark $ dcDisk FILL 1 + + +-- | Stroked disk (circle) - radius 0.25 MarkSize. +-- +smallCirc :: InterpretUnit u => LocGraphic u +smallCirc = umark $ dcDisk STROKE 0.25 + + +-- | Stroked disk (circle) - radius 1.0 MarkSize. +-- +largeCirc :: InterpretUnit u => LocGraphic u +largeCirc = umark $ dcDisk STROKE 1 + + +-- possibly: +-- szCirc :: u -> LocGraphic u + +dotNone :: InterpretUnit u => LocGraphic u +dotNone = emptyLocImage + +dotChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u +dotChar ch = dotText [ch] + + + +dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u +dotText ss = ignoreAns $ ccTextline ss + + + + +-- | Supplied point is the center. +-- +axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u +axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v) + + +dotHLine :: (Fractional u, InterpretUnit u) => LocGraphic u +dotHLine = umark $ axialLine (hvec 1) + + +dotVLine :: (Fractional u, InterpretUnit u) => LocGraphic u +dotVLine = umark $ axialLine (vvec 1) + + +dotX :: (Fractional u, InterpretUnit u) => LocGraphic u +dotX = umark $ axialLine (vec 0.75 1) `mappend` axialLine (vec (-0.75) 1) + + + +dotPlus :: (Fractional u, InterpretUnit u) => LocGraphic u +dotPlus = dotVLine `mappend` dotHLine + + +dotCross :: (Floating u, InterpretUnit u) => LocGraphic u +dotCross = + umark $ axialLine (avec ang 1) `mappend` axialLine (avec (-ang) 1) + where + ang = pi*0.25 + + + + + +dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u +dotDiamond = umark $ drawVertexPathAlg STROKE (diamondPathAlg 0.5 0.66) + +dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u +dotFDiamond = umark $ drawVertexPathAlg FILL (diamondPathAlg 0.5 0.66) + + + +dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u +dotBDiamond = umark $ drawVertexPathAlg FILL_STROKE (diamondPathAlg 0.5 0.66) + + +-- | Note disk is filled. +-- +dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u +dotDisk = umark $ dcDisk FILL 0.5 + + + +dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u +dotSquare = umark $ drawVertexPathAlg STROKE (rectanglePathAlg 1 1) + + +dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u +dotCircle = umark $ dcDisk STROKE 0.5 + + +dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u +dotBCircle = umark $ dcDisk FILL_STROKE 0.5 + + + +dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u +dotPentagon = umark $ drawVertexPathAlg STROKE (polygonPathAlg 5 0.5) + + + +dotStar :: (Floating u, InterpretUnit u) => LocGraphic u +dotStar = umark $ starLines 0.5 + +starLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u +starLines hh = promoteLoc $ \ctr -> + let ps = runPathAlgPoint ctr $ polygonPathAlg 5 hh + in step $ map (fn ctr) ps + where + fn p0 p1 = straightLine p0 p1 + step (x:xs) = mconcat $ x:xs + step _ = error "starLines - unreachable" + + +dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u +dotAsterisk = umark $ asteriskLines 1 + +asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u +asteriskLines h = lineF1 `mappend` lineF2 `mappend` lineF3 + where + ang = (pi*2) / 6 + lineF1 = axialLine (vvec h) + lineF2 = axialLine (avec ((pi*0.5) + ang) h) + lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h) + + +dotOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u +dotOPlus = dotCircle `mappend` dotPlus + + +dotOCross :: (Floating u, InterpretUnit u) => LocGraphic u +dotOCross = dotCircle `mappend` dotCross + + +dotFOCross :: (Floating u, InterpretUnit u) => LocGraphic u +dotFOCross = dotBCircle `mappend` dotCross + + +-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u +-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) + + + +dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u +dotTriangle = umark $ drawVertexPathAlg STROKE alg + where + alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices 1 + fn3 = \(a,b,c) -> [a,b,c] diff --git a/src/Wumpus/Drawing/Extras/Axes.hs b/src/Wumpus/Drawing/Extras/Axes.hs --- a/src/Wumpus/Drawing/Extras/Axes.hs +++ b/src/Wumpus/Drawing/Extras/Axes.hs @@ -26,24 +26,23 @@ import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core +import Data.Monoid -- Note - axes need labels working out... --- | Draw axes from (0,0). +-- | Simple orthonormal axes using snap grid units. -- orthontAxes :: (Real u, Floating u, InterpretUnit u) - => (Double, Double) -> Graphic u -orthontAxes (w,h) = - snapmove (1,1) >>= \(V2 w1 h1) -> + => (Int,Int) -> (Int,Int) -> LocGraphic u +orthontAxes (xl,xr) (yl,yr) = + promoteLoc $ \(P2 x y) -> + snapmove (1,1) >>= \(V2 uw uh) -> let conn1 = rightArrow barb45 connline - uw = w1 * realToFrac w - uh = h1 * realToFrac h - ptX = displaceH uw zeroPt - ptY = displaceV uh zeroPt - in localize cap_square $ graphic_ (connect conn1 zeroPt ptX) - `oplus` graphic_ (connect conn1 zeroPt ptY) - + xPtl = P2 (x - (uw * fromIntegral xl)) y + xPtr = P2 (x + (uw * fromIntegral xr)) y + yPtl = P2 x (y - (uh * fromIntegral yl)) + yPtr = P2 x (y + (uh * fromIntegral yr)) + in localize cap_square $ ignoreAns (connect xPtl xPtr conn1) + `mappend` ignoreAns (connect yPtl yPtr conn1) - - diff --git a/src/Wumpus/Drawing/Extras/Clip.hs b/src/Wumpus/Drawing/Extras/Clip.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Clip.hs @@ -0,0 +1,41 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Extras.Clip +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Clipping paths. +-- +-- Note - at the moment there is nothing much to this module. +-- Ideally, clipping would be defined in Wumpus-Basic, but clipping +-- needs a higher level path object than Wumpus-Basic provides. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Extras.Clip + ( + + locClip + + ) where + + +import Wumpus.Drawing.Paths.Relative + +import Wumpus.Basic.Kernel -- package: wumpus-basic + + + + +-- | Clip a LocGraphic. +-- +locClip :: InterpretUnit u => RelPath u -> LocGraphic u -> LocGraphic u +locClip rp gf = promoteLoc $ \pt -> + zapQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt) + diff --git a/src/Wumpus/Drawing/Extras/Grids.hs b/src/Wumpus/Drawing/Extras/Grids.hs --- a/src/Wumpus/Drawing/Extras/Grids.hs +++ b/src/Wumpus/Drawing/Extras/Grids.hs @@ -20,6 +20,8 @@ GridContextF , grid , standard_grid + , dotted_major_grid + , grid_major_colour , grid_major_line_width , grid_major_dotnum @@ -33,11 +35,14 @@ ) where +import Wumpus.Drawing.Basis.DrawingPrimitives +import Wumpus.Drawing.Basis.LocTrace + import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Wumpus.Core.Colour ( black ) - +import Data.Monoid type GridContextF = GridProps -> GridProps @@ -74,18 +79,16 @@ -grid :: (Fractional u, InterpretUnit u) - => GridContextF -> (Int,Int) -> (Int,Int) -> Graphic u -grid upd bl tr = go (upd default_grid_props) - where - go props | gp_minor_subdivs props < 1 = gridMajor bl tr props - | otherwise = gridMinor bl tr props `oplus` gridMajor bl tr props - - standard_grid :: GridContextF standard_grid = id +dotted_major_grid :: GridContextF +dotted_major_grid = + grid_minor_subdivisions 0 . grid_major_dotnum 2 + +-- Setters for client code. + grid_major_colour :: RGBi -> GridContextF grid_major_colour rgb = (\s -> s { gp_major_colour = rgb }) @@ -96,7 +99,7 @@ grid_major_dotnum n = (\s -> s { gp_major_dotnum = n }) grid_minor_subdivisions :: Int -> GridContextF -grid_minor_subdivisions n = (\s -> s { gp_major_dotnum = n }) +grid_minor_subdivisions n = (\s -> s { gp_minor_subdivs = n }) grid_minor_colour :: RGBi -> GridContextF grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb }) @@ -117,28 +120,20 @@ --------------------------------------------------------------------------------- - - -gridMinor :: (Fractional u, InterpretUnit u) - => (Int,Int) -> (Int,Int) -> GridProps -> Graphic u -gridMinor bl tr props = - let mi = minorInterior bl tr (gp_minor_subdivs props) - minF = lineProps (gp_minor_colour props) (gp_minor_lnwidth props) - (gp_minor_dotnum props) - in localize minF mi - -gridMajor :: (Fractional u, InterpretUnit u) - => (Int,Int) -> (Int,Int) -> GridProps -> Graphic u -gridMajor bl tr props = - let mj = majorInterior bl tr - outer = outerRect bl tr - majF = lineProps (gp_major_colour props) (gp_major_lnwidth props) - (gp_major_dotnum props) - in localize majF (mj `oplus` outer) +-- Drawing context updaters... +major_line_update :: GridProps -> DrawingContextF +major_line_update (GridProps { gp_major_colour = rgb + , gp_major_lnwidth = lnwidth + , gp_major_dotnum = dotnum }) = + lineProps rgb lnwidth dotnum +minor_line_update :: GridProps -> DrawingContextF +minor_line_update (GridProps { gp_minor_colour = rgb + , gp_minor_lnwidth = lnwidth + , gp_minor_dotnum = dotnum }) = + lineProps rgb lnwidth dotnum lineProps :: RGBi -> Double -> Int -> DrawingContextF @@ -149,81 +144,67 @@ dashesF = set_dash_pattern $ Dash 0 [(1,n)] --- | Coordinates are expected to be normalized. --- -outerRect :: (Fractional u, InterpretUnit u) - => (Int,Int) -> (Int,Int) -> Graphic u -outerRect cbl@(xmin,ymin) (xmaj,ymaj) = - snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) -> - position cbl >>= \bl -> - strokedRectangle uw uh `at` bl +-------------------------------------------------------------------------------- --- | The major interior is the snap grid. --- -majorInterior :: (Fractional u, InterpretUnit u) - => (Int,Int) -> (Int,Int) -> Graphic u -majorInterior cbl@(xmin,ymin) (xmaj,ymaj) = - snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) -> - snapmove (1,1) >>= \(V2 w1 h1) -> - position cbl >>= \bl -> - let xcount = sub1 (xmaj - xmin) - ycount = sub1 (ymaj - ymin) - hlines = chainlike ycount (displaceV h1) (hline uw) - vlines = chainlike xcount (displaceH w1) (vline uh) - in (apply1R1 hlines $ displaceV h1 bl) - `oplus` (apply1R1 vlines $ displaceH w1 bl) +grid :: (Fractional u, InterpretUnit u) + => GridContextF -> Int -> Int -> LocGraphic u +grid upd nx ny = + snapmove (1,1) >>= \(V2 uw uh) -> + let props = upd default_grid_props + width = uw * fromIntegral nx + height = uh * fromIntegral ny + intrr = gridInterior nx width uw ny height uh props + rect = localize (major_line_update props) $ + blRectangle STROKE width height + in intrr `mappend` rect + +gridInterior :: (Fractional u, InterpretUnit u) + => Int -> u -> u -> Int -> u -> u -> GridProps -> LocGraphic u +gridInterior nx w uw ny h uh props = hlines `mappend` vlines + where + hlines = horizontalLines ny w uh props + vlines = verticalLines nx h uw props --- | The minor interior divides each element of the snap grid. --- -minorInterior :: (Fractional u, InterpretUnit u) - => (Int,Int) -> (Int,Int) -> Int -> Graphic u -minorInterior cbl@(xmin,ymin) (xmaj,ymaj) scount = - snapmove (xmaj-xmin, ymaj-ymin) >>= \(V2 uw uh) -> - snapmove (1,1) >>= \(V2 w1 h1) -> - position cbl >>= \bl -> - let xcount = xmaj - xmin - ycount = ymaj - ymin - subw1 = w1 / fromIntegral scount - subh1 = h1 / fromIntegral scount - hlines1 = moveStart (displaceV subh1) - $ chainlike (scount-1) (displaceV subh1) (hline uw) +horizontalLines :: (Fractional u, InterpretUnit u) + => Int -> u -> u -> GridProps -> LocGraphic u +horizontalLines numh w uh props@(GridProps { gp_minor_subdivs = subs }) + | subs > 0 = let dy = uh / (fromIntegral subs) + n = (numh * subs) - 1 + in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr + | otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr + where + mnr = localize (minor_line_update props) $ hline w + mjr = localize (major_line_update props) $ hline w - vlines1 = moveStart (displaceH subw1) - $ chainlike (scount-1) (displaceH subw1) (vline uh) - hlines = chainlike ycount (displaceV h1) hlines1 - vlines = chainlike xcount (displaceH w1) vlines1 - in (apply1R1 hlines bl) - `oplus` (apply1R1 vlines bl) --- This doesn\'t work as an advGraphic - - --- | This is an operation chain should support, but chain needs a --- rethink... --- -chainlike :: Int -> PointDisplace u -> LocGraphic u -> LocGraphic u -chainlike i mv g = promoteR1 $ \start -> go (i-1) (g `at` start) (mv start) +verticalLines :: (Fractional u, InterpretUnit u) + => Int -> u -> u -> GridProps -> LocGraphic u +verticalLines numv h uw props@(GridProps { gp_minor_subdivs = subs }) + | subs > 0 = let dx = uw / (fromIntegral subs) + n = (numv * subs) - 1 + in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr + | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr where - go n acc pt | n < 1 = acc - | otherwise = go (n-1) (acc `oplus` (g `at` pt)) (mv pt) - + mnr = localize (minor_line_update props) $ vline h + mjr = localize (major_line_update props) $ vline h -vline :: InterpretUnit u => u -> LocGraphic u -vline len = locStraightLine $ vvec len -hline :: InterpretUnit u => u -> LocGraphic u -hline len = locStraightLine $ hvec len - - -sub1 :: Num u => u -> u -sub1 = subtract 1 +minorMajor :: Num u + => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u + -> LocGraphic u +minorMajor count alt mv mnr mjr = execLocTrace (step count) + where + step n | n <= 0 = return () + | n `mod` alt == 0 = insertl mjr >> moveBy mv >> step (n-1) + | otherwise = insertl mnr >> moveBy mv >> step (n-1) + diff --git a/src/Wumpus/Drawing/Extras/Loop.hs b/src/Wumpus/Drawing/Extras/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Loop.hs @@ -0,0 +1,95 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Extras.Loop +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Open loop for a circle (useful for automata diagrams). +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Extras.Loop + ( + loop + , loopPoints + ) where + + +import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Geometry.Base -- package: wumpus-basic +import Wumpus.Basic.Kernel +import Wumpus.Core -- package: wumpus-core + + +import Data.AffineSpace -- package: vector-space + + +-- TODO - Loop is a decoration not a connector. +-- It should probably have the same signature as wedge / arc. + +-- | Generate a loop - suitable for decorating a circle. +-- +-- The radius and the (implicit) start point are the center and +-- radius of the initial circle not the loop itself. +-- +loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Point2 u -> Radian -> Query u (AbsPath u) +loop zradius zctr ang = return $ curvePath $ loopPoints zradius zctr ang + + + +-- Should be able to use trig to get a loop suitable for +-- decorating rectangles (provided the start-to-end arc is smaller +-- than the side length + + + + +-- | Note - intermediate names and quadrants represent a loop +-- drawn upwards. +-- +loopPoints :: (Real u, Floating u) => u -> Point2 u -> Radian -> [Point2 u] +loopPoints circ_radius circ_ctr incl = + [ startl, cp1, cp2, kitel, cp3, cp4, top, cp5, cp6, kiter, cp7, cp8, startr ] + where + hw = 1.25 * circ_radius + height = 3.8 * circ_radius + hminor = 2.72 * circ_radius + hbase = circ_radius / 3 + theta = toRadian $ asin $ hbase / circ_radius + start_vec = avec (circularModulo $ incl - quarter_pi) (0.26 * circ_radius) + end_vec = avec (circularModulo $ incl + quarter_pi) (0.26 * circ_radius) + minor_down = negate $ 0.8 * circ_radius + major_up = 0.52 * circ_radius + top_right = negate $ 0.8 * circ_radius + top_left = 0.8 * circ_radius + + top = dispParallel height incl circ_ctr + kiter = dispOrtho (V2 hminor (-hw)) incl circ_ctr + kitel = dispOrtho (V2 hminor (hw) ) incl circ_ctr + + startr = circ_ctr .+^ avec (circularModulo $ incl - theta) circ_radius + startl = circ_ctr .+^ avec (circularModulo $ incl + theta) circ_radius + + -- quadrant III + cp1 = startl .+^ end_vec + cp2 = dispParallel minor_down incl kitel + + -- quadrant II + cp3 = dispParallel major_up incl kitel + cp4 = dispPerpendicular top_left incl top + + -- quadrant I + cp5 = dispPerpendicular top_right incl top + cp6 = dispParallel major_up incl kiter + + -- quadrant IV + cp7 = dispParallel minor_down incl kiter + cp8 = startr .+^ start_vec diff --git a/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Extras.Turtle.TurtleClass --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad and monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"coordinate-free\" style of drawing, some types of diagram --- are more easily expressed in the LOGO style. --- --- Note - as turtle drawing with Wumpus is a /local effect/, --- there is only one instance of TurtleM. Potentially TurtleM --- will be removed and the functions implemented directly. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Extras.Turtle.TurtleClass - ( - - Coord - - , TurtleM(..) - - , setsLoc - , setsLoc_ - - -- * movement - , resetLoc - , moveLeft - , moveRight - , moveUp - , moveDown - , nextLine - - - ) where - - - -type Coord = (Int,Int) - - -class Monad m => TurtleM m where - getLoc :: m (Int,Int) - setLoc :: (Int,Int) -> m () - getOrigin :: m (Int,Int) - setOrigin :: (Int,Int) -> m () - - - -setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a -setsLoc f = getLoc >>= \coord -> - let (a,coord') = f coord in setLoc coord' >> return a - -setsLoc_ :: TurtleM m => (Coord -> Coord) -> m () -setsLoc_ f = getLoc >>= \coord -> setLoc (f coord) - - -resetLoc :: TurtleM m => m () -resetLoc = getOrigin >>= setLoc - - -moveRight :: TurtleM m => m () -moveRight = setsLoc_ $ \(x,y)-> (x+1, y) - - -moveLeft :: TurtleM m => m () -moveLeft = setsLoc_ $ \(x,y) -> (x-1,y) - -moveUp :: TurtleM m => m () -moveUp = setsLoc_ $ \(x,y) -> (x,y+1) - -moveDown :: TurtleM m => m () -moveDown = setsLoc_ $ \(x,y) -> (x ,y-1) - - -nextLine :: TurtleM m => m () -nextLine = getOrigin >>= \(ox,_) -> - setsLoc_ $ \(_,y) -> (ox,y-1) - diff --git a/src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Extras.Turtle.TurtleMonad --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"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.Drawing.Extras.Turtle.TurtleMonad - ( - -- * Re-exports - module Wumpus.Drawing.Extras.Turtle.TurtleClass - - -- * Turtle transformer - , TurtleT - , runTurtleT - - - ) where - -import Wumpus.Drawing.Extras.Turtle.TurtleClass - -import Wumpus.Basic.Kernel -- package: wumpus-basic - - -import Control.Applicative -import Control.Monad - - --- Note - if Turtle is now just a /local effect/ monad is the --- Turtle class still needed? Afterall, there is (probably) --- only ever going to be one instance. --- - --- Turtle is a Reader / State monad --- --- The env is the horizontal and vertical move distances. --- --- The state is the current coordinate and the origin. --- - -data TurtleState = TurtleState - { _turtle_origin :: (Int,Int) - , _current_coord :: (Int,Int) - } - -newtype TurtleT u m a = TurtleT { - getTurtleT :: TurtleState -> m (a, TurtleState) } - - -type instance MonUnit (TurtleT u m a) = u - --- Functor - - - -instance Monad m => Functor (TurtleT u m) where - fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> - return (f a, s') - - --- Applicative - -instance Monad m => Applicative (TurtleT u m) where - pure a = TurtleT $ \s -> return (a,s) - mf <*> ma = TurtleT $ \s -> getTurtleT mf s >>= \(f,s') -> - getTurtleT ma s' >>= \(a,s'') -> - return (f a,s'') - - --- Monad - -instance Monad m => Monad (TurtleT u m) where - return a = TurtleT $ \s -> return (a,s) - m >>= k = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> - (getTurtleT . k) a 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) - getOrigin = TurtleT $ \s@(TurtleState o _) -> return (o,s) - setOrigin o = TurtleT $ \(TurtleState _ c) -> return ((),TurtleState o c) - - -runTurtleT :: (Monad m, Num u) - => (Int,Int) -> TurtleT u m a -> m a -runTurtleT ogin mf = getTurtleT mf st0 >>= \(a,_) -> return a - where - st0 = TurtleState ogin ogin - - - ----------------------------------------------------------------------------------- --- Cross instances - -instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where - askDC = TurtleT $ \s -> askDC >>= \ ctx -> return (ctx,s) - localize upd mf = TurtleT $ \s -> localize upd (getTurtleT mf s) - - --- This needs undecidable instances... - -instance (Monad m, TraceM m, u ~ MonUnit (m ()) ) => TraceM (TurtleT u m) where - trace a = TurtleT $ \s -> trace a >> return ((),s) - fontDelta mf = TurtleT $ \s -> fontDelta $ getTurtleT mf s - - diff --git a/src/Wumpus/Drawing/Paths/Absolute.hs b/src/Wumpus/Drawing/Paths/Absolute.hs --- a/src/Wumpus/Drawing/Paths/Absolute.hs +++ b/src/Wumpus/Drawing/Paths/Absolute.hs @@ -18,11 +18,11 @@ module Wumpus.Drawing.Paths.Absolute ( - module Wumpus.Drawing.Paths.Base.AbsBuilder - , module Wumpus.Drawing.Paths.Base.AbsPath + module Wumpus.Drawing.Paths.Base.AbsPath + , module Wumpus.Drawing.Paths.Base.PathBuilder ) where -import Wumpus.Drawing.Paths.Base.AbsBuilder import Wumpus.Drawing.Paths.Base.AbsPath +import Wumpus.Drawing.Paths.Base.PathBuilder diff --git a/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs b/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs +++ /dev/null @@ -1,561 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Base.AbsBuilder --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Build absolute paths monadically. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Base.AbsBuilder - ( - - AbsBuild - , runAbsBuild - , execAbsBuild - , evalAbsBuild - - , tip - - , absline - , abscurve - , absmove - - , relline - , relcurve - , relmove - - , rellineParallel - , rellinePerpendicular - - , relmoveParallel - , relmovePerpendicular - - - - , ctrlcurve - - , insert - , vamp - , cycle - , setIncline - - -- * Derived operators - , pen_colour - , pen_width - - , hline - , vline - , aline - - , hmove - , vmove - , amove - - , line_up - , line_down - , line_left - , line_right - - , line_up_left - , line_up_right - , line_down_left - , line_down_right - - , line_north - , line_south - , line_east - , line_west - , line_northeast - , line_northwest - , line_southeast - , line_southwest - - , move_up - , move_down - , move_left - , move_right - - , move_up_left - , move_up_right - , move_down_left - , move_down_right - - , move_north - , move_south - , move_east - , move_west - , move_northeast - , move_northwest - , move_southeast - , move_southwest - - - ) where - -import Wumpus.Drawing.Paths.Base.AbsPath -import qualified Wumpus.Drawing.Paths.Base.AbsPath as A -import Wumpus.Drawing.Paths.Base.BuildCommon -import qualified Wumpus.Drawing.Paths.Base.RelPath as R - - -import Wumpus.Basic.Geometry ( half_pi ) -- package: wumpus-basic -import Wumpus.Basic.Kernel - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - -import Control.Applicative hiding ( empty ) -import Data.Monoid - -import Prelude hiding ( log, cycle ) - - - --- State monad building is quite good - it ameliorates the problem --- of joining to the end point of an empty path... - -data St u = St - { current_point :: Point2 u - , current_incline :: Radian - , cumulative_path :: AbsPath u - , active_path :: (Point2 u, AbsPath u) - , pen_dc_modifier :: DrawingContextF - } - -type instance DUnit (St u) = u - -type Log u = BuildLog (Graphic u) - - --- | Absolute Path builder monad. --- -newtype AbsBuild u a = AbsBuild { - getAbsBuild :: St u -> (a, St u, Log u) } - -type instance DUnit (AbsBuild u a) = u - - --------------------------------------------------------------------------------- --- instances - - - -instance Functor (AbsBuild u) where - fmap f mf = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild mf s0 - in (f a, s1, w1) - - -instance Applicative (AbsBuild u) where - pure a = AbsBuild $ \s0 -> (a,s0,mempty) - mf <*> ma = AbsBuild $ \s0 -> let (f,s1,w1) = getAbsBuild mf s0 - (a,s2,w2) = getAbsBuild ma s1 - in (f a,s2,w1 `mappend` w2) - -instance Monad (AbsBuild u) where - return a = AbsBuild $ \s0 -> (a,s0,mempty) - m >>= k = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild m s0 - (b,s2,w2) = (getAbsBuild . k) a s1 - in (b, s2, w1 `mappend` w2) - - - - - --- | The initial state is needs the start point. --- -initSt :: Floating u => Point2 u -> St u -initSt pt = St { current_point = pt - , current_incline = 0 - , cumulative_path = empty pt - , active_path = (pt, empty pt) - , pen_dc_modifier = id - } - --- run - (path,graphic) --- exec - graphic --- eval - path - --- | Note - runAbsBuild drops the monadic answer and returns the --- constructed path and a trace of the inserts and sub-paths. --- -runAbsBuild :: (Floating u, InterpretUnit u) - => Point2 u -> AbsBuild u a -> (AbsPath u, Graphic u) -runAbsBuild pt mf = post $ getAbsBuild mf (initSt pt) - where - post (_,st,log) = let sub_last = snd $ active_path st - cf = pen_dc_modifier st - log_last = logSubPath PATH_OPEN cf sub_last - log2 = log `mappend` log_last - empty_gfx = emptyLocGraphic `at` pt - (pen,ins) = extractTrace empty_gfx log2 - in (cumulative_path st, pen `oplus` ins) - - --- | Run an 'AbsBuild' - return the Graphic formed by the pen --- trace and the insert trace, /forget/ the outline of the path. --- -execAbsBuild :: (Floating u, InterpretUnit u) - => Point2 u -> AbsBuild u a -> Graphic u -execAbsBuild pt mf = snd $ runAbsBuild pt mf - - - --- | Run an 'AbsBuild' - return the outline of the path, /forget/ --- the Graphic formed by the pen trace and the insert trace. --- -evalAbsBuild :: (Floating u, InterpretUnit u) - => Point2 u -> AbsBuild u a -> AbsPath u -evalAbsBuild pt mf = fst $ runAbsBuild pt mf - - - -logSubPath :: InterpretUnit u - => PathEnd -> DrawingContextF -> AbsPath u -> Log u -logSubPath spe upd subp - | A.null subp = mempty - | otherwise = pen1 (toPrimPath subp >>= localize upd . drawF) - where - drawF = if spe == PATH_OPEN then openStroke else closedStroke - - - -tellSubClosed :: InterpretUnit u - => DrawingContextF -> AbsPath u -> AbsBuild u () -tellSubClosed upd subp = - AbsBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd subp) - -tellSubOpen :: InterpretUnit u - => DrawingContextF -> AbsPath u -> AbsBuild u () -tellSubOpen upd subp = - AbsBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd subp) - - -tellInsert :: Graphic u -> AbsBuild u () -tellInsert g1 = - AbsBuild $ \s0 -> ((),s0, insert1 g1) - - -sets_ :: (St u -> St u) -> AbsBuild u () -sets_ f = AbsBuild $ \s0 -> ((), f s0, mempty) - - -gets :: (St u -> a) -> AbsBuild u a -gets f = AbsBuild $ \s0 -> (f s0, s0, mempty) - - - --------------------------------------------------------------------------------- --- operations - -tip :: AbsBuild u (Point2 u) -tip = gets current_point - --- | Helper - extend the path. --- -extendPath :: (Point2 u -> AbsPath u -> AbsPath u) -> Point2 u -> AbsBuild u () -extendPath fn end_pt = sets_ upd - where - upd = (\s pt i j -> s { current_point = end_pt - , cumulative_path = fn pt i - , active_path = bimapR (fn pt) j }) - <*> current_point <*> cumulative_path <*> active_path - -absline :: Floating u => Point2 u -> AbsBuild u () -absline p1 = extendPath (\_ acc -> acc `snocLineTo` p1) p1 - - - -abscurve :: (Floating u, Ord u, Tolerance u) - => Point2 u -> Point2 u -> Point2 u -> AbsBuild u () -abscurve p1 p2 p3 = extendPath (\_ acc -> snocCurveTo acc p1 p2 p3) p3 - - - - --- | 'absmove' is a pen up. --- -absmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => Point2 u -> AbsBuild u () -absmove p1 = - gets active_path >>= \(_,ans) -> - gets pen_dc_modifier >>= \cf -> - tellSubOpen cf ans >> sets_ upd - where - upd = (\s i -> s { current_point = p1 - , cumulative_path = i `snocLineTo` p1 - , active_path = (p1, empty p1) }) - <*> cumulative_path - - -relline :: Floating u => Vec2 u -> AbsBuild u () -relline v1 = gets current_point >>= \pt -> absline (pt .+^ v1) - - -relcurve :: (Floating u, Ord u, Tolerance u) - => Vec2 u -> Vec2 u -> Vec2 u -> AbsBuild u () -relcurve v1 v2 v3 = - gets current_point >>= \pt -> - abscurve (pt .+^ v1) (pt .+^ v1 ^+^ v2) (pt .+^ v1 ^+^ v2 ^+^ v3) - - -relmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => Vec2 u -> AbsBuild u () -relmove v1 = gets current_point >>= \pt -> absmove (pt .+^ v1) - - - -rellineParallel :: Floating u => u -> AbsBuild u () -rellineParallel u = gets current_incline >>= \ang -> relline (avec ang u) - -rellinePerpendicular :: Floating u => u -> AbsBuild u () -rellinePerpendicular u = - gets current_incline >>= \ang -> relline (avec (fn ang) u) - where - fn = circularModulo . (+ half_pi) - -relmoveParallel :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -relmoveParallel u = gets current_incline >>= \ang -> relmove (avec ang u) - - -relmovePerpendicular :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -relmovePerpendicular u = - gets current_incline >>= \ang -> relmove (avec (fn ang) u) - where - fn = circularModulo . (+ half_pi) - - - -ctrlcurve :: (Floating u, Ord u, Tolerance u) - => Radian -> Radian -> Point2 u -> AbsBuild u () -ctrlcurve cin cout p1 = - extendPath (\p0 acc -> acc `append` controlCurve p0 cin cout p1) p1 - - - -insert :: Num u => LocGraphic u -> AbsBuild u () -insert gf = gets current_point >>= \pt -> tellInsert (gf `at` pt) - - -penCtxUpdate :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => DrawingContextF -> AbsBuild u () -penCtxUpdate cf = relmove (V2 0 0) >> sets_ upd - where - upd = (\s f -> s { pen_dc_modifier = cf . f }) - <*> pen_dc_modifier - - - --- Note - vamps should be a data type then we can have libraries --- of them. - -vamp :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => Vamp u -> AbsBuild u () -vamp (Vamp vnext vstart upd relp path_end) = - gets current_point >>= \p0 -> - relmove vnext >> drawF upd (R.toAbsPath (p0 .+^ vstart) relp) - where - drawF = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed - -cycle :: (Floating u, InterpretUnit u) => AbsBuild u () -cycle = - gets current_point >>= \pt -> - gets pen_dc_modifier >>= \cf -> - gets active_path >>= \(start,acc) -> - tellSubClosed cf (acc `snocLineTo` start) >> - sets_ (\s -> s { active_path = (pt, empty pt)}) - - -setIncline :: Radian -> AbsBuild u () -setIncline ang = sets_ upd - where - upd = (\s -> s { current_incline = ang }) - - --------------------------------------------------------------------------------- --- Derived operators - - -pen_colour :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => RGBi -> AbsBuild u () -pen_colour rgb = penCtxUpdate (stroke_colour rgb) - -pen_width :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => Double -> AbsBuild u () -pen_width d = penCtxUpdate (set_line_width d) - - - - -hline :: Floating u => u -> AbsBuild u () -hline dx = relline (hvec dx) - -vline :: Floating u => u -> AbsBuild u () -vline dy = relline (vvec dy) - -aline :: Floating u => u -> AbsBuild u () -aline u = gets current_incline >>= \ang -> relline (avec ang u) - -hmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -hmove dx = relmove (hvec dx) - -vmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -vmove dy = relmove (vvec dy) - - -amove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -amove u = gets current_incline >>= \ang -> relmove (avec ang u) - - - -line_up :: Floating u => u -> AbsBuild u () -line_up u = relline (vvec u) - -line_down :: Floating u => u -> AbsBuild u () -line_down u = relline (vvec $ negate u) - -line_left :: Floating u => u -> AbsBuild u () -line_left u = relline (hvec $ negate u) - -line_right :: Floating u => u -> AbsBuild u () -line_right u = relline (hvec u) - --- | Diagonal lines - -line_up_left :: Floating u => u -> AbsBuild u () -line_up_left u = relline (vec (-u) u) - -line_up_right :: Floating u => u -> AbsBuild u () -line_up_right u = relline (vec u u) - -line_down_left :: Floating u => u -> AbsBuild u () -line_down_left u = relline (vec (-u) (-u)) - -line_down_right :: Floating u => u -> AbsBuild u () -line_down_right u = relline (vec u (-u)) - - --- Cardinal lines - -line_north :: Floating u => u -> AbsBuild u () -line_north = vline - - -line_south :: Floating u => u -> AbsBuild u () -line_south = vline . negate - -line_east :: Floating u => u -> AbsBuild u () -line_east = hline - -line_west :: Floating u => u -> AbsBuild u () -line_west = hline . negate - - -line_northeast :: Floating u => u -> AbsBuild u () -line_northeast = relline . avec (0.25 * pi) - -line_northwest :: Floating u => u -> AbsBuild u () -line_northwest = relline . avec (0.75 * pi) - -line_southeast :: Floating u => u -> AbsBuild u () -line_southeast = relline . avec (1.75 * pi) - -line_southwest :: Floating u => u -> AbsBuild u () -line_southwest = relline . avec (1.25 * pi) - - - - -move_up :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_up u = relmove (vvec u) - -move_down :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_down u = relmove (vvec $ negate u) - -move_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_left u = relmove (hvec $ negate u) - -move_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_right u = relmove (hvec u) - - - --- | Diagonal moves - -move_up_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_up_left u = relmove (vec (-u) u) - -move_up_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_up_right u = relmove (vec u u) - -move_down_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_down_left u = relmove (vec (-u) (-u)) - -move_down_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_down_right u = relmove (vec u (-u)) - - --- Cardinal moves - -move_north :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_north = vmove - - -move_south :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_south = vmove . negate - -move_east :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_east = hmove - -move_west :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_west = hmove . negate - - -move_northeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_northeast = relmove . avec (0.25 * pi) - -move_northwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_northwest = relmove . avec (0.75 * pi) - -move_southeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_southeast = relmove . avec (1.75 * pi) - -move_southwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => u -> AbsBuild u () -move_southwest = relmove . avec (1.25 * pi) - - - diff --git a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs --- a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs +++ b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs @@ -49,6 +49,8 @@ -- * Conversion , toPrimPath + , openAbsPath + , closedAbsPath -- * Shortening , shortenPath @@ -79,6 +81,7 @@ , pathViewL , pathViewR + , optimizeLines , roundTrail , roundInterior @@ -269,7 +272,7 @@ -- Length is the length of the path as it is drawn, it is not a -- count of the number or path segments. -- --- Length is cached so this operation is cheap - though this put +-- Length is cached so this operation is cheap - though this puts -- a tax on the build operations. -- length :: Num u => AbsPath u -> u @@ -400,8 +403,16 @@ +openAbsPath :: InterpretUnit u + => AbsPath u -> Image u (AbsPath u) +openAbsPath rp = replaceAns rp $ + zapQuery (toPrimPath rp) >>= dcOpenPath +closedAbsPath :: InterpretUnit u + => DrawStyle -> AbsPath u -> Image u (AbsPath u) +closedAbsPath sty rp = replaceAns rp $ + zapQuery (toPrimPath rp) >>= dcClosedPath sty -- | Turn a Path into an ordinary PrimPath. @@ -410,7 +421,7 @@ -- segment is the same point as the start point of the next -- segment. -- -toPrimPath :: InterpretUnit u => AbsPath u -> Query PrimPath +toPrimPath :: InterpretUnit u => AbsPath u -> Query u PrimPath toPrimPath (AbsPath _ start segs _) = uconvertCtxF start >>= \dstart -> T.mapM uconvertCtxF segs >>= \dsegs -> @@ -689,6 +700,34 @@ +-------------------------------------------------------------------------------- + + +-- Path should be same length afterwards. + +optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) + => AbsPath u -> AbsPath u +optimizeLines (AbsPath _ sp0 segs _) = outer (zeroPath sp0) (viewl segs) + where + outer acc (AbsLineSeg _ p0 p1 :< se) = + inner acc (vdirection $ pvec p0 p1) p0 p1 (viewl se) + + outer acc (AbsCurveSeg _ _ p1 p2 p3 :< se) = + outer (snocCurveTo acc p1 p2 p3) (viewl se) + + outer acc EmptyL = acc + + inner acc d1 sp ep (AbsLineSeg _ p0 p1 :< se) = + let d2 = vdirection $ pvec p0 p1 in + if (d1 == d2) + then inner acc d1 sp p1 (viewl se) + else inner (acc `snocLineTo` ep) d2 ep p1 (viewl se) + + inner acc _ _ ep (AbsCurveSeg _ _ p1 p2 p3 :< se) = + let acc1 = snocCurveTo (snocLineTo acc ep) p1 p2 p3 + in outer acc1 (viewl se) + + inner acc _ _ ep EmptyL = acc `snocLineTo` ep -------------------------------------------------------------------------------- -- Round corners diff --git a/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs b/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Base.BuildCommon --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Common data types for the monadic builders. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Base.BuildCommon - ( - - BuildLog - , PathEnd(..) - , Vamp(..) - - , extractTrace - , addInsert - , addPen - - , insert1 - , pen1 - - ) where - -import Wumpus.Drawing.Paths.Base.RelPath ( RelPath ) - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.Utils.HList - -import Wumpus.Core -- package: wumpus-core - -import Data.Monoid - --- | Monadic builders allow both inserts (patterned after TikZ) --- which are decorations along the path and sub paths that are --- stroked and possibly closed. --- -data BuildLog a = Log { insert_trace :: H a - , pen_trace :: H a - } - | NoLog - -data PathEnd = PATH_CLOSED | PATH_OPEN - deriving (Eq,Show) - - -data Vamp u = Vamp - { vamp_move_span :: Vec2 u - , vamp_move_start :: Vec2 u - , vamp_dc_update :: DrawingContextF - , vamp_deco_path :: RelPath u - , vamp_path_end :: PathEnd - } - -type instance DUnit (Vamp u) = u - --------------------------------------------------------------------------------- --- instances - -instance Monoid (BuildLog a) where - mempty = NoLog - NoLog `mappend` b = b - a `mappend` NoLog = a - Log li lp `mappend` Log ri rp = Log (li `appendH` ri) (lp `appendH` rp) - - - - --- | Extract the pen and insert drawings from a 'BuildLog'. --- --- Any sub-paths traced by the pen are drawn at the back in the --- Z-order. --- -extractTrace :: OPlus a => a -> BuildLog a -> (a,a) -extractTrace zero NoLog = (zero,zero) -extractTrace zero (Log ins pen) = (pent,inst) - where - pent = altconcat zero $ toListH $ pen - inst = altconcat zero $ toListH $ ins - - --- | Add an /insert/. --- --- This is a decoration drawn at the /current point/ during path --- building. --- -addInsert :: a -> BuildLog a -> BuildLog a -addInsert a NoLog = Log { insert_trace = wrapH a, pen_trace = emptyH } -addInsert a s@(Log { insert_trace=i }) = s { insert_trace = i `snocH` a } - - --- | Build a trace from an /insert/. --- --- This is a decoration drawn at the /current point/ during path --- building. --- -insert1 :: a -> BuildLog a -insert1 a = Log { insert_trace = wrapH a, pen_trace = emptyH } - --- | Add a /pen/ drawing. --- --- This is a stroked path sub-path formed prior to a @moveto@ --- instruction. Moveto is synonymous with /pen up/ - at a pen up --- and sub-path is drawn as a trace. --- -addPen :: a -> BuildLog a -> BuildLog a -addPen a NoLog = Log { insert_trace = wrapH a, pen_trace = emptyH } -addPen a s@(Log { pen_trace=i }) = s { pen_trace = i `snocH` a } - - --- | Build a trace from an /insert/. --- --- This is a decoration drawn at the /current point/ during path --- building. --- -pen1 :: a -> BuildLog a -pen1 a = Log { insert_trace = emptyH, pen_trace = wrapH a } - - - diff --git a/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs b/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs @@ -0,0 +1,576 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Base.PathBuilder +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Build relative paths monadically. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base.PathBuilder + ( + + LocTraceM(..) -- re-export + + , PathSpec + , PathSpecT + + , Vamp + , PathTerm(..) + , makeVamp + + , runPathSpec + , execPathSpec + , evalPathSpec + + , runPathSpecT + , execPathSpecT + , evalPathSpecT + + , execPivot + , execPivotT + + + , PathOpM(..) + + + -- * Derived operators + , pen_colour + , pen_width + + , lines + + , hline + , vline + , aline + + + ) where + +import Wumpus.Drawing.Basis.LocTrace +import Wumpus.Drawing.Paths.Base.RelPath +-- import qualified Wumpus.Drawing.Paths.Base.RelPath as R + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + +import Data.VectorSpace -- package: vector-space + +import Control.Applicative +import Control.Monad +import Data.Monoid +import Prelude hiding ( null, cycle, lines ) + + + + + + +-- | The vector part of the @active_path@ is its start point. +-- This allows cycled paths. +-- +data BuildSt u = BuildSt + { cumulative_tip :: Vec2 u + , cumulative_path :: RelPath u + , current_incline :: Radian + , active_path :: ActivePath u + , pen_trace :: LocGraphic u + , ins_trace :: LocGraphic u + , pen_dc_modifier :: DrawingContextF + } + + -- TODO - is incline worthwhile? + + +-- | The vector for @PEN_DOWN@ is the start-point not the current +-- tip. +-- +-- Startpoint is needed for cycling a path. +-- +data ActivePath u = PEN_UP + | PEN_DOWN (Vec2 u) (RelPath u) + + + + +type instance DUnit (BuildSt u) = u +type instance DUnit (ActivePath u) = u + + +newtype PathSpec u a = PathSpec { + getPathSpec :: BuildSt u -> (a, BuildSt u) } + + +newtype PathSpecT u m a = PathSpecT { + getPathSpecT :: BuildSt u -> m (a, BuildSt u) } + + +-- Note - splitting the state between BuildSt and the /path tip/ +-- in LocTrace as actually detrimental to clarity of the code +-- below. It would make some sense to add the tip and the insert +-- trace to @BuildSt@ so everything is in one place. + + +type instance MonUnit (PathSpec u a) = u +type instance MonUnit (PathSpecT u m a) = u + + +-- | Vamps... +-- +data Vamp u = Vamp + { vamp_move :: Vec2 u + , vamp_path :: RelPath u + , vamp_term :: PathTerm + } + + +type instance DUnit (Vamp u) = u + + +data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle + deriving (Eq,Show) + + +makeVamp :: Vec2 u -> RelPath u -> PathTerm -> Vamp u +makeVamp v1 ph pe = Vamp { vamp_move = v1 + , vamp_path = ph + , vamp_term = pe + } + + +-------------------------------------------------------------------------------- +-- instances + + +-- Functor + +instance Functor (PathSpec u) where + fmap f mf = PathSpec $ \s0 -> let (a,s1) = getPathSpec mf s0 in (f a,s1) + +instance Monad m => Functor (PathSpecT u m) where + fmap f mf = PathSpecT $ \s0 -> + getPathSpecT mf s0 >>= \(a,s1) -> return (f a,s1) + + +-- Applicative + +instance Applicative (PathSpec u) where + pure a = PathSpec $ \s0 -> (a, s0) + mf <*> ma = PathSpec $ \s0 -> let (f,s1) = getPathSpec mf s0 + (a,s2) = getPathSpec ma s1 + in (f a, s2) + +instance Monad m => Applicative (PathSpecT u m) where + pure a = PathSpecT $ \s0 -> return (a, s0) + mf <*> ma = PathSpecT $ \s0 -> + getPathSpecT mf s0 >>= \(f,s1) -> + getPathSpecT ma s1 >>= \(a,s2) -> + return (f a, s2) + + +-- Monad + +instance Monad (PathSpec u) where + return a = PathSpec $ \s0 -> (a, s0) + ma >>= k = PathSpec $ \s0 -> + let (a,s1) = getPathSpec ma s0 in (getPathSpec . k) a s1 + +instance Monad m => Monad (PathSpecT u m) where + return a = PathSpecT $ \s0 -> return (a, s0) + ma >>= k = PathSpecT $ \s0 -> + getPathSpecT ma s0 >>= \(a,s1) -> (getPathSpecT . k) a s1 + + + +-- | Make the initial build state. +-- +zeroBuildSt :: InterpretUnit u => BuildSt u +zeroBuildSt = BuildSt { cumulative_tip = V2 0 0 + , cumulative_path = mempty + , current_incline = 0 + , active_path = PEN_UP + , pen_trace = mempty + , ins_trace = mempty + , pen_dc_modifier = id + } + + +-- The /full/ versions throw away only parts of the @BuildSt@ . +-- + + +-- | Run a PathSpec - return a five-tuple. +-- +-- > (ans, path, end_vector, pen_trace, insert_trace) +-- +-- > ans - is the monadic answer, usually (). +-- +-- > path - is the relative path formed by all movements during +-- > the build. This includes movement where the pen is _up_. +-- +-- > end_vector - is the cumulative displacement from the start +-- > point. +-- +-- > pen_trace - is ... +-- +-- > insert_trace - +-- +runPathSpec :: (Floating u, InterpretUnit u) + => PathSpec u a + -> (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u) +runPathSpec mf = + post $ getPathSpec mf zeroBuildSt + where + post (a,st) = let (ph,end,pen,ins) = postBuildSt st + in (a,ph,end,pen,ins) + +-- | /Close/ the BuildSt, extracting the values. +-- +-- A partly drawn sub path will be added to the pen trace as an +-- open sub path. +-- +postBuildSt :: InterpretUnit u + => BuildSt u -> (RelPath u, Vec2 u, LocGraphic u, LocGraphic u) +postBuildSt s0 = step (penUp SUBPATH_OPEN s0) + where + step st = ( cumulative_path st + , cumulative_tip st + , pen_trace st + , ins_trace st ) + + + + +-- | Run an 'PathSpec' - return the LocGraphic formed by the pen +-- trace and the insert trace, /forget/ the outline of the path. +-- +-- Note - the insert trace is printed above the pen trace in the +-- z-order. +-- +execPathSpec :: (Floating u, InterpretUnit u) + => PathSpec u a -> LocGraphic u +execPathSpec mf = post $ runPathSpec mf + where + post (_,_,_,g1,g2) = g1 `mappend` g2 + + + +-- | Run an 'PathSpec' - return the outline of the path, /forget/ +-- the the pen trace and the insert trace. +-- +evalPathSpec :: (Floating u, InterpretUnit u) + => PathSpec u a -> RelPath u +evalPathSpec mf = post $ runPathSpec mf + where + post (_,ph,_,_,_) = ph + + +-- | Transformer version of 'runPathSpec' +-- +runPathSpecT :: (Monad m, Floating u, InterpretUnit u) + => PathSpecT u m a + -> m (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u) +runPathSpecT mf = + liftM post $ getPathSpecT mf zeroBuildSt + where + post (a,st) = let (ph,end,pen,ins) = postBuildSt st + in (a,ph,end,pen,ins) + + +-- | Transformer version of 'execPathSpec' +-- +execPathSpecT :: (Monad m, Floating u, InterpretUnit u) + => PathSpecT u m a -> m (LocGraphic u) +execPathSpecT mf = liftM post $ runPathSpecT mf + where + post (_,_,_,g1,g2) = g1 `mappend` g2 + + +-- | Transformer version of 'evalPathSpec'. +-- +evalPathSpecT :: (Monad m, Floating u, InterpretUnit u) + => PathSpecT u m a -> m (RelPath u) +evalPathSpecT mf = liftM post $ runPathSpecT mf + where + post (_,ph,_,_,_) = ph + + + + +-- | Form a \"pivot path\" drawing from two path specifications. +-- The start point of the drawing is the pivot formed by joining +-- the paths. +-- +execPivot :: (Floating u, InterpretUnit u) + => PathSpec u a -> PathSpec u a -> LocGraphic u +execPivot ma mb = moveStart (negateV v) $ pen `mappend` ins + where + (v, _, _, pen, ins) = runPathSpec ( ma >> location >>= \ans -> + mb >> return ans ) + +-- | Transformer version of 'execPivot'. +-- +execPivotT :: (Floating u, InterpretUnit u, Monad m) + => PathSpecT u m a -> PathSpecT u m a -> m (LocGraphic u) +execPivotT ma mb = + liftM post $ runPathSpecT ( ma >> location >>= \ans -> + mb >> return ans ) + where + post (v, _, _, pen, ins) = moveStart (negateV v) $ pen `mappend` ins + + + + +-------------------------------------------------------------------------------- + +-- BuildSt modifiers. + +type BuildStF u = BuildSt u -> BuildSt u + + +-- | Helper - extend the path with a line. +-- +-- This is an implicit PEN_DOWN if the active pen is UP. +-- +extendPath :: Floating u + => Vec2 u -> BuildStF u +extendPath v1 = (\s v0 ph pa -> s { cumulative_tip = v0 ^+^ v1 + , cumulative_path = updP ph + , active_path = updA v0 pa }) + <*> cumulative_tip <*> cumulative_path <*> active_path + where + updP ph = snocLineTo ph v1 + updA tip PEN_UP = PEN_DOWN tip (line1 v1) + updA _ (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocLineTo ph v1) + + + + +-- | Helper - extend the path with a curve. +-- +-- This is an implicit PEN_DOWN if the active pen is UP. +-- +extendPathC :: (Floating u, Ord u, Tolerance u) + => Vec2 u -> Vec2 u -> Vec2 u -> BuildStF u +extendPathC c1 c2 c3 = + (\s v0 ph pa -> s { cumulative_tip = v0 ^+^ c1 ^+^ c2 ^+^ c3 + , cumulative_path = updP ph + , active_path = updA v0 pa }) + <*> cumulative_tip <*> cumulative_path <*> active_path + where + updP ph = snocCurveTo ph c1 c2 c3 + updA tip PEN_UP = PEN_DOWN tip (curve1 c1 c2 c2) + updA _ (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocCurveTo ph c1 c2 c3) + + +-- | Helper - change the active_path to PEN_UP. +-- +-- This will implicitly log any partly drawn path. +-- +penUp :: InterpretUnit u => PathTerm -> BuildStF u +penUp term = + (\s pt pa upd -> s { active_path = PEN_UP + , pen_trace = pt `mappend` fn upd pa }) + <*> pen_trace <*> active_path <*> pen_dc_modifier + where + fn _ PEN_UP = mempty + fn upd (PEN_DOWN v0 pa) = subPathDraw upd v0 pa term + + +-- | Move the current tip. +-- +-- This is an implicit PEN_UP if the active pen is DOWN. +-- +moveTip :: (Floating u, InterpretUnit u) + => Vec2 u -> BuildStF u +moveTip v1 = + (\s pa v0 cp -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s + in s1 { cumulative_tip = v0 ^+^ v1 + , cumulative_path = snocLineTo cp v1 }) + <*> active_path <*> cumulative_tip <*> cumulative_path + + +-- | Cycle the current active path. +-- +cycleAP :: (Floating u, InterpretUnit u) + => DrawStyle -> BuildStF u +cycleAP sty = + (\s pa vtip cp -> case pa of + PEN_UP -> s + PEN_DOWN v0 _ -> let s1 = penUp (SUBPATH_CLOSED sty) s + mv = v0 ^-^ vtip + in s1 { cumulative_tip = v0 + , cumulative_path = snocLineTo cp mv }) + <*> active_path <*> cumulative_tip <*> cumulative_path + + + +-- | Change the drawing props of the current pen. +-- +-- This is an implicit PEN_UP if the active pen is DOWN. +-- +changePen :: InterpretUnit u => DrawingContextF -> BuildStF u +changePen upd = + (\s pa df -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s + in s1 { pen_dc_modifier = (upd . df) }) + <*> active_path <*> pen_dc_modifier + + + +insertGf :: Num u => LocGraphic u -> BuildStF u +insertGf gf = + (\s ins v1 -> let g1 = moveStart v1 gf + in s { ins_trace = ins `mappend` g1 }) + <*> ins_trace <*> cumulative_tip + + + +appendVamp :: (Floating u, InterpretUnit u) + => Vamp u -> BuildStF u +appendVamp (Vamp { vamp_path = vph, vamp_term = term, vamp_move = mv }) = + next . penUp SUBPATH_OPEN + where + next = (\s v1 cp trc df -> let p1 = subPathDraw df v1 vph term + in s { cumulative_tip = v1 ^+^ mv + , cumulative_path = snocLineTo cp mv + , pen_trace = trc `mappend` p1 }) + <*> cumulative_tip <*> cumulative_path + <*> pen_trace <*> pen_dc_modifier + + + +subPathDraw :: InterpretUnit u + => DrawingContextF -> Vec2 u -> RelPath u -> PathTerm + -> LocGraphic u +subPathDraw upd v0 subp term = promoteLoc $ \pt -> + zapQuery (toPrimPath (displace v0 pt) subp) >>= \pp -> localize upd (drawF pp) + where + drawF = case term of + SUBPATH_OPEN -> dcOpenPath + SUBPATH_CLOSED sty -> dcClosedPath sty + + + + + +-------------------------------------------------------------------------------- +-- LocTraceM instances + +-- Note - path building does not support forking (LocForkTraceM). + +-- moveBy becomes a pen up + +instance (Floating u, InterpretUnit u) => + LocTraceM (PathSpec u) where + insertl a = PathSpec $ \s0 -> ((), insertGf a s0) + location = PathSpec $ \s0 -> (cumulative_tip s0, s0) + moveBy v = PathSpec $ \s0 -> ((), moveTip v s0) + + + + +instance (Monad m, Floating u, InterpretUnit u) => + LocTraceM (PathSpecT u m) where + insertl a = PathSpecT $ \s0 -> return ((), insertGf a s0) + location = PathSpecT $ \s0 -> return (cumulative_tip s0, s0) + moveBy v = PathSpecT $ \s0 -> return ((), moveTip v s0) + + + +-------------------------------------------------------------------------------- +-- + + +-- | @updatePen@ will draw any in-progress path as an open-stroked +-- line before changing the pen properties. +-- +class Monad m => PathOpM m where + line :: u ~ MonUnit (m ()) => Vec2 u -> m () + curve :: u ~ MonUnit (m ()) => Vec2 u -> Vec2 u -> Vec2 u -> m () + updatePen :: DrawingContextF -> m () + cycleSubPath :: DrawStyle -> m () + vamp :: u ~ MonUnit (m ()) => Vamp u -> m () + + + +instance (Floating u, Ord u, Tolerance u, InterpretUnit u) => + PathOpM (PathSpec u) where + line v1 = PathSpec $ \s0 -> ((), extendPath v1 s0) + curve v1 v2 v3 = PathSpec $ \s0 -> ((), extendPathC v1 v2 v3 s0) + updatePen upd = PathSpec $ \s0 -> ((), changePen upd s0) + cycleSubPath sty = PathSpec $ \s0 -> ((), cycleAP sty s0) + vamp vp = PathSpec $ \s0 -> ((), appendVamp vp s0) + + + +instance (Monad m, Floating u, Ord u, Tolerance u, InterpretUnit u) => + PathOpM (PathSpecT u m) where + line v1 = PathSpecT $ \s0 -> return ((), extendPath v1 s0) + curve v1 v2 v3 = PathSpecT $ \s0 -> return ((), extendPathC v1 v2 v3 s0) + updatePen upd = PathSpecT $ \s0 -> return ((), changePen upd s0) + cycleSubPath sty = PathSpecT $ \s0 -> return ((), cycleAP sty s0) + vamp vp = PathSpecT $ \s0 -> return ((), appendVamp vp s0) + + + +-------------------------------------------------------------------------------- +-- operations + + + +{- + +setIncline :: Radian -> PathSpec u () +setIncline ang = sets_ upd + where + upd = (\s -> s { current_incline = ang }) + +-} + +-------------------------------------------------------------------------------- +-- Derived operators + + + + +pen_colour :: PathOpM m + => RGBi -> m () +pen_colour rgb = updatePen (stroke_colour rgb) + +pen_width :: PathOpM m + => Double -> m () +pen_width d = updatePen (set_line_width d) + + +lines :: (PathOpM m, u ~ MonUnit (m ())) => [Vec2 u] -> m () +lines = mapM_ line + + +-- +-- Note - these names are not consistent with Displacement in +-- Wumpus-Basic. +-- + +hline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m () +hline dx = line (hvec dx) + +vline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m () +vline dy = line (vvec dy) + + +aline :: (PathOpM m, Floating u, u ~ MonUnit (m ())) => Radian -> u -> m () +aline ang d = line (avec ang d) diff --git a/src/Wumpus/Drawing/Paths/Base/RelBuilder.hs b/src/Wumpus/Drawing/Paths/Base/RelBuilder.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/RelBuilder.hs +++ /dev/null @@ -1,520 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Base.RelBuilder --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Build relative paths monadically. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Base.RelBuilder - ( - - RelBuild - , runRelBuild - , execRelBuild - , evalRelBuild - , execPivot - - - , tip - , line - , curve - , move - - , insert - , vamp - , cycle - - , setIncline - , pivot - - -- * Derived operators - , pen_colour - , pen_width - - , hline - , vline - , aline - - , hmove - , vmove - , amove - - , line_up - , line_down - , line_left - , line_right - - , line_up_left - , line_up_right - , line_down_left - , line_down_right - - , line_north - , line_south - , line_east - , line_west - , line_northeast - , line_northwest - , line_southeast - , line_southwest - - , move_up - , move_down - , move_left - , move_right - - , move_up_left - , move_up_right - , move_down_left - , move_down_right - - , move_north - , move_south - , move_east - , move_west - , move_northeast - , move_northwest - , move_southeast - , move_southwest - - ) where - --- import qualified Wumpus.Drawing.Paths.Base.AbsPath as A -import Wumpus.Drawing.Paths.Base.BuildCommon -import Wumpus.Drawing.Paths.Base.RelPath -import qualified Wumpus.Drawing.Paths.Base.RelPath as R - - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core - - -import Data.VectorSpace -- package: vector-space - -import Control.Applicative -import Data.Monoid -import Prelude hiding ( null, log, cycle ) - - -data St u = St - { cumulative_disp :: Vec2 u - , cumulative_path :: RelPath u - , current_incline :: Radian - , active_path :: (Vec2 u, RelPath u) - , pen_dc_modifier :: DrawingContextF - , pivot_position :: Vec2 u - } - -type instance DUnit (St u) = u - -type Log u = BuildLog (LocGraphic u) - - - - --- Don\'t want to write pen trace along with the insert commands --- as some renderings (fill) should ignore the the pen trace. - - --- | Evaluation is two States - a vector for cummulative --- displacement and a cummulative path - plus one Writer - a trace --- of TikZ-like @insert@ commands. --- -data RelBuild u a = RelBuild { getRelBuild :: St u -> (a, St u, Log u) } - -type instance DUnit (RelBuild u a) = u - - --------------------------------------------------------------------------------- --- instances - - - -instance Functor (RelBuild u) where - fmap f mf = RelBuild $ \s0 -> let (a, s1, w) = getRelBuild mf s0 - in (f a, s1, w) - - -instance Applicative (RelBuild u) where - pure a = RelBuild $ \s0 -> (a, s0, mempty) - mf <*> ma = RelBuild $ \s0 -> - let (f,s1,w1) = getRelBuild mf s0 - (a,s2,w2) = getRelBuild ma s1 - in (f a, s2, w1 `mappend` w2) - -instance Monad (RelBuild u) where - return a = RelBuild $ \s0 -> (a, s0, mempty) - ma >>= k = RelBuild $ \s0 -> - let (a,s1,w1) = getRelBuild ma s0 - (b,s2,w2) = (getRelBuild . k) a s1 - in (b, s2, w1 `mappend` w2) - - - -zeroSt :: Num u => St u -zeroSt = St { cumulative_disp = V2 0 0 - , cumulative_path = mempty - , current_incline = 0 - , active_path = (V2 0 0, mempty) - , pen_dc_modifier = id - , pivot_position = V2 0 0 - } - - -runBuildMonad :: (Floating u, InterpretUnit u) - => RelBuild u a -> (a, St u, LocGraphic u) -runBuildMonad mf = post $ getRelBuild mf zeroSt - where - post (a,st,log) = (a, st, pen `oplus` ins) - where - (v1,sub_last) = active_path st - cf = pen_dc_modifier st - log_last = logSubPath PATH_OPEN cf v1 sub_last - log2 = log `mappend` log_last - (pen,ins) = extractTrace emptyLocGraphic log2 - - --- | Note - runAbsBuild drops the monadic answer and returns the --- constructed path and a trace of the inserts and sub-paths. --- -runRelBuild :: (Floating u, InterpretUnit u) - => RelBuild u a -> (RelPath u, LocGraphic u) -runRelBuild mf = post $ runBuildMonad mf - where - post (_,st,gf) = (cumulative_path st,gf) - - --- | Run an 'RelBuild' - return the LocGraphic formed by the pen --- trace and the insert trace, /forget/ the outline of the path. --- -execRelBuild :: (Floating u, InterpretUnit u) - => RelBuild u a -> LocGraphic u -execRelBuild mf = snd $ runRelBuild mf - - - --- | Run an 'RelBuild' - return the outline of the path, /forget/ --- the LocGraphic formed by the pen trace and the insert trace. --- -evalRelBuild :: (Floating u, InterpretUnit u) - => RelBuild u a -> RelPath u -evalRelBuild mf = fst $ runRelBuild mf - - -execPivot :: (Floating u, InterpretUnit u) - => RelBuild u a -> LocGraphic u -execPivot mf = post $ runBuildMonad mf - where - post (_,st,gf) = let v1 = pivot_position st - in moveStart (displaceVec $ vreverse v1) gf - - - - -logSubPath :: InterpretUnit u - => PathEnd -> DrawingContextF -> Vec2 u -> RelPath u -> Log u -logSubPath spe upd v1 subp - | R.null subp = mempty - | otherwise = pen1 gf - where - drawF = if spe == PATH_OPEN then openStroke else closedStroke - gf = promoteR1 $ \pt -> - toPrimPath (displaceVec v1 pt) subp >>= \pp -> - localize upd (drawF pp) - - -tellSubClosed :: InterpretUnit u - => DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u () -tellSubClosed upd v1 subp = - RelBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd v1 subp) - -tellSubOpen :: InterpretUnit u - => DrawingContextF -> Vec2 u -> RelPath u -> RelBuild u () -tellSubOpen upd v1 subp = - RelBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd v1 subp) - - -tellInsert :: LocGraphic u -> RelBuild u () -tellInsert g1 = - RelBuild $ \s0 -> ((),s0, insert1 g1) - - -sets_ :: (St u -> St u) -> RelBuild u () -sets_ f = RelBuild $ \s0 -> ((), f s0, mempty) - - -gets :: (St u -> a) -> RelBuild u a -gets f = RelBuild $ \s0 -> (f s0, s0, mempty) - - - --------------------------------------------------------------------------------- --- operations - -tip :: RelBuild u (Vec2 u) -tip = gets cumulative_disp - - - --- | Helper - extend the path. --- -extendPath :: Num u - => (Vec2 u -> RelPath u -> RelPath u) -> Vec2 u -> RelBuild u () -extendPath fn v1 = sets_ upd - where - upd = (\s v0 i j -> s { cumulative_disp = v0 ^+^ v1 - , cumulative_path = fn v0 i - , active_path = bimapR (fn v0) j }) - <*> cumulative_disp <*> cumulative_path <*> active_path - --- --- Note - is the @r@ prefix of @rlineto@ redundant considering --- RelBuild can only support relative operations anyway. --- --- @lineto@ or probably better just @line@ would be shorter and --- the derivatives @hline@, @vline@ would inherit an obvious --- naming scheme. --- - - -line :: Floating u => Vec2 u -> RelBuild u () -line v1 = extendPath (\_ acc -> snocLineTo acc v1) v1 - - - - - -curve :: Floating u => Vec2 u -> Vec2 u -> Vec2 u -> RelBuild u () -curve v1 v2 v3 = extendPath (\_ acc -> snocCurveTo acc v1 v2 v3) v3 - - - - --- | 'rmoveto' is a pen up. --- -move :: (Floating u, InterpretUnit u) => Vec2 u -> RelBuild u () -move v1 = - gets active_path >>= \(v0,ans) -> - gets pen_dc_modifier >>= \cf -> - tellSubOpen cf v0 ans >> sets_ upd - where - upd = (\s v0 i -> s { cumulative_disp = v0 ^+^ v1 - , cumulative_path = snocLineTo i v1 - , active_path = (v0 ^+^ v1, mempty) }) - <*> cumulative_disp <*> cumulative_path - - - - - -insert :: Num u => LocGraphic u -> RelBuild u () -insert gf = gets cumulative_disp >>= \v -> - tellInsert (moveStart (displaceVec v) gf) - - -penCtxUpdate :: (Floating u, InterpretUnit u) - => DrawingContextF -> RelBuild u () -penCtxUpdate cf = move (V2 0 0) >> sets_ upd - where - upd = (\s f -> s { pen_dc_modifier = cf . f }) <*> pen_dc_modifier - - - - --- Note - vamps should be a data type then we can have libraries --- of them. - -vamp :: (Floating u, Ord u, Tolerance u, InterpretUnit u) - => Vamp u -> RelBuild u () -vamp (Vamp vnext vstart upd relp path_end) = - gets cumulative_disp >>= \v0 -> - gets pen_dc_modifier >>= \cf -> - move vnext >> drawF (upd . cf) (v0 ^+^ vstart) relp - where - drawF = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed - - -cycle :: (Floating u, InterpretUnit u) => RelBuild u () -cycle = - gets cumulative_disp >>= \v1 -> - gets pen_dc_modifier >>= \cf -> - gets active_path >>= \(start,acc) -> - tellSubClosed cf start (snocLineTo acc start) >> - sets_ (\s -> s { active_path = (v1, mempty)}) - - -setIncline :: Radian -> RelBuild u () -setIncline ang = sets_ upd - where - upd = (\s -> s { current_incline = ang }) - - -pivot :: RelBuild u () -pivot = sets_ upd - where - upd = (\s i -> s { pivot_position = i }) <*> cumulative_disp - - --------------------------------------------------------------------------------- --- Derived operators - - -pen_colour :: (Floating u, InterpretUnit u) - => RGBi -> RelBuild u () -pen_colour rgb = penCtxUpdate (stroke_colour rgb) - -pen_width :: (Floating u, InterpretUnit u) - => Double -> RelBuild u () -pen_width d = penCtxUpdate (set_line_width d) - - - -hline :: Floating u => u -> RelBuild u () -hline dx = line (hvec dx) - -vline :: Floating u => u -> RelBuild u () -vline dy = line (vvec dy) - -aline :: Floating u => Radian -> u -> RelBuild u () -aline ang u = line (avec ang u) - -hmove :: (Floating u, InterpretUnit u) => u -> RelBuild u () -hmove dx = move (hvec dx) - -vmove :: (Floating u, InterpretUnit u) => u -> RelBuild u () -vmove dy = move (vvec dy) - - -amove :: (Floating u, InterpretUnit u) => Radian -> u -> RelBuild u () -amove ang u = move (avec ang u) - - -line_up :: Floating u => u -> RelBuild u () -line_up u = line (vvec u) - -line_down :: Floating u => u -> RelBuild u () -line_down u = line (vvec $ negate u) - -line_left :: Floating u => u -> RelBuild u () -line_left u = line (hvec $ negate u) - -line_right :: Floating u => u -> RelBuild u () -line_right u = line (hvec u) - --- | Diagonal lines - -line_up_left :: Floating u => u -> RelBuild u () -line_up_left u = line (vec (-u) u) - -line_up_right :: Floating u => u -> RelBuild u () -line_up_right u = line (vec u u) - -line_down_left :: Floating u => u -> RelBuild u () -line_down_left u = line (vec (-u) (-u)) - -line_down_right :: Floating u => u -> RelBuild u () -line_down_right u = line (vec u (-u)) - - --- Cardinal lines - -line_north :: Floating u => u -> RelBuild u () -line_north = vline - - -line_south :: Floating u => u -> RelBuild u () -line_south = vline . negate - -line_east :: Floating u => u -> RelBuild u () -line_east = hline - -line_west :: Floating u => u -> RelBuild u () -line_west = hline . negate - - -line_northeast :: Floating u => u -> RelBuild u () -line_northeast = line . avec (0.25 * pi) - -line_northwest :: Floating u => u -> RelBuild u () -line_northwest = line . avec (0.75 * pi) - -line_southeast :: Floating u => u -> RelBuild u () -line_southeast = line . avec (1.75 * pi) - -line_southwest :: Floating u => u -> RelBuild u () -line_southwest = line . avec (1.25 * pi) - - - - -move_up :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_up u = move (vvec u) - -move_down :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_down u = move (vvec $ negate u) - -move_left :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_left u = move (hvec $ negate u) - -move_right :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_right u = move (hvec u) - - - --- | Diagonal moves - -move_up_left :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_up_left u = move (vec (-u) u) - -move_up_right :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_up_right u = move (vec u u) - -move_down_left :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_down_left u = move (vec (-u) (-u)) - -move_down_right :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_down_right u = move (vec u (-u)) - - --- Cardinal moves - -move_north :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_north = vmove - - -move_south :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_south = vmove . negate - -move_east :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_east = hmove - -move_west :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_west = hmove . negate - - -move_northeast :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_northeast = move . avec (0.25 * pi) - -move_northwest :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_northwest = move . avec (0.75 * pi) - -move_southeast :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_southeast = move . avec (1.75 * pi) - -move_southwest :: (Floating u, InterpretUnit u) => u -> RelBuild u () -move_southwest = move . avec (1.25 * pi) - diff --git a/src/Wumpus/Drawing/Paths/Base/RelPath.hs b/src/Wumpus/Drawing/Paths/Base/RelPath.hs --- a/src/Wumpus/Drawing/Paths/Base/RelPath.hs +++ b/src/Wumpus/Drawing/Paths/Base/RelPath.hs @@ -41,7 +41,7 @@ -- * Queries , null - + , length -- * Concat , append @@ -57,8 +57,10 @@ , toPrimPath , toAbsPath - , strokeRelPath + , openRelPath + , closedRelPath + ) where @@ -72,12 +74,15 @@ import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + + import qualified Data.Foldable as F import Data.Monoid import qualified Data.Traversable as T -import Prelude hiding ( null ) +import Prelude hiding ( null, length ) @@ -88,7 +93,9 @@ -- Note this type is more limited than AbsPath, it does not -- support /introspective/ operations like @length@ or anchors. -- -newtype RelPath u = RelPath { getRelPath :: JoinList (RelPathSeg u) } +data RelPath u = RelPath + { rel_path_len :: u + , rel_path_segs :: JoinList (RelPathSeg u) } deriving (Eq,Show) type instance DUnit (RelPath u) = u @@ -98,8 +105,16 @@ -- No annotations... -- -data RelPathSeg u = RelLineSeg (Vec2 u) - | RelCurveSeg (Vec2 u) (Vec2 u) (Vec2 u) +data RelPathSeg u = RelLineSeg + { rel_line_len :: u + , rel_line_to :: Vec2 u + } + | RelCurveSeg + { rel_curve_len :: u + , rel_curve_cp1 :: Vec2 u + , rel_curve_cp2 :: Vec2 u + , rel_curve_cp3 :: Vec2 u + } deriving (Eq,Show) @@ -110,17 +125,17 @@ -------------------------------------------------------------------------------- instance Functor RelPath where - fmap f = RelPath . fmap (fmap f) . getRelPath + fmap f (RelPath len xs) = RelPath (f len) (fmap (fmap f) xs) instance Functor RelPathSeg where - fmap f (RelLineSeg v1) = - RelLineSeg (fmap f v1) + fmap f (RelLineSeg len v1) = + RelLineSeg (f len) (fmap f v1) - fmap f (RelCurveSeg v1 v2 v3) = - RelCurveSeg (fmap f v1) (fmap f v2) (fmap f v3) + fmap f (RelCurveSeg len v1 v2 v3) = + RelCurveSeg (f len) (fmap f v1) (fmap f v2) (fmap f v3) -instance Monoid (RelPath u) where +instance Num u => Monoid (RelPath u) where mempty = empty mappend = append @@ -129,25 +144,61 @@ -- Construction +-- | Helper - construct a straight line segment. +-- +lineSegment :: Floating u => Vec2 u -> (u, RelPathSeg u) +lineSegment v1 = + (len, RelLineSeg { rel_line_len = len, rel_line_to = v1 }) + where + len = vlength v1 + + +-- | Helper - construct a curve segment. +-- +curveSegment :: (Floating u, Ord u, Tolerance u) + => Vec2 u -> Vec2 u -> Vec2 u -> (u, RelPathSeg u) +curveSegment v1 v2 v3 = (len, cseg) + where + p0 = zeroPt + p1 = p0 .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + + len = bezierLength (BezierCurve p0 p1 p2 p3) + cseg = RelCurveSeg { rel_curve_len = len + , rel_curve_cp1 = v1 + , rel_curve_cp2 = v2 + , rel_curve_cp3 = v3 + } + + + + -- | An empty relative path is acceptible to Wumpus because -- it is always drawn as a LocGraphic. -- -empty :: RelPath u -empty = RelPath mempty +empty :: Num u => RelPath u +empty = RelPath { rel_path_len = 0, rel_path_segs = mempty } -- | Create a relative path from a single straight line. -- -line1 :: Vec2 u -> RelPath u -line1 = RelPath . JL.one . RelLineSeg +line1 :: Floating u => Vec2 u -> RelPath u +line1 v = RelPath len (JL.one $ RelLineSeg len v) + where + len = vlength v + -- | Create a relative path from a single Bezier curve. -- -curve1 :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -curve1 v1 v2 v3 = RelPath $ JL.one $ RelCurveSeg v1 v2 v3 +curve1 :: Floating u + => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u +curve1 v1 v2 v3 = RelPath len (JL.one $ RelCurveSeg len v1 v2 v3) + where + len = vlength $ v1 ^+^ v2 ^+^ v3 -vertexPath :: [Vec2 u] -> RelPath u +vertexPath :: Floating u => [Vec2 u] -> RelPath u vertexPath [] = empty vertexPath (x:xs) = go (line1 x) xs where @@ -156,7 +207,7 @@ -curvedPath :: [Vec2 u] -> RelPath u +curvedPath :: Floating u => [Vec2 u] -> RelPath u curvedPath xs = case xs of (v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs _ -> empty @@ -173,8 +224,18 @@ -- Queries null :: RelPath u -> Bool -null = JL.null . getRelPath +null = JL.null . rel_path_segs +-- | Length of the Path. +-- +-- Length is the length of the path as it is drawn, it is not a +-- count of the number or path segments. +-- +-- Length is cached so this operation is cheap - though this puts +-- a tax on the build operations. +-- +length :: RelPath u -> u +length = rel_path_len -------------------------------------------------------------------------------- @@ -184,23 +245,35 @@ -append :: RelPath u -> RelPath u -> RelPath u -append (RelPath se0) (RelPath se1) = RelPath $ se0 `join` se1 +append :: Num u => RelPath u -> RelPath u -> RelPath u +append (RelPath la ssa) (RelPath lb ssb) = RelPath (la + lb) $ ssa `join` ssb -consLineTo :: Vec2 u -> RelPath u -> RelPath u -consLineTo v1 (RelPath se) = RelPath $ JL.cons (RelLineSeg v1) se +consLineTo :: Floating u + => Vec2 u -> RelPath u -> RelPath u +consLineTo v1 (RelPath len se) = RelPath (len + vl) $ JL.cons s se + where + (vl,s) = lineSegment v1 -snocLineTo :: RelPath u -> Vec2 u -> RelPath u -snocLineTo (RelPath se) v1 = RelPath $ JL.snoc se (RelLineSeg v1) +snocLineTo :: Floating u + => RelPath u -> Vec2 u -> RelPath u +snocLineTo (RelPath len se) v1 = RelPath (len + vl) $ JL.snoc se s + where + (vl,s) = lineSegment v1 -consCurveTo :: Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u -consCurveTo v1 v2 v3 (RelPath se) = RelPath $ JL.cons (RelCurveSeg v1 v2 v3) se +consCurveTo :: (Floating u, Ord u, Tolerance u) + => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u +consCurveTo v1 v2 v3 (RelPath len se) = RelPath (len + cl) $ JL.cons s se + where + (cl,s) = curveSegment v1 v2 v3 -snocCurveTo :: RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -snocCurveTo (RelPath se) v1 v2 v3 = RelPath $ JL.snoc se (RelCurveSeg v1 v2 v3) +snocCurveTo :: (Floating u, Ord u, Tolerance u) + => RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u +snocCurveTo (RelPath len se) v1 v2 v3 = RelPath (len + cl) $ JL.snoc se s + where + (cl,s) = curveSegment v1 v2 v3 @@ -209,45 +282,46 @@ -------------------------------------------------------------------------------- -- Conversion -fromPathAlgVertices :: Num u => PathAlg u -> (Vec2 u, RelPath u) +fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u) fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec where fn = maybe (V2 0 0) id -fromPathAlgCurves :: Num u => PathAlg u -> (Vec2 u, RelPath u) +fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u) fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec where fn = maybe (V2 0 0) id -toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query PrimPath -toPrimPath start (RelPath segs) = +toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query u PrimPath +toPrimPath start (RelPath _ segs) = uconvertCtxF start >>= \dstart -> T.mapM uconvertCtxF segs >>= \dsegs -> return $ relPrimPath dstart $ F.foldr fn [] dsegs where - fn (RelLineSeg v1) ac = relLineTo v1 : ac - fn (RelCurveSeg v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac + fn (RelLineSeg _ v1) ac = relLineTo v1 : ac + fn (RelCurveSeg _ v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac + toAbsPath :: (Floating u, Ord u, Tolerance u) => Point2 u -> RelPath u -> AbsPath u -toAbsPath start (RelPath segs) = step1 start $ viewl segs +toAbsPath start (RelPath _ segs) = step1 start $ viewl segs where step1 p0 EmptyL = Abs.empty p0 - step1 p0 (RelLineSeg v1 :< se) = + step1 p0 (RelLineSeg _ v1 :< se) = let (pth,end) = aline p0 v1 in step2 end pth (viewl se) - step1 p0 (RelCurveSeg v1 v2 v3 :< se) = + step1 p0 (RelCurveSeg _ v1 v2 v3 :< se) = let (pth,end) = acurve p0 v1 v2 v3 in step2 end pth (viewl se) step2 _ acc EmptyL = acc - step2 p0 acc (RelLineSeg v1 :< se) = + step2 p0 acc (RelLineSeg _ v1 :< se) = let (s1,end) = aline p0 v1 in step2 end (acc `Abs.append` s1) (viewl se) - step2 p0 acc (RelCurveSeg v1 v2 v3 :< se) = + step2 p0 acc (RelCurveSeg _ v1 v2 v3 :< se) = let (s1,end) = acurve p0 v1 v2 v3 in step2 end (acc `Abs.append` s1) (viewl se) @@ -262,8 +336,14 @@ -strokeRelPath :: InterpretUnit u => RelPath u -> LocGraphic u -strokeRelPath rp = - promoteR1 $ \start -> toPrimPath start rp >>= openStroke +openRelPath :: InterpretUnit u + => RelPath u -> LocImage u (RelPath u) +openRelPath rp = replaceAns rp $ + promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcOpenPath + +closedRelPath :: InterpretUnit u + => DrawStyle -> RelPath u -> LocImage u (RelPath u) +closedRelPath sty rp = replaceAns rp $ + promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcClosedPath sty diff --git a/src/Wumpus/Drawing/Paths/Relative.hs b/src/Wumpus/Drawing/Paths/Relative.hs --- a/src/Wumpus/Drawing/Paths/Relative.hs +++ b/src/Wumpus/Drawing/Paths/Relative.hs @@ -17,11 +17,11 @@ module Wumpus.Drawing.Paths.Relative ( - module Wumpus.Drawing.Paths.Base.RelBuilder + module Wumpus.Drawing.Paths.Base.PathBuilder , module Wumpus.Drawing.Paths.Base.RelPath ) where -import Wumpus.Drawing.Paths.Base.RelBuilder +import Wumpus.Drawing.Paths.Base.PathBuilder import Wumpus.Drawing.Paths.Base.RelPath diff --git a/src/Wumpus/Drawing/Paths/Vamps.hs b/src/Wumpus/Drawing/Paths/Vamps.hs --- a/src/Wumpus/Drawing/Paths/Vamps.hs +++ b/src/Wumpus/Drawing/Paths/Vamps.hs @@ -10,7 +10,7 @@ -- Stability : highly unstable -- Portability : GHC -- --- Shim import module for the Absolute Path modules. +-- Library of vamps (currently small). -- -- -------------------------------------------------------------------------------- @@ -18,22 +18,17 @@ module Wumpus.Drawing.Paths.Vamps ( - -- * Re-exported types - Vamp(..) - , PathEnd(..) - - , circleVamp + squareWE ) where -import Wumpus.Drawing.Paths.Base.BuildCommon +import Wumpus.Drawing.Paths.Base.PathBuilder import Wumpus.Drawing.Paths.Base.RelPath -import Wumpus.Basic.Geometry -- package: wumpus-basic +import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core -import Data.VectorSpace -- package: vector-space -- TODO - library of useful / illustrative vamps (circle, square etc.) @@ -41,16 +36,11 @@ -circleVamp :: (Fractional u, Floating u) => Vec2 u -> Vamp u -circleVamp v0 = Vamp { vamp_move_span = v0 - , vamp_move_start = half_v0 ^+^ v1 - , vamp_dc_update = id - , vamp_deco_path = path - , vamp_path_end = PATH_CLOSED - } +squareWE :: (Fractional u, Floating u) => u -> Vamp u +squareWE diam = makeVamp (hvec diam) rpath (SUBPATH_CLOSED STROKE) where - radius = 0.5 * vlength v0 - half_v0 = 0.5 *^ v0 - (v1,path) = fromPathAlgCurves $ circlePathAlg radius + hdiam = 0.5 * diam + rpath = vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] - -- Note - circlePathAlg starts from east + +-- Drawing a cirle is probably best done with 90deg arcs. diff --git a/src/Wumpus/Drawing/Shapes/Base.hs b/src/Wumpus/Drawing/Shapes/Base.hs --- a/src/Wumpus/Drawing/Shapes/Base.hs +++ b/src/Wumpus/Drawing/Shapes/Base.hs @@ -82,21 +82,16 @@ , shape_decoration :: LocThetaGraphic u } +type instance DUnit (Shape t u) = u type DShape t = Shape t Double - --- Design note - shapes look like they should be constrained to --- InterpretUnit rather than CtxSize, this allows direct affine --- transformations. --- - -------------------------------------------------------------------------------- shapeMap :: (t u -> t' u) -> Shape t u -> Shape t' u -shapeMap f = (\s sf -> s { shape_ans_fun = promoteR2 $ \pt ang -> - fmap f $ apply2R2 sf pt ang }) +shapeMap f = (\s sf -> s { shape_ans_fun = qpromoteLocTheta $ \pt ang -> + fmap f $ qapplyLocTheta sf pt ang }) <*> shape_ans_fun @@ -116,14 +111,14 @@ => LocThetaQuery u (t u) -> LocThetaQuery u (AbsPath u) -> Shape t u makeShape f g = Shape { shape_ans_fun = f , shape_path_fun = g - , shape_decoration = emptyLocThetaGraphic + , shape_decoration = emptyLocThetaImage } strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -strokedShape = shapeToLoc closedStroke +strokedShape = shapeToLoc (dcClosedPath STROKE) -- | Note - this is simplistic double stroking - draw a background @@ -136,59 +131,59 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -dblStrokedShape sh = decorateR1 back fore +dblStrokedShape sh = decorate back fore where - img = shapeToLoc closedStroke sh + img = shapeToLoc (dcClosedPath STROKE) sh back = getLineWidth >>= \lw -> localize (set_line_width $ lw * 3.0) img - fore = pushR1 ignoreAns $ localize (stroke_colour white) img + fore = ignoreAns $ localize (stroke_colour white) img filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -filledShape = shapeToLoc filledPath +filledShape = shapeToLoc (dcClosedPath FILL) borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -borderedShape = shapeToLoc borderedPath +borderedShape = shapeToLoc (dcClosedPath FILL_STROKE) shapeToLoc :: InterpretUnit u => (PrimPath -> Graphic u) -> Shape t u -> LocImage u (t u) -shapeToLoc drawF sh = promoteR1 $ \pt -> - apply2R2 (shape_ans_fun sh) pt 0 >>= \a -> - apply2R2 (shape_path_fun sh) pt 0 >>= \spath -> +shapeToLoc drawF sh = promoteLoc $ \pt -> + zapLocThetaQuery (shape_ans_fun sh) pt 0 >>= \a -> + zapLocThetaQuery (shape_path_fun sh) pt 0 >>= \spath -> let g2 = atIncline (shape_decoration sh) pt 0 - in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF) + in replaceAns a (decorate g2 $ zapQuery (toPrimPath spath) >>= drawF) rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rstrokedShape = shapeToLocTheta closedStroke +rstrokedShape = shapeToLocTheta (dcClosedPath STROKE) rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rfilledShape = shapeToLocTheta filledPath +rfilledShape = shapeToLocTheta (dcClosedPath FILL) rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rborderedShape = shapeToLocTheta borderedPath +rborderedShape = shapeToLocTheta (dcClosedPath FILL_STROKE) shapeToLocTheta :: InterpretUnit u => (PrimPath -> Graphic u) -> Shape t u -> LocThetaImage u (t u) -shapeToLocTheta drawF sh = promoteR2 $ \pt theta -> - apply2R2 (shape_ans_fun sh) pt theta >>= \a -> - apply2R2 (shape_path_fun sh) pt theta >>= \spath -> +shapeToLocTheta drawF sh = promoteLocTheta $ \pt theta -> + zapLocThetaQuery (shape_ans_fun sh) pt theta >>= \a -> + zapLocThetaQuery (shape_path_fun sh) pt theta >>= \spath -> let g2 = atIncline (shape_decoration sh) pt theta - in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF) + in replaceAns a $ decorate g2 (zapQuery (toPrimPath spath) >>= drawF) -- | Draw the shape path with round corners. -- roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> [Point2 u] -> Query (AbsPath u) + => u -> [Point2 u] -> Query u (AbsPath u) roundCornerShapePath sz xs = if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail sz xs) @@ -203,8 +198,8 @@ -- updatePathAngle :: (Radian -> Radian) -> Shape t u -> Shape t u updatePathAngle f = - (\s i -> s { shape_path_fun = promoteR2 $ \pt ang -> - apply2R2 i pt (mvTheta ang) }) + (\s fi -> s { shape_path_fun = qpromoteLocTheta $ \pt ang -> + qapplyLocTheta fi pt (mvTheta ang) }) <*> shape_path_fun where mvTheta = circularModulo . f diff --git a/src/Wumpus/Drawing/Shapes/Circle.hs b/src/Wumpus/Drawing/Shapes/Circle.hs --- a/src/Wumpus/Drawing/Shapes/Circle.hs +++ b/src/Wumpus/Drawing/Shapes/Circle.hs @@ -120,7 +120,7 @@ mkCircle :: InterpretUnit u => u -> LocThetaQuery u (Circle u) -mkCircle radius = promoteR2 $ \ctr theta -> +mkCircle radius = qpromoteLocTheta $ \ctr theta -> pure $ Circle { circ_ctm = makeShapeCTM ctr theta , circ_radius = radius } @@ -130,7 +130,7 @@ -- mkCirclePath :: (Floating u, Ord u, InterpretUnit u, Tolerance u) => u -> LocThetaQuery u (AbsPath u) -mkCirclePath radius = promoteR2 $ \ctr _ -> +mkCirclePath radius = qpromoteLocTheta $ \ctr _ -> pure $ curvePath $ bezierCircle radius ctr diff --git a/src/Wumpus/Drawing/Shapes/Diamond.hs b/src/Wumpus/Drawing/Shapes/Diamond.hs --- a/src/Wumpus/Drawing/Shapes/Diamond.hs +++ b/src/Wumpus/Drawing/Shapes/Diamond.hs @@ -145,7 +145,7 @@ mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u) -mkDiamond hw hh = promoteR2 $ \ctr theta -> +mkDiamond hw hh = qpromoteLocTheta $ \ctr theta -> pure $ Diamond { dia_ctm = makeShapeCTM ctr theta , dia_hw = hw , dia_hh = hh @@ -154,9 +154,9 @@ mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkDiamondPath rnd hw hh = promoteR2 $ \ctr theta -> - let ps = map (rotateAbout theta ctr) $ diamondCoordPath hw hh ctr - in roundCornerShapePath rnd ps +mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> + let ps = runPathAlgPoint ctr $ diamondPathAlg hw hh + in roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps diff --git a/src/Wumpus/Drawing/Shapes/Ellipse.hs b/src/Wumpus/Drawing/Shapes/Ellipse.hs --- a/src/Wumpus/Drawing/Shapes/Ellipse.hs +++ b/src/Wumpus/Drawing/Shapes/Ellipse.hs @@ -139,7 +139,7 @@ mkEllipse :: InterpretUnit u => u -> u -> LocThetaQuery u (Ellipse u) -mkEllipse rx ry = promoteR2 $ \ctr theta -> +mkEllipse rx ry = qpromoteLocTheta $ \ctr theta -> pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta , ell_rx = rx , ell_ry = ry @@ -148,7 +148,7 @@ mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> LocThetaQuery u (AbsPath u) -mkEllipsePath rx ry = promoteR2 $ \pt theta -> +mkEllipsePath rx ry = qpromoteLocTheta $ \pt theta -> let xs = map (rotateAbout theta pt) $ bezierEllipse rx ry pt in return $ curvePath xs diff --git a/src/Wumpus/Drawing/Shapes/Parallelogram.hs b/src/Wumpus/Drawing/Shapes/Parallelogram.hs --- a/src/Wumpus/Drawing/Shapes/Parallelogram.hs +++ b/src/Wumpus/Drawing/Shapes/Parallelogram.hs @@ -30,13 +30,12 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Intersection -import Wumpus.Basic.Geometry.Paths +import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core +import Data.VectorSpace -- package: vector-space import Control.Applicative @@ -53,34 +52,17 @@ , pll_base_width :: !u , pll_height :: !u , pll_base_l_ang :: Radian - , pll_syn_props :: SyntheticProps u } type instance DUnit (Parallelogram u) = u --- | Note (center) is a line dropped from the center of the --- paralleogram. --- --- > base_minor is the (center) to left corner. --- > base_major is the (center) to right corner. --- -data SyntheticProps u = SyntheticProps - { pll_base_minor :: u - , pll_base_major :: u - } -type instance DUnit (SyntheticProps u) = u - - type DParallelogram = Parallelogram Double instance Functor Parallelogram where - fmap f (Parallelogram ctm bw h lang props) = - Parallelogram (fmap f ctm) (f bw) (f h) lang (fmap f props) - -instance Functor SyntheticProps where - fmap f (SyntheticProps bmin bmaj) = SyntheticProps (f bmin) (f bmaj) + fmap f (Parallelogram ctm bw h lang) = + Parallelogram (fmap f ctm) (f bw) (f h) lang @@ -112,32 +94,43 @@ -- * base_major -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Anchor u + => (u -> u -> Radian -> Vec2 u) -> Parallelogram u -> Anchor u runDisplaceCenter fn (Parallelogram { pll_ctm = ctm , pll_base_width = bw - , pll_height = h - , pll_syn_props = syn }) = - projectFromCtr (fn (0.5 * bw) (0.5 * h) - (pll_base_minor syn) (pll_base_major syn)) ctm + , pll_height = h + , pll_base_l_ang = lang }) = + projectFromCtr (fn (0.5 * bw) (0.5 * h) lang) ctm instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where - center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 + center = runDisplaceCenter $ \_ _ _ -> V2 0 0 + +-- | WARNING - WRONG... + -- top anchors swap the base minor and major... -- + instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where - topLeftCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh - topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin hh + topLeftCorner = runDisplaceCenter $ \hw hh lang -> + let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo + topRightCorner = runDisplaceCenter $ \hw hh lang -> + let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang hypo + instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where - bottomLeftCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh) - bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj (-hh) + bottomLeftCorner = runDisplaceCenter $ \hw hh lang -> + let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo) + bottomRightCorner = runDisplaceCenter $ \hw hh lang -> + let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo) + + + instance (Real u, Floating u) => SideMidpointAnchor (Parallelogram u) where sideMidpoint n a = step (n `mod` 4) @@ -151,10 +144,10 @@ instance (Real u, Floating u) => CardinalAnchor (Parallelogram u) where - north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh - south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh) - east = runDisplaceCenter $ \hw _ _ _ -> V2 hw 0 - west = runDisplaceCenter $ \hw _ _ _ -> V2 (-hw) 0 + north = runDisplaceCenter $ \_ hh _ -> V2 0 hh + south = runDisplaceCenter $ \_ hh _ -> V2 0 (-hh) + east = runDisplaceCenter $ \hw _ _ -> V2 hw 0 + west = runDisplaceCenter $ \hw _ _ -> V2 (-hw) 0 instance (Real u, Floating u, InterpretUnit u, Tolerance u) => @@ -171,17 +164,23 @@ radialAnchor = pllRadialAnchor --- TODO - update this to a quadrant function... +-- | Note - it is not worth changing this to a quadrantAlg. -- +-- There are pathological parallelograms that the current +-- QuadrantAlg code cannot handle, and a better abstraction is +-- needed (rather than better implementation of QuadrantAlg). +-- pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) => Radian -> Parallelogram u -> Anchor u -pllRadialAnchor theta (Parallelogram { pll_ctm = ctm - , pll_height = h - , pll_syn_props = syn }) = +pllRadialAnchor theta (Parallelogram { pll_ctm = ctm + , pll_base_width = bw + , pll_height = h + , pll_base_l_ang = lang }) = post $ findIntersect zeroPt theta $ polygonLineSegments ps where - ps = pllPoints (pll_base_minor syn) (pll_base_major syn) h - post = \ans -> case ans of + ps = runVertices4 zeroPt $ parallelogramVertices bw h lang + + post = \ans -> case ans of Nothing -> projectFromCtr (V2 0 0) ctm Just (P2 x y) -> projectFromCtr (V2 x y) ctm @@ -196,10 +195,7 @@ parallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Radian -> Shape Parallelogram u parallelogram bw h lang = - let props = synthesizeProps bw h lang - in makeShape (mkParallelogram bw h lang props) - (mkParallelogramPath 0 (pll_base_minor props) - (pll_base_major props) h) + makeShape (mkParallelogram bw h lang) (mkParallelogramPath 0 bw h lang) -- | 'zparallelogram' : @ base_width * height -> Parallelogram @ @@ -216,64 +212,23 @@ mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) - => u -> u -> Radian -> SyntheticProps u - -> LocThetaQuery u (Parallelogram u) -mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> + => u -> u -> Radian -> LocThetaQuery u (Parallelogram u) +mkParallelogram bw h lang = qpromoteLocTheta $ \ctr theta -> pure $ Parallelogram { pll_ctm = makeShapeCTM ctr theta , pll_base_width = bw , pll_height = h , pll_base_l_ang = lang - , pll_syn_props = props } --- Note - expects ang value 0 < ang < 180, though does not check... --- -synthesizeProps :: Fractional u => u -> u -> Radian -> SyntheticProps u -synthesizeProps bw h lang - | lang == 0.5*pi = let hw = 0.5 * bw in SyntheticProps hw hw - | lang > 0.5*pi = less_ninety - | otherwise = grtr_ninety - where - less_ninety = let extw = h / (fromRadian $ tan lang) - half_rect_width = 0.5 * (bw + extw) - in SyntheticProps half_rect_width (half_rect_width - extw) - grtr_ninety = let extw = h / (fromRadian $ tan (pi-lang)) - half_rect_width = 0.5 * (bw + extw) - in SyntheticProps (half_rect_width - extw) half_rect_width - - - mkParallelogramPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) -mkParallelogramPath rnd bw_minor bw_major h = promoteR2 $ \ctr theta -> - let xs = pllPath bw_minor bw_major h ctr + => u -> u -> u -> Radian -> LocThetaQuery u (AbsPath u) +mkParallelogramPath rnd bw h lang = qpromoteLocTheta $ \ctr theta -> + let xs = runVertices4 ctr $ parallelogramVertices bw h lang in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs - - -pllPath :: (Real u, Floating u) - => u -> u -> u -> LocCoordPath u -pllPath bw_minor bw_major h (P2 x y) = [ bl, br, tr, tl ] - where - hh = 0.5 * h - bl = P2 (x - bw_minor) (y - hh) - br = P2 (x + bw_major) (y - hh) - tl = P2 (x - bw_major) (y + hh) -- topleft subtracts major - tr = P2 (x + bw_minor) (y + hh) -- topright adds minor - - -pllPoints :: (Real u, Floating u) - => u -> u -> u -> [Point2 u] -pllPoints bw_minor bw_major h = [ bl, br, tr, tl ] - where - hh = 0.5 * h - bl = P2 (-bw_minor) (-hh) - br = P2 bw_major (-hh) - tl = P2 (-bw_major) hh - tr = P2 bw_minor hh diff --git a/src/Wumpus/Drawing/Shapes/Rectangle.hs b/src/Wumpus/Drawing/Shapes/Rectangle.hs --- a/src/Wumpus/Drawing/Shapes/Rectangle.hs +++ b/src/Wumpus/Drawing/Shapes/Rectangle.hs @@ -30,8 +30,7 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Paths -- package: wumpus-basic -import Wumpus.Basic.Geometry.Quadrant +import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -153,7 +152,7 @@ mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u) -mkRectangle hw hh = promoteR2 $ \ctr theta -> +mkRectangle hw hh = qpromoteLocTheta $ \ctr theta -> pure $ Rectangle { rect_ctm = makeShapeCTM ctr theta , rect_hw = hw , rect_hh = hh @@ -162,9 +161,8 @@ mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkRectPath rnd hw hh = promoteR2 $ \ctr theta -> - let btm_left = displace (-hw) (-hh) ctr - xs = rectangleCoordPath (2*hw) (2*hh) btm_left +mkRectPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> + let xs = runVertices4 ctr $ rectangleVertices hw hh in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs diff --git a/src/Wumpus/Drawing/Shapes/Semicircle.hs b/src/Wumpus/Drawing/Shapes/Semicircle.hs --- a/src/Wumpus/Drawing/Shapes/Semicircle.hs +++ b/src/Wumpus/Drawing/Shapes/Semicircle.hs @@ -46,15 +46,15 @@ data Semicircle u = Semicircle { sc_ctm :: ShapeCTM u , sc_radius :: !u - , sc_syn_props :: SyntheticProps u } type instance DUnit (Semicircle u) = u --- | rect_width is the width of the (greater) enclosing rectangle. -data SyntheticProps u = SyntheticProps - { sc_ctr_minor :: u - , sc_ctr_major :: u +-- | Height minor and major. +-- +data SyntheticProps u = SP + { sc_hminor :: u + , sc_hmajor :: u } type instance DUnit (SyntheticProps u) = u @@ -64,12 +64,26 @@ instance Functor Semicircle where - fmap f (Semicircle ctm r props) = Semicircle (fmap f ctm) (f r) (fmap f props) + fmap f (Semicircle ctm r) = Semicircle (fmap f ctm) (f r) -instance Functor SyntheticProps where - fmap f (SyntheticProps cmin cmaj) = SyntheticProps (f cmin) (f cmaj) +-- | Use the formula: +-- +-- > 4r +-- > --- +-- > 3pi +-- +-- to get the yminor. +-- +synthesizeProps :: Floating u => u -> SyntheticProps u +synthesizeProps radius = + SP { sc_hminor = hminor, sc_hmajor = hmajor } + where + hminor = (4 * radius) / (3 * pi) + hmajor = radius - hminor + + -------------------------------------------------------------------------------- -- Affine trans @@ -100,10 +114,12 @@ runDisplaceCenter :: (Real u, Floating u) => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u runDisplaceCenter fn (Semicircle { sc_ctm = ctm - , sc_radius = radius - , sc_syn_props = syn }) = - projectFromCtr (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) ctm - + , sc_radius = radius }) = + projectFromCtr (fn radius hminor hmajor) ctm + where + props = synthesizeProps radius + hminor = sc_hminor props + hmajor = sc_hmajor props instance (Real u, Floating u) => CenterAnchor (Semicircle u) where @@ -151,22 +167,28 @@ -- helpers +-- | Semicircle does not fit into a QuadrantAlg easily. +-- +-- So all the work has to be done here. +-- scRadialVec :: (Real u, Floating u, Ord u, Tolerance u) => Radian -> u -> u -> u -> Vec2 u -scRadialVec theta radius hminor _ = go theta +scRadialVec theta radius hminor _ = go (circularModulo theta) where (lang,rang) = baselineRange radius hminor (bctr, br, _, bl) = constructionPoints radius hminor - plane = makePlane zeroPt theta + plane = inclinedLine zeroPt theta base_line = LineSegment bl br left_curve = mkCurve radius half_pi bctr right_curve = mkCurve radius 0 bctr post = maybe (V2 0 0) (\(P2 x y) -> V2 x y) - go a | lang <= a && a <= rang = post $ interLinesegLine base_line plane - | half_pi <= a && a < lang = post $ interCurveLine left_curve plane - | otherwise = post $ interCurveLine right_curve plane + go a + | lang <= a && a <= rang = post $ interLinesegLine base_line plane + | half_pi <= a && a < lang = post $ interCurveLine left_curve plane + | otherwise = post $ interCurveLine right_curve plane + mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3 where @@ -186,7 +208,7 @@ bctr = P2 0 (-hminor) br = bctr .+^ hvec radius apx = bctr .+^ vvec radius - bl = bctr .-^ hvec radius + bl = bctr .+^ hvec (-radius) @@ -212,26 +234,16 @@ => u -> Shape Semicircle u semicircle radius = let props = synthesizeProps radius - in makeShape (mkSemicircle radius props) - (mkSemicirclePath radius (sc_ctr_minor props)) + in makeShape (mkSemicircle radius) + (mkSemicirclePath radius (sc_hminor props)) -synthesizeProps :: Floating u => u -> SyntheticProps u -synthesizeProps radius = - SyntheticProps { sc_ctr_minor = cminor - , sc_ctr_major = cmajor - } - where - cminor = (4 * radius) / (3 * pi) - cmajor = radius - cminor - mkSemicircle :: InterpretUnit u - => u -> SyntheticProps u -> LocThetaQuery u (Semicircle u) -mkSemicircle radius props = promoteR2 $ \ctr theta -> - pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta + => u -> LocThetaQuery u (Semicircle u) +mkSemicircle radius = qpromoteLocTheta $ \ctr theta -> + pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta , sc_radius = radius - , sc_syn_props = props } @@ -241,7 +253,7 @@ -- mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> LocThetaQuery u (AbsPath u) -mkSemicirclePath radius cminor = promoteR2 $ \pt theta -> - let ctr = displacePerpendicular (-cminor) theta pt +mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta -> + let ctr = dispPerpendicular (-cminor) theta pt in pure $ curvePath $ bezierArcPoints pi radius theta ctr diff --git a/src/Wumpus/Drawing/Shapes/Semiellipse.hs b/src/Wumpus/Drawing/Shapes/Semiellipse.hs --- a/src/Wumpus/Drawing/Shapes/Semiellipse.hs +++ b/src/Wumpus/Drawing/Shapes/Semiellipse.hs @@ -46,15 +46,14 @@ { se_ctm :: ShapeCTM u , se_rx :: !u , se_ry :: !u - , se_syn_props :: SyntheticProps u } type instance DUnit (Semiellipse u) = u --- | rect_width is the width of the (greater) enclosing rectangle. -data SyntheticProps u = SyntheticProps - { se_ry_minor :: u - , se_ry_major :: u + +data SyntheticProps u = SP + { se_hminor :: u + , se_hmajor :: u } type instance DUnit (SyntheticProps u) = u @@ -62,12 +61,18 @@ type DSemiellipse = Semiellipse Double instance Functor Semiellipse where - fmap f (Semiellipse ctm rx ry props) = - Semiellipse (fmap f ctm) (f rx) (f ry) (fmap f props) + fmap f (Semiellipse ctm rx ry) = Semiellipse (fmap f ctm) (f rx) (f ry) -instance Functor SyntheticProps where - fmap f (SyntheticProps rymin rymaj) = SyntheticProps (f rymin) (f rymaj) + +synthesizeProps :: Floating u => u -> SyntheticProps u +synthesizeProps ry = + SP { se_hminor = ry_minor, se_hmajor = ry_major } + where + ry_minor = (4 * ry) / (3 * pi) + ry_major = ry - ry_minor + + -------------------------------------------------------------------------------- -- Affine trans @@ -101,9 +106,12 @@ => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u runDisplaceCenter fn (Semiellipse { se_ctm = ctm , se_rx = rx - , se_ry = ry - , se_syn_props = syn }) = - projectFromCtr (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm + , se_ry = ry }) = + projectFromCtr (fn rx ry hminor hmajor) ctm + where + props = synthesizeProps ry + hminor = se_hminor props + hmajor = se_hmajor props @@ -149,7 +157,7 @@ where (lang,rang) = baselineRange rx hminor (bctr, br, _, bl) = constructionPoints rx ry hminor - plane = makePlane zeroPt theta + plane = inclinedLine zeroPt theta base_line = LineSegment bl br (right_curve,left_curve) = bezierSemiellipse rx ry bctr post = maybe (V2 0 0) (\(P2 x y) -> V2 x y) @@ -200,34 +208,24 @@ => u -> u -> Shape Semiellipse u semiellipse rx ry = let props = synthesizeProps ry - in makeShape (mkSemiellipse rx ry props) - (mkSemiellipsePath rx ry (se_ry_minor props)) + in makeShape (mkSemiellipse rx ry) + (mkSemiellipsePath rx ry (se_hminor props)) -synthesizeProps :: Floating u => u -> SyntheticProps u -synthesizeProps ry = - SyntheticProps { se_ry_minor = ry_minor - , se_ry_major = ry_major - } - where - ry_minor = (4 * ry) / (3 * pi) - ry_major = ry - ry_minor - -mkSemiellipse :: u -> u -> SyntheticProps u -> LocThetaQuery u (Semiellipse u) -mkSemiellipse rx ry props = promoteR2 $ \ctr theta -> +mkSemiellipse :: u -> u -> LocThetaQuery u (Semiellipse u) +mkSemiellipse rx ry = qpromoteLocTheta $ \ctr theta -> pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta , se_rx = rx , se_ry = ry - , se_syn_props = props } mkSemiellipsePath :: (Real u, Floating u, Tolerance u) => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkSemiellipsePath rx ry cminor = promoteR2 $ \pt theta -> - let ctr = displacePerpendicular (-cminor) theta pt +mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta -> + let ctr = dispPerpendicular (-hminor) theta pt xs = bezierSemiellipsePoints rx ry ctr in return $ curvePath $ map (rotateAbout theta ctr) xs diff --git a/src/Wumpus/Drawing/Shapes/Trapezium.hs b/src/Wumpus/Drawing/Shapes/Trapezium.hs --- a/src/Wumpus/Drawing/Shapes/Trapezium.hs +++ b/src/Wumpus/Drawing/Shapes/Trapezium.hs @@ -11,10 +11,7 @@ -- Stability : highly unstable -- Portability : GHC -- --- Trapezium. --- --- Note cardinal anchors correspond directly to the compass --- positions. +-- Isoceles Trapezium. -- -------------------------------------------------------------------------------- @@ -24,7 +21,6 @@ Trapezium , DTrapezium , trapezium - , ztrapezium ) where @@ -38,7 +34,6 @@ import Wumpus.Core -- package: wumpus-core -import Data.VectorSpace -- package: vector-space import Control.Applicative @@ -53,9 +48,8 @@ data Trapezium u = Trapezium { tz_ctm :: ShapeCTM u , tz_base_width :: !u + , tz_top_width :: !u , tz_height :: !u - , tz_base_l_ang :: Radian - , tz_base_r_ang :: Radian } type instance DUnit (Trapezium u) = u @@ -63,8 +57,7 @@ type DTrapezium = Trapezium Double instance Functor Trapezium where - fmap f (Trapezium ctm bw h lang rang) = - Trapezium (fmap f ctm) (f bw) (f h) lang rang + fmap f (Trapezium ctm bw tw h) = Trapezium (fmap f ctm) (f bw) (f tw) (f h) -------------------------------------------------------------------------------- -- Affine trans @@ -89,43 +82,40 @@ -------------------------------------------------------------------------------- -- Anchors + + -- | 'runDisplaceCenter' : @ ( half_base_width --- * half_height --- * left_base_ang --- * right_base_ang -> Vec ) * trapzium -> Point @ +-- * half_top_width +-- * half_height -> Vec ) * trapezium -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> Radian -> Radian -> Vec2 u) + => (u -> u -> u -> Vec2 u) -> Trapezium u -> Anchor u runDisplaceCenter fn (Trapezium { tz_ctm = ctm , tz_base_width = bw - , tz_height = h - , tz_base_l_ang = lang - , tz_base_r_ang = rang }) = - projectFromCtr (fn (0.5 * bw) (0.5 * h) lang rang) ctm + , tz_top_width = tw + , tz_height = h }) = + projectFromCtr (fn (0.5 * bw) (0.5 * tw) (0.5 * h)) ctm instance (Real u, Floating u) => CenterAnchor (Trapezium u) where - center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 + center = runDisplaceCenter $ \_ _ _ -> V2 0 0 instance (Real u, Floating u) => BottomCornerAnchor (Trapezium u) where - bottomLeftCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 (-hbw) (-hh) - bottomRightCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 hbw (-hh) + bottomLeftCorner = runDisplaceCenter $ \hbw _ hh -> V2 (-hbw) (-hh) + bottomRightCorner = runDisplaceCenter $ \hbw _ hh -> V2 hbw (-hh) + + + instance (Real u, Floating u) => TopCornerAnchor (Trapezium u) where - topLeftCorner = runDisplaceCenter $ \hbw hh lang _ -> - let vbase = V2 (-hbw) (-hh) - vup = leftSideVec (2*hh) lang - in vbase ^+^ vup - topRightCorner = runDisplaceCenter $ \hbw hh _ rang -> - let vbase = V2 hbw (-hh) - vup = rightSideVec (2*hh) rang - in vbase ^+^ vup + topLeftCorner = runDisplaceCenter $ \_ htw hh -> V2 (-htw) hh + topRightCorner = runDisplaceCenter $ \_ htw hh -> V2 htw hh instance (Real u, Floating u, Tolerance u) => @@ -141,8 +131,8 @@ instance (Real u, Floating u, Tolerance u) => CardinalAnchor (Trapezium u) where - north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh - south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh) + north = runDisplaceCenter $ \_ _ hh -> V2 0 hh + south = runDisplaceCenter $ \_ _ hh -> V2 0 (-hh) east = tzRadialAnchor 0 west = tzRadialAnchor pi @@ -160,18 +150,16 @@ RadialAnchor (Trapezium u) where radialAnchor = tzRadialAnchor --- TODO - update this to a quadrant function... --- +-- tzRadialAnchor :: (Real u, Floating u, Tolerance u) => Radian -> Trapezium u -> Anchor u tzRadialAnchor theta (Trapezium { tz_ctm = ctm , tz_base_width = bw - , tz_height = h - , tz_base_l_ang = lang - , tz_base_r_ang = rang }) = + , tz_top_width = tw + , tz_height = h }) = post $ findIntersect zeroPt theta $ polygonLineSegments ps where - ps = tzPoints bw h lang rang + ps = runVertices4 zeroPt $ isoscelesTrapeziumVertices bw tw h post = \ans -> case ans of Nothing -> projectFromCtr (V2 0 0) ctm Just (P2 x y) -> projectFromCtr (V2 x y) ctm @@ -186,98 +174,30 @@ -- -- trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> Radian -> Radian -> Shape Trapezium u -trapezium bw h lang rang = - makeShape (mkTrapezium bw h lang rang) (mkTrapeziumPath 0 bw h lang rang) + => u -> u -> u -> Shape Trapezium u +trapezium bw tw h = + makeShape (mkTrapezium bw tw h) (mkTrapeziumPath 0 bw tw h) --- | 'ztrapezium' : @ base_width * height -> Trapezium @ --- --- -ztrapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> Shape Trapezium u -ztrapezium bw h = trapezium bw h ang ang - where - ang = d2r (60::Double) -------------------------------------------------------------------------------- mkTrapezium :: (Real u, Fractional u, InterpretUnit u) - => u -> u -> Radian -> Radian -> LocThetaQuery u (Trapezium u) -mkTrapezium bw h lang rang = promoteR2 $ \ctr theta -> + => u -> u -> u -> LocThetaQuery u (Trapezium u) +mkTrapezium bw tw h = qpromoteLocTheta $ \ctr theta -> pure $ Trapezium { tz_ctm = makeShapeCTM ctr theta , tz_base_width = bw + , tz_top_width = tw , tz_height = h - , tz_base_l_ang = lang - , tz_base_r_ang = rang } mkTrapeziumPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> Radian -> Radian - -> LocThetaQuery u (AbsPath u) -mkTrapeziumPath rnd bw h lang rang = promoteR2 $ \ctr theta -> - let xs = tzPath bw h lang rang ctr + => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) +mkTrapeziumPath rnd bw tw h = qpromoteLocTheta $ \ctr theta -> + let xs = runVertices4 ctr $ isoscelesTrapeziumVertices bw tw h in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs - -tzPath :: (Real u, Floating u) - => u -> u -> Radian -> Radian -> LocCoordPath u -tzPath bw h lang rang (P2 x y) = [ bl, br, tr, tl ] - where - half_base = 0.5 * bw - hh = 0.5 * h - br = P2 (x + half_base ) (y - hh) - bl = P2 (x - half_base ) (y - hh) - tr = displaceVec (rightSideVec h rang) br - tl = displaceVec (leftSideVec h lang) bl - - -tzPoints :: (Real u, Floating u) - => u -> u -> Radian -> Radian -> [Point2 u] -tzPoints bw h lang rang = [ bl, br, tr, tl ] - where - half_base = 0.5 * bw - hh = 0.5 * h - bl = P2 (-half_base) (-hh) - br = P2 half_base (-hh) - tr = displaceVec (rightSideVec h rang) br - tl = displaceVec (leftSideVec h lang) bl - - - --- | Calculate the vector that produces the upper-left point given --- the lower-left point. --- --- Note - expects ang value 0 < ang < 180, though does not check... --- -leftSideVec :: Floating u => u -> Radian -> Vec2 u -leftSideVec h lang | lang < 0.5*pi = less_ninety - | lang == 0.5*pi = vvec h - | otherwise = grtr_ninety - where - less_ninety = let dist = h / (fromRadian $ sin lang) in avec lang dist - grtr_ninety = let theta = lang - (0.5*pi) - dist = h / (fromRadian $ cos theta) - in avec lang dist - - - - --- | Calculate the vector that produces the upper-right point given --- the lower-right point. --- --- Note - expects ang value 0 < ang < 180, though does not check... --- -rightSideVec :: Floating u => u -> Radian -> Vec2 u -rightSideVec h rang | rang < 0.5*pi = less_ninety - | rang == 0.5*pi = vvec h - | otherwise = grtr_ninety - where - less_ninety = let dist = h / (fromRadian $ sin rang) in avec (pi - rang) dist - grtr_ninety = let theta = rang - (0.5*pi) - dist = h / (fromRadian $ cos theta) - in avec (pi - rang) dist diff --git a/src/Wumpus/Drawing/Shapes/Triangle.hs b/src/Wumpus/Drawing/Shapes/Triangle.hs --- a/src/Wumpus/Drawing/Shapes/Triangle.hs +++ b/src/Wumpus/Drawing/Shapes/Triangle.hs @@ -27,9 +27,7 @@ import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Quadrant -import Wumpus.Basic.Geometry.Paths +import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -48,7 +46,6 @@ { tri_ctm :: ShapeCTM u , tri_base_width :: !u , tri_height :: !u - , tri_syn_props :: SyntheticProps u } type instance DUnit (Triangle u) = u @@ -60,19 +57,28 @@ , tri_apex_ang :: Radian } -type instance DUnit (SyntheticProps u) = u - type DTriangle = Triangle Double instance Functor Triangle where - fmap f (Triangle ctm bw h props) = - Triangle (fmap f ctm) (f bw) (f h) (fmap f props) + fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h) -instance Functor SyntheticProps where - fmap f (SyntheticProps hmin hmaj ang1 ang2) = - SyntheticProps (f hmin) (f hmaj) ang1 ang2 +synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u +synthesizeProps bw h = + SyntheticProps { tri_hmajor = hmajor + , tri_hminor = hminor + , tri_base_ang = base_ang + , tri_apex_ang = apex_ang + } + where + half_base = 0.5 * bw + hminor = h / 3 + hmajor = 2 * hminor + base_ang = atan $ toRadian (h / half_base) + apex_ang = 2 * ((pi/4) - base_ang) + + -------------------------------------------------------------------------------- -- Affine trans @@ -103,13 +109,14 @@ runDisplaceCenter :: (Real u, Floating u) => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Anchor u runDisplaceCenter fn (Triangle { tri_ctm = ctm - , tri_base_width = bw - , tri_syn_props = syn }) = + , tri_base_width = bw + , tri_height = h }) = projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm where - hminor = tri_hminor syn - hmajor = tri_hmajor syn - base_ang = tri_base_ang syn + props = synthesizeProps bw h + hminor = tri_hminor props + hmajor = tri_hmajor props + base_ang = tri_base_ang props @@ -187,52 +194,38 @@ let props = synthesizeProps bw h hminor = tri_hminor props hmajor = tri_hmajor props - in makeShape (mkTriangle bw h props) (mkTrianglePath 0 bw hminor hmajor) + in makeShape (mkTriangle bw h) (mkTrianglePath 0 bw hminor hmajor) mkTriangle :: (Real u, Fractional u, InterpretUnit u) - => u -> u -> SyntheticProps u -> LocThetaQuery u (Triangle u) -mkTriangle bw h props = promoteR2 $ \ctrd theta -> + => u -> u -> LocThetaQuery u (Triangle u) +mkTriangle bw h = qpromoteLocTheta $ \ctrd theta -> pure $ Triangle { tri_ctm = makeShapeCTM ctrd theta , tri_base_width = bw , tri_height = h - , tri_syn_props = props } -synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u -synthesizeProps bw h = - SyntheticProps { tri_hmajor = hmajor - , tri_hminor = hminor - , tri_base_ang = base_ang - , tri_apex_ang = apex_ang - } - where - half_base = 0.5 * bw - hminor = h / 3 - hmajor = 2 * hminor - base_ang = atan $ toRadian (h / half_base) - apex_ang = 2 * ((pi/4) - base_ang) mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) -mkTrianglePath rnd bw hminor hmajor = promoteR2 $ \ctr theta -> - let xs = trianglePath bw hminor hmajor ctr +mkTrianglePath rnd bw hminor hmajor = qpromoteLocTheta $ \ctr theta -> + let xs = runVertices3 ctr $ trianglePath bw hminor hmajor in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs trianglePath :: (Real u, Floating u) - => u -> u -> u -> LocCoordPath u -trianglePath bw hminor hmajor (P2 x y) = [br, apx, bl] + => u -> u -> u -> Vertices3 u +trianglePath bw hminor hmajor = (br, apx, bl) where half_base = 0.5 * bw - br = P2 (x + half_base ) (y - hminor) - apx = P2 x (y + hmajor) - bl = P2 (x - half_base ) (y - hminor) + br = V2 half_base (-hminor) + apx = V2 0 hmajor + bl = V2 (-half_base) (-hminor) diff --git a/src/Wumpus/Drawing/Text/Base/Common.hs b/src/Wumpus/Drawing/Text/Base/Common.hs --- a/src/Wumpus/Drawing/Text/Base/Common.hs +++ b/src/Wumpus/Drawing/Text/Base/Common.hs @@ -46,19 +46,19 @@ posTextWithMargins :: (Fractional u, InterpretUnit u) - => PosObject u -> BoundedLocRectGraphic u -posTextWithMargins obj = + => PosObject u -> (RectAddress -> LocImage u (BoundingBox u)) +posTextWithMargins obj = \raddr -> textMargin >>= \(xsep,ysep) -> let body = extendPosObject xsep xsep ysep ysep obj - in runPosObjectR2 body + in runPosObject raddr body -- | Single line text, returning its advance vector. -- -advtext :: InterpretUnit u => EscapedText -> AdvGraphic u +advtext :: InterpretUnit u => EscapedText -> LocImage u (Vec2 u) advtext esc = textVector esc >>= body where - body v = pushR1 (replaceAns v) $ escTextLine esc + body v = replaceAns v $ dcEscapedlabel esc textVector :: (DrawingCtxM m, InterpretUnit u) diff --git a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs --- a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs +++ b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs @@ -83,7 +83,7 @@ | Mono (WidthQuery u) [EscapedChar] | AElab (AElaborateF u) (Doc u) -type WidthQuery u = Query (AdvanceVec u) +type WidthQuery u = Query u (AdvanceVec u) type TextContextF u = TextContext u -> TextContext u @@ -94,7 +94,7 @@ -- | TextFrame is the result Graphic made from rendering multiple -- lines of DocText. -- -type TextFrame u = BoundedLocRectGraphic u +type TextFrame u = RectAddress -> LocImage u (BoundingBox u) -- NOTE - should the API use @em@ for fill, padding etc.? @@ -248,10 +248,11 @@ render :: (Real u, Floating u, InterpretUnit u) - => FontFamily -> Doc u -> BoundedLocRectGraphic u -render ff doc = localize (set_font $ regularWeight ff) $ + => FontFamily -> Doc u -> (RectAddress -> LocImage u (BoundingBox u)) +render ff doc = \raddr -> localize (set_font $ regularWeight ff) $ textlineSpace >>= \sep -> - posTextWithMargins $ runEvalM (initTextCtx sep ff) (interpret doc) + let po = runEvalM (initTextCtx sep ff) (interpret doc) + in posTextWithMargins po raddr data TextContext u = TextContext @@ -319,16 +320,17 @@ valignSpace va <$> lineSpace <*> interpret a <*> interpret b interpret (Fill va w a) = ppad va w <$> interpret a -interpret (DLocal upd a) = localizePO upd <$> interpret a +interpret (DLocal upd a) = localPosObject upd <$> interpret a interpret (TLocal upd a) = local upd (interpret a) interpret (Mono q1 xs) = interpMono q1 xs -interpret (AElab fn a) = aelaboratePO fn <$> interpret a +interpret (AElab fn a) = decoPosObject fn ANTERIOR <$> interpret a interpEmpty :: InterpretUnit u => EvalM u (PosObject u) -interpEmpty = return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic +interpEmpty = + return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocImage @@ -341,7 +343,7 @@ interpText :: (Fractional u, InterpretUnit u) => EscapedText -> EvalM u (PosObject u) interpText esc = interpretLeaf $ - makePosObject (textOrientationZero esc) (escTextLine esc) + makePosObject (textOrientationZero esc) (dcEscapedlabel esc) @@ -352,38 +354,40 @@ -- interpSpace :: InterpretUnit u => EvalM u (PosObject u) -interpSpace = return $ makePosObject qy1 emptyLocGraphic +interpSpace = return $ makePosObject qy1 emptyLocImage where qy1 = charOrientationZero $ CharEscInt $ ord ' ' ppad :: (Fractional u, Ord u) - => VAlign -> u -> PosObject u -> PosObject u -ppad VLeft = padLeftPO -ppad VCenter = padHorizontalPO -ppad VRight = padRightPO + => VAlign -> u -> PosObject u -> PosObject u +ppad VLeft du = mapOrientation (padXMinor du) +ppad VCenter du = mapOrientation (padHEven $ 0.5 * du) +ppad VRight du = mapOrientation (padXMajor du) interpMono :: (Fractional u, InterpretUnit u) - => Query (AdvanceVec u) -> [EscapedChar] + => Query u (AdvanceVec u) -> [EscapedChar] -> EvalM u (PosObject u) -interpMono qy1 chs = interpretLeaf $ - makeBindPosObject qy hkernOrientationZero hkernLine +interpMono avq chs = + interpretLeaf $ makePosObject (qChars >>= hkernOrientationZero) + (promoteLoc $ \pt -> + zapQuery qChars >>= \ks -> hkernLine ks `at` pt) where - qy = (\v1 -> monoSpace (advanceH v1) chs ) <$> qy1 - + qChars = (\v1 -> monoSpace (advanceH v1) chs) <$> avq + interpretLeaf :: (Fractional u, InterpretUnit u) => PosObject u -> EvalM u (PosObject u) interpretLeaf po = - (\f1 f2 sty -> f1 $ f2 $ localizePO sty po) + (\f1 f2 sty -> f1 $ f2 $ localPosObject sty po) <$> (fmap (condE drawUnderline) $ asks text_underline) <*> (fmap (condE drawStrikethrough) $ asks text_strikethrough) <*> textstyle where - condE f b = if b then elaboratePO f else id + condE f b = if b then decoPosObject f SUPERIOR else id textstyle :: EvalM u DrawingContextF textstyle = @@ -413,7 +417,7 @@ drawStrikethrough :: (Fractional u, InterpretUnit u) => Orientation u -> LocGraphic u drawStrikethrough (Orientation xmin xmaj _ ymaj) = - linestyle $ moveStart (displaceVec $ vec (-xmin) vpos) hline + linestyle $ moveStart (vec (-xmin) vpos) hline where vpos = 0.45 * ymaj hline = locStraightLine (hvec $ xmin + xmaj) @@ -423,7 +427,7 @@ drawUnderline :: (Fractional u, InterpretUnit u) => Orientation u -> LocGraphic u drawUnderline (Orientation xmin xmaj ymin _) = - linestyle $ moveStart (displaceVec $ vec (-xmin) vpos) hline + linestyle $ moveStart (vec (-xmin) vpos) hline where vpos = negate $ 0.45 * ymin hline = locStraightLine (hvec $ xmin + xmaj) @@ -447,7 +451,7 @@ hdy = 0.5 * dy in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy) where - mkVec dx dy = displaceVec $ vec (negate $ xmin+dx) (negate $ ymin+dy) + mkVec dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy) mkRect dx dy = let w = dx + xmin + xmaj + dx h = dy + ymin + ymaj + dy - in filledRectangle w h + in dcRectangle FILL w h diff --git a/src/Wumpus/Drawing/Text/Base/Label.hs b/src/Wumpus/Drawing/Text/Base/Label.hs --- a/src/Wumpus/Drawing/Text/Base/Label.hs +++ b/src/Wumpus/Drawing/Text/Base/Label.hs @@ -19,6 +19,7 @@ ( locImageLabel + , label_center_of , label_left_of , label_right_of @@ -30,6 +31,14 @@ , label_atstart_of , label_atend_of + , centerRelative + , right_of + , left_of + , above_right_of + , below_right_of + , above_left_of + , below_left_of + ) where @@ -40,16 +49,20 @@ import Wumpus.Core -- package: wumpus-core - +type BoundedLocRectGraphic u = RectAddress -> LocImage u (BoundingBox u) locImageLabel :: Floating u - => (a -> Anchor u) -> RectAddress - -> BoundedLocRectGraphic u -> LocImage u a -> LocImage u a -locImageLabel fn rpos lbl obj = promoteR1 $ \pt -> - elaborateR0 (obj `at` pt) (\a -> graphic_ $ atStartAddr lbl (fn a) rpos) + => (a -> Anchor u) + -> RectAddress + -> (RectAddress -> LocImage u (BoundingBox u)) + -> LocImage u a + -> LocImage u a +locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> + elaborate (obj `at` pt) (\a -> ignoreAns $ mklabel rpos `at` fn a) + label_center_of :: (Floating u, CenterAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_center_of = locImageLabel center CENTER @@ -83,7 +96,7 @@ -> Image u (AbsPath u) -> Image u (AbsPath u) connectorPathLabel fn rpos lbl img = - elaborateR0 img (\a -> graphic_ $ atStartAddr lbl (fn a) rpos) + elaborate img (\a -> ignoreAns $ lbl rpos `at` (fn a)) label_midway_of :: (Real u, Floating u) @@ -105,6 +118,77 @@ -> BoundedLocRectGraphic u -> Image u (AbsPath u) -> Image u (AbsPath u) label_atend_of = connectorPathLabel atend_ + + + + +-- | Absolute units. +-- +centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => (Int,Int) -> a -> Query u (Anchor u) +centerRelative coord a = + snapmove coord >>= \v -> return $ displace v (center a) + +-- TODO - These are really for Anchors. +-- +-- Should the have a separate module or be rolled into the same +-- module as the classes? +-- + +-- | Value is 1 snap unit right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +right_of = centerRelative (1,0) + +-- | Value is 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +left_of = centerRelative ((-1),0) + +-- | Value is 1 snap move up, 1 snap move right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +above_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +above_right_of = centerRelative (1,1) + +-- | Value is 1 snap move below, 1 snap move right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +below_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +below_right_of = centerRelative (1, (-1)) + +-- | Value is 1 snap move up, 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +above_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +above_left_of = centerRelative ((-1),1) + +-- | Value is 1 snap move down, 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +below_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query u (Anchor u) +below_left_of = centerRelative ((-1),(-1)) + diff --git a/src/Wumpus/Drawing/Text/Base/PosChar.hs b/src/Wumpus/Drawing/Text/Base/PosChar.hs --- a/src/Wumpus/Drawing/Text/Base/PosChar.hs +++ b/src/Wumpus/Drawing/Text/Base/PosChar.hs @@ -47,7 +47,7 @@ -- -- While it may be adequate, it does need another prefix. -- -type LocRectChar u = BoundedLocRectGraphic u +type LocRectChar u = RectAddress -> LocImage u (BoundingBox u) @@ -58,7 +58,7 @@ escCharLabel :: (Floating u, InterpretUnit u) => EscapedChar -> LocRectChar u -escCharLabel esc = runPosObjectR2 (makePosChar esc) +escCharLabel esc = \raddr -> runPosObject raddr (makePosChar esc) makePosChar :: InterpretUnit u @@ -67,7 +67,7 @@ escText1 :: InterpretUnit u => EscapedChar -> LocGraphic u -escText1 ch = escTextLine $ wrapEscChar ch +escText1 ch = dcEscapedlabel $ wrapEscChar ch diff --git a/src/Wumpus/Drawing/Text/Base/RotTextZero.hs b/src/Wumpus/Drawing/Text/Base/RotTextZero.hs --- a/src/Wumpus/Drawing/Text/Base/RotTextZero.hs +++ b/src/Wumpus/Drawing/Text/Base/RotTextZero.hs @@ -47,8 +47,8 @@ import Control.Applicative -type LocRectTextLine u = BoundedLocRectGraphic u -type LocTextLine u = BoundedLocGraphic u +type LocRectTextLine u = RectAddress -> LocImage u (BoundingBox u) +type LocTextLine u = LocImage u (BoundingBox u) type TextObject u = PosObject u @@ -63,16 +63,16 @@ bllTextline :: (Floating u, InterpretUnit u) => String -> LocTextLine u -bllTextline ss = startAddr (textline ss) BLL +bllTextline ss = textline ss BLL blcTextline :: (Floating u, InterpretUnit u) => String -> LocTextLine u -blcTextline ss = startAddr (textline ss) BLC +blcTextline ss = textline ss BLC ccTextline :: (Floating u, InterpretUnit u) => String -> LocTextLine u -ccTextline ss = startAddr (textline ss) CENTER +ccTextline ss = textline ss CENTER multiAlignLeft :: (Real u, Floating u, InterpretUnit u) @@ -93,9 +93,10 @@ renderMultiLine :: (Real u, Floating u, InterpretUnit u) => VAlign -> [TextObject u] -> LocRectTextLine u -renderMultiLine va docs = body >>= posTextWithMargins +renderMultiLine va docs = \raddr -> + body >>= \ans -> posTextWithMargins ans raddr where - body = (\dy -> alignColumnSep va dy $ reverse docs) <$> textlineSpace + body = (\dy -> alignColumnSep va dy docs) <$> textlineSpace makeTextObject :: InterpretUnit u => String -> TextObject u @@ -104,7 +105,7 @@ makeEscTextObject :: InterpretUnit u => EscapedText -> TextObject u makeEscTextObject esc = - makePosObject (textOrientationZero esc) (escTextLine esc) + makePosObject (textOrientationZero esc) (dcEscapedlabel esc) -- Note inclided text will (probably) have to construct with the @@ -115,29 +116,32 @@ => Radian -> String -> LocRectTextLine u rtextline ang ss = rescTextline ang (escapeString ss) --- Is rotated text better with no margin? + rescTextline :: (Real u, Floating u, Ord u, InterpretUnit u) => Radian -> EscapedText -> LocRectTextLine u -rescTextline ang esc = runPosObjectR2 $ makePosObject ortt body +rescTextline ang esc = \raddr -> runPosObject raddr $ makePosObject ortt body where ortt = fmap (rotOrientation ang) $ textOrientationZero esc - body = incline (rescTextLine esc) ang + body = incline (dcREscapedlabel esc) ang + + -- | Rotate an Orientation about its locus. -- rotOrientation :: (Real u, Floating u, Ord u) => Radian -> Orientation u -> Orientation u -rotOrientation ang (Orientation xmin xmaj ymin ymaj) = +rotOrientation ang (Orientation { or_x_minor = xmin + , or_x_major = xmaj + , or_y_minor = ymin + , or_y_major = ymaj }) = orthoOrientation bl br tl tr where - bl = rotateCorner ang $ P2 (-xmin) (-ymin) - br = rotateCorner ang $ P2 xmaj (-ymaj) - tr = rotateCorner ang $ P2 xmaj ymaj - tl = rotateCorner ang $ P2 (-xmin) ymaj + bl = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin) + br = rotateAbout ang zeroPt $ P2 xmaj (-ymin) + tr = rotateAbout ang zeroPt $ P2 xmaj ymaj + tl = rotateAbout ang zeroPt $ P2 (-xmin) ymaj --- | This is not necessarily correct... --- orthoOrientation :: (Num u, Ord u) => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Orientation u @@ -149,227 +153,9 @@ } -rotateCorner :: (Real u, Floating u) => Radian -> Point2 u -> Point2 u -rotateCorner ang pt = displaceVec v2 zeroPt - where - v1 = pvec zeroPt pt - theta = vdirection v1 - hyp = vlength v1 - v2 = avec (ang+theta) hyp - min4 :: Ord u => u -> u -> u -> u -> u min4 a b c d = min (min a b) (min c d) max4 :: Ord u => u -> u -> u -> u -> u max4 a b c d = max (max a b) (max c d) - -{- - -type RotText u = PosThetaImage BoundingBox u - - -------------------- - --- | One line of multiline text --- -data OnelineText u = OnelineText - { text_content :: EscapedText - , oneline_adv :: AdvanceVec u - } - - - -type OnelineGraphicF u = u -> OnelineText u -> LocThetaGraphic u - - - - -rotTextStart :: PosThetaImage u a -> RectPosition -> Radian -> LocImage u a -rotTextStart = startPosRot - - -textbox :: (Real u, Floating u, InterpretUnit u) - => String -> PosImage BoundingBox u -textbox ss = multiAlignCenter ss `ptRot` 0 - - - -rtextbox :: (Real u, Floating u, InterpretUnit u) - => String -> PosThetaImage BoundingBox u -rtextbox ss = multiAlignCenter ss - - --- multi line text allows rotation - -multiAlignLeft :: (Real u, Floating u, InterpretUnit u) - => String -> PosThetaImage BoundingBox u -multiAlignLeft ss = - drawMultiline onelineALeft (map escapeString $ lines ss) - -multiAlignCenter :: (Real u, Floating u, InterpretUnit u) - => String -> PosThetaImage BoundingBox u -multiAlignCenter ss = - drawMultiline onelineACenter (map escapeString $ lines ss) - -multiAlignRight :: (Real u, Floating u, InterpretUnit u) - => String -> RotText u -multiAlignRight ss = - drawMultiline onelineARight (map escapeString $ lines ss) - - -textAlignLeft :: (Real u, Floating u, InterpretUnit u) - => String -> LocImage BoundingBox u -textAlignLeft ss = startPosRot (multiAlignLeft ss) CENTER 0 - -textAlignCenter :: (Real u, Floating u, InterpretUnit u) - => String -> LocImage BoundingBox u -textAlignCenter ss = startPosRot (multiAlignCenter ss) CENTER 0 - -textAlignRight :: (Real u, Floating u, InterpretUnit u) - => String -> LocImage BoundingBox u -textAlignRight ss = startPosRot (multiAlignRight ss) CENTER 0 - - - - - -drawMultiline :: (Real u, Floating u, InterpretUnit u) - => OnelineGraphicF u -> [EscapedText] - -> PosThetaImage BoundingBox u -drawMultiline _ [] = lift1R3 emptyBoundedLocGraphic -drawMultiline drawF xs = promoteR3 $ \start rpos ang -> - linesToInterims xs >>= \(max_w, ones) -> - borderedRotTextPos ang line_count max_w >>= \opos -> - let gf = multilineGraphic drawF max_w ang ones - bbf = orthoBB max_w line_count ang - img = intoLocImage bbf gf - posG = makePosImage opos img - in atStartPos posG start rpos - where - line_count = length xs - - -multilineGraphic :: (Floating u, InterpretUnit u) - => OnelineGraphicF u - -> u - -> Radian - -> [OnelineText u] - -> LocGraphic u -multilineGraphic drawF max_w ang xs = - lift0R1 (centerSpineDisps (length xs) ang) >>= \(disp_top, disp_next) -> - let gs = map (\a -> rot (drawF max_w a) ang) xs - in ignoreAns $ moveStart disp_top $ chainDisplace disp_next gs - --- | Draw left-aligned text. Effictively this is: --- --- > Leftwards for the half the max vector --- > --- > Down to the baseline from the center. --- -onelineALeft :: (Real u, Floating u, InterpretUnit u) - => OnelineGraphicF u -onelineALeft width otext = promoteR2 $ \ctr theta -> - centerToBaseline >>= \down -> - let pt = move down theta ctr - in atRot (rescTextLine $ text_content otext) pt theta - where - vec1 = hvec $ negate $ 0.5 * width - move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang - - --- | Draw center-aligned text. Effictively this is: --- --- > Leftwards for the half the width vector --- > --- > Down to the baseline from the center. --- --- The max_adv is ignored. --- -onelineACenter :: (Real u, Floating u, InterpretUnit u) - => OnelineGraphicF u -onelineACenter _ otext = promoteR2 $ \ctr theta -> - centerToBaseline >>= \down -> - let pt = move down theta ctr - in atRot (rescTextLine $ text_content otext) pt theta - where - vec1 = negateV $ 0.5 *^ oneline_adv otext - move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang - - --- | Draw right-aligned text. Effictively this is: --- --- > Rightwards for the half the max width --- > --- > Leftwards for the width vector --- > --- > Down to the baseline from the center. --- -onelineARight :: (Real u, Floating u, InterpretUnit u) - => OnelineGraphicF u -onelineARight max_w otext = promoteR2 $ \ctr theta -> - centerToBaseline >>= \down -> - let pt = move down theta ctr - in atRot (rescTextLine $ text_content otext) pt theta - where - vec1 = hvec (0.5 * max_w) ^-^ oneline_adv otext - move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang - - - - - --- Note - for multiline text, the bounding box (of one line) is --- always the same size regardless of the alignment of the textlines. --- - --- | Its easy to find top-left and top-right, then bottom-left is --- the vector from top-right to center added to the center. --- Likewise bottom-right is the vector from top-left-to center --- added to the center. Visually this construction forms a bow of --- two triangles meeting at the (rectangle) center. - -orthoBB :: (Real u, Floating u, InterpretUnit u) - => u -> Int -> Radian -> LocQuery u (BoundingBox u) -orthoBB w line_count theta = promoteR1 $ \ctr -> - fmap (0.5*) verticalSpan >>= \hh1 -> - textMargin >>= \(xsep,ysep) -> - centerSpineDisps line_count theta >>= \(disp_top,_) -> - let top_ctr = disp_top ctr - hw = 0.5 * w - tr = displaceOrtho (V2 (hw+xsep) (hh1+ysep)) theta top_ctr - tl = displaceOrtho (V2 (negate $ hw+xsep) (hh1+ysep)) theta top_ctr - bl = ctr .+^ pvec tr ctr - br = ctr .+^ pvec tl ctr - in return $ traceBoundary [tr,tl,bl,br] - - - --- Note - displaceOrtho would be more convenient if it wasn\'t a --- vector. - - - --------------------------------------------------------------------------------- - --- This isn't worth the complexity to get down to one traversal... - --- | Turn the input list of lines of 'EscapedText' into --- 'OnelineText' and return the result list twinned with the --- largest width. --- -linesToInterims :: (InterpretUnit u, Ord u) - => [EscapedText] -> Query (u, [OnelineText u]) -linesToInterims = fmap post . mapM onelineEscText - where - post xs = let vmax = foldr fn 0 xs in (vmax,xs) - fn (OnelineText _ av) wmax = max (advanceH av) wmax - - - - -onelineEscText :: InterpretUnit u => EscapedText -> Query (OnelineText u) -onelineEscText esc = fmap (OnelineText esc) $ textVector esc - - --} diff --git a/src/Wumpus/Drawing/VersionNumber.hs b/src/Wumpus/Drawing/VersionNumber.hs --- a/src/Wumpus/Drawing/VersionNumber.hs +++ b/src/Wumpus/Drawing/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,3,0) +-- > (0,4,0) -- wumpus_drawing_version :: (Int,Int,Int) -wumpus_drawing_version = (0,3,0) +wumpus_drawing_version = (0,4,0) diff --git a/wumpus-drawing.cabal b/wumpus-drawing.cabal --- a/wumpus-drawing.cabal +++ b/wumpus-drawing.cabal @@ -1,5 +1,5 @@ name: wumpus-drawing -version: 0.3.0 +version: 0.4.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -38,47 +38,20 @@ . Changelog: . - v0.2.0 to v0.3.0: + v0.3.0 to v0.4.0: . - * Moved Turtle and Grids into the @Wumpus.Drawing.Extras@ - name-space. Modules here are considered sketches. + * Simplified Trapezium shape so it only produces isosceles + Trapeziums. . - * Re-implemented arrowheads and connectors. + * Added Basis modules. These are \"mid-level\" modules similar + to ones in @Wumpus.Basic.Kernel.Objects@, however they are + considered less general so there are put here where they can + be imported individually (and so not pollute the namespace). . - * Re-implemented monadic path construction. This is now - essentially \"turtle drawing\" with a path trace. + * Removed the Turtle modules. The new @LocTrace@ and @RefTrace@ + modules supercede the Turtle modules. . - * Removed chains - a simplified implementation is now - provided by Wumpus-Basic. . - * Re-implemented and expanded Text. - . - v0.1.0 to v0.2.0: - . - * Added new Shapes. - . - * Move Geometry modules to Wumpus-Basic. - . - * Re-implemented Chains. - . - * Re-implemented LR-Text. Added CatText. - . - v0.1.0: - . - * Initial release - this is a split from @Wumpus-Basic@ making - the (very prototypical - read sub-alpha, unstable...) modules - in the @Drawing@ hierarchy a separate package. - . - * Simplified Chains - chains are now regular lists (though often - infinite). Drawings are made with chains using new zip-like - functions. - . - * Re-worked Shapes. - . - * Re-worked Arrow and Arrow Tip types. - . - * Re-worked ConnectorPaths. - . build-type: Simple stability: highly unstable cabal-version: >= 1.2 @@ -101,19 +74,22 @@ demo/SingleChar.hs, demo/SingleLine.hs, demo/SampleShapes.hs, - demo/Symbols.hs, - demo/TableChains.hs + demo/Symbols.hs library hs-source-dirs: src build-depends: base < 5, containers >= 0.3 && <= 0.6, vector-space >= 0.6 && < 1.0, - wumpus-core >= 0.50.0 && < 0.51.0, - wumpus-basic == 0.17.0 + wumpus-core >= 0.51.0 && < 0.52.0, + wumpus-basic == 0.18.0 exposed-modules: + Wumpus.Drawing.Basis.DrawingPrimitives, + Wumpus.Drawing.Basis.TraceGraphic, + Wumpus.Drawing.Basis.LocTrace, + Wumpus.Drawing.Basis.RefTrace, Wumpus.Drawing.Colour.SVGColours, Wumpus.Drawing.Colour.X11Colours, Wumpus.Drawing.Connectors, @@ -121,18 +97,15 @@ Wumpus.Drawing.Connectors.Base, Wumpus.Drawing.Connectors.BoxConnectors, Wumpus.Drawing.Connectors.ConnectorPaths, - Wumpus.Drawing.Connectors.Loop, Wumpus.Drawing.Dots.AnchorDots, - Wumpus.Drawing.Dots.Marks, + Wumpus.Drawing.Dots.SimpleDots, Wumpus.Drawing.Extras.Axes, + Wumpus.Drawing.Extras.Clip, Wumpus.Drawing.Extras.Grids, - Wumpus.Drawing.Extras.Turtle.TurtleClass, - Wumpus.Drawing.Extras.Turtle.TurtleMonad, + Wumpus.Drawing.Extras.Loop, Wumpus.Drawing.Paths.Absolute, - Wumpus.Drawing.Paths.Base.AbsBuilder, Wumpus.Drawing.Paths.Base.AbsPath, - Wumpus.Drawing.Paths.Base.BuildCommon, - Wumpus.Drawing.Paths.Base.RelBuilder, + Wumpus.Drawing.Paths.Base.PathBuilder, Wumpus.Drawing.Paths.Base.RelPath, Wumpus.Drawing.Paths.Relative, Wumpus.Drawing.Paths.Vamps,