diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -5,60 +5,42 @@ -- Acknowledgment - the Arrow diagram is taken from Ross -- Paterson\'s slides /Arrows and Computation/. +-- NOTE - this example now rather out-of-date. Wumpus-Drawing has +-- some new features to make node/connector drawing a bit easier. module ArrowCircuit where -import Wumpus.Drawing.Arrows -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors import Wumpus.Drawing.Shapes -import Wumpus.Drawing.Text.LRText -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core -import FontLoaderUtils - -import Data.AffineSpace +import Data.AffineSpace -- package: vector-space import System.Directory main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic - writeEPS "./out/arrow_circuit01.eps" pic1 - writeSVG "./out/arrow_circuit01.svg" pic1 +main = simpleFontLoader main1 >> return () -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] - mapM_ putStrLn msgs +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Right times_roman_family ] + printLoadErrors base_metrics let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic - writeEPS "./out/arrow_circuit02.eps" pic1 - writeSVG "./out/arrow_circuit02.svg" pic1 + writeEPS "./out/arrow_circuit.eps" pic1 + writeSVG "./out/arrow_circuit.svg" pic1 -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace times_roman . metricsContext 11 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font times_roman . metricsContext 11 @@ -69,8 +51,11 @@ -- Note `at` currently does not work for Shapes. -circuit_pic :: CtxPicture Double -circuit_pic = drawTracing $ do +circuit_pic :: CtxPicture +circuit_pic = drawTracing body + +body :: TraceDrawing Double () +body = do a1 <- drawi $ rrectangle 12 66 30 `at` P2 0 72 atext a1 "CONST 0" a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60 @@ -79,44 +64,46 @@ atext a3 "+1" a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0 atext a4 "DELAY 0" - connWith connLine (east a1) (east a1 .+^ hvec 76) - connWith connLine (east a2) (east a2 .+^ hvec 180) - connWith connLine (north a2 .+^ vvec 40) (north a2) - connWith connLine (north a3 .+^ vvec 16) (north a3) - connWith connRightVH (south a3) (east a4) - connWith (connRightHVH (-30)) (west a4) (southwest a2) + connWith connline (east a1) ((.+^ hvec 76) $ east a1) + connWith connline (east a2) ((.+^ hvec 180) $ east a2) + connWith connline ((.+^ vvec 40) $ north a2) (north a2) + connWith connline ((.+^ vvec 16) $ north a3) (north a3) + connWith connaright (south a3) (east a4) + connWith connabar (west a4) (southwest a2) ptext (P2 40 10) "next" ptext (P2 152 100) "reset" ptext (P2 252 72) "output" return () - + -- Note - need a variant of /bar/ that draws UDLR only. -connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m - , Real u, Floating u, FromPtSize u ) - => ConnectorPath u -> Point2 u -> Point2 u -> m () -connWith con p0 p1 = localize doublesize $ - drawi_ $ apply2R2 (rightArrow tri45 con) p0 p1 +connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) + , Real u, Floating u, InterpretUnit u ) + => Connector u -> Anchor u -> Anchor u -> m () +connWith con a0 a1 = localize double_point_size $ + drawc a0 a1 (rightArrow tri45 con) -atext :: ( CenterAnchor t, DUnit t ~ u - , Real u, Floating u, FromPtSize u - , TraceM m, DrawingCtxM m, u ~ MonUnit m ) - => t -> String -> m () -atext ancr ss = let pt = center ancr in - drawi_ $ textAlignCenter ss `at` pt +atext :: ( CenterAnchor (t u) + , Real u, Floating u, InterpretUnit u + , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()), u ~ DUnit (t u) ) + => t u -> String -> m () +atext ancr ss = + draw $ ccTextline ss `at` (center ancr) -ptext :: ( Real u, Floating u, FromPtSize u - , TraceM m, DrawingCtxM m, u ~ MonUnit m ) +ptext :: ( Real u, Floating u, InterpretUnit u + , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) => Point2 u -> String -> m () -ptext pt ss = localize (fontAttr times_italic 14) $ - drawi_ $ textAlignCenter ss `at` pt +ptext pt ss = localize (font_attr times_italic 14) $ + draw $ ccTextline ss `at` pt -- Note - return type is a LocImage not a shape... -- -rrectangle :: (Real u, Floating u, FromPtSize u) - => u -> u -> u -> LocImage u (Rectangle u) -rrectangle r w h = - localize (roundCornerFactor $ realToFrac r) $ strokedShape (rectangle w h) +rrectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => Double -> u -> u -> LocImage u (Rectangle u) +rrectangle _r w h = strokedShape (rectangle w h) + -- This should have round corners but they are currently + -- disabled pending a re-think. + {- localize (round_corner_factor r) $ -} diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -2,84 +2,97 @@ module Arrowheads where - -import Wumpus.Drawing.Arrows -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Paths hiding ( length ) +import Wumpus.Drawing.Connectors +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs + import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space import System.Directory main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_ctx arrow_drawing - writeEPS "./out/arrowheads01.eps" pic1 - writeSVG "./out/arrowheads01.svg" pic1 +main = simpleFontLoader main1 >> return () -arrow_drawing :: CtxPicture Double -arrow_drawing = drawTracing $ localize (dashPattern unit_dash_pattern) - $ tableGraphic arrtable +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) arrow_drawing + writeEPS "./out/arrowheads.eps" pic1 + writeSVG "./out/arrowheads.svg" pic1 -arrtable :: [(Arrowhead Double, Arrowhead Double)] + +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 14 + + + +arrow_drawing :: CtxPicture +arrow_drawing = + drawTracing $ localize dotted_line $ tableGraphic arrtable + +arrtable :: [(String, ArrowTip Double)] arrtable = - [ (tri90, tri90) - , (tri60, tri60) - , (tri45, tri45) - , (otri90, otri90) - , (otri60, otri60) - , (otri45, otri45) - , (revtri90, revtri90) - , (revtri60, revtri60) - , (revtri45, revtri45) - , (orevtri90, orevtri90) - , (orevtri60, orevtri60) - , (orevtri45, orevtri45) - , (barb90, barb90) - , (barb60, barb60) - , (barb45, barb45) - , (revbarb90, revbarb90) - , (revbarb60, revbarb60) - , (revbarb45, revbarb45) - , (perp, perp) - , (bracket, bracket) - , (diskTip, diskTip) - , (odiskTip, odiskTip) - , (squareTip, squareTip) - , (osquareTip, osquareTip) - , (diamondTip, diamondTip) - , (odiamondTip, odiamondTip) - , (curveTip, curveTip) - , (revcurveTip, revcurveTip) + [ ("tri90", tri90) + , ("tri60", tri60) + , ("tri45", tri45) + , ("otri90", otri90) + , ("otri60", otri60) + , ("otri45", otri45) + , ("revtri90", revtri90) + , ("revtri60", revtri60) + , ("revtri45", revtri45) + , ("orevtri90", orevtri90) + , ("orevtri60", orevtri60) + , ("orevtri45", orevtri45) + , ("barb90", barb90) + , ("barb60", barb60) + , ("barb45", barb45) + , ("revbarb90", revbarb90) + , ("revbarb60", revbarb60) + , ("revbarb45", revbarb45) + , ("perp", perp) + , ("bracket", bracket) + , ("diskTip", diskTip) + , ("odiskTip", odiskTip) + , ("squareTip", squareTip) + , ("osquareTip", osquareTip) + , ("diamondTip", diamondTip) + , ("odiamondTip", odiamondTip) + , ("diamondWideTip", diamondWideTip) + , ("odiamondWideTip", odiamondWideTip) + , ("curveTip", curveTip) + , ("revcurveTip", revcurveTip) ] -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u () + + +tableGraphic :: [(String, ArrowTip Double)] -> TraceDrawing Double () tableGraphic tips = - draw $ unchainZipWith emptyLocGraphic makeArrowDrawing tips chn `at` start + drawl start $ chain_ chn_alg (map makeArrowDrawing tips) where - chn = tableDown 20 (120,24) - start = P2 0 480 + chn_alg = tableDown 18 (180,24) + start = P2 0 480 std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 18 +std_ctx = fill_colour peru $ standardContext 18 -makeArrowDrawing :: (Real u, Floating u, FromPtSize u) - => (Arrowhead u, Arrowhead u) -> LocGraphic u -makeArrowDrawing (arrl,arrr) = - promoteR1 $ \p0 -> forget $ - connect (leftRightArrow arrl arrr connLine) p0 (mkP1 p0) +makeArrowDrawing :: (String, ArrowTip Double) -> LocGraphic Double +makeArrowDrawing (name, utip) = aconn `oplus` lbl where - mkP1 = (.+^ hvec 100) - -- forget needs a better name, then adding to Wumpus-Basic. - forget = fmap (replaceL uNil) + aconn = promoteR1 $ \pt -> fmap ignoreAns $ + connect (uniformArrow utip connline) pt (displaceH 60 pt) + + lbl = promoteR1 $ \pt -> fmap ignoreAns $ + atStartAddr (textline name) (displaceH 66 pt) WW diff --git a/demo/Automata.hs b/demo/Automata.hs new file mode 100644 --- /dev/null +++ b/demo/Automata.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +module Automata where + +import Wumpus.Drawing.Connectors +import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs +import Wumpus.Drawing.Text.Base.Label + + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Basic.System.FontLoader + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + + +main :: IO () +main = simpleFontLoader main1 >> return () + +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Right times_roman_family ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) automata + writeEPS "./out/automata.eps" pic1 + writeSVG "./out/automata.svg" pic1 + + +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = + snap_grid_factors 60.0 60.0 . set_font times_roman . metricsContext 14 + + +automata :: CtxPicture +automata = udrawTracing (0::Double) $ do + q0 <- nodei (8,0) $ state "q0" + q1 <- drawi $ state "q1" `mat` above_right_of q0 + q2 <- drawi $ state "q2" `mat` below_right_of q0 + q3 <- drawi $ stopstate "q3" `mat` below_right_of q1 + + s0 <- evalQuery $ left_of q0 + + draw $ label_midway_of SE (textline "0") $ straightconn q0 q1 + draw $ label_midway_of SS (textline "0") $ arrloop (center q1) (north q1) + draw $ label_midway_of SW (textline "1") $ straightconn q1 q3 + draw $ label_midway_of NE (textline "1") $ straightconn q0 q2 + draw $ label_midway_of NW (textline "0") $ straightconn q2 q3 + draw $ label_midway_of NN (textline "1") $ arrloop (center q2) (south q2) + draw $ label_atstart_of EE (textline "start") $ astraightconn s0 (west q0) + + return () + + +infixr 1 `mat` + +mat :: LocImage u a -> Query (Point2 u) -> Image u a +mat img mq = mq >>= \pt -> img `at` pt + +state :: String -> DLocImage DCircle +state ss = + localize (set_font times_italic) $ + label_center_of (textline ss) $ strokedShape $ circle 20 + + +stopstate :: String -> DLocImage DCircle +stopstate ss = + localize (set_font times_italic) $ + label_center_of (textline ss) $ dblStrokedShape $ circle 20 + + + +straightconn :: ( Real u, Floating u, InterpretUnit u + , u ~ DUnit a, u ~ DUnit b + , CenterAnchor a, RadialAnchor a + , CenterAnchor b, RadialAnchor b + ) + => a -> b -> Image u (AbsPath u) +straightconn a b = + let (p0,p1) = radialConnectorPoints a b + in connect (rightArrow tri45 connline) p0 p1 + + +astraightconn :: ( Real u, Floating u, InterpretUnit u) + => Anchor u -> Anchor u -> Image u (AbsPath u) +astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1 + + +-- Note - there is a problem with @rightArrow@ as @loop@ +-- manufactures the start and end points... +-- +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 + + + + + + + diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -12,11 +12,9 @@ module ClipPic where -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Paths -import Wumpus.Drawing.Paths.MonadicConstruction -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -30,76 +28,83 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - let pic = runCtxPictureU pic_drawing_ctx big_pic - writeEPS "./out/clip_pic.eps" pic - writeSVG "./out/clip_pic.svg" pic + let pic1 = runCtxPictureU std_ctx $ top_pic `vconcat` clip_pic + writeEPS "./out/clip_pic.eps" pic1 + writeSVG "./out/clip_pic.svg" pic1 -pic_drawing_ctx :: DrawingContext -pic_drawing_ctx = standardContext 14 +std_ctx :: DrawingContext +std_ctx = standardContext 14 -big_pic :: DCtxPicture -big_pic = pic1 `cxpDown` oconcat cpic1 [cpic2, cpic3, cpic4] - -fillPath :: Num u => Path u -> Graphic u -fillPath = filledPath . toPrimPath +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 -pic1 :: DCtxPicture -pic1 = drawTracing $ localize (fillColour medium_slate_blue) $ do - draw $ fillPath path01 - draw $ localize (fillColour powder_blue) $ fillPath path02 - draw $ fillPath path03 - draw $ fillPath path04 +clip_pic :: CtxPicture +clip_pic = drawTracing $ do + mapM_ draw $ [ clip1, clip2, clip3, clip4 ] -background :: RGBi -> DCtxPicture -background rgb = drawTracing $ - draw $ localize (strokeColour rgb) $ ihh `at` P2 0 288 +background :: RGBi -> Graphic Double +background rgb = + fmap ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 where - ihh = unchain 112 emptyLocGraphic iheartHaskell $ tableDown 18 (86,16) + ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell) -cpic1 :: DCtxPicture -cpic1 = clipCtxPicture (toPrimPath path01) (background black) +-- 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) -cpic2 :: DCtxPicture -cpic2 = clipCtxPicture (toPrimPath path02) (background medium_violet_red) +clip2 :: Graphic Double +clip2 = toPrimPath path02 >>= \pp -> clipGraphic pp (background medium_violet_red) -cpic3 :: DCtxPicture -cpic3 = clipCtxPicture (toPrimPath path03) (background black) +clip3 :: Graphic Double +clip3 = toPrimPath path03 >>= \pp -> clipGraphic pp (background black) -cpic4 :: DCtxPicture -cpic4 = clipCtxPicture (toPrimPath path04) (background black) +clip4 :: Graphic Double +clip4 = toPrimPath path04 >>= \pp -> clipGraphic pp (background black) -iheartHaskell :: Num u => FromPtSize u => LocGraphic u +iheartHaskell :: LocGraphic Double iheartHaskell = promoteR1 $ \pt -> - let body = textline "I Haskell" `at` pt - heart = localize (fontFace symbol) $ - textline "&heart;" `at` (pt .+^ hvec 7) + let body = plainTextLine "I Haskell" `at` pt + heart = localize (set_font symbol) $ + plainTextLine "&heart;" `at` (pt .+^ hvec 7) in body `oplus` heart -path01 :: Floating u => Path u -path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) - >> rlineto (vec (-112) 160) - >> hline (-80) - >> rlineto (vec 112 (-160)) - >> rlineto (vec (-112) (-160)) +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)) -path02 :: Floating u => Path u -path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112) - >> rlineto (vec 72 (-112)) - >> hline 80 - >> rlineto (vec (-224) 320) - >> hline (-80) - >> rlineto (vec 112 (-160)) - >> rlineto (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)) -path03 :: Floating u => Path u -path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) +path03 :: AbsPath Double +path03 = evalAbsBuild (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) -path04 :: Floating u => Path u -path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) +path04 :: AbsPath Double +path04 = evalAbsBuild (P2 328 192) $ 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,7 +4,6 @@ import ColourChartUtils -import Wumpus.Drawing.Chains import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -22,28 +21,27 @@ writeSVG "./out/SVGcolours.svg" svg_pic -- let x11_p = runCtxPictureU draw_ctx x11_portrait - writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p + writeEPS "./out/X11colours.eps" $ scale 0.75 0.75 x11_p let x11_l = runCtxPictureU draw_ctx x11_landscape writeSVG "./out/X11colours.svg" x11_l draw_ctx :: DrawingContext draw_ctx = (standardContext 9) -svg :: CtxPicture Double +svg :: CtxPicture svg = makeDrawing 52 all_svg_colours -x11_landscape :: CtxPicture Double +x11_landscape :: CtxPicture x11_landscape = makeDrawing 52 all_x11_colours -x11_portrait :: CtxPicture Double +x11_portrait :: CtxPicture x11_portrait = makeDrawing 72 all_x11_colours -makeDrawing :: Int -> [(String,RGBi)] -> DCtxPicture +makeDrawing :: Int -> [(String,RGBi)] -> CtxPicture makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () -tableGraphic row_count xs = - draw $ unchainZip emptyLocGraphic gs chn `at` pt +tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt where chn = tableDown row_count (152,11) pt = displaceV (fromIntegral $ 11 * row_count) zeroPt @@ -51,9 +49,9 @@ colourSample :: String -> RGBi -> LocGraphic Double -colourSample name rgb = localize (fillColour rgb) $ +colourSample name rgb = localize (fill_colour rgb) $ promoteR1 $ \pt -> oplus (borderedRectangle 15 10 `at` pt) - (textline name `at` displace 20 2 pt) + (plainTextLine name `at` displace 20 2 pt) diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -2,73 +2,87 @@ module Connectors where - -import Wumpus.Drawing.Arrows -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Paths hiding ( length ) +import Wumpus.Drawing.Connectors +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core + + import System.Directory + main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_ctx conn_pic - writeEPS "./out/connectors01.eps" pic1 - writeSVG "./out/connectors01.svg" pic1 +main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) conn_pic + writeEPS "./out/connectors.eps" pic1 + writeSVG "./out/connectors.svg" pic1 + +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 11 -conn_pic :: CtxPicture Double -conn_pic = drawTracing $ tableGraphic $ conntable +conn_pic :: CtxPicture +conn_pic = drawTracing $ localize (dest_arm_len (0.75::Em)) + $ tableGraphic conntable -conntable :: [ConnectorPath Double] +conntable :: [(String, Connector Double)] conntable = - [ connLine - , connRightVH - , connRightHV - , connRightVHV 15 - , connRightHVH 15 - , connIsosceles 25 - , connIsosceles (-25) - , connIsosceles2 15 - , connIsosceles2 (-15) - , connLightningBolt 15 - , connLightningBolt (-15) - , connIsoscelesCurve 25 - , connIsoscelesCurve (-25) - , connSquareCurve - , connUSquareCurve - , connTrapezoidCurve 40 0.5 - , connTrapezoidCurve (-40) 0.5 - , connZSquareCurve - , connUZSquareCurve + [ ("connline", connline) + , ("connarc", connarc) + , ("connhdiagh", connhdiagh) + , ("connvdiagv", connvdiagv) + , ("conndiagh", conndiagh) + , ("conndiagv", conndiagv) + , ("connhdiag", connhdiag) + , ("connvdiag", connvdiag) + , ("connabar", connabar) + , ("connbbar", connbbar) + , ("connaright", connaright) + , ("connbright", connbright) + , ("connhrr", connhrr) + , ("connrrh", connrrh) + , ("connvrr", connvrr) + , ("connrrv", connrrv) + , ("connaloop", connaloop) + , ("connbloop", connbloop) + , ("connhbezier", connhbezier) + , ("connvbezier", connvbezier) ] -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [ConnectorPath u] -> TraceDrawing u () +tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double () tableGraphic conns = - draw $ unchainZipWith emptyLocGraphic makeConnDrawing conns chn `at` start + draw $ chain_ chn_alg (map makeConnDrawing conns) `at` start where - chn = tableDown 10 (120,52) - start = P2 0 520 + chn_alg = tableDown 8 (180,64) + start = P2 0 520 std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 18 +std_ctx = fill_colour peru $ standardContext 18 -makeConnDrawing :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -> LocGraphic u -makeConnDrawing conn = - promoteR1 $ \p0 -> fmap (replaceL uNil) $ - connect (uniformArrow curveTip conn) p0 (mkP1 p0) +makeConnDrawing :: (String, Connector Double) -> DLocGraphic +makeConnDrawing (ss,conn) = + promoteR1 $ \p0 -> fn p0 (displace 60 40 p0) where - mkP1 = displace 100 40 - + fn p0 p1 = disk p0 `oplus` disk p1 `oplus` dcon p0 p1 `oplus` lbl p1 + + disk pt = localize (fill_colour red) $ filledDisk 2 `at` pt + dcon p0 p1 = fmap ignoreAns $ connect (uniformArrow curveTip conn) p0 p1 + + lbl pt = fmap ignoreAns $ atStartAddr (textline ss) (displaceH 10 pt) WW + diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -2,18 +2,12 @@ module DotPic where - - -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots -import Wumpus.Drawing.Text.SafeFonts - -import FontLoaderUtils +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core @@ -21,45 +15,25 @@ import System.Directory - - main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - +main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic - writeEPS "./out/dot_pic01_gs.eps" pic1 - writeSVG "./out/dot_pic01_gs.svg" pic1 + writeEPS "./out/dot_pic.eps" pic1 + writeSVG "./out/dot_pic.svg" pic1 - -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic - writeEPS "./out/dot_pic01_afm.eps" pic1 - writeSVG "./out/dot_pic01_afm.svg" pic1 - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fillColour peru . fontFace helvetica . metricsContext 24 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = fill_colour peru . set_font helvetica . metricsContext 24 -dot_pic :: CtxPicture Double +dot_pic :: CtxPicture dot_pic = drawTracing $ tableGraphic $ [ dotHLine , dotVLine @@ -82,13 +56,12 @@ ] -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [DotLocImage u] -> TraceDrawing u () +tableGraphic :: [DotLocImage Double] -> TraceDrawing Double () tableGraphic imgs = - draw $ unchainZipWith emptyLocGraphic makeDotDrawing imgs chn `at` pt + draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt where row_count = length imgs - chn = tableDown row_count (1,36) + chn_alg = tableDown row_count (1,36) pt = displaceV (fromIntegral $ 36 * row_count) zeroPt @@ -96,20 +69,18 @@ -- This is a bit convoluted - maybe there should be chain-run -- functions for TraceDrawings as well as LocGraphics? -makeDotDrawing :: (Real u, Floating u, FromPtSize u) +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 -> ignoreL $ dotF `at` p1) all_points) + (map (\p1 -> fmap ignoreAns $ dotF `at` p1) all_points) where - dashline = \ps -> localize attrUpd (openStroke $ vertexPath ps) + dashline = \ps -> localize attrUpd $ vertexPP ps >>= openStroke attrUpd :: DrawingContext -> DrawingContext - attrUpd = dashPattern (evenDashes 1) . strokeColour cadet_blue - - ignoreL = fmap (replaceL uNil) + 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] diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -1,66 +1,45 @@ -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} module FeatureModel where -import Wumpus.Drawing.Arrows -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes -import Wumpus.Drawing.Text.LRText -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core -import FontLoaderUtils - - import System.Directory main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." +main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"] - mapM_ putStrLn msgs +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left courier_bold ] + printLoadErrors base_metrics let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model writeEPS "./out/feature_model01.eps" pic1 writeSVG "./out/feature_model01.svg" pic1 -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model - writeEPS "./out/feature_model02.eps" pic1 - writeSVG "./out/feature_model02.svg" pic1 - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace courier_bold . metricsContext 18 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font courier_bold . metricsContext 18 -- Note - I haven't worked out how to do @alternative@, @or@ and -- @repetitions@ yet. -- -feature_model :: CtxPicture Double -feature_model = drawTracing $ do +feature_model :: CtxPicture +feature_model = udrawTracing (0::Double) $ do lea <- widebox "e" $ P2 150 160 lra <- widebox "r" $ P2 60 80 lsa <- widebox "s" $ P2 240 80 @@ -91,46 +70,45 @@ -- Note - ctrCenterLine does not seem to be working well... -makeBox :: (Real u, Floating u, FromPtSize u) +makeBox :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do a <- drawi $ (strokedShape $ rectangle w 20) `at` pt - drawi_ $ textAlignCenter ss `at` center a - -- draw $ filledDisk 2 `at` center a + drawl (center a) $ ccTextline ss return a -box :: (Real u, Floating u, FromPtSize u) +box :: (Real u, Floating u, InterpretUnit u, Tolerance u) => String -> Point2 u -> TraceDrawing u (Box u) box = makeBox 40 -widebox :: (Real u, Floating u, FromPtSize u) +widebox :: (Real u, Floating u, InterpretUnit u, Tolerance u) => String -> Point2 u -> TraceDrawing u (Box u) widebox = makeBox 60 -connWith :: ( Real u, Floating u, FromPtSize u ) - => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u) +connWith :: ( Real u, Floating u, InterpretUnit u ) + => ArrowTip u -> 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 $ apply2R2 (rightArrow arrh connLine) p0 p1 + drawi $ connect (rightArrow arrh connline) p0 p1 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` -cmandatory :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u (Path u) +cmandatory :: ( Real u, Floating u, InterpretUnit u ) + => Box u -> Box u -> TraceDrawing u (AbsPath u) cmandatory = connWith diskTip -coptional :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u (Path u) +coptional :: ( Real u, Floating u, InterpretUnit u ) + => Box u -> Box u -> TraceDrawing u (AbsPath u) coptional = connWith odiskTip -cmandatory_ :: ( Real u, Floating u, FromPtSize u ) +cmandatory_ :: ( Real u, Floating u, InterpretUnit u ) => Box u -> Box u -> TraceDrawing u () cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () -coptional_ :: ( Real u, Floating u, FromPtSize u ) +coptional_ :: ( Real u, Floating u, InterpretUnit u ) => Box u -> Box u -> TraceDrawing u () coptional_ p0 p1 = connWith odiskTip p0 p1 >> return () diff --git a/demo/FontLoaderUtils.hs b/demo/FontLoaderUtils.hs deleted file mode 100644 --- a/demo/FontLoaderUtils.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# OPTIONS -Wall #-} - - -module FontLoaderUtils - ( - processCmdLine - , default_font_loader_help - ) where - - -import Control.Applicative -import Control.Monad -import System.Directory -import System.Console.GetOpt -import System.Environment -import System.IO.Error - - -wumpus_gs_font_dir :: String -wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR" - -wumpus_afm_font_dir :: String -wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR" - - -default_font_loader_help :: String -default_font_loader_help = unlines $ - [ "This example uses glyph metrics loaded at runtime." - , "It can use either the metrics files supplied with GhostScript," - , "or the AFM v4.1 metrics for the Core 14 fonts available from" - , "Adobe's website." - , "" - , "To use GhostScripts font metrics set the environemt variable" - , wumpus_gs_font_dir ++ " to point to the GhostScript fonts" - , "directory (e.g. /usr/share/ghostscript/fonts) or use the command" - , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS" - , "" - , "To use the Adode Core 14 font metrics download the archive from" - , "the Adobe website and set the environment variable " - , wumpus_afm_font_dir ++ " to point to it, or use the command line" - , "flag -- afm=PATH_TO_AFM_CORE14_FONTS" - ] - - -data CmdLineFlag = Help - | GS_FontDir String - | AFM_FontDir String - deriving (Eq,Ord,Show) - -processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath) -processCmdLine help_message = - let options = makeCmdLineOptions help_message in do - args <- getArgs - let (opts, _, _) = getOpt Permute options args - if Help `elem` opts then failk help_message - else succk opts - where - failk msg = putStr msg >> return (Nothing,Nothing) - succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags - - -makeCmdLineOptions :: String -> [OptDescr CmdLineFlag] -makeCmdLineOptions help_message = - [ Option ['h'] ["help"] (NoArg Help) help_message - , Option [] ["afm"] (ReqArg AFM_FontDir "DIR") "AFM v4.1 metrics dir" - , Option [] ["gs"] (ReqArg GS_FontDir "DIR") "GhoshScript font dir" - ] - - -gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) -gsFontDirectory = step - where - step (GS_FontDir p:xs) = doesDirectoryExist p >>= \check -> - if check then return (Just p) else step xs - - step (_:xs) = step xs - step [] = envLookup wumpus_gs_font_dir - - -afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) -afmFontDirectory = step - where - step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> - if check then return (Just p) else step xs - - step (_:xs) = step xs - step [] = envLookup wumpus_afm_font_dir - - -envLookup :: String -> IO (Maybe String) -envLookup name = liftM fn $ try $ getEnv name - where - fn (Left _) = Nothing - fn (Right a) = Just a - diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -2,10 +2,9 @@ module FontPic where -import Wumpus.Drawing.Chains import Wumpus.Drawing.Colour.SVGColours ( steel_blue ) import Wumpus.Drawing.Colour.X11Colours ( indian_red1 ) -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -35,16 +34,17 @@ writeSVG "./out/font_symbol.svg" symbol_pic -fontMsg :: FontFace -> Int -> String -fontMsg ff sz = msgF [] +fontMsg :: FontDef -> Int -> String +fontMsg ft sz = msgF [] where - msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt" + msgF = showString name . showChar ' ' . shows sz . showString "pt" + name = ps_font_name $ font_def_face ft -makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic -makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz) +makeLabel :: RGBi -> FontDef -> Int -> DLocGraphic +makeLabel rgb ft sz = localize upd (plainTextLine $ fontMsg ft sz) where - upd = fillColour rgb . fontAttr ff sz + upd = text_colour rgb . font_attr ft sz -- indian_red1 -- steel_blue @@ -55,35 +55,39 @@ positions :: [Int] positions = [0, 12, 27, 49, 78, 122] - -pointChain :: LocChain Double -pointChain = verticalSteps $ map (fromIntegral . (+2)) point_sizes +-- Note - this chain might be worth putting in a library... +pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2 +pointChain fn = chain chn_alg $ map fn point_sizes + where + chn_alg = linear $ 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) -fontGraphic :: RGBi -> FontFace -> DLocGraphic -fontGraphic rgb ff = - unchainZipWith emptyLocGraphic mkGF point_sizes pointChain +fontGraphic :: RGBi -> FontDef -> DLocGraphic +fontGraphic rgb ft = locGraphic_ $ pointChain mkGF where - mkGF sz = makeLabel rgb ff sz + mkGF sz = makeLabel rgb ft sz std_ctx :: DrawingContext std_ctx = standardContext 10 -fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture +fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $ - draw $ unchainZipWith emptyLocGraphic (uncurry fontGraphic) xs chn `at` start + draw $ chain_ chn_alg (map (uncurry fontGraphic) xs) `at` start where - chn = tableDown 4 (1,180) - start = P2 0 (4*180) + chn_alg = tableDown 4 (1,180) + start = P2 0 (4*180) -------------------------------------------------------------------------------- -- Times -times_cxpic :: CtxPicture Double +times_cxpic :: CtxPicture times_cxpic = fontDrawing [ (steel_blue, times_roman) , (indian_red1, times_italic) @@ -91,7 +95,7 @@ , (indian_red1, times_bold_italic) ] -helvetica_cxpic :: CtxPicture Double +helvetica_cxpic :: CtxPicture helvetica_cxpic = fontDrawing [ (steel_blue, helvetica) , (indian_red1, helvetica_oblique) @@ -103,7 +107,7 @@ -------------------------------------------------------------------------------- -courier_cxpic :: CtxPicture Double +courier_cxpic :: CtxPicture courier_cxpic = fontDrawing [ (steel_blue, courier) , (indian_red1, courier_oblique) @@ -115,6 +119,6 @@ -------------------------------------------------------------------------------- -symbol_cxpic :: CtxPicture Double +symbol_cxpic :: CtxPicture symbol_cxpic = fontDrawing [ (steel_blue, symbol) ] diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs --- a/demo/LeftRightText.hs +++ b/demo/LeftRightText.hs @@ -15,79 +15,54 @@ module LeftRightText where -import FontLoaderUtils import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.Marks -import Wumpus.Drawing.Text.LRText -import Wumpus.Drawing.Text.SafeFonts - +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core import System.Directory - main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx gs_metrics) text_pic - writeEPS "./out/lr_text01.eps" pic1 - writeSVG "./out/lr_text01.svg" pic1 - -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic2 = runCtxPictureU (makeCtx afm_metrics) text_pic - writeEPS "./out/lr_text02.eps" pic2 - writeSVG "./out/lr_text02.svg" pic2 +main = simpleFontLoader main1 >> return () +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) text_pic + writeEPS "./out/left_right_text.eps" pic1 + writeSVG "./out/left_right_text.svg" pic1 -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace helvetica . metricsContext 14 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 15 -text_pic :: CtxPicture Double -text_pic = drawTracing $ do - drawi_ $ (fn left_text) `at` P2 0 400 - drawi_ $ (fn center_text) `at` P2 150 400 - drawi_ $ (fn right_text) `at` P2 300 400 - drawi_ $ (fn blank_text) `at` P2 0 300 - drawi_ $ (fn ne_oneline) `at` P2 150 300 - drawi_ $ (fn cc_oneline) `at` P2 300 300 +text_pic :: CtxPicture +text_pic = udrawTracing (0::Double) $ localize text_margin_loose $ do + draw $ (fn left_text) `at` P2 0 400 + draw $ (fn center_text) `at` P2 150 400 + draw $ (fn right_text) `at` P2 300 400 + draw $ (fn blank_text) `at` P2 0 300 + draw $ (fn ne_oneline) `at` P2 150 300 + draw $ (fn cc_oneline) `at` P2 300 300 - drawi_ $ (fn sw_oneline) `at` P2 0 200 - drawi_ $ (fn ss_oneline) `at` P2 150 200 - drawi_ $ (fn se_oneline) `at` P2 300 200 - drawi_ $ (fn swr_multi) `at` P2 0 100 - drawi_ $ (fn ssr_multi) `at` P2 150 100 - drawi_ $ (fn ner_multi) `at` P2 300 100 - drawi_ $ (fn rleft_text) `at` P2 0 (-75) - drawi_ $ (fn rcenter_text) `at` P2 150 (-75) - drawi_ $ (fn rright_text) `at` P2 300 (-75) + draw $ (fn sw_oneline) `at` P2 0 200 + draw $ (fn ss_oneline) `at` P2 150 200 + draw $ (fn se_oneline) `at` P2 300 200 + draw $ (fn swr_single) `at` P2 0 100 + draw $ (fn ssr_single) `at` P2 150 100 + draw $ (fn ner_single) `at` P2 300 100 draw $ redPlus `at` P2 0 400 draw $ redPlus `at` P2 150 400 @@ -108,78 +83,67 @@ where fn = illustrateBoundedLocGraphic -redPlus :: (Fractional u, FromPtSize u) => LocGraphic u -redPlus = localize (strokeColour red) markPlus +redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u +redPlus = localize (stroke_colour red) markPlus -- single line -- ne_oneline :: BoundedLocGraphic Double -ne_oneline = singleLine "north east" `startPos` NE +ne_oneline = textline "north east" `startAddr` NE -- single line -- se_oneline :: BoundedLocGraphic Double -se_oneline = singleLine "south east" `startPos` SE +se_oneline = textline "south east" `startAddr` SE -- single line -- ss_oneline :: BoundedLocGraphic Double -ss_oneline = singleLine "south" `startPos` SS +ss_oneline = textline "south" `startAddr` SS -- single line -- sw_oneline :: BoundedLocGraphic Double -sw_oneline = singleLine "south west" `startPos` SW +sw_oneline = textline "south west" `startAddr` SW --- multi line + +-- single line rot -- -ssr_multi :: BoundedLocGraphic Double -ssr_multi = multiAlignCenter (0.25*pi) "south rot45" `startPos` SS +ssr_single :: BoundedLocGraphic Double +ssr_single = rtextline (0.25*pi) "south rot45" `startAddr` SS --- multi line +-- single line rot -- -swr_multi :: BoundedLocGraphic Double -swr_multi = multiAlignCenter (0.25*pi) "south west rot45" `startPos` SW +swr_single :: BoundedLocGraphic Double +swr_single = rtextline (0.25*pi) "south west rot45" `startAddr` SW --- multi line +-- single line rot -- -ner_multi :: BoundedLocGraphic Double -ner_multi = multiAlignCenter (0.25*pi) "north east rot45" `startPos` NE +ner_single :: BoundedLocGraphic Double +ner_single = rtextline (0.25*pi) "north east rot45" `startAddr` NE cc_oneline :: BoundedLocGraphic Double -cc_oneline = rsingleLine 0 "Center-center..." `startPos` CENTER +cc_oneline = ccTextline "Center-center..." blank_text :: BoundedLocGraphic Double -blank_text = multiAlignCenter 0 "" `startPos` CENTER +blank_text = blcTextline "" left_text :: BoundedLocGraphic Double -left_text = multiAlignLeft 0 dummy_text `startPos` CENTER +left_text = multiAlignLeft dummy_text `startAddr` CENTER right_text :: BoundedLocGraphic Double -right_text = multiAlignRight 0 dummy_text `startPos` CENTER +right_text = multiAlignRight dummy_text `startAddr` CENTER center_text :: BoundedLocGraphic Double -center_text = multiAlignCenter 0 dummy_text `startPos` CENTER - - -rleft_text :: BoundedLocGraphic Double -rleft_text = multiAlignLeft (0.25*pi) dummy_text `startPos` CENTER - - -rright_text :: BoundedLocGraphic Double -rright_text = multiAlignRight (0.25*pi) dummy_text `startPos` CENTER - -rcenter_text :: BoundedLocGraphic Double -rcenter_text = multiAlignCenter (0.25*pi) dummy_text `startPos` CENTER - +center_text = multiAlignCenter dummy_text `startAddr` 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 @@ -7,18 +7,14 @@ module PetriNet where -import Wumpus.Drawing.Arrows import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Connectors import Wumpus.Drawing.Shapes -import Wumpus.Drawing.Text.SafeFonts -import Wumpus.Drawing.Text.LRText - -import FontLoaderUtils +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core @@ -26,135 +22,117 @@ import System.Directory - - main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." +main = simpleFontLoader main1 >> return () -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"] - mapM_ putStrLn msgs +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Right helvetica_family ] + printLoadErrors base_metrics let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net - writeEPS "./out/petri_net01.eps" pic1 - writeSVG "./out/petri_net01.svg" pic1 + writeEPS "./out/petri_net.eps" pic1 + writeSVG "./out/petri_net.svg" pic1 -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net - writeEPS "./out/petri_net02.eps" pic1 - writeSVG "./out/petri_net02.svg" pic1 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 14 -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace helvetica . metricsContext 14 - +petri_net :: CtxPicture +petri_net = udrawTracing (0::Double) $ do + pw <- drawi $ place `at` (P2 0 140) + tu1 <- drawi $ transition `at` (P2 70 140) + rtw <- drawi $ place `at` (P2 140 140) + tu2 <- drawi $ transition `at` (P2 210 140) + w <- drawi $ place `at` (P2 280 140) + tu3 <- drawi $ transition `at` (P2 350 140) + res <- drawi $ place `at` (P2 280 70) + pr <- drawi $ place `at` (P2 0 0) + tl1 <- drawi $ transition `at` (P2 70 0) + rtr <- drawi $ place `at` (P2 140 0) + tl2 <- drawi $ transition `at` (P2 210 0) + r <- drawi $ place `at` (P2 280 0) + tl3 <- drawi $ transition `at` (P2 350 0) -petri_net :: DCtxPicture -petri_net = drawTracing $ do - pw <- place 0 140 - tu1 <- transition 70 140 - rtw <- place 140 140 - tu2 <- transition 210 140 - w <- place 280 140 - tu3 <- transition 350 140 - res <- place 280 70 - pr <- place 0 0 - tl1 <- transition 70 0 - rtr <- place 140 0 - tl2 <- transition 210 0 - r <- place 280 0 - tl3 <- transition 350 0 - connector' (east pw) (west tu1) - connector' (east tu1) (west rtw) - connector' (east rtw) (west tu2) - connector' (east tu2) (west w) - connector' (east w) (west tu3) - connectorC 32 (north tu3) (north pw) - connector' (east pr) (west tl1) - connector' (east tl1) (west rtr) - connector' (east rtr) (west tl2) - connector' (east tl2) (west r) - connector' (east r) (west tl3) - connectorC (-32) (south tl3) (south pr) - connector' (southwest res) (northeast tl2) - connector' (northwest tl3) (southeast res) - connectorD 6 (southwest tu3) (northeast res) - connectorD (-6) (southwest tu3) (northeast res) - connectorD 6 (northwest res) (southeast tu2) - connectorD (-6) (northwest res) (southeast tu2) + drawc (east pw) (west tu1) $ straightconn + drawc (east tu1) (west rtw) $ straightconn + drawc (east rtw) (west tu2) $ straightconn + drawc (east tu2) (west w) $ straightconn + drawc (east w) (west tu3) $ straightconn + drawc (north tu3) (north pw) $ connectorC + drawc (east pr) (west tl1) $ straightconn + drawc (east tl1) (west rtr) $ straightconn + drawc (east rtr) (west tl2) $ straightconn + drawc (east tl2) (west r) $ straightconn + drawc (east r) (west tl3) $ straightconn + drawc (south tl3) (south pr) $ connectorC' + drawc (southwest res) (northeast tl2) $ straightconn + drawc (northwest tl3) (southeast res) $ straightconn + drawc (southwest tu3) (northeast res) $ connectorD + drawc (southwest tu3) (northeast res) $ connectorD' + drawc (northwest res) (southeast tu2) $ connectorD + drawc (northwest res) (southeast tu2) $ connectorD' draw $ lblParensParens `at` (P2 (-36) 150) draw $ lblParensParens `at` (P2 300 60) draw $ lblParensParensParens `at` (P2 (-52) (-14)) - draw $ lblBold "processing_w" `at` (projectAnchor south 12 pw) - draw $ lblBold "ready_to_write" `at` (projectAnchor south 12 rtw) - draw $ lblBold "writing" `at` (projectAnchor south 12 w) - draw $ lblBold' "resource" `at` (P2 300 72) - draw $ lblBold "processing_r" `at` (projectAnchor north 12 pr) - draw $ lblBold "ready_to_read" `at` (projectAnchor north 12 rtr) - draw $ lblBold "reading" `at` (projectAnchor north 12 r) + drawl (projectAnchor south 12 pw) $ lblBold "processing_w" + drawl (projectAnchor south 12 rtw) $ lblBold "ready_to_write" + drawl (projectAnchor south 12 w) $ lblBold "writing" + draw $ lblBold "resource" `at` (P2 300 72) + drawl (projectAnchor north 12 pr) $ lblBold "processing_r" + drawl (projectAnchor north 12 rtr) $ lblBold "ready_to_read" + drawl (projectAnchor north 12 r) $ lblBold "reading" + return () -greenFill :: DrawingCtxM m => m a -> m a -greenFill = localize (fillColour lime_green) +greenFill :: LocImage u a -> LocImage u a +greenFill = localize (fill_colour lime_green) -place :: ( Real u, Floating u, FromPtSize u - , DrawingCtxM m, TraceM m, u ~ MonUnit m ) - => u -> u -> m (Circle u) -place x y = greenFill $ drawi $ (borderedShape $ circle 14) `at` P2 x y -transition :: ( Real u, Floating u, FromPtSize u - , DrawingCtxM m, TraceM m, u ~ MonUnit m ) - => u -> u -> m (Rectangle u) -transition x y = - greenFill $ drawi $ (borderedShape $ rectangle 32 22) `at` P2 x y +place :: DLocImage (Circle Double) +place = greenFill $ borderedShape $ circle 14 +transition :: DLocImage (Rectangle Double) +transition = greenFill $ borderedShape $ rectangle 32 22 -connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m - , Real u, Floating u, FromPtSize u ) - => Point2 u -> Point2 u -> m () -connector' p0 p1 = - drawi_ $ apply2R2 (rightArrow tri45 connLine) p0 p1 -connectorC :: ( Real u, Floating u, FromPtSize u - , DrawingCtxM m, TraceM m, u ~ MonUnit m ) - => u -> Point2 u -> Point2 u -> m () -connectorC v p0 p1 = - drawi_ $ apply2R2 (rightArrow tri45 (connRightVHV v)) p0 p1 +straightconn :: ConnectorGraphic Double +straightconn = connectorGraphic_ $ rightArrow tri45 connline -connectorD :: ( Real u, Floating u, FromPtSize u - , DrawingCtxM m, TraceM m, u ~ MonUnit m ) - => u -> Point2 u -> Point2 u -> m () -connectorD u p0 p1 = - drawi_ $ apply2R2 (rightArrow tri45 (connIsosceles u)) p0 p1 +connectorC :: ConnectorGraphic Double +connectorC = + connectorGraphic_ $ localize (uniform_arm_len (30::Double)) + $ rightArrow tri45 connbbar -lblParensParens :: Num u => LocGraphic u -lblParensParens = localize (fontFace helvetica) $ textline "(),()" +connectorC' :: ConnectorGraphic Double +connectorC' = + connectorGraphic_ $ localize (uniform_arm_len (30::Double)) + $ rightArrow tri45 connabar -lblParensParensParens :: Num u => LocGraphic u -lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()" +connectorD :: ConnectorGraphic Double +connectorD = connectorGraphic_ $ rightArrow tri45 connarc +connectorD' :: ConnectorGraphic Double +connectorD' = + connectorGraphic_ $ localize (conn_arc_angle $ negate $ pi / 12) + $ rightArrow tri45 connarc -lblBold' :: Num u => String -> LocGraphic u -lblBold' ss = localize (fontFace helvetica_bold) $ textline ss +lblParensParens :: DLocGraphic +lblParensParens = + locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),()" -lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u -lblBold ss = localize (fontFace helvetica_bold) $ - ignoreAns $ textAlignCenter ss +lblParensParensParens :: DLocGraphic +lblParensParensParens = + locGraphic_ $ localize (set_font helvetica) $ ccTextline "(),(),()" + + + +lblBold :: String -> DLocGraphic +lblBold ss = + locGraphic_ $ 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 @@ -1,66 +1,43 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} module SampleShapes where -import FontLoaderUtils - import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.Marks import Wumpus.Drawing.Shapes -import Wumpus.Drawing.Text.LRText -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript - +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core import Control.Monad import System.Directory - main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/shapes/" - maybe gs_failk (makeGSPicture shape_list) $ mb_gs - maybe afm_failk (makeAfmPicture shape_list) $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - +main = simpleFontLoader main1 >> return () -makeGSPicture :: ShapeList -> FilePath -> IO () -makeGSPicture shapes font_dir = do - putStrLn "Using GhostScript metrics..." - (gs_metrics, msgs) <- loadGSMetrics font_dir ["Courier"] - mapM_ putStrLn msgs - mapM_ (out1 gs_metrics) shapes +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/shapes/" + base_metrics <- loader [ Left courier ] + printLoadErrors base_metrics + let ctx = makeCtx base_metrics + mapM_ (out1 ctx) shape_list where - out1 gs_metrics (name, shape_pic) = do - let pic1 = runCtxPictureU (makeCtx gs_metrics) $ shape_pic name + out1 ctx (name, shape_pic) = do + let pic1 = runCtxPictureU ctx $ shape_pic name writeEPS ("./out/shapes/" ++ name ++ "01.eps") pic1 writeSVG ("./out/shapes/" ++ name ++ "01.svg") pic1 -makeAfmPicture :: ShapeList -> FilePath -> IO () -makeAfmPicture shapes font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Courier"] - mapM_ putStrLn msgs - mapM_ (out1 afm_metrics) shapes - where - out1 afm_metrics (name, shape_pic) = do - let pic1 = runCtxPictureU (makeCtx afm_metrics) $ shape_pic name - writeEPS ("./out/shapes/" ++ name ++ "02.eps") pic1 - writeSVG ("./out/shapes/" ++ name ++ "02.svg") pic1 - -type ShapeList = [(String, (String -> DCtxPicture))] +type ShapeList = [(String, (String -> CtxPicture))] shape_list :: ShapeList @@ -96,10 +73,10 @@ triangle 300 150 ) ] -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace courier . metricsContext 16 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font courier . metricsContext 16 -rotate05 :: Rotate a => a -> a +rotate05 :: Rotate a => Image u a -> Image u a rotate05 = rotate (d2r (5::Double)) -- Extra elaboration... @@ -107,26 +84,27 @@ voidExtra :: a -> TraceDrawing u () voidExtra _ = return () -apexAnchor :: ( Real u, Floating u, FromPtSize u - , ApexAnchor a - , u ~ DUnit a ) + + +apexAnchor :: ( Real u, Floating u, InterpretUnit u + , ApexAnchor a, u ~ DUnit a) => a -> TraceDrawing u a apexAnchor a = do draw $ label EAST "(apex)" `at` apex a return a -bottomCorners :: ( Real u, Floating u, FromPtSize u - , BottomCornerAnchor a - , u ~ DUnit a ) +bottomCorners :: ( Real u, Floating u, InterpretUnit u + , BottomCornerAnchor a, u ~ DUnit a + ) => a -> TraceDrawing u a bottomCorners a = do draw $ label SOUTH_WEST "(bottom left)" `at` bottomLeftCorner a draw $ label SOUTH_EAST "(bottom right)" `at` bottomRightCorner a return a -topCorners :: ( Real u, Floating u, FromPtSize u - , TopCornerAnchor a - , u ~ DUnit a ) +topCorners :: ( Real u, Floating u, InterpretUnit u + , TopCornerAnchor a, u ~ DUnit a + ) => a -> TraceDrawing u a topCorners a = do draw $ label NORTH_WEST "(top left)" `at` topLeftCorner a @@ -134,9 +112,9 @@ return a -midPoints :: ( Real u, Floating u, FromPtSize u - , SideMidpointAnchor a - , u ~ DUnit a ) +midPoints :: ( Real u, Floating u, InterpretUnit u + , SideMidpointAnchor a, u ~ DUnit a + ) => Int -> a -> TraceDrawing u a midPoints n a = mapM_ mf [1..n] >> return a where @@ -146,12 +124,17 @@ -shapePic :: ( CenterAnchor a, CardinalAnchor a, CardinalAnchor2 a - , RadialAnchor a - , Scale a, Rotate a - , DUnit a ~ Double) - => (a -> DTraceDrawing b) -> DShape a -> String -> DCtxPicture -shapePic mf sh name = drawTracing $ do +shapePic :: ( Functor t + , CenterAnchor (t Double) + , CardinalAnchor (t Double) + , CardinalAnchor2 (t Double) + , RadialAnchor (t Double) + , Scale (t Double) + , Rotate (t Double) + , Double ~ DUnit (t Double) + ) + => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture +shapePic mf sh name = udrawTracing (0::Double) $ do a1 <- localize shapeSty $ drawi $ uniformScale 2 $ rotate05 $ shape `at` (P2 100 0) draw $ label NORTH "(center)" `at` center a1 @@ -171,7 +154,7 @@ return () where shape = strokedShape $ setDecoration textF sh - textF = lift1R2 $ ignoreAns (multiAlignCenter 0 name `startPos` CENTER) + textF = lift1R2 $ locGraphic_ (startAddr (multiAlignCenter name) CENTER) deg10 = d2r (10::Double) deg110 = d2r (110::Double) @@ -184,23 +167,23 @@ shapeSty :: DrawingContextF -shapeSty = strokeColour light_steel_blue . ultrathick +shapeSty = stroke_colour light_steel_blue . line_ultra_thick -label :: (Real u, Floating u, FromPtSize u) - => Cardinal -> String -> LocGraphic u +label :: (Real u, Floating u, InterpretUnit u) + => Cardinal -> String -> LocGraphic u label cpos ss = markX `oplus` msg where (rpos,fn) = go cpos - msg = ignoreAns $ moveStart (fn 10) $ - multiAlignCenter 0 ss `startPos` rpos + msg = locGraphic_ $ moveStart (fn 10) $ + startAddr (multiAlignCenter ss) rpos - go NORTH = (SS, northwards) - go NORTH_EAST = (SW, northeastwards) - go EAST = (WW, eastwards) - go SOUTH_EAST = (NW, southeastwards) - go SOUTH = (NN, southwards) - go SOUTH_WEST = (NE, southwestwards) - go WEST = (EE, westwards) - go NORTH_WEST = (SE, northwestwards) + 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) diff --git a/demo/SingleChar.hs b/demo/SingleChar.hs new file mode 100644 --- /dev/null +++ b/demo/SingleChar.hs @@ -0,0 +1,70 @@ +{-# OPTIONS -Wall #-} + + +module SingleChar where + + +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Basic.System.FontLoader + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + +main :: IO () +main = simpleFontLoader main1 >> return () + +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01 + writeEPS "./out/single_char.eps" pic1 + writeSVG "./out/single_char.svg" pic1 + + +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 18 + + + +drawing01 :: CtxPicture +drawing01 = drawTracing $ localize (fill_colour red) $ mf + + +-- Note - Baseline positions not meaningful for multiline text + +mf :: TraceDrawing Double () +mf = localize (text_margin 6.0 6.0) $ do + draw $ (fn SS $ posChar 'S') `at` zeroPt + draw $ redPlus `at` zeroPt + + draw $ (fn NN $ posChar 'N') `at` P2 40 0 + draw $ redPlus `at` P2 40 0 + + draw $ (fn EE $ posChar 'E') `at` P2 80 0 + draw $ redPlus `at` P2 80 0 + + draw $ (fn WW $ posChar 'W') `at` P2 120 0 + draw $ redPlus `at` P2 120 0 + + draw $ (fn CENTER $ posChar 'C') `at` P2 160 0 + draw $ redPlus `at` P2 160 0 + + draw $ (fn NE $ posChar 'X') `at` P2 200 0 + draw $ redPlus `at` P2 200 0 + + where + fn addr obj = illustrateBoundedLocGraphic (runPosObjectR2 obj `startAddr` addr) + + +redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u +redPlus = localize (stroke_colour red) markPlus + diff --git a/demo/SingleLine.hs b/demo/SingleLine.hs --- a/demo/SingleLine.hs +++ b/demo/SingleLine.hs @@ -3,15 +3,12 @@ module SingleLine where -import FontLoaderUtils - import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Text.LRText -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.DirectionZero +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.System.FontLoader.Afm -import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Basic.System.FontLoader import Wumpus.Core -- package: wumpus-core @@ -19,46 +16,29 @@ main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runCtxPictureU (makeCtx gs_metrics) drawing01 - writeEPS "./out/single_line01.eps" pic1 - writeSVG "./out/single_line01.svg" pic1 +main = simpleFontLoader main1 >> return () -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic2 = runCtxPictureU (makeCtx afm_metrics) drawing01 - writeEPS "./out/single_line02.eps" pic2 - writeSVG "./out/single_line02.svg" pic2 +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left helvetica ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) drawing01 + writeEPS "./out/single_line.eps" pic1 + writeSVG "./out/single_line.svg" pic1 -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace helvetica . metricsContext 12 +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font helvetica . metricsContext 12 -drawing01 :: DCtxPicture -drawing01 = drawTracing $ localize (fillColour red) $ mf +drawing01 :: CtxPicture +drawing01 = drawTracing $ localize (fill_colour red) $ mf -mf :: (Real u, Floating u, FromPtSize u) => TraceDrawing u () +mf :: TraceDrawing Double () mf = do draw $ testDraw NN `at` (P2 0 200) draw $ testDraw SS `at` (P2 75 200) @@ -71,10 +51,10 @@ draw $ testDraw CENTER `at` (P2 0 0) -testDraw :: (Real u, Floating u, FromPtSize u) => RectPosition -> LocGraphic u -testDraw rpos = filledDisk 2 `oplus` (ignoreAns ans) +testDraw :: RectAddress -> LocGraphic Double +testDraw rpos = filledDisk 2 `oplus` (locGraphic_ ans) where - ans = singleLine "Qwerty" `startPos` rpos + ans = textline "Qwerty" `startAddr` rpos diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -2,8 +2,7 @@ module Symbols where -import Wumpus.Drawing.Chains -import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -21,7 +20,7 @@ std_ctx :: DrawingContext -std_ctx = fontFace times_roman $ standardContext 12 +std_ctx = set_font times_roman $ standardContext 12 -- Because the font changes, we draw the all the symbols in one @@ -29,16 +28,16 @@ -- generate better PostScript as there are less changes to the -- /graphics state/. -- -symbols :: DCtxPicture -symbols = drawTracing $ do - draw $ localize (fontFace symbol) $ - unchainZipWith emptyLocGraphic sdraw all_letters chn `at` start - draw $ unchainZipWith emptyLocGraphic ldraw all_letters chn `at` start +symbols :: CtxPicture +symbols = udrawTracing (0::Double) $ do + localize (set_font symbol) $ fontDelta $ draw $ + chain_ chn_alg (map sdraw all_letters) `at` start + fontDelta $ draw $ chain chn_alg (map ldraw all_letters) `at` start where - chn = tableDown 30 (100,20) + chn_alg = tableDown 30 (100,20) start = P2 0 (30*20) - sdraw (s,_) = textline s - ldraw (_,name) = moveStart (displaceH 16) (textline name) + sdraw (s,_) = plainTextLine s + ldraw (_,name) = moveStart (displaceH 16) (plainTextLine name) all_letters :: [(String, String)] diff --git a/demo/TableChains.hs b/demo/TableChains.hs --- a/demo/TableChains.hs +++ b/demo/TableChains.hs @@ -4,7 +4,7 @@ import Wumpus.Drawing.Colour.SVGColours -import Wumpus.Drawing.Grids +import Wumpus.Drawing.Extras.Grids import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -19,32 +19,8 @@ writeSVG "./out/table_chains01.svg" pic1 std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 18 - -table_drawing :: CtxPicture Double -table_drawing = drawTracing $ do --- tableGraphic - draw $ connect (interiorGrid 10) (P2 (-20) (-20)) (P2 150 80) - draw $ grid (3,2) 20 `at` (P2 300 60) - -{- -tableGraphic :: (Real u, Floating u, FromPtSize u) - => TraceDrawing u () -tableGraphic = do - draw $ filledDisk 3 `at` dstart - draw $ filledDisk 3 `at` rstart - zipchainWith (textline . show) [1..20::Int] downs - zipchainWith (textline . show) [1..20::Int] rights - where - downs = tableDown 4 (36,24) dstart - rights = tableRight 5 (36,24) rstart - - dstart = P2 0 200 -- note grows down... - rstart = P2 240 200 -- ditto --} - - - - - +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/Arrows.hs b/src/Wumpus/Drawing/Arrows.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim module for arrow connectors and arrowheads. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows - ( - - module Wumpus.Drawing.Arrows.Tips - , module Wumpus.Drawing.Arrows.Connectors - - ) where - -import Wumpus.Drawing.Arrows.Tips -import Wumpus.Drawing.Arrows.Connectors - - diff --git a/src/Wumpus/Drawing/Arrows/Connectors.hs b/src/Wumpus/Drawing/Arrows/Connectors.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows/Connectors.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Draw arrows. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows.Connectors - ( - - ArrowConnector - , leftArrow - , rightArrow - , leftRightArrow - , uniformArrow - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Arrows.Tips -import Wumpus.Drawing.Paths - - - --- An arrowhead always know how to draw itself (filled triangle, --- stroked barb, etc.) --- --- A Path is currently always drawn with openStroke, --- eventually there might be scope for drawing --- e.g. parallel lines ==== --- - - --- | A connector with arrow tips. The connector is an /Image/, --- drawing it returns the path - positions can be taken on the --- path (e.g. @midpoint@) for further decoration. --- -type ArrowConnector u = ConnectorImage u (Path u) - - --- | Connector with an arrow tip at the start point \/ left. --- -leftArrow :: (Real u, Floating u) - => Arrowhead u -> ConnectorPath u -> ArrowConnector u -leftArrow arrh conn = promoteR2 $ \p0 p1 -> - connect conn p0 p1 >>= \cpath -> - arrowhead_retract_dist arrh >>= \dl -> - let path1 = shortenL dl cpath - ang = directionL path1 - g1 = openStroke $ toPrimPath path1 - g2 = atRot (arrowhead_draw arrh) p0 ang - in fmap (replaceL cpath) $ g1 `oplus` g2 - --- Note - returns original path - - --- | Connector with an arrow tip at the end point \/ right. --- -rightArrow :: (Real u, Floating u) - => Arrowhead u -> ConnectorPath u -> ArrowConnector u -rightArrow arrh conn = promoteR2 $ \p0 p1 -> - connect conn p0 p1 >>= \cpath -> - arrowhead_retract_dist arrh >>= \dr -> - let path1 = shortenR dr cpath - ang = directionR path1 - g1 = openStroke $ toPrimPath path1 - g2 = atRot (arrowhead_draw arrh) p1 ang - in fmap (replaceL cpath) $ g1 `oplus` g2 - - - --- | Connector with two arrow tips, possibly different. --- -leftRightArrow :: (Real u, Floating u) - => Arrowhead u -> Arrowhead u -> ConnectorPath u - -> ArrowConnector u -leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 -> - connect conn p0 p1 >>= \cpath -> - arrowhead_retract_dist arrL >>= \dL -> - arrowhead_retract_dist arrR >>= \dR -> - let path1 = shortenPath dL dR cpath - angL = directionL path1 - angR = directionR path1 - g1 = openStroke $ toPrimPath path1 - gL = atRot (arrowhead_draw arrL) p0 angL - gR = atRot (arrowhead_draw arrR) p1 angR - in fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR - - --- | Connector with the same arrow tip at both ends. --- -uniformArrow :: (Real u, Floating u) - => Arrowhead u -> ConnectorPath u -> ArrowConnector u -uniformArrow arrh cp = leftRightArrow arrh arrh cp - diff --git a/src/Wumpus/Drawing/Arrows/Tips.hs b/src/Wumpus/Drawing/Arrows/Tips.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows/Tips.hs +++ /dev/null @@ -1,515 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows.Tips --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Anchor points on shapes. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows.Tips - ( - - - Arrowhead(..) - - - , tri90 - , tri60 - , tri45 - , otri90 - , otri60 - , otri45 - - , revtri90 - , revtri60 - , revtri45 - , orevtri90 - , orevtri60 - , orevtri45 - - , barb90 - , barb60 - , barb45 - , revbarb90 - , revbarb60 - , revbarb45 - - , perp - - , bracket - - , diskTip - , odiskTip - , squareTip - , osquareTip - , diamondTip - , odiamondTip - - , curveTip - , revcurveTip - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Paths - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative - - --- | Encode an arrowhead as a Graphic and a retract distance - --- lines should be shortened for certain drawings (e.g. open --- triangles). --- --- The retract distance is context sensitive - usually just on --- the markHeight (or halfMarkHeight) so it has to be calculated --- w.r.t. the DrawingCtx. --- -data Arrowhead u = Arrowhead - { arrowhead_retract_dist :: DrawingInfo u - , arrowhead_draw :: LocThetaGraphic u - } - - --- Design note - this used to be a newtype wrapper over a --- LocThetaImage that returned retract distance. But, considering --- the dataflow / evaluation, in some respects Arrowhead is not an --- ideal LocThetaImage as we want the retract distance to work out --- how to draw the image. --- --- Images do not inherently encode objects that should be drawn --- and evaluated at the same time (and lazy eval permits this) but --- it seems to helpful to think that Images should be evaluated as --- they are drawn. --- - - --- | Tiplen is length of the tip \*along the line it follows\*. --- --- > |\ --- > | \ --- > | / --- > |/ --- > --- > | | -- tip len --- - --- | Tip width is the distance between upper and lower --- arrow points. --- --- > __ --- > |\ --- > | \ tip --- > | / width --- > |/ __ --- > - - - --- | This one is for triangular tips defined by their tip angle --- e.g. 90deg, 60deg, 45deg. --- --- The tip width will be variable (tip length should be the --- markHeight). --- -triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u) -triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower) - where - hypo_len = tiplen / (fromRadian $ cos halfang) - rtheta = pi + theta -- theta in the opposite direction - vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len - vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len - - - --- | This one is for triangles when the tip height and tip width --- are known. --- -triVecsByDist :: (Real u, Floating u) - => u -> u -> Radian -> (Vec2 u, Vec2 u) -triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower) - where - hypo_len = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth) - halfang = toRadian $ atan (half_tipwidth / tiplen) - rtheta = pi + theta -- theta in the opposite direction - vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len - vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len - - - - -{- -markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u -markHeightPlusLineWidth = - (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth --} - - -markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u -markHeightLessLineWidth = - (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth - - --- noRetract ignores both the angle and the point. --- --- Its common for the rectraction not to care about the angle or --- the point and only care about the DrawingCtx. --- -noRetract :: Num u => DrawingInfo u -noRetract = pure 0 - - --- | Arrow tips are drawn with a sloid line even if the connector --- line is dashed (tips also override round corners) - -solidArrTip :: DrawingCtxM m => m a -> m a -solidArrTip mf = localize (dashPattern Solid . roundCornerFactor 0) mf - - -solidOpenStroke :: Num u => PrimPath u -> Graphic u -solidOpenStroke = solidArrTip . openStroke - -solidClosedStroke :: Num u => PrimPath u -> Graphic u -solidClosedStroke = solidArrTip . closedStroke - -solidStrokedDisk :: Num u => u -> LocGraphic u -solidStrokedDisk = solidArrTip . strokedDisk - --------------------------------------------------------------------------------- - -tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a -tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h - --- | Tripoints takes the \*tip length\* is the mark height. --- --- This means that the 90deg tip has a tip width greater-than the --- mark height (but that is okay - seemingly this is how TikZ --- does it). --- -tripointsByAngle :: (Floating u, FromPtSize u) - => Radian -> LocThetaCF u (Point2 u, Point2 u) -tripointsByAngle triang = - tipBody $ \pt theta h -> - let (vup,vlo) = triVecsByAngle h (0.5*triang) theta - in pure (pt .+^ vup, pt .+^ vlo) - - -revtripointsByAngle :: (Floating u, FromPtSize u) - => Radian - -> LocThetaCF u (Point2 u, Point2 u, Point2 u) -revtripointsByAngle triang = - tipBody $ \pt theta h -> - let theta' = circularModulo $ pi+theta - (vup,vlo) = triVecsByAngle h (0.5*triang) theta' - back_tip = pt .-^ avec theta h - in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) - - - -tripointsByDist :: (Real u, Floating u, FromPtSize u) - => LocThetaCF u (Point2 u, Point2 u) -tripointsByDist = - tipBody $ \pt theta h -> - let (vup,vlo) = triVecsByDist h (0.5*h) theta - in pure (pt .+^ vup, pt .+^ vlo) - - - -revtripointsByDist :: (Real u, Floating u, FromPtSize u) - => LocThetaCF u (Point2 u, Point2 u, Point2 u) -revtripointsByDist = - tipBody $ \pt theta h -> - let theta' = circularModulo $ pi+theta - (vup,vlo) = triVecsByDist h (0.5*h) theta' - back_tip = pt .-^ avec theta h - in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) - - - - - --- width = xchar_height --- filled with stroke colour! - -triTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u -triTLG triang drawF = - promoteR2 $ \pt theta -> - localize bothStrokeColour $ - apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> - drawF $ vertexPath [pt,u,v] - - - -tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri90 = Arrowhead markHeight (triTLG (pi/2) filledPath) - - -tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri60 = Arrowhead markHeight (triTLG (pi/3) filledPath) - - -tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri45 = Arrowhead markHeight (triTLG (pi/4) filledPath) - -otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri90 = Arrowhead markHeight (triTLG (pi/2) solidClosedStroke) - -otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri60 = Arrowhead markHeight (triTLG (pi/3) solidClosedStroke) - -otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri45 = Arrowhead markHeight (triTLG (pi/4) solidClosedStroke) - - --- width = xchar_height --- filled with stroke colour! - -revtriTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u -revtriTLG triang drawF = - promoteR2 $ \pt theta -> - localize bothStrokeColour $ - apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> - drawF $ vertexPath [u,pt',v] - - - -revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri90 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/2) filledPath) - -revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri60 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/3) filledPath) - -revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri45 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/4) filledPath) - - -orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri90 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/2) solidClosedStroke) - -orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri60 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/3) solidClosedStroke) - -orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri45 = Arrowhead markHeightLessLineWidth - (revtriTLG (pi/4) solidClosedStroke) - - - -barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u -barbTLG ang = - promoteR2 $ \pt theta -> - apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> - solidOpenStroke $ vertexPath [u,pt,v] - - - -barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb90 = Arrowhead noRetract (barbTLG (pi/2)) - -barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb60 = Arrowhead noRetract (barbTLG (pi/3)) - - -barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb45 = Arrowhead noRetract (barbTLG (pi/4)) - - - -revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u -revbarbTLG ang = - promoteR2 $ \pt theta -> - apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> - solidOpenStroke $ vertexPath [u,pt',v] - -revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb90 = Arrowhead markHeight (revbarbTLG (pi/2)) - - -revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb60 = Arrowhead markHeight (revbarbTLG (pi/3)) - -revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb45 = Arrowhead markHeight (revbarbTLG (pi/4)) - - -perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u -perpTLG = - tipBody $ \pt theta h -> - let hh = 0.5*h in solidOpenStroke $ rperpPath hh pt theta - - -rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u -rperpPath hh ctr theta = primPath p0 [lineTo p1] - where - p0 = displacePerpendicular hh theta ctr - p1 = displacePerpendicular (-hh) theta ctr - - - -perp :: (Floating u, FromPtSize u) => Arrowhead u -perp = Arrowhead noRetract perpTLG - - - -bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u -bracketTLG = - tipBody $ \pt theta h -> - let hh = 0.5*h in solidOpenStroke $ rbracketPath hh pt theta - - -rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u -rbracketPath hh pt theta = vertexPath [p0,p1,p2,p3] - where - p1 = displacePerpendicular hh theta pt - p0 = displaceParallel (-hh) theta p1 - p2 = displacePerpendicular (-hh) theta pt - p3 = displaceParallel (-hh) theta p2 - - - - -bracket :: (Floating u, FromPtSize u) => Arrowhead u -bracket = Arrowhead noRetract bracketTLG - - -diskTLG :: (Floating u, FromPtSize u) - => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u -diskTLG drawF = - tipBody $ \pt theta h -> let hh = 0.5*h - ctr = pt .-^ avec theta hh - in drawF hh ctr - - -diskTip :: (Floating u, FromPtSize u) => Arrowhead u -diskTip = Arrowhead markHeight (diskTLG drawF) - where - drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt - - -odiskTip :: (Floating u, FromPtSize u) => Arrowhead u -odiskTip = Arrowhead markHeight (diskTLG drawF) - where - drawF r pt = solidStrokedDisk r `at` pt - - -squareTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> LocThetaGraphic u -squareTLG drawF = - tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h) - - -rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u -rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3] - where - p0 = displacePerpendicular hh theta pt - p3 = displacePerpendicular (-hh) theta pt - p1 = displaceParallel (-2*hh) theta p0 - p2 = displaceParallel (-2*hh) theta p3 - - -squareTip :: (Floating u, FromPtSize u) => Arrowhead u -squareTip = Arrowhead markHeight (squareTLG drawF) - where - drawF = localize bothStrokeColour . filledPath - - -osquareTip :: (Floating u, FromPtSize u) => Arrowhead u -osquareTip = Arrowhead markHeight (squareTLG solidClosedStroke) - - -diamondTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> LocThetaGraphic u -diamondTLG drawF = - tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h) - - -rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u -rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3] - where - ctr = displaceParallel (-2*hh) theta pt - p1 = displacePerpendicular hh theta ctr - p3 = displacePerpendicular (-hh) theta ctr - p2 = displaceParallel (-4*hh) theta pt - - - -diamondTip :: (Floating u, FromPtSize u) => Arrowhead u -diamondTip = Arrowhead (fmap (2*) markHeightLessLineWidth) - (diamondTLG drawF) - where - drawF = localize bothStrokeColour . filledPath - - -odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u -odiamondTip = Arrowhead (fmap (2*) markHeight) (diamondTLG solidClosedStroke) - - - - --- Note - points flipped to get the second trapezium to --- draw /underneath/. --- -curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u -curveTLG = - tipBody $ \pt theta h -> - cxCurvePath pt theta (0.5*h) >>= \path -> - localize (joinRound . capRound) (solidOpenStroke path) - - -cxCurvePath :: (Real u, Floating u, FromPtSize u) - => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) -cxCurvePath pt theta hh = - apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt - in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo - - - - -curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u -curveTip = Arrowhead (fmap realToFrac getLineWidth) curveTLG - - --- Note - points flipped to get the second trapezium to --- draw /underneath/. --- -revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u -revcurveTLG = - tipBody $ \pt theta h -> - cxRevcurvePath pt theta (0.5*h) >>= \path -> - localize (joinRound . capRound) (solidOpenStroke path) - -cxRevcurvePath :: (Real u, Floating u, FromPtSize u) - => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) -cxRevcurvePath pt theta hh = - apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 - in pure $ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo - - -revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u -revcurveTip = Arrowhead markHeight revcurveTLG - diff --git a/src/Wumpus/Drawing/Chains.hs b/src/Wumpus/Drawing/Chains.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Chains --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Shim module. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Chains - ( - module Wumpus.Drawing.Chains.Base - , module Wumpus.Drawing.Chains.Derived - - - ) where - - -import Wumpus.Drawing.Chains.Base -import Wumpus.Drawing.Chains.Derived diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains/Base.hs +++ /dev/null @@ -1,259 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Chains.Base --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Generate points in an iterated chain. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Chains.Base - ( - - PointChain - , LocChain - , ConnectorChain - - -- * Unrolling chains - , unchain - , unchainU - , unchainZip - , unchainZipWith - , unconnectorChain - - -- * Building chains - , liftChainF - - ) where - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core - - - --- | A 'PointChain' is a list of points. --- --- The list is typically inifinte so some attention must be given --- to choosing a chain drawing function and using it appropriately. --- -type PointChain u = [Point2 u] - - --- | A LocChain is a function from a starting point to a --- 'PointChain'. --- --- The list is often expected to be inifinte, but if it was a --- Stream it would loose the ability to use list comprehensions. --- -type LocChain u = LocDrawingInfo u (PointChain u) - - --- | A ConnectorChain is a function from a start- and end-point --- to a 'Chain'. --- -type ConnectorChain u = ConnectorCF u (PointChain u) - - - - --- | 'unchain' : @ unroll_count * alt_fun * draw_fun * chain -> LocCF @ --- --- Unroll the chain, applying the @draw_fun@ to each point --- producing a LocCF (usually a 'LocGraphic'). If the chain does --- not produce any points the @alt_fun@ is applied to the start --- point. --- --- Note - commonly a 'Chain' may be infinite, so it is only --- unrolled a finite number of times - the @unrool_count@. --- --- This function has a very general type signature commonly it --- will be used at these types: --- --- > unchain :: (Num u, OPlus a) => --- > Int -> LocImage u a -> LocImage u a -> LocChain u -> LocImage u a --- > --- > unchain :: Num u => --- > Int -> LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u --- -unchain :: (Num u, OPlus a) - => Int - -> LocCF u (ImageAns u a) - -> LocCF u (ImageAns u a) - -> LocChain u - -> LocCF u (ImageAns u a) -unchain i alt _ _ | i <= 0 = alt -unchain i alt gf chn = promoteR1 $ \p0 -> - (chn `at` p0) >>= \pts -> case pts of - [] -> alt `at` p0 - [x] -> gf `at` x - (x:xs) -> go x (take (i-1) xs) - where - go x [] = gf `at` x - go x (y:ys) = (gf `at` x) `oplus` go y ys - - - - --- | 'unchain' : @ alt_fun * draw_fun * chain -> LocCF @ --- --- /Unsafe/ version of 'unchain' - this function assumes the chain --- is finite which is not usually the case. --- --- This function has a very general type signature commonly it --- will be used at these type: --- --- > unchainU :: (Num u, OPlus a) => --- > LocImage u a -> LocImage u a -> LocChain u -> LocImage u a --- > --- > unchainU :: Num u => --- > LocGraphic u -> LocGraphic u -> LocChain u -> LocGraphic u --- --- \*\* WARNING \*\* - if the chain is infinite this function will --- not terminate. --- -unchainU :: (Num u, OPlus a) - => LocCF u (ImageAns u a) - -> LocCF u (ImageAns u a) - -> LocChain u - -> LocCF u (ImageAns u a) -unchainU alt gf chn = promoteR1 $ \p0 -> - (chn `at` p0) >>= \pts -> case pts of - [] -> alt `at` p0 - [x] -> gf `at` x - (x:xs) -> go x xs - where - go x [] = gf `at` x - go x (y:ys) = (gf `at` x) `oplus` go y ys - - --- | 'unchainZip' : @ alt_fun * [draw_fun] * chain -> LocCF @ --- --- Unroll the chain, zipping the list of @draw_funs@ to the list --- of points producing a LocCF (usually a 'LocGraphic'). If the --- chain does not produce any points the @alt_fun@ is applied to --- the start point. --- --- This function has a very general type signature commonly it --- will be used at these types: --- --- > unchainZip :: (Num u, OPlus a) => --- > LocImage u a -> [LocImage u a] -> LocChain u -> LocImage u a --- > --- > unchainZip :: Num u => --- > LocGraphic u -> [LocGraphic u] -> LocChain u -> LocGraphic u --- --- \*\* WARNING \*\* - the list of drawing functions should be --- finite. If both the list of drawing functions and the chain are --- infinite this function will not terminate. --- -unchainZip :: (Num u, OPlus a) - => LocCF u (ImageAns u a) - -> [LocCF u (ImageAns u a)] - -> LocChain u - -> LocCF u (ImageAns u a) -unchainZip alt [] _ = promoteR1 $ \p0 -> alt `at` p0 -unchainZip alt (g:gs) chn = promoteR1 $ \p0 -> - (chn `at` p0) >>= \pts -> case pts of - [] -> alt `at` p0 - [x] -> g `at` x - (x:xs) -> go (g `at` x) gs xs - where - go acc _ [] = acc - go acc [] _ = acc - go acc (f:fs) (p:ps) = go (acc `oplus` (f `at` p)) fs ps - - - --- | 'unchainZipWith' : @ alt_fun * (a -> draw_fun) * [a] * chain -> LocCF @ --- --- Version of 'unchainZip' where the list is some data rather --- than a drawing function and the @(a -> draw_fun)@ builder is --- applied to each element as part of the unrolling. --- --- Approximately this function is a @zipWith@ to the @zip@ of --- @unchainZip@. --- --- This function has a very general type signature commonly it --- will be used at these type: --- --- > unchainZipWith :: (Num u, OPlus a) => --- > LocImage u a -> (s -> LocImage u a) -> [s] -> LocChain u -> LocImage u a --- > --- > unchainZipWith :: Num u => --- > LocGraphic u -> (s -> LocGraphic u) -> [s] -> LocChain u -> LocGraphic u --- --- \*\* WARNING \*\* - if the chain and list are infinite this --- function will not terminate. --- -unchainZipWith :: (Num u, OPlus a) - => LocCF u (ImageAns u a) - -> (s -> LocCF u (ImageAns u a)) - -> [s] - -> LocChain u - -> LocCF u (ImageAns u a) -unchainZipWith alt _ [] _ = promoteR1 $ \p0 -> alt `at` p0 -unchainZipWith alt mkGF (s:ss) chn = promoteR1 $ \p0 -> - (chn `at` p0) >>= \pts -> case pts of - [] -> alt `at` p0 - [x] -> mkGF s `at` x - (x:xs) -> go (mkGF s `at` x) ss xs - where - go acc _ [] = acc - go acc [] _ = acc - go acc (t:ts) (p:ps) = go (acc `oplus` (mkGF t `at` p)) ts ps - - - - --- | 'unconnectorChain' : @ alt_fun * draw_fun * conn_chain -> ConnectorCF @ --- --- Unroll the chain produced between the implicit start and end --- points. Apply the @draw_fun@ to each point producing a --- ConnectorCF (usually a 'ConnectorGraphic'). If the chain does --- not produce any points, the @alt_fun@ is applied to the start --- and end points. --- --- This function has a very general type signature commonly it --- will be used at these types: --- --- > unconnectorChain :: (Num u, OPlus a) => --- > ConnectorImage u a -> LocImage u a -> ConnectorChain u -> ConnectorImage u a --- > --- > unconnectorChain :: Num u => --- > ConnectorGraphic u -> LocGraphic u -> ConnectorChain u -> ConnectorGraphic u --- --- -unconnectorChain :: (Num u, OPlus a) - => ConnectorCF u (ImageAns u a) - -> LocCF u (ImageAns u a) - -> ConnectorChain u - -> ConnectorCF u (ImageAns u a) -unconnectorChain alt gf cchn = promoteR2 $ \p0 p1 -> - (connect cchn p0 p1) >>= \pts -> case pts of - [] -> connect alt p0 p1 - [x] -> gf `at` x - (x:xs) -> go (gf `at` x) xs - where - go acc [] = acc - go acc (p:ps) = go (acc `oplus` (gf `at` p)) ps - - - - --------------------------------------------------------------------------------- - --- | 'liftChainF' : @ (point -> [point]) -> LocChain @ --- --- Lift a pure chain generating function inot a 'LocChain'. --- -liftChainF :: (Point2 u -> PointChain u) -> LocChain u -liftChainF fn = promoteR1 $ \pt -> return $ fn pt - diff --git a/src/Wumpus/Drawing/Chains/Derived.hs b/src/Wumpus/Drawing/Chains/Derived.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains/Derived.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Chains.Derived --- Copyright : (c) Stephen Tetley 2010-2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Generate points in an iterated chain. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Chains.Derived - ( - - tableDown - , tableRight - - , horizontalPoints - , verticalPoints - - , horizontalSteps - , verticalSteps - - , innerHorizontals - , innerVerticals - - ) where - -import Wumpus.Drawing.Chains.Base - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core - - -import Data.List - --------------------------------------------------------------------------------- --- Tables - --- Note - for the minor runtime cost, pairing the row_width and --- row_height should make the API more /memorable/... - - --- | 'tableDown' : @ num_rows * (row_width, row_height) -> LocChain @ --- --- The table grows down and right, the implicit initial point is --- @top-left@. --- -tableDown :: Num u => Int -> (u,u) -> LocChain u -tableDown n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints - where - ints = iterate (+1) 0 - fn pt i = let (x,y) = i `divMod` n - in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt - - --- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @ --- --- The table grows right and down, the implicit initial point is --- @top-left@. --- --- This chain is infinite. --- -tableRight :: Num u => Int -> (u,u) -> LocChain u -tableRight n (rw,rh) = liftChainF $ \pt -> map (fn pt) ints - where - ints = iterate (+1) 0 - fn pt i = let (y,x) = i `divMod` n - in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt - - - --- | 'horizontalPoints' : @ horizontal_dist -> LocChain @ --- --- The chain grows right by the supplied increment. --- --- This chain is infinite. --- -horizontalPoints :: Num u => u -> LocChain u -horizontalPoints dx = liftChainF $ iterate (displaceH dx) - - --- | 'verticalPoints' : @ vertical_dist -> LocChain @ --- --- The chain grows up by the supplied increment. --- --- This chain is infinite. --- -verticalPoints :: Num u => u -> LocChain u -verticalPoints dy = liftChainF $ iterate (displaceV dy) - - --- | 'horizontalSteps' : @ [horizontal_dist] -> LocChain @ --- --- This is a @scanl@ successive displacing the start point. --- --- This chain is finite (for finite input list). --- -horizontalSteps :: Num u => [u] -> LocChain u -horizontalSteps xs = liftChainF $ \pt -> scanl (flip displaceH) pt xs - - --- | 'verticalSteps' : @ [vertical_dist] -> LocChain @ --- --- This is a @scanl@ successive displacing the start point. --- --- This chain is finite (for finite input list). --- --- \*\* WARNING \*\* - name due to be changed. Current name is --- too general for this function. --- -verticalSteps :: Num u => [u] -> LocChain u -verticalSteps ys = liftChainF $ \pt -> scanl (flip displaceV) pt ys - - -{-# INLINE [0] ceilingi #-} -ceilingi :: RealFrac a => a -> Int -ceilingi = ceiling - - --- | Note - horizontals are projected from the start point. The --- horizontal component of the second point is ignored. --- --- This chain is finite for well formed input. --- -innerHorizontals :: RealFrac u => u -> ConnectorChain u -innerHorizontals n = promoteR2 $ \a b -> return $ body a b - where - body (P2 x0 y0) (P2 x1 _) = unfoldr phi (n * fromIntegral z) - where z = ceilingi $ x0 / n - phi x | x < x1 = Just (P2 x y0, x+n) - | otherwise = Nothing - - - --- | Note - verticals are projected from the start point. The --- vertical component of the second point is ignored. --- --- This chain is finite for well formed input. --- -innerVerticals :: RealFrac u => u -> ConnectorChain u -innerVerticals n = promoteR2 $ \a b -> return $ body a b - where - body (P2 x0 y0) (P2 _ y1) = unfoldr phi (n * fromIntegral z) - where z = ceilingi $ y0 / n - phi y | y < y1 = Just (P2 x0 y, y+n) - | otherwise = Nothing - diff --git a/src/Wumpus/Drawing/Connectors.hs b/src/Wumpus/Drawing/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim module for Connectors. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors + ( + module Wumpus.Drawing.Connectors.Arrowheads + , module Wumpus.Drawing.Connectors.Base + , module Wumpus.Drawing.Connectors.BoxConnectors + , module Wumpus.Drawing.Connectors.ConnectorPaths + , module Wumpus.Drawing.Connectors.Loop + + ) where + +import Wumpus.Drawing.Connectors.Arrowheads +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 new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/Arrowheads.hs @@ -0,0 +1,464 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors.Arrowheads +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Arrowheads. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors.Arrowheads + ( + + tri90 + , tri60 + , tri45 + , otri90 + , otri60 + , otri45 + + , revtri90 + , revtri60 + , revtri45 + , orevtri90 + , orevtri60 + , orevtri45 + + , barb90 + , barb60 + , barb45 + , revbarb90 + , revbarb60 + , revbarb45 + + , perp + , bracket + + , diskTip + , odiskTip + + , squareTip + , osquareTip + + , diamondTip + , odiamondTip + + , diamondWideTip + , odiamondWideTip + + , curveTip + , revcurveTip + + ) where + + +import Wumpus.Drawing.Connectors.Base +import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative + + + +-- | Arrow tips are drawn with a sloid line even if the connector +-- line is dashed (tips also override round corners) + +solid_stroke_tip :: DrawingContextF +solid_stroke_tip = reset_drawing_metrics + + +type PointGen = Radian -> [Vec2 En] + + +filledTipPath :: PointGen -> LocThetaGraphic En +filledTipPath fn = + localize fill_use_stroke_colour $ promoteR2 $ \pt theta -> + let vs = fn theta in vertexPP (map (pt .+^) vs) >>= filledPath + + +closedTipPath :: PointGen -> LocThetaGraphic En +closedTipPath fn = + localize solid_stroke_tip $ promoteR2 $ \pt theta -> + let vs = fn theta in vertexPP (map (pt .+^) vs) >>= closedStroke + + +openTipPath :: PointGen -> LocThetaGraphic En +openTipPath fn = + localize solid_stroke_tip $ promoteR2 $ \pt theta -> + let vs = fn theta in vertexPP (map (pt .+^) vs) >>= openStroke + + + +-- | Return @o-a@ and @o-b@: +-- +-- > a +-- > .\ +-- > . \ +-- > .....o +-- > . / +-- > ./ +-- > b +-- +tripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En)) +tripointsFromTip baselen ang = \theta -> + (avec (theta + au) hyp, avec (theta + ad) hyp) + where + half_ang = 0.5 * ang + au = pi - half_ang + ad = half_ang + pi + hyp = baselen / (fromRadian $ cos half_ang) + + + +-- | Return @o-x@ and @o-a@ and @o-b@: +-- +-- > a +-- > /. +-- > / . +-- > .. x..o +-- > \ . +-- > \. +-- > b +-- +revTripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En, Vec2 En)) +revTripointsFromTip baselen ang = \theta -> + (avec theta (-baselen), oa theta, ob theta) + where + half_ang = 0.5 * ang + half_height = baselen * (fromRadian $ tan half_ang) + oa = \theta -> avec (theta + ang90) half_height + ob = \theta -> avec (theta - ang90) half_height + + + + +zeroVec :: Vec2 En +zeroVec = V2 0 0 + +ang90 :: Radian +ang90 = pi / 2 + +ang60 :: Radian +ang60 = pi / 3 + +ang45 :: Radian +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 ang = + makeArrowTip retract_one len_one (filledTipPath spec) + where + spec theta = let (v1,v2) = tripointsFromTip 1 ang theta + in [zeroVec, v1, v2] + + +tri90 :: InterpretUnit u => ArrowTip u +tri90 = filledTri ang90 + +tri60 :: InterpretUnit u => ArrowTip u +tri60 = filledTri ang60 + +tri45 :: InterpretUnit u => ArrowTip u +tri45 = filledTri ang45 + + +strokedClosedTri :: InterpretUnit u => Radian -> ArrowTip u +strokedClosedTri ang = + makeArrowTip retract_one len_one (closedTipPath spec) + where + spec theta = let (v1,v2) = tripointsFromTip 1 ang theta + in [zeroVec, v1, v2] + + +otri90 :: InterpretUnit u => ArrowTip u +otri90 = strokedClosedTri ang90 + +otri60 :: InterpretUnit u => ArrowTip u +otri60 = strokedClosedTri ang60 + +otri45 :: InterpretUnit u => ArrowTip u +otri45 = strokedClosedTri ang45 + + +filledRevTri :: InterpretUnit u => Radian -> ArrowTip u +filledRevTri ang = + makeArrowTip retract_one len_one (filledTipPath spec) + where + spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta + in [v0, v1, v2] + +revtri90 :: InterpretUnit u => ArrowTip u +revtri90 = filledRevTri ang90 + +revtri60 :: InterpretUnit u => ArrowTip u +revtri60 = filledRevTri ang60 + +revtri45 :: InterpretUnit u => ArrowTip u +revtri45 = filledRevTri ang45 + + +strokedClosedRevTri :: InterpretUnit u => Radian -> ArrowTip u +strokedClosedRevTri ang = + makeArrowTip retract_one len_one (closedTipPath spec) + where + spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta + in [v0, v1, v2] + + +orevtri90 :: InterpretUnit u => ArrowTip u +orevtri90 = strokedClosedRevTri ang90 + +orevtri60 :: InterpretUnit u => ArrowTip u +orevtri60 = strokedClosedRevTri ang60 + +orevtri45 :: InterpretUnit u => ArrowTip u +orevtri45 = strokedClosedRevTri ang45 + + + +strokedBarb :: InterpretUnit u => Radian -> ArrowTip u +strokedBarb ang = + makeArrowTip retract_zero len_one (openTipPath spec) + where + spec theta = let (v1,v2) = tripointsFromTip 1 ang theta + in [v1,zeroVec,v2] + + +barb90 :: InterpretUnit u => ArrowTip u +barb90 = strokedBarb ang90 + +barb60 :: InterpretUnit u => ArrowTip u +barb60 = strokedBarb ang60 + +barb45 :: InterpretUnit u => ArrowTip u +barb45 = strokedBarb ang45 + + +strokedRevBarb :: InterpretUnit u => Radian -> ArrowTip u +strokedRevBarb ang = + makeArrowTip retract_one len_one (openTipPath spec) + where + spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta + in [v1,v0,v2] + +revbarb90 :: InterpretUnit u => ArrowTip u +revbarb90 = strokedRevBarb ang90 + +revbarb60 :: InterpretUnit u => ArrowTip u +revbarb60 = strokedRevBarb ang60 + +revbarb45 :: InterpretUnit u => ArrowTip u +revbarb45 = strokedRevBarb ang45 + + + +perp :: InterpretUnit u => ArrowTip u +perp = + makeArrowTip retract_zero len_zero (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 = + makeArrowTip retract_zero len_half (openTipPath spec) + where + spec theta = let oa = avec (theta + ang90) 0.5 + ob = avec (theta - ang90) 0.5 + dv = avec theta (-0.5) + in [ oa ^+^ dv, oa, ob, ob ^+^ dv ] + + + +diskTip :: InterpretUnit u => ArrowTip u +diskTip = + makeArrowTip retract_one len_one + (promoteR2 $ \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) + + +odiskTip :: InterpretUnit u => ArrowTip u +odiskTip = + makeArrowTip retract_one len_one + (promoteR2 $ \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) + + +-- | squareSpec: +-- +-- > +-- > ,-----a +-- > | | +-- > ...v.....o +-- > | | +-- > `-----b +-- +squareSpec :: PointGen +squareSpec theta = [ oa ^+^ ov, oa, ob, ob ^+^ ov ] + where + oa = avec (theta + ang90) 0.5 + ob = avec (theta - ang90) 0.5 + ov = avec theta (-1) + + +squareTip :: InterpretUnit u => ArrowTip u +squareTip = + makeArrowTip retract_one len_one (filledTipPath squareSpec) + +osquareTip :: InterpretUnit u => ArrowTip u +osquareTip = + makeArrowTip retract_one len_one (closedTipPath squareSpec) + + + +-- | squareSpec: +-- +-- > +-- > a +-- > / \ +-- > ...w..v..o +-- > \ / +-- > b +-- +diamondSpec :: En -> PointGen +diamondSpec width theta = [ ow, oa, zeroVec, ob ] + where + ow = avec theta (-width) + ov = avec theta (negate $ 0.5 * width) + oa = ov ^+^ avec (theta + ang90) 0.5 + ob = ov ^+^ avec (theta - ang90) 0.5 + + +diamondTip :: InterpretUnit u => ArrowTip u +diamondTip = + makeArrowTip retract_one len_one (filledTipPath $ diamondSpec 1) + +odiamondTip :: InterpretUnit u => ArrowTip u +odiamondTip = + makeArrowTip retract_one len_one (closedTipPath $ diamondSpec 1) + + +diamondWideTip :: InterpretUnit u => ArrowTip u +diamondWideTip = + makeArrowTip retract_two len_two (filledTipPath $ diamondSpec 2) + +odiamondWideTip :: InterpretUnit u => ArrowTip u +odiamondWideTip = + makeArrowTip retract_two len_two (closedTipPath $ diamondSpec 2) + + +curveTipPath :: Point2 En -> Radian -> AbsPath En +curveTipPath pt theta = + curve1 a b c pt `append` curve1 pt z y x + where + ow = avec theta (-1) + a = pt .+^ ow ^+^ avec (theta + ang90) 0.5 + x = pt .+^ ow ^+^ avec (theta - ang90) 0.5 + + (c,b) = trapezoidFromBasePoints 0.125 0.5 pt a + (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt + + +curveTip :: InterpretUnit u => ArrowTip u +curveTip = + makeArrowTip retract_zero len_one + (promoteR2 $ \pt theta -> + localize (join_bevel . solid_stroke_tip) $ + toPrimPath (curveTipPath pt theta) >>= openStroke) + + + +curveTipRevPath :: Point2 En -> Radian -> AbsPath En +curveTipRevPath pt theta = + curve1 a b c p2 `append` curve1 p2 z y x + where + p2 = pt .+^ avec theta (-1) + a = pt .+^ avec (theta + ang90) 0.5 + x = pt .+^ avec (theta - ang90) 0.5 + + (b,c) = trapezoidFromBasePoints 0.125 0.5 a p2 + (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x + + +revcurveTip :: InterpretUnit u => ArrowTip u +revcurveTip = + makeArrowTip retract_one len_one + (promoteR2 $ \pt theta -> + localize (join_bevel . solid_stroke_tip) $ + toPrimPath (curveTipRevPath pt theta) >>= openStroke) + + + +-- | 'trapezoidFromBasePoints' : +-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @ +-- +-- Control points form an isosceles trapezoid. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +trapezoidFromBasePoints :: (Real u, Floating u) + => u -> u -> Point2 u -> Point2 u + -> (Point2 u, Point2 u) +trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + 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 diff --git a/src/Wumpus/Drawing/Connectors/Base.hs b/src/Wumpus/Drawing/Connectors/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/Base.hs @@ -0,0 +1,172 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors.Base +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Connectors... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors.Base + ( + + Connector + , ArrowConnector + , ArrowTip + , makeArrowTip + + , leftArrow + , rightArrow + , leftRightArrow + , uniformArrow + + , promoteConn + + ) where + +import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +import Control.Applicative + + +-- | The type of Connectors - a query from start and end point to +-- a Path. +-- +type Connector u = ConnectorQuery u (AbsPath u) + + + +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) + + +data ArrowTip u = ArrowTip { getArrowTip :: CF (TipAns u) } + + + + +-- | 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 + + +-- | Connector with two arrow tips, possibly different. +-- +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 + + +-- | Connector with the same arrow tip at both ends. +-- +uniformArrow :: (Real u, Floating u, InterpretUnit u) + => ArrowTip u -> Connector u -> ArrowConnector u +uniformArrow utip conn = leftRightArrow utip utip conn + + + + +convertTipAns :: InterpretUnit u => GraphicAns En -> Graphic u +convertTipAns = uconvImageF . pure + +-- | Helper - direction looks best at half the retract distance. +-- +tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian +tipDirectionL u absp | u <= 0 = directionL absp + |otherwise = directionL $ shortenL (0.5*u) absp + +tipDirectionR :: (Real u, Floating u) => u -> AbsPath u -> Radian +tipDirectionR u absp | u <= 0 = directionR absp + |otherwise = directionR $ shortenR (0.5*u) absp + + + +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 +-- 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 -> + 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) + +-- +-- CAUTION - promoteConn 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 new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors.BoxConnectors +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Box connectors +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors.BoxConnectors + ( + ConnectorBox + , connbox + + ) where + +-- import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + +-- NOTE - boxes (currently) seem to only support stroke otherwise +-- they would obliterate what they connect. + + + +-- | The type of BoxConnectors - a query from start and end point +-- to a Path. +-- +-- Note - unlike a @Connector@, a BoxConnnector is expected to be +-- closed, then filled, stroked or bordered. +-- +type ConnectorBox u = ConnectorGraphic u + + +-- +-- DESIGN NOTE - boxes (probably) should not use source and dest +-- separators. +-- + + +-- | Draw a stroked, rectangular box around the connector points. +-- +-- The rectangle will be inclined to the line. +-- +connbox :: (Real u, Floating u, InterpretUnit u) + => ConnectorBox u +connbox = promoteR2 $ \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 diff --git a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs @@ -0,0 +1,499 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors.ConnectorPaths +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Primitive connectors +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors.ConnectorPaths + ( + + connline + , connarc + , connhdiagh + , connvdiagv + + , conndiagh + , conndiagv + + , connhdiag + , connvdiag + + , connabar + , connbbar + + , connaright + , connbright + + , connhrr + , connrrh + , connvrr + , connrrv + + , connaloop + , connbloop + + , connhbezier + , connvbezier + + ) where + +import Wumpus.Drawing.Connectors.Base +import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Geometry.Quadrant -- package: wumpus-basic +import Wumpus.Basic.Kernel hiding ( promoteR2 ) + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + + + + + +-- | Straight line connector. +-- +connline :: (Real u, Floating u, InterpretUnit u) => Connector u +connline = promoteConn $ \p0 p1 -> return $ line1 p0 p1 + + + +-- | Form an arc connector. +-- +-- If the conn_arc_angle in the Drawing context is positive the arc +-- will be formed /above/ the straight line joining the points. +-- If the angle is negative it will be drawn below. +-- +-- The notion of /above/ is respective to the line direction, of +-- course. +-- +-- +connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) + => Connector u +connarc = promoteConn $ \p0 p1 -> + connectorArcAngle >>= \arc_ang -> + let v1 = pvec p0 p1 + hlen = 0.5 * vlength v1 + ang = vdirection v1 + cp0 = p0 .+^ avec (ang + arc_ang) hlen + cp1 = p1 .+^ avec (pi + ang - arc_ang) hlen + in return $ curve1 p0 cp0 cp1 p1 + + + + +-- | Horizontal-diagonal-horizontal connector. +-- +-- > --@ +-- > / +-- > o-- +-- +-- Horizontal /arms/ are drawn from the start and end points, a +-- diagonal segment joins the arms. +-- +connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connhdiagh = promoteConn $ \p0 p1 -> + connectorSrcArm >>= \src_arm -> + connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> right p0 p1 src_arm dst_arm + QUAD_SE -> right p0 p1 src_arm dst_arm + _ -> left p0 p1 src_arm dst_arm + where + right p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .+^ hvec h0 + , p1 .-^ hvec h1, p1 ] + + left p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .-^ hvec h0 + , p1 .+^ hvec h1, p1 ] + + + +-- | Vertical-diagonal-vertical connector. +-- +-- > @ +-- > | +-- > \ +-- > | +-- > o +-- +-- Vertical /arms/ are drawn from the start and end points, a +-- diagonal segment joins the arms. +-- +connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connvdiagv = promoteConn $ \p0 p1 -> + connectorSrcArm >>= \src_arm -> + connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> up p0 p1 src_arm dst_arm + QUAD_NW -> up p0 p1 src_arm dst_arm + _ -> down p0 p1 src_arm dst_arm + where + up p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .+^ vvec v0 + , p1 .-^ vvec v1, p1 ] + + down p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .-^ vvec v0 + , p1 .+^ vvec v1, p1 ] + + + +-- | Diagonal-horizontal connector. +-- +-- > --@ +-- > / +-- > o +-- +-- Restricted variant of 'hconndiag' - a diagonal segment is drawn +-- from the start point joining a horizontal arm drawn from the +-- end point +-- +conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +conndiagh = promoteConn $ \p0 p1 -> + connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> right p0 p1 dst_arm + QUAD_SE -> right p0 p1 dst_arm + _ -> left p0 p1 dst_arm + where + right p0 p1 h1 = return $ vertexPath [ p0, p1 .-^ hvec h1, p1 ] + + left p0 p1 h1 = return $ vertexPath [ p0, p1 .+^ hvec h1, p1 ] + + +-- | Diagonal-vertical connector. +-- +-- > @ +-- > | +-- > / +-- > o +-- +-- Restricted variant of 'vconndiag' - a diagonal segment is drawn +-- from the start point joining a vertical arm drawn from the end +-- point. +-- +conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +conndiagv = promoteConn $ \p0 p1 -> + connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> up p0 p1 dst_arm + QUAD_NW -> up p0 p1 dst_arm + _ -> down p0 p1 dst_arm + where + up p0 p1 v1 = return $ vertexPath [ p0, p1 .-^ vvec v1, p1 ] + + down p0 p1 v1 = return $ vertexPath [ p0, p1 .+^ vvec v1, p1 ] + + + +-- | Horizontal-diagonal connector. +-- +-- > @ +-- > / +-- > o-- +-- +-- Restricted variant of 'hconndiag' - a horizontal arm is drawn +-- from the start point joining a diagonal segment drawn from the +-- end point. +-- +connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connhdiag = promoteConn $ \p0 p1 -> + connectorSrcArm >>= \src_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> right p0 p1 src_arm + QUAD_SE -> right p0 p1 src_arm + _ -> left p0 p1 src_arm + where + right p0 p1 h1 = return $ vertexPath [ p0, p0 .+^ hvec h1, p1 ] + + left p0 p1 h1 = return $ vertexPath [ p0, p0 .-^ hvec h1, p1 ] + + +-- | Vertical-diagonal connector. +-- +-- > @ +-- > / +-- > | +-- > o +-- +-- Restricted variant of 'vconndiag' - a horizontal arm is drawn +-- from the start point joining a vertical segment drawn from the +-- end point. +-- +connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connvdiag = promoteConn $ \p0 p1 -> + connectorSrcArm >>= \src_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> up p0 p1 src_arm + QUAD_NW -> up p0 p1 src_arm + _ -> down p0 p1 src_arm + where + up p0 p1 v1 = return $ vertexPath [ p0, p0 .+^ vvec v1, p1 ] + + down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ] + + +-- DESIGN NOTE - should the concept of /above/ and /below/ use +-- quadrants? +-- + + +-- | Bar connector. +-- +-- > ,----, +-- > | | +-- > o @ +-- +-- The bar is drawn /above/ the points. +-- +connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connabar = promoteConn $ \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 ] + + +-- | Bar connector. +-- +-- > o @ +-- > | | +-- > '----' +-- +-- The bar is drawn /below/ the points. +-- +connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connbbar = promoteConn $ \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 ] + + + +-- | Right angle connector. +-- +-- > ,----@ +-- > | +-- > o +-- +-- The bar is drawn /above/ the points. +-- +connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connaright = promoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> + let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1] + + +-- | Right angle connector. +-- +-- > @ +-- > | +-- > o----' +-- +-- The bar is drawn /below/ the points. +-- +connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connbright = promoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> + let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1] + + + +-- Helper + +-- | Derive the direction aka. sign of an arm. +-- +directional :: (Num u, Ord u) => u -> u -> u -> u +directional src dst arm = if src < dst then arm else negate arm + + + +-- | Connector with two horizontal segements and a joining +-- vertical segment. +-- +-- > ,--@ +-- > | +-- > o----' +-- +-- The length of the first horizontal segment is the source arm +-- length. The length of the final segment is the remaing +-- horizontal distance. +-- +connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connhrr = promoteConn $ \ 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) + in return $ vertexPath [p0, a0, a1, p1] + + +-- | Connector with two horizontal segements and a joining +-- vertical segment. +-- +-- > ,----@ +-- > | +-- > o--' +-- +-- The length of the final horizontal segment is the distination +-- arm length. The length of the initial segment is the remaining +-- horizontal distance. +-- +connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connrrh = promoteConn $ \ 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) + in return $ vertexPath [p0, a0, a1, p1] + + +-- | Connector with two right angles... +-- +-- > @ +-- > | +-- > ,----' +-- > | +-- > o +-- +connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connvrr = promoteConn $ \ 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) + in return $ vertexPath [p0, a0, a1, p1] + + +-- | Connector with two right angles... +-- +-- > @ +-- > | +-- > ,----' +-- > | +-- > o +-- +connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connrrv = promoteConn $ \ 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) + in return $ vertexPath [p0, a0, a1, p1] + + + + +-- | Loop connector. +-- +-- > ,---------, +-- > | | +-- > '-o @--' +-- +-- The loop is drawn /above/ the points. +-- +connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connaloop = loopbody id + +-- | Loop connector. +-- +-- > ,-o @--, +-- > | | +-- > '---------' +-- +-- The loop is drawn /above/ the points. +-- +connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => Connector u +connbloop = loopbody negate + +-- | Looping just differs on a negate... +-- +loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => (u -> u) -> Connector u +loopbody fn = promoteConn $ \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 + in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ] + +-- | Bezier curve connector - the control points are positioned +-- horizontally respective to the source and dest. +-- +-- > *--@ +-- > . +-- > . +-- > o--* +-- +-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves. +-- +connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => Connector u +connhbezier = promoteConn $ \p0 p1 -> + fmap (2*) connectorSrcArm >>= \src_arm -> + fmap (2*) connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> right p0 p1 src_arm dst_arm + QUAD_SE -> right p0 p1 src_arm dst_arm + _ -> left p0 p1 src_arm dst_arm + where + right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1 + + left p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1 + + +-- | Bezier curve connector - the control points are positioned +-- vertically respective to the source and dest. +-- +-- > @ +-- > .| +-- > * . * +-- > |. +-- > o +-- +-- Note - the source and dest arm lengths are doubled, generally +-- this produces nicer curves. +-- +connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => Connector u +connvbezier = promoteConn $ \p0 p1 -> + fmap (2*) connectorSrcArm >>= \src_arm -> + fmap (2*) connectorDstArm >>= \dst_arm -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> up p0 p1 src_arm dst_arm + QUAD_NW -> up p0 p1 src_arm dst_arm + _ -> down p0 p1 src_arm dst_arm + where + up p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1 + + down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1 + + + diff --git a/src/Wumpus/Drawing/Connectors/Loop.hs b/src/Wumpus/Drawing/Connectors/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/Loop.hs @@ -0,0 +1,86 @@ +{-# 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,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -58,9 +59,10 @@ import Wumpus.Drawing.Dots.Marks -import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.Base.RotTextZero -import Wumpus.Basic.Geometry.Intersection -- package: wumpus-basic +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.Kernel @@ -84,7 +86,6 @@ , radial_anchor :: Radian -> Point2 u , cardinal_anchor :: Cardinal -> Point2 u } - type instance DUnit (DotAnchor u) = u instance CenterAnchor (DotAnchor u) where @@ -153,7 +154,7 @@ fn theta = displaceVec (rectRadialVector hw hh theta) ctr -polygonAnchor :: (Real u, Floating u, FromPtSize u) +polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr = DotAnchor { center_anchor = ctr @@ -172,7 +173,7 @@ in rectangleAnchor hw hh (bl .+^ vec hw hh) rectangleLDO :: (Real u, Floating u) - => u -> u -> LocDrawingInfo u (DotAnchor u) + => u -> u -> LocQuery u (DotAnchor u) rectangleLDO w h = promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt @@ -182,7 +183,7 @@ (\theta -> ctr .+^ (avec theta rad)) (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u) +circleLDO :: (Floating u, InterpretUnit u) => LocQuery u (DotAnchor u) circleLDO = promoteR1 $ \pt -> markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt @@ -191,8 +192,8 @@ -- This might be better taking a function: ctr -> poly_points -- ... -- -polygonLDO :: (Real u, Floating u, FromPtSize u) - => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u) +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 @@ -201,11 +202,11 @@ -------------------------------------------------------------------------------- -type DotLocImage u = LocImage u (DotAnchor u) +type DotLocImage u = LocImage u (DotAnchor u) type DDotLocImage = DotLocImage Double -dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u +dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u dotChar ch = dotText [ch] @@ -216,73 +217,74 @@ -- -dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u -dotText ss = fmap (bimapL bboxRectAnchor) (textAlignCenter ss) +dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u +dotText ss = pushR1 (mapAns bboxRectAnchor) $ ccTextline ss -- Note - maybe Wumpus-Basic should have a @swapAns@ function? -dotHLine :: (Floating u, FromPtSize u) => DotLocImage u +dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u dotHLine = intoLocImage circleLDO markHLine -dotVLine :: (Floating u, FromPtSize u) => DotLocImage u +dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u dotVLine = intoLocImage circleLDO markVLine -dotX :: (Floating u, FromPtSize u) => DotLocImage u +dotX :: (Floating u, InterpretUnit u) => DotLocImage u dotX = intoLocImage circleLDO markX -dotPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotPlus = intoLocImage circleLDO markPlus -dotCross :: (Floating u, FromPtSize u) => DotLocImage u +dotCross :: (Floating u, InterpretUnit u) => DotLocImage u dotCross = intoLocImage circleLDO markCross -dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotDiamond = intoLocImage circleLDO markDiamond -dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotFDiamond = intoLocImage circleLDO markFDiamond -dotDisk :: (Floating u, FromPtSize u) => DotLocImage u +dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u dotDisk = intoLocImage circleLDO markDisk -dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u +dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u dotSquare = - lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare + markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare -dotCircle :: (Floating u, FromPtSize u) => DotLocImage u +dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u dotCircle = intoLocImage circleLDO markCircle -dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u +dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u dotPentagon = intoLocImage circleLDO markPentagon -dotStar :: (Floating u, FromPtSize u) => DotLocImage u +dotStar :: (Floating u, InterpretUnit u) => DotLocImage u dotStar = intoLocImage circleLDO markStar -dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u +dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u dotAsterisk = intoLocImage circleLDO markAsterisk -dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotOPlus = intoLocImage circleLDO markOPlus -dotOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotOCross = intoLocImage circleLDO markOCross -dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotFOCross = intoLocImage circleLDO markFOCross -dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u +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] diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs --- a/src/Wumpus/Drawing/Dots/Marks.hs +++ b/src/Wumpus/Drawing/Dots/Marks.hs @@ -50,7 +50,7 @@ ) where -import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.Base.RotTextZero import Wumpus.Basic.Geometry.Paths -- package: wumpus-basic import Wumpus.Basic.Kernel @@ -60,7 +60,6 @@ import Data.AffineSpace -- package: vector-space import Data.VectorSpace -import Control.Applicative -- Marks should be the height of a lower-case letter... @@ -75,52 +74,52 @@ infixr 9 `renderPathWith` -renderPathWith :: LocDrawingInfo u (PrimPath u) - -> (PrimPath u -> Graphic u) +renderPathWith :: LocQuery u PrimPath + -> (PrimPath -> Graphic u) -> LocGraphic u -renderPathWith m k = m >>= (lift0R1 . k) +renderPathWith qy mk = promoteR1 $ \pt -> apply1R1 qy pt >>= mk -markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u +markChar :: (Real u, Floating u, InterpretUnit u) => Char -> LocGraphic u markChar ch = markText [ch] -markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u -markText ss = fmap (replaceL uNil) $ textAlignCenter ss +markText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u +markText ss = pushR1 ignoreAns $ ccTextline ss -- | Supplied point is the center. -- -axialLine :: Fractional u => Vec2 u -> LocGraphic u -axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v) +axialLine :: (Fractional u, InterpretUnit u) => Vec2 u -> LocGraphic u +axialLine v = moveStart (\ctr -> ctr .-^ (0.5 *^ v)) (locStraightLine v) -markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h) +markHLine :: (Fractional u, InterpretUnit u) => LocGraphic u +markHLine = markHeight >>= \h -> axialLine (hvec h) -markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) +markVLine :: (Fractional u, InterpretUnit u) => LocGraphic u +markVLine = markHeight >>= \h -> axialLine (vvec h) -markX :: (Fractional u, FromPtSize u) => LocGraphic u -markX = lift0R1 markHeight >>= mkX +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, FromPtSize u) => LocGraphic u +markPlus :: (Fractional u, InterpretUnit u) => LocGraphic u markPlus = markVLine `oplus` markHLine -markCross :: (Floating u, FromPtSize u) => LocGraphic u +markCross :: (Floating u, InterpretUnit u) => LocGraphic u markCross = markHeight >>= mkCross where mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h) @@ -128,12 +127,11 @@ -- Note - height is extended slightly to look good... -pathDiamond :: (Fractional u, FromPtSize u) - => LocDrawingInfo u (PrimPath u) -pathDiamond = - promoteR1 $ \pt -> - markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) - in return $ coordinatePrimPath pt cp +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 @@ -141,10 +139,10 @@ -- pathDiamond :: (ctx -> pt -> a) -- ans :: (ctx -> pt -> prim) -markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markDiamond = pathDiamond `renderPathWith` closedStroke -markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markFDiamond = pathDiamond `renderPathWith` filledPath @@ -155,60 +153,60 @@ -- A named combinator might be better. -- -markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u markBDiamond = pathDiamond `renderPathWith` borderedPath -- | Note disk is filled. -- -markDisk :: (Fractional u, FromPtSize u) => LocGraphic u -markDisk = lift0R1 markHalfHeight >>= filledDisk +markDisk :: (Fractional u, InterpretUnit u) => LocGraphic u +markDisk = markHalfHeight >>= filledDisk -markSquare :: (Fractional u, FromPtSize u) => LocGraphic u +markSquare :: (Fractional u, InterpretUnit u) => LocGraphic u markSquare = - lift0R1 markHeight >>= \h -> + markHeight >>= \h -> let d = 0.5*(-h) in moveStart (displace d d) $ strokedRectangle h h -markCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markCircle = lift0R1 markHalfHeight >>= strokedDisk +markCircle :: (Fractional u, InterpretUnit u) => LocGraphic u +markCircle = markHalfHeight >>= strokedDisk -markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markBCircle = lift0R1 markHalfHeight >>= borderedDisk +markBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u +markBCircle = markHalfHeight >>= borderedDisk -markPentagon :: (Floating u, FromPtSize u) => LocGraphic u -markPentagon = - promoteR1 $ \pt -> - markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h) +markPentagon :: (Floating u, InterpretUnit u) => LocGraphic u +markPentagon = promoteR1 $ \pt -> + pentagonPath pt >>= closedStroke where - pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh + pentagonPath pt = markHalfHeight >>= \hh -> + coordinatePrimPath (polygonCoordPath 5 hh) pt -markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h) +markStar :: (Floating u, InterpretUnit u) => LocGraphic u +markStar = markHeight >>= \h -> starLines (0.5*h) -starLines :: Floating u => u -> LocGraphic u -starLines hh = - promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh - in step $ map (fn ctr) $ cp ctr +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 = openStroke $ primPath p0 [lineTo p1] + fn p0 p1 = straightLine p0 p1 step (x:xs) = oconcat x xs step _ = error "starLines - unreachable" -markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u -markAsterisk = lift0R1 markHeight >>= asteriskLines +markAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u +markAsterisk = markHeight >>= asteriskLines -asteriskLines :: Floating u => u -> LocGraphic u +asteriskLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3 where ang = (pi*2) / 6 @@ -217,27 +215,28 @@ lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h) -markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markOPlus :: (Fractional u, InterpretUnit u) => LocGraphic u markOPlus = markCircle `oplus` markPlus -markOCross :: (Floating u, FromPtSize u) => LocGraphic u +markOCross :: (Floating u, InterpretUnit u) => LocGraphic u markOCross = markCircle `oplus` markCross -markFOCross :: (Floating u, FromPtSize u) => LocGraphic u +markFOCross :: (Floating u, InterpretUnit u) => LocGraphic u markFOCross = markCross `oplus` markBCircle --- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u +-- bkCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) -markTriangle :: (Floating u, FromPtSize u) => LocGraphic u +markTriangle :: (Floating u, InterpretUnit u) => LocGraphic u markTriangle = tripath `renderPathWith` closedStroke where tripath = promoteR1 $ \pt -> - markHeight >>= \h -> let cp = equilateralTriangleCoordPath h - in pure $ coordinatePrimPath pt cp + markHeight >>= \h -> + let cp = equilateralTriangleCoordPath h + in coordinatePrimPath cp pt diff --git a/src/Wumpus/Drawing/Extras/Axes.hs b/src/Wumpus/Drawing/Extras/Axes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Axes.hs @@ -0,0 +1,49 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Extras.Axes +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Drawing grids +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Extras.Axes + ( + + orthontAxes + + ) where + +import Wumpus.Drawing.Connectors + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Core -- package: wumpus-core + + +-- Note - axes need labels working out... + + +-- | Draw axes from (0,0). +-- +orthontAxes :: (Real u, Floating u, InterpretUnit u) + => (Double, Double) -> Graphic u +orthontAxes (w,h) = + snapmove (1,1) >>= \(V2 w1 h1) -> + 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) + + + + diff --git a/src/Wumpus/Drawing/Extras/Grids.hs b/src/Wumpus/Drawing/Extras/Grids.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Grids.hs @@ -0,0 +1,229 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Extras.Grids +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Drawing grids +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Extras.Grids + ( + + GridContextF + , grid + , standard_grid + , grid_major_colour + , grid_major_line_width + , grid_major_dotnum + , grid_minor_subdivisions + , grid_minor_colour + , grid_minor_line_width + , grid_minor_dotnum + , grid_point_size + , grid_label_colour + + ) where + + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour ( black ) + + + + +type GridContextF = GridProps -> GridProps + +-- | GridProps control the drawing of grids. +-- +data GridProps = GridProps + { gp_major_colour :: RGBi + , gp_major_lnwidth :: Double + , gp_major_dotnum :: Int + , gp_minor_subdivs :: Int + , gp_minor_colour :: RGBi + , gp_minor_lnwidth :: Double + , gp_minor_dotnum :: Int + , gp_point_size :: FontSize + , gp_label_colour :: RGBi + } + +default_grid_props :: GridProps +default_grid_props = + GridProps { gp_major_colour = grey1 + , gp_major_lnwidth = 1 + , gp_major_dotnum = 0 + , gp_minor_subdivs = 5 + , gp_minor_colour = grey2 + , gp_minor_lnwidth = 0.5 + , gp_minor_dotnum = 0 + , gp_point_size = 10 + , gp_label_colour = black + } + where + grey1 = RGBi 100 100 100 + grey2 = RGBi 150 150 150 + + + +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 + +grid_major_colour :: RGBi -> GridContextF +grid_major_colour rgb = (\s -> s { gp_major_colour = rgb }) + +grid_major_line_width :: Double -> GridContextF +grid_major_line_width lw = (\s -> s { gp_major_lnwidth = lw }) + +grid_major_dotnum :: Int -> GridContextF +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_colour :: RGBi -> GridContextF +grid_minor_colour rgb = (\s -> s { gp_minor_colour = rgb }) + +grid_minor_line_width :: Double -> GridContextF +grid_minor_line_width lw = (\s -> s { gp_minor_lnwidth = lw }) + +grid_minor_dotnum :: Int -> GridContextF +grid_minor_dotnum n = (\s -> s { gp_minor_dotnum = n }) + + +grid_point_size :: FontSize -> GridContextF +grid_point_size i = (\s -> s { gp_point_size = i }) + + +grid_label_colour :: RGBi -> GridContextF +grid_label_colour rgb = (\s -> s { gp_label_colour = rgb }) + + + +-------------------------------------------------------------------------------- + + + +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) + + + + +lineProps :: RGBi -> Double -> Int -> DrawingContextF +lineProps rgb lw n + | n < 1 = stroke_colour rgb . set_line_width lw . solid_line + | otherwise = stroke_colour rgb . set_line_width lw . dashesF + where + 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) + + + + +-- | 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) + + 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) + where + go n acc pt | n < 1 = acc + | otherwise = go (n-1) (acc `oplus` (g `at` pt)) (mv pt) + + + +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 + + diff --git a/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Turtle/TurtleClass.hs @@ -0,0 +1,91 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Extras/Turtle/TurtleMonad.hs @@ -0,0 +1,132 @@ +{-# 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/Grids.hs b/src/Wumpus/Drawing/Grids.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Grids.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Grids --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Drawing grids --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Grids - ( - grid - , interiorGrid - - ) where - -import Wumpus.Drawing.Chains - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core - - - -grid :: Fractional u => (Int,Int) -> u -> LocGraphic u -grid (nx,ny) incr - | nx < 1 || ny < 1 = emptyLocGraphic - | otherwise = promoteR1 $ \sw -> - let rw = incr * fromIntegral nx - rh = incr * fromIntegral ny - xchn = horizontalPoints incr - ychn = verticalPoints incr - vline1 = straightLine (vvec rh) - hline1 = straightLine (hvec rw) - vlines = unchain nx emptyLocGraphic vline1 xchn - hlines = unchain ny emptyLocGraphic hline1 ychn - in (hlines `oplus` vlines `oplus` strokedRectangle rw rh) `at` sw - - - --- | 'interiorGrid' : @ increment -> ConnectorGraphic @ --- --- Draw the interior lines of a grid between the /connector/ --- points - start point is interpreted as bottom-left, end-point --- is interpreted as top right. --- --- The interior lines are calculated with repsect to the 0 and the --- increment, for instance with an increment of 10 but a start --- point @(15,0)@ lines are drawn from @(20,0), (30,0)@ etc. --- -interiorGrid :: RealFrac u => u -> ConnectorGraphic u -interiorGrid incr = promoteR2 $ \sw ne -> - let xcc = innerHorizontals incr - ycc = innerVerticals incr - (V2 vx vy) = pvec sw ne - hline1 = straightLine (hvec vx) - vline1 = straightLine (vvec vy) - vlines = unconnectorChain emptyConnectorGraphic vline1 xcc - hlines = unconnectorChain emptyConnectorGraphic hline1 ycc - in connect (hlines `oplus` vlines) sw ne - diff --git a/src/Wumpus/Drawing/Paths.hs b/src/Wumpus/Drawing/Paths.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths --- Copyright : (c) Stephen Tetley 2010-2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim import module for Paths. --- --- Note MonadicConstruction is not exported, this module is --- somewhat out-of-date and needs a re-think. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths - ( - - module Wumpus.Drawing.Paths.Base - , module Wumpus.Drawing.Paths.Connectors - , module Wumpus.Drawing.Paths.ControlPoints - - ) where - -import Wumpus.Drawing.Paths.Base -import Wumpus.Drawing.Paths.Connectors -import Wumpus.Drawing.Paths.ControlPoints - diff --git a/src/Wumpus/Drawing/Paths/Absolute.hs b/src/Wumpus/Drawing/Paths/Absolute.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Absolute.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Abolute +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim import module for the Absolute Path modules. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Absolute + ( + + module Wumpus.Drawing.Paths.Base.AbsBuilder + , module Wumpus.Drawing.Paths.Base.AbsPath + + ) where + +import Wumpus.Drawing.Paths.Base.AbsBuilder +import Wumpus.Drawing.Paths.Base.AbsPath + diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base.hs +++ /dev/null @@ -1,585 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Base --- Copyright : (c) Stephen Tetley 2010-2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Extended path type - more amenable for complex drawings than --- the type in Wumpus-Core. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Base - ( - - Path - , DPath - , length - , append - , pconcat - , line - , curve - , pivot - , traceLinePoints - , traceCurvePoints - , curveByAngles - - , toPrimPath - - , tipL - , tipR - - , shortenPath - , shortenL - , shortenR - , directionL - , directionR - - , midway - , midway_ - , atstart - , atstart_ - , atend - , atend_ - - , PathViewL(..) - , DPathViewL - , PathViewR(..) - , DPathViewR - , PathSegment(..) - , DPathSegment - , pathViewL - , pathViewR - - - , roundTrail - , roundInterior - - ) where - - - -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl - , ViewR(..), viewr, cons, snoc, join ) -import qualified Wumpus.Basic.Utils.JoinList as JL - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace - -import Data.List ( foldl' ) - -import Prelude hiding ( length ) - -data Path u = Path { _path_length :: u - , _path_start :: Point2 u - , _path_elements :: JoinList (PathSeg u) - , _path_end :: Point2 u - } - deriving (Eq,Show) - -type DPath = Path Double - --- Annotating each segment with length is \*\* good \*\*. --- Makes it much more efficient to find the midway point. --- --- But what do we do about the start point: --- --- a) put it in the segment - too much info in the type, allows --- consistency problems vis-a-vis gaps in the path. --- --- b) leave it out - too little info in the type, allows --- consistency problems with length. --- --- Option (a) is probably most convenient espcially as the --- constructors won\'t be exported. - --- Annotation is length... --- -data PathSeg u = LineSeg { _line_length :: u - , _line_start :: Point2 u - , _line_end :: Point2 u - } - | CurveSeg { _curve_length :: u - , _curve_start :: Point2 u - , _ctrl_pt_one :: Point2 u - , _ctrl_pt_two :: Point2 u - , _curve_end :: Point2 u - } - deriving (Eq,Show) - - -type instance DUnit (Path u) = u -type instance DUnit (PathSeg u) = u - - -infixr 1 `append` - -length :: Num u => Path u -> u -length (Path u _ _ _) = u - -append :: Floating u => Path u -> Path u -> Path u -append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) - | end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2 - | otherwise = let joint = lineSegment end1 start2 - total_len = len1 + len2 + segmentLength joint - in Path total_len start1 (se1 `join` (cons joint se2)) end2 - --- CAUTION - @append@ is using Floating Point equality to see if --- points are equal... - - -pconcat :: Floating u => Path u -> [Path u] -> Path u -pconcat p0 ps = foldl' append p0 ps - -segmentLength :: PathSeg u -> u -segmentLength (LineSeg u _ _) = u -segmentLength (CurveSeg u _ _ _ _) = u - - -segmentStart :: PathSeg u -> Point2 u -segmentStart (LineSeg _ p0 _) = p0 -segmentStart (CurveSeg _ p0 _ _ _) = p0 - -segmentEnd :: PathSeg u -> Point2 u -segmentEnd (LineSeg _ _ p1) = p1 -segmentEnd (CurveSeg _ _ _ _ p3) = p3 - - - - -lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u -lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1 - - -pathZero :: Floating u => Point2 u -> Path u -pathZero p0 = Path 0 p0 JL.empty p0 - - -line :: Floating u => Point2 u -> Point2 u -> Path u -line p0 p1 = let v = vlength $ pvec p0 p1 - in Path v p0 (JL.one $ LineSeg v p0 p1) p1 - - -curve :: (Floating u, Ord u, FromPtSize u) - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u -curve p0 p1 p2 p3 = let v = bezierLength (BezierCurve p0 p1 p2 p3) - in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3 - --- | A draw a /straight line/ of length 0 at the supplied point. --- --- This is /might/ be useful in concatenating curved paths --- as it introduces and extra control point. --- -pivot :: Floating u => Point2 u -> Path u -pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0 - - --- | 'traceLinePoints' throws a runtime error if the supplied list --- is empty. --- -traceLinePoints :: Floating u => [Point2 u] -> Path u -traceLinePoints [] = error "traceLinePoints - empty point list." -traceLinePoints [a] = line a a -traceLinePoints (a:b:xs) = step (line a b) b xs - where - step acc _ [] = acc - step acc e (y:ys) = step (acc `append` line e y) y ys - - --- | 'traceCurvePoints' consumes 4 points from the list on the --- intial step (start, control1, control2, end) then steps --- through the list taking 3 points at a time thereafter --- (control1,control2, end). Leftover points are discarded. --- --- 'traceCurvePoints' throws a runtime error if the supplied list --- is has less than 4 elements (start, control1, control2, end). --- -traceCurvePoints :: (Floating u, Ord u, FromPtSize u) - => [Point2 u] -> Path u -traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs - where - step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs - step acc _ _ = acc - -traceCurvePoints _ = error "tracePointsCurve - less than 4 elems." - - -curveByAngles :: (Floating u, Ord u, FromPtSize u) - => Point2 u -> Radian -> Radian -> Point2 u -> Path u -curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end - where - sz = 0.375 * (vlength $ pvec start end) - v1 = avec cin sz - v2 = avec cout sz - - - --- | Turn a Path into an ordinary PrimPath. --- --- Assumes path is properly formed - i.e. end point of one --- segment is the same point as the start point of the next --- segment. --- -toPrimPath :: Num u => Path u -> PrimPath u -toPrimPath (Path _ start segs _) = step1 $ viewl segs - where - step1 EmptyL = emptyPath start - step1 (e :< se) = let (p0,a) = seg1 e in - primPath p0 $ a : step2 (viewl se) - - step2 EmptyL = [] - step2 (e :< se) = seg2 e : step2 (viewl se) - - seg1 (LineSeg _ p0 p1) = (p0, lineTo p1) - seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3) - - seg2 (LineSeg _ _ p1) = lineTo p1 - seg2 (CurveSeg _ _ p1 p2 p3) = curveTo p1 p2 p3 - - - - --------------------------------------------------------------------------------- --- tips - -tipL :: Path u -> Point2 u -tipL (Path _ sp _ _) = sp - - -tipR :: Path u -> Point2 u -tipR (Path _ _ _ ep) = ep - - - - --- | 'sortenPath' : @ left_dist * right_dist * path -> Path @ --- -shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u -shortenPath l r = shortenL l . shortenR r - - --------------------------------------------------------------------------------- --- shorten from the left... - --- | Note - shortening a line from the left by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the end point. --- -shortenL :: (Real u, Floating u) => u -> Path u -> Path u -shortenL n (Path u _ segs ep) - | n >= u = line ep ep - | otherwise = step n (viewl segs) - where - step _ EmptyL = line ep ep -- should be unreachable - step d (e :< se) = let z = segmentLength e in - case compare d z of - GT -> step (d-z) (viewl se) - EQ -> makeLeftPath (u-n) se ep - LT -> let e1 = shortenSegL d e - in Path (u-n) (segmentStart e1) (e1 `cons` se) ep - - -makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u -makeLeftPath u se ep = - case viewl se of - EmptyL -> line ep ep - (e :< _) -> Path u (segmentStart e) se ep - - -shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u -shortenSegL n (LineSeg u p0 p1) = - LineSeg (u-n) (shortenLineL n p0 p1) p1 - -shortenSegL n (CurveSeg u p0 p1 p2 p3) = CurveSeg (u-n) q0 q1 q2 q3 - where - (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) - (BezierCurve p0 p1 p2 p3) - - - -shortenLineL :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -shortenLineL n p0 p1 = p0 .+^ v - where - v0 = p1 .-. p0 - v = avec (vdirection v0) n - - - --------------------------------------------------------------------------------- --- shorten from the right ... - --- | Note - shortening a line from the right by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the start point. --- -shortenR :: (Real u, Floating u) => u -> Path u -> Path u -shortenR n (Path u sp segs _) - | n >= u = line sp sp - | otherwise = step n (viewr segs) - where - step _ EmptyR = line sp sp -- should be unreachable - step d (se :> e) = let z = segmentLength e in - case compare d z of - GT -> step (d-z) (viewr se) - EQ -> makeRightPath n sp se - LT -> let e1 = shortenSegR d e - in Path (u-n) sp (se `snoc` e1) (segmentEnd e1) - - -makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u -makeRightPath u sp se = - case viewr se of - EmptyR -> line sp sp - (_ :> e) -> Path u sp se (segmentEnd e) - - - -shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u -shortenSegR n (LineSeg u p0 p1) = - LineSeg (u-n) p0 (shortenLineR n p0 p1) - -shortenSegR n (CurveSeg u p0 p1 p2 p3) = CurveSeg (u-n) q0 q1 q2 q3 - where - (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) - (BezierCurve p0 p1 p2 p3) - - - -shortenLineR :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -shortenLineR n p0 p1 = p1 .+^ v - where - v0 = p0 .-. p1 - v = avec (vdirection v0) n - - - - --------------------------------------------------------------------------------- --- line direction - --- | Direction of empty path is considered to be 0. --- -directionL :: (Real u, Floating u) => Path u -> Radian -directionL (Path _ _ se _) = step $ viewl se - where - step (LineSeg _ p0 p1 :< _) = lineDirection p1 p0 -- 1-to-0 - step (CurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0 - step _ = 0 -- should be unreachable - - --- | Direction of empty path is considered to be 0. --- -directionR :: (Real u, Floating u) => Path u -> Radian -directionR (Path _ _ se _) = step $ viewr se - where - step (_ :> LineSeg _ p0 p1) = lineDirection p0 p1 - step (_ :> CurveSeg _ _ _ p2 p3) = lineDirection p2 p3 - step _ = 0 -- should be unreachable - - - - --------------------------------------------------------------------------------- - - --- Return direction as well because the calculation is expensive... --- -midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -midway pa@(Path u sp _ _) - | u == 0 = (sp,0) - | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) - --- Just the midway point. --- -midway_ :: (Real u, Floating u) => Path u -> Point2 u -midway_ = fst . midway - - -atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -atstart pa@(Path _ sp _ _) = (sp, directionL pa) - -atstart_ :: Path u -> Point2 u -atstart_ (Path _ sp _ _) = sp - - -atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -atend pa@(Path _ _ _ ep) = (ep, directionR pa) - - -atend_ :: Path u -> Point2 u -atend_ (Path _ _ _ ep) = ep - - --- nearstart, nearend, verynear ... - - --------------------------------------------------------------------------------- - -data PathViewL u = PathOneL (PathSegment u) - | PathSegment u :<< Path u - deriving (Eq,Show) - -type DPathViewL = PathViewL Double - -data PathViewR u = PathOneR (PathSegment u) - | Path u :>> PathSegment u - deriving (Eq,Show) - -type DPathViewR = PathViewR Double - - -data PathSegment u = Line1 (Point2 u) (Point2 u) - | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u) - deriving (Eq,Show) - -type DPathSegment = PathSegment Double - -type instance DUnit (PathViewL u) = u -type instance DUnit (PathViewR u) = u -type instance DUnit (PathSegment u) = u - -pathViewL :: Num u => Path u -> PathViewL u -pathViewL (Path u _ segs ep) = go (viewl segs) - where - go EmptyL = error "pathViewL - (not) unreachable." - - go (LineSeg v p0 p1 :< se) - | JL.null se = PathOneL (Line1 p0 p1) - | otherwise = Line1 p0 p1 :<< Path (u-v) p1 se ep - - go (CurveSeg v p0 p1 p2 p3 :< se) - | JL.null se = PathOneL (Curve1 p0 p1 p2 p3) - | otherwise = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep - - -pathViewR :: Num u => Path u -> PathViewR u -pathViewR (Path u _ segs ep) = go (viewr segs) - where - go EmptyR = error "pathViewR - (not) unreachable." - - go (se :> LineSeg v p0 p1) - | JL.null se = PathOneR (Line1 p0 p1) - | otherwise = Path (u-v) p1 se ep :>> Line1 p0 p1 - - go (se :> CurveSeg v p0 p1 p2 p3) - | JL.null se = PathOneR (Curve1 p0 p1 p2 p3) - | otherwise = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3 - - - - --------------------------------------------------------------------------------- --- Round corners - --- | The length of the control-point vector wants to be slighly --- longer than half of /d/ (d - being the distance between the --- /truncated/ points and the corner). --- -cornerCurve :: (Real u, Floating u, FromPtSize u) - => Point2 u -> Point2 u -> Point2 u -> Path u -cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3 - where - len1 = 0.6 * (vlength $ pvec p1 p2) - len2 = 0.6 * (vlength $ pvec p3 p2) - cp1 = p1 .+^ (avec (lineAngle p1 p2) len1) - cp2 = p3 .+^ (avec (lineAngle p3 p2) len2) - - --- | 'roundTrail' : @ rounding_distance * [point] -> Path @ --- --- Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance \*and\* final --- round corner is created \"incorporating\" the start point (as --- the start point becomes a rounded corner the actual path will --- not intersect it). --- --- It is expected that this function will be used to create round --- cornered shapes. --- --- 'roundTrail' throws a runtime error if the input list is empty. --- If the list has one element /the null path/ is built, if the --- list has two elements a straight line is built. --- -roundTrail :: (Real u, Floating u, FromPtSize u) - => u -> [Point2 u] -> Path u -roundTrail _ [] = error "roundTrail - empty list." -roundTrail _ [a] = pathZero a -roundTrail _ [a,b] = line a b -roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs) - where - step acc (m:n:o:ps) = step (acc `append` lineCurveTrail u m n o) (n:o:ps) - step acc [n,o] = acc `append` lineCurveTrail u n o start - `append` lineCurveTrail u o start b - step acc _ = acc - - - --- | Two parts - line and corner curve... --- --- Note - the starting point is moved, this function is for --- closed, rounded paths. --- -lineCurveTrail :: (Real u, Floating u, FromPtSize u) - => u -> Point2 u -> Point2 u -> Point2 u -> Path u -lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3 - where - p1 = a .+^ (avec (vdirection $ pvec a b) u) - p2 = b .+^ (avec (vdirection $ pvec b a) u) - p3 = b .+^ (avec (vdirection $ pvec b c) u) - - --- | 'roundInterior' : @ rounding_distance * [point] -> Path @ --- --- Build a path from the list of vertices, all the interior --- corners are rounded by the rounding distance. Unlike --- 'roundTrail' there is no /loop around/ to the start point, --- and start path will begin exactly on the start point and end --- exactly on the end point. --- --- 'roundInterior' throws a runtime error if the input list is --- empty. If the list has one element /the null path/ is built, --- if the list has two elements a straight line is built. --- -roundInterior :: (Real u, Floating u, FromPtSize u) - => u -> [Point2 u] -> Path u -roundInterior _ [] = error "roundEveryInterior - empty list." -roundInterior _ [a] = pathZero a -roundInterior _ [a,b] = line a b -roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c - in step path1 (p1:c:xs) - where - step acc (m:n:o:ps) = let (seg2,p1) = lineCurveInter1 u m n o - in step (acc `append` seg2) (p1:o:ps) - step acc [n,o] = acc `append` line n o - step acc _ = acc - - - --- | Two parts - line and corner curve... --- --- Note - draws a straight line from the starting point - this is --- the first step of an interior (non-closed) rounded path --- -lineCurveInter1 :: (Real u, Floating u, FromPtSize u) - => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u) -lineCurveInter1 u a b c = - (line a p2 `append` cornerCurve p2 b p3, p3) - where - p2 = b .+^ (avec (vdirection $ pvec b a) u) - p3 = b .+^ (avec (vdirection $ pvec b c) u) - diff --git a/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs b/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/AbsBuilder.hs @@ -0,0 +1,561 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs @@ -0,0 +1,801 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Base.AbsPath +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Absolute path type - this should be more amenable for building +-- complex drawings than the PrimPath type in Wumpus-Core. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base.AbsPath + ( + + -- * Absolute path type + AbsPath + , DAbsPath + + + -- * Construction + , empty + , line1 + , curve1 + , vertexPath + , curvePath + , controlCurve + + -- * Queries + , null + , length + + -- * Concat and extension + , append + , consLineTo + , snocLineTo + , consCurveTo + , snocCurveTo + + , pathconcat + + -- * Conversion + , toPrimPath + + + -- * Shortening + , shortenPath + , shortenL + , shortenR + + -- * Tips and direction + , tipL + , tipR + , directionL + , directionR + + -- * Path anchors + , midway + , midway_ + , atstart + , atstart_ + , atend + , atend_ + + -- * Views + , PathViewL(..) + , DPathViewL + , PathViewR(..) + , DPathViewR + , PathSegment(..) + , DPathSegment + , pathViewL + , pathViewR + + + , roundTrail + , roundInterior + + ) where + + + +import Wumpus.Basic.Geometry.Base -- package: wumpus-basic +import Wumpus.Basic.Kernel +import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl + , ViewR(..), viewr, cons, snoc, join ) +import qualified Wumpus.Basic.Utils.JoinList as JL + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace + +import Data.List ( foldl' ) +import qualified Data.Traversable as T + +import Prelude hiding ( null, length ) + + + + +-- | Absolute path data type. + +data AbsPath u = AbsPath + { _abs_path_length :: u + , _abs_path_start :: Point2 u + , _abs_path_elements :: JoinList (AbsPathSeg u) + , _abs_path_end :: Point2 u + } + deriving (Eq,Show) + +type instance DUnit (AbsPath u) = u + + +type DAbsPath = AbsPath Double + +-- Annotating each segment with length is \*\* good \*\*. +-- Makes it much more efficient to find the midway point. +-- +-- But what do we do about the start point: +-- +-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path. +-- +-- b) leave it out - too little info in the type, allows +-- consistency problems with length. +-- +-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported. + +-- Annotation is length... +-- +data AbsPathSeg u = AbsLineSeg + { _abs_line_length :: u + , _abs_line_start :: Point2 u + , _abs_line_end :: Point2 u + } + | AbsCurveSeg + { _abs_curve_length :: u + , _abs_curve_start :: Point2 u + , _abs_ctrl_pt_one :: Point2 u + , _abs_ctrl_pt_two :: Point2 u + , _abs_curve_end :: Point2 u + } + deriving (Eq,Show) + + +type instance DUnit (AbsPathSeg u) = u + + +-------------------------------------------------------------------------------- + +instance Functor AbsPath where + fmap f (AbsPath u sp ls ep) = + AbsPath (f u) (fmap f sp) (fmap (fmap f) ls) (fmap f ep) + +instance Functor AbsPathSeg where + fmap f (AbsLineSeg u p0 p1) = + AbsLineSeg (f u) (fmap f p0) (fmap f p1) + + fmap f (AbsCurveSeg u p0 p1 p2 p3) = + AbsCurveSeg (f u) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3) + + +-------------------------------------------------------------------------------- + +-- TODO - must organize the Path datatype modules so they provide +-- Containers-like API functions when appropriate. + + + +-------------------------------------------------------------------------------- +-- Construction + +-- | Create the empty path. +-- +-- Note - an absolute path needs /locating/ and cannot be built +-- without a start point. Figuratively, the empty path is a path +-- from the start point to the start point. +-- +-- Thus AbsPath operates as a semigroup but not a monoid. +-- +empty :: Floating u => Point2 u -> AbsPath u +empty = zeroPath + + +-- | Create an absolute path as a straight line between the +-- supplied points. +-- +line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u +line1 p0 p1 = AbsPath v p0 (JL.one $ AbsLineSeg v p0 p1) p1 + where + v = vlength $ pvec p0 p1 + +-- | Create an absolute path from a single cubic Bezier curve. +-- +curve1 :: (Floating u, Ord u, Tolerance u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u +curve1 p0 p1 p2 p3 = AbsPath v p0 (JL.one $ AbsCurveSeg v p0 p1 p2 p3) p3 + where + v = bezierLength (BezierCurve p0 p1 p2 p3) + + +-- | 'vertexPath' throws a runtime error if the supplied list +-- is empty. +-- +vertexPath :: (Floating u, Ord u, Tolerance u) + => [Point2 u] -> AbsPath u +vertexPath [] = error "traceLinePoints - empty point list." +vertexPath [a] = line1 a a +vertexPath (a:b:xs) = step (line1 a b) b xs + where + step acc _ [] = acc + step acc e (y:ys) = step (acc `append` line1 e y) y ys + + + +-- | 'curvePath' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter +-- (control1,control2, end). Leftover points are discarded. +-- +-- 'curvePath' throws a runtime error if the supplied list +-- is has less than 4 elements (start, control1, control2, end). +-- +curvePath :: (Floating u, Ord u, Tolerance u) + => [Point2 u] -> AbsPath u +curvePath (a:b:c:d:xs) = step (curve1 a b c d) d xs + where + step acc p0 (x:y:z:zs) = step (acc `append` curve1 p0 x y z) z zs + step acc _ _ = acc + +curvePath _ = error "curvePath - less than 4 elems." + + + +-- NOTE - need a proper arc path builder. + + + +-- | This is not an arc... +-- +controlCurve :: (Floating u, Ord u, Tolerance u) + => Point2 u -> Radian -> Radian -> Point2 u -> AbsPath u +controlCurve start cin cout end = + curve1 start (start .+^ v1) (end .+^ v2) end + where + sz = 0.375 * (vlength $ pvec start end) + v1 = avec cin sz + v2 = avec cout sz + + +-------------------------------------------------------------------------------- +-- Queries + +-- | Is the path empty? +-- +null :: AbsPath u -> Bool +null = JL.null . _abs_path_elements + +-- | 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 put +-- a tax on the build operations. +-- +length :: Num u => AbsPath u -> u +length (AbsPath u _ _ _) = u + + +-------------------------------------------------------------------------------- +-- Concat + +infixr 1 `append` + +-- | Append two AbsPaths. +-- +-- If the end of the first path and the start of the second path +-- coalesce then the paths are joined directly, otherwise, a +-- straight line segment is added to join the paths. +-- +-- Neither path is /moved/. Consider 'RelPath' if you need +-- different concatenation. +-- +append :: (Floating u, Ord u, Tolerance u) + => AbsPath u -> AbsPath u -> AbsPath u +append (AbsPath len1 start1 se1 end1) (AbsPath len2 start2 se2 end2) + | end1 == start2 = AbsPath (len1+len2) start1 (se1 `join` se2) end2 + | otherwise = AbsPath total_len start1 segs end2 + where + joint = lineSegment end1 start2 + total_len = len1 + len2 + segmentLength joint + segs = se1 `join` (cons joint se2) + + +-- | Prefix the path with a straight line segment from the +-- supplied point. +-- +consLineTo :: Floating u => Point2 u -> AbsPath u -> AbsPath u +consLineTo p0 (AbsPath len1 sp se1 ep) = AbsPath (v+len1) p0 (cons s1 se1) ep + where + s1@(AbsLineSeg v _ _) = lineSegment p0 sp + + +-- | Suffix the path with a straight line segment to the +-- supplied point. +-- +snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u +snocLineTo (AbsPath len1 sp se1 ep) p1 = AbsPath (len1+v) sp (snoc se1 s1) p1 + where + s1@(AbsLineSeg v _ _) = lineSegment ep p1 + + +-- | Prefix the path with a Bezier curve segment formed by the +-- supplied points. +-- +consCurveTo :: (Floating u, Ord u, Tolerance u) + => Point2 u -> Point2 u -> Point2 u -> AbsPath u -> AbsPath u +consCurveTo p0 p1 p2 (AbsPath len1 sp se1 ep) = + AbsPath (v+len1) p0 (cons s1 se1) ep + where + s1@(AbsCurveSeg v _ _ _ _) = curveSegment p0 p1 p2 sp + + +-- | Suffix the path with a Bezier curve segment formed by the +-- supplied points. +-- +snocCurveTo :: (Floating u, Ord u, Tolerance u) + => AbsPath u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u +snocCurveTo (AbsPath len1 sp se1 ep) p1 p2 p3 = + AbsPath (v+len1) sp (snoc se1 s1) p3 + where + s1@(AbsCurveSeg v _ _ _ _) = curveSegment ep p1 p2 p3 + + + + +-- | Concat the list of paths onto the intial path. +-- +-- Because a true empty path cannot be constructed (i.e. the +-- /empty/ path needs a start point even if it has no segments) - +-- the list is in /destructor form/. Client code has to decide +-- how to handle the empty list case, e.g.: +-- +-- > case paths of +-- > (x:xs) -> Just $ pathconcat x xs +-- > [] -> Nothing +-- +-- +pathconcat :: (Floating u, Ord u, Tolerance u) + => AbsPath u -> [AbsPath u] -> AbsPath u +pathconcat p0 ps = foldl' append p0 ps + +segmentLength :: AbsPathSeg u -> u +segmentLength (AbsLineSeg u _ _) = u +segmentLength (AbsCurveSeg u _ _ _ _) = u + + +segmentStart :: AbsPathSeg u -> Point2 u +segmentStart (AbsLineSeg _ p0 _) = p0 +segmentStart (AbsCurveSeg _ p0 _ _ _) = p0 + +segmentEnd :: AbsPathSeg u -> Point2 u +segmentEnd (AbsLineSeg _ _ p1) = p1 +segmentEnd (AbsCurveSeg _ _ _ _ p3) = p3 + + + + +-- | Helper - construct a curve segment. +-- +lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u +lineSegment p0 p1 = AbsLineSeg v p0 p1 + where + v = vlength $ pvec p0 p1 + + +-- | Helper - construct a curve segment. +-- +curveSegment :: (Floating u, Ord u, Tolerance u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> AbsPathSeg u +curveSegment p0 p1 p2 p3 = AbsCurveSeg v p0 p1 p2 p3 + where + v = bezierLength (BezierCurve p0 p1 p2 p3) + + +-- | Helper - construct the /empty/ but located path. +-- +zeroPath :: Floating u => Point2 u -> AbsPath u +zeroPath p0 = AbsPath 0 p0 JL.empty p0 + + + + + + + + +-- | Turn a Path into an ordinary PrimPath. +-- +-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next +-- segment. +-- +toPrimPath :: InterpretUnit u => AbsPath u -> Query PrimPath +toPrimPath (AbsPath _ start segs _) = + uconvertCtxF start >>= \dstart -> + T.mapM uconvertCtxF segs >>= \dsegs -> + return $ step1 dstart (viewl dsegs) + where + step1 p0 EmptyL = emptyPrimPath p0 + step1 _ (e :< se) = let (p0,a) = seg1 e + rest = step2 (viewl se) + in absPrimPath p0 (a:rest) + + step2 EmptyL = [] + step2 (e :< se) = seg2 e : step2 (viewl se) + + seg1 (AbsLineSeg _ p0 p1) = (p0, absLineTo p1) + seg1 (AbsCurveSeg _ p0 p1 p2 p3) = (p0, absCurveTo p1 p2 p3) + + seg2 (AbsLineSeg _ _ p1) = absLineTo p1 + seg2 (AbsCurveSeg _ _ p1 p2 p3) = absCurveTo p1 p2 p3 + + + + + + +-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @ +-- +shortenPath :: (Real u , Floating u) + => u -> u -> AbsPath u -> AbsPath u +shortenPath l r = shortenL l . shortenR r + + +-------------------------------------------------------------------------------- +-- shorten from the left... + +-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point. +-- +shortenL :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u +shortenL n (AbsPath u _ segs ep) + | n >= u = line1 ep ep + | otherwise = step n (viewl segs) + where + step _ EmptyL = line1 ep ep -- should be unreachable + step d (e :< se) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewl se) + EQ -> makeLeftPath (u-n) se ep + LT -> let e1 = shortenSegL d e + sp = segmentStart e1 + in AbsPath (u-n) sp (e1 `cons` se) ep + + +makeLeftPath :: Floating u + => u -> JoinList (AbsPathSeg u) -> Point2 u -> AbsPath u +makeLeftPath u se ep = + case viewl se of + EmptyL -> line1 ep ep + (e :< _) -> AbsPath u (segmentStart e) se ep + + +shortenSegL :: (Real u, Floating u) + => u -> AbsPathSeg u -> AbsPathSeg u +shortenSegL n (AbsLineSeg u p0 p1) = + AbsLineSeg (u-n) (shortenLineL n p0 p1) p1 + +shortenSegL n (AbsCurveSeg u p0 p1 p2 p3) = + AbsCurveSeg (u-n) q0 q1 q2 q3 + where + (BezierCurve q0 q1 q2 q3) = snd $ subdividet (n/u) + (BezierCurve p0 p1 p2 p3) + + + +shortenLineL :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineL n p0 p1 = p0 .+^ v + where + v0 = p1 .-. p0 + v = avec (vdirection v0) n + + + +-------------------------------------------------------------------------------- +-- shorten from the right ... + +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point. +-- +shortenR :: (Real u, Floating u) => u -> AbsPath u -> AbsPath u +shortenR n (AbsPath u sp segs _) + | n >= u = line1 sp sp + | otherwise = step n (viewr segs) + where + step _ EmptyR = line1 sp sp -- should be unreachable + step d (se :> e) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewr se) + EQ -> makeRightPath n sp se + LT -> let e1 = shortenSegR d e + ep = segmentEnd e1 + in AbsPath (u-n) sp (se `snoc` e1) ep + + +makeRightPath :: Floating u + => u -> Point2 u -> JoinList (AbsPathSeg u) -> AbsPath u +makeRightPath u sp se = + case viewr se of + EmptyR -> line1 sp sp + (_ :> e) -> AbsPath u sp se (segmentEnd e) + + + +shortenSegR :: (Real u, Floating u) + => u -> AbsPathSeg u -> AbsPathSeg u +shortenSegR n (AbsLineSeg u p0 p1) = + AbsLineSeg (u-n) p0 (shortenLineR n p0 p1) + +shortenSegR n (AbsCurveSeg u p0 p1 p2 p3) = AbsCurveSeg (u-n) q0 q1 q2 q3 + where + (BezierCurve q0 q1 q2 q3) = fst $ subdividet ((u-n)/u) + (BezierCurve p0 p1 p2 p3) + + + +shortenLineR :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineR n p0 p1 = p1 .+^ v + where + v0 = p0 .-. p1 + v = avec (vdirection v0) n + + + +-------------------------------------------------------------------------------- +-- tips + +tipL :: AbsPath u -> Point2 u +tipL (AbsPath _ sp _ _) = sp + + +tipR :: AbsPath u -> Point2 u +tipR (AbsPath _ _ _ ep) = ep + + +-------------------------------------------------------------------------------- +-- line direction + +-- | Direction of empty path is considered to be 0. +-- +directionL :: (Real u, Floating u) => AbsPath u -> Radian +directionL (AbsPath _ _ se _) = step $ viewl se + where + step (AbsLineSeg _ p0 p1 :< _) = lineDirection p1 p0 -- 1-to-0 + step (AbsCurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0 + step _ = 0 -- should be unreachable + + +-- | Direction of empty path is considered to be 0. +-- +directionR :: (Real u, Floating u) => AbsPath u -> Radian +directionR (AbsPath _ _ se _) = step $ viewr se + where + step (_ :> AbsLineSeg _ p0 p1) = lineDirection p0 p1 + step (_ :> AbsCurveSeg _ _ _ p2 p3) = lineDirection p2 p3 + step _ = 0 -- should be unreachable + + + + +-------------------------------------------------------------------------------- + + +-- Return direction as well because the calculation is expensive... +-- +midway :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian) +midway pa@(AbsPath u sp _ _) + | u == 0 = (sp,0) + | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) + +-- Just the midway point. +-- +midway_ :: (Real u, Floating u) => AbsPath u -> Point2 u +midway_ = fst . midway + + +atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian) +atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa) + +atstart_ :: AbsPath u -> Point2 u +atstart_ (AbsPath _ sp _ _) = sp + + +atend :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian) +atend pa@(AbsPath _ _ _ ep) = (ep, directionR pa) + + +atend_ :: AbsPath u -> Point2 u +atend_ (AbsPath _ _ _ ep) = ep + + +-- nearstart, nearend, verynear ... + + +-------------------------------------------------------------------------------- + +infixr 5 :<< +infixl 5 :>> + +data PathViewL u = PathOneL (PathSegment u) + | PathSegment u :<< AbsPath u + deriving (Eq,Show) + +type DPathViewL = PathViewL Double + +data PathViewR u = PathOneR (PathSegment u) + | AbsPath u :>> PathSegment u + deriving (Eq,Show) + +type DPathViewR = PathViewR Double + + +data PathSegment u = LineSeg (Point2 u) (Point2 u) + | CurveSeg (Point2 u) (Point2 u) (Point2 u) (Point2 u) + deriving (Eq,Show) + +type DPathSegment = PathSegment Double + + +-------------------------------------------------------------------------------- + +instance Functor PathSegment where + fmap f (LineSeg p0 p1) = LineSeg (fmap f p0) (fmap f p1) + fmap f (CurveSeg p0 p1 p2 p3) = + CurveSeg (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3) + +instance Functor PathViewL where + fmap f (PathOneL a) = PathOneL (fmap f a) + fmap f (a :<< as) = fmap f a :<< fmap f as + +instance Functor PathViewR where + fmap f (PathOneR a) = PathOneR (fmap f a) + fmap f (as :>> a) = fmap f as :>> fmap f a + +-------------------------------------------------------------------------------- + + + +pathViewL :: Num u => AbsPath u -> PathViewL u +pathViewL (AbsPath u _ segs ep) = go (viewl segs) + where + go EmptyL = error "pathViewL - (not) unreachable." + + go (AbsLineSeg v p0 p1 :< se) + | JL.null se = PathOneL (LineSeg p0 p1) + | otherwise = LineSeg p0 p1 :<< AbsPath (u-v) p1 se ep + + go (AbsCurveSeg v p0 p1 p2 p3 :< se) + | JL.null se = PathOneL (CurveSeg p0 p1 p2 p3) + | otherwise = CurveSeg p0 p1 p2 p3 :<< AbsPath (u-v) p3 se ep + + +pathViewR :: Num u => AbsPath u -> PathViewR u +pathViewR (AbsPath u _ segs ep) = go (viewr segs) + where + go EmptyR = error "pathViewR - (not) unreachable." + + go (se :> AbsLineSeg v p0 p1) + | JL.null se = PathOneR (LineSeg p0 p1) + | otherwise = AbsPath (u-v) p1 se ep :>> LineSeg p0 p1 + + go (se :> AbsCurveSeg v p0 p1 p2 p3) + | JL.null se = PathOneR (CurveSeg p0 p1 p2 p3) + | otherwise = AbsPath (u-v) p3 se ep :>> CurveSeg p0 p1 p2 p3 + + + + +-------------------------------------------------------------------------------- +-- Round corners + +-- NOTE - round corners are probably better suited to construction +-- rather than transformation. +-- +-- The code below is pencilled in to change. +-- + + + +-- | The length of the control-point vector wants to be slighly +-- longer than half of /d/ (d - being the distance between the +-- /truncated/ points and the corner). +-- +cornerCurve :: (Real u, Floating u, Tolerance u) + => Point2 u -> Point2 u -> Point2 u -> AbsPath u +cornerCurve p1 p2 p3 = curve1 p1 cp1 cp2 p3 + where + len1 = 0.6 * (vlength $ pvec p1 p2) + len2 = 0.6 * (vlength $ pvec p3 p2) + cp1 = p1 .+^ (avec (lineAngle p1 p2) len1) + cp2 = p3 .+^ (avec (lineAngle p3 p2) len2) + + +-- | 'roundTrail' : @ rounding_distance * [point] -> Path @ +-- +-- Build a path from the list of vertices, all the interior +-- corners are rounded by the rounding distance \*and\* final +-- round corner is created \"incorporating\" the start point (as +-- the start point becomes a rounded corner the actual path will +-- not intersect it). +-- +-- It is expected that this function will be used to create round +-- cornered shapes. +-- +-- 'roundTrail' throws a runtime error if the input list is empty. +-- If the list has one element /the null path/ is built, if the +-- list has two elements a straight line is built. +-- +roundTrail :: (Real u, Floating u, Tolerance u) + => u -> [Point2 u] -> AbsPath u +roundTrail _ [] = error "roundTrail - empty list." +roundTrail _ [a] = zeroPath a +roundTrail _ [a,b] = line1 a b +roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs) + where + step acc (m:n:o:ps) = step (acc `append` lineCurveTrail u m n o) (n:o:ps) + step acc [n,o] = acc `append` lineCurveTrail u n o start + `append` lineCurveTrail u o start b + step acc _ = acc + + + +-- | Two parts - line and corner curve... +-- +-- Note - the starting point is moved, this function is for +-- closed, rounded paths. +-- +lineCurveTrail :: (Real u, Floating u, Tolerance u) + => u -> Point2 u -> Point2 u -> Point2 u -> AbsPath u +lineCurveTrail u a b c = line1 p1 p2 `append` cornerCurve p2 b p3 + where + p1 = a .+^ (avec (vdirection $ pvec a b) u) + p2 = b .+^ (avec (vdirection $ pvec b a) u) + p3 = b .+^ (avec (vdirection $ pvec b c) u) + + +-- | 'roundInterior' : @ rounding_distance * [point] -> Path @ +-- +-- Build a path from the list of vertices, all the interior +-- corners are rounded by the rounding distance. Unlike +-- 'roundTrail' there is no /loop around/ to the start point, +-- and start path will begin exactly on the start point and end +-- exactly on the end point. +-- +-- 'roundInterior' throws a runtime error if the input list is +-- empty. If the list has one element /the null path/ is built, +-- if the list has two elements a straight line is built. +-- +roundInterior :: (Real u, Floating u, Tolerance u) + => u -> [Point2 u] -> AbsPath u +roundInterior _ [] = error "roundEveryInterior - empty list." +roundInterior _ [a] = zeroPath a +roundInterior _ [a,b] = line1 a b +roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c + in step path1 (p1:c:xs) + where + step acc (m:n:o:ps) = let (seg2,p1) = lineCurveInter1 u m n o + in step (acc `append` seg2) (p1:o:ps) + step acc [n,o] = acc `append` line1 n o + step acc _ = acc + + + +-- | Two parts - line and corner curve... +-- +-- Note - draws a straight line from the starting point - this is +-- the first step of an interior (non-closed) rounded path +-- +lineCurveInter1 :: (Real u, Floating u, Tolerance u) + => u -> Point2 u -> Point2 u -> Point2 u + -> (AbsPath u, Point2 u) +lineCurveInter1 u a b c = + (line1 a p2 `append` cornerCurve p2 b p3, p3) + where + p2 = b .+^ (avec (vdirection $ pvec b a) u) + p3 = b .+^ (avec (vdirection $ pvec b c) u) + diff --git a/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs b/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/BuildCommon.hs @@ -0,0 +1,129 @@ +{-# 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/RelBuilder.hs b/src/Wumpus/Drawing/Paths/Base/RelBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/RelBuilder.hs @@ -0,0 +1,520 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base/RelPath.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Base.RelPath +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Relative path type - this should be more amenable for building +-- complex drawings than the PrimPath type in Wumpus-Core. +-- +-- Note - RelPath is not directly equivalent to AbsPath. +-- AbsPath is more powerful - as it is expected to have more +-- demanding use-cases (e.g. connector paths). +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base.RelPath + ( + + + -- * Relative path type + + RelPath + , DRelPath + + -- * Construction + , empty + , line1 + , curve1 + , vertexPath + , curvedPath + + , circular + + -- * Queries + , null + + + -- * Concat + , append + , consLineTo + , snocLineTo + , consCurveTo + , snocCurveTo + + + -- * Conversion + , fromPathAlgVertices + , fromPathAlgCurves + + , toPrimPath + , toAbsPath + , strokeRelPath + + ) where + + +import Wumpus.Drawing.Paths.Base.AbsPath ( AbsPath ) +import qualified Wumpus.Drawing.Paths.Base.AbsPath as Abs + +import Wumpus.Basic.Geometry +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl, join ) +import qualified Wumpus.Basic.Utils.JoinList as JL + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace + +import qualified Data.Foldable as F +import Data.Monoid +import qualified Data.Traversable as T +import Prelude hiding ( null ) + + + + + +-- | Relative Path data type. +-- +-- 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) } + deriving (Eq,Show) + +type instance DUnit (RelPath u) = u + + +type DRelPath = RelPath Double + +-- No annotations... +-- +data RelPathSeg u = RelLineSeg (Vec2 u) + | RelCurveSeg (Vec2 u) (Vec2 u) (Vec2 u) + deriving (Eq,Show) + + +type instance DUnit (RelPathSeg u) = u + + + +-------------------------------------------------------------------------------- + +instance Functor RelPath where + fmap f = RelPath . fmap (fmap f) . getRelPath + +instance Functor RelPathSeg where + fmap f (RelLineSeg v1) = + RelLineSeg (fmap f v1) + + fmap f (RelCurveSeg v1 v2 v3) = + RelCurveSeg (fmap f v1) (fmap f v2) (fmap f v3) + + +instance Monoid (RelPath u) where + mempty = empty + mappend = append + + +-------------------------------------------------------------------------------- +-- Construction + + +-- | An empty relative path is acceptible to Wumpus because +-- it is always drawn as a LocGraphic. +-- +empty :: RelPath u +empty = RelPath mempty + +-- | Create a relative path from a single straight line. +-- +line1 :: Vec2 u -> RelPath u +line1 = RelPath . JL.one . RelLineSeg + + +-- | 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 + + +vertexPath :: [Vec2 u] -> RelPath u +vertexPath [] = empty +vertexPath (x:xs) = go (line1 x) xs + where + go acc [] = acc + go acc (v:vs) = go (acc `snocLineTo` v) vs + + + +curvedPath :: [Vec2 u] -> RelPath u +curvedPath xs = case xs of + (v1:v2:v3:vs) -> go (curve1 v1 v2 v3) vs + _ -> empty + where + go acc (v1:v2:v3:vs) = go (acc `append` curve1 v1 v2 v3) vs + go acc _ = acc + + + +circular :: Floating u => u -> RelPath u +circular = snd . fromPathAlgCurves . circlePathAlg + +-------------------------------------------------------------------------------- +-- Queries + +null :: RelPath u -> Bool +null = JL.null . getRelPath + + + +-------------------------------------------------------------------------------- +-- Concat + +infixr 1 `append` + + + +append :: RelPath u -> RelPath u -> RelPath u +append (RelPath se0) (RelPath se1) = RelPath $ se0 `join` se1 + + +consLineTo :: Vec2 u -> RelPath u -> RelPath u +consLineTo v1 (RelPath se) = RelPath $ JL.cons (RelLineSeg v1) se + +snocLineTo :: RelPath u -> Vec2 u -> RelPath u +snocLineTo (RelPath se) v1 = RelPath $ JL.snoc se (RelLineSeg 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 + +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) + + + + + +-------------------------------------------------------------------------------- +-- Conversion + +fromPathAlgVertices :: Num 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 = bimap fn curvedPath . runPathAlgVec + where + fn = maybe (V2 0 0) id + + +toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query 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 + + +toAbsPath :: (Floating u, Ord u, Tolerance u) + => Point2 u -> RelPath u -> AbsPath u +toAbsPath start (RelPath segs) = step1 start $ viewl segs + where + step1 p0 EmptyL = Abs.empty p0 + + step1 p0 (RelLineSeg v1 :< se) = + let (pth,end) = aline p0 v1 in step2 end pth (viewl 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) = + let (s1,end) = aline p0 v1 + in step2 end (acc `Abs.append` s1) (viewl 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) + + aline p0 v1 = + let p1 = p0 .+^ v1 in (Abs.line1 p0 p1, p1) + + acurve p0 v1 v2 v3 = + let p1 = p0 .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in (Abs.curve1 p0 p1 p2 p3, p3) + + + +strokeRelPath :: InterpretUnit u => RelPath u -> LocGraphic u +strokeRelPath rp = + promoteR1 $ \start -> toPrimPath start rp >>= openStroke + + diff --git a/src/Wumpus/Drawing/Paths/Connectors.hs b/src/Wumpus/Drawing/Paths/Connectors.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Connectors.hs +++ /dev/null @@ -1,253 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Library of connector paths... --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Connectors - ( - - ConnectorPath - , DConnectorPath - , sconnect - - , connLine - - , connRightVH - , connRightHV - , connRightVHV - , connRightHVH - - , connIsosceles - , connIsosceles2 - , connLightningBolt - - , connIsoscelesCurve - , connSquareCurve - , connUSquareCurve - - , connTrapezoidCurve - , connZSquareCurve - , connUZSquareCurve - - ) where - -import Wumpus.Drawing.Paths.Base -import Wumpus.Drawing.Paths.ControlPoints - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative -import Prelude hiding ( length ) - - --- | Note - a ConnectorPath is not drawn automatically, it is a --- @ConnectorCF@ not a @ConnectorGraphic@ or @ConnectorImage@. --- -type ConnectorPath u = ConnectorCF u (Path u) - -type DConnectorPath = ConnectorPath Double - - - --- Maybe this should be ConnectorPath u -> ConnectorImage u (Path u) instead? --- This would be closer to the new shapes... --- -sconnect :: Num u - => ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u) -sconnect mf p0 p1 = - connect mf p0 p1 >>= \cpath -> - intoImage (pure cpath) (openStroke $ toPrimPath cpath) - - --- | Build the path with interior round corners. --- -roundCornerPath :: (Real u, Floating u, FromPtSize u) - => [Point2 u] -> CF (Path u) -roundCornerPath xs = getRoundCornerSize >>= \sz -> - if sz == 0 then return (traceLinePoints xs) - else return (roundInterior sz xs) - - - --------------------------------------------------------------------------------- - --- | Connect with a straight line. --- -connLine :: Floating u => ConnectorPath u -connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1 - - - --- | Right-angled connector - go vertical, then go horizontal. --- -connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u -connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> - let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1] - - - --- | Right-angled connector - go horizontal, then go vertical. --- -connRightHV :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> - let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1] - --- | Right-angled connector - go vertical for the supplied --- distance, go horizontal, go vertical again for the --- remaining distance. --- -connRightVHV :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) -> - let a0 = p0 .+^ vvec v - a1 = a0 .+^ hvec (x1 - x0) - in roundCornerPath [p0, a0, a1, p1] - - --- | Right-angled connector - go horizontal for the supplied --- distance, go verical, go horizontal again for the --- remaining distance. --- -connRightHVH :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) -> - let a0 = p0 .+^ hvec h - a1 = a0 .+^ vvec (y1 - y0) - in roundCornerPath [p0,a0,a1,p1] - - --- | /Triangular/ joint. --- --- @u@ is the altitude of the triangle. --- -connIsosceles :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connIsosceles dy = promoteR2 $ \ p0 p1 -> - let mid_pt = midpointIsosceles dy p0 p1 - in roundCornerPath [p0, mid_pt, p1] - - - - - --- | Double /triangular/ joint. --- --- @u@ is the altitude of the triangle. --- -connIsosceles2 :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connIsosceles2 u = promoteR2 $ \ p0 p1 -> - let (cp0,cp1) = dblpointIsosceles u p0 p1 - in roundCornerPath [ p0, cp0, cp1, p1 ] - - - --- | /Lightning bolt/ joint - a two joint connector with an /axis/ --- perpendicular to the connector direction. --- --- @u@ is the half length of the of the axis. --- -connLightningBolt :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connLightningBolt u = promoteR2 $ \ p0 p1 -> - let cp0 = midpointIsosceles u p0 p1 - cp1 = midpointIsosceles (-u) p0 p1 - in roundCornerPath [ p0, cp0, cp1, p1 ] - --------------------------------------------------------------------------------- - - - --- | Form a curve inside an isosceles triangle. --- --- The two Bezier control points take the same point - the --- altitude of the triangle. The curve tends to be quite shallow --- relative to the altitude. --- --- @u@ is the altitude of the triangle. --- -connIsoscelesCurve :: (Real u, Floating u, FromPtSize u) - => u -> ConnectorPath u -connIsoscelesCurve u = promoteR2 $ \ p0 p1 -> - let control_pt = midpointIsosceles u p0 p1 - in pure $ traceCurvePoints [p0, control_pt, control_pt, p1] - - - --- | Form a curve inside a square. --- --- The two Bezier control points take the /top/ corners. The --- curve tends to be very deep. --- -connSquareCurve :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -connSquareCurve = promoteR2 $ \ p0 p1 -> - let (cp0,cp1) = squareFromBasePoints p0 p1 - in pure $ traceCurvePoints [p0, cp0, cp1, p1] - - - --- | Form a curve inside a square. --- --- As per 'connSquareCurve' but the curve is drawn /underneath/ --- the line formed between the start and end points. --- --- (Underneath is modulo the direction, of course). --- -connUSquareCurve :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -connUSquareCurve = promoteR2 $ \ p0 p1 -> - let (cp0,cp1) = usquareFromBasePoints p0 p1 - in pure $ traceCurvePoints [p0, cp0, cp1, p1] - - --- | altitude * ratio_to_base --- --- Form a curve inside a trapeziod. --- -connTrapezoidCurve :: (Real u, Floating u, FromPtSize u) - => u -> u -> ConnectorPath u -connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> - let (cp0,cp1) = trapezoidFromBasePoints u ratio_to_base p0 p1 - in pure $ traceCurvePoints [p0, cp0, cp1, p1] - - --- | Make a curve within a square, following the corner points as --- a Z. --- -connZSquareCurve :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -connZSquareCurve = promoteR2 $ \p0 p1 -> - let (cp0,cp1) = squareFromCornerPoints p0 p1 - in pure $ traceCurvePoints [p0,cp0,cp1,p1] - --- | Make a curve within a square, following the corner points as --- a Z. --- --- The order of tracing flips the control points, so this is an --- /underneath/ version of 'connZSquareCurve'. --- -connUZSquareCurve :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -connUZSquareCurve = promoteR2 $ \ p0 p1 -> - let (cp0,cp1) = squareFromCornerPoints p0 p1 - in pure $ traceCurvePoints [p0,cp1,cp0,p1] - diff --git a/src/Wumpus/Drawing/Paths/ControlPoints.hs b/src/Wumpus/Drawing/Paths/ControlPoints.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/ControlPoints.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.ControlPoints --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Collection of point manufacturing functions. --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.ControlPoints - ( - - midpointIsosceles - , dblpointIsosceles - - , rectangleFromBasePoints - , squareFromBasePoints - , usquareFromBasePoints - - , trapezoidFromBasePoints - - , squareFromCornerPoints - - ) where - -import Wumpus.Basic.Kernel - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - - - --- | 'midpointIsosceles' : --- @ altitude * start_pt * end_pt -> mid_pt @ --- --- Triangular midpoint. --- --- @u@ is the altitude of the triangle - negative values of u --- form the triangle below the line. --- -midpointIsosceles :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = - mid_pt .+^ avec perp_ang u - where - mid_pt = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1)) - perp_ang = (pi*0.5) + vdirection (pvec p1 p2) - - - --- | 'dblpointIsosceles' : --- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @ --- --- Double triangular joint - one joint at a third of the line --- length, the other at two thirds. --- -dblpointIsosceles :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) -dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = - (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u) - where - mid1 = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1)) - mid2 = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1)) - perp_ang = (pi*0.5) + vdirection (pvec p1 p2) - - --------------------------------------------------------------------------------- - - - --- | 'rectangleFromBasePoints' : --- @ altitude * start_pt * end_pt * (top_left, top_right) @ --- --- Control points forming a rectangle. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -rectangleFromBasePoints :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) -rectangleFromBasePoints u p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - theta = vdirection base_vec - cp1 = displacePerpendicular u theta p1 - cp2 = displacePerpendicular u theta p2 - - --- | 'squareFromBasePoints' : --- @ start_pt -> end_pt -> (top_left, top_right) @ --- --- Control points forming a square - side_len derived from the --- distance between start and end points. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -squareFromBasePoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 - where - side_len = vlength $ pvec p1 p2 - - --- | 'usquareFromBasePoints' : --- @ start_pt -> end_pt -> (bottom_left, bottom_right) @ --- --- Control points forming a square - side_len derived from the --- distance between start and end points. --- --- As per 'squareFromBasePoints' but the square is drawn --- /underneath/ the line formed between the start and end points. --- (Underneath is modulo the direction, of course). --- --- The two manufactured control points form the /bottom/ corners, --- so the supplied points map as @start_point == top_left@ and --- @end_point == top_right@. --- -usquareFromBasePoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 - where - side_len = negate $ vlength $ pvec p1 p2 - - - - - --- | 'trapezoidFromBasePoints' : --- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @ --- --- Control points form an isosceles trapezoid. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -trapezoidFromBasePoints :: (Real u, Floating u) - => u -> u -> Point2 u -> Point2 u - -> (Point2 u, Point2 u) -trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - 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 - - - - --- | 'squareFromCornerPoints' : --- @ altitude * start_pt * end_pt * (top_left, bottom_right) @ --- --- Control points forming a square bisected by the line from --- start_pt to end_pt. --- --- The two manufactured control points form the top_left and --- bottom_right corners, so the supplied points map as --- @start_point == bottom_left@ and @end_point == top_right@. --- -squareFromCornerPoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -squareFromCornerPoints p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - half_len = 0.5 * (vlength base_vec) - theta = vdirection base_vec - base_mid = displaceParallel half_len theta p1 - cp1 = displacePerpendicular half_len theta base_mid - cp2 = displacePerpendicular (-half_len) theta base_mid - diff --git a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.MonadicConstruction --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Build paths monadically. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.MonadicConstruction - ( - - PathM - , runPath - , execPath - - , tip - - , lineto - , rlineto - , hline - , vline - - , bezierto - , curveto - - , verticalHorizontal - , horizontalVertical - - ) where - -import Wumpus.Basic.Utils.HList -import Wumpus.Drawing.Paths.Base - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative -import Data.List - - --- Are connectors and paths quite different things? --- --- It looks like they are - connectors always know start and end --- points. --- - - --- State monad version 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 - , path_acc :: H (Path u) - } - - -newtype PathM u a = PathM { getPathM :: St u -> (a,St u) } - - -instance Functor (PathM u) where - fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1) - - -instance Applicative (PathM u) where - pure a = PathM $ \s -> (a,s) - mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s - (a,s2) = getPathM ma s1 - in (f a,s2) - -instance Monad (PathM u) where - return a = PathM $ \s -> (a,s) - m >>= k = PathM $ \s -> let (a,s1) = getPathM m s in - (getPathM . k) a s1 - - - --- Running the path is (probably) agnostic to the DrawingCtx. --- -runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u) -runPath start mf = - let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s') - where - s = St { current_point = start - , path_acc = emptyH - } - post [] = line start start - post (x:xs) = foldl' append x xs - -execPath :: Floating u => Point2 u -> PathM u a -> Path u -execPath start mf = snd $ runPath start mf - -snocline :: Floating u => Vec2 u -> PathM u () -snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v - in ((), St ep (ac `snocH` line pt ep)) - - -tip :: PathM u (Point2 u) -tip = PathM $ \s -> (current_point s,s) - - -lineto :: Floating u => Point2 u -> PathM u () -lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt)) - -rlineto :: Floating u => Vec2 u -> PathM u () -rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) - - -hline :: Floating u => u -> PathM u () -hline len = snocline (hvec len) - -vline :: Floating u => u -> PathM u () -vline len = snocline (vvec len) - - - -bezierto :: (Floating u, Ord u, FromPtSize u) - => Point2 u -> Point2 u -> Point2 u -> PathM u () -bezierto c1 c2 ep = PathM $ \(St p0 ac) -> - ((), St ep (ac `snocH` curve p0 c1 c2 ep)) - - - - - --- - - -curveto :: (Floating u, Ord u, FromPtSize u) - => Radian -> Radian -> Point2 u -> PathM u () -curveto cin cout end = PathM $ \(St p0 ac) -> - let seg = curveByAngles p0 cin cout end - ac1 = ac `snocH` seg - end1 = tipR seg - in ((), St end1 ac1) - - - - -verticalHorizontal :: Floating u => Point2 u -> PathM u () -verticalHorizontal (P2 x y) = - tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y) - -horizontalVertical :: Floating u => Point2 u -> PathM u () -horizontalVertical (P2 x y) = - tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y) - diff --git a/src/Wumpus/Drawing/Paths/Relative.hs b/src/Wumpus/Drawing/Paths/Relative.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Relative.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Relative +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim import module for the Relative Path modules. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Relative + ( + + module Wumpus.Drawing.Paths.Base.RelBuilder + , module Wumpus.Drawing.Paths.Base.RelPath + + ) where + +import Wumpus.Drawing.Paths.Base.RelBuilder +import Wumpus.Drawing.Paths.Base.RelPath + diff --git a/src/Wumpus/Drawing/Paths/Vamps.hs b/src/Wumpus/Drawing/Paths/Vamps.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Vamps.hs @@ -0,0 +1,56 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Vamps +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim import module for the Absolute Path modules. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Vamps + ( + + -- * Re-exported types + Vamp(..) + , PathEnd(..) + + , circleVamp + + ) where + +import Wumpus.Drawing.Paths.Base.BuildCommon +import Wumpus.Drawing.Paths.Base.RelPath + +import Wumpus.Basic.Geometry -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.VectorSpace -- package: vector-space + + +-- TODO - library of useful / illustrative vamps (circle, square etc.) + + + + +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 + } + where + radius = 0.5 * vlength v0 + half_v0 = 0.5 *^ v0 + (v1,path) = fromPathAlgCurves $ circlePathAlg radius + + -- Note - circlePathAlg starts from east 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -24,8 +23,10 @@ Shape , DShape + , shapeMap , makeShape , strokedShape + , dblStrokedShape , filledShape , borderedShape , rstrokedShape @@ -41,21 +42,23 @@ , makeShapeCTM , ctmCenter , ctmAngle - , displaceCenter - + , projectFromCtr ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour ( white ) import Data.AffineSpace -- package: vector-space import Control.Applicative +-- import Data.Traversable ( Traversable ) +-- import qualified Data.Traversable as T -- | Shape is a record of three /LocTheta/ functions - -- functions /from Point and Angle to answer/. @@ -73,23 +76,28 @@ -- to address specific locations on the Shape border so -- \"node and link\" diagrams can be made easily. -- -data Shape u a = Shape - { shape_ans_fun :: LocThetaCF u a - , shape_path_fun :: LocThetaCF u (Path u) +data Shape t u = Shape + { shape_ans_fun :: LocThetaQuery u (t u) + , shape_path_fun :: LocThetaQuery u (AbsPath u) , shape_decoration :: LocThetaGraphic u } -type DShape a = Shape Double a +type DShape t = Shape t Double -type instance DUnit (Shape u a) = u +-- Design note - shapes look like they should be constrained to +-- InterpretUnit rather than CtxSize, this allows direct affine +-- transformations. +-- + -------------------------------------------------------------------------------- -instance Functor (Shape u) where - fmap f = (\s i -> s { shape_ans_fun = fmap f i }) - <*> shape_ans_fun +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 }) + <*> shape_ans_fun -- Note - there are no instances of Applicative, Monad, @@ -104,7 +112,8 @@ -------------------------------------------------------------------------------- -makeShape :: Num u => LocThetaCF u a -> LocThetaCF u (Path u) -> Shape u a +makeShape :: InterpretUnit u + => 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 @@ -113,59 +122,75 @@ -strokedShape :: Num u => Shape u a -> LocImage u a +strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) strokedShape = shapeToLoc closedStroke -filledShape :: Num u => Shape u a -> LocImage u a +-- | Note - this is simplistic double stroking - draw a background +-- line with triple thickness and draw a white line on top. +-- +-- I think this is what TikZ does, but it works better for TikZ +-- where the extra thickness seems to be accounted for by the +-- anchors. For Wumpus, arrows cut into the outside black line. +-- +-- Probably Wumpus should calculate two paths instead. +-- +dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) +dblStrokedShape sh = decorateR1 back fore + where + img = shapeToLoc closedStroke sh + back = getLineWidth >>= \lw -> + localize (set_line_width $ lw * 3.0) img + fore = pushR1 ignoreAns $ localize (stroke_colour white) img + + + +filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u) filledShape = shapeToLoc filledPath -borderedShape :: Num u => Shape u a -> LocImage u a +borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) borderedShape = shapeToLoc borderedPath -shapeToLoc :: Num u - => (PrimPath u -> Graphic u) -> Shape u a -> LocImage u a -shapeToLoc pathF sh = promoteR1 $ \pt -> - atRot (shape_ans_fun sh) pt 0 >>= \a -> - atRot (shape_path_fun sh) pt 0 >>= \spath -> - let g1 = pathF $ toPrimPath spath - g2 = atRot (shape_decoration sh) pt 0 - in intoImage (pure a) (g1 `oplus` g2) +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 -> + let g2 = atIncline (shape_decoration sh) pt 0 + in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF) -rstrokedShape :: Num u => Shape u a -> LocThetaImage u a +rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) rstrokedShape = shapeToLocTheta closedStroke -rfilledShape :: Num u => Shape u a -> LocThetaImage u a +rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) rfilledShape = shapeToLocTheta filledPath -rborderedShape :: Num u => Shape u a -> LocThetaImage u a +rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) rborderedShape = shapeToLocTheta borderedPath -shapeToLocTheta :: Num u - => (PrimPath u -> Graphic u) -> Shape u a -> LocThetaImage u a -shapeToLocTheta pathF sh = promoteR2 $ \pt theta -> - atRot (shape_ans_fun sh) pt theta >>= \a -> - atRot (shape_path_fun sh) pt theta >>= \spath -> - let g1 = pathF $ toPrimPath spath - g2 = atRot (shape_decoration sh) pt theta - in intoImage (pure a) (g1 `oplus` g2) +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 -> + let g2 = atIncline (shape_decoration sh) pt theta + in intoImage (pure a) (decorateR0 g2 $ toPrimPath spath >>= drawF) -- | Draw the shape path with round corners. -- -roundCornerShapePath :: (Real u, Floating u, FromPtSize u) - => [Point2 u] -> CF (Path u) -roundCornerShapePath xs = getRoundCornerSize >>= \sz -> - if sz == 0 then return (traceLinePoints xs) - else return (roundTrail sz xs) +roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> [Point2 u] -> Query (AbsPath u) +roundCornerShapePath sz xs = + if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail sz xs) -- | The path angle can be modified. This allows /inverse/ -- versions of shapes (e.g. InvTriangle) to be made by @@ -176,26 +201,19 @@ -- angle. The anchors are typically implemented by rotating the -- correspoding anchor of the wrapped Shape about its center. -- -updatePathAngle :: (Radian -> Radian) -> Shape u a -> Shape u a +updatePathAngle :: (Radian -> Radian) -> Shape t u -> Shape t u updatePathAngle f = - (\s i -> s { shape_path_fun = moveTheta (circularModulo . f) i}) + (\s i -> s { shape_path_fun = promoteR2 $ \pt ang -> + apply2R2 i pt (mvTheta ang) }) <*> shape_path_fun + where + mvTheta = circularModulo . f -setDecoration :: LocThetaGraphic u -> Shape u a -> Shape u a +setDecoration :: LocThetaGraphic u -> Shape t u -> Shape t u setDecoration gf = (\s -> s { shape_decoration = gf }) - --- For Wumpus-Basic... --- | Move the /rotation/ of a LocThetaImage with the supplied --- displacement function. --- -moveTheta :: (Radian -> Radian) -> LocThetaCF u a -> LocThetaCF u a -moveTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta) - - - -------------------------------------------------------------------------------- -- CTM @@ -205,31 +223,47 @@ data ShapeCTM u = ShapeCTM { ctm_center :: Point2 u - , ctm_scale_x :: !u - , ctm_scale_y :: !u + , ctm_scale_x :: !Double + , ctm_scale_y :: !Double , ctm_rotation :: Radian } deriving (Eq,Ord,Show) - type instance DUnit (ShapeCTM u) = u -makeShapeCTM :: Num u => Point2 u -> Radian -> ShapeCTM u + +instance Functor ShapeCTM where + fmap f = (\s i -> s { ctm_center = fmap f i }) <*> ctm_center + + +makeShapeCTM :: Point2 u -> Radian -> ShapeCTM u makeShapeCTM pt ang = ShapeCTM { ctm_center = pt , ctm_scale_x = 1 , ctm_scale_y = 1 , ctm_rotation = ang } -instance Num u => Scale (ShapeCTM u) where - scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy }) - <*> ctm_scale_x <*> ctm_scale_y +ctmCenter :: ShapeCTM u -> Point2 u +ctmCenter = ctm_center +ctmAngle :: ShapeCTM u -> Radian +ctmAngle = ctm_rotation -instance Rotate (ShapeCTM u) where - rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang }) - <*> ctm_rotation +instance (Fractional u) => Scale (ShapeCTM u) where + scale sx sy = (\s x y pt -> s { ctm_scale_x = x*sx + , ctm_scale_y = y*sy + , ctm_center = scale sx sy pt }) + <*> ctm_scale_x <*> ctm_scale_y <*> ctm_center + + +instance (Real u, Floating u) => Rotate (ShapeCTM u) where + rotate ang = (\s i pt -> let ctr = rotate ang pt + in s { ctm_rotation = circularModulo $ i+ang + , ctm_center = ctr }) + <*> ctm_rotation <*> ctm_center + + instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where rotateAbout ang pt = (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang @@ -237,27 +271,18 @@ <*> ctm_center <*> ctm_rotation -instance Num u => Translate (ShapeCTM u) where - translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) }) - <*> ctm_center - +instance (Num u) => Translate (ShapeCTM u) where + translate dx dy = + (\s i -> s { ctm_center = translate dx dy i }) + <*> ctm_center -ctmCenter :: ShapeCTM u -> Point2 u -ctmCenter = ctm_center - -ctmAngle :: ShapeCTM u -> Radian -ctmAngle = ctm_rotation +projectFromCtr :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Anchor u +projectFromCtr v (ShapeCTM { ctm_center = ctr + , ctm_scale_x = sx + , ctm_scale_y = sy + , ctm_rotation = theta }) = + let v1 = rotate theta $ scale sx sy $ v in ctr .+^ v1 -displaceCenter :: (Real u, Floating u) => Vec2 u -> ShapeCTM u -> Point2 u -displaceCenter v0 (ShapeCTM { ctm_center = ctr0 - , ctm_scale_x = sx - , ctm_scale_y = sy - , ctm_rotation = theta }) = ctr .+^ v - where - ctr = rotate theta $ scale sx sy ctr0 - v = rotateAbout theta ctr $ scale sx sy v0 - - 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -25,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -44,10 +43,13 @@ { circ_ctm :: ShapeCTM u , circ_radius :: !u } - + +type instance DUnit (Circle u) = u + type DCircle = Circle Double -type instance DUnit (Circle u) = u +instance Functor Circle where + fmap f (Circle ctm r) = Circle (fmap f ctm) (f r) -------------------------------------------------------------------------------- @@ -56,32 +58,31 @@ mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u mapCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm -instance Num u => Scale (Circle u) where - scale sx sy = mapCTM (scale sx sy) -instance Rotate (Circle u) where - rotate ang = mapCTM (rotate ang) +instance (Real u, Floating u) => Rotate (Circle u) where + rotate ang = mapCTM (rotate ang) - instance (Real u, Floating u) => RotateAbout (Circle u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Circle u) where + scale sx sy = mapCTM (scale sx sy) instance Num u => Translate (Circle u) where - translate dx dy = mapCTM (translate dx dy) + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors -runDisplaceCenter :: (Real u, Floating u) - => (u -> Vec2 u) -> Circle u -> Point2 u +runDisplaceCenter :: (Real u, Floating u) + => (u -> Vec2 u) -> Circle u -> Anchor u runDisplaceCenter fn (Circle { circ_ctm = ctm , circ_radius = radius }) = - displaceCenter (fn radius) ctm - + projectFromCtr (fn radius) ctm +-- Anchors look like they need ctx... instance (Real u, Floating u) => CenterAnchor (Circle u) where center = runDisplaceCenter $ \_ -> V2 0 0 @@ -112,13 +113,13 @@ -- | 'circle' : @ radius -> Shape @ -- -circle :: (Real u, Floating u, FromPtSize u) - => u -> Shape u (Circle u) +circle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Shape Circle u circle radius = makeShape (mkCircle radius) (mkCirclePath radius) -mkCircle :: Num u => u -> LocThetaCF u (Circle u) +mkCircle :: InterpretUnit u => u -> LocThetaQuery u (Circle u) mkCircle radius = promoteR2 $ \ctr theta -> pure $ Circle { circ_ctm = makeShapeCTM ctr theta , circ_radius = radius @@ -127,10 +128,10 @@ -- Rotation (theta) can be ignored. -- -mkCirclePath :: (Floating u, Ord u, FromPtSize u) - => u -> LocThetaCF u (Path u) +mkCirclePath :: (Floating u, Ord u, InterpretUnit u, Tolerance u) + => u -> LocThetaQuery u (AbsPath u) mkCirclePath radius = promoteR2 $ \ctr _ -> - pure $ traceCurvePoints $ bezierCircle radius 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -26,7 +25,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic @@ -52,10 +51,13 @@ , dia_hh :: !u } +type instance DUnit (Diamond u) = u + type DDiamond = Diamond Double -type instance DUnit (Diamond u) = u +instance Functor Diamond where + fmap f (Diamond ctm hw hh) = Diamond (fmap f ctm) (f hw) (f hh) -------------------------------------------------------------------------------- -- Affine trans @@ -63,21 +65,19 @@ mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u mapCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm -instance Num u => Scale (Diamond u) where - scale sx sy = mapCTM (scale sx sy) -instance Rotate (Diamond u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Diamond u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Diamond u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Diamond u) where + scale sx sy = mapCTM (scale sx sy) instance Num u => Translate (Diamond u) where - translate dx dy = mapCTM (translate dx dy) - + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- @@ -86,12 +86,12 @@ -- | 'runDisplaceCenter' : @ ( half_width -- * half_height -> Vec ) * diamond -> Point @ -- -runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> Vec2 u) -> Diamond u -> Point2 u +runDisplaceCenter :: (Real u, Floating u) + => (u -> u -> Vec2 u) -> Diamond u -> Anchor u runDisplaceCenter fn (Diamond { dia_ctm = ctm , dia_hw = hw , dia_hh = hh }) = - displaceCenter (fn hw hh) ctm + projectFromCtr (fn hw hh) ctm instance (Real u, Floating u) => CenterAnchor (Diamond u) where @@ -100,7 +100,8 @@ instance (Real u, Floating u) => ApexAnchor (Diamond u) where apex = runDisplaceCenter $ \_ hh -> V2 0 hh -instance (Real u, Floating u) => SideMidpointAnchor (Diamond u) where +instance (Real u, Floating u) => + SideMidpointAnchor (Diamond u) where sideMidpoint n a = step (n `mod` 4) where step 1 = midpoint (north a) (west a) @@ -115,7 +116,7 @@ east = runDisplaceCenter $ \hw _ -> V2 hw 0 west = runDisplaceCenter $ \hw _ -> V2 (-hw) 0 -instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where +instance (Real u, Floating u) => CardinalAnchor2 (Diamond u) where northeast x = midpoint (north x) (east x) southeast x = midpoint (south x) (east x) southwest x = midpoint (south x) (west x) @@ -123,9 +124,10 @@ -instance (Real u, Floating u) => RadialAnchor (Diamond u) where - radialAnchor ang = runDisplaceCenter $ \hw hh -> - diamondRadialVector hw hh ang +instance (Real u, Floating u) => + RadialAnchor (Diamond u) where + radialAnchor ang = runDisplaceCenter $ \hw hh -> + diamondRadialVector hw hh ang @@ -137,21 +139,25 @@ -- -- Note - args might change to tull_width and full_height... -- -diamond :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Diamond u) -diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh) +diamond :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Diamond u +diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath 0 hw hh) -mkDiamond :: Num u => u -> u -> LocThetaCF u (Diamond u) +mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u) mkDiamond hw hh = promoteR2 $ \ctr theta -> pure $ Diamond { dia_ctm = makeShapeCTM ctr theta , dia_hw = hw - , dia_hh = hh + , dia_hh = hh } -mkDiamondPath :: (Real u, Floating u, FromPtSize u) - => u -> u -> LocThetaCF u (Path u) -mkDiamondPath hw hh = promoteR2 $ \ctr theta -> - roundCornerShapePath $ map (rotateAbout theta ctr) - $ diamondCoordPath hw hh ctr +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 + + + + 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -28,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -46,53 +45,64 @@ -- Ellipse + data Ellipse u = Ellipse - { ell_ctm :: ShapeCTM u + { ell_ctm :: ShapeCTM u , ell_rx :: !u , ell_ry :: !u } +type instance DUnit (Ellipse u) = u + type DEllipse = Ellipse Double -type instance DUnit (Ellipse u) = u +instance Functor Ellipse where + fmap f (Ellipse ctm rx ry) = Ellipse (fmap f ctm) (f rx) (f ry) + + -------------------------------------------------------------------------------- -- Affine trans -mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u -mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm - -instance Num u => Scale (Ellipse u) where - scale sx sy = mapEllipseCTM (scale sx sy) +mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u +mapCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm -instance Rotate (Ellipse u) where - rotate ang = mapEllipseCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Ellipse u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Ellipse u) where - rotateAbout ang pt = mapEllipseCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Ellipse u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Ellipse u) where - translate dx dy = mapEllipseCTM (translate dx dy) +instance InterpretUnit u => Translate (Ellipse u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors -runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> Vec2 u) -> Ellipse u -> Point2 u +-- Note - this is monadic for Ellipse... + +runDisplaceCenter :: (Real u, Floating u) + => (u -> u -> Vec2 u) -> Ellipse u -> Anchor u runDisplaceCenter fn (Ellipse { ell_ctm = ctm - , ell_rx = rx - , ell_ry = ry }) = - displaceCenter (fn rx ry) ctm + , ell_rx = rx + , ell_ry = ry }) = + projectFromCtr (fn rx ry) ctm +-- NOTE - the Affine instances provided by Wumpus-Core for Point +-- and Vector may be contradictory for Wumpus-Basic. + + -- | x_radius is the unit length. -- -scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t -scaleEll rx ry = scale 1 (ry/rx) +scaleEll :: (Real u, Fractional u) + => u -> u -> Vec2 u -> Vec2 u +scaleEll rx ry v = let rat = realToFrac (ry/rx) in scale 1 rat v instance (Real u, Floating u) => CenterAnchor (Ellipse u) where @@ -123,12 +133,12 @@ -- | 'ellipse' : @ x_radii * y_radii -> shape @ -- -ellipse :: (Real u, Floating u, FromPtSize u, Ord u) - => u -> u -> Shape u (Ellipse u) +ellipse :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Ellipse u ellipse rx ry = makeShape (mkEllipse rx ry) (mkEllipsePath rx ry) -mkEllipse :: Num u => u -> u -> LocThetaCF u (Ellipse u) +mkEllipse :: InterpretUnit u => u -> u -> LocThetaQuery u (Ellipse u) mkEllipse rx ry = promoteR2 $ \ctr theta -> pure $ Ellipse { ell_ctm = makeShapeCTM ctr theta , ell_rx = rx @@ -136,9 +146,10 @@ } -mkEllipsePath :: (Real u, Floating u, FromPtSize u, Ord u) - => u -> u -> LocThetaCF u (Path u) +mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> LocThetaQuery u (AbsPath u) mkEllipsePath rx ry = promoteR2 $ \pt theta -> - pure $ traceCurvePoints $ map (rotateAbout theta pt) - $ bezierEllipse rx ry pt + let xs = map (rotateAbout theta pt) $ bezierEllipse rx ry pt + in return $ curvePath xs + diff --git a/src/Wumpus/Drawing/Shapes/InvSemicircle.hs b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs --- a/src/Wumpus/Drawing/Shapes/InvSemicircle.hs +++ b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -40,62 +39,68 @@ newtype InvSemicircle u = InvSemicircle { getInvSemicircle :: Semicircle u } +type instance DUnit (InvSemicircle u) = u type DInvSemicircle = InvSemicircle Double -type instance DUnit (InvSemicircle u) = u +instance Functor InvSemicircle where + fmap f = InvSemicircle . fmap f . getInvSemicircle -------------------------------------------------------------------------------- -- Affine trans -mapSemicircle :: (Semicircle u -> Semicircle u) - -> InvSemicircle u - -> InvSemicircle u -mapSemicircle f = InvSemicircle . f . getInvSemicircle - -instance Num u => Scale (InvSemicircle u) where - scale sx sy = mapSemicircle (scale sx sy) +mapInner :: (Semicircle u -> Semicircle u) + -> InvSemicircle u + -> InvSemicircle u +mapInner f = InvSemicircle . f . getInvSemicircle -instance Rotate (InvSemicircle u) where - rotate ang = mapSemicircle (rotate ang) - - +instance (Real u, Floating u) => Rotate (InvSemicircle u) where + rotate ang = mapInner (rotate ang) + instance (Real u, Floating u) => RotateAbout (InvSemicircle u) where - rotateAbout ang pt = mapSemicircle (rotateAbout ang pt) + rotateAbout ang pt = mapInner (rotateAbout ang pt) +instance Fractional u => Scale (InvSemicircle u) where + scale sx sy = mapInner (scale sx sy) -instance Num u => Translate (InvSemicircle u) where - translate dx dy = mapSemicircle (translate dx dy) +instance InterpretUnit u => Translate (InvSemicircle u) where + translate dx dy = mapInner (translate dx dy) + -------------------------------------------------------------------------------- -- Anchors runRotateAnchor :: (Real u, Floating u) - => (Semicircle u -> Point2 u) -> InvSemicircle u -> Point2 u -runRotateAnchor f (InvSemicircle a) = rotateAbout pi (center a) (f a) + => (Semicircle u -> Anchor u) -> InvSemicircle u -> Anchor u +runRotateAnchor f (InvSemicircle a) = + let ctr = center a in rotateAbout pi ctr (f a) -instance (Real u, Floating u) => CenterAnchor (InvSemicircle u) where +instance (Real u, Floating u) => + CenterAnchor (InvSemicircle u) where center = center . getInvSemicircle -instance (Real u, Floating u) => ApexAnchor (InvSemicircle u) where +instance (Real u, Floating u) => + ApexAnchor (InvSemicircle u) where apex = runRotateAnchor apex -instance (Real u, Floating u) => TopCornerAnchor (InvSemicircle u) where +instance (Real u, Floating u) => + TopCornerAnchor (InvSemicircle u) where topLeftCorner = runRotateAnchor bottomRightCorner topRightCorner = runRotateAnchor bottomLeftCorner -instance (Real u, Floating u) => CardinalAnchor (InvSemicircle u) where +instance (Real u, Floating u) => + CardinalAnchor (InvSemicircle u) where north = runRotateAnchor south south = runRotateAnchor north east = runRotateAnchor west west = runRotateAnchor east -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (InvSemicircle u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest @@ -104,7 +109,7 @@ -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => RadialAnchor (InvSemicircle u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) @@ -115,7 +120,7 @@ -- | 'invsemicircle' : @ radius -> Shape @ -- -invsemicircle :: (Real u, Floating u, FromPtSize u) - => u -> Shape u (InvSemicircle u) +invsemicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Shape InvSemicircle u invsemicircle radius = - fmap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius + shapeMap InvSemicircle $ updatePathAngle (+ pi) $ semicircle radius diff --git a/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs --- a/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs +++ b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -40,56 +39,61 @@ newtype InvSemiellipse u = InvSemiellipse { getInvSemiellipse :: Semiellipse u } +type instance DUnit (InvSemiellipse u) = u type DInvSemiellipse = InvSemiellipse Double -type instance DUnit (InvSemiellipse u) = u +instance Functor InvSemiellipse where + fmap f = InvSemiellipse . fmap f . getInvSemiellipse + -------------------------------------------------------------------------------- -- Affine trans -mapSemiellipse :: (Semiellipse u -> Semiellipse u) - -> InvSemiellipse u - -> InvSemiellipse u -mapSemiellipse f = InvSemiellipse . f . getInvSemiellipse - -instance Num u => Scale (InvSemiellipse u) where - scale sx sy = mapSemiellipse (scale sx sy) - - -instance Rotate (InvSemiellipse u) where - rotate ang = mapSemiellipse (rotate ang) - +mapInner :: (Semiellipse u -> Semiellipse u) + -> InvSemiellipse u + -> InvSemiellipse u +mapInner f = InvSemiellipse . f . getInvSemiellipse +instance (Real u, Floating u) => Rotate (InvSemiellipse u) where + rotate ang = mapInner (rotate ang) + instance (Real u, Floating u) => RotateAbout (InvSemiellipse u) where - rotateAbout ang pt = mapSemiellipse (rotateAbout ang pt) + rotateAbout ang pt = mapInner (rotateAbout ang pt) +instance Fractional u => Scale (InvSemiellipse u) where + scale sx sy = mapInner (scale sx sy) -instance Num u => Translate (InvSemiellipse u) where - translate dx dy = mapSemiellipse (translate dx dy) +instance InterpretUnit u => Translate (InvSemiellipse u) where + translate dx dy = mapInner (translate dx dy) + -------------------------------------------------------------------------------- -- Anchors runRotateAnchor :: (Real u, Floating u) - => (Semiellipse u -> Point2 u) -> InvSemiellipse u -> Point2 u -runRotateAnchor f (InvSemiellipse a) = rotateAbout pi (center a) (f a) + => (Semiellipse u -> Anchor u) -> InvSemiellipse u -> Anchor u +runRotateAnchor f (InvSemiellipse a) = + let ctr = center a in rotateAbout pi ctr (f a) -instance (Real u, Floating u) => CenterAnchor (InvSemiellipse u) where + +instance (Real u, Floating u, Tolerance u) => + CenterAnchor (InvSemiellipse u) where center = center . getInvSemiellipse -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => ApexAnchor (InvSemiellipse u) where apex = runRotateAnchor apex -instance (Real u, Floating u) => TopCornerAnchor (InvSemiellipse u) where +instance (Real u, Floating u, Tolerance u) => + TopCornerAnchor (InvSemiellipse u) where topLeftCorner = runRotateAnchor bottomRightCorner topRightCorner = runRotateAnchor bottomLeftCorner -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor (InvSemiellipse u) where north = runRotateAnchor south south = runRotateAnchor north @@ -97,7 +101,7 @@ west = runRotateAnchor east -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (InvSemiellipse u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest @@ -106,7 +110,7 @@ -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => RadialAnchor (InvSemiellipse u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) @@ -117,7 +121,7 @@ -- | 'invsemiellipse' : @ rx * ry -> Shape @ -- -invsemiellipse :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (InvSemiellipse u) +invsemiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape InvSemiellipse u invsemiellipse rx ry = - fmap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry + shapeMap InvSemiellipse $ updatePathAngle (+ pi) $ semiellipse rx ry diff --git a/src/Wumpus/Drawing/Shapes/InvTriangle.hs b/src/Wumpus/Drawing/Shapes/InvTriangle.hs --- a/src/Wumpus/Drawing/Shapes/InvTriangle.hs +++ b/src/Wumpus/Drawing/Shapes/InvTriangle.hs @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -36,65 +35,65 @@ - - - -- Datatype newtype InvTriangle u = InvTriangle { getInvTriangle :: Triangle u } +type instance DUnit (InvTriangle u) = u type DInvTriangle = InvTriangle Double -type instance DUnit (InvTriangle u) = u +instance Functor InvTriangle where + fmap f = InvTriangle . fmap f . getInvTriangle + -------------------------------------------------------------------------------- -- Affine trans -mapTriangle :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u -mapTriangle f = InvTriangle . f . getInvTriangle - - -instance Num u => Scale (InvTriangle u) where - scale sx sy = mapTriangle (scale sx sy) - - -instance Rotate (InvTriangle u) where - rotate ang = mapTriangle (rotate ang) - +mapInner :: (Triangle u -> Triangle u) -> InvTriangle u -> InvTriangle u +mapInner f = InvTriangle . f . getInvTriangle +instance (Real u, Floating u) => Rotate (InvTriangle u) where + rotate ang = mapInner (rotate ang) + instance (Real u, Floating u) => RotateAbout (InvTriangle u) where - rotateAbout ang pt = mapTriangle (rotateAbout ang pt) + rotateAbout ang pt = mapInner (rotateAbout ang pt) +instance Fractional u => Scale (InvTriangle u) where + scale sx sy = mapInner (scale sx sy) -instance Num u => Translate (InvTriangle u) where - translate dx dy = mapTriangle (translate dx dy) +instance InterpretUnit u => Translate (InvTriangle u) where + translate dx dy = mapInner (translate dx dy) -------------------------------------------------------------------------------- -- Anchors --- I think anchors should be rotated about the center by pi... +-- Anchors should be rotated about the center by pi... runRotateAnchor :: (Real u, Floating u) - => (Triangle u -> Point2 u) -> InvTriangle u -> Point2 u -runRotateAnchor f (InvTriangle a) = rotateAbout pi (center a) (f a) + => (Triangle u -> Anchor u) -> InvTriangle u -> Anchor u +runRotateAnchor f (InvTriangle a) = + let ctr = center a in rotateAbout pi ctr (f a) -instance (Real u, Floating u) => CenterAnchor (InvTriangle u) where +instance (Real u, Floating u) => + CenterAnchor (InvTriangle u) where center = center . getInvTriangle -- apex is same on InvTriangle as regular triangle -instance (Real u, Floating u) => ApexAnchor (InvTriangle u) where +instance (Real u, Floating u) => + ApexAnchor (InvTriangle u) where apex = runRotateAnchor apex -- Top corners are bottom corners of the wrapped triangle. -- -instance (Real u, Floating u) => TopCornerAnchor (InvTriangle u) where +instance (Real u, Floating u) => + TopCornerAnchor (InvTriangle u) where topLeftCorner = runRotateAnchor bottomRightCorner topRightCorner = runRotateAnchor bottomLeftCorner @@ -102,26 +101,29 @@ -- Use established points on the InvTrangle - don\'t delegate to -- the base Triangle. -- -instance (Real u, Floating u) => SideMidpointAnchor (InvTriangle u) where +instance (Real u, Floating u) => + SideMidpointAnchor (InvTriangle u) where sideMidpoint n a = step (n `mod` 3) where - step 1 = midpoint (topRightCorner a) (topLeftCorner a) - step 2 = midpoint (topLeftCorner a) (apex a) - step _ = midpoint (apex a) (topRightCorner a) + step 1 = midpoint (topRightCorner a) (topLeftCorner a) + step 2 = midpoint (topLeftCorner a) (apex a) + step _ = midpoint (apex a) (topRightCorner a) -- east and west should be parallel to the centroid. -- -instance (Real u, Floating u) => CardinalAnchor (InvTriangle u) where +instance (Real u, Floating u) => + CardinalAnchor (InvTriangle u) where north = runRotateAnchor south south = runRotateAnchor north east = runRotateAnchor west west = runRotateAnchor east -instance (Real u, Floating u) => CardinalAnchor2 (InvTriangle u) where +instance (Real u, Floating u) => + CardinalAnchor2 (InvTriangle u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest southwest = runRotateAnchor northeast @@ -129,7 +131,8 @@ -instance (Real u, Floating u) => RadialAnchor (InvTriangle u) where +instance (Real u, Floating u) => + RadialAnchor (InvTriangle u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) -------------------------------------------------------------------------------- @@ -138,9 +141,10 @@ -- | 'invtriangle' : @ top_base_width * height -> Triangle @ -- -- -invtriangle :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (InvTriangle u) -invtriangle bw h = fmap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h +invtriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape InvTriangle u +invtriangle bw h = + shapeMap InvTriangle $ updatePathAngle (+ pi) $ triangle bw h 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -28,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic @@ -57,6 +56,7 @@ , pll_syn_props :: SyntheticProps u } +type instance DUnit (Parallelogram u) = u -- | Note (center) is a line dropped from the center of the -- paralleogram. @@ -69,34 +69,39 @@ , pll_base_major :: u } +type instance DUnit (SyntheticProps u) = u + type DParallelogram = Parallelogram Double -type instance DUnit (Parallelogram u) = u +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) + -------------------------------------------------------------------------------- -- Affine trans mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm -instance Num u => Scale (Parallelogram u) where - scale sx sy = mapCTM (scale sx sy) - -instance Rotate (Parallelogram u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Parallelogram u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Parallelogram u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Parallelogram u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Parallelogram u) where - translate dx dy = mapCTM (translate dx dy) +instance InterpretUnit u => Translate (Parallelogram u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors @@ -107,30 +112,34 @@ -- * base_major -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Point2 u + => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Anchor u runDisplaceCenter fn (Parallelogram { pll_ctm = ctm , pll_base_width = bw , pll_height = h , pll_syn_props = syn }) = - displaceCenter (fn (0.5 * bw) (0.5 * h) + projectFromCtr (fn (0.5 * bw) (0.5 * h) (pll_base_minor syn) (pll_base_major syn)) ctm -instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where +instance (Real u, Floating u) => + CenterAnchor (Parallelogram u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 -- top anchors swap the base minor and major... -- -instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where +instance (Real u, Floating u) => + TopCornerAnchor (Parallelogram u) where topLeftCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin hh -instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Parallelogram u) where bottomLeftCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh) bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj (-hh) -instance (Real u, Floating u) => SideMidpointAnchor (Parallelogram u) where +instance (Real u, Floating u) => + SideMidpointAnchor (Parallelogram u) where sideMidpoint n a = step (n `mod` 4) where step 1 = midpoint (topRightCorner a) (topLeftCorner a) @@ -140,14 +149,15 @@ -instance (Real u, Floating u) => CardinalAnchor (Parallelogram u) where +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 -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Parallelogram u) where northeast = pllRadialAnchor (0.25*pi) southeast = pllRadialAnchor (1.75*pi) @@ -156,15 +166,15 @@ -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Parallelogram u) where radialAnchor = pllRadialAnchor -- TODO - update this to a quadrant function... -- -pllRadialAnchor :: (Real u, Floating u, FromPtSize u) - => Radian -> Parallelogram u -> Point2 u +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 }) = @@ -172,8 +182,8 @@ where ps = pllPoints (pll_base_minor syn) (pll_base_major syn) h post = \ans -> case ans of - Nothing -> displaceCenter (V2 0 0) ctm - Just (P2 x y) -> displaceCenter (V2 x y) ctm + Nothing -> projectFromCtr (V2 0 0) ctm + Just (P2 x y) -> projectFromCtr (V2 x y) ctm -------------------------------------------------------------------------------- @@ -183,20 +193,20 @@ -- | 'parallelogram' : @ width * height * bottom_left_ang -> Parallelogram @ -- -- -parallelogram :: (Real u, Floating u, FromPtSize u) - => u -> u -> Radian -> Shape u (Parallelogram u) +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 (pll_base_minor props) - (pll_base_major props) h) + (mkParallelogramPath 0 (pll_base_minor props) + (pll_base_major props) h) -- | 'zparallelogram' : @ base_width * height -> Parallelogram @ -- -- -zparallelogram :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Parallelogram u) +zparallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Parallelogram u zparallelogram bw h = parallelogram bw h ang where ang = d2r (60::Double) @@ -205,9 +215,9 @@ -------------------------------------------------------------------------------- -mkParallelogram :: (Real u, Fractional u) +mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) => u -> u -> Radian -> SyntheticProps u - -> LocThetaCF u (Parallelogram u) + -> LocThetaQuery u (Parallelogram u) mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> pure $ Parallelogram { pll_ctm = makeShapeCTM ctr theta , pll_base_width = bw @@ -236,11 +246,12 @@ -mkParallelogramPath :: (Real u, Floating u, FromPtSize u) - => u -> u -> u -> LocThetaCF u (Path u) -mkParallelogramPath bw_minor bw_major h = promoteR2 $ \ctr theta -> - roundCornerShapePath $ map (rotateAbout theta ctr) - $ pllPath bw_minor bw_major h ctr +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 + in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs + pllPath :: (Real u, Floating u) 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -28,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Paths -- package: wumpus-basic @@ -51,11 +50,13 @@ } deriving (Eq,Ord,Show) +type instance DUnit (Rectangle u) = u + type DRectangle = Rectangle Double -type instance DUnit (Rectangle u) = u - +instance Functor Rectangle where + fmap f (Rectangle ctm hw hh) = Rectangle (fmap f ctm) (f hw) (f hh) -------------------------------------------------------------------------------- -- Affine trans @@ -63,20 +64,19 @@ mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u mapCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm -instance Num u => Scale (Rectangle u) where - scale sx sy = mapCTM (scale sx sy) -instance Rotate (Rectangle u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Rectangle u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Rectangle u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Rectangle u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Rectangle u) where - translate dx dy = mapCTM (translate dx dy) +instance InterpretUnit u => Translate (Rectangle u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors @@ -87,25 +87,29 @@ -- * half_height -> Vec ) * rectangle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> Vec2 u) -> Rectangle u -> Point2 u + => (u -> u -> Vec2 u) -> Rectangle u -> Anchor u runDisplaceCenter fn (Rectangle { rect_ctm = ctm , rect_hw = hw , rect_hh = hh }) = - displaceCenter (fn hw hh) ctm + projectFromCtr (fn hw hh) ctm -instance (Real u, Floating u) => CenterAnchor (Rectangle u) where +instance (Real u, Floating u) => + CenterAnchor (Rectangle u) where center = runDisplaceCenter $ \_ _ -> V2 0 0 -instance (Real u, Floating u) => TopCornerAnchor (Rectangle u) where +instance (Real u, Floating u) => + TopCornerAnchor (Rectangle u) where topLeftCorner = runDisplaceCenter $ \hw hh -> V2 (-hw) hh topRightCorner = runDisplaceCenter $ \hw hh -> V2 hw hh -instance (Real u, Floating u) => BottomCornerAnchor (Rectangle u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Rectangle u) where bottomLeftCorner = runDisplaceCenter $ \hw hh -> V2 (-hw) (-hh) bottomRightCorner = runDisplaceCenter $ \hw hh -> V2 hw (-hh) -instance (Real u, Floating u) => SideMidpointAnchor (Rectangle u) where +instance (Real u, Floating u) => + SideMidpointAnchor (Rectangle u) where sideMidpoint n a = step (n `mod` 4) where step 1 = north a @@ -114,20 +118,23 @@ step _ = east a -instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where +instance (Real u, Floating u) => + CardinalAnchor (Rectangle 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 -instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where +instance (Real u, Floating u) => + CardinalAnchor2 (Rectangle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) southwest = radialAnchor (1.25*pi) northwest = radialAnchor (0.75*pi) -instance (Real u, Floating u) => RadialAnchor (Rectangle u) where +instance (Real u, Floating u) => + RadialAnchor (Rectangle u) where radialAnchor theta = runDisplaceCenter $ \hw hh -> rectRadialVector hw hh theta @@ -139,14 +146,13 @@ -- | 'rectangle' : @ width * height -> shape @ -- -rectangle :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Rectangle u) +rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Rectangle u rectangle w h = - makeShape (mkRectangle (0.5*w) (0.5*h)) - (mkRectPath (0.5*w) (0.5*h)) + makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath 0 (0.5*w) (0.5*h)) -mkRectangle :: Num u => u -> u -> LocThetaCF u (Rectangle u) +mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u) mkRectangle hw hh = promoteR2 $ \ctr theta -> pure $ Rectangle { rect_ctm = makeShapeCTM ctr theta , rect_hw = hw @@ -154,12 +160,12 @@ } -mkRectPath :: (Real u, Floating u, FromPtSize u) - => u -> u -> LocThetaCF u (Path u) -mkRectPath hw hh = promoteR2 $ \ctr theta -> +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 - in roundCornerShapePath $ map (rotateAbout theta ctr) - $ rectangleCoordPath (2*hw) (2*hh) btm_left + xs = rectangleCoordPath (2*hw) (2*hh) btm_left + 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -25,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic @@ -50,39 +49,45 @@ , 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 } + +type instance DUnit (SyntheticProps u) = u + type DSemicircle = Semicircle Double -type instance DUnit (Semicircle u) = u +instance Functor Semicircle where + fmap f (Semicircle ctm r props) = Semicircle (fmap f ctm) (f r) (fmap f props) +instance Functor SyntheticProps where + fmap f (SyntheticProps cmin cmaj) = SyntheticProps (f cmin) (f cmaj) + + -------------------------------------------------------------------------------- -- Affine trans mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semicircle u -> Semicircle u mapCTM f = (\s i -> s { sc_ctm = f i }) <*> sc_ctm -instance Num u => Scale (Semicircle u) where - scale sx sy = mapCTM (scale sx sy) - -instance Rotate (Semicircle u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Semicircle u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Semicircle u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Semicircle u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Semicircle u) where - translate dx dy = mapCTM (translate dx dy) +instance InterpretUnit u => Translate (Semicircle u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- @@ -93,24 +98,28 @@ -- * height_major -> Vec ) * semicircle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> Vec2 u) -> Semicircle u -> Point2 u + => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u runDisplaceCenter fn (Semicircle { sc_ctm = ctm , sc_radius = radius , sc_syn_props = syn }) = - displaceCenter (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) ctm + projectFromCtr (fn radius (sc_ctr_minor syn) (sc_ctr_major syn)) ctm -instance (Real u, Floating u) => CenterAnchor (Semicircle u) where +instance (Real u, Floating u) => + CenterAnchor (Semicircle u) where center = runDisplaceCenter $ \_ _ _ -> V2 0 0 -instance (Real u, Floating u) => ApexAnchor (Semicircle u) where +instance (Real u, Floating u) => + ApexAnchor (Semicircle u) where apex = runDisplaceCenter $ \_ _ cmaj -> V2 0 cmaj -instance (Real u, Floating u) => BottomCornerAnchor (Semicircle u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Semicircle u) where bottomLeftCorner = runDisplaceCenter $ \r hminor _ -> V2 (-r) (-hminor) bottomRightCorner = runDisplaceCenter $ \r hminor _ -> V2 r (-hminor) -instance (Real u, Floating u) => CardinalAnchor (Semicircle u) where +instance (Real u, Floating u) => + CardinalAnchor (Semicircle u) where north = apex south = runDisplaceCenter $ \_ cmin _ -> V2 0 (-cmin) east = runDisplaceCenter $ \r cmin _ -> let x = pyth r cmin in V2 x 0 @@ -126,7 +135,7 @@ pow2 = (^ (2::Int)) -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (Semicircle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -136,11 +145,13 @@ -instance (Real u, Floating u, FromPtSize u) => RadialAnchor (Semicircle u) where +instance (Real u, Floating u, Tolerance u) => + RadialAnchor (Semicircle u) where radialAnchor theta = runDisplaceCenter (scRadialVec theta) +-- helpers -scRadialVec :: (Real u, Floating u, Ord u, FromPtSize u) +scRadialVec :: (Real u, Floating u, Ord u, Tolerance u) => Radian -> u -> u -> u -> Vec2 u scRadialVec theta radius hminor _ = go theta where @@ -197,8 +208,8 @@ -- | 'semicircle' : @ radius -> Shape @ -- -semicircle :: (Real u, Floating u, FromPtSize u) - => u -> Shape u (Semicircle u) +semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Shape Semicircle u semicircle radius = let props = synthesizeProps radius in makeShape (mkSemicircle radius props) @@ -215,7 +226,8 @@ cmajor = radius - cminor -mkSemicircle :: Num u => u -> SyntheticProps u -> LocThetaCF u (Semicircle u) +mkSemicircle :: InterpretUnit u + => u -> SyntheticProps u -> LocThetaQuery u (Semicircle u) mkSemicircle radius props = promoteR2 $ \ctr theta -> pure $ Semicircle { sc_ctm = makeShapeCTM ctr theta , sc_radius = radius @@ -227,9 +239,9 @@ -- TODO - need to check other shapes to see if the are deriving -- the center properly... -- -mkSemicirclePath :: (Real u, Floating u, FromPtSize u) - => u -> u -> LocThetaCF u (Path u) +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 - in pure $ traceCurvePoints $ bezierArcPoints pi radius theta ctr + 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -25,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic @@ -50,18 +49,24 @@ , 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 } + +type instance DUnit (SyntheticProps u) = u type DSemiellipse = Semiellipse Double -type instance DUnit (Semiellipse u) = u +instance Functor Semiellipse where + fmap f (Semiellipse ctm rx ry props) = + Semiellipse (fmap f ctm) (f rx) (f ry) (fmap f props) +instance Functor SyntheticProps where + fmap f (SyntheticProps rymin rymaj) = SyntheticProps (f rymin) (f rymaj) -------------------------------------------------------------------------------- -- Affine trans @@ -69,20 +74,18 @@ mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Semiellipse u -> Semiellipse u mapCTM f = (\s i -> s { se_ctm = f i }) <*> se_ctm -instance Num u => Scale (Semiellipse u) where - scale sx sy = mapCTM (scale sx sy) - -instance Rotate (Semiellipse u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Semiellipse u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Semiellipse u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Semiellipse u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Semiellipse u) where - translate dx dy = mapCTM (translate dx dy) +instance InterpretUnit u => Translate (Semiellipse u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- @@ -95,36 +98,38 @@ -- * ry_major -> Vec ) * semiellipse -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Point2 u + => (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 }) = - displaceCenter (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm + projectFromCtr (fn rx ry (se_ry_minor syn) (se_ry_major syn)) ctm -instance (Real u, Floating u) => CenterAnchor (Semiellipse u) where +instance (Real u, Floating u) => + CenterAnchor (Semiellipse u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => ApexAnchor (Semiellipse u) where apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major -instance (Real u, Floating u) => BottomCornerAnchor (Semiellipse u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Semiellipse u) where bottomLeftCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 (-rx) (-ry_minor) bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 rx (-ry_minor) -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor (Semiellipse u) where north = apex south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor) east = radialAnchor 0 west = radialAnchor pi -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (Semiellipse u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -133,11 +138,12 @@ -instance (Real u, Floating u, FromPtSize u) => RadialAnchor (Semiellipse u) where +instance (Real u, Floating u, Tolerance u) => + RadialAnchor (Semiellipse u) where radialAnchor theta = runDisplaceCenter (seRadialVec theta) -seRadialVec :: (Real u, Floating u, Ord u, FromPtSize u) +seRadialVec :: (Real u, Floating u, Ord u, Tolerance u) => Radian -> u -> u -> u -> u -> Vec2 u seRadialVec theta rx ry hminor _ = go theta where @@ -190,8 +196,8 @@ -- | 'semiellipse' : @ x_radius * y_radius -> Shape @ -- -semiellipse :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Semiellipse u) +semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Semiellipse u semiellipse rx ry = let props = synthesizeProps ry in makeShape (mkSemiellipse rx ry props) @@ -209,8 +215,7 @@ ry_major = ry - ry_minor -mkSemiellipse :: Num u - => u -> u -> SyntheticProps u -> LocThetaCF u (Semiellipse u) +mkSemiellipse :: u -> u -> SyntheticProps u -> LocThetaQuery u (Semiellipse u) mkSemiellipse rx ry props = promoteR2 $ \ctr theta -> pure $ Semiellipse { se_ctm = makeShapeCTM ctr theta , se_rx = rx @@ -219,12 +224,12 @@ } -mkSemiellipsePath :: (Real u, Floating u, FromPtSize u) - => u -> u -> u -> LocThetaCF u (Path u) +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 - in pure $ traceCurvePoints $ map (rotateAbout theta ctr) - $ bezierSemiellipsePoints rx ry ctr + xs = bezierSemiellipsePoints rx ry ctr + in return $ curvePath $ map (rotateAbout theta ctr) xs bezierSemiellipsePoints :: Floating u 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -30,11 +29,10 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Intersection -- package: wumpus-basic -import Wumpus.Basic.Geometry.Paths +import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -60,11 +58,13 @@ , tz_base_r_ang :: Radian } +type instance DUnit (Trapezium u) = u type DTrapezium = Trapezium Double -type instance DUnit (Trapezium u) = u - +instance Functor Trapezium where + fmap f (Trapezium ctm bw h lang rang) = + Trapezium (fmap f ctm) (f bw) (f h) lang rang -------------------------------------------------------------------------------- -- Affine trans @@ -72,20 +72,18 @@ mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Trapezium u -> Trapezium u mapCTM f = (\s i -> s { tz_ctm = f i }) <*> tz_ctm -instance Num u => Scale (Trapezium u) where - scale sx sy = mapCTM (scale sx sy) - -instance Rotate (Trapezium u) where - rotate ang = mapCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Trapezium u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Trapezium u) where - rotateAbout ang pt = mapCTM (rotateAbout ang pt) + rotateAbout ang pt = mapCTM (rotateAbout ang pt) +instance Fractional u => Scale (Trapezium u) where + scale sx sy = mapCTM (scale sx sy) -instance Num u => Translate (Trapezium u) where - translate dx dy = mapCTM (translate dx dy) +instance InterpretUnit u => Translate (Trapezium u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- @@ -98,25 +96,28 @@ -- runDisplaceCenter :: (Real u, Floating u) => (u -> u -> Radian -> Radian -> Vec2 u) - -> Trapezium u -> Point2 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 }) = - displaceCenter (fn (0.5 * bw) (0.5 * h) lang rang) ctm + projectFromCtr (fn (0.5 * bw) (0.5 * h) lang rang) ctm -instance (Real u, Floating u) => CenterAnchor (Trapezium u) where +instance (Real u, Floating u) => + CenterAnchor (Trapezium u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 -instance (Real u, Floating u) => BottomCornerAnchor (Trapezium u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Trapezium u) where bottomLeftCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 (-hbw) (-hh) bottomRightCorner = runDisplaceCenter $ \hbw hh _ _ -> V2 hbw (-hh) -instance (Real u, Floating u) => TopCornerAnchor (Trapezium u) where +instance (Real u, Floating u) => + TopCornerAnchor (Trapezium u) where topLeftCorner = runDisplaceCenter $ \hbw hh lang _ -> let vbase = V2 (-hbw) (-hh) vup = leftSideVec (2*hh) lang @@ -127,7 +128,7 @@ in vbase ^+^ vup -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => SideMidpointAnchor (Trapezium u) where sideMidpoint n a = step (n `mod` 4) where @@ -138,7 +139,7 @@ -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor (Trapezium u) where north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh) @@ -146,7 +147,7 @@ west = tzRadialAnchor pi -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (Trapezium u) where northeast = tzRadialAnchor (0.25*pi) southeast = tzRadialAnchor (1.75*pi) @@ -155,14 +156,14 @@ -instance (Real u, Floating u, FromPtSize u) => +instance (Real u, Floating u, Tolerance u) => RadialAnchor (Trapezium u) where radialAnchor = tzRadialAnchor -- TODO - update this to a quadrant function... -- -tzRadialAnchor :: (Real u, Floating u, FromPtSize u) - => Radian -> Trapezium u -> Point2 u +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 @@ -172,8 +173,8 @@ where ps = tzPoints bw h lang rang post = \ans -> case ans of - Nothing -> displaceCenter (V2 0 0) ctm - Just (P2 x y) -> displaceCenter (V2 x y) ctm + Nothing -> projectFromCtr (V2 0 0) ctm + Just (P2 x y) -> projectFromCtr (V2 x y) ctm -------------------------------------------------------------------------------- @@ -184,17 +185,17 @@ -- bottom_right_ang -> Shape @ -- -- -trapezium :: (Real u, Floating u, FromPtSize u) - => u -> u -> Radian -> Radian -> Shape u (Trapezium u) +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 bw h lang rang) + makeShape (mkTrapezium bw h lang rang) (mkTrapeziumPath 0 bw h lang rang) -- | 'ztrapezium' : @ base_width * height -> Trapezium @ -- -- -ztrapezium :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Trapezium u) +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) @@ -203,8 +204,8 @@ -------------------------------------------------------------------------------- -mkTrapezium :: (Real u, Fractional u) - => u -> u -> Radian -> Radian -> LocThetaCF u (Trapezium u) +mkTrapezium :: (Real u, Fractional u, InterpretUnit u) + => u -> u -> Radian -> Radian -> LocThetaQuery u (Trapezium u) mkTrapezium bw h lang rang = promoteR2 $ \ctr theta -> pure $ Trapezium { tz_ctm = makeShapeCTM ctr theta , tz_base_width = bw @@ -214,11 +215,12 @@ } -mkTrapeziumPath :: (Real u, Floating u, FromPtSize u) - => u -> u -> Radian -> Radian -> LocThetaCF u (Path u) -mkTrapeziumPath bw h lang rang = promoteR2 $ \ctr theta -> - roundCornerShapePath $ map (rotateAbout theta ctr) - $ tzPath bw h lang rang ctr +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 + in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs tzPath :: (Real u, Floating u) 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 @@ -1,5 +1,4 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -25,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic @@ -47,10 +46,12 @@ -- data Triangle u = Triangle { tri_ctm :: ShapeCTM u - , tri_height :: !u , tri_base_width :: !u + , tri_height :: !u , tri_syn_props :: SyntheticProps u } + +type instance DUnit (Triangle u) = u data SyntheticProps u = SyntheticProps { tri_hmajor :: u @@ -59,34 +60,37 @@ , tri_apex_ang :: Radian } +type instance DUnit (SyntheticProps u) = u + type DTriangle = Triangle Double -type instance DUnit (Triangle u) = u +instance Functor Triangle where + fmap f (Triangle ctm bw h props) = + Triangle (fmap f ctm) (f bw) (f h) (fmap f props) +instance Functor SyntheticProps where + fmap f (SyntheticProps hmin hmaj ang1 ang2) = + SyntheticProps (f hmin) (f hmaj) ang1 ang2 -------------------------------------------------------------------------------- -- Affine trans -mapTriangleCTM :: (ShapeCTM u -> ShapeCTM u) - -> Triangle u -> Triangle u -mapTriangleCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm - -instance Num u => Scale (Triangle u) where - scale sx sy = mapTriangleCTM (scale sx sy) +mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Triangle u -> Triangle u +mapCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm -instance Rotate (Triangle u) where - rotate ang = mapTriangleCTM (rotate ang) - - +instance (Real u, Floating u) => Rotate (Triangle u) where + rotate ang = mapCTM (rotate ang) + instance (Real u, Floating u) => RotateAbout (Triangle u) where - rotateAbout ang pt = mapTriangleCTM (rotateAbout ang pt) - + rotateAbout ang pt = mapCTM (rotateAbout ang pt) -instance Num u => Translate (Triangle u) where - translate dx dy = mapTriangleCTM (translate dx dy) +instance Fractional u => Scale (Triangle u) where + scale sx sy = mapCTM (scale sx sy) +instance InterpretUnit u => Translate (Triangle u) where + translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors @@ -97,11 +101,11 @@ -- * base_ang -> Vec ) * traingle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Point2 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 }) = - displaceCenter (fn (0.5*bw) hminor hmajor base_ang) ctm + projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm where hminor = tri_hminor syn hmajor = tri_hmajor syn @@ -109,15 +113,18 @@ -instance (Real u, Floating u) => CenterAnchor (Triangle u) where +instance (Real u, Floating u) => + CenterAnchor (Triangle u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 -instance (Real u, Floating u) => ApexAnchor (Triangle u) where +instance (Real u, Floating u) => + ApexAnchor (Triangle u) where apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj -instance (Real u, Floating u) => BottomCornerAnchor (Triangle u) where +instance (Real u, Floating u) => + BottomCornerAnchor (Triangle u) where bottomLeftCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 (-hbw) (-hmin) bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 hbw (-hmin) @@ -125,18 +132,20 @@ -- east and west should be parallel to the centroid. -- -instance (Real u, Floating u) => CardinalAnchor (Triangle u) where +instance (Real u, Floating u) => + CardinalAnchor (Triangle u) where north = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj south = runDisplaceCenter $ \_ hmin _ _ -> V2 0 (-hmin) east = runDisplaceCenter $ \hbw hmin _ ang -> findEast hbw hmin ang west = runDisplaceCenter $ \hbw hmin _ ang -> findWest hbw hmin ang -instance (Real u, Floating u) => SideMidpointAnchor (Triangle u) where +instance (Real u, Floating u) => + SideMidpointAnchor (Triangle u) where sideMidpoint n a = step (n `mod` 3) where - step 1 = midpoint (apex a) (bottomLeftCorner a) - step 2 = midpoint (bottomLeftCorner a) (bottomRightCorner a) + step 1 = midpoint (apex a) (bottomLeftCorner a) + step 2 = midpoint (bottomLeftCorner a) (bottomRightCorner a) step _ = midpoint (bottomRightCorner a) (apex a) @@ -151,7 +160,8 @@ -instance (Real u, Floating u) => CardinalAnchor2 (Triangle u) where +instance (Real u, Floating u) => + CardinalAnchor2 (Triangle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) southwest = radialAnchor (1.25*pi) @@ -159,7 +169,8 @@ -instance (Real u, Floating u) => RadialAnchor (Triangle u) where +instance (Real u, Floating u) => + RadialAnchor (Triangle u) where radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> triangleRadialVector hbw hmin hmaj theta @@ -170,20 +181,20 @@ -- | 'triangle' : @ base_width * height -> Shape @ -- -- -triangle :: (Real u, Floating u, FromPtSize u) - => u -> u -> Shape u (Triangle u) +triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Shape Triangle u triangle bw h = let props = synthesizeProps bw h hminor = tri_hminor props hmajor = tri_hmajor props - in makeShape (mkTriangle bw h props) (mkTrianglePath bw hminor hmajor) + in makeShape (mkTriangle bw h props) (mkTrianglePath 0 bw hminor hmajor) -mkTriangle :: (Real u, Fractional u) - => u -> u -> SyntheticProps u -> LocThetaCF u (Triangle u) +mkTriangle :: (Real u, Fractional u, InterpretUnit u) + => u -> u -> SyntheticProps u -> LocThetaQuery u (Triangle u) mkTriangle bw h props = promoteR2 $ \ctrd theta -> pure $ Triangle { tri_ctm = makeShapeCTM ctrd theta , tri_base_width = bw @@ -208,11 +219,12 @@ -mkTrianglePath :: (Real u, Floating u, FromPtSize u) - => u -> u -> u -> LocThetaCF u (Path u) -mkTrianglePath bw hminor hmajor = promoteR2 $ \ctr theta -> - roundCornerShapePath $ map (rotateAbout theta ctr) - $ trianglePath bw hminor hmajor ctr +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 + in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs + trianglePath :: (Real u, Floating u) diff --git a/src/Wumpus/Drawing/Text/Base.hs b/src/Wumpus/Drawing/Text/Base.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/Base.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.Base --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Helpers for working with measured / advance text. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.Base - ( - - advtext - , textVector - , charVector - - , multilineHeight - , textObjectPos - , borderedTextObjectPos - - , centerToBaseline - , centerSpinePoints - - ) where - -import Wumpus.Drawing.Chains - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.GlyphIndices - -import Data.VectorSpace -- package: vector-space - -import Control.Applicative -import Data.Char -import qualified Data.Map as Map -import Data.Maybe - - --- | Single line text, returning its advance vector. --- -advtext :: FromPtSize u => EscapedText -> AdvGraphic u -advtext esc = lift0R1 (textVector esc) >>= \v -> replaceAns v $ escapedline esc - - --- kernchar versions to do... - - -textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u) -textVector esc = - cwLookupTable >>= \table -> - let cs = destrEscapedText id esc - in return $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs - -charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u) -charVector ch = cwLookupTable >>= \table -> return $ charWidth table ch - - --- | This is outside the Drawing context as we don\'t want to get --- the @cwLookupTable@ for every char. --- -charWidth :: FromPtSize u - => CharWidthTable u -> EscapedChar -> AdvanceVec u -charWidth fn (CharLiteral c) = fn $ ord c -charWidth fn (CharEscInt i) = fn i -charWidth fn (CharEscName s) = fn ix - where - ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices - - --------------------------------------------------------------------------------- --- Measurement and start points for multiline text - - --- | Height of multiline text is cap_height to descender for the --- first line, then baseline-to-baseline span for the remaining --- lines. --- -multilineHeight :: (Real u, Floating u, FromPtSize u) - => Int -> DrawingInfo u -multilineHeight line_count - | line_count < 1 = return 0 - | line_count == 1 = glyphVerticalSpan - | otherwise = fn <$> glyphVerticalSpan <*> baselineSpacing - where - fn h1 bspan = let rest_spans = bspan * fromIntegral (line_count - 1) - in h1 + rest_spans - - - --- | Height of multiline text is cap_height to descender for the --- first line, then baseline-to-baseline span for the remaining --- lines. --- --- The answer is in centerform, i.e.: --- --- > ObjectPos half_width half_width half_height half_height --- -textObjectPos :: (Real u, Floating u, FromPtSize u) - => Int -> u -> DrawingInfo (ObjectPos u) -textObjectPos line_count w = - fmap (0.5*) (multilineHeight line_count) >>= \hh -> - let hw = 0.5 * w - in return $ ObjectPos hw hw hh hh - - --- | Variant of 'textObjectPos' where the calculation includes --- margins around all four sides of the enclosing rectangle. --- --- Margin sizes are taken from the 'text_margin' field in the --- 'DrawingContext'. --- -borderedTextObjectPos :: (Real u, Floating u, FromPtSize u) - => Int -> u -> DrawingInfo (ObjectPos u) -borderedTextObjectPos line_count w = - multilineHeight line_count >>= \h -> - getTextMargin >>= \(xsep,ysep) -> - let hw = (2 * xsep) + (0.5 * w) - hh = (2 * ysep) + (0.5 * h) - in return $ ObjectPos hw hw hh hh - - - --- | Calculate the distance from the center of a one-line textbox --- to the baseline. Note the height of a textbox is @vspan@ which --- is cap_height + descender --- -centerToBaseline :: (Fractional u, FromPtSize u) => DrawingInfo u -centerToBaseline = - (\ch vspan -> ch - 0.5 * vspan) <$> glyphCapHeight <*> glyphVerticalSpan - --- | All drawing is done on a spine that plots points from the --- first line of text. The spine is calculated from its center and --- has to account for the inclination. --- -centerSpinePoints :: Floating u - => Int -> Radian -> LocChain u -centerSpinePoints n theta - | n <= 1 = promoteR1 $ \ctr -> return [ctr] - | otherwise = promoteR1 $ \ctr -> - baselineSpacing >>= \h1 -> - let dist_top = h1 * centerCount n - top = thetaNorthwards dist_top theta ctr - in return (take n $ iterate (thetaSouthwards h1 theta) top) - - --- | Count the steps from the center to an end: --- --- > --- > 1 = 0 . --- > 2 = 0.5 .__. --- > 3 = 1 .__.__. --- > 4 = 1.5 .__.__.__. --- > --- -centerCount :: Fractional u => Int -> u -centerCount i = (fromIntegral i) / 2 - 0.5 diff --git a/src/Wumpus/Drawing/Text/Base/Common.hs b/src/Wumpus/Drawing/Text/Base/Common.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/Base/Common.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.Base.Common +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Helpers for working with measured / advance text. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.Base.Common + ( + posTextWithMargins + , advtext + , textVector + , textOrientationZero + + , charVector + , charOrientationZero + , hkernVector + , hkernOrientationZero + + ) where + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + +import Data.VectorSpace -- package: vector-space + +import Control.Applicative +import Data.Char +import qualified Data.Map as Map +import Data.Maybe + + + +posTextWithMargins :: (Fractional u, InterpretUnit u) + => PosObject u -> BoundedLocRectGraphic u +posTextWithMargins obj = + textMargin >>= \(xsep,ysep) -> + let body = extendPosObject xsep xsep ysep ysep obj + in runPosObjectR2 body + + +-- | Single line text, returning its advance vector. +-- +advtext :: InterpretUnit u => EscapedText -> AdvGraphic u +advtext esc = textVector esc >>= body + where + body v = pushR1 (replaceAns v) $ escTextLine esc + + +textVector :: (DrawingCtxM m, InterpretUnit u) + => EscapedText -> m (AdvanceVec u) +textVector esc = + cwLookupTable >>= \table -> + pointSize >>= \sz -> + let cs = destrEscapedText id esc + in return $ foldr (step sz table) (vec 0 0) cs + where + step sz table ch v = (v ^+^) $ charWidth sz table ch + +charVector :: (DrawingCtxM m, InterpretUnit u) + => EscapedChar -> m (AdvanceVec u) +charVector ch = + (\table sz -> charWidth sz table ch) <$> cwLookupTable <*> pointSize + +-- | Build the Orientation of a single line of EscapedText. +-- +-- The locus of the Orientation is baseline left - margins are +-- added. +-- +textOrientationZero :: (DrawingCtxM m, InterpretUnit u ) + => EscapedText -> m (Orientation u) +textOrientationZero esc = textVector esc >>= bllOrientationZero + +-- | Build the Orientation of an EscapedChar. +-- +-- The locus of the Orientation is baseline left - margins are +-- added. +-- +charOrientationZero :: (DrawingCtxM m, InterpretUnit u) + => EscapedChar -> m (Orientation u) +charOrientationZero ch = charVector ch >>= bllOrientationZero + + + +-- NOTE - TextMargin should probably be added as a final step +-- not during construction... + +bllOrientationZero :: (DrawingCtxM m, InterpretUnit u ) + => AdvanceVec u -> m (Orientation u) +bllOrientationZero (V2 w _) = + (\ymin ymaj -> Orientation 0 w ymin ymaj) + <$> fmap abs descender <*> capHeight + + + +-- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @ +-- +-- 'hkernvector' takes whatever length is paired with the +-- EscapedChar for the init of the the list, for the last element +-- it takes the charVector. +-- +hkernVector :: (DrawingCtxM m, InterpretUnit u) + => [KernChar u] -> m (AdvanceVec u) +hkernVector = go 0 + where + go w [] = return $ V2 w 0 + go w [(dx,ch)] = fmap (addWidth $ w + dx) (charVector ch) + go w ((dx,_ ):xs) = go (w + dx) xs + + addWidth w (V2 x y) = V2 (w+x) y + + -- ERROR this not the right way to count... + + +hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u ) + => [KernChar u] -> m (Orientation u) +hkernOrientationZero xs = hkernVector xs >>= bllOrientationZero + +-- | This is outside the Drawing context as we don\'t want to get +-- the @cwLookupTable@ for every char. +-- +charWidth :: InterpretUnit u + => FontSize -> CharWidthLookup -> EscapedChar -> AdvanceVec u +charWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c +charWidth sz fn (CharEscInt i) = fmap (dinterp sz) $ fn i +charWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix + where + ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices + diff --git a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs @@ -0,0 +1,453 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.Base.DocTextZero +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Flexible text type, composable with @pretty-print@ style +-- operators. +-- +-- Direction zero (left-to-right) only. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.Base.DocTextZero + ( + + Doc + , TextFrame + , render + + , leftAlign + , centerAlign + , rightAlign + + , blank + , space + , string + , escaped + , int + , integer + , float + , ffloat + + , (<>) + , (<+>) + , vcatl + , vcatc + , vcatr + + , lfill + , rfill + , centerfill + + , fontColour + , textSize + , bold + , italic + , boldItalic + , strikethrough + , underline + , highlight + + ) where + +import Wumpus.Drawing.Text.Base.Common + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Data.Char ( ord ) +import Numeric + + +-- | Space is the width of a space in the current font - it is +-- filled in during interpretation. +-- +data Doc u = Empty + | Space + | Text EscapedText + | Cat (Doc u) (Doc u) + | VCat VAlign (Doc u) (Doc u) + | Fill VAlign u (Doc u) + | DLocal DrawingContextF (Doc u) + | TLocal (TextContextF u) (Doc u) + | Mono (WidthQuery u) [EscapedChar] + | AElab (AElaborateF u) (Doc u) + +type WidthQuery u = Query (AdvanceVec u) + +type TextContextF u = TextContext u -> TextContext u + +type AElaborateF u = Orientation u -> LocGraphic u + + + +-- | TextFrame is the result Graphic made from rendering multiple +-- lines of DocText. +-- +type TextFrame u = BoundedLocRectGraphic u + + +-- NOTE - should the API use @em@ for fill, padding etc.? + +blank :: Doc u +blank = Empty + +space :: Doc u +space = Space + +string :: String -> Doc u +string = Text . escapeString + +escaped :: EscapedText -> Doc u +escaped = Text + + + +int :: InterpretUnit u => Int -> Doc u +int i = integer $ fromIntegral i + + +integer :: InterpretUnit u => Integer -> Doc u +integer i = Mono (charVector $ CharLiteral '0') (map CharLiteral $ show i) + +-- | Specialized version of 'ffloat' - the answer is always +-- rendered at \"full precision\". +-- +float :: (RealFloat a, InterpretUnit u) => a -> Doc u +float = ffloat Nothing + + +-- | This is equivalent to 'showFFloat' in the Numeric module. +-- +-- Like 'showFFloat', the answer is rendered to supplied +-- precision. @Nothing@ indicated full precision. +-- +ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> Doc u +ffloat mb d = Mono (charVector $ CharLiteral '0') xs + where + xs = (map CharLiteral $ ($ []) $ showFFloat mb d) + + + + +infixr 6 <>, <+> + + +-- | Concatenate two DocTexts separated with no spacing. +-- +-- (infixr 6) +-- +(<>) :: Doc u -> Doc u -> Doc u +a <> b = Cat a b + + +-- | Concatenate two Docs separated with a space. +-- +-- (infixr 6) +-- +(<+>) :: Doc u -> Doc u -> Doc u +a <+> b = a <> space <> b + +infixr 5 `vcatl`, `vcatc`, `vcatr` + +-- | Vertically concatenate - aligning left. +-- +-- (infixr 5) +-- +vcatl :: Doc u -> Doc u -> Doc u +vcatl = VCat VLeft + +-- | Vertically concatenate - aligning center. +-- +-- (infixr 5) +-- +vcatc :: Doc u -> Doc u -> Doc u +vcatc = VCat VCenter + +-- | Vertically concatenate - aligning right. +-- +-- (infixr 5) +-- +vcatr :: Doc u -> Doc u -> Doc u +vcatr = VCat VRight + +leftAlign :: [Doc u] -> Doc u +leftAlign = multiline vcatl + +centerAlign :: [Doc u] -> Doc u +centerAlign = multiline vcatc + +rightAlign :: [Doc u] -> Doc u +rightAlign = multiline vcatr + + +multiline :: (Doc u -> Doc u -> Doc u) -> [Doc u] -> Doc u +multiline _ [] = blank +multiline op (x:xs) = go x xs + where + go a [] = a + go a (b:bs) = go (a `op` b) bs + + + + +rfill :: u -> Doc u -> Doc u +rfill = Fill VLeft + +lfill :: u -> Doc u -> Doc u +lfill = Fill VRight + + +centerfill :: u -> Doc u -> Doc u +centerfill = Fill VCenter + + + +fontColour :: RGBi -> Doc u -> Doc u +fontColour rgb = DLocal (text_colour rgb) + + + +textSize :: Int -> Doc u -> Doc u +textSize sz = DLocal (set_font_size sz) + + + +bold :: Doc u -> Doc u +bold = TLocal (\s -> s { text_bold = True, text_italic = False }) + +italic :: Doc u -> Doc u +italic = TLocal (\s -> s { text_bold = False, text_italic = True }) + +boldItalic :: Doc u -> Doc u +boldItalic = TLocal (\s -> s { text_bold = True, text_italic = True }) + + +strikethrough :: Doc u -> Doc u +strikethrough = TLocal (\s -> s { text_strikethrough = True }) + +underline :: Doc u -> Doc u +underline = TLocal (\s -> s { text_underline = True }) + +-- | Background fill. +-- +highlight :: (Fractional u, InterpretUnit u) + => RGBi -> Doc u -> Doc u +highlight rgb = AElab (drawBackfill rgb) + + + +render :: (Real u, Floating u, InterpretUnit u) + => FontFamily -> Doc u -> BoundedLocRectGraphic u +render ff doc = localize (set_font $ regularWeight ff) $ + textlineSpace >>= \sep -> + posTextWithMargins $ runEvalM (initTextCtx sep ff) (interpret doc) + + +data TextContext u = TextContext + { text_strikethrough :: Bool + , text_underline :: Bool + , text_sep :: u + , text_font_family :: FontFamily + , text_bold :: Bool + , text_italic :: Bool + } + + + +initTextCtx :: u -> FontFamily -> TextContext u +initTextCtx sep ff = TextContext + { text_strikethrough = False + , text_underline = False + , text_sep = sep + , text_font_family = ff + , text_bold = False + , text_italic = False + } + +newtype EvalM u a = EvalM { getEvalM :: TextContext u -> a } + + +instance Functor (EvalM u) where + fmap f mf = EvalM $ \ctx -> f $ getEvalM mf ctx + + +instance Applicative (EvalM u) where + pure a = EvalM $ \_ -> a + mf <*> ma = EvalM $ \ctx -> + let f = getEvalM mf ctx + a = getEvalM ma ctx + in f a + +instance Monad (EvalM u) where + return a = EvalM $ \_ -> a + ma >>= k = EvalM $ \ctx -> + let a = getEvalM ma ctx + in (getEvalM . k) a ctx + +asks :: (TextContext u -> a) -> EvalM u a +asks f = EvalM $ \ctx -> f ctx + +lineSpace :: EvalM u u +lineSpace = asks text_sep + +local :: (TextContext u -> TextContext u) -> EvalM u a -> EvalM u a +local upd mf = EvalM $ \ctx -> getEvalM mf (upd ctx) + +runEvalM :: TextContext u -> EvalM u a -> a +runEvalM ctx mf = getEvalM mf ctx + + + +interpret :: (Fractional u, Ord u, InterpretUnit u) + => Doc u -> EvalM u (PosObject u) +interpret Empty = interpEmpty +interpret Space = interpSpace +interpret (Text esc) = interpText esc +interpret (Cat a b) = hconcat <$> interpret a <*> interpret b +interpret (VCat va a b) = + 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 (TLocal upd a) = local upd (interpret a) +interpret (Mono q1 xs) = interpMono q1 xs +interpret (AElab fn a) = aelaboratePO fn <$> interpret a + + + + +interpEmpty :: InterpretUnit u => EvalM u (PosObject u) +interpEmpty = return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic + + + +-- | Note - the current way of seeding the LocGraphic with the +-- DrawingContext looks dodgy (substantial copying). +-- +-- Maybe EvalM should have a private, much smaller +-- DrawingContext... +-- +interpText :: (Fractional u, InterpretUnit u) + => EscapedText -> EvalM u (PosObject u) +interpText esc = interpretLeaf $ + makePosObject (textOrientationZero esc) (escTextLine esc) + + + + +-- | Note - a space character is not draw in the output, instead +-- 'space' advances the width vector by the width of a space in +-- the current font. +-- +interpSpace :: InterpretUnit u + => EvalM u (PosObject u) +interpSpace = return $ makePosObject qy1 emptyLocGraphic + 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 + + +interpMono :: (Fractional u, InterpretUnit u) + => Query (AdvanceVec u) -> [EscapedChar] + -> EvalM u (PosObject u) +interpMono qy1 chs = interpretLeaf $ + makeBindPosObject qy hkernOrientationZero hkernLine + where + qy = (\v1 -> monoSpace (advanceH v1) chs ) <$> qy1 + + + + +interpretLeaf :: (Fractional u, InterpretUnit u) + => PosObject u -> EvalM u (PosObject u) +interpretLeaf po = + (\f1 f2 sty -> f1 $ f2 $ localizePO 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 + +textstyle :: EvalM u DrawingContextF +textstyle = + fn <$> asks text_font_family <*> asks text_bold <*> asks text_italic + where + fn ff False False = set_font $ regularWeight ff + fn ff True False = set_font $ boldWeight ff + fn ff False True = set_font $ italicWeight ff + fn ff _ _ = set_font $ boldItalicWeight ff + +-------------------------------------------------------------------------------- +-- Helpers + + +monoSpace :: Num u => u -> [EscapedChar] -> [KernChar u] +monoSpace w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs +monoSpace _ [] = [] + + + +-- API might be simple if we conditionally apply strikethrough on +-- interpText (possibly including spaces), but never on interpSpace. +-- +-- Might want to derive stroke_colour from text_colour and linewidth +-- fromf font size as well... +-- +drawStrikethrough :: (Fractional u, InterpretUnit u) + => Orientation u -> LocGraphic u +drawStrikethrough (Orientation xmin xmaj _ ymaj) = + linestyle $ moveStart (displaceVec $ vec (-xmin) vpos) hline + where + vpos = 0.45 * ymaj + hline = locStraightLine (hvec $ xmin + xmaj) + + + +drawUnderline :: (Fractional u, InterpretUnit u) + => Orientation u -> LocGraphic u +drawUnderline (Orientation xmin xmaj ymin _) = + linestyle $ moveStart (displaceVec $ vec (-xmin) vpos) hline + where + vpos = negate $ 0.45 * ymin + hline = locStraightLine (hvec $ xmin + xmaj) + +linestyle :: LocGraphic u -> LocGraphic u +linestyle mf = + pointSize >>= \sz -> + localize (stroke_use_text_colour . set_line_width (lim sz)) mf + where + lim i | i < 10 = 1.0 + | otherwise = (fromIntegral i) / 15.0 + + +-- | Note - halving the TextMargin looks good. +-- +drawBackfill :: (Fractional u, InterpretUnit u) + => RGBi -> Orientation u -> LocGraphic u +drawBackfill rgb (Orientation xmin xmaj ymin ymaj) = + textMargin >>= \(dx,dy) -> + let hdx = 0.5 * dx + 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) + mkRect dx dy = let w = dx + xmin + xmaj + dx + h = dy + ymin + ymaj + dy + in filledRectangle w h diff --git a/src/Wumpus/Drawing/Text/Base/Label.hs b/src/Wumpus/Drawing/Text/Base/Label.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/Base/Label.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.Base.Label +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Annotation labels. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.Base.Label + ( + + locImageLabel + , label_center_of + , label_left_of + , label_right_of + , label_above + , label_below + + , connectorPathLabel + , label_midway_of + , label_atstart_of + , label_atend_of + + ) where + + +import Wumpus.Drawing.Paths.Absolute + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + + + + +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) + + +label_center_of :: (Floating u, CenterAnchor a, u ~ DUnit a) + => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a +label_center_of = locImageLabel center CENTER + + +label_left_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) + => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a +label_left_of = locImageLabel west EE + +label_right_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) + => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a +label_right_of = locImageLabel east WW + + +label_above :: (Floating u, CardinalAnchor a, u ~ DUnit a) + => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a +label_above = locImageLabel north SS + + +label_below :: (Floating u, CardinalAnchor a, u ~ DUnit a) + => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a +label_below = locImageLabel south NN + + + + +connectorPathLabel :: Floating u + => (AbsPath u -> Point2 u) + -> RectAddress + -> BoundedLocRectGraphic u + -> Image u (AbsPath u) + -> Image u (AbsPath u) +connectorPathLabel fn rpos lbl img = + elaborateR0 img (\a -> graphic_ $ atStartAddr lbl (fn a) rpos) + + +label_midway_of :: (Real u, Floating u) + => RectAddress + -> BoundedLocRectGraphic u + -> Image u (AbsPath u) -> Image u (AbsPath u) +label_midway_of = connectorPathLabel midway_ + + +label_atstart_of :: (Real u, Floating u) + => RectAddress + -> BoundedLocRectGraphic u + -> Image u (AbsPath u) -> Image u (AbsPath u) +label_atstart_of = connectorPathLabel atstart_ + + +label_atend_of :: (Real u, Floating u) + => RectAddress + -> BoundedLocRectGraphic u + -> Image u (AbsPath u) -> Image u (AbsPath u) +label_atend_of = connectorPathLabel atend_ + + + +-- TikZ has label=below etc. +-- +-- This would probably translate to a functions: +-- @labelBelow@ +-- + + +-- Design note - there aren\'t many Images that support anchors, +-- except for LocImages that have been /saturated/ (i.e. applied +-- to a point with @at@). +-- +-- For a saturated Image, getting at the anchors via bind does +-- not seem so bad (indeed, this was the original point of +-- anchors). Obviously it is important to add labels to LocImages +-- (the original point of the label functions) but what about +-- LocThetaImages and LocRectImages. Is it acceptable to /saturate/ +-- them to LocImages before labelling them? +-- +-- Connectors support different /anchor-like/ positions so they +-- will different labelling functions. +-- + + diff --git a/src/Wumpus/Drawing/Text/Base/PosChar.hs b/src/Wumpus/Drawing/Text/Base/PosChar.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/Base/PosChar.hs @@ -0,0 +1,73 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.Base.PosChar +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Drawing single a char as a PosImage. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.Base.PosChar + ( + LocRectChar + + , posChar + , posEscChar + + , charLabel + , escCharLabel + + ) where + +import Wumpus.Drawing.Text.Base.Common + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + +type PosChar u = PosObject u + +posChar :: InterpretUnit u => Char -> PosChar u +posChar = makePosChar . CharLiteral + +posEscChar :: InterpretUnit u => EscapedChar -> PosChar u +posEscChar = makePosChar + + + +-- Note this type doesn\'t support concat... +-- +-- While it may be adequate, it does need another prefix. +-- +type LocRectChar u = BoundedLocRectGraphic u + + + + +charLabel :: (Floating u, InterpretUnit u) => Char -> LocRectChar u +charLabel ch = escCharLabel $ CharLiteral ch + + +escCharLabel :: (Floating u, InterpretUnit u) + => EscapedChar -> LocRectChar u +escCharLabel esc = runPosObjectR2 (makePosChar esc) + + +makePosChar :: InterpretUnit u + => EscapedChar -> PosObject u +makePosChar esc = makePosObject (charOrientationZero esc) (escText1 esc) + + +escText1 :: InterpretUnit u => EscapedChar -> LocGraphic u +escText1 ch = escTextLine $ wrapEscChar ch + + + diff --git a/src/Wumpus/Drawing/Text/Base/RotTextZero.hs b/src/Wumpus/Drawing/Text/Base/RotTextZero.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/Base/RotTextZero.hs @@ -0,0 +1,375 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.Base.RotTextZero +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Direction zero (left-to-right) measured text that supports +-- radial inclination. Caveat - rendering at any inclination other +-- than the horizontal may not look good in PostScript or SVG. +-- +-- \*\* WARNING \*\* - the API for this module needs some polish. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.Base.RotTextZero + ( + LocRectTextLine + , LocTextLine + , TextObject + + , textline + , bllTextline + , blcTextline + , ccTextline + + , multiAlignLeft + , multiAlignCenter + , multiAlignRight + + , rtextline + , rescTextline + + ) where + +import Wumpus.Drawing.Text.Base.Common + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +type LocRectTextLine u = BoundedLocRectGraphic u +type LocTextLine u = BoundedLocGraphic u + +type TextObject u = PosObject u + + + +-- | Draw a single line of text. +-- +textline :: (Fractional u, InterpretUnit u) + => String -> LocRectTextLine u +textline ss = posTextWithMargins (makeTextObject ss) + + +bllTextline :: (Floating u, InterpretUnit u) + => String -> LocTextLine u +bllTextline ss = startAddr (textline ss) BLL + + +blcTextline :: (Floating u, InterpretUnit u) + => String -> LocTextLine u +blcTextline ss = startAddr (textline ss) BLC + +ccTextline :: (Floating u, InterpretUnit u) + => String -> LocTextLine u +ccTextline ss = startAddr (textline ss) CENTER + + +multiAlignLeft :: (Real u, Floating u, InterpretUnit u) + => String -> LocRectTextLine u +multiAlignLeft ss = + renderMultiLine VLeft (map makeTextObject $ lines ss) + +multiAlignCenter :: (Real u, Floating u, InterpretUnit u) + => String -> LocRectTextLine u +multiAlignCenter ss = + renderMultiLine VCenter (map makeTextObject $ lines ss) + +multiAlignRight :: (Real u, Floating u, InterpretUnit u) + => String -> LocRectTextLine u +multiAlignRight ss = + renderMultiLine VRight (map makeTextObject $ lines ss) + + +renderMultiLine :: (Real u, Floating u, InterpretUnit u) + => VAlign -> [TextObject u] -> LocRectTextLine u +renderMultiLine va docs = body >>= posTextWithMargins + where + body = (\dy -> alignColumnSep va dy $ reverse docs) <$> textlineSpace + + +makeTextObject :: InterpretUnit u => String -> TextObject u +makeTextObject = makeEscTextObject . escapeString + + +makeEscTextObject :: InterpretUnit u => EscapedText -> TextObject u +makeEscTextObject esc = + makePosObject (textOrientationZero esc) (escTextLine esc) + + +-- Note inclided text will (probably) have to construct with the +-- incline angle rather than apply it as part of the run function. +-- + +rtextline :: (Real u, Floating u, Ord u, InterpretUnit u) + => 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 + where + ortt = fmap (rotOrientation ang) $ textOrientationZero esc + body = incline (rescTextLine 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) = + 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 + + +-- | This is not necessarily correct... +-- +orthoOrientation :: (Num u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u + -> Orientation u +orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) = + Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3 + , or_x_major = max4 x0 x1 x2 x3 + , or_y_minor = abs $ min4 y0 y1 y2 y3 + , or_y_major = max4 y0 y1 y2 y3 + } + + +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/Text/CatText.hs b/src/Wumpus/Drawing/Text/CatText.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/CatText.hs +++ /dev/null @@ -1,207 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.Text --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Left-to-right text. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.CatText - ( - - CatText - , leftAlign - , centerAlign - , rightAlign - - , blank - , space - , string - , (<>) - , (<+>) - - , fontColour - - ) where - -import Wumpus.Drawing.Chains -import Wumpus.Drawing.Text.Base - -import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl ) -import qualified Wumpus.Basic.Utils.JoinList as JL - -import Wumpus.Core -- package: wumpus-core - -import Data.Char ( ord ) - --- Need to know line width (horizontal) and line count (vertical) --- to render... --- --- Can obviously access line count if we avoid avoid operators --- for vertical composition operator and delegate it to rendering --- instead: --- --- > rightAlign :: [CatText u] -> PosImage u (BoundingBox u) --- - --- A CatPrim returns a drawing function (AdvGraphic) to be used --- drawing final rendering. --- -type CatPrim u = CF (u, AdvGraphic u) - -newtype CatText u = CatText { getCatText :: JoinList (CatPrim u) } - - - --- | 'HMove' : @ half_max_width * line_width -> Horizontal_Displacement @ --- -type HMove u = u -> u -> u - -leftAMove :: Num u => HMove u -leftAMove half_max _ = negate half_max - -centerAMove :: Fractional u => HMove u -centerAMove _ elt_w = negate $ 0.5 * elt_w - -rightAMove :: Num u => HMove u -rightAMove half_max elt_w = half_max - elt_w - - - -leftAlign :: (Real u, FromPtSize u, Floating u) - => [CatText u] -> PosImage u (BoundingBox u) -leftAlign = drawMulti leftAMove - -centerAlign :: (Real u, FromPtSize u, Floating u) - => [CatText u] -> PosImage u (BoundingBox u) -centerAlign = drawMulti centerAMove - -rightAlign :: (Real u, FromPtSize u, Floating u) - => [CatText u] -> PosImage u (BoundingBox u) -rightAlign = drawMulti rightAMove - - - -drawMulti :: (Real u, FromPtSize u, Floating u) - => HMove u -> [CatText u] -> PosImage u (BoundingBox u) -drawMulti moveF xs = promoteR2 $ \start rpos -> - evalAllLines xs >>= \all_lines -> - centerToBaseline >>= \down -> - borderedTextObjectPos line_count (fst all_lines) >>= \opos -> - let chn = centerSpinePoints line_count 0 - gs = positionHLines moveF down all_lines - gf = unchainZip emptyLocGraphic gs chn - posG = makePosImage opos gf - bbox = objectPosBounds start rpos opos - in replaceAns bbox $ atStartPos posG start rpos - where - line_count = length xs - -positionHLines :: Fractional u - => HMove u -> u -> (u,[(u, AdvGraphic u)]) -> [LocGraphic u] -positionHLines mkH down (max_w,xs) = map fn xs - where - half_max = 0.5 * max_w - moveF w1 = let v = vec (mkH half_max w1) (-down) - in moveStart $ displaceVec v - fn (elt_w, gf) = ignoreAns $ moveF elt_w $ gf - - -evalAllLines :: (Num u, Ord u) - => [CatText u] -> DrawingInfo (u, [(u, AdvGraphic u)]) -evalAllLines = fmap post . mapM evalLine - where - post xs = let mx = foldr (\(a,_) x -> max a x) 0 xs in (mx,xs) - - - - - -evalLine :: Num u => CatText u -> DrawingInfo (u, AdvGraphic u) -evalLine ct = case viewl $ getCatText ct of - EmptyL -> return (0, replaceAns (hvec 0) $ emptyLocGraphic) - af :< rest -> af >>= \a -> go a (viewl rest) - where - go acc EmptyL = return acc - go (dx,af) (mf :< ms) = let moveF = moveStart (displaceH dx) - in mf >>= \(u,gf) -> - go (dx+u, af `oplus` moveF gf) (viewl ms) - - - - - --- | Build a blank CatText with no output and a 0 width vector. --- -blank :: Num u => CatText u -blank = catOne $ return (0, replaceAns (hvec 0) $ emptyLocGraphic) - --- | Note - a space character is not draw in the output, instead --- 'space' advances the width vector by the width of a space in --- the current font. --- -space :: FromPtSize u => CatText u -space = catOne $ - charVector (CharEscInt $ ord ' ') >>= \v -> - return (advanceH v, replaceAns v $ emptyLocGraphic) - --- | Build a CatText from a string. --- -string :: FromPtSize u => String -> CatText u -string = catOne . stringPrim - - -infixr 6 <>, <+> - --- | Concatenate two CatTexts separated with no spacing. --- -(<>) :: CatText u -> CatText u -> CatText u -a <> b = CatText $ JL.join (getCatText a) (getCatText b) - - --- | Concatenate two CatTexts separated with a space. --- -(<+>) :: FromPtSize u => CatText u -> CatText u -> CatText u -a <+> b = a <> space <> b - - - --- Note - @fill@ combinators cf. @wl-pprint@ (but left and right) --- will be very useful. --- --- Also PosImages can be inlined in text... --- - -catOne :: CatPrim u -> CatText u -catOne = CatText . JL.one - - -stringPrim :: FromPtSize u => String -> CatPrim u -stringPrim = escapedPrim . escapeString - -escapedPrim :: FromPtSize u => EscapedText -> CatPrim u -escapedPrim esc = textVector esc >>= \v -> - return (vector_x v, replaceAns v $ escapedline esc) - - -catMap :: (AdvGraphic u -> AdvGraphic u) -> CatText u -> CatText u -catMap f = CatText . fmap (fmap (\(u,ag) -> (u, f $ ag))) . getCatText - -catlocal :: DrawingContextF -> CatText u -> CatText u -catlocal fn = catMap (localize fn) - - -fontColour :: RGBi -> CatText u -> CatText u -fontColour rgb = catlocal (strokeColour rgb) - - diff --git a/src/Wumpus/Drawing/Text/DirectionZero.hs b/src/Wumpus/Drawing/Text/DirectionZero.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/DirectionZero.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.DirectionZero +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Common import module for the Writing Direction 0 modules +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.DirectionZero + ( + module Wumpus.Drawing.Text.Base.DocTextZero + , module Wumpus.Drawing.Text.Base.PosChar + , module Wumpus.Drawing.Text.Base.RotTextZero + + ) where + +import Wumpus.Drawing.Text.Base.DocTextZero +import Wumpus.Drawing.Text.Base.PosChar +import Wumpus.Drawing.Text.Base.RotTextZero diff --git a/src/Wumpus/Drawing/Text/LRText.hs b/src/Wumpus/Drawing/Text/LRText.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/LRText.hs +++ /dev/null @@ -1,292 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.LRText --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Left-to-right measured text that supports radial inclination. --- Caveat - rendering at any degree other than the horizontal may --- not look good in PostScript or SVG. --- --- Note - LRText does not use the 'text_margin' setting from the --- 'DrawingContext'. --- --- \*\* WARNING \*\* - the API for this module needs some polish. --- --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.LRText - ( - - singleLine - , escSingleLine - , rsingleLine - , rescSingleLine - - , multiAlignLeft - , multiAlignCenter - , multiAlignRight - - , textAlignCenter - , textAlignLeft - , textAlignRight - - ) where - -import Wumpus.Drawing.Chains -import Wumpus.Drawing.Text.Base - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - - --- --- Note - margins are not added to the text. This seems to be the --- right thing to do in the case of rotated text, where the ortho --- projection of the rectangle already can add spacing between --- the RectPos and the actual text. --- - - -------------------- - --- | One line of multiline text --- -data OnelineText u = OnelineText - { text_content :: EscapedText - , oneline_adv :: AdvanceVec u - } - --- Design note - using a LocThetaImage could be used instead, but --- as the angle of inclination is interior to the final type the --- it is used explicitly. --- -type OnelineDrawF u = - Radian -> AdvanceVec u -> OnelineText u -> LocImage u (BoundingBox u) - - - - -singleLine :: (Real u, Floating u, FromPtSize u) - => String -> PosImage u (BoundingBox u) -singleLine ss = onelineDraw onelineACenter 0 (escapeString ss) - -escSingleLine :: (Real u, Floating u, FromPtSize u) - => EscapedText -> PosImage u (BoundingBox u) -escSingleLine = onelineDraw onelineACenter 0 - - -rsingleLine :: (Real u, Floating u, FromPtSize u) - => Radian -> String -> PosImage u (BoundingBox u) -rsingleLine theta ss = onelineDraw onelineACenter theta (escapeString ss) - -rescSingleLine :: (Real u, Floating u, FromPtSize u) - => Radian -> EscapedText -> PosImage u (BoundingBox u) -rescSingleLine = onelineDraw onelineACenter - -multiAlignLeft :: (Real u, Floating u, FromPtSize u) - => Radian -> String -> PosImage u (BoundingBox u) -multiAlignLeft theta ss = - drawMultiline onelineALeft theta (map escapeString $ lines ss) - -multiAlignCenter :: (Real u, Floating u, FromPtSize u) - => Radian -> String -> PosImage u (BoundingBox u) -multiAlignCenter theta ss = - drawMultiline onelineACenter theta (map escapeString $ lines ss) - -multiAlignRight :: (Real u, Floating u, FromPtSize u) - => Radian -> String -> PosImage u (BoundingBox u) -multiAlignRight theta ss = - drawMultiline onelineARight theta (map escapeString $ lines ss) - - -textAlignLeft :: (Real u, Floating u, FromPtSize u) - => String -> LocImage u (BoundingBox u) -textAlignLeft ss = multiAlignLeft 0 ss `startPos` CENTER - -textAlignCenter :: (Real u, Floating u, FromPtSize u) - => String -> LocImage u (BoundingBox u) -textAlignCenter ss = multiAlignCenter 0 ss `startPos` CENTER - -textAlignRight :: (Real u, Floating u, FromPtSize u) - => String -> LocImage u (BoundingBox u) -textAlignRight ss = multiAlignRight 0 ss `startPos` CENTER - - - - --- Note - inclination is not part of the ContextFunction... - -drawMultiline :: (Real u, Floating u, FromPtSize u) - => OnelineDrawF u -> Radian -> [EscapedText] - -> PosImage u (BoundingBox u) -drawMultiline _ _ [] = lift1R2 emptyBoundedLocGraphic -drawMultiline drawF theta [x] = onelineDraw drawF theta x -drawMultiline drawF theta xs = promoteR2 $ \start rpos -> - linesToInterims xs >>= \(max_adv, ones) -> - rotObjectPos theta line_count (advanceH max_adv) >>= \opos -> - let chn = centerSpinePoints line_count theta - gs = map (drawF theta max_adv) ones - gf = unchainZip emptyBoundedLocGraphic gs chn - posG = makePosImage opos gf - in atStartPos posG start rpos - where - line_count = length xs - - - - -onelineDraw :: (Real u, Floating u, FromPtSize u) - => OnelineDrawF u -> Radian -> EscapedText -> PosImage u (BoundingBox u) -onelineDraw drawF theta esc = promoteR2 $ \start rpos -> - onelineEscText esc >>= \otext -> - rotObjectPos theta 1 (advanceH $ oneline_adv otext) >>= \opos -> - let max_adv = oneline_adv otext - gf = drawF theta max_adv otext - posG = makePosImage opos gf - in atStartPos posG start rpos - - --- | LR text needs the objectPos under rotation. --- -rotObjectPos :: (Real u, Floating u, FromPtSize u) - => Radian -> Int -> u -> DrawingInfo (ObjectPos u) -rotObjectPos theta line_count max_w = - fmap (orthoObjectPos theta) $ textObjectPos line_count max_w - - - - - --- | Note - this returns the answer in center form, regardless --- of whether the input was in center form. --- --- So it is probably not a general enough function for the --- PosImage library. --- -orthoObjectPos :: (Real u, Floating u) - => Radian -> ObjectPos u -> ObjectPos u -orthoObjectPos theta (ObjectPos xmin xmaj ymin ymaj) = - ObjectPos bbox_hw bbox_hw bbox_hh bbox_hh - where - input_hw = 0.5 * (xmin + xmaj) - input_hh = 0.5 * (ymin + ymaj) - bbox0 = BBox (P2 (-input_hw) (-input_hh)) (P2 input_hw input_hh) - bbox1 = retraceBoundary (rotateAbout theta zeroPt) bbox0 - bbox_hw = 0.5 * (boundaryWidth bbox1) - bbox_hh = 0.5 * (boundaryHeight bbox1) - - - - - - - --- | 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, FromPtSize u) - => OnelineDrawF u -onelineALeft theta max_adv otext = promoteR1 $ \ctr -> - centerToBaseline >>= \down -> - atRot (orthoBB max_adv) ctr theta >>= \bbox -> - let pt = move down theta ctr - in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta - where - vec1 = negateV $ 0.5 *^ max_adv - 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. --- -onelineACenter :: (Real u, Floating u, FromPtSize u) - => OnelineDrawF u -onelineACenter theta max_adv otext = promoteR1 $ \ctr -> - centerToBaseline >>= \down -> - atRot (orthoBB max_adv) ctr theta >>= \bbox -> - let pt = move down theta ctr - in replaceAns bbox $ atRot (rescapedline $ 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 vector --- > --- > Leftwards for the width vector --- > --- > Down to the baseline from the center. --- -onelineARight :: (Real u, Floating u, FromPtSize u) - => OnelineDrawF u -onelineARight theta max_adv otext = promoteR1 $ \ctr -> - centerToBaseline >>= \down -> - atRot (orthoBB max_adv) ctr theta >>= \bbox -> - let pt = move down theta ctr - in replaceAns bbox $ atRot (rescapedline $ text_content otext) pt theta - where - vec1 = (0.5 *^ max_adv) ^-^ 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. --- -orthoBB :: (Real u, Floating u, FromPtSize u) - => AdvanceVec u -> LocThetaDrawingInfo u (BoundingBox u) -orthoBB (V2 w _) = promoteR2 $ \ctr theta -> - glyphVerticalSpan >>= \h -> - let bl = ctr .-^ V2 (0.5 * w) (0.5 * h) - bb1 = boundingBox bl (bl .+^ V2 w h) - bb2 = retraceBoundary (rotateAbout theta ctr) bb1 - in return bb2 - - - --------------------------------------------------------------------------------- - --- 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 'AdvanceVec'. --- -linesToInterims :: (FromPtSize u, Ord u) - => [EscapedText] -> DrawingInfo (AdvanceVec u, [OnelineText u]) -linesToInterims = fmap post . mapM onelineEscText - where - post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs) - fn (OnelineText _ av) vmax = avMaxWidth av vmax - - - - -avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u -avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a - -onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u) -onelineEscText esc = fmap (OnelineText esc) $ textVector esc - - diff --git a/src/Wumpus/Drawing/Text/SafeFonts.hs b/src/Wumpus/Drawing/Text/SafeFonts.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/SafeFonts.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.SafeFonts --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Safe to use \"Core 13\" fonts that are expected to be present --- for any PostScript interpreter. --- --- Note - regrettably Symbol is not safe to use for SVG. --- --- \*\* WARNING \*\* - this module is in flux due to changes to --- Text encoding in Wumpus-Core and adding font metrics to --- Wumpus-Basic. The code here is likely to be revised. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.SafeFonts - ( - -- * Times Roman - times_roman - , times_italic - , times_bold - , times_bold_italic - - -- * Helvetica - , helvetica - , helvetica_oblique - , helvetica_bold - , helvetica_bold_oblique - - -- * Courier - , courier - , courier_oblique - , courier_bold - , courier_bold_oblique - - -- * Symbol - , symbol - - ) where - - - -import Wumpus.Core -import Wumpus.Core.Text.StandardEncoding -import Wumpus.Core.Text.Symbol - --- Supported fonts are: --- --- Times-Roman Times-Italic Times-Bold Times-BoldItalic --- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique --- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique --- Symbol - --------------------------------------------------------------------------------- --- - --- | Times-Roman --- -times_roman :: FontFace -times_roman = - FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding - --- | Times Italic --- -times_italic :: FontFace -times_italic = - FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding - --- | Times Bold --- -times_bold :: FontFace -times_bold = - FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding - --- | Times Bold Italic --- -times_bold_italic :: FontFace -times_bold_italic = FontFace "Times-BoldItalic" - "Times New Roman" - SVG_BOLD_ITALIC - standard_encoding - - --------------------------------------------------------------------------------- --- Helvetica - --- | Helvetica --- -helvetica :: FontFace -helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding - - --- | Helvetica Oblique --- -helvetica_oblique :: FontFace -helvetica_oblique = - FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding - --- | Helvetica Bold --- -helvetica_bold :: FontFace -helvetica_bold = - FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding - - --- | Helvetica Bold Oblique --- -helvetica_bold_oblique :: FontFace -helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" - "Helvetica" - SVG_BOLD_OBLIQUE - standard_encoding - - - --------------------------------------------------------------------------------- - --- | Courier --- -courier :: FontFace -courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding - --- | Courier Oblique --- -courier_oblique :: FontFace -courier_oblique = - FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding - --- | Courier Bold --- -courier_bold :: FontFace -courier_bold = - FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding - - --- | Courier Bold Oblique --- -courier_bold_oblique :: FontFace -courier_bold_oblique = FontFace "Courier-Bold-Oblique" - "Courier New" - SVG_BOLD_OBLIQUE - standard_encoding - --------------------------------------------------------------------------------- --- Symbol - --- | Symbol --- --- Note - Symbol is intentionally not supported for SVG by some --- renderers (Firefox). Chrome is fine, but the use of symbol --- should be still be avoided for web graphics. --- -symbol :: FontFace -symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding - - - - - diff --git a/src/Wumpus/Drawing/Text/StandardFontDefs.hs b/src/Wumpus/Drawing/Text/StandardFontDefs.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/StandardFontDefs.hs @@ -0,0 +1,323 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.StandardFontDefs +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Safe to use \"Core 13\" fonts that are expected to be present +-- for any PostScript interpreter. +-- +-- Note - regrettably Symbol is not safe to use for SVG. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.StandardFontDefs + ( + -- * Times Roman + times_roman_family + + , times_roman + , times_italic + , times_bold + , times_bold_italic + + -- * Helvetica + , helvetica_family + + , helvetica + , helvetica_oblique + , helvetica_bold + , helvetica_bold_oblique + + -- * Courier + , courier_family + + , courier + , courier_oblique + , courier_bold + , courier_bold_oblique + + -- * Symbol + , symbol + + ) where + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.StandardEncoding +import Wumpus.Core.Text.Symbol + +-- Supported fonts are: +-- +-- Times-Roman Times-Italic Times-Bold Times-BoldItalic +-- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique +-- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique +-- Symbol + +-------------------------------------------------------------------------------- +-- + +-- | 'FontFamily' definition for Times-Roman. +-- +times_roman_family :: FontFamily +times_roman_family = + FontFamily { ff_regular = times_roman + , ff_bold = Just times_bold + , ff_italic = Just times_italic + , ff_bold_italic = Just times_bold_italic + } + + +-- | Times-Roman +-- +times_roman :: FontDef +times_roman = + FontDef { font_def_face = face + , gs_file_name = "n021003l.afm" -- NimbusRomNo9L-Regu + , afm_file_name = "Times-Roman.afm" + } + where + face = FontFace { ps_font_name = "Times-Roman" + , svg_font_family = "Times New Roman" + , svg_font_style = SVG_REGULAR + , font_enc_vector = standard_encoding + } + + +-- | Times Italic +-- +times_italic :: FontDef +times_italic = + FontDef { font_def_face = face + , gs_file_name = "n021023l.afm" -- NimbusRomNo9L-ReguItal + , afm_file_name = "Times-Italic.afm" + } + where + face = FontFace { ps_font_name = "Times-Italic" + , svg_font_family = "Times New Roman" + , svg_font_style = SVG_ITALIC + , font_enc_vector = standard_encoding + } + + +-- | Times Bold +-- +times_bold :: FontDef +times_bold = + FontDef { font_def_face = face + , gs_file_name = "n021004l.afm" -- NimbusRomNo9L-Medi + , afm_file_name = "Times-Bold.afm" + } + where + face = FontFace { ps_font_name = "Times-Bold" + , svg_font_family = "Times New Roman" + , svg_font_style = SVG_BOLD + , font_enc_vector = standard_encoding + } + + +-- | Times Bold Italic +-- +times_bold_italic :: FontDef +times_bold_italic = + FontDef { font_def_face = face + , gs_file_name = "n021024l.afm" -- NimbusRomNo9L-MediItal + , afm_file_name = "Times-BoldItalic.afm" + } + where + face = FontFace { ps_font_name = "Times-BoldItalic" + , svg_font_family = "Times New Roman" + , svg_font_style = SVG_BOLD_ITALIC + , font_enc_vector = standard_encoding + } + + +-------------------------------------------------------------------------------- +-- Helvetica + +-- | 'FontFamily' definition for Helvetica. +-- +helvetica_family :: FontFamily +helvetica_family = + FontFamily { ff_regular = helvetica + , ff_bold = Just helvetica_bold + , ff_italic = Just helvetica_oblique + , ff_bold_italic = Just helvetica_bold_oblique + } + + + +-- | Helvetica regular weight. +-- +helvetica :: FontDef +helvetica = + FontDef { font_def_face = face + , gs_file_name = "n019003l.afm" -- NimbusSanL-Regu + , afm_file_name = "Helvetica.afm" + } + where + face = FontFace { ps_font_name = "Helvetica" + , svg_font_family = "Helvetica" + , svg_font_style = SVG_REGULAR + , font_enc_vector = standard_encoding + } + + +-- | Helvetica Oblique +-- +helvetica_oblique :: FontDef +helvetica_oblique = + FontDef { font_def_face = face + , gs_file_name = "n019023l.afm" -- NimbusSanL-ReguItal + , afm_file_name = "Helvetica-Oblique.afm" + } + where + face = FontFace { ps_font_name = "Helvetica-Oblique" + , svg_font_family = "Helvetica" + , svg_font_style = SVG_OBLIQUE + , font_enc_vector = standard_encoding + } + +-- | Helvetica Bold +-- +helvetica_bold :: FontDef +helvetica_bold = + FontDef { font_def_face = face + , gs_file_name = "n019004l.afm" -- NimbusSanL-Bold + , afm_file_name = "Helvetica-Bold.afm" + } + where + face = FontFace { ps_font_name = "Helvetica-Bold" + , svg_font_family = "Helvetica" + , svg_font_style = SVG_BOLD + , font_enc_vector = standard_encoding + } + + +-- | Helvetica Bold Oblique +-- +helvetica_bold_oblique :: FontDef +helvetica_bold_oblique = + FontDef { font_def_face = face + , gs_file_name = "n019024l.afm" -- NimbusSanL-BoldItal + , afm_file_name = "Helvetica-BoldOblique.afm" + } + where + face = FontFace { ps_font_name = "Helvetica-Bold-Oblique" + , svg_font_family = "Helvetica" + , svg_font_style = SVG_BOLD_OBLIQUE + , font_enc_vector = standard_encoding + } + + + +-------------------------------------------------------------------------------- + +-- | 'FontFamily' definition for Courier. +-- +courier_family :: FontFamily +courier_family = + FontFamily { ff_regular = courier + , ff_bold = Just courier_bold + , ff_italic = Just courier_oblique + , ff_bold_italic = Just courier_bold_oblique + } + + + +-- | Courier +-- +courier :: FontDef +courier = + FontDef { font_def_face = face + , gs_file_name = "n022003l.afm" -- NimbusMonL-Regu + , afm_file_name = "Courier.afm" + } + where + face = FontFace { ps_font_name = "Courier" + , svg_font_family = "Courier New" + , svg_font_style = SVG_REGULAR + , font_enc_vector = standard_encoding + } + +-- | Courier Oblique +-- +courier_oblique :: FontDef +courier_oblique = + FontDef { font_def_face = face + , gs_file_name = "n022023l.afm" -- NimbusMonL-ReguObli + , afm_file_name = "Courier-Oblique.afm" + } + where + face = FontFace { ps_font_name = "Courier-Oblique" + , svg_font_family = "Courier New" + , svg_font_style = SVG_OBLIQUE + , font_enc_vector = standard_encoding + } + + +-- | Courier Bold +-- +courier_bold :: FontDef +courier_bold = + FontDef { font_def_face = face + , gs_file_name = "n022004l.afm" -- NimbusMonL-Bold + , afm_file_name = "Courier-Bold.afm" + } + where + face = FontFace { ps_font_name = "Courier-Bold" + , svg_font_family = "Courier New" + , svg_font_style = SVG_BOLD + , font_enc_vector = standard_encoding + } + + +-- | Courier Bold Oblique +-- +courier_bold_oblique :: FontDef +courier_bold_oblique = + FontDef { font_def_face = face + , gs_file_name = "n022024l.afm" -- NimbusMonL-BoldObli + , afm_file_name = "Courier-BoldOblique.afm" + } + where + face = FontFace { ps_font_name = "Courier-Bold-Oblique" + , svg_font_family = "Courier New" + , svg_font_style = SVG_BOLD_OBLIQUE + , font_enc_vector = standard_encoding + } + +-------------------------------------------------------------------------------- +-- Symbol + +-- | Symbol +-- +-- Note - Symbol is intentionally not supported for SVG by some +-- renderers (Firefox). Chrome is fine, but the use of symbol +-- should be still be avoided for web graphics. +-- +symbol :: FontDef +symbol = + FontDef { font_def_face = face + , gs_file_name = "s050000l.afm" -- StandardSymL + , afm_file_name = "Symbol.afm" + } + where + face = FontFace { ps_font_name = "Symbol" + , svg_font_family = "Symbol" + , svg_font_style = SVG_REGULAR + , font_enc_vector = symbol_encoding + } + + + + + diff --git a/src/Wumpus/Drawing/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Turtle/TurtleClass.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Turtle/TurtleClass.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.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.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/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.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.Turtle.TurtleMonad - ( - -- * Re-exports - module Wumpus.Drawing.Turtle.TurtleClass - - -- * Turtle transformer - , TurtleT - , runTurtleT - - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Turtle.TurtleClass - - - -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 :: ScalingContext Int Int u - -> TurtleState - -> m (a, TurtleState) } - -type instance MonUnit (TurtleT u m) = u - - - --- Functor - - - -instance Monad m => Functor (TurtleT u m) where - fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') -> - return (f a, s') - - --- Applicative - -instance Monad m => Applicative (TurtleT u m) where - pure a = TurtleT $ \_ s -> return (a,s) - mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s >>= \(f,s') -> - getTurtleT ma r 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 $ \r s -> getTurtleT m r s >>= \(a,s') -> - (getTurtleT . k) a r s' >>= \(b,s'') -> - return (b,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) -> ScalingContext Int Int u -> TurtleT u m a -> m a -runTurtleT ogin cfg mf = getTurtleT mf cfg 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 $ \r s -> localize upd (getTurtleT mf r 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) - - -instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where - position = TurtleT $ \r s@(TurtleState _ (x,y)) -> return (scalePt r x y,s) - 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 @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.VersionNumber --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,2,0) +-- > (0,3,0) -- wumpus_drawing_version :: (Int,Int,Int) -wumpus_drawing_version = (0,2,0) +wumpus_drawing_version = (0,3,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.2.0 +version: 0.3.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -12,7 +12,7 @@ \*\* WARNING \*\* - this package is sub-alpha. Although many of the drawing objects have been improved since the code was split from Wumpus-Basic, the code is still prototypical. Essentially - this package is a /technology preview/ and not a re-usable + this package is a /technology preview/ and not yet a re-usable library. . NOTE - many of the demos use font metrics. Font metrics for @@ -24,7 +24,7 @@ links below. To run the demos properly you will need one of these sets of metrics. . - Adobe Font techinal notes: + Adobe Font technical notes: . Core 14 AFM metrics: @@ -38,8 +38,23 @@ . Changelog: . - v0.1.0 to 0.2.0: + v0.2.0 to v0.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. + . + v0.1.0 to v0.2.0: + . * Added new Shapes. . * Move Geometry modules to Wumpus-Basic. @@ -73,16 +88,17 @@ LICENSE, demo/ArrowCircuit.hs, demo/Arrowheads.hs, + demo/Automata.hs, demo/ClipPic.hs, demo/ColourCharts.hs, demo/ColourChartUtils.hs, demo/Connectors.hs demo/DotPic.hs, demo/FeatureModel.hs, - demo/FontLoaderUtils.hs, demo/FontPic.hs, demo/LeftRightText.hs, demo/PetriNet.hs, + demo/SingleChar.hs, demo/SingleLine.hs, demo/SampleShapes.hs, demo/Symbols.hs, @@ -93,27 +109,33 @@ build-depends: base < 5, containers >= 0.3 && <= 0.6, vector-space >= 0.6 && < 1.0, - wumpus-core >= 0.43.0 && < 0.44.0, - wumpus-basic == 0.16.0 + wumpus-core >= 0.50.0 && < 0.51.0, + wumpus-basic == 0.17.0 exposed-modules: - Wumpus.Drawing.Arrows, - Wumpus.Drawing.Arrows.Connectors, - Wumpus.Drawing.Arrows.Tips, - Wumpus.Drawing.Chains, - Wumpus.Drawing.Chains.Base, - Wumpus.Drawing.Chains.Derived, Wumpus.Drawing.Colour.SVGColours, Wumpus.Drawing.Colour.X11Colours, + Wumpus.Drawing.Connectors, + Wumpus.Drawing.Connectors.Arrowheads, + 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.Grids, - Wumpus.Drawing.Paths, - Wumpus.Drawing.Paths.Base, - Wumpus.Drawing.Paths.Connectors, - Wumpus.Drawing.Paths.MonadicConstruction, - Wumpus.Drawing.Paths.ControlPoints, + Wumpus.Drawing.Extras.Axes, + Wumpus.Drawing.Extras.Grids, + Wumpus.Drawing.Extras.Turtle.TurtleClass, + Wumpus.Drawing.Extras.Turtle.TurtleMonad, + 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.RelPath, + Wumpus.Drawing.Paths.Relative, + Wumpus.Drawing.Paths.Vamps, Wumpus.Drawing.Shapes, Wumpus.Drawing.Shapes.Base, Wumpus.Drawing.Shapes.Circle, @@ -128,12 +150,13 @@ Wumpus.Drawing.Shapes.Semicircle, Wumpus.Drawing.Shapes.Semiellipse, Wumpus.Drawing.Shapes.Triangle, - Wumpus.Drawing.Text.Base, - Wumpus.Drawing.Text.CatText, - Wumpus.Drawing.Text.LRText, - Wumpus.Drawing.Text.SafeFonts, - Wumpus.Drawing.Turtle.TurtleClass, - Wumpus.Drawing.Turtle.TurtleMonad, + Wumpus.Drawing.Text.Base.Common, + Wumpus.Drawing.Text.Base.DocTextZero, + Wumpus.Drawing.Text.Base.Label, + Wumpus.Drawing.Text.Base.PosChar, + Wumpus.Drawing.Text.Base.RotTextZero, + Wumpus.Drawing.Text.DirectionZero, + Wumpus.Drawing.Text.StandardFontDefs, Wumpus.Drawing.VersionNumber other-modules: