diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -11,6 +11,7 @@ module ArrowCircuit where import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -78,7 +79,7 @@ -- Note - need a variant of /bar/ that draws UDLR only. connWith :: ( Real u, Floating u, InterpretUnit u ) - => Connector u -> Anchor u -> Anchor u -> TraceDrawing u () + => ConnectorPathQuery u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $ drawc a0 a1 (rightArrow tri45 con) @@ -87,13 +88,13 @@ , Real u, Floating u, InterpretUnit u) => t u -> String -> TraceDrawing u () atext ancr ss = - draw $ textline ss CENTER `at` (center ancr) + draw $ textline CENTER ss `at` (center ancr) ptext :: (Floating u, InterpretUnit u) => Point2 u -> String -> TraceDrawing u () ptext pt ss = localize (font_attr times_italic 14) $ - draw $ textline ss CENTER `at` pt + draw $ textline CENTER ss `at` pt -- Note - return type is a LocImage not a shape... @@ -104,3 +105,20 @@ -- This should have round corners but they are currently -- disabled pending a re-think. {- localize (round_corner_factor r) $ -} + + + +-- Cf. Parsec\'s Token module... + +connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u +connline = C.connline default_connector_props + +connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathQuery u +connabar = C.connabar default_connector_props + + +connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathQuery u +connaright = C.connaright default_connector_props + diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -4,6 +4,7 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -76,9 +77,9 @@ tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = - drawl start $ runChain_ (mapM makeArrowDrawing tips) chn_alg + drawl start $ runTableColumnwise 18 (180,24) + $ sequenceChain $ map arrowGraphic tips where - chn_alg = tableDown 18 (180,24) start = P2 0 480 @@ -89,13 +90,17 @@ -- Note - /null/ chain action needs a better type synonym name. -- -makeArrowDrawing :: (String, ArrowTip) -> Chain Double (UNil Double) -makeArrowDrawing (name, utip) = cnext (aconn `mappend` lbl) +arrowGraphic :: (String, ArrowTip) -> LocGraphic Double +arrowGraphic (name, utip) = aconn `mappend` lbl where aconn = ignoreAns $ promoteLoc $ \pt -> - connect pt (displace (hvec 60) pt) (uniformArrow utip connline) + connect (uniformArrow utip connline) pt (displace (hvec 60) pt) lbl = ignoreAns $ promoteLoc $ \pt -> - textline name WW `at` (displace (hvec 66) pt) + textline WW name `at` (displace (hvec 66) pt) +-- Cf. Parsec\'s Token module... + +connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u +connline = C.connline default_connector_props diff --git a/demo/Automata.hs b/demo/Automata.hs --- a/demo/Automata.hs +++ b/demo/Automata.hs @@ -4,8 +4,9 @@ module Automata where import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Extras.Loop -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -48,13 +49,13 @@ 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) + draw $ label_midway_of SE (textline `flip` "0") $ straightconn q0 q1 + draw $ label_midway_of SS (textline `flip` "0") $ arrloop (center q1) (north q1) + draw $ label_midway_of SW (textline `flip` "1") $ straightconn q1 q3 + draw $ label_midway_of NE (textline `flip` "1") $ straightconn q0 q2 + draw $ label_midway_of NW (textline `flip` "0") $ straightconn q2 q3 + draw $ label_midway_of NN (textline `flip` "1") $ arrloop (center q2) (south q2) + draw $ label_atstart_of EE (textline `flip` "start") $ astraightconn s0 (west q0) return () @@ -68,13 +69,13 @@ state :: String -> DLocImage DCircle state ss = localize (set_font times_italic) $ - label_center_of (textline ss) $ strokedShape $ circle 20 + label_center_of (textline `flip` ss) $ strokedShape $ circle 20 stopstate :: String -> DLocImage DCircle stopstate ss = localize (set_font times_italic) $ - label_center_of (textline ss) $ dblStrokedShape $ circle 20 + label_center_of (textline `flip` ss) $ dblStrokedShape $ circle 20 @@ -86,12 +87,12 @@ => a -> b -> Image u (AbsPath u) straightconn a b = let (p0,p1) = radialConnectorPoints a b - in connect p0 p1 (rightArrow tri45 connline) + 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 p0 p1 (rightArrow tri45 connline) +astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1 -- Note - there is a problem with @rightArrow@ as @loop@ @@ -107,6 +108,11 @@ zradius = vlength v1 zincl = vdirection v1 + +-- Cf. Parsec\'s Token module... + +connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u +connline = C.connline default_connector_props diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -14,7 +14,7 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Extras.Clip -import Wumpus.Drawing.Paths.Relative +import Wumpus.Drawing.Paths import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -44,20 +44,23 @@ clip_pic :: CtxPicture clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do - drawl (P2 0 320) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path01)) + drawl (P2 0 320) $ runPathSpec_ CFILL path01 drawl (P2 112 320) $ localize (fill_colour powder_blue) $ - (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path02)) - drawl (P2 384 416) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path03)) - drawl (P2 328 512) $ (drawClosedPath FILL =<< liftLocQuery (extrPathSpec path04)) + runPathSpec_ CFILL path02 + drawl (P2 384 416) $ runPathSpec_ CFILL path03 + drawl (P2 328 512) $ runPathSpec_ CFILL path04 drawl (P2 0 0) $ clip1 drawl (P2 112 0) $ clip2 drawl (P2 384 96) $ clip3 drawl (P2 328 192) $ clip4 +-- PathSpec is overkill here... +-- extrPathSpec :: InterpretUnit u - => PathSpec u a -> LocQuery u (RelPath u) -extrPathSpec spec = fmap post $ stripGenPathSpec spec () (PATH_CLOSED STROKE) + => PathSpec u a -> LocQuery u (AbsPath u) +extrPathSpec spec = qpromoteLoc $ \pt -> + fmap post $ qapplyLoc (stripGenPathSpec () CSTROKE spec) pt where post (_,_,c) = c @@ -65,8 +68,8 @@ background rgb = promoteLoc $ \_ -> ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 where - ihh = runChain (mapM cnext $ replicate 112 iheartHaskell) - (tableDown 18 (86,16)) + ihh = runTableColumnwise 18 (86,16) $ mapM chain1 $ replicate 112 iheartHaskell + -- | This is one for Wumpus-Basic - the set of combinators to -- shift between Images and Queries needs sorting out @@ -75,12 +78,11 @@ zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a zapLocQ ma = promoteLoc $ \pt -> askDC >>= \ctx -> - let a = runLocQuery ma ctx pt - in return a + let a = runLocQuery ctx pt ma in return a clip1 :: LocGraphic Double clip1 = zapLocQ (extrPathSpec path01) >>= \a -> - ignoreAns $ locClip a (background black) + locClip a (background black) clip2 :: LocGraphic Double clip2 = zapLocQ (extrPathSpec path02) >>= \a -> @@ -108,14 +110,14 @@ -- zeroPt path01 :: UPathSpec Double -path01 = do +path01 = do hpenline 80 penline (vec 112 160) penline (vec (-112) 160) hpenline (-80) penline (vec 112 (-160)) penline (vec (-112) (-160)) - ureturn + ureturn -- (P2 112 0) diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -43,9 +43,9 @@ makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () -tableGraphic row_count xs = draw $ (runChain (mapM cnext gs) chn) `at` pt +tableGraphic row_count xs = draw $ (runChain chn (mapM chain1 gs)) `at` pt where - chn = tableDown row_count (152,11) + chn = tableColumnwiseScm row_count (152,11) pt = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt gs = map (uncurry colourSample) xs @@ -53,7 +53,7 @@ colourSample :: String -> RGBi -> LocGraphic Double colourSample name rgb = localize (fill_colour rgb) $ promoteLoc $ \pt -> - mappend (blRectangle FILL_STROKE 15 10 `at` pt) + mappend (blRectangle DRAW_FILL_STROKE 15 10 `at` pt) (dcTextlabel name `at` displace (vec 20 2) pt) diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -4,6 +4,7 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -34,39 +35,44 @@ makeCtx = set_font helvetica . metricsContext 11 conn_pic :: CtxPicture -conn_pic = drawTracing $ localize (dest_arm_len (0.75::Em)) - $ tableGraphic conntable +conn_pic = drawTracing $ tableGraphic conntable -conntable :: [(String, Connector Double)] + +conntable :: [(String, ConnectorPathQuery Double)] conntable = - [ ("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) + [ ("connline", C.connline props) + , ("connarc", C.connarc props) + , ("connhdiagh", C.connhdiagh props) + , ("connvdiagv", C.connvdiagv props) + , ("conndiagh", C.conndiagh props) + , ("conndiagv", C.conndiagv props) + , ("connhdiag", C.connhdiag props) + , ("connvdiag", C.connvdiag props) + , ("connabar", C.connabar props) + , ("connbbar", C.connbbar props) + , ("connaright", C.connaright props) + , ("connbright", C.connbright props) + , ("connhrr", C.connhrr props) + , ("connrrh", C.connrrh props) + , ("connvrr", C.connvrr props) + , ("connrrv", C.connrrv props) + , ("connaloop", C.connaloop props) + , ("connbloop", C.connbloop props) + , ("connhbezier", C.connhbezier props) + , ("connvbezier", C.connvbezier props) ] + where + props = default_connector_props { conn_dst_arm = 2 + , conn_src_space = 0.5 + , conn_dst_space = 0.5 } -tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double () + +tableGraphic :: [(String, ConnectorPathQuery Double)] -> TraceDrawing Double () tableGraphic conns = - draw $ runChain (mapM (cnext . makeConnDrawing) conns) chn_alg `at` start + drawl start $ ignoreAns $ runTableColumnwise 8 (180,64) + $ mapM (chain1 . makeConnDrawing) conns where - chn_alg = tableDown 8 (180,64) - start = P2 0 520 + start = P2 0 520 std_ctx :: DrawingContext @@ -74,15 +80,15 @@ -makeConnDrawing :: (String, Connector Double) -> DLocGraphic +makeConnDrawing :: (String, ConnectorPathQuery Double) -> DLocGraphic makeConnDrawing (ss,conn) = promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0) where fn p0 p1 = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1] - disk pt = localize (fill_colour red) $ dcDisk FILL 2 `at` pt - dcon p0 p1 = ignoreAns $ connect p0 p1 (uniformArrow curveTip conn) + disk pt = localize (fill_colour red) $ dcDisk DRAW_FILL 2 `at` pt + dcon p0 p1 = ignoreAns $ connect (uniformArrow curveTip conn) p0 p1 - lbl pt = ignoreAns $ textline ss WW `at` (displace (hvec 10) pt) + lbl pt = ignoreAns $ textline WW ss `at` (displace (hvec 10) pt) diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -4,7 +4,7 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Dots.AnchorDots -import Wumpus.Drawing.Paths.Relative +import Wumpus.Drawing.Paths import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -38,6 +38,9 @@ dot_pic = drawTracing $ tableGraphic dottable +-- Note - dots should probably have lower_case_with_underscore +-- names. + dottable :: [(String, DotLocImage Double)] dottable = [ ("smallDisk", smallDisk) @@ -45,8 +48,8 @@ , ("smallCirc", smallCirc) , ("largeCirc", largeCirc) , ("dotNone", dotNone) - , ("dotHLine", dotHLine) - , ("dotVLine", dotVLine) + , ("dotHBar", dotHBar) + , ("dotVBar", dotVBar) , ("dotX", dotX) , ("dotPlus", dotPlus) , ("dotCross", dotCross) @@ -69,10 +72,10 @@ tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = - draw $ runChain_ (mapM (cnext . makeDotDrawing) imgs) chn_alg `at` pt + drawl pt $ runTableColumnwise row_count (180,36) + $ mapM (chain1 . makeDotDrawing) imgs where row_count = 18 - chn_alg = tableDown row_count (180,36) pt = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt @@ -82,17 +85,17 @@ makeDotDrawing (name,df) = drawing `mappend` moveStart (vec 86 14) lbl where - drawing = runPathSpec_ path_spec PATH_OPEN + drawing = runPathSpec_ OSTROKE path_spec - path_spec = localize path_style $ - insertl dot >> - mapM (\v -> penline v >> insertl dot) steps >> - ureturn + path_spec = updatePen path_style >> + insertl dot >> + mapM (\v -> penline v >> insertl dot) steps >> + ureturn lbl = ignoreAns $ promoteLoc $ \pt -> - textline name WW `at` pt + textline WW name `at` pt steps = [V2 25 15, V2 25 (-15), V2 25 15] dot = ignoreAns df diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -5,7 +5,8 @@ module FeatureModel where import Wumpus.Drawing.Connectors -import Wumpus.Drawing.Paths.Absolute +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -74,7 +75,7 @@ => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do a <- drawi $ (strokedShape $ rectangle w 20) `at` pt - drawl (center a) $ textline ss CENTER + drawl (center a) $ textline CENTER ss return a box :: (Real u, Floating u, InterpretUnit u, Tolerance u) @@ -92,7 +93,7 @@ lw <- getLineWidth let p0 = south b0 let p1 = projectAnchor north (realToFrac lw) b1 - drawi $ connect p0 p1 (rightArrow arrh connline) + drawi $ connect (rightArrow arrh connline) p0 p1 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` @@ -112,3 +113,9 @@ coptional_ :: ( Real u, Floating u, InterpretUnit u ) => Box u -> Box u -> TraceDrawing u () coptional_ p0 p1 = connWith odiskTip p0 p1 >> return () + + +-- Cf. Parsec\'s Token module... + +connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u +connline = C.connline default_connector_props diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -55,15 +55,18 @@ positions :: [Int] positions = [0, 12, 27, 49, 78, 122] --- Note - this chain might be worth putting in a library... +-- Note - this chain has grown a bit crufty as the implementation +-- of chains has changed... +-- pointChain :: (Int -> DLocGraphic) -> DLocGraphic -pointChain fn = runChain_ (mapM (cnext . fn) point_sizes) chn_alg +pointChain fn = runChain_ chn_alg $ mapM (chain1 . fn) point_sizes where chn_alg = ChainScheme start step start = \pt -> (pt,point_sizes) - step _ (pt,[]) = (pt, (displace (vvec 50) pt, [])) - step _ (pt,(y:ys)) = (pt, (displace (vvec $ fromIntegral $ 2 + y) pt, ys)) + step _ (pt,[]) = let pnext = displace (vvec 50) pt in (pnext, (pnext, [])) + step _ (pt,(y:ys)) = let pnext = displace (vvec $ fromIntegral $ 2 + y) pt + in (pnext, (pnext, ys)) fontGraphic :: RGBi -> FontDef -> DLocGraphic fontGraphic rgb ft = ignoreAns $ pointChain mkGF @@ -77,9 +80,9 @@ fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $ - draw $ runChain_ (mapM (cnext . uncurry fontGraphic) xs) chn_alg `at` start + drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs where - chn_alg = tableDown 4 (1,180) + chn_alg = tableColumnwiseScm 4 (2,180) start = P2 0 (4*180) diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs --- a/demo/LeftRightText.hs +++ b/demo/LeftRightText.hs @@ -80,59 +80,59 @@ -- single line -- ne_oneline :: BoundedLocGraphic Double -ne_oneline = textline "north east" NE +ne_oneline = textline NE "north east" -- single line -- se_oneline :: BoundedLocGraphic Double -se_oneline = textline "south east" SE +se_oneline = textline SE "south east" -- single line -- ss_oneline :: BoundedLocGraphic Double -ss_oneline = textline "south" SS +ss_oneline = textline SS "south" -- single line -- sw_oneline :: BoundedLocGraphic Double -sw_oneline = textline "south west" SW +sw_oneline = textline SW "south west" -- single line rot -- ssr_single :: BoundedLocGraphic Double -ssr_single = rtextline (0.25*pi) "south rot45" SS +ssr_single = rtextline (0.25*pi) SS "south rot45" -- single line rot -- swr_single :: BoundedLocGraphic Double -swr_single = rtextline (0.25*pi) "south west rot45" SW +swr_single = rtextline (0.25*pi) SW "south west rot45" -- single line rot -- ner_single :: BoundedLocGraphic Double -ner_single = rtextline (0.25*pi) "north east rot45" NE +ner_single = rtextline (0.25*pi) NE "north east rot45" cc_oneline :: BoundedLocGraphic Double -cc_oneline = textline "Center-center..." CENTER +cc_oneline = textline CENTER "Center-center..." blank_text :: BoundedLocGraphic Double -blank_text = textline "" BLC +blank_text = textline BLC "" left_text :: BoundedLocGraphic Double -left_text = multilineText VALIGN_LEFT dummy_text CENTER +left_text = multilineText VALIGN_LEFT CENTER dummy_text right_text :: BoundedLocGraphic Double -right_text = multilineText VALIGN_RIGHT dummy_text CENTER +right_text = multilineText VALIGN_RIGHT CENTER dummy_text center_text :: BoundedLocGraphic Double -center_text = multilineText VALIGN_CENTER dummy_text CENTER +center_text = multilineText VALIGN_CENTER CENTER dummy_text 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 @@ -9,6 +9,7 @@ import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Drawing.Shapes import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs @@ -104,35 +105,56 @@ connectorC :: ConnectorGraphic Double -connectorC = - ignoreAns $ localize (uniform_arm_len (30::Double)) - $ rightArrow tri45 connbbar +connectorC = ignoreAns $ rightArrow tri45 connbbar connectorC' :: ConnectorGraphic Double -connectorC' = - ignoreAns $ localize (uniform_arm_len (30::Double)) - $ rightArrow tri45 connabar +connectorC' = ignoreAns $ rightArrow tri45 connabar connectorD :: ConnectorGraphic Double connectorD = ignoreAns $ rightArrow tri45 connarc connectorD' :: ConnectorGraphic Double -connectorD' = - ignoreAns $ localize (conn_arc_angle $ negate $ pi / 12) - $ rightArrow tri45 connarc +connectorD' = ignoreAns $ rightArrow tri45 connarc lblParensParens :: DLocGraphic lblParensParens = - ignoreAns $ localize (set_font helvetica) $ textline "(),()" CENTER + ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),()" lblParensParensParens :: DLocGraphic lblParensParensParens = - ignoreAns $ localize (set_font helvetica) $ textline "(),(),()" CENTER + ignoreAns $ localize (set_font helvetica) $ textline CENTER "(),(),()" lblBold :: String -> DLocGraphic lblBold ss = - ignoreAns $ localize (set_font helvetica_bold) $ textline ss CENTER + ignoreAns $ localize (set_font helvetica_bold) $ textline CENTER ss + + +-- Cf. Parsec\'s Token module... + +conn_props :: ConnectorProps +conn_props = (default_connector_props { conn_src_arm = 2 + , conn_dst_arm = 2 + , conn_arc_ang = negate $ pi / 12 }) + +connline :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathQuery u +connline = C.connline conn_props + + +connabar :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathQuery u +connabar = C.connabar conn_props + + +connbbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathQuery u +connbbar = C.connbbar conn_props + + +connarc :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathQuery u +connarc = C.connarc conn_props diff --git a/demo/SampleShapes.hs b/demo/SampleShapes.hs --- a/demo/SampleShapes.hs +++ b/demo/SampleShapes.hs @@ -156,7 +156,7 @@ where shape = strokedShape $ setDecoration textF sh textF = promoteLocTheta $ \pt _ -> - ignoreAns (multilineText VALIGN_CENTER name CENTER) `at` pt + ignoreAns (multilineText VALIGN_CENTER CENTER name) `at` pt deg10 = d2r (10::Double) deg110 = d2r (110::Double) @@ -177,7 +177,7 @@ where (rpos,fn) = go cpos msg = ignoreAns $ moveStart (fn 10) $ - multilineText VALIGN_CENTER ss rpos + multilineText VALIGN_CENTER rpos ss go NORTH = (SS, go_north) go NORTH_EAST = (SW, go_north_east) diff --git a/demo/SingleChar.hs b/demo/SingleChar.hs --- a/demo/SingleChar.hs +++ b/demo/SingleChar.hs @@ -61,7 +61,7 @@ draw $ redPlus `at` P2 200 0 where - fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox obj addr + fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox addr obj redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u diff --git a/demo/SingleLine.hs b/demo/SingleLine.hs --- a/demo/SingleLine.hs +++ b/demo/SingleLine.hs @@ -53,9 +53,9 @@ testDraw :: RectAddress -> LocGraphic Double -testDraw rpos = dcDisk FILL 2 `mappend` (ignoreAns ans) +testDraw rpos = dcDisk DRAW_FILL 2 `mappend` (ignoreAns ans) where - ans = textline "Qwerty" rpos + ans = textline rpos "Qwerty" diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -2,220 +2,76 @@ module Symbols where +import Wumpus.Drawing.Basis.DrawingPrimitives +import Wumpus.Drawing.Basis.Symbols +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Text.DirectionZero import Wumpus.Drawing.Text.StandardFontDefs import Wumpus.Basic.Kernel -- package: wumpus-basic -import Wumpus.Core -- package: wumpus-core +import Wumpus.Basic.System.FontLoader -import Prelude hiding ( pi, product ) +import Wumpus.Core -- package: wumpus-core import System.Directory + main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_ctx symbols +main = simpleFontLoader main1 >> return () + +main1 :: FontLoader -> IO () +main1 loader = do + createDirectoryIfMissing True "./out/" + base_metrics <- loader [ Left times_roman ] + printLoadErrors base_metrics + let pic1 = runCtxPictureU (makeCtx base_metrics) symb_pic writeEPS "./out/symbols.eps" pic1 - writeSVG "./out/symbols.svg" pic1 + writeSVG "./out/symbols.svg" pic1 + +makeCtx :: FontLoadResult -> DrawingContext +makeCtx = set_font times_roman . metricsContext 14 -std_ctx :: DrawingContext -std_ctx = set_font times_roman $ standardContext 12 +symb_pic :: CtxPicture +symb_pic = drawTracing $ tableGraphic symbtable --- Because the font changes, we draw the all the symbols in one --- run and all the labels in a second run. This helps Wumpus-Core --- generate better PostScript as there are less changes to the --- /graphics state/. --- -symbols :: CtxPicture -symbols = udrawTracing (0::Double) $ do - localize (set_font symbol) $ fontDelta $ draw $ - runChain_ (mapM sdraw all_letters) chn_alg `at` start - fontDelta $ draw $ runChain (mapM ldraw all_letters) chn_alg `at` start - where - chn_alg = tableDown 30 (100,20) - start = P2 0 (30*20) - sdraw (s,_) = cnext $ dcTextlabel s - ldraw (_,name) = cnext $ moveStart (hvec 16) (dcTextlabel name) +symbtable :: [(String, LocGraphic Double)] +symbtable = + [ ("ocircle", ocircle 8) + , ("ochar", ochar $ CharLiteral 'a') + , ("ochar - bad", ochar $ CharLiteral 'g') + , ("ocharDescender", ocharDescender $ CharLiteral 'g') + , ("ocharUpright", ocharUpright $ CharLiteral '8') + , ("ocharUpright - bad", ocharUpright $ CharLiteral 'a') + , ("ocurrency", ocurrency 8) + , ("left_slice", left_slice 14) + , ("right_slice", right_slice 14) + , ("left_triangle", left_triangle 14) + , ("right_triangle", right_triangle 14) + , ("hbar", hbar 14) + , ("vbar", vbar 14) + , ("dbl_hbar", dbl_hbar 14) + , ("dbl_vbar", dbl_vbar 14) + ] -all_letters :: [(String, String)] -all_letters = - [ ("Α", "Alpha") - , ("Β", "Beta") - , ("Χ", "Chi") - , ("Δ", "Delta") - , ("Ε", "Epsilon") - , ("Η", "Eta") - , ("&Euro;", "Euro") - , ("Γ", "Gamma") - , ("&Ifraktur;", "Ifraktur") - , ("Ι", "Iota") - , ("Κ", "Kappa") - , ("Λ", "Lambda") - , ("Μ", "Mu") - , ("Ν", "Nu") - , ("Ω", "Omega") - , ("Ο", "Omicron") - , ("Φ", "Phi") - , ("Π", "Pi") - , ("Ψ", "Psi") - , ("&Rfraktur;", "Rfraktur") - , ("Ρ", "Rho") - , ("Σ", "Sigma") - , ("Τ", "Tau") - , ("Θ", "Theta") - , ("Υ", "Upsilon") - , ("&Upsilon1;", "Upsilon1") - , ("Ξ", "Xi") - , ("Ζ", "Zeta") - , ("ℵ", "aleph") - , ("α", "alpha") - , ("&ersand;", "ampersand") - , ("∠", "angle") - , ("&angleleft;", "angleleft") - , ("&angleright;", "angleright") - , ("&approxequal;", "approxequal") +tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double () +tableGraphic symbs = + drawl start $ ignoreAns $ runTableColumnwise 8 (180,24) + $ mapM (chain1 . makeSymbDrawing) symbs + where + start = P2 0 520 - -- - , ("&arrowboth;", "arrowboth") - , ("&arrowdblboth;", "arrowdblboth") - , ("&arrowdbldown;", "arrowdbldown") - , ("&arrowdblleft;", "arrowdblleft") - , ("&arrowdblright;", "arrowdblright") - , ("&arrowdblup;", "arrowdblup") - , ("&arrowdown;", "arrowdown") - , ("&arrowleft;", "arrowleft") - , ("&arrowright;", "arrowright") - , ("&arrowup;", "arrowup") - , ("&asteriskmath;", "asteriskmath") - , ("&bar;", "bar") - , ("β", "beta") - , ("&braceleft;", "braceleft") - , ("&braceright;", "braceright") - , ("&bracketleft;", "bracketleft") - , ("&bracketright;", "bracketright") - , ("•", "bullet") - , ("&carriagereturn;", "carriagereturn") - , ("χ", "chi") + +std_ctx :: DrawingContext +std_ctx = fill_colour peru $ standardContext 18 - -- - , ("&circlemultiply;", "circlemultiply") - , ("&circleplus;", "circleplus") - , ("&club;", "club") - , (":", "colon") - , (",", "comma") - , ("&congruent;", "congruent") - , ("©rightsans;", "copyrightsans") - , ("©rightserif;", "copyrightserif") - , ("°ree;", "degree") - , ("δ", "delta") - , ("⋄", "diamond") - , ("÷", "divide") - , ("&dotmath;", "dotmath") - , ("&eight;", "eight") - , ("&element;", "element") - , ("&ellipsis;", "ellipsis") - , ("∅", "emptyset") - , ("ε", "epsilon") - , ("&equal;", "equal") - , ("&equivalence;", "equivalence") - , ("η", "eta") - , ("&exclam;", "exclam") - , ("&existential;", "existential") - , ("&five;", "five") - , ("&florin;", "florin") - , ("&four;", "four") - , ("&fraction;", "fraction") - , ("γ", "gamma") - , ("&gradient;", "gradient") - , ("&greater;", "greater") - , ("&greaterequal;", "greaterequal") - , ("&heart;", "heart") - , ("&infinity;", "infinity") - , ("&integral;", "integral") - -- - , ("&intersection;", "intersection") - , ("ι", "iota") - , ("κ", "kappa") - , ("λ", "lambda") - , ("&less;", "less") - , ("&lessequal;", "lessequal") - , ("&logicaland;", "logicaland") - , ("&logicalnot;", "logicalnot") - , ("&logicalor;", "logicalor") - , ("◊", "lozenge") - , ("−", "minus") - , ("&minute;", "minute") - , ("μ", "mu") - , ("&multiply;", "multiply") - , ("&nine;", "nine") - , ("¬element;", "notelement") - , ("¬equal;", "notequal") - , ("¬subset;", "notsubset") - , ("ν", "nu") - , ("&numbersign;", "numbersign") - , ("ω", "omega") - , ("&omega1;", "omega1") - , ("ο", "omicron") - , ("&one;", "one") - , ("&parenleft;", "parenleft") - , ("&parenright;", "parenright") - -- - , ("&partialdiff;", "partialdiff") - , ("&percent;", "percent") - , (".", "period") - , ("&perpendicular;", "perpendicular") - , ("φ", "phi") - , ("&phi1;", "phi1") - , ("π", "pi") - , ("+", "plus") - , ("&plusminus;", "plusminus") - , ("&product;", "product") - , ("&propersubset;", "propersubset") - , ("&propersuperset;", "propersuperset") - , ("&proportional;", "proportional") - , ("ψ", "psi") - , ("&question;", "question") - , ("&radical;", "radical") - , ("&radicalex;", "radicalex") - , ("&reflexsubset;", "reflexsubset") - , ("&reflexsuperset;", "reflexsuperset") - , ("®istersans;", "registersans") - , ("®isterserif;", "registerserif") - , ("ρ", "rho") - - -- - , ("&second;", "second") - , ("&semicolon;", "semicolon") - , ("&seven;", "seven") - , ("σ", "sigma") - , ("&sigma1;", "sigma1") - , ("&similar;", "similar") - , ("&six;", "six") - , ("&slash;", "slash") - , ("&space;", "space") - , ("&spade;", "spade") - , ("&suchthat;", "suchthat") - , ("&summation;", "summation") - , ("τ", "tau") - , ("∴", "therefore") - , ("θ", "theta") - , ("&theta1;", "theta1") - , ("&three;", "three") - , ("&trademarksans;", "trademarksans") - , ("&trademarkserif;", "trademarkserif") - , ("&two;", "two") - , ("&underscore;", "underscore") - , ("&union;", "union") - , ("&universal;", "universal") - , ("υ", "upsilon") - , ("&weierstrass;", "weierstrass") - , ("ξ", "xi") - , ("&zero;", "zero") - , ("ζ", "zeta") - ] +makeSymbDrawing :: (String, LocGraphic Double) -> DLocGraphic +makeSymbDrawing (ss,symb) = symb <> moveStart (hvec 20) lbl + where + lbl = ignoreAns $ textline WW ss + diff --git a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs --- a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +++ b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs @@ -18,6 +18,9 @@ -- -- This module is expected to be imported qualified - other modules -- (e.g. shapes and paths) are likely to export conflicting names. +-- +-- \*\* WARNING \*\* - much of this module is probably obsolete +-- (except wedge). -- -------------------------------------------------------------------------------- @@ -29,8 +32,8 @@ -- * Lines - , hline - , vline + , horizontalLine + , verticalLine , pivotLine , oStraightLines @@ -75,15 +78,16 @@ -------------------------------------------------------------------------------- -- Lines + -- | Draw a vertical line. -- -vline :: InterpretUnit u => u -> LocGraphic u -vline len = locStraightLine $ vvec len +verticalLine :: InterpretUnit u => u -> LocGraphic u +verticalLine len = locStraightLine $ vvec len -- | Draw a horizontal line. -- -hline :: InterpretUnit u => u -> LocGraphic u -hline len = locStraightLine $ hvec len +horizontalLine :: InterpretUnit u => u -> LocGraphic u +horizontalLine len = locStraightLine $ hvec len @@ -105,8 +109,8 @@ -- | Draw an closed path formed from straight line segments. -- -cStraightLines :: InterpretUnit u => DrawStyle -> [Point2 u] -> Graphic u -cStraightLines sty ps = liftQuery (vertexPP ps) >>= dcClosedPath sty +cStraightLines :: InterpretUnit u => DrawMode -> [Point2 u] -> Graphic u +cStraightLines mode ps = liftQuery (vertexPP ps) >>= dcClosedPath mode -------------------------------------------------------------------------------- @@ -116,16 +120,16 @@ -- | Draw a rectangle, start point is bottom left. -- -blRectangle :: InterpretUnit u => DrawStyle -> u -> u -> LocGraphic u +blRectangle :: InterpretUnit u => DrawMode -> u -> u -> LocGraphic u blRectangle = dcRectangle -- | Draw a rectangle, start point is bottom left. -- ctrRectangle :: (Fractional u, InterpretUnit u) - => DrawStyle -> u -> u -> LocGraphic u -ctrRectangle sty w h = - moveStart (vec (-hw) (-hh)) $ dcRectangle sty w h + => DrawMode -> u -> u -> LocGraphic u +ctrRectangle mode w h = + moveStart (vec (-hw) (-hh)) $ dcRectangle mode w h where hw = 0.5 * w hh = 0.5 * h @@ -144,24 +148,18 @@ let ps = bezierArcPoints ang radius inclin pt in liftQuery (curvePP ps) >>= dcOpenPath --- | wedge : radius * apex_angle +-- | wedge : mode * radius * apex_angle -- -wedge :: (Floating u, InterpretUnit u) - => DrawStyle -> u -> Radian -> LocThetaGraphic u -wedge sty radius ang = promoteLocTheta $ \pt inclin -> - let ps = bezierArcPoints ang radius inclin pt - in uconvertCtxF pt >>= \dpt -> - mapM uconvertCtxF ps >>= \dps -> - dcClosedPath sty (build dpt dps) - where - -- Note - this relies on an implicit straight line cycle back - -- to the start point. - -- - build :: DPoint2 -> [DPoint2] -> PrimPath - build pt [] = emptyPrimPath pt - build pt (p1:ps) = let cs = curves ps - in absPrimPath pt (absLineTo p1 : cs) - - curves (a:b:c:ps) = absCurveTo a b c : curves ps - curves _ = [] - +-- Wedge is drawn at the apex. +-- +wedge :: (Real u, Floating u, InterpretUnit u) + => DrawMode -> u -> Radian -> LocThetaGraphic u +wedge mode radius ang = promoteLocTheta $ \pt inclin -> + let half_ang = 0.5 * ang + line_in = catline $ avec (inclin + half_ang) radius + line_out = catline $ avec (inclin - half_ang) (-radius) + w_arc = circularArcCW ang radius (inclin - half_pi) + ct = line_in `mappend` w_arc `mappend` line_out + in supplyLoc pt $ drawCatTrail (closedMode mode) ct + + diff --git a/src/Wumpus/Drawing/Basis/Symbols.hs b/src/Wumpus/Drawing/Basis/Symbols.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/Symbols.hs @@ -0,0 +1,165 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.Symbols +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Symbols - many symbols expected to be re-defined as Dots or +-- character size PosObjects for DocText. +-- +-- \*\* WARNING \*\* - naming conventention is to be determined... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.Symbols + ( + + ocircle + , ochar + , ocharUpright + , ocharDescender + , ocurrency + , left_slice + , right_slice + + , left_triangle + , right_triangle + + , empty_box + + , hbar + , vbar + , dbl_hbar + , dbl_vbar + + ) + where + +import Wumpus.Drawing.Basis.DrawingPrimitives + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +-- import Data.AffineSpace -- package: vector-space + +-- +-- DESIGN NOTE +-- +-- Should names follow the /function scheme/ (camelCase), or the +-- /data scheme/ (underscore_separators). +-- +-- Objects here are functions as they take size param, but they +-- expected to be redefined elsewhere at fixed size and not used +-- in /user code/. +-- +-- Using camelCase here, then under_score in the DocText versions +-- adds double the function signatures to the Haddock docs. +-- + + + +ocircle :: InterpretUnit u => u -> LocGraphic u +ocircle radius = dcDisk DRAW_STROKE radius + +-- | Note this looks horrible for chars with descenders. +-- +ochar :: (Fractional u, InterpretUnit u) + => EscapedChar -> LocGraphic u +ochar esc = char1 <> circ1 + where + char1 = runPosObject CENTER $ posEscChar esc + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h) + +ocharUpright :: (Fractional u, InterpretUnit u) + => EscapedChar -> LocGraphic u +ocharUpright esc = char1 <> circ1 + where + char1 = runPosObject CENTER $ posEscCharUpright esc + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h) + +ocharDescender :: (Fractional u, InterpretUnit u) + => EscapedChar -> LocGraphic u +ocharDescender esc = char1 <> circ1 + where + char1 = fmap abs descender >>= \dy -> + moveStart (go_up dy) $ runPosObject CENTER $ posEscCharUpright esc + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> ocircle (0.85 * h) + + +ocurrency :: (Floating u, InterpretUnit u) + => u -> LocGraphic u +ocurrency ra = ocircle ra <> lne <> lnw <> lsw <> lse + where + ra3 = 0.33 * ra + lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3 + lnw = moveStart (go_north_west ra) $ locStraightLine $ go_north_west ra3 + lsw = moveStart (go_south_west ra) $ locStraightLine $ go_south_west ra3 + lse = moveStart (go_south_east ra) $ locStraightLine $ go_south_east ra3 + +left_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +left_slice radius = moveStart (go_left $ 0.5 * radius) lwedge + where + lwedge = supplyIncline 0 $ wedge DRAW_STROKE radius quarter_pi + + +right_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +right_slice radius = moveStart (go_right $ 0.5 * radius) rwedge + where + rwedge = supplyIncline pi $ wedge DRAW_STROKE radius quarter_pi + +left_triangle :: (Fractional u, InterpretUnit u) + => u -> LocGraphic u +left_triangle w = + drawPlacedTrail CSTROKE $ placeCatTrail (go_left $ 0.5 * w) + $ line_r <> vbase <> line_l + where + hh = 0.40 * w + line_r = catline $ vec w hh + vbase = catline $ go_down $ 2*hh + line_l = catline $ vec (-w) hh + +right_triangle :: (Fractional u, InterpretUnit u) + => u -> LocGraphic u +right_triangle w = + drawPlacedTrail CSTROKE $ placeCatTrail (go_right $ 0.5 * w) + $ line_l <> vbase <> line_r + where + hh = 0.40 * w + line_l = catline $ vec (-w) hh + vbase = catline $ go_down $ 2*hh + line_r = catline $ vec w hh + + +empty_box :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +empty_box w = drawPlacedTrail CSTROKE $ rectangleTrail w w + +hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +hbar u = + drawPlacedTrail OSTROKE $ placeCatTrail (go_left $ 0.5 * u) $ trail_right u + +vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +vbar u = + drawPlacedTrail OSTROKE $ placeCatTrail (go_down $ 0.5 * u) $ trail_up u + +dbl_hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +dbl_hbar u = line1 <> line2 + where + line1 = moveStart (go_up $ 0.1 * u) $ hbar u + line2 = moveStart (go_down $ 0.1 * u) $ hbar u + + +dbl_vbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +dbl_vbar u = line1 <> line2 + where + line1 = moveStart (go_left $ 0.1 * u) $ vbar u + line2 = moveStart (go_right $ 0.1 * u) $ vbar u diff --git a/src/Wumpus/Drawing/Connectors.hs b/src/Wumpus/Drawing/Connectors.hs --- a/src/Wumpus/Drawing/Connectors.hs +++ b/src/Wumpus/Drawing/Connectors.hs @@ -11,6 +11,8 @@ -- Portability : GHC -- -- Shim module for Connectors. +-- +-- \*\* WARNING \*\* - this is due to change... -- -------------------------------------------------------------------------------- @@ -19,11 +21,11 @@ module Wumpus.Drawing.Connectors.Arrowheads , module Wumpus.Drawing.Connectors.Base , module Wumpus.Drawing.Connectors.BoxConnectors - , module Wumpus.Drawing.Connectors.ConnectorPaths + , module Wumpus.Drawing.Connectors.ConnectorProps ) 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.ConnectorProps diff --git a/src/Wumpus/Drawing/Connectors/Arrowheads.hs b/src/Wumpus/Drawing/Connectors/Arrowheads.hs --- a/src/Wumpus/Drawing/Connectors/Arrowheads.hs +++ b/src/Wumpus/Drawing/Connectors/Arrowheads.hs @@ -61,7 +61,6 @@ import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Connectors.Base -import Wumpus.Drawing.Paths.Absolute import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -86,13 +85,13 @@ filledTipPath :: PointGen -> LocThetaGraphic En filledTipPath gen = localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta -> - cStraightLines FILL $ map (pt .+^) $ gen theta + cStraightLines DRAW_FILL $ map (pt .+^) $ gen theta closedTipPath :: PointGen -> LocThetaGraphic En closedTipPath gen = localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> - cStraightLines STROKE $ map (pt .+^) $ gen theta + cStraightLines DRAW_STROKE $ map (pt .+^) $ gen theta openTipPath :: PointGen -> LocThetaGraphic En @@ -145,18 +144,8 @@ -ang90 :: Radian -ang90 = pi / 2 -ang60 :: Radian -ang60 = pi / 3 -ang45 :: Radian -ang45 = pi / 4 - - - - filledTri :: Radian -> ArrowTip filledTri ang = ArrowTip @@ -333,7 +322,7 @@ body :: Radian -> LocGraphic En body theta = let v1 = avec theta (-0.5) in localize fill_use_stroke_colour $ - moveStart v1 (dcDisk FILL 0.5) + moveStart v1 (dcDisk DRAW_FILL 0.5) odiskTip :: ArrowTip @@ -347,7 +336,7 @@ body :: Radian -> LocGraphic En body theta = let v1 = avec theta (-0.5) in localize solid_stroke_tip $ - moveStart v1 (dcDisk STROKE 0.5) + moveStart v1 (dcDisk DRAW_STROKE 0.5) -- | squareSpec: @@ -437,18 +426,31 @@ } -curveTipPath :: Point2 En -> Radian -> AbsPath En -curveTipPath pt theta = - curve1 a b c pt `append` curve1 pt z y x +curveTipTrail :: Radian -> PlacedTrail En +curveTipTrail theta = + placeCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2 where - ow = avec theta (-1) - a = pt .+^ ow ^+^ avec (theta + ang90) 0.5 - x = pt .+^ ow ^+^ avec (theta - ang90) 0.5 + dv = orthoVec (-1.0) 0.75 theta -- back and up + v1 = orthoVec 1.0 (-0.75) theta -- fwd and down + v2 = orthoVec (-1.0) (-0.75) theta -- back and down - (c,b) = trapezoidFromBasePoints 0.125 0.5 pt a - (y,z) = trapezoidFromBasePoints 0.125 0.5 x pt +vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u +vectrapCW v1 = trapcurveCW w h ang45 ang + where + w = vlength v1 + h = w / 4 + ang = vdirection v1 + +vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u +vectrapCCW v1 = trapcurveCCW w h quarter_pi ang + where + w = vlength v1 + h = w / 4 + ang = vdirection v1 + + curveTip :: ArrowTip curveTip = ArrowTip @@ -459,20 +461,18 @@ where body = promoteLocTheta $ \pt theta -> localize (join_bevel . solid_stroke_tip) $ - liftQuery (toPrimPath $ curveTipPath pt theta) >>= dcOpenPath + supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipTrail theta -curveTipRevPath :: Point2 En -> Radian -> AbsPath En -curveTipRevPath pt theta = - curve1 a b c p2 `append` curve1 p2 z y x +curveTipRevTrail :: Radian -> PlacedTrail En +curveTipRevTrail theta = + placeCatTrail dv $ vectrapCW v1 <> vectrapCW v2 where - p2 = pt .+^ avec theta (-1) - a = pt .+^ avec (theta + ang90) 0.5 - x = pt .+^ avec (theta - ang90) 0.5 + dv = orthoVec 0.0 0.75 theta -- just up + v1 = orthoVec (-1.0) (-0.75) theta -- back and down + v2 = orthoVec 1.0 (-0.75) theta -- fwd and down - (b,c) = trapezoidFromBasePoints 0.125 0.5 a p2 - (z,y) = trapezoidFromBasePoints 0.125 0.5 p2 x revcurveTip :: ArrowTip @@ -485,29 +485,6 @@ where body = promoteLocTheta $ \pt theta -> localize (join_bevel . solid_stroke_tip) $ - liftQuery (toPrimPath $ curveTipRevPath pt theta) >>= dcOpenPath + supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipRevTrail theta - --- | '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 = dispParallel (0.5 * base_len) theta p1 - ubase_mid = dispPerpendicular u theta base_mid - cp1 = dispParallel (-half_ulen) theta ubase_mid - cp2 = dispParallel half_ulen theta ubase_mid diff --git a/src/Wumpus/Drawing/Connectors/Base.hs b/src/Wumpus/Drawing/Connectors/Base.hs --- a/src/Wumpus/Drawing/Connectors/Base.hs +++ b/src/Wumpus/Drawing/Connectors/Base.hs @@ -17,8 +17,9 @@ module Wumpus.Drawing.Connectors.Base ( - Connector + ConnectorPathQuery + , ArrowTip(..) , ArrowConnector @@ -29,25 +30,23 @@ , rightArrowPath - - , buildConn - ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space - import Data.Monoid + + + -- | The type of Connectors - a query from start and end point to -- a Path. -- -type Connector u = ConnectorQuery u (AbsPath u) +type ConnectorPathQuery u = ConnectorQuery u (AbsPath u) -- | Arrowhead /algorithm/ - the components of an arrowhead. -- @@ -67,7 +66,8 @@ -runArrowTip :: InterpretUnit u => ArrowTip -> Query u (u, u, LocThetaGraphic u) +runArrowTip :: InterpretUnit u + => ArrowTip -> Query u (u, u, LocThetaGraphic u) runArrowTip (ArrowTip df len deco) = getLineWidth >>= \lw -> uconvertCtx1 (df lw) >>= \uretd -> @@ -78,7 +78,7 @@ -- | Connector with an arrow tip at the end point (i.e right). -- rightArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> Connector u -> ArrowConnector u + => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u rightArrow alg conn = promoteConn $ \p0 p1 -> applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> rightArrowPath alg full_path @@ -88,7 +88,7 @@ -- | Connector with an arrow tip at the start point (i.e left). -- leftArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> Connector u -> ArrowConnector u + => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u leftArrow alg conn = promoteConn $ \p0 p1 -> applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> leftArrowPath alg full_path @@ -98,7 +98,7 @@ -- end points. -- leftRightArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> ArrowTip -> Connector u -> ArrowConnector u + => ArrowTip -> ArrowTip -> ConnectorPathQuery u -> ArrowConnector u leftRightArrow algl algr conn = promoteConn $ \p0 p1 -> applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> leftRightArrowPath algl algr full_path @@ -109,7 +109,7 @@ -- end points. -- uniformArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> Connector u -> ArrowConnector u + => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u uniformArrow alg conn = promoteConn $ \p0 p1 -> applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> leftRightArrowPath alg alg full_path @@ -134,7 +134,7 @@ mid_ang = tipDirectionL len full_path tip = applyLocTheta deco (tipL full_path) mid_ang in replaceAns full_path $ - sdecorate tip $ drawOpenPath short_path + sdecorate tip $ drawPath OSTROKE short_path @@ -152,7 +152,7 @@ mid_ang = tipDirectionR len full_path tip = applyLocTheta deco (tipR full_path) mid_ang in replaceAns full_path $ - sdecorate tip $ drawOpenPath short_path + sdecorate tip $ drawPath OSTROKE short_path @@ -173,7 +173,7 @@ tipl = applyLocTheta decol (tipL full_path) mid_angl tipr = applyLocTheta decor (tipR full_path) mid_angr in replaceAns full_path $ - sdecorate (tipl `mappend` tipr) $ drawOpenPath short_path + sdecorate (tipl `mappend` tipr) $ drawPath OSTROKE short_path @@ -191,28 +191,3 @@ - --- | 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 @promoteConn@ for functions --- building connectors. --- -buildConn :: (Real u, Floating u, InterpretUnit u) - => (Point2 u -> Point2 u -> Image u a) - -> ConnectorImage u a -buildConn fn = promoteConn $ \p0 p1 -> - connectorSrcSpace >>= \sep0 -> - connectorDstSpace >>= \sep1 -> - connectorSrcOffset >>= \off0 -> - connectorDstOffset >>= \off1 -> - let ang = vdirection $ pvec p0 p1 - in fn (dispPerpendicular off0 ang $ p0 .+^ avec ang sep0) - (dispPerpendicular off1 ang $ p1 .-^ avec ang sep1) - --- --- CAUTION - buildConn projects the spacers along the (straight) --- connector line. This might not be what is wanted for jointed --- connectors. --- diff --git a/src/Wumpus/Drawing/Connectors/BoxConnectors.hs b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs --- a/src/Wumpus/Drawing/Connectors/BoxConnectors.hs +++ b/src/Wumpus/Drawing/Connectors/BoxConnectors.hs @@ -18,16 +18,20 @@ ( ConnectorBox , connbox + , conntube ) where --- import Wumpus.Drawing.Paths.Absolute +-- import Wumpus.Drawing.Connectors.Base +import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core +import Data.Monoid + -- NOTE - boxes (currently) seem to only support stroke otherwise -- they would obliterate what they connect. @@ -53,13 +57,55 @@ -- The rectangle will be inclined to the line. -- connbox :: (Real u, Floating u, InterpretUnit u) - => ConnectorBox u -connbox = promoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> - let ang = vdirection $ pvec p0 p1 - bl = dispOrtho (V2 (-src_arm) (-src_arm)) ang p0 - tl = dispOrtho (V2 (-src_arm) src_arm ) ang p0 - br = dispOrtho (V2 dst_arm (-src_arm)) ang p1 - tr = dispOrtho (V2 dst_arm src_arm ) ang p1 - in liftQuery (vertexPP [ bl, br, tr, tl ]) >>= dcClosedPath STROKE + => ConnectorProps -> ConnectorBox u +connbox props = promoteConn $ \p0 p1 -> + connectorBoxHalfSize props >>= \sz -> + applyLoc (drawPlacedTrail CSTROKE $ cfconnbox sz (pvec p0 p1)) p0 + + +conntube :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps -> ConnectorBox u +conntube props = promoteConn $ \p0 p1 -> + connectorBoxHalfSize props >>= \sz -> + applyLoc (drawPlacedTrail CSTROKE $ cfconntube sz (pvec p0 p1)) p0 + + + +-- Box connectors aren\'t especially coordinate free. + +-- | @v1@ is the /interior/ vector. +-- +cfconnbox :: (Real u, Floating u) => u -> Vec2 u -> PlacedTrail u +cfconnbox du v1 = + placeCatTrail (orthoVec (-du) (-du) ang) $ mconcat $ + [ trail_theta_right w ang + , trail_theta_up h ang + , trail_theta_left w ang + , trail_theta_down h ang + ] + where + ang = vdirection v1 + w = (2*du) + vlength v1 + h = 2*du + + + +-- | @v1@ is the /interior/ vector. +-- +cfconntube :: (Real u, Floating u) => u -> Vec2 u -> PlacedTrail u +cfconntube du v1 = + placeCatTrail (orthoVec 0 (-du) ang) $ mconcat $ + [ trail_theta_right w ang + , semicircleCCW vup + , trail_theta_left w ang + , semicircleCCW vdown + ] + where + ang = vdirection v1 + w = vlength v1 + vup = avec (ang + half_pi) (2*du) + vdown = avec (ang - half_pi) (2*du) + + + + diff --git a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs --- a/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs +++ b/src/Wumpus/Drawing/Connectors/ConnectorPaths.hs @@ -48,7 +48,8 @@ ) where import Wumpus.Drawing.Connectors.Base -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Connectors.ConnectorProps +import Wumpus.Drawing.Paths import Wumpus.Basic.Geometry.Quadrant -- package: wumpus-basic import Wumpus.Basic.Kernel hiding ( promoteConn ) @@ -59,16 +60,155 @@ +type ProjectionQuery u = + ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u) +inlineSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +inlineSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p0 .+^ avec ang sep +inlineDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +inlineDst props p0 p1 = + connectorDstSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p1 .-^ avec ang sep +-- | Like 'inlineSrc' but /expands/ rather than /contracts/. +-- +-- Use for loops. +-- +extlineSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +extlineSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p0 .-^ avec ang sep + + +-- | Like 'inlineDst' but /expands/ rather than /contracts/. +-- +-- Use for loops. +-- +extlineDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +extlineDst props p0 p1 = + connectorDstSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p1 .+^ avec ang sep + +-- | Horizontal \"orthonormal\" version of 'inlineSrc'. +-- +horizontalSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +horizontalSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> return $ p0 .+^ go_right sep + QUAD_SE -> return $ p0 .+^ go_right sep + _ -> return $ p0 .+^ go_left sep + + + +-- | Horizontal \"orthonormal\" version of 'inlineDst'. +-- +horizontalDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +horizontalDst props p0 p1 = + connectorDstSpace props >>= \sep -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> return $ p1 .+^ go_left sep + QUAD_SE -> return $ p1 .+^ go_left sep + _ -> return $ p1 .+^ go_right sep + + + +-- | Vertical \"orthonormal\" version of 'inlineSrc'. +-- +verticalSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +verticalSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> return $ p0 .+^ go_up sep + QUAD_NW -> return $ p0 .+^ go_up sep + _ -> return $ p0 .+^ go_down sep + + +-- | Vertical \"orthonormal\" version of 'inlineDst'. +-- +verticalDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +verticalDst props p0 p1 = + connectorDstSpace props >>= \sep -> + case quadrant $ vdirection $ pvec p0 p1 of + QUAD_NE -> return $ p1 .+^ go_down sep + QUAD_NW -> return $ p1 .+^ go_down sep + _ -> return $ p1 .+^ go_up sep + + +abovePerpSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +abovePerpSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p0 .+^ avec (ang + half_pi) sep + +abovePerpDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +abovePerpDst props p0 p1 = + connectorDstSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p1 .+^ avec (ang + half_pi) sep + + +belowPerpSrc :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +belowPerpSrc props p0 p1 = + connectorSrcSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p0 .+^ avec (ang - half_pi) sep + +belowPerpDst :: (Real u, Floating u, InterpretUnit u) + => ProjectionQuery u +belowPerpDst props p0 p1 = + connectorDstSpace props >>= \sep -> + let ang = vdirection $ pvec p0 p1 + in return $ p1 .+^ avec (ang - half_pi) sep + + + +-- | Promote a function from source and dest points to a connector +-- function accounting for the separator values in the +-- DrawingContext. +-- +buildConn :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps + -> ProjectionQuery u -> ProjectionQuery u + -> (Point2 u -> Point2 u -> Query u (AbsPath u)) + -> ConnectorPathQuery u +buildConn props qsrc qdst fn = qpromoteConn $ \p0 p1 -> + qsrc props p0 p1 >>= \q0 -> qdst props p0 p1 >>= \q1 -> fn q0 q1 + + + + + + + -- | Straight line connector. -- -connline :: (Real u, Floating u, InterpretUnit u) => Connector u -connline = qpromoteConn $ \p0 p1 -> return $ line1 p0 p1 +connline :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps -> ConnectorPathQuery u +connline props = buildConn props inlineSrc inlineDst $ \p0 p1 -> + return $ line1 p0 p1 + -- | Form an arc connector. -- -- If the conn_arc_angle in the Drawing context is positive the arc @@ -80,10 +220,10 @@ -- -- connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) - => Connector u -connarc = qpromoteConn $ \p0 p1 -> - connectorArcAngle >>= \arc_ang -> - let v1 = pvec p0 p1 + => ConnectorProps -> ConnectorPathQuery u +connarc props = buildConn props inlineSrc inlineDst $ \p0 p1 -> + let arc_ang = conn_arc_ang props + v1 = pvec p0 p1 hlen = 0.5 * vlength v1 ang = vdirection v1 cp0 = p0 .+^ avec (ang + arc_ang) hlen @@ -103,10 +243,9 @@ -- diagonal segment joins the arms. -- connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connhdiagh = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connhdiagh props = buildConn props horizontalSrc horizontalDst $ \p0 p1 -> + connectorArms props >>= \(src_arm, 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 @@ -132,10 +271,9 @@ -- diagonal segment joins the arms. -- connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connvdiagv = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connvdiagv props = buildConn props verticalSrc verticalDst $ \p0 p1 -> + connectorArms props >>= \(src_arm, 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 @@ -160,9 +298,9 @@ -- end point -- conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -conndiagh = qpromoteConn $ \p0 p1 -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +conndiagh props = buildConn props inlineSrc horizontalDst $ \p0 p1 -> + connectorArms props >>= \(_,dst_arm) -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> right p0 p1 dst_arm QUAD_SE -> right p0 p1 dst_arm @@ -185,9 +323,9 @@ -- point. -- conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -conndiagv = qpromoteConn $ \p0 p1 -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +conndiagv props = buildConn props inlineSrc verticalDst $ \p0 p1 -> + connectorArms props >>= \(_,dst_arm) -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> up p0 p1 dst_arm QUAD_NW -> up p0 p1 dst_arm @@ -210,9 +348,9 @@ -- end point. -- connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connhdiag = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> + => ConnectorProps -> ConnectorPathQuery u +connhdiag props = buildConn props horizontalSrc inlineDst $ \p0 p1 -> + connectorArms props >>= \(src_arm,_) -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> right p0 p1 src_arm QUAD_SE -> right p0 p1 src_arm @@ -235,9 +373,9 @@ -- end point. -- connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connvdiag = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> + => ConnectorProps -> ConnectorPathQuery u +connvdiag props = buildConn props verticalSrc inlineDst $ \p0 p1 -> + connectorArms props >>= \(src_arm,_) -> case quadrant $ vdirection $ pvec p0 p1 of QUAD_NE -> up p0 p1 src_arm QUAD_NW -> up p0 p1 src_arm @@ -248,6 +386,7 @@ down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ] + -- DESIGN NOTE - should the concept of /above/ and /below/ use -- quadrants? -- @@ -262,10 +401,9 @@ -- The bar is drawn /above/ the points. -- connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connabar = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connabar props = buildConn props abovePerpSrc abovePerpDst $ \p0 p1 -> + connectorArms props >>= \(src_arm,dst_arm) -> let ang = vdirection $ pvec p0 p1 in return $ vertexPath [ p0, dispDirectionTheta UP src_arm ang p0 , dispDirectionTheta UP dst_arm ang p1, p1 ] @@ -280,10 +418,9 @@ -- The bar is drawn /below/ the points. -- connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connbbar = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connbbar props = buildConn props belowPerpSrc belowPerpDst $ \p0 p1 -> + connectorArms props >>= \(src_arm, dst_arm) -> let ang = vdirection $ pvec p0 p1 in return $ vertexPath [ p0, dispDirectionTheta DOWN src_arm ang p0 , dispDirectionTheta DOWN dst_arm ang p1, p1 ] @@ -299,9 +436,10 @@ -- The bar is drawn /above/ the points. -- connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connaright = qpromoteConn $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> - let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1] + => ConnectorProps -> ConnectorPathQuery u +connaright props = + buildConn props verticalSrc horizontalDst $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> + let mid = P2 x0 y1 in return $ vertexPath [p0, mid, p1] -- | Right angle connector. @@ -313,8 +451,9 @@ -- The bar is drawn /below/ the points. -- connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connbright = qpromoteConn $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> + => ConnectorProps -> ConnectorPathQuery u +connbright props = + buildConn props horizontalSrc verticalDst $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> let mid = P2 x1 y0 in return $ vertexPath [p0, mid, p1] @@ -324,7 +463,7 @@ -- | 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 +directional src dst arm = if src < dst then arm else negate arm @@ -340,10 +479,11 @@ -- horizontal distance. -- connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connhrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> - fmap (directional x0 x1) connectorSrcArm >>= \ src_arm -> - let a0 = p0 .+^ hvec src_arm + => ConnectorProps -> ConnectorPathQuery u +connhrr props = + buildConn props horizontalSrc horizontalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> + connectorArms props >>= \(src_arm,_) -> + let a0 = p0 .+^ hvec (directional x0 x1 src_arm) a1 = a0 .+^ vvec (y1 - y0) in return $ vertexPath [p0, a0, a1, p1] @@ -360,12 +500,13 @@ -- horizontal distance. -- connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connrrh = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> - fmap (directional x0 x1) connectorDstArm >>= \ dst_arm -> - let a1 = p1 .-^ hvec dst_arm - a0 = a1 .-^ vvec (y1 - y0) - in return $ vertexPath [p0, a0, a1, p1] + => ConnectorProps -> ConnectorPathQuery u +connrrh props = + buildConn props horizontalSrc horizontalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) -> + connectorArms props >>= \(_,dst_arm) -> + let a1 = p1 .-^ hvec (directional x0 x1 dst_arm) + a0 = a1 .-^ vvec (y1 - y0) + in return $ vertexPath [p0, a0, a1, p1] -- | Connector with two right angles... @@ -377,12 +518,13 @@ -- > o -- connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connvrr = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> - fmap (directional y0 y1) connectorSrcArm >>= \ src_arm -> - let a0 = p0 .+^ vvec src_arm - a1 = a0 .+^ hvec (x1 - x0) - in return $ vertexPath [p0, a0, a1, p1] + => ConnectorProps -> ConnectorPathQuery u +connvrr props = + buildConn props verticalSrc verticalDst $ \p0@(P2 x0 y0) p1@(P2 x1 y1) -> + connectorArms props >>= \(src_arm,_) -> + let a0 = p0 .+^ vvec (directional y0 y1 src_arm) + a1 = a0 .+^ hvec (x1 - x0) + in return $ vertexPath [p0, a0, a1, p1] -- | Connector with two right angles... @@ -394,12 +536,13 @@ -- > o -- connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u -connrrv = qpromoteConn $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> - fmap (directional y0 y1) connectorDstArm >>= \ dst_arm -> - let a1 = p1 .-^ vvec dst_arm - a0 = a1 .-^ hvec (x1 - x0) - in return $ vertexPath [p0, a0, a1, p1] + => ConnectorProps -> ConnectorPathQuery u +connrrv props = + buildConn props verticalSrc verticalDst $ \ p0@(P2 x0 y0) p1@(P2 x1 y1) -> + connectorArms props >>= \(_,dst_arm) -> + let a1 = p1 .-^ vvec (directional y0 y1 dst_arm) + a0 = a1 .-^ hvec (x1 - x0) + in return $ vertexPath [p0, a0, a1, p1] @@ -413,7 +556,7 @@ -- The loop is drawn /above/ the points. -- connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u + => ConnectorProps -> ConnectorPathQuery u connaloop = loopbody id -- | Loop connector. @@ -425,17 +568,16 @@ -- The loop is drawn /above/ the points. -- connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => Connector u + => ConnectorProps -> ConnectorPathQuery 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 = qpromoteConn $ \p0 p1 -> - connectorSrcArm >>= \src_arm -> - connectorDstArm >>= \dst_arm -> - connectorLoopSize >>= \loop_len -> + => (u -> u) -> ConnectorProps -> ConnectorPathQuery u +loopbody fn props = buildConn props extlineSrc extlineDst $ \p0 p1 -> + connectorArms props >>= \(src_arm, dst_arm) -> + connectorLoopSize props >>= \loop_len -> let ang = vdirection $ pvec p0 p1 a0 = dispParallel (negate src_arm) ang p0 a1 = dispPerpendicular (fn loop_len) ang a0 @@ -453,12 +595,14 @@ -- -- Note - the source and dest arm lengths are doubled, generally -- this produces nicer curves. +-- +-- Warning - currently bezier connectors do not draw properly +-- with source or destination spacers. -- connhbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => Connector u -connhbezier = qpromoteConn $ \p0 p1 -> - fmap (2*) connectorSrcArm >>= \src_arm -> - fmap (2*) connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connhbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> + fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,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 @@ -481,11 +625,13 @@ -- Note - the source and dest arm lengths are doubled, generally -- this produces nicer curves. -- +-- Warning - currently bezier connectors do not draw properly +-- with source or destination spacers. +-- connvbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => Connector u -connvbezier = qpromoteConn $ \p0 p1 -> - fmap (2*) connectorSrcArm >>= \src_arm -> - fmap (2*) connectorDstArm >>= \dst_arm -> + => ConnectorProps -> ConnectorPathQuery u +connvbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> + fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,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 diff --git a/src/Wumpus/Drawing/Connectors/ConnectorProps.hs b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs @@ -0,0 +1,148 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Connectors.ConnectorProps +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Connectors... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Connectors.ConnectorProps + ( + + -- * Data types + ConnectorProps(..) + , default_connector_props + + -- * Queries + , connectorSrcSpace + , connectorDstSpace + , connectorArms + , connectorLoopSize + , connectorBoxHalfSize + + ) where + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + + + +-- | ConnectorProps control the drawing of connectors in +-- Wumpus-Drawing. +-- +-- > conn_src_space :: Em +-- > conn_dst_space :: Em +-- +-- Source and destination offsets - these offset the drawing of +-- the connector perpendicular to the direction of line formed +-- between the connector points (a positive offset is drawn above, +-- a negative offset below). The main use of offsets is to draw +-- parallel line connectors. +-- +-- > conn_arc_ang :: Radian +-- +-- Control the /bend/ of an arc connector. +-- +-- > conn_src_arm :: Em +-- > conn_dst_arm :: Em +-- +-- Control the /arm/ length of a jointed connector - arms are the +-- initial segments of the connector. +-- +-- > conn_loop_size :: Em +-- +-- Control the /height/ of a loop connector. +-- +-- > conn_box_halfsize :: Em +-- +-- Control the size of a connector box. Connector boxes are +-- drawn with the exterior lines projected out from the connector +-- points a halfsize above and below. +-- +data ConnectorProps = ConnectorProps + { conn_src_space :: !Em + , conn_dst_space :: !Em + , conn_arc_ang :: !Radian + , conn_src_arm :: !Em + , conn_dst_arm :: !Em + , conn_loop_size :: !Em + , conn_box_halfsize :: !Em + } + deriving (Eq,Show) + + +-- | Default connector properties. +-- +-- > conn_src_sep: 0 +-- > conn_dst_sep: 0 +-- > conn_arc_ang: pi / 12 +-- > conn_src_arm: 1 +-- > conn_dst_arm: 1 +-- > conn_loop_size: 2 +-- > conn_box_half_size: 2 +-- +-- Arc angle is 15deg - quite shallow. +-- +default_connector_props :: ConnectorProps +default_connector_props = + ConnectorProps { conn_src_space = 0 + , conn_dst_space = 0 + , conn_arc_ang = pi / 12 + , conn_src_arm = 1 + , conn_dst_arm = 1 + , conn_loop_size = 2 + , conn_box_halfsize = 1 + } + + + + +-------------------------------------------------------------------------------- +-- Queries + + +connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m u +connectorSrcSpace props = + (\sz -> uconvert1 sz $ conn_src_space props) <$> pointSize + + +connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m u +connectorDstSpace props = + (\sz -> uconvert1 sz $ conn_dst_space props) <$> pointSize + + +connectorArms :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m (u,u) +connectorArms props = + (\sz -> ( uconvert1 sz $ conn_src_arm props + , uconvert1 sz $ conn_dst_arm props) ) + <$> pointSize + + + +connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m u +connectorLoopSize props = + (\sz -> uconvert1 sz $ conn_loop_size props) <$> pointSize + + +connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m u +connectorBoxHalfSize props = + (\sz -> uconvert1 sz $ conn_box_halfsize props) <$> pointSize + 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 @@ -39,8 +39,8 @@ , dotNone , dotChar , dotText - , dotHLine - , dotVLine + , dotHBar + , dotVBar , dotX , dotPlus , dotCross @@ -225,9 +225,9 @@ => MarkSize -> LocQuery u (DotAnchor u) triangleLDO h = qpromoteLoc $ \pt -> uconvertCtx1 h >>= \uh -> - let alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices uh - ps = runPathAlgPoint pt alg - in return $ polygonAnchor ps pt + let alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices uh + in (\ps -> polygonAnchor ps pt) + <$> qapplyLoc (placedTrailPoints alg) pt where fn3 (a,b,c) = [a,b,c] @@ -273,17 +273,17 @@ dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u dotText ss = - fmap bboxRectAnchor $ runPosObjectBBox (posText ss) CENTER + fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss -- Note - maybe Wumpus-Basic should have a @swapAns@ function? -dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u -dotHLine = intoLocImage (circleLDO 0.5) SD.dotHLine +dotHBar :: (Floating u, InterpretUnit u) => DotLocImage u +dotHBar = intoLocImage (circleLDO 0.5) SD.dotHBar -dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u -dotVLine = intoLocImage (circleLDO 0.5) SD.dotVLine +dotVBar :: (Floating u, InterpretUnit u) => DotLocImage u +dotVBar = intoLocImage (circleLDO 0.5) SD.dotVBar dotX :: (Floating u, InterpretUnit u) => DotLocImage u @@ -320,7 +320,8 @@ dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u dotPentagon = intoLocImage (circleLDO 0.5) SD.dotPentagon -dotStar :: (Floating u, InterpretUnit u) => DotLocImage u +dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) + => DotLocImage u dotStar = intoLocImage (circleLDO 0.5) SD.dotStar @@ -346,5 +347,5 @@ => LocQuery u a -> LocImage u z -> LocImage u a intoLocImage ma gf = promoteLoc $ \pt -> askDC >>= \ctx -> - let ans = runLocQuery ma ctx pt + let ans = runLocQuery ctx pt ma in replaceAns ans $ applyLoc gf pt diff --git a/src/Wumpus/Drawing/Dots/SimpleDots.hs b/src/Wumpus/Drawing/Dots/SimpleDots.hs --- a/src/Wumpus/Drawing/Dots/SimpleDots.hs +++ b/src/Wumpus/Drawing/Dots/SimpleDots.hs @@ -46,8 +46,8 @@ , dotEscText - , dotHLine - , dotVLine + , dotHBar + , dotVBar , dotX , dotPlus , dotCross @@ -67,7 +67,7 @@ ) where - +import Wumpus.Drawing.Basis.Symbols import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel @@ -104,7 +104,11 @@ normalize sz a = (realToFrac a) * 0.75 * fromIntegral sz dinterp sz d = (4/3) * (realToFrac d) / (fromIntegral sz) +instance Tolerance MarkSize where + eq_tolerance = 0.001 + length_tolerance = 0.01 + umark :: InterpretUnit u => LocGraphic MarkSize -> LocGraphic u umark = uconvF @@ -112,25 +116,25 @@ -- | Filled disk - radius 0.25 MarkSize. -- smallDisk :: InterpretUnit u => LocGraphic u -smallDisk = umark $ dcDisk FILL 0.25 +smallDisk = umark $ dcDisk DRAW_FILL 0.25 -- | Filled disk - radius 1.0 MarkSize. -- largeDisk :: InterpretUnit u => LocGraphic u -largeDisk = umark $ dcDisk FILL 1 +largeDisk = umark $ dcDisk DRAW_FILL 1 -- | Stroked disk (circle) - radius 0.25 MarkSize. -- smallCirc :: InterpretUnit u => LocGraphic u -smallCirc = umark $ dcDisk STROKE 0.25 +smallCirc = umark $ ocircle 0.25 -- | Stroked disk (circle) - radius 1.0 MarkSize. -- largeCirc :: InterpretUnit u => LocGraphic u -largeCirc = umark $ dcDisk STROKE 1 +largeCirc = umark $ ocircle 1 -- possibly: @@ -145,7 +149,7 @@ dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u -dotText ss = ignoreAns $ runPosObject (posText ss) CENTER +dotText ss = ignoreAns $ runPosObject CENTER $ posText ss dotEscChar :: (Real u, Floating u, InterpretUnit u) => EscapedChar -> LocGraphic u @@ -153,7 +157,7 @@ dotEscText :: (Real u, Floating u, InterpretUnit u) => EscapedText -> LocGraphic u -dotEscText esc = ignoreAns $ runPosObject (posEscText esc) CENTER +dotEscText esc = ignoreAns $ runPosObject CENTER $ posEscText esc -- TODO - need Upright versions of dots... @@ -165,12 +169,12 @@ axialLine v = moveStart (negateV (0.5 *^ v)) (locStraightLine v) -dotHLine :: (Fractional u, InterpretUnit u) => LocGraphic u -dotHLine = umark $ axialLine (hvec 1) +dotHBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotHBar = umark $ hbar 1 -dotVLine :: (Fractional u, InterpretUnit u) => LocGraphic u -dotVLine = umark $ axialLine (vvec 1) +dotVBar :: (Fractional u, InterpretUnit u) => LocGraphic u +dotVBar = umark $ vbar 1 dotX :: (Fractional u, InterpretUnit u) => LocGraphic u @@ -179,7 +183,7 @@ dotPlus :: (Fractional u, InterpretUnit u) => LocGraphic u -dotPlus = dotVLine `mappend` dotHLine +dotPlus = dotVBar `mappend` dotHBar dotCross :: (Floating u, InterpretUnit u) => LocGraphic u @@ -193,55 +197,57 @@ dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotDiamond = umark $ drawVertexPathAlg STROKE (diamondPathAlg 0.5 0.66) +dotDiamond = umark $ drawPlacedTrail CSTROKE (diamondTrail 0.5 0.66) dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotFDiamond = umark $ drawVertexPathAlg FILL (diamondPathAlg 0.5 0.66) +dotFDiamond = umark $ drawPlacedTrail CFILL (diamondTrail 0.5 0.66) dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotBDiamond = umark $ drawVertexPathAlg FILL_STROKE (diamondPathAlg 0.5 0.66) +dotBDiamond = umark $ drawPlacedTrail CFILL_STROKE (diamondTrail 0.5 0.66) -- | Note disk is filled. -- dotDisk :: (Fractional u, InterpretUnit u) => LocGraphic u -dotDisk = umark $ dcDisk FILL 0.5 +dotDisk = umark $ dcDisk DRAW_FILL 0.5 dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u -dotSquare = umark $ drawVertexPathAlg STROKE (rectanglePathAlg 1 1) +dotSquare = umark $ drawPlacedTrail CSTROKE (rectangleTrail 1 1) dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -dotCircle = umark $ dcDisk STROKE 0.5 +dotCircle = umark $ ocircle 0.5 dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -dotBCircle = umark $ dcDisk FILL_STROKE 0.5 +dotBCircle = umark $ dcDisk DRAW_FILL_STROKE 0.5 dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u -dotPentagon = umark $ drawVertexPathAlg STROKE (polygonPathAlg 5 0.5) +dotPentagon = umark $ drawPlacedTrail CSTROKE (polygonTrail 5 0.5) -dotStar :: (Floating u, InterpretUnit u) => LocGraphic u +dotStar :: (Floating u, Ord u, InterpretUnit u, Tolerance u) + => LocGraphic u dotStar = umark $ starLines 0.5 -starLines :: (Floating u, InterpretUnit u) => u -> LocGraphic u -starLines hh = promoteLoc $ \ctr -> - let ps = runPathAlgPoint ctr $ polygonPathAlg 5 hh - in step $ map (fn ctr) ps +starLines :: (Floating u, Ord u, InterpretUnit u, Tolerance u) + => u -> LocGraphic u +starLines hh = promoteLoc $ \ctr -> + let alg = polygonTrail 5 hh + in liftQuery (qapplyLoc (placedTrailPoints alg) ctr) >>= \ps -> + step $ map (fn ctr) ps where fn p0 p1 = straightLine p0 p1 step (x:xs) = mconcat $ x:xs step _ = error "starLines - unreachable" - dotAsterisk :: (Floating u, InterpretUnit u) => LocGraphic u dotAsterisk = umark $ asteriskLines 1 @@ -272,7 +278,7 @@ dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u -dotTriangle = umark $ drawVertexPathAlg STROKE alg +dotTriangle = umark $ drawPlacedTrail CSTROKE alg where - alg = pathIterateLocus $ fn3 $ equilateralTriangleVertices 1 + alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices 1 fn3 = \(a,b,c) -> [a,b,c] diff --git a/src/Wumpus/Drawing/Extras/Axes.hs b/src/Wumpus/Drawing/Extras/Axes.hs --- a/src/Wumpus/Drawing/Extras/Axes.hs +++ b/src/Wumpus/Drawing/Extras/Axes.hs @@ -18,10 +18,14 @@ ( orthontAxes + + , horizontalLabels + , verticalLabels ) where import Wumpus.Drawing.Connectors +import qualified Wumpus.Drawing.Connectors.ConnectorPaths as C import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -35,14 +39,36 @@ -- orthontAxes :: (Real u, Floating u, InterpretUnit u) => (Int,Int) -> (Int,Int) -> LocGraphic u -orthontAxes (xl,xr) (yl,yr) = - promoteLoc $ \(P2 x y) -> +orthontAxes (xl,xr) (yl,yr) = promoteLoc $ \(P2 x y) -> snapmove (1,1) >>= \(V2 uw uh) -> let conn1 = rightArrow barb45 connline xPtl = P2 (x - (uw * fromIntegral xl)) y xPtr = P2 (x + (uw * fromIntegral xr)) y yPtl = P2 x (y - (uh * fromIntegral yl)) yPtr = P2 x (y + (uh * fromIntegral yr)) - in localize cap_square $ ignoreAns (connect xPtl xPtr conn1) - `mappend` ignoreAns (connect yPtl yPtr conn1) + in localize cap_square $ ignoreAns (connect conn1 xPtl xPtr) + `mappend` ignoreAns (connect conn1 yPtl yPtr) + + +horizontalLabels :: (Num a, Fractional u, InterpretUnit u) + => RectAddress -> [a] -> LocGraphic u +horizontalLabels addr ns = + snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (runChainH uw $ mapM mf ns) + where + mf n = chain1 $ runPosObject addr $ posTextUpright $ show n + + +verticalLabels :: (Num a, Fractional u, InterpretUnit u) + => RectAddress -> [a] -> LocGraphic u +verticalLabels addr ns = + snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (runChainV uh $ mapM mf ns) + where + mf n = chain1 $ runPosObject addr $ posTextUpright $ show n + + + +-- Cf. Parsec\'s Token module... +-- +connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u +connline = C.connline default_connector_props diff --git a/src/Wumpus/Drawing/Extras/Clip.hs b/src/Wumpus/Drawing/Extras/Clip.hs --- a/src/Wumpus/Drawing/Extras/Clip.hs +++ b/src/Wumpus/Drawing/Extras/Clip.hs @@ -16,6 +16,8 @@ -- Ideally, clipping would be defined in Wumpus-Basic, but clipping -- needs a higher level path object than Wumpus-Basic provides. -- +-- \*\* WARNING \*\* names need improving. +-- -------------------------------------------------------------------------------- module Wumpus.Drawing.Extras.Clip @@ -26,16 +28,19 @@ ) where -import Wumpus.Drawing.Paths.Relative +import Wumpus.Drawing.Paths import Wumpus.Basic.Kernel -- package: wumpus-basic - -- | Clip a LocGraphic. +-- +-- \*\* WARNING \*\* - AbsPath (coordinate-specific) is the wrong +-- object to clip a LocGraphic (coordinate-free). -- -locClip :: InterpretUnit u => RelPath u -> LocGraphic u -> LocGraphic u -locClip rp gf = promoteLoc $ \pt -> - liftQuery (toPrimPath pt rp) >>= \pp -> clipImage pp (gf `at` pt) +locClip :: InterpretUnit u => AbsPath u -> LocGraphic u -> LocGraphic u +locClip absp gf = promoteLoc $ \pt -> + liftQuery (toPrimPath absp) >>= \pp -> clipImage pp (gf `at` pt) + diff --git a/src/Wumpus/Drawing/Extras/Grids.hs b/src/Wumpus/Drawing/Extras/Grids.hs --- a/src/Wumpus/Drawing/Extras/Grids.hs +++ b/src/Wumpus/Drawing/Extras/Grids.hs @@ -155,9 +155,9 @@ let props = upd default_grid_props width = uw * fromIntegral nx height = uh * fromIntegral ny - intrr = gridInterior nx width uw ny height uh props + intrr = gridInterior nx width uw ny height uh props rect = localize (major_line_update props) $ - blRectangle STROKE width height + blRectangle DRAW_STROKE width height in intrr `mappend` rect @@ -178,8 +178,8 @@ in moveStart (vvec dy) $ minorMajor n subs (vvec dy) mnr mjr | otherwise = moveStart (vvec uh) $ duplicate numh (vvec uh) mjr where - mnr = localize (minor_line_update props) $ hline w - mjr = localize (major_line_update props) $ hline w + mnr = localize (minor_line_update props) $ horizontalLine w + mjr = localize (major_line_update props) $ horizontalLine w @@ -191,8 +191,8 @@ in moveStart (hvec dx) $ minorMajor n subs (hvec dx) mnr mjr | otherwise = moveStart (hvec uw) $ duplicate numv (hvec uw) mjr where - mnr = localize (minor_line_update props) $ vline h - mjr = localize (major_line_update props) $ vline h + mnr = localize (minor_line_update props) $ verticalLine h + mjr = localize (major_line_update props) $ verticalLine h diff --git a/src/Wumpus/Drawing/Extras/Loop.hs b/src/Wumpus/Drawing/Extras/Loop.hs --- a/src/Wumpus/Drawing/Extras/Loop.hs +++ b/src/Wumpus/Drawing/Extras/Loop.hs @@ -21,10 +21,10 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic + import Wumpus.Core -- package: wumpus-core diff --git a/src/Wumpus/Drawing/Paths.hs b/src/Wumpus/Drawing/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths.hs @@ -0,0 +1,30 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths +-- 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 + ( + + module Wumpus.Drawing.Paths.Base + , module Wumpus.Drawing.Paths.PathBuilder + , module Wumpus.Drawing.Paths.Vamps + + ) where + +import Wumpus.Drawing.Paths.Base +import Wumpus.Drawing.Paths.PathBuilder +import Wumpus.Drawing.Paths.Vamps + diff --git a/src/Wumpus/Drawing/Paths/Absolute.hs b/src/Wumpus/Drawing/Paths/Absolute.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Absolute.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# 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.AbsPath - , module Wumpus.Drawing.Paths.Base.PathBuilder - - ) where - -import Wumpus.Drawing.Paths.Base.AbsPath -import Wumpus.Drawing.Paths.Base.PathBuilder - diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base.hs @@ -0,0 +1,967 @@ +{-# 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 +-- +-- Absolute path type - this should be more amenable for building +-- complex drawings than the PrimPath type in Wumpus-Core. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base + ( + + -- * Absolute path type + AbsPath + , DAbsPath + + + -- * Construction + , emptyPath + , line1 + , curve1 + , vertexPath + , curvePath + , controlCurve + + , vectorPath + , vectorPathTheta + + , placedTrailPath + , catTrailPath + + -- * Queries + , null + , length + + -- * Concat and extension + , snocLine + , snocLineTo + , snocCurve + , snocCurveTo + + + -- * Conversion + , toPrimPath + + , drawPath + , drawPath_ + + -- * Shortening + , shortenPath + , shortenL + , shortenR + + -- * Tips and direction + , tipL + , tipR + , directionL + , directionR + , isBezierL + , isBezierR + + + -- * Path anchors + , midway + , midway_ + , atstart + , atstart_ + , atend + , atend_ + + + -- * Views + , PathViewL(..) + , DPathViewL + , PathViewR(..) + , DPathViewR + , PathSegment(..) + , DPathSegment + , pathViewL + , pathViewR + + , optimizeLines + + , roundExterior + , roundInterior + + -- * Path division + , pathdiv + + + ) 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 ) +import qualified Wumpus.Basic.Utils.JoinList as JL + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Data.Monoid +import qualified Data.Traversable as T + +import Prelude hiding ( null, length ) + +-- +-- Design Note +-- +-- Wumpus has no relative path type. An AbsPath is expected to be +-- an /answer/ from some function like an anchor point or a +-- bounding box. +-- +-- Wumpus didn\'t always work on this premise, some of the code +-- below may contradict this... +-- + + + + + +-- | 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 u (Vec2 u) + | AbsCurveSeg u (Vec2 u) (Vec2 u) (Vec2 u) + deriving (Eq,Show) + + +type instance DUnit (AbsPathSeg u) = u + +-- +-- DESIGN NOTE +-- +-- No monoid instance. AbsPaths dont support empty or even concat +-- naturally. +-- +-- Concat is troublesome because AbsPaths are always located +-- within a frame. +-- +-- They can support: +-- +-- a. Concat with a join between the end of the first path and the +-- start of the second. +-- +-- b. Shape preserving concat - the second path is moved so it +-- continues from the end point of the first path. +-- +-- It is conceptually simpler to think about extension (adding to +-- the path tip) rather than concatenation. +-- + +-------------------------------------------------------------------------------- + +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 v1) = + AbsLineSeg (f u) (fmap f v1) + + fmap f (AbsCurveSeg u v1 v2 v3) = + AbsCurveSeg (f u) (fmap f v1) (fmap f v2) (fmap f v3) + + + +-------------------------------------------------------------------------------- +-- Translate + +-- Translate is cheap on AbsPath + +instance Num u => Translate (AbsPath u) where + translate x y (AbsPath len sp se ep) = + AbsPath len (translate x y sp) se (translate x y ep) + + + +-------------------------------------------------------------------------------- +-- 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 end point. +-- +-- Thus AbsPath operates as a semigroup but not a monoid. +-- +emptyPath :: Floating u => Point2 u -> AbsPath u +emptyPath = 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 len p0 (JL.one $ AbsLineSeg len v1) p1 + where + v1 = pvec p0 p1 + len = vlength v1 + +-- | 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 len p0 (JL.one $ AbsCurveSeg len v1 v2 v3) p3 + where + v1 = pvec p0 p1 + v2 = pvec p1 p2 + v3 = pvec p2 p3 + len = 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) xs + where + step acc [] = acc + step acc (y:ys) = step (snocLineTo acc 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) xs + where + step acc (x:y:z:zs) = step (snocCurveTo acc (x,y,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 + + + + + +vectorPath :: (Floating u, Ord u, Tolerance u) + => [Vec2 u] -> Point2 u -> AbsPath u +vectorPath vecs p0 = vertexPath $ p0 : step p0 vecs + where + step _ [] = [] + step pt (v1:vs) = let p1 = pt .+^ v1 in p1 : step p1 vs + + +vectorPathTheta :: (Real u, Floating u, Tolerance u) + => [Vec2 u] -> Radian -> Point2 u -> AbsPath u +vectorPathTheta vs ang = vectorPath $ map (rotate ang) vs + + +placedTrailPath :: (Floating u, Ord u, Tolerance u) + => Point2 u -> PlacedTrail u -> AbsPath u +placedTrailPath pt trl = + let (v1,ss) = destrPlacedTrail trl in step (emptyPath $ pt .+^ v1) ss + where + step ac [] = ac + step ac (TLine v1:xs) = step (ac `snocLine` v1) xs + step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs + +catTrailPath :: (Floating u, Ord u, Tolerance u) + => Point2 u -> CatTrail u -> AbsPath u +catTrailPath pt trl = step (emptyPath pt) $ destrCatTrail trl + where + step ac [] = ac + step ac (TLine v1:xs) = step (ac `snocLine` v1) xs + step ac (TCurve v1 v2 v3:xs) = step (snocCurve ac (v1,v2,v3)) xs + + +-------------------------------------------------------------------------------- +-- 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 puts +-- a tax on the build operations. +-- +length :: Num u => AbsPath u -> u +length (AbsPath u _ _ _) = u + + +-------------------------------------------------------------------------------- +-- Extension + +infixl 5 `snocLine` + + +-- | Extend the path with a straight line segment from the +-- end-point defined by the supplied vector. +-- +-- > infixl 5 `snocLine` +-- +snocLine :: Floating u => AbsPath u -> Vec2 u -> AbsPath u +snocLine (AbsPath u sp se ep) v1 = + let u1 = vlength v1 + tail_line = AbsLineSeg u1 v1 + in AbsPath (u + u1) sp (JL.snoc se tail_line) (ep .+^ v1) + + + +infixl 5 `snocLineTo` + + +-- | Extend the path with a straight line segment from the +-- end-point to the supplied point. +-- +-- > infixl 5 `snocLineTo` +-- +snocLineTo :: Floating u => AbsPath u -> Point2 u -> AbsPath u +snocLineTo (AbsPath u sp se1 ep) p1 = AbsPath (u + len) sp (snoc se1 s1) p1 + where + s1@(AbsLineSeg len _) = lineSegment ep p1 + + +infixl 5 `snocCurve` + +-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points. +-- +-- > infixl 5 `snocCurve` +-- +snocCurve :: (Floating u, Ord u, Tolerance u) + => AbsPath u -> (Vec2 u, Vec2 u, Vec2 u) -> AbsPath u +snocCurve absp@(AbsPath _ _ _ ep) (v1,v2,v3) = snocCurveTo absp (p1,p2,p3) + where + p1 = ep .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + + +infixl 5 `snocCurveTo` + + +-- | Extend the path from the end-point with a Bezier curve +-- segment formed by the supplied points. +-- +-- > infixl 5 `snocCurveTo` +-- +snocCurveTo :: (Floating u, Ord u, Tolerance u) + => AbsPath u -> (Point2 u, Point2 u, Point2 u) -> AbsPath u +snocCurveTo (AbsPath u sp se1 ep) (p1,p2,p3) = + AbsPath (u + len) sp (snoc se1 s1) p3 + where + s1@(AbsCurveSeg len _ _ _) = curveSegment ep p1 p2 p3 + + +-------------------------------------------------------------------------------- + + + +segmentLength :: AbsPathSeg u -> u +segmentLength (AbsLineSeg u _) = u +segmentLength (AbsCurveSeg u _ _ _) = u + + +segmentVector :: Num u => AbsPathSeg u -> Vec2 u +segmentVector (AbsLineSeg _ v1) = v1 +segmentVector (AbsCurveSeg _ v1 v2 v3) = v1 ^+^ v2 ^+^ v3 + + + +-- | Helper - construct a line segment. +-- +lineSegment :: Floating u => Point2 u -> Point2 u -> AbsPathSeg u +lineSegment p0 p1 = lineSegmentV $ pvec p0 p1 + +-- | Helper - construct a line segment. +-- +lineSegmentV :: Floating u => Vec2 u -> AbsPathSeg u +lineSegmentV v1 = AbsLineSeg (vlength v1) v1 + + +-- | 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 len v1 v2 v3 + where + len = bezierLength (BezierCurve p0 p1 p2 p3) + v1 = pvec p0 p1 + v2 = pvec p1 p2 + v3 = pvec p2 p3 + + +-- | Helper - construct the /empty/ but located path. +-- +zeroPath :: Floating u => Point2 u -> AbsPath u +zeroPath p0 = AbsPath 0 p0 JL.empty p0 + + + +drawPath :: InterpretUnit u + => PathMode -> AbsPath u -> Image u (AbsPath u) +drawPath mode rp = replaceAns rp $ + liftQuery (toPrimPath rp) >>= dcPath mode + + +drawPath_ :: InterpretUnit u + => PathMode -> AbsPath u -> Graphic u +drawPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode + + +-- | 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 u PrimPath +toPrimPath (AbsPath _ start segs _) = + uconvertCtxF start >>= \dstart -> + T.mapM uconvertCtxF segs >>= \dsegs -> + return $ step1 dstart dsegs + where + step1 p0 se | JL.null se = emptyPrimPath p0 + | otherwise = absPrimPath p0 $ step2 p0 (viewl se) + + step2 _ EmptyL = [] + step2 pt (e :< se) = let (p1,s) = mkSeg pt e + in s : step2 p1 (viewl se) + + mkSeg p0 (AbsLineSeg _ v1) = let p1 = p0 .+^ v1 + in (p1, absLineTo p1) + mkSeg p0 (AbsCurveSeg _ v1 v2 v3) = let p1 = p0 .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in (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 path1@(AbsPath u startp segs ep) + | n < 0 = path1 + | n >= u = AbsPath 0 ep mempty ep + | otherwise = step n startp (viewl segs) + where + step _ _ EmptyL = AbsPath 0 ep mempty ep + step d sp (e :< se) = let z = segmentLength e + snext = sp .+^ segmentVector e + in case compare d z of + GT -> step (d-z) snext (viewl se) + EQ -> makeLeftPath (u-n) snext se ep + LT -> let (spart,e1) = shortenSegL d sp e + in AbsPath (u-n) spart (e1 `cons` se) ep + + +makeLeftPath :: Floating u + => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u + -> AbsPath u +makeLeftPath u sp se ep | JL.null se = line1 sp ep + | otherwise = AbsPath u sp se ep + + + +shortenSegL :: (Real u, Floating u) + => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u) +shortenSegL n sp (AbsLineSeg u v1) = + let v2 = shortenVec n v1 + sp' = sp .+^ (v1 ^-^ v2) + in (sp', AbsLineSeg (u-n) v2) + +shortenSegL n sp (AbsCurveSeg u v1 v2 v3) = + (q0, AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3)) + where + (BezierCurve q0 q1 q2 q3) = let p1 = sp .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in snd $ subdividet (n/u) + (BezierCurve sp p1 p2 p3) + + + +shortenVec :: (Real u, Floating u) => u -> Vec2 u -> Vec2 u +shortenVec n v0 = v0 ^-^ v + where + 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 path1@(AbsPath u sp segs endpt) + | n < 0 = path1 + | n >= u = AbsPath 0 sp mempty sp + | otherwise = step n (viewr segs) endpt + where + step _ EmptyR _ = AbsPath 0 sp mempty sp + step d (se :> e) ep = let z = segmentLength e + enext = ep .-^ segmentVector e + in case compare d z of + GT -> step (d-z) (viewr se) enext + EQ -> makeRightPath n sp se enext + LT -> let (e1,epart) = shortenSegR d e ep + in AbsPath (u-n) sp (se `snoc` e1) epart + + +makeRightPath :: Floating u + => u -> Point2 u -> JoinList (AbsPathSeg u) -> Point2 u + -> AbsPath u +makeRightPath u sp se ep | JL.null se = line1 sp ep + | otherwise = AbsPath u sp se ep + + +shortenSegR :: (Real u, Floating u) + => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u) +shortenSegR n (AbsLineSeg u v1) ep = + let v2 = shortenVec n v1 + ep' = ep .-^ (v1 ^+^ v2) + in (AbsLineSeg (u-n) v2, ep') + +shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = + (AbsCurveSeg (u-n) (pvec q0 q1) (pvec q1 q2) (pvec q2 q3), q3) + where + (BezierCurve q0 q1 q2 q3) = let p2 = ep .-^ v3 + p1 = p2 .-^ v2 + p0 = p1 .-^ v1 + in fst $ subdividet ((u-n)/u) + (BezierCurve p0 p1 p2 ep) + + + + + +-------------------------------------------------------------------------------- +-- 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 _ v1 :< _) = vdirection $ negateV v1 + step (AbsCurveSeg _ v1 _ _ :< _) = vdirection $ negateV v1 + step _ = 0 + + +-- | 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 _ v1) = vdirection v1 + step (_ :> AbsCurveSeg _ _ _ v3) = vdirection v3 + step _ = 0 + +-- | Is the left tip a Bezier curve? +-- +isBezierL :: AbsPath u -> Bool +isBezierL (AbsPath _ _ se _) = step $ viewl se + where + step (AbsCurveSeg _ _ _ _ :< _) = True + step _ = False + + + +-- | Is the right tip a Bezier curve? +-- +isBezierR :: AbsPath u -> Bool +isBezierR (AbsPath _ _ se _) = step $ viewr se + where + step (_ :> AbsCurveSeg _ _ _ _) = True + step _ = False + + +-------------------------------------------------------------------------------- + + +-- 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 ... + + + + +-------------------------------------------------------------------------------- +-- Path Views cf. Data.Sequence + + +infixr 5 :<< +infixl 5 :>> + +data PathViewL u = EmptyPathL + | PathSegment u :<< AbsPath u + deriving (Eq,Show) + +type instance DUnit (PathViewL u) = u + +type DPathViewL = PathViewL Double + +data PathViewR u = EmptyPathR + | AbsPath u :>> PathSegment u + deriving (Eq,Show) + +type instance DUnit (PathViewR u) = u + +type DPathViewR = PathViewR Double + + + +-- | PathSegments are annotated with length. +-- +-- +data PathSegment u = LineSeg u (Point2 u) (Point2 u) + | CurveSeg u (Point2 u) (Point2 u) (Point2 u) (Point2 u) + deriving (Eq,Show) + +type instance DUnit (PathSegment u) = u + + +type DPathSegment = PathSegment Double + + +-------------------------------------------------------------------------------- + +instance Functor PathSegment where + fmap f (LineSeg d p0 p1) = LineSeg (f d) (fmap f p0) (fmap f p1) + fmap f (CurveSeg d p0 p1 p2 p3) = + CurveSeg (f d) (fmap f p0) (fmap f p1) (fmap f p2) (fmap f p3) + +instance Functor PathViewL where + fmap _ EmptyPathL = EmptyPathL + fmap f (a :<< as) = fmap f a :<< fmap f as + +instance Functor PathViewR where + fmap _ EmptyPathR = EmptyPathR + fmap f (as :>> a) = fmap f as :>> fmap f a + +-------------------------------------------------------------------------------- + + + +pathViewL :: Num u => AbsPath u -> PathViewL u +pathViewL (AbsPath len sp segs ep) = go (viewl segs) + where + go EmptyL = EmptyPathL + + go (AbsLineSeg d v1 :< se) = + let p1 = sp .+^ v1 in LineSeg d sp p1 :<< AbsPath (len - d) p1 se ep + + go (AbsCurveSeg d v1 v2 v3 :< se) = + let p1 = sp .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in CurveSeg d sp p1 p2 p3 :<< AbsPath (len - d) p3 se ep + + +pathViewR :: Num u => AbsPath u -> PathViewR u +pathViewR (AbsPath len sp segs ep) = go (viewr segs) + where + go EmptyR = EmptyPathR + + go (se :> AbsLineSeg d v1) = + let p0 = ep .-^ v1 in AbsPath (len - d) sp se p0 :>> LineSeg d p0 ep + + go (se :> AbsCurveSeg d v1 v2 v3) = + let p2 = ep .-^ v3 + p1 = p2 .-^ v2 + p0 = p1 .-^ v1 + in AbsPath (len - d) sp se p0 :>> CurveSeg d p0 p1 p2 ep + + + +-------------------------------------------------------------------------------- + + +-- Path should be same length afterwards. + +optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) + => AbsPath u -> AbsPath u +optimizeLines (AbsPath _ sp0 segs _) = + outer (zeroPath sp0) (viewl segs) + where + outer acc (AbsLineSeg _ v1 :< se) = + inner acc (vdirection v1) v1 (viewl se) + + outer acc (AbsCurveSeg u v1 v2 v3 :< se) = + outer (snocC acc u v1 v2 v3) (viewl se) + + outer acc EmptyL = acc + + inner acc d0 v0 (AbsLineSeg _ v1 :< se) = + let d1 = vdirection v1 + in if (d0 == vdirection v1) + then inner acc d1 (v0 ^+^ v1) (viewl se) + else inner (snocV acc v0) d1 v1 (viewl se) + + inner acc _ v0 (AbsCurveSeg u v1 v2 v3 :< se) = + let acc1 = snocC (snocV acc v0) u v1 v2 v3 + in outer acc1 (viewl se) + + inner acc _ v0 EmptyL = snocV acc v0 + + snocC (AbsPath u sp se ep) u1 v1 v2 v3 = + let tail_curve = AbsCurveSeg u1 v1 v2 v3 + vtotal = v1 ^+^ v2 ^+^ v3 + in AbsPath (u+u1) sp (JL.snoc se tail_curve) (ep .+^ vtotal) + + snocV (AbsPath u sp se ep) v1 = + let u1 = vlength v1 + tail_line = AbsLineSeg u1 v1 + in AbsPath (u+u1) sp (JL.snoc se tail_line) (ep .+^ v1) + + +-------------------------------------------------------------------------------- +-- Round corners + + +segToCatTrail :: AbsPathSeg u -> CatTrail u +segToCatTrail (AbsLineSeg _ v1) = catline v1 +segToCatTrail (AbsCurveSeg _ v1 v2 v3) = catcurve v1 v2 v3 + +-- | Because lookahead of 2 makes the rounding algos easier we +-- decons to a list... +-- +segmentListL :: AbsPath u -> (Point2 u, [AbsPathSeg u]) +segmentListL (AbsPath _ sp se _) = (sp, JL.toList se) + +-- | Round interior corners of a Path. +-- +-- The path is treated as open - the start of the initial and end +-- of the final segments are not rounded. Only straight line to +-- straight line joins are rounded, joins to or from Beczier +-- curves are not rounded. +-- +-- Caution - all path segments are expected to be longer than +-- 2x the round corner length, though this is not checked.. +-- +roundInterior :: (Real u, Floating u,Tolerance u) + => u -> AbsPath u -> AbsPath u +roundInterior du pth0 = catTrailPath pt ctrail + where + (pt,ss) = segmentListL pth0 + ctrail = roundInteriorCat du ss + + +roundInteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u +roundInteriorCat _ [] = mempty +roundInteriorCat du (z:zs) = step mempty z zs + where + step ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = + let (x,k) = roundAB du v1 v2 in step (ac `mappend` x) k xs + + step ac prev (x:xs) = + let tprev = segToCatTrail prev in step (ac `mappend` tprev) x xs + + step ac prev [] = ac `mappend` segToCatTrail prev + +roundAB :: (Real u, Floating u) + => u -> Vec2 u -> Vec2 u -> (CatTrail u, AbsPathSeg u) +roundAB du v1 v2 = + (catline v1' `mappend` tcurve, lineSegmentV v2') + where + v1' = shortenVec du v1 + v2' = shortenVec du v2 + + tv1 = avec (vdirection v1) du + tv2 = avec (vdirection v2) du + base_vec = tv1 ^+^ tv2 + bw = vlength base_vec + h = sqrt $ pow2 du - (pow2 $ 0.5 * bw) + tcurve = tricurve bw (-h) (vdirection base_vec) + + -- note the (-h) in tricurve is wrong, we need to account + -- for CCW or CW properly... + +pow2 :: Num a => a -> a +pow2 x = x ^ (2::Int) + +-- Form corners inside a /triangle/ Bezier. + + +-- | Round a \"closed\" path. +-- +-- Caution - all path sgements are expected to be longer than +-- 2x the round corner length, though this is not checked.. +-- +roundExterior :: (Real u, Floating u, Tolerance u) + => u -> AbsPath u -> AbsPath u +roundExterior du pth0 + | isBezierR pth0 || isBezierL pth0 = roundInterior du pth0 + | otherwise = catTrailPath pt ctrail + where + (pt,ss) = segmentListL pth0 + ctrail = roundExteriorCat du ss + + +roundExteriorCat :: (Real u, Floating u) => u -> [AbsPathSeg u] -> CatTrail u +roundExteriorCat _ [] = mempty + +roundExteriorCat _ (AbsCurveSeg _ _ _ _ : _) = + error "runExteriorCat - unreachable." + +roundExteriorCat du (z@(AbsLineSeg _ v0):zs) = step0 z zs + where + step0 (AbsLineSeg _ v1) xs = + let seg0 = lineSegmentV $ shortenVec du v1 in step1 mempty seg0 xs + + step0 _ _ = error "roundExteriorCat - unreachable 1." + + step1 ac (AbsLineSeg _ v1) (AbsLineSeg _ v2:xs) = + let (x,k) = roundAB du v1 v2 in step1 (ac `mappend` x) k xs + + step1 ac prev (x:xs) = + let tprev = segToCatTrail prev in step1 (ac `mappend` tprev) x xs + + step1 ac (AbsLineSeg _ v1) [] = + let (t,_) = roundAB du v1 v0 in ac `mappend` t + + step1 _ _ [] = + error "roundExteriorCat - unreachable 2." + +-------------------------------------------------------------------------------- +-- Path division + + +-- | Divide a path returning intermediate points and direction +-- +-- Args are initial-prefix, division size, trailing size. +-- +-- Generation is stopped if the remainder of the path is shorter +-- than the trailing size. +-- +pathdiv :: (Real u, Floating u) + => u -> u -> u -> AbsPath u -> [(Point2 u, Radian)] +pathdiv ana sz end = step . shortenL ana + where + step pth | length pth < end = [] + | otherwise = atstart pth : step (shortenL sz pth) + diff --git a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs +++ /dev/null @@ -1,852 +0,0 @@ -{-# 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 - - , drawOpenPath - , drawOpenPath_ - , drawClosedPath - , drawClosedPath_ - - -- * 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 - - , optimizeLines - - , 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 puts --- 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 - - - - -drawOpenPath :: InterpretUnit u - => AbsPath u -> Image u (AbsPath u) -drawOpenPath rp = replaceAns rp $ - liftQuery (toPrimPath rp) >>= dcOpenPath - - -drawOpenPath_ :: InterpretUnit u - => AbsPath u -> Graphic u -drawOpenPath_ rp = liftQuery (toPrimPath rp) >>= dcOpenPath - - -drawClosedPath :: InterpretUnit u - => DrawStyle -> AbsPath u -> Image u (AbsPath u) -drawClosedPath sty rp = replaceAns rp $ - liftQuery (toPrimPath rp) >>= dcClosedPath sty - - -drawClosedPath_ :: InterpretUnit u - => DrawStyle -> AbsPath u -> Graphic u -drawClosedPath_ sty rp = liftQuery (toPrimPath rp) >>= dcClosedPath sty - - --- | 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 u 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 - - - --------------------------------------------------------------------------------- - - --- Path should be same length afterwards. - -optimizeLines :: (Real u, Floating u, Ord u, Tolerance u) - => AbsPath u -> AbsPath u -optimizeLines (AbsPath _ sp0 segs _) = outer (zeroPath sp0) (viewl segs) - where - outer acc (AbsLineSeg _ p0 p1 :< se) = - inner acc (vdirection $ pvec p0 p1) p0 p1 (viewl se) - - outer acc (AbsCurveSeg _ _ p1 p2 p3 :< se) = - outer (snocCurveTo acc p1 p2 p3) (viewl se) - - outer acc EmptyL = acc - - inner acc d1 sp ep (AbsLineSeg _ p0 p1 :< se) = - let d2 = vdirection $ pvec p0 p1 in - if (d1 == d2) - then inner acc d1 sp p1 (viewl se) - else inner (acc `snocLineTo` ep) d2 ep p1 (viewl se) - - inner acc _ _ ep (AbsCurveSeg _ _ p1 p2 p3 :< se) = - let acc1 = snocCurveTo (snocLineTo acc ep) p1 p2 p3 - in outer acc1 (viewl se) - - inner acc _ _ ep EmptyL = acc `snocLineTo` ep - --------------------------------------------------------------------------------- --- Round corners - --- 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/PathBuilder.hs b/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +++ /dev/null @@ -1,465 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Base.PathBuilder --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Build relative paths monadically. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Base.PathBuilder - ( - - - GenPathSpec - , PathSpec - , Vamp(..) - , PathTerm(..) - - , runGenPathSpec - , execGenPathSpec - , evalGenPathSpec - , stripGenPathSpec - - , runPathSpec - , runPathSpec_ - - , runPivot - - - , penline - , pencurve - - - , breakPath - , hpenline - , vpenline - , apenline - - , penlines - , pathmoves - - , vamp - , cycleSubPath - , localPen - - ) where - -import Wumpus.Drawing.Paths.Base.RelPath - - -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 -import Control.Monad -import Data.Monoid -import Prelude hiding ( null, cycle, lines ) - - -newtype GenPathSpec st u a = GenPathSpec - { getGenPathSpec :: DrawingContext -> DPoint2 -> PathSt st - -> (a, DPoint2, PathSt st, PathW) } - -type instance DUnit (GenPathSpec st u a) = u -type instance UState (GenPathSpec st u) = st - -type PathSpec u a = GenPathSpec () u a - - -data PathSt st = PathSt - { st_active_pen :: ActivePen - , st_user_state :: st - } - - --- | Note - this formulation doesn\'t support monoidal append. --- --- Information gets lost for this one (we really would want to --- draw the left-hand-side): --- --- > PEN_DOWN _ _ `mappend` PEN_UP --- --- So it has to be part of the state not the writer. --- -data ActivePen = PEN_UP - | PEN_DOWN { ap_start_point :: Point2 Double - , ap_rel_path :: RelPath Double - } - - -zeroActivePath :: DPoint2 -> ActivePen -zeroActivePath pt = PEN_DOWN pt mempty - - -data PathW = PathW - { w_rel_path :: RelPath Double - , w_trace :: CatPrim - } - - -instance Monoid PathW where - mempty = PathW mempty mempty - PathW a0 b0 `mappend` PathW a1 b1 = PathW (a0 `mappend` a1) (b0 `mappend` b1) - - - -data PathTerm = PATH_OPEN | PATH_CLOSED DrawStyle - deriving (Eq,Show) - - -data Vamp u = Vamp - { vamp_move :: Vec2 u - , vamp_conn :: ConnectorGraphic u - } - -type instance DUnit (Vamp u) = u - - --------------------------------------------------------------------------------- --- Instances - - --- Functor - -instance Functor (GenPathSpec st u) where - fmap f ma = GenPathSpec $ \ctx pt s -> - let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s - in (f a,p1,s1,w1) - - --- Applicative - -instance Applicative (GenPathSpec st u) where - pure a = GenPathSpec $ \_ pt s -> (a, pt, s, mempty) - mf <*> ma = GenPathSpec $ \ctx pt s -> - let (f,p1,s1,w1) = getGenPathSpec mf ctx pt s - (a,p2,s2,w2) = getGenPathSpec ma ctx p1 s1 - in (f a, p2, s2, w1 `mappend` w2) - - --- Monad - -instance Monad (GenPathSpec st u) where - return a = GenPathSpec $ \_ pt s -> (a, pt, s, mempty) - ma >>= k = GenPathSpec $ \ctx pt s -> - let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s - (b,p2,s2,w2) = (getGenPathSpec . k) a ctx p1 s1 - in (b, p2, s2, w1 `mappend` w2) - - -instance Monoid a => Monoid (GenPathSpec st u a) where - mempty = GenPathSpec $ \_ pt s -> (mempty, pt, s, mempty) - ma `mappend` mb = GenPathSpec $ \ctx pt s -> - let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s - (b,p2,s2,w2) = getGenPathSpec mb ctx p1 s1 - in (a `mappend` b, p2, s2, w1 `mappend` w2) - --- DrawingCtxM - -instance DrawingCtxM (GenPathSpec st u) where - askDC = GenPathSpec $ \ctx pt s -> (ctx, pt, s, mempty) - asksDC f = GenPathSpec $ \ctx pt s -> (f ctx, pt, s, mempty) - localize upd ma = GenPathSpec $ \ctx pt s -> - getGenPathSpec ma (upd ctx) pt s - - --- UserStateM - -instance UserStateM (GenPathSpec st u) where - getState = GenPathSpec $ \_ pt s -> - (st_user_state s, pt, s, mempty) - setState ust = GenPathSpec $ \_ pt s -> - ((), pt, s {st_user_state = ust} , mempty) - updateState upd = GenPathSpec $ \_ pt s -> - let ust = st_user_state s - in ((), pt, s {st_user_state = upd ust}, mempty) - - - --- LocationM - -instance InterpretUnit u => LocationM (GenPathSpec st u) where - location = locationImpl - - --- CursorM - -instance InterpretUnit u => CursorM (GenPathSpec st u) where - moveby = movebyImpl - - --- InsertlM - -instance InterpretUnit u => InsertlM (GenPathSpec st u) where - insertl = insertlImpl - - --------------------------------------------------------------------------------- --- Run functions - -runGenPathSpec :: InterpretUnit u - => GenPathSpec st u a -> st -> PathTerm - -> LocImage u (a, st, RelPath u) -runGenPathSpec ma st term = promoteLoc $ \pt -> - askDC >>= \ctx -> - let dpt = normalizeF (dc_font_size ctx) pt - st_zero = PathSt (zeroActivePath dpt) st - (a,_,s,w) = getGenPathSpec ma ctx dpt st_zero - upath = dinterpF (dc_font_size ctx) $ w_rel_path w - (_,wcp) = runImage (drawActivePen term $ st_active_pen s) ctx - wfinal = w_trace w `mappend` wcp - in replaceAns (a, st_user_state s, upath) $ primGraphic wfinal - - --- Note - eval and exec return the RelPath this is as-per RWS --- which returns @w@ for execRWS (s,w) and evalRWS (a,w) --- - -evalGenPathSpec :: InterpretUnit u - => GenPathSpec st u a -> st -> PathTerm - -> LocImage u (a, RelPath u) -evalGenPathSpec ma st term = - (\(a,_,w) -> (a,w)) <$> runGenPathSpec ma st term - - - -execGenPathSpec :: InterpretUnit u - => GenPathSpec st u a -> st -> PathTerm - -> LocImage u (st, RelPath u) -execGenPathSpec ma st term = - (\(_,s,w) -> (s,w)) <$> runGenPathSpec ma st term - - - -stripGenPathSpec :: InterpretUnit u - => GenPathSpec st u a -> st -> PathTerm - -> LocQuery u (a, st, RelPath u) -stripGenPathSpec ma st term = stripLocImage $ runGenPathSpec ma st term - - -runPathSpec :: InterpretUnit u - => PathSpec u a -> PathTerm -> LocImage u (a, RelPath u) -runPathSpec ma term = evalGenPathSpec ma () term - -runPathSpec_ :: InterpretUnit u - => PathSpec u a -> PathTerm -> LocGraphic u -runPathSpec_ ma term = ignoreAns $ evalGenPathSpec ma () term - - - --- Monad run function nomenclature: --- --- > run - both --- > eval - answer (no state) --- > exec - state (no answer) --- --- Note RWS always returns the @w@. --- --- For Wumpus: --- --- > run - monadic answer, and the writer /construction/ --- > eval - just the monadic answer --- > exec - just the writer /construction/. --- --- In all case the CatPrim inside the LocImage may contain --- additional graphics. --- --- Client code can use @ignoreAns@ to generate a @LocGraphic@ --- from the @LocImage@. - - --- | Helper. --- -drawActivePen :: PathTerm -> ActivePen -> DGraphic -drawActivePen _ PEN_UP = mempty -drawActivePen term (PEN_DOWN { ap_start_point = pt - , ap_rel_path = rp}) = case term of - PATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt - PATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt - - - - - - - - --- | Form a \"pivot path\" drawing from two path specifications. --- The start point of the drawing is the pivot formed by joining --- the paths. --- -runPivot :: (Floating u, InterpretUnit u) - => PathSpec u a -> PathSpec u a -> LocGraphic u -runPivot ma mb = promoteLoc $ \pt -> - askDC >>= \ctx -> - let dpt = normalizeF (dc_font_size ctx) pt - st_zero = PathSt (zeroActivePath dpt) () - (p1,_,s,w1) = getGenPathSpec mz ctx dpt st_zero - dp1 = normalizeF (dc_font_size ctx) p1 - v1 = pvec dpt dp1 - (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx - wfinal = w_trace w1 `mappend` wcp - in primGraphic $ cpmove (negateV v1) wfinal - where - mz = ma >> location >>= \pt -> mb >> return pt - - --------------------------------------------------------------------------------- --- operations - - -locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u) -locationImpl = GenPathSpec $ \ctx pt s -> - let upt = dinterpF (dc_font_size ctx) pt - in (upt, pt, s, mempty) - - --- | @extendPen@ causes a pendown. --- -extendPen :: DPoint2 -> DVec2 -> ActivePen -> ActivePen -extendPen pt v PEN_UP = PEN_DOWN pt (line1 v) -extendPen _ v (PEN_DOWN p0 rp) = PEN_DOWN p0 (rp `snocLineTo` v) - --- --- NOTE - /lineto/ needs a new name as the @to@ suffix suggests --- moving to a point, whereas the movement is @by@ a vector. --- --- @relline@ not a good candidate, need a name that supports --- horizontal (h) and vertical (v) versions. --- - - --- | Extend the path with a line, drawn by the pen. --- -penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u () -penline v1 = GenPathSpec $ \ctx pt s -> - let sz = dc_font_size ctx - dv1 = normalizeF sz v1 - pen = extendPen pt dv1 (st_active_pen s) - w1 = PathW { w_rel_path = line1 dv1, w_trace = mempty } - in ((), pt .+^ dv1, s { st_active_pen = pen }, w1) - - - --- | @extendPenC@ causes a pendown. --- -extendPenC :: DPoint2 -> DVec2 -> DVec2 -> DVec2 -> ActivePen -> ActivePen -extendPenC pt v1 v2 v3 PEN_UP = PEN_DOWN pt (curve1 v1 v2 v3) -extendPenC _ v1 v2 v3 (PEN_DOWN p0 rp) = PEN_DOWN p0 (snocCurveTo rp v1 v2 v3) - - - --- | Extend the path with a curve, drawn by the pen. --- -pencurve :: InterpretUnit u - => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u () -pencurve v1 v2 v3 = GenPathSpec $ \ctx pt s -> - let sz = dc_font_size ctx - dv1 = normalizeF sz v1 - dv2 = normalizeF sz v2 - dv3 = normalizeF sz v3 - pen = extendPenC pt dv1 dv2 dv3 (st_active_pen s) - w1 = PathW { w_rel_path = line1 dv1, w_trace = mempty } - in ((), pt .+^ dv1, s { st_active_pen = pen }, w1) - - --- | @moveby@ causes a pen up. --- -movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u () -movebyImpl v1 = GenPathSpec $ \ctx pt s -> - let sz = dc_font_size ctx - dv1 = normalizeF sz v1 - (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx - w1 = PathW { w_rel_path = mempty, w_trace = wcp } - in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1) - - -breakPath :: InterpretUnit u => GenPathSpec st u () -breakPath = movebyImpl (V2 0 0) - -hpenline :: InterpretUnit u => u -> GenPathSpec st u () -hpenline dx = penline (hvec dx) - -vpenline :: InterpretUnit u => u -> GenPathSpec st u () -vpenline dy = penline (vvec dy) - - -apenline :: (Floating u, InterpretUnit u) - => Radian -> u -> GenPathSpec st u () -apenline ang d = penline (avec ang d) - -penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () -penlines = mapM_ penline - -pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () -pathmoves = mapM_ moveby - - - -insertlImpl :: InterpretUnit u - => LocImage u a -> GenPathSpec st u a -insertlImpl gf = GenPathSpec $ \ctx pt s -> - let upt = dinterpF (dc_font_size ctx) pt - (a,wcp) = runLocImage gf ctx upt - w1 = PathW { w_rel_path = mempty, w_trace = wcp } - in (a, pt, s, w1) - - - -vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u () -vamp (Vamp v1 conn) = GenPathSpec $ \ctx pt s -> - let sz = dc_font_size ctx - dv1 = normalizeF sz v1 - (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx - upt = dinterpF sz pt - (_,ccp) = runConnectorImage conn ctx upt (upt .+^ v1) - w1 = PathW { w_rel_path = mempty, w_trace = wcp `mappend` ccp } - in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1) - - -cycleSubPath :: DrawStyle -> GenPathSpec st u () -cycleSubPath styl = GenPathSpec $ \ctx pt s -> - let gf = drawActivePen (PATH_CLOSED styl) $ st_active_pen s - (_,wcp) = runImage gf ctx - w1 = PathW { w_rel_path = mempty, w_trace = wcp } - in ((), pt, s { st_active_pen = PEN_UP }, w1) - - --- Design note --- --- Should pen changing be @local@ style vis the Reader monad or a --- state change with the State monad? --- --- @local@ is more idiomatic within the context of Wumpus (and --- easier to implement), but @state change@ is probably more --- natural for Path building. --- --- For the time being we go with local. --- - - -localPen :: DrawingContextF -> GenPathSpec st u a -> GenPathSpec st u a -localPen upd ma = GenPathSpec $ \ctx pt s -> - let (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx - (a,p1,s1,w1) = getGenPathSpec ma (upd ctx) pt s - w2 = let wcp2 = wcp `mappend` w_trace w1 - in w1 { w_trace = wcp2 } - in (a, p1, s1 { st_active_pen = PEN_UP }, w2) - diff --git a/src/Wumpus/Drawing/Paths/Base/RelPath.hs b/src/Wumpus/Drawing/Paths/Base/RelPath.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base/RelPath.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# 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 - , length - - -- * Concat - , append - , consLineTo - , snocLineTo - , consCurveTo - , snocCurveTo - - - -- * Conversion - , fromPathAlgVertices - , fromPathAlgCurves - - , toPrimPath - , toAbsPath - - , drawOpenPath - , drawOpenPath_ - , drawClosedPath - , drawClosedPath_ - - ) 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 -- package: vector-space -import Data.VectorSpace - - -import qualified Data.Foldable as F -import Data.Monoid -import qualified Data.Traversable as T -import Prelude hiding ( null, length ) - - - - - --- | Relative Path data type. --- --- Note this type is more limited than AbsPath, it does not --- support /introspective/ operations like @length@ or anchors. --- -data RelPath u = RelPath - { rel_path_len :: u - , rel_path_segs :: JoinList (RelPathSeg u) } - deriving (Eq,Show) - -type instance DUnit (RelPath u) = u - - -type DRelPath = RelPath Double - --- No annotations... --- -data RelPathSeg u = RelLineSeg - { rel_line_len :: u - , rel_line_to :: Vec2 u - } - | RelCurveSeg - { rel_curve_len :: u - , rel_curve_cp1 :: Vec2 u - , rel_curve_cp2 :: Vec2 u - , rel_curve_cp3 :: Vec2 u - } - deriving (Eq,Show) - - -type instance DUnit (RelPathSeg u) = u - - - --------------------------------------------------------------------------------- - -instance Functor RelPath where - fmap f (RelPath len xs) = RelPath (f len) (fmap (fmap f) xs) - -instance Functor RelPathSeg where - fmap f (RelLineSeg len v1) = - RelLineSeg (f len) (fmap f v1) - - fmap f (RelCurveSeg len v1 v2 v3) = - RelCurveSeg (f len) (fmap f v1) (fmap f v2) (fmap f v3) - - -instance Num u => Monoid (RelPath u) where - mempty = empty - mappend = append - - --------------------------------------------------------------------------------- --- Construction - - --- | Helper - construct a straight line segment. --- -lineSegment :: Floating u => Vec2 u -> (u, RelPathSeg u) -lineSegment v1 = - (len, RelLineSeg { rel_line_len = len, rel_line_to = v1 }) - where - len = vlength v1 - - --- | Helper - construct a curve segment. --- -curveSegment :: (Floating u, Ord u, Tolerance u) - => Vec2 u -> Vec2 u -> Vec2 u -> (u, RelPathSeg u) -curveSegment v1 v2 v3 = (len, cseg) - where - p0 = zeroPt - p1 = p0 .+^ v1 - p2 = p1 .+^ v2 - p3 = p2 .+^ v3 - - len = bezierLength (BezierCurve p0 p1 p2 p3) - cseg = RelCurveSeg { rel_curve_len = len - , rel_curve_cp1 = v1 - , rel_curve_cp2 = v2 - , rel_curve_cp3 = v3 - } - - - - --- | An empty relative path is acceptible to Wumpus because --- it is always drawn as a LocGraphic. --- -empty :: Num u => RelPath u -empty = RelPath { rel_path_len = 0, rel_path_segs = mempty } - --- | Create a relative path from a single straight line. --- -line1 :: Floating u => Vec2 u -> RelPath u -line1 v = RelPath len (JL.one $ RelLineSeg len v) - where - len = vlength v - - - --- | Create a relative path from a single Bezier curve. --- -curve1 :: Floating u - => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -curve1 v1 v2 v3 = RelPath len (JL.one $ RelCurveSeg len v1 v2 v3) - where - len = vlength $ v1 ^+^ v2 ^+^ v3 - - -vertexPath :: Floating u => [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 :: Floating u => [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 . rel_path_segs - --- | Length of the Path. --- --- Length is the length of the path as it is drawn, it is not a --- count of the number or path segments. --- --- Length is cached so this operation is cheap - though this puts --- a tax on the build operations. --- -length :: RelPath u -> u -length = rel_path_len - - --------------------------------------------------------------------------------- --- Concat - -infixr 1 `append` - - - -append :: Num u => RelPath u -> RelPath u -> RelPath u -append (RelPath la ssa) (RelPath lb ssb) = RelPath (la + lb) $ ssa `join` ssb - - -consLineTo :: Floating u - => Vec2 u -> RelPath u -> RelPath u -consLineTo v1 (RelPath len se) = RelPath (len + vl) $ JL.cons s se - where - (vl,s) = lineSegment v1 - -snocLineTo :: Floating u - => RelPath u -> Vec2 u -> RelPath u -snocLineTo (RelPath len se) v1 = RelPath (len + vl) $ JL.snoc se s - where - (vl,s) = lineSegment v1 - - - -consCurveTo :: (Floating u, Ord u, Tolerance u) - => Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -> RelPath u -consCurveTo v1 v2 v3 (RelPath len se) = RelPath (len + cl) $ JL.cons s se - where - (cl,s) = curveSegment v1 v2 v3 - -snocCurveTo :: (Floating u, Ord u, Tolerance u) - => RelPath u -> Vec2 u -> Vec2 u -> Vec2 u -> RelPath u -snocCurveTo (RelPath len se) v1 v2 v3 = RelPath (len + cl) $ JL.snoc se s - where - (cl,s) = curveSegment v1 v2 v3 - - - - - --------------------------------------------------------------------------------- --- Conversion - -fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u) -fromPathAlgVertices = step . runPathAlgVec - where - step (Nothing, xs) = (zeroVec, vertexPath xs) - step (Just v1, xs) = (v1, vertexPath xs) - -fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u) -fromPathAlgCurves = step . runPathAlgVec - where - step (Nothing, xs) = (zeroVec, curvedPath xs) - step (Just v1, xs) = (v1, curvedPath xs) - - -toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query u PrimPath -toPrimPath start (RelPath _ segs) = - uconvertCtxF start >>= \dstart -> - T.mapM uconvertCtxF segs >>= \dsegs -> - return $ relPrimPath dstart $ F.foldr fn [] dsegs - where - fn (RelLineSeg _ v1) ac = relLineTo v1 : ac - fn (RelCurveSeg _ v1 v2 v3) ac = relCurveTo v1 v2 v3 : ac - - - -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) - - - -drawOpenPath :: InterpretUnit u - => RelPath u -> LocImage u (RelPath u) -drawOpenPath rp = replaceAns rp $ - promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcOpenPath - -drawOpenPath_ :: InterpretUnit u - => RelPath u -> LocGraphic u -drawOpenPath_ rp = promoteLoc $ \start -> - liftQuery (toPrimPath start rp) >>= dcOpenPath - - -drawClosedPath :: InterpretUnit u - => DrawStyle -> RelPath u -> LocImage u (RelPath u) -drawClosedPath sty rp = replaceAns rp $ - promoteLoc $ \start -> liftQuery (toPrimPath start rp) >>= dcClosedPath sty - -drawClosedPath_ :: InterpretUnit u - => DrawStyle -> RelPath u -> LocGraphic u -drawClosedPath_ sty rp = promoteLoc $ \start -> - liftQuery (toPrimPath start rp) >>= dcClosedPath sty - diff --git a/src/Wumpus/Drawing/Paths/PathBuilder.hs b/src/Wumpus/Drawing/Paths/PathBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/PathBuilder.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.PathBuilder +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Build relative paths monadically. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.PathBuilder + ( + + + GenPathSpec + , PathSpec + , Vamp(..) + + + , runGenPathSpec + , execGenPathSpec + , evalGenPathSpec + , stripGenPathSpec + + , runPathSpec + , runPathSpec_ + + , runPivot + + + , penline + , pencurve + + + , breakPath + , hpenline + , vpenline + , apenline + + , penlines + , pathmoves + + , vamp + , cycleSubPath + , updatePen + + ) where + +import Wumpus.Drawing.Paths.Base + +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 +import Control.Monad +import Data.Monoid +import Prelude hiding ( null, cycle, lines ) + +-- +-- TODO - possibly we need two drawing contexts one for the pen +-- and one for the decoration trace. +-- +-- Alternatively PathSt should have a local DrawingContext for the +-- pen. +-- + + +-- | Note - a path spec has an immutable start point like +-- @LocDrawing@. +-- +-- Effectively a path is draw in a local coordinate system with +-- @(0,0)@ as the origin. +-- +newtype GenPathSpec st u a = GenPathSpec { + getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) } + +type instance DUnit (GenPathSpec st u a) = u +type instance UState (GenPathSpec st u) = st + +type PathSpec u a = GenPathSpec () u a + + +data PathSt st = PathSt + { st_active_pen :: ActivePen + , st_pen_ctx :: DrawingContext + , st_cumulative_path :: AbsPath Double + , st_user_state :: st + } + + +-- | Note - this formulation doesn\'t support monoidal append. +-- +-- Information gets lost for this one (we really would want to +-- draw the left-hand-side): +-- +-- > PEN_DOWN _ _ `mappend` PEN_UP +-- +-- So it has to be part of the state not the writer. +-- +data ActivePen = PEN_UP + | PEN_DOWN (AbsPath Double) + + + +zeroActivePen :: DPoint2 -> ActivePen +zeroActivePen pt = PEN_DOWN (emptyPath pt) + + +data Vamp u = Vamp + { vamp_move :: Vec2 u + , vamp_conn :: ConnectorGraphic u + } + +type instance DUnit (Vamp u) = u + + +-------------------------------------------------------------------------------- +-- Instances + + +-- Functor + +instance Functor (GenPathSpec st u) where + fmap f ma = GenPathSpec $ \ctx s -> + let (a,s1,w1) = getGenPathSpec ma ctx s + in (f a,s1,w1) + + +-- Applicative + +instance Applicative (GenPathSpec st u) where + pure a = GenPathSpec $ \_ s -> (a, s, mempty) + mf <*> ma = GenPathSpec $ \ctx s -> + let (f,s1,w1) = getGenPathSpec mf ctx s + (a,s2,w2) = getGenPathSpec ma ctx s1 + in (f a, s2, w1 `mappend` w2) + + +-- Monad + +instance Monad (GenPathSpec st u) where + return a = GenPathSpec $ \_ s -> (a, s, mempty) + ma >>= k = GenPathSpec $ \ctx s -> + let (a,s1,w1) = getGenPathSpec ma ctx s + (b,s2,w2) = (getGenPathSpec . k) a ctx s1 + in (b, s2, w1 `mappend` w2) + + +-- Monoid + +instance Monoid a => Monoid (GenPathSpec st u a) where + mempty = GenPathSpec $ \_ s -> (mempty, s, mempty) + ma `mappend` mb = GenPathSpec $ \ctx s -> + let (a,s1,w1) = getGenPathSpec ma ctx s + (b,s2,w2) = getGenPathSpec mb ctx s1 + in (a `mappend` b, s2, w1 `mappend` w2) + + +-- DrawingCtxM + +instance DrawingCtxM (GenPathSpec st u) where + askDC = GenPathSpec $ \ctx s -> (ctx, s, mempty) + asksDC f = GenPathSpec $ \ctx s -> (f ctx, s, mempty) + localize upd ma = GenPathSpec $ \ctx s -> + getGenPathSpec ma (upd ctx) s + + +-- UserStateM + +instance UserStateM (GenPathSpec st u) where + getState = GenPathSpec $ \_ s -> + (st_user_state s, s, mempty) + setState ust = GenPathSpec $ \_ s -> + ((), s {st_user_state = ust} , mempty) + updateState upd = GenPathSpec $ \_ s -> + let ust = st_user_state s + in ((), s {st_user_state = upd ust}, mempty) + + + +-- Note - all these need to peek at the cumulative path + +-- LocationM + +instance InterpretUnit u => LocationM (GenPathSpec st u) where + location = locationImpl + + +-- CursorM + +instance InterpretUnit u => CursorM (GenPathSpec st u) where + moveby = movebyImpl + + +-- InsertlM + +instance InterpretUnit u => InsertlM (GenPathSpec st u) where + insertl = insertlImpl + + + +-------------------------------------------------------------------------------- +-- Run functions + +runGenPathSpec :: InterpretUnit u + => st -> PathMode -> GenPathSpec st u a + -> LocImage u (a, st, AbsPath u) +runGenPathSpec st mode ma = promoteLoc $ \pt -> + askDC >>= \ctx -> + let P2 dx dy = normalizeF (dc_font_size ctx) pt + st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st + (a,s1,w1) = getGenPathSpec ma ctx st_zero + dpath = translate dx dy $ st_cumulative_path s1 + upath = dinterpF (dc_font_size ctx) dpath + pctx = st_pen_ctx s1 + (_,w2) = runImage pctx (drawActivePen mode $ st_active_pen s1) + wfinal = cpmove (V2 dx dy) $ w1 `mappend` w2 + in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal + + +-- Note - eval and exec return the AbsPath this is as-per RWS +-- which returns @w@ for execRWS (s,w) and evalRWS (a,w) +-- + +evalGenPathSpec :: InterpretUnit u + => st -> PathMode -> GenPathSpec st u a + -> LocImage u (a, AbsPath u) +evalGenPathSpec st mode ma = + (\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma + + + +execGenPathSpec :: InterpretUnit u + => st -> PathMode -> GenPathSpec st u a + -> LocImage u (st, AbsPath u) +execGenPathSpec st mode ma = + (\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma + + + +stripGenPathSpec :: InterpretUnit u + => st -> PathMode -> GenPathSpec st u a + -> LocQuery u (a, st, AbsPath u) +stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma + + +runPathSpec :: InterpretUnit u + => PathMode -> PathSpec u a -> LocImage u (a, AbsPath u) +runPathSpec mode ma = evalGenPathSpec () mode ma + +runPathSpec_ :: InterpretUnit u + => PathMode -> PathSpec u a -> LocGraphic u +runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma + + + +-- Monad run function nomenclature: +-- +-- > run - both +-- > eval - answer (no state) +-- > exec - state (no answer) +-- +-- Note RWS always returns the @w@. +-- +-- For Wumpus: +-- +-- > run - monadic answer, and the writer /construction/ +-- > eval - just the monadic answer +-- > exec - just the writer /construction/. +-- +-- In all case the CatPrim inside the LocImage may contain +-- additional graphics. +-- +-- Client code can use @ignoreAns@ to generate a @LocGraphic@ +-- from the @LocImage@. + + + +-- | Helper. +-- +drawActivePen :: PathMode -> ActivePen -> DGraphic +drawActivePen _ PEN_UP = mempty +drawActivePen mode (PEN_DOWN abs_path) = drawPath_ mode abs_path + + + + + + + +-- | Form a \"pivot path\" drawing from two path specifications. +-- The start point of the drawing is the pivot formed by joining +-- the paths. +-- +runPivot :: (Floating u, InterpretUnit u) + => PathSpec u a -> PathSpec u a -> LocGraphic u +runPivot ma mb = promoteLoc $ \pt -> + askDC >>= \ctx -> + let dpt = normalizeF (dc_font_size ctx) pt + st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) () + (p1,s1,w1) = getGenPathSpec mz ctx st_zero + dp1 = normalizeF (dc_font_size ctx) p1 + v1 = pvec dpt dp1 + pctx = st_pen_ctx s1 + (_,w2) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s1 + wfinal = w1 `mappend` w2 + in primGraphic $ cpmove (negateV v1) wfinal + where + mz = ma >> location >>= \pt -> mb >> return pt + + +-------------------------------------------------------------------------------- +-- operations + + +locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u) +locationImpl = GenPathSpec $ \ctx s -> + let pt = tipR $ st_cumulative_path s + upt = dinterpF (dc_font_size ctx) pt + in (upt, s, mempty) + + +-- | 'extendPaths' extends both the @cumulative_path@ and the +-- @active_pen@. If the pen is up it, changes to a pendown. +-- +extendPaths :: DVec2 -> PathSt st -> PathSt st +extendPaths v1 s@(PathSt { st_cumulative_path = cp + , st_active_pen = pen} ) = + s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen } + where + upd PEN_UP = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1) + upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1 + + + + +-- | Extend the path with a line, drawn by the pen. +-- +penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u () +penline v1 = GenPathSpec $ \ctx s -> + let sz = dc_font_size ctx + dv1 = normalizeF sz v1 + in ((), extendPaths dv1 s, mempty) + + + +-- | @extendPenC@ causes a pendown. +-- +extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st +extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp + , st_active_pen = pen} ) = + s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen } + where + upd PEN_UP = let p0 = tipR cp + p1 = p0 .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in PEN_DOWN $ curve1 p0 p1 p2 p3 + upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3) + + + +-- | Extend the path with a curve, drawn by the pen. +-- +pencurve :: InterpretUnit u + => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u () +pencurve v1 v2 v3 = GenPathSpec $ \ctx s -> + let sz = dc_font_size ctx + dv1 = normalizeF sz v1 + dv2 = normalizeF sz v2 + dv3 = normalizeF sz v3 + in ((), extendPathsC dv1 dv2 dv3 s, mempty) + + +-- | @moveby@ causes a pen up. +-- +movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u () +movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) -> + let sz = dc_font_size ctx + dv1 = normalizeF sz v1 + (_,w1) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s + cpath = snocLine (st_cumulative_path s) dv1 + in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1) + + +breakPath :: InterpretUnit u => GenPathSpec st u () +breakPath = movebyImpl (V2 0 0) + +hpenline :: InterpretUnit u => u -> GenPathSpec st u () +hpenline dx = penline (hvec dx) + +vpenline :: InterpretUnit u => u -> GenPathSpec st u () +vpenline dy = penline (vvec dy) + + +apenline :: (Floating u, InterpretUnit u) + => Radian -> u -> GenPathSpec st u () +apenline ang d = penline (avec ang d) + +penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () +penlines = mapM_ penline + +pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () +pathmoves = mapM_ moveby + + + +insertlImpl :: InterpretUnit u + => LocImage u a -> GenPathSpec st u a +insertlImpl gf = GenPathSpec $ \ctx s -> + let upt = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s) + (a,wcp) = runLocImage ctx upt gf + in (a, s, wcp) + + + +vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u () +vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) -> + let sz = dc_font_size ctx + dv1 = normalizeF sz v1 + (_,w1) = runImage pctx $ drawActivePen OSTROKE $ st_active_pen s + upt = dinterpF sz (tipR $ st_cumulative_path s) + (_,w2) = runConnectorImage ctx upt (upt .+^ v1) conn + cpath = snocLine (st_cumulative_path s) dv1 + in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath } + , w1 `mappend` w2) + + +cycleSubPath :: DrawMode -> GenPathSpec st u () +cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) -> + let (_,w1) = runImage pctx $ drawActivePen (fn mode) (st_active_pen s) + in ((), s { st_active_pen = PEN_UP }, w1) + where + fn DRAW_STROKE = CSTROKE + fn DRAW_FILL = CFILL + fn DRAW_FILL_STROKE = CFILL_STROKE + + + +-- Design note +-- +-- Should pen changing be @local@ style vis the Reader monad or a +-- state change with the State monad? +-- +-- Now switched to state change. +-- + + +-- | Note - updates the pen but doesn\'t draw, the final path +-- will be drawing with the last updated context. +-- +updatePen :: DrawingContextF -> GenPathSpec st u () +updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx}) -> + ((), s { st_pen_ctx = upd pctx}, mempty ) + diff --git a/src/Wumpus/Drawing/Paths/Relative.hs b/src/Wumpus/Drawing/Paths/Relative.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Relative.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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.PathBuilder - , module Wumpus.Drawing.Paths.Base.RelPath - - ) where - -import Wumpus.Drawing.Paths.Base.PathBuilder -import Wumpus.Drawing.Paths.Base.RelPath - diff --git a/src/Wumpus/Drawing/Paths/Vamps.hs b/src/Wumpus/Drawing/Paths/Vamps.hs --- a/src/Wumpus/Drawing/Paths/Vamps.hs +++ b/src/Wumpus/Drawing/Paths/Vamps.hs @@ -22,20 +22,19 @@ ) where -import Wumpus.Drawing.Paths.Base.PathBuilder ( Vamp(..) ) -import Wumpus.Drawing.Paths.Base.AbsPath +import Wumpus.Drawing.Paths.PathBuilder ( Vamp(..) ) +import Wumpus.Drawing.Paths.Base import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core - -- TODO - library of useful / illustrative vamps (circle, square etc.) --- Note - actual square TODO... +-- -- squareWE :: (Real u, Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> Vamp u @@ -43,10 +42,12 @@ , vamp_conn = conn } where conn = promoteConn $ \p1 p2 -> - -- TODO ... - drawClosedPath_ STROKE $ vertexPath $ [ p1, p2 ] + let dir = vdirection $ pvec p1 p2 + in drawPath_ CSTROKE $ vectorPathTheta path1 dir p1 - -- vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] + hdiam = 0.5 * diam + path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] -- Drawing a cirle picks the half point on the vamp_move vector... + 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 @@ -46,7 +46,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -119,7 +119,7 @@ strokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -strokedShape = shapeToLoc (dcClosedPath STROKE) +strokedShape = shapeToLoc (dcClosedPath DRAW_STROKE) -- | Note - this is simplistic double stroking - draw a background @@ -134,7 +134,7 @@ dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) dblStrokedShape sh = sdecorate back fore where - img = shapeToLoc (dcClosedPath STROKE) sh + img = shapeToLoc (dcClosedPath DRAW_STROKE) sh back = getLineWidth >>= \lw -> localize (set_line_width $ lw * 3.0) img fore = ignoreAns $ localize (stroke_colour white) img @@ -142,11 +142,11 @@ filledShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -filledShape = shapeToLoc (dcClosedPath FILL) +filledShape = shapeToLoc (dcClosedPath DRAW_FILL) borderedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -borderedShape = shapeToLoc (dcClosedPath FILL_STROKE) +borderedShape = shapeToLoc (dcClosedPath DRAW_FILL_STROKE) shapeToLoc :: InterpretUnit u @@ -160,15 +160,15 @@ rstrokedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rstrokedShape = shapeToLocTheta (dcClosedPath STROKE) +rstrokedShape = shapeToLocTheta (dcClosedPath DRAW_STROKE) rfilledShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rfilledShape = shapeToLocTheta (dcClosedPath FILL) +rfilledShape = shapeToLocTheta (dcClosedPath DRAW_FILL) rborderedShape :: InterpretUnit u => Shape t u -> LocThetaImage u (t u) -rborderedShape = shapeToLocTheta (dcClosedPath FILL_STROKE) +rborderedShape = shapeToLocTheta (dcClosedPath DRAW_FILL_STROKE) shapeToLocTheta :: InterpretUnit u @@ -186,7 +186,8 @@ roundCornerShapePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> [Point2 u] -> Query u (AbsPath u) roundCornerShapePath sz xs = - if sz `tEQ` 0 then return (vertexPath xs) else return (roundTrail sz xs) + if sz `tEQ` 0 then return (vertexPath xs) + else return (roundExterior sz $ vertexPath xs) -- | The path angle can be modified. This allows /inverse/ -- versions of shapes (e.g. InvTriangle) to be made by 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 @@ -24,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Kernel -- package: wumpus-basic 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 @@ -25,12 +25,11 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic import Wumpus.Basic.Geometry.Quadrant -import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -155,8 +154,8 @@ mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> u -> LocThetaQuery u (AbsPath u) mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> - let ps = runPathAlgPoint ctr $ diamondPathAlg hw hh - in roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps + qapplyLoc (placedTrailPoints $ diamondTrail hw hh) ctr >>= \ps -> + roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps diff --git a/src/Wumpus/Drawing/Shapes/Ellipse.hs b/src/Wumpus/Drawing/Shapes/Ellipse.hs --- a/src/Wumpus/Drawing/Shapes/Ellipse.hs +++ b/src/Wumpus/Drawing/Shapes/Ellipse.hs @@ -27,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Kernel -- package: wumpus-basic 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 @@ -27,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry -- package: wumpus-basic 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 @@ -27,7 +27,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry -- package: wumpus-basic 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 @@ -24,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic 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 @@ -24,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic 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 @@ -25,7 +25,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry -- package: wumpus-basic 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 @@ -24,7 +24,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry -- package: wumpus-basic diff --git a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs --- a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs +++ b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs @@ -21,10 +21,11 @@ module Wumpus.Drawing.Text.Base.DocTextZero ( - - Doc + GenDoc + , Doc + , GenDocGraphic , DocGraphic - , runDoc + , runGenDoc , (<+>) , blank @@ -58,14 +59,25 @@ import Data.Monoid import Numeric - +-- +-- Design Issue: +-- +-- Can user state be added to Doc? +-- +-- Easy if PosObject had user state, difficult as it doesn\'t... +-- -- | Doc type. -- -newtype Doc u a = Doc { getDoc :: DocEnv -> PosObject u a } +newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a } -type instance DUnit (Doc u a) = u +type instance DUnit (GenDoc st u a) = u +type instance UState (GenDoc st u) = st +type GenDocGraphic st u = GenDoc st u (UNil u) + +type Doc u a = GenDoc () u a + type DocGraphic u = Doc u (UNil u) @@ -74,33 +86,37 @@ , doc_font_family :: FontFamily } -instance Functor (Doc u) where - fmap f ma = Doc $ \env -> fmap f $ getDoc ma env +instance Functor (GenDoc st u) where + fmap f ma = GenDoc $ \env -> fmap f $ getGenDoc ma env -instance Applicative (Doc u) where - pure a = Doc $ \_ -> pure a - mf <*> ma = Doc $ \env -> getDoc mf env <*> getDoc ma env +instance Applicative (GenDoc st u) where + pure a = GenDoc $ \_ -> pure a + mf <*> ma = GenDoc $ \env -> getGenDoc mf env <*> getGenDoc ma env -instance Monad (Doc u) where - return a = Doc $ \_ -> return a - ma >>= k = Doc $ \env -> getDoc ma env >>= \a -> getDoc (k a) env +instance Monad (GenDoc st u) where + return a = GenDoc $ \_ -> return a + ma >>= k = GenDoc $ \env -> getGenDoc ma env >>= \a -> getGenDoc (k a) env +instance (Monoid a, InterpretUnit u) => Monoid (GenDoc st u a) where + mempty = GenDoc $ \_ -> mempty + ma `mappend` mb = GenDoc $ \env -> getGenDoc ma env `hconcat` getGenDoc mb env -instance DrawingCtxM (Doc u) where - askDC = Doc $ \_ -> askDC - asksDC fn = Doc $ \_ -> asksDC fn - localize upd ma = Doc $ \env -> localize upd (getDoc ma env) +instance DrawingCtxM (GenDoc st u) where + askDC = GenDoc $ \_ -> askDC + asksDC fn = GenDoc $ \_ -> asksDC fn + localize upd ma = GenDoc $ \env -> localize upd (getGenDoc ma env) -instance (Monoid a, InterpretUnit u) => Monoid (Doc u a) where - mempty = Doc $ \_ -> mempty - ma `mappend` mb = Doc $ \env -> getDoc ma env `hconcat` getDoc mb env +instance UserStateM (GenDoc st u) where + getState = GenDoc $ \_ -> getState + setState s = GenDoc $ \_ -> setState s + updateState upd = GenDoc $ \_ -> updateState upd -runDoc :: Doc u a -> VAlign -> FontFamily -> PosObject u a -runDoc ma va ff = getDoc ma env1 +runGenDoc :: VAlign -> FontFamily -> GenDoc st u a -> GenPosObject st u a +runGenDoc va ff ma = getGenDoc ma env1 where env1 = DocEnv { doc_alignment = va, doc_font_family = ff } @@ -109,16 +125,17 @@ -------------------------------------------------------------------------------- -- Get vcat vconcat... from the Concat class -instance (Monoid a, Fractional u, InterpretUnit u) => Concat (Doc u a) where +instance (Monoid a, Fractional u, InterpretUnit u) => + Concat (GenDoc st u a) where hconcat = mappend vconcat = vcatImpl vcatImpl :: (Monoid a, Fractional u, InterpretUnit u) - => Doc u a -> Doc u a -> Doc u a -vcatImpl ma mb = Doc $ \env -> + => GenDoc st u a -> GenDoc st u a -> GenDoc st u a +vcatImpl ma mb = GenDoc $ \env -> let va = doc_alignment env in textlineSpace >>= \sep -> - valignSpace va sep (getDoc ma env) (getDoc mb env) + valignSpace va sep (getGenDoc ma env) (getGenDoc mb env) -------------------------------------------------------------------------------- -- Primitives @@ -129,67 +146,69 @@ -- -- (infixr 6) -- -(<+>) :: InterpretUnit u => DocGraphic u -> DocGraphic u -> DocGraphic u +(<+>) :: InterpretUnit u + => GenDocGraphic st u -> GenDocGraphic st u -> GenDocGraphic st u a <+> b = a `mappend` space `mappend` b -blank :: InterpretUnit u => DocGraphic u -blank = Doc $ \_ -> posTextPrim (Left "") +blank :: InterpretUnit u => GenDocGraphic st u +blank = GenDoc $ \_ -> posTextPrim (Left "") -space :: InterpretUnit u => DocGraphic u -space = Doc $ \_ -> posCharPrim (Left ' ') +space :: InterpretUnit u => GenDocGraphic st u +space = GenDoc $ \_ -> posCharPrim (Left ' ') -string :: InterpretUnit u => String -> DocGraphic u -string ss = Doc $ \_ -> posTextPrim (Left ss) +string :: InterpretUnit u => String -> GenDocGraphic st u +string ss = GenDoc $ \_ -> posTextPrim (Left ss) -escaped :: InterpretUnit u => EscapedText -> DocGraphic u -escaped esc = Doc $ \_ -> posTextPrim (Right esc) +escaped :: InterpretUnit u => EscapedText -> GenDocGraphic st u +escaped esc = GenDoc $ \_ -> posTextPrim (Right esc) -embedPosObject :: PosObject u a -> Doc u a -embedPosObject ma = Doc $ \_ -> ma +embedPosObject :: GenPosObject st u a -> GenDoc st u a +embedPosObject ma = GenDoc $ \_ -> ma -------------------------------------------------------------------------------- -- Change font weight -bold :: Doc u a -> Doc u a -bold ma = Doc $ \env -> +bold :: GenDoc st u a -> GenDoc st u a +bold ma = GenDoc $ \env -> localize (set_font $ boldWeight $ doc_font_family env) - (getDoc ma env) + (getGenDoc ma env) -italic :: Doc u a -> Doc u a -italic ma = Doc $ \env -> +italic :: GenDoc st u a -> GenDoc st u a +italic ma = GenDoc $ \env -> localize (set_font $ italicWeight $ doc_font_family env) - (getDoc ma env) + (getGenDoc ma env) -boldItalic :: Doc u a -> Doc u a -boldItalic ma = Doc $ \env -> +boldItalic :: GenDoc st u a -> GenDoc st u a +boldItalic ma = GenDoc $ \env -> localize (set_font $ boldItalicWeight $ doc_font_family env) - (getDoc ma env) + (getGenDoc ma env) -------------------------------------------------------------------------------- -- Monospace -monospace :: InterpretUnit u => EscapedChar -> EscapedText -> DocGraphic u -monospace ref_ch esc = Doc $ \_ -> +monospace :: InterpretUnit u + => EscapedChar -> EscapedText -> GenDocGraphic st u +monospace ref_ch esc = GenDoc $ \_ -> monospaceEscText (vector_x <$> escCharVector ref_ch) esc -int :: InterpretUnit u => Int -> DocGraphic u +int :: InterpretUnit u => Int -> GenDocGraphic st u int i = integer $ fromIntegral i -integer :: InterpretUnit u => Integer -> DocGraphic u +integer :: InterpretUnit u => Integer -> GenDocGraphic st u integer i = monospace (CharLiteral '0') (escapeString $ show i) @@ -200,7 +219,7 @@ -- | Specialized version of 'ffloat' - the answer is always -- rendered at \"full precision\". -- -float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u +float :: (RealFloat a, InterpretUnit u) => a -> GenDocGraphic st u float = ffloat Nothing @@ -209,7 +228,8 @@ -- Like 'showFFloat', the answer is rendered to supplied -- precision. @Nothing@ indicated full precision. -- -ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u +ffloat :: (RealFloat a, InterpretUnit u) + => (Maybe Int) -> a -> GenDocGraphic st u ffloat mb d = monospace (CharLiteral '0') $ escapeString $ ($ "") $ showFFloat mb d @@ -222,23 +242,24 @@ -- Decorate strikethrough :: (Fractional u, InterpretUnit u) - => Doc u a -> Doc u a + => GenDoc st u a -> GenDoc st u a strikethrough = decorateDoc SUPERIOR drawStrikethrough underline :: (Fractional u, InterpretUnit u) - => Doc u a -> Doc u a + => GenDoc st u a -> GenDoc st u a underline = decorateDoc SUPERIOR drawUnderline highlight :: (Fractional u, InterpretUnit u) - => RGBi -> Doc u a -> Doc u a + => RGBi -> GenDoc st u a -> GenDoc st u a highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb) decorateDoc :: InterpretUnit u - => ZDeco -> (Orientation u -> LocGraphic u) -> Doc u a -> Doc u a -decorateDoc zdec fn ma = Doc $ \env -> - decoratePosObject zdec fn $ getDoc ma env + => ZDeco -> (Orientation u -> LocGraphic u) -> GenDoc st u a + -> GenDoc st u a +decorateDoc zdec fn ma = GenDoc $ \env -> + decoratePosObject zdec fn $ getGenDoc ma env @@ -289,5 +310,5 @@ mkVec dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy) mkRect dx dy = let w = dx + xmin + xmaj + dx h = dy + ymin + ymaj + dy - in dcRectangle FILL w h + in dcRectangle DRAW_FILL w h diff --git a/src/Wumpus/Drawing/Text/Base/Label.hs b/src/Wumpus/Drawing/Text/Base/Label.hs --- a/src/Wumpus/Drawing/Text/Base/Label.hs +++ b/src/Wumpus/Drawing/Text/Base/Label.hs @@ -42,7 +42,7 @@ ) where -import Wumpus.Drawing.Paths.Absolute +import Wumpus.Drawing.Paths import Wumpus.Basic.Kernel -- package: wumpus-basic diff --git a/src/Wumpus/Drawing/Text/DirectionZero.hs b/src/Wumpus/Drawing/Text/DirectionZero.hs --- a/src/Wumpus/Drawing/Text/DirectionZero.hs +++ b/src/Wumpus/Drawing/Text/DirectionZero.hs @@ -35,19 +35,19 @@ -- Also, reversed argument order would be more convenient as -- RectAddress always short but String could be long. -- -textline :: InterpretUnit u => String -> RectAddress -> BoundedLocGraphic u -textline ss addr = runPosObjectBBox (posText ss) addr +textline :: InterpretUnit u => RectAddress -> String -> BoundedLocGraphic u +textline addr ss = runPosObjectBBox addr (posText ss) -- | Note - this is likely to be moved too... -- rtextline :: (Real u, Floating u, InterpretUnit u) - => Radian -> String -> RectAddress -> BoundedLocGraphic u -rtextline ang ss addr = runPosObjectBBox (rposText ang ss) addr + => Radian -> RectAddress -> String -> BoundedLocGraphic u +rtextline ang addr ss = runPosObjectBBox addr (rposText ang ss) multilineText :: (Fractional u, InterpretUnit u) - => VAlign -> String -> RectAddress -> BoundedLocGraphic u -multilineText va ss addr = runPosObjectBBox (multilinePosText va ss) addr + => VAlign -> RectAddress -> String -> BoundedLocGraphic u +multilineText va addr ss = runPosObjectBBox addr (multilinePosText va ss) diff --git a/src/Wumpus/Drawing/Text/DocSymbols.hs b/src/Wumpus/Drawing/Text/DocSymbols.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/DocSymbols.hs @@ -0,0 +1,78 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.DocSymbols +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Symbols - redefined Basis.Symbols. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.DocSymbols + ( + + ocircle + , small_ocircle + + , empty_box + + , left_slice + , right_slice + + ) + where + +import qualified Wumpus.Drawing.Basis.Symbols as S +import Wumpus.Drawing.Text.Base.DocTextZero + + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +-- import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u +ocircle = embedPosObject $ makePosObject qy gf + where + qy = (\h -> let hh = 0.5 * h in Orientation hh hh 0 h) <$> capHeight + gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.ocircle $ 0.5 * h) + + + +small_ocircle :: (Fractional u, InterpretUnit u) => GenDocGraphic st u +small_ocircle = embedPosObject $ makePosObject qy gf + where + qy = (\h -> let hw = 0.33 * h in Orientation hw hw 0 h) <$> capHeight + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.ocircle $ 0.25 * h) + +empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u +empty_box = embedPosObject $ makePosObject qy gf + where + qy = (\h -> let hw = 0.5 * h in Orientation hw hw 0 h) <$> capHeight + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.empty_box $ 0.66 * h) + + + +left_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u +left_slice = embedPosObject $ makePosObject qy gf + where + qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.left_slice h) + +right_slice :: (Real u, Floating u, InterpretUnit u) => GenDocGraphic st u +right_slice = embedPosObject $ makePosObject qy gf + where + qy = (\h -> let hw = 0.66 * h in Orientation hw hw 0 h) <$> capHeight + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.right_slice h) + +-- More to follow... + diff --git a/src/Wumpus/Drawing/VersionNumber.hs b/src/Wumpus/Drawing/VersionNumber.hs --- a/src/Wumpus/Drawing/VersionNumber.hs +++ b/src/Wumpus/Drawing/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,6,0) +-- > (0,7,0) -- wumpus_drawing_version :: (Int,Int,Int) -wumpus_drawing_version = (0,6,0) +wumpus_drawing_version = (0,7,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.6.0 +version: 0.7.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -38,9 +38,24 @@ . Changelog: . + v0.6.0 to v0.7.0 + . + * Changed paths - @RelPath@ has been removed and there are now + only absolute paths. @PathBuilder@ builds absolute paths. + Pen updating in @PathBuilder@ now works like a State monad + rather than @local@ in a Reader monad. + . + * Changed argument order of the run functions to @monadLib@ + style (params * monadic action) rather than @MTL@ style + (monadic action * params). + . + * Added Symbols to Drawing.Basis. + . + * Added a tube box connector. + . v0.5.0 to v0.6.0 . - * Removed @LocTRace@ and @RefTrace@ from @Wumpus.Drawing.Basis@, + * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@, they are superseded by @LocDrawing@ in Wumpus-Basic. . * Remaned path building operations in @RelPathBuilder@. @@ -75,12 +90,13 @@ build-depends: base < 5, containers >= 0.3 && <= 0.6, vector-space >= 0.6 && < 1.0, - wumpus-core >= 0.51.0 && < 0.52.0, - wumpus-basic == 0.21.0 + wumpus-core >= 0.52.0 && < 0.53.0, + wumpus-basic == 0.22.0 exposed-modules: Wumpus.Drawing.Basis.DrawingPrimitives, + Wumpus.Drawing.Basis.Symbols, Wumpus.Drawing.Colour.SVGColours, Wumpus.Drawing.Colour.X11Colours, Wumpus.Drawing.Connectors, @@ -88,17 +104,16 @@ Wumpus.Drawing.Connectors.Base, Wumpus.Drawing.Connectors.BoxConnectors, Wumpus.Drawing.Connectors.ConnectorPaths, + Wumpus.Drawing.Connectors.ConnectorProps, Wumpus.Drawing.Dots.AnchorDots, Wumpus.Drawing.Dots.SimpleDots, Wumpus.Drawing.Extras.Axes, Wumpus.Drawing.Extras.Clip, Wumpus.Drawing.Extras.Grids, Wumpus.Drawing.Extras.Loop, - Wumpus.Drawing.Paths.Absolute, - Wumpus.Drawing.Paths.Base.AbsPath, - Wumpus.Drawing.Paths.Base.PathBuilder, - Wumpus.Drawing.Paths.Base.RelPath, - Wumpus.Drawing.Paths.Relative, + Wumpus.Drawing.Paths, + Wumpus.Drawing.Paths.Base, + Wumpus.Drawing.Paths.PathBuilder, Wumpus.Drawing.Paths.Vamps, Wumpus.Drawing.Shapes, Wumpus.Drawing.Shapes.Base, @@ -117,6 +132,7 @@ Wumpus.Drawing.Text.Base.DocTextZero, Wumpus.Drawing.Text.Base.Label, Wumpus.Drawing.Text.DirectionZero, + Wumpus.Drawing.Text.DocSymbols, Wumpus.Drawing.Text.StandardFontDefs, Wumpus.Drawing.VersionNumber