diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -65,12 +65,12 @@ atext a3 "+1" a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0 atext a4 "DELAY 0" - connWith connline (east a1) ((.+^ hvec 76) $ east a1) - connWith connline (east a2) ((.+^ hvec 180) $ east a2) - connWith connline ((.+^ vvec 40) $ north a2) (north a2) - connWith connline ((.+^ vvec 16) $ north a3) (north a3) - connWith connaright (south a3) (east a4) - connWith connabar (west a4) (southwest a2) + connWith conn_line (east a1) ((.+^ hvec 76) $ east a1) + connWith conn_line (east a2) ((.+^ hvec 180) $ east a2) + connWith conn_line ((.+^ vvec 40) $ north a2) (north a2) + connWith conn_line ((.+^ vvec 16) $ north a3) (north a3) + connWith conna_right (south a3) (east a4) + connWith conna_orthovbar (west a4) (southwest a2) ptext (P2 40 10) "next" ptext (P2 152 100) "reset" ptext (P2 252 72) "output" @@ -79,9 +79,9 @@ -- Note - need a variant of /bar/ that draws UDLR only. connWith :: ( Real u, Floating u, InterpretUnit u ) - => ConnectorPathQuery u -> Anchor u -> Anchor u -> TraceDrawing u () + => ArrowConnector u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $ - drawc a0 a1 (rightArrow tri45 con) + drawc a0 a1 (ignoreAns con) atext :: ( CenterAnchor (t u), u ~ DUnit (t u) @@ -110,15 +110,28 @@ -- Cf. Parsec\'s Token module... -connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u -connline = C.connline default_connector_props +conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conn_line = + renderConnectorConfig default_connector_props $ makeSglArrConn C.conn_line -connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => ConnectorPathQuery u -connabar = C.connabar default_connector_props +conna_orthovbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conna_orthovbar = + renderConnectorConfig default_connector_props $ + makeSglArrConn C.conna_orthovbar -connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => ConnectorPathQuery u -connaright = C.connaright default_connector_props +conna_right :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conna_right = + renderConnectorConfig default_connector_props $ makeSglArrConn C.conna_right + +makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u +makeSglArrConn cspec = + ConnectorConfig + { conn_arrowl = Nothing + , conn_arrowr = Just tri45 + , conn_path_spec = cspec + } diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -37,7 +37,7 @@ arrow_drawing :: CtxPicture arrow_drawing = - drawTracing $ localize dotted_line $ tableGraphic arrtable + drawTracing $ localize line_thick $ tableGraphic arrtable arrtable :: [(String, ArrowTip)] arrtable = @@ -77,8 +77,7 @@ tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = - drawl start $ runTableColumnwise 18 (180,24) - $ sequenceChain $ map arrowGraphic tips + drawl start $ distribColumnwiseTable 18 (180,24) $ map arrowGraphic tips where start = P2 0 480 @@ -94,13 +93,15 @@ arrowGraphic (name, utip) = aconn `mappend` lbl where aconn = ignoreAns $ promoteLoc $ \pt -> - connect (uniformArrow utip connline) pt (displace (hvec 60) pt) + connect (mkConn_line utip) pt (displace (hvec 60) pt) lbl = ignoreAns $ promoteLoc $ \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 +mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowTip -> ArrowConnector u +mkConn_line = rightArrowConnector default_connector_props C.conn_line + + diff --git a/demo/Automata.hs b/demo/Automata.hs --- a/demo/Automata.hs +++ b/demo/Automata.hs @@ -79,20 +79,19 @@ -straightconn :: ( Real u, Floating u, InterpretUnit u +straightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u , u ~ DUnit a, u ~ DUnit b , CenterAnchor a, RadialAnchor a , CenterAnchor b, RadialAnchor b ) => a -> b -> Image u (AbsPath u) straightconn a b = - let (p0,p1) = radialConnectorPoints a b - in connect (rightArrow tri45 connline) p0 p1 + let (p0,p1) = radialConnectorPoints a b in connect conn_line p0 p1 -astraightconn :: ( Real u, Floating u, InterpretUnit u) +astraightconn :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Anchor u -> Anchor u -> Image u (AbsPath u) -astraightconn p0 p1 = connect (rightArrow tri45 connline) p0 p1 +astraightconn p0 p1 = connect conn_line p0 p1 -- Note - there is a problem with @rightArrow@ as @loop@ @@ -101,8 +100,7 @@ arrloop :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Anchor u -> Anchor u -> Image u (AbsPath u) arrloop ctr p1 = - liftQuery (loop zradius ctr zincl) >>= \absp -> - rightArrowPath tri45 absp + rightArrowPath $ loopPath zradius ctr zincl where v1 = pvec ctr p1 zradius = vlength v1 @@ -111,9 +109,13 @@ -- Cf. Parsec\'s Token module... -connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u -connline = C.connline default_connector_props +conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conn_line = rightArrowConnector default_connector_props C.conn_line tri45 +rightArrowPath :: (Real u, Floating u, InterpretUnit u) + => AbsPath u -> Image u (AbsPath u) +rightArrowPath = arrowDecoratePath Nothing (Just tri45) diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -68,7 +68,7 @@ background rgb = promoteLoc $ \_ -> ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 where - ihh = runTableColumnwise 18 (86,16) $ mapM chain1 $ replicate 112 iheartHaskell + ihh = distribColumnwiseTable 18 (86,16) $ replicate 112 iheartHaskell -- | This is one for Wumpus-Basic - the set of combinators to 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 chn (mapM chain1 gs)) `at` pt +tableGraphic row_count xs = + drawl pt $ distribColumnwiseTable row_count (152,11) gs where - chn = tableColumnwiseScm row_count (152,11) pt = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt gs = map (uncurry colourSample) xs diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -38,39 +38,47 @@ conn_pic = drawTracing $ tableGraphic conntable -conntable :: [(String, ConnectorPathQuery Double)] +conntable :: [(String, ConnectorPathSpec Double)] conntable = - [ ("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) + [ ("conn_line", C.conn_line) + , ("conna_arc", C.conna_arc) + , ("connb_arc", C.connb_arc) + , ("conn_hdiagh", C.conn_hdiagh) + , ("conn_vdiagv", C.conn_vdiagv) + , ("conn_diagh", C.conn_diagh) + , ("conn_diagv", C.conn_diagv) + , ("conn_hdiag", C.conn_hdiag) + , ("conn_vdiag", C.conn_vdiag) + , ("conna_bar", C.conna_bar) + , ("connb_bar", C.connb_bar) + , ("conna_flam", C.conna_flam) + , ("connb_flam", C.connb_flam) + , ("conna_orthohbar", C.conna_orthohbar) + , ("connb_orthohbar", C.connb_orthohbar) + , ("conna_orthovbar", C.conna_orthovbar) + , ("connb_orthovbar", C.connb_orthovbar) + , ("conna_right", C.conna_right) + , ("connb_right", C.connb_right) + , ("conn_hrr", C.conn_hrr ) + , ("conn_rrh", C.conn_rrh) + , ("conn_vrr", C.conn_vrr) + , ("conn_rrv", C.conn_rrv) + , ("conna_loop", C.conna_loop) + , ("connb_loop", C.connb_loop) + , ("conn_hbezier", C.conn_hbezier) + , ("conn_vbezier", C.conn_vbezier) ] - where - props = default_connector_props { conn_dst_arm = 2 - , conn_src_space = 0.5 - , conn_dst_space = 0.5 } +props :: ConnectorProps +props = default_connector_props { conn_src_arm = 1 + , conn_dst_arm = 1.5 + , conn_src_space = 0.5 + , conn_dst_space = 0.5 } -tableGraphic :: [(String, ConnectorPathQuery Double)] -> TraceDrawing Double () + +tableGraphic :: [(String, ConnectorPathSpec Double)] -> TraceDrawing Double () tableGraphic conns = - drawl start $ ignoreAns $ runTableColumnwise 8 (180,64) - $ mapM (chain1 . makeConnDrawing) conns + drawl start $ distribColumnwiseTable 6 (200,80) $ map makeConnDrawing conns where start = P2 0 520 @@ -80,15 +88,24 @@ -makeConnDrawing :: (String, ConnectorPathQuery Double) -> DLocGraphic +makeConnDrawing :: (String, ConnectorPathSpec Double) -> DLocGraphic makeConnDrawing (ss,conn) = - promoteLoc $ \p0 -> fn p0 (displace (vec 60 40) p0) + promoteLoc $ \p0 -> fn p0 (displace (vec 72 42) p0) where fn p0 p1 = mconcat [disk p0, disk p1, dcon p0 p1, lbl p1] disk pt = localize (fill_colour red) $ dcDisk DRAW_FILL 2 `at` pt - dcon p0 p1 = ignoreAns $ connect (uniformArrow curveTip conn) p0 p1 + dcon p0 p1 = ignoreAns $ connect biarrow p0 p1 - lbl pt = ignoreAns $ textline WW ss `at` (displace (hvec 10) pt) + lbl pt = ignoreAns $ textline WW ss `at` (displace (V2 10 (-10)) pt) + biarrow = renderConnectorConfig props conf + + + conf = ConnectorConfig { conn_arrowl = Just curveTip + , conn_arrowr = Just curveTip + , conn_path_spec = conn + } + + diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -72,8 +72,8 @@ tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = - drawl pt $ runTableColumnwise row_count (180,36) - $ mapM (chain1 . makeDotDrawing) imgs + drawl pt $ distribColumnwiseTable row_count (180,36) + $ map makeDotDrawing imgs where row_count = 18 pt = displace (vvec $ fromIntegral $ 36 * row_count) zeroPt diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -87,35 +87,35 @@ widebox = makeBox 60 -connWith :: ( Real u, Floating u, InterpretUnit u ) +connWith :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => ArrowTip -> Box u -> Box u -> TraceDrawing u (AbsPath u) connWith arrh b0 b1 = do lw <- getLineWidth let p0 = south b0 let p1 = projectAnchor north (realToFrac lw) b1 - drawi $ connect (rightArrow arrh connline) p0 p1 + drawi $ connect (mkConn_line arrh) p0 p1 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` -cmandatory :: ( Real u, Floating u, InterpretUnit u ) +cmandatory :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Box u -> Box u -> TraceDrawing u (AbsPath u) cmandatory = connWith diskTip -coptional :: ( Real u, Floating u, InterpretUnit u ) +coptional :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Box u -> Box u -> TraceDrawing u (AbsPath u) coptional = connWith odiskTip -cmandatory_ :: ( Real u, Floating u, InterpretUnit u ) +cmandatory_ :: ( Real u, Floating u, InterpretUnit u, Tolerance u) => Box u -> Box u -> TraceDrawing u () cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () -coptional_ :: ( Real u, Floating u, InterpretUnit u ) +coptional_ :: ( Real u, Floating u, InterpretUnit u, Tolerance 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 +mkConn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowTip -> ArrowConnector u +mkConn_line = rightArrowConnector default_connector_props C.conn_line diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -82,7 +82,7 @@ fontDrawing xs = drawTracing $ drawl start $ runChain_ chn_alg $ mapM (chain1 . uncurry fontGraphic) xs where - chn_alg = tableColumnwiseScm 4 (2,180) + chn_alg = columnwiseTableScheme 4 (2,180) start = P2 0 (4*180) diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs --- a/demo/PetriNet.hs +++ b/demo/PetriNet.hs @@ -99,22 +99,29 @@ +makeSglArrConn :: ConnectorPathSpec u -> ConnectorConfig u +makeSglArrConn cspec = + ConnectorConfig + { conn_arrowl = Nothing + , conn_arrowr = Just tri45 + , conn_path_spec = cspec + } straightconn :: ConnectorGraphic Double -straightconn = ignoreAns $ rightArrow tri45 connline +straightconn = ignoreAns conn_line connectorC :: ConnectorGraphic Double -connectorC = ignoreAns $ rightArrow tri45 connbbar +connectorC = ignoreAns conna_bar connectorC' :: ConnectorGraphic Double -connectorC' = ignoreAns $ rightArrow tri45 connabar +connectorC' = ignoreAns connb_bar connectorD :: ConnectorGraphic Double -connectorD = ignoreAns $ rightArrow tri45 connarc +connectorD = ignoreAns conna_arc connectorD' :: ConnectorGraphic Double -connectorD' = ignoreAns $ rightArrow tri45 connarc +connectorD' = ignoreAns connb_arc lblParensParens :: DLocGraphic @@ -140,21 +147,25 @@ , 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 +conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conn_line = renderConnectorConfig conn_props $ makeSglArrConn C.conn_line -connabar :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => ConnectorPathQuery u -connabar = C.connabar conn_props +conna_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conna_bar = renderConnectorConfig conn_props $ makeSglArrConn C.conna_bar -connbbar :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => ConnectorPathQuery u -connbbar = C.connbbar conn_props +connb_bar :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +connb_bar = renderConnectorConfig conn_props $ makeSglArrConn C.connb_bar -connarc :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => ConnectorPathQuery u -connarc = C.connarc conn_props +conna_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conna_arc = renderConnectorConfig conn_props $ makeSglArrConn C.conna_arc + +connb_arc :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +connb_arc = renderConnectorConfig conn_props $ makeSglArrConn C.connb_arc diff --git a/demo/SampleShapes.hs b/demo/SampleShapes.hs --- a/demo/SampleShapes.hs +++ b/demo/SampleShapes.hs @@ -68,7 +68,7 @@ , shapePic (apexAnchor >=> bottomCorners) $ semiellipse 100 150) , ( "trapezium" , shapePic (bottomCorners >=> topCorners >=> midPoints 4) $ - trapezium 300 200 150) + trapezium 300 180 ang60) , ( "triangle" , shapePic (apexAnchor >=> bottomCorners >=> midPoints 3) $ triangle 300 150 ) @@ -137,7 +137,7 @@ => (t Double -> DTraceDrawing a) -> DShape t -> String -> CtxPicture shapePic mf sh name = udrawTracing (0::Double) $ do a1 <- localize shapeSty $ drawi $ - uniformScale 2 $ rotate05 $ shape `at` (P2 100 0) + uniformScale 2 $ {- rotate05 $ -} shape `at` (P2 100 0) draw $ label NORTH "(center)" `at` center a1 draw $ label NORTH "(north)" `at` north a1 draw $ label SOUTH "(south)" `at` south a1 @@ -147,22 +147,20 @@ draw $ label NORTH_WEST "(northwest)" `at` northwest a1 draw $ label SOUTH_EAST "(southeast)" `at` southeast a1 draw $ label SOUTH_WEST "(southwest)" `at` southwest a1 - draw $ label EAST "(10 deg)" `at` radialAnchor deg10 a1 - draw $ label NORTH_WEST "(110 deg)" `at` radialAnchor deg110 a1 - draw $ label WEST "(190 deg)" `at` radialAnchor deg190 a1 - draw $ label NORTH "(250 deg)" `at` radialAnchor deg250 a1 + draw $ label EAST "(10 deg)" `at` radialAnchor (d2r 10) a1 + draw $ label NORTH_WEST "(110 deg)" `at` radialAnchor (d2r 110) a1 + draw $ label WEST "(190 deg)" `at` radialAnchor (d2r 190) a1 + draw $ label NORTH "(250 deg)" `at` radialAnchor (d2r 250) a1 + draw $ label WEST "(200 deg)" `at` radialAnchor (d2r 200) a1 + +-- draw $ label WEST "(0 deg)" `at` radialAnchor (d2r 0) a1 + draw $ label NORTH "(224.5 deg)" `at` radialAnchor (d2r 225.5) a1 _ <- mf a1 return () where shape = strokedShape $ setDecoration textF sh textF = promoteLocTheta $ \pt _ -> ignoreAns (multilineText VALIGN_CENTER CENTER name) `at` pt - - deg10 = d2r (10::Double) - deg110 = d2r (110::Double) - deg190 = d2r (190::Double) - deg250 = d2r (250::Double) - diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -2,7 +2,6 @@ module Symbols where -import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Basis.Symbols import Wumpus.Drawing.Colour.SVGColours import Wumpus.Drawing.Text.DirectionZero @@ -13,6 +12,7 @@ import Wumpus.Core -- package: wumpus-core +import Data.Monoid import System.Directory @@ -30,7 +30,7 @@ makeCtx :: FontLoadResult -> DrawingContext -makeCtx = set_font times_roman . metricsContext 14 +makeCtx = fill_colour khaki . set_font times_roman . metricsContext 14 symb_pic :: CtxPicture symb_pic = drawTracing $ tableGraphic symbtable @@ -38,17 +38,30 @@ symbtable :: [(String, LocGraphic Double)] symbtable = - [ ("ocircle", ocircle 8) + [ ("scircle", scircle 8) + , ("fcircle", fcircle 8) + , ("fscircle", fscircle 8) + , ("ssquare", ssquare 8) + , ("fsquare", fsquare 8) + , ("fssquare", fssquare 8) + , ("sleft_slice", sleft_slice 14) + , ("fleft_slice", fleft_slice 14) + , ("fsleft_slice", fsleft_slice 14) + , ("sright_slice", sright_slice 14) + , ("fright_slice", fright_slice 14) + , ("fsright_slice", fsright_slice 14) + , ("sleft_triangle", sleft_triangle 14) + , ("fleft_triangle", fleft_triangle 14) + , ("fsleft_triangle", fsleft_triangle 14) + , ("sright_triangle", sright_triangle 14) + , ("fright_triangle", fright_triangle 14) + , ("fsright_triangle", fsright_triangle 14) , ("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) @@ -58,8 +71,8 @@ tableGraphic :: [(String, LocGraphic Double)] -> TraceDrawing Double () tableGraphic symbs = - drawl start $ ignoreAns $ runTableColumnwise 8 (180,24) - $ mapM (chain1 . makeSymbDrawing) symbs + drawl start $ ignoreAns $ distribColumnwiseTable 14 (180,24) + $ map makeSymbDrawing symbs where start = P2 0 520 diff --git a/src/Wumpus/Drawing/Basis/BezierCurve.hs b/src/Wumpus/Drawing/Basis/BezierCurve.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/BezierCurve.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.BezierCurve +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Datatype for cubic Bezier curve. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.BezierCurve + ( + + BezierCurve(..) + , vbezierCurve + , subdivide + , subdividet + + , bezierLength + + ) where + + +import Wumpus.Drawing.Basis.Geometry + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +-------------------------------------------------------------------------------- + + + +-- | A Strict cubic Bezier curve. +-- +data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u) + deriving (Eq,Ord,Show) + +type instance DUnit (BezierCurve u) = u + + + +vbezierCurve :: Num u + => Vec2 u -> Vec2 u -> Vec2 u -> Point2 u -> BezierCurve u +vbezierCurve v1 v2 v3 p0 = BezierCurve p0 p1 p2 p3 + where + p1 = p0 .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + + + +-- | Curve subdivision via de Casteljau\'s algorithm. +-- +subdivide :: Fractional u + => BezierCurve u -> (BezierCurve u, BezierCurve u) +subdivide (BezierCurve p0 p1 p2 p3) = + (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3) + where + p01 = midpoint p0 p1 + p12 = midpoint p1 p2 + p23 = midpoint p2 p3 + p012 = midpoint p01 p12 + p123 = midpoint p12 p23 + p0123 = midpoint p012 p123 + + +-- | subdivide with an affine weight along the line... +-- +subdividet :: Real u + => u -> BezierCurve u -> (BezierCurve u, BezierCurve u) +subdividet t (BezierCurve p0 p1 p2 p3) = + (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3) + where + p01 = affineComb t p0 p1 + p12 = affineComb t p1 p2 + p23 = affineComb t p2 p3 + p012 = affineComb t p01 p12 + p123 = affineComb t p12 p23 + p0123 = affineComb t p012 p123 + + +-------------------------------------------------------------------------------- + +-- | 'bezierLength' : @ start_point * control_1 * control_2 * +-- end_point -> Length @ +-- +-- Find the length of a Bezier curve. The result is an +-- approximation, with the /tolerance/ is 0.1 of a point. This +-- seems good enough for drawing (potentially the tolerance could +-- be larger still). +-- +-- The result is found through repeated subdivision so the +-- calculation is potentially costly. +-- +bezierLength :: (Floating u, Ord u, Tolerance u) + => BezierCurve u -> u +bezierLength = gravesenLength length_tolerance + + + +-- | Jens Gravesen\'s bezier arc-length approximation. +-- +-- Note this implementation is parametrized on error tolerance. +-- +gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u +gravesenLength err_tol crv = step crv + where + step c = let l1 = ctrlPolyLength c + l0 = cordLength c + in if l1-l0 > err_tol + then let (a,b) = subdivide c in step a + step b + else 0.5*l0 + 0.5*l1 + +-- | Length of the tree lines spanning the control points. +-- +ctrlPolyLength :: Floating u => BezierCurve u -> u +ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3 + where + len pa pb = vlength $ pvec pa pb + + +-- | Length of the cord - start point to end point. +-- +cordLength :: Floating u => BezierCurve u -> u +cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3 + + 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 @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Basis.DrawingPrimitives --- Copyright : (c) Stephen Tetley 2011 +-- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -27,34 +27,27 @@ module Wumpus.Drawing.Basis.DrawingPrimitives ( - -- * Monoid mappend - (<>) -- * Lines - , horizontalLine + horizontalLine , verticalLine , pivotLine - , oStraightLines - , cStraightLines - -- * Rectangles , blRectangle , ctrRectangle - -- * Arc and wedge - , arc + -- * Wedge , wedge ) where -import Wumpus.Basic.Geometry -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -63,18 +56,7 @@ import Data.Monoid -infixr 6 <> - --- | Alias for mappend in Monoid. --- --- > <> (infixr 6) --- -(<>) :: Monoid a => a -> a -> a -(<>) = mappend - - - -------------------------------------------------------------------------------- -- Lines @@ -102,17 +84,8 @@ straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru) --- | Draw an open path formed from straight line segments. --- -oStraightLines :: InterpretUnit u => [Point2 u] -> Graphic u -oStraightLines ps = liftQuery (vertexPP ps) >>= dcOpenPath --- | Draw an closed path formed from straight line segments. --- -cStraightLines :: InterpretUnit u => DrawMode -> [Point2 u] -> Graphic u -cStraightLines mode ps = liftQuery (vertexPP ps) >>= dcClosedPath mode - -------------------------------------------------------------------------------- -- Rectangles @@ -141,12 +114,6 @@ -- Wedge --- | arc : radius * apex_angle --- -arc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u -arc radius ang = promoteLocTheta $ \pt inclin -> - let ps = bezierArcPoints ang radius inclin pt - in liftQuery (curvePP ps) >>= dcOpenPath -- | wedge : mode * radius * apex_angle -- @@ -158,8 +125,8 @@ 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) + w_arc = circularArc CW ang radius (inclin - half_pi) ct = line_in `mappend` w_arc `mappend` line_out - in supplyLoc pt $ drawCatTrail (closedMode mode) ct + in supplyLoc pt $ renderCatTrail (closedMode mode) ct diff --git a/src/Wumpus/Drawing/Basis/Geometry.hs b/src/Wumpus/Drawing/Basis/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/Geometry.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.Geometry +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Misc geometric operations. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.Geometry + ( + + midpoint + , affineComb + + ) where + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +-------------------------------------------------------------------------------- + + + +-------------------------------------------------------------------------------- +-- + + +-- | Affine combination... +-- +affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u +affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1) + + +-- | 'midpoint' : @ start_point * end_point -> Midpoint @ +-- +-- Mid-point on the line formed between the two supplied points. +-- +midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u +midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0 diff --git a/src/Wumpus/Drawing/Basis/InclineTrails.hs b/src/Wumpus/Drawing/Basis/InclineTrails.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/InclineTrails.hs @@ -0,0 +1,499 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.InclineTrails +-- Copyright : (c) Stephen Tetley 2011-2012 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.InclineTrails + ( + + incline_circle + , incline_ellipse + , incline_square + , incline_rect + , incline_diamond + , incline_triangle + , incline_barb + , incline_tube + , incline_chamf_rect + + , trail_diagh + , trail_diagv + , trail_hdiag + , trail_vdiag + + , trail_hdiagh + , trail_vdiagv + + , trail_perp_bar + , trail_perp_bar2 + + , trail_vflam + , trail_ortho_hbar + , trail_ortho_vbar + + , trail_hright + , trail_vright + + , trail_hrr + , trail_vrr + , trail_rrh + , trail_rrv + + , trail_rect_loop + + , vtriCurve + , vrectCurve + , vtrapCurve + , vbowCurve + , vwedgeCurve + + ) + where + + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Data.Monoid + + +-- Shapes... + +incline_circle :: (Real u, Floating u) => Vec2 u -> AnaTrail u +incline_circle v1 = + anaCatTrail zeroVec (semicircleTrail CW v1 <> semicircleTrail CW rv1) + where + rv1 = vreverse v1 + +incline_ellipse :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u +incline_ellipse ry v1 = + anaCatTrail zeroVec (semiellipseTrail CW ry v1 <> semiellipseTrail CW ry rv1) + where + rv1 = vreverse v1 + + + +incline_square :: (Real u, Floating u) => Vec2 u -> AnaTrail u +incline_square v1 = incline_rect (vlength v1) v1 + + +incline_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u +incline_rect h v1 = + anaCatTrail (theta_down (0.5 * h) ang) catt + where + len = vlength v1 + ang = vdirection v1 + catt = mconcat [ trail_theta_right len ang + , trail_theta_up h ang + , trail_theta_left len ang + , trail_theta_down h ang + ] + +incline_diamond :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u +incline_diamond h v1 = anaCatTrail zeroVec catt + where + hw = 0.5 * vlength v1 + hh = 0.5 * h + ang = vdirection v1 + catt = mconcat [ orthoCatTrail hw (-hh) ang + , orthoCatTrail hw hh ang + , orthoCatTrail (-hw) hh ang + , orthoCatTrail (-hw) (-hh) ang + ] + +-- | Note - vector represents midpoint of the baseline to the +-- tip. Angle is the ang of the tip. +-- +-- This trail is primarily for drawing arrowheads. +-- +incline_triangle :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u +incline_triangle tip_ang v1 = + anaCatTrail (theta_up opposite theta) catt + where + half_ang = 0.5 * tip_ang + theta = vdirection v1 + h = vlength v1 + opposite = h * (fromRadian $ tan half_ang) + + catt = mconcat [ trail_theta_adj_grazing h half_ang theta + , trail_theta_bkwd_adj_grazing h half_ang theta + , trail_theta_up (2 * opposite) theta + ] + + +-- | Note - vector represents midpoint of the baseline to the +-- tip. Angle is the ang of the tip. +-- +-- This trail is primarily for drawing arrowheads. The resulting +-- path is /open/. +-- +incline_barb :: (Real u, Floating u) => Radian -> Vec2 u -> AnaTrail u +incline_barb tip_ang v1 = + anaCatTrail (theta_up opposite theta) catt + where + half_ang = 0.5 * tip_ang + theta = vdirection v1 + h = vlength v1 + opposite = h * (fromRadian $ tan half_ang) + + catt = mconcat [ trail_theta_adj_grazing h half_ang theta + , trail_theta_bkwd_adj_grazing h half_ang theta + ] + + +-- | @v1@ is the /interior/ vector. +-- +incline_tube :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u +incline_tube h v1 = + anaCatTrail (theta_down_right hh ang) $ mconcat $ + [ trail_theta_right base_len ang + , semicircleTrail CCW vup + , trail_theta_left base_len ang + , semicircleTrail CCW vdown + ] + where + hh = 0.5 * h + ang = vdirection v1 + base_len = vlength v1 - h + vup = avec (ang + half_pi) h + vdown = avec (ang - half_pi) h + + +incline_chamf_rect :: (Real u, Floating u) => u -> Vec2 u -> AnaTrail u +incline_chamf_rect h v1 = + anaCatTrail zeroVec $ mconcat $ + [ trail_theta_down_right hh ang + , trail_theta_right base_len ang + , trail_theta_up_right hh ang + , trail_theta_up_left hh ang + , trail_theta_left base_len ang + , trail_theta_down_left hh ang + ] + where + hh = 0.5 * h + ang = vdirection v1 + base_len = vlength v1 - h + +-- | Diagonal-horizontal trail. +-- +-- > --@ +-- > / +-- > o +-- +trail_diagh :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u +trail_diagh leg v1 = + let h = vector_y v1 + mid = (abs $ vector_x v1) - leg + in case horizontalDirection $ vdirection v1 of + RIGHTWARDS -> orthoCatTrail mid h 0 <> trail_right leg + _ -> orthoCatTrail (-mid) h 0 <> trail_left leg + +trail_diagv :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u +trail_diagv leg v1 = + let w = vector_x v1 + mid = (abs $ vector_y v1) - leg + in case verticalDirection $ vdirection v1 of + UPWARDS -> orthoCatTrail w mid 0 <> trail_up leg + _ -> orthoCatTrail w (-mid) 0 <> trail_down leg + + +trail_hdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u +trail_hdiag leg v1 = + let h = vector_y v1 + mid = (abs $ vector_x v1) - leg + in case horizontalDirection $ vdirection v1 of + RIGHTWARDS -> trail_right leg <> orthoCatTrail mid h 0 + _ -> trail_left leg <> orthoCatTrail (-mid) h 0 + + +trail_vdiag :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u +trail_vdiag leg v1 = + let w = vector_x v1 + mid = (abs $ vector_y v1) - leg + in case verticalDirection $ vdirection v1 of + UPWARDS -> trail_up leg <> orthoCatTrail w mid 0 + _ -> trail_down leg <> orthoCatTrail w (-mid) 0 + + + +-- | Horizontal-diagonal-horizontal trail. +-- +-- > --@ +-- > / +-- > o-- +-- +-- +trail_hdiagh :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u +trail_hdiagh legl legr v1 = + let h = vector_y v1 + mid = (abs $ vector_x v1) - (legl + legr) + in case horizontalDirection $ vdirection v1 of + RIGHTWARDS -> mconcat [ trail_right legl + , orthoCatTrail mid h 0 + , trail_right legr + ] + _ -> mconcat [ trail_left legl + , orthoCatTrail (-mid) h 0 + , trail_left legr + ] + + + +trail_vdiagv :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u +trail_vdiagv legl legr v1 = + let w = vector_x v1 + mid = (abs $ vector_y v1) - (legl + legr) + in case verticalDirection $ vdirection v1 of + UPWARDS -> mconcat [ trail_up legl + , orthoCatTrail w mid 0 + , trail_up legr + ] + _ -> mconcat [ trail_down legl + , orthoCatTrail w (-mid) 0 + , trail_down legr + ] + +-- | Uniform leg size. +-- +trail_perp_bar :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +trail_perp_bar CW h v1 = trail_perp_barCW h v1 +trail_perp_bar _ h v1 = trail_perp_barCW (-h) v1 + + +trail_perp_barCW :: (Real u, Floating u) => u -> Vec2 u -> CatTrail u +trail_perp_barCW h v1 = + trail_theta_up h ang <> catline v1 <> trail_theta_down h ang + where + ang = vdirection v1 + + +-- | Bar connector - independent leg size, legs perpendicular. +-- +-- +-- > o @ +-- > | | +-- > '----' +-- +-- The bar is drawn /below/ the points. +-- +trail_perp_bar2 :: (Real u, Floating u) + => ClockDirection -> u -> u -> Vec2 u -> CatTrail u +trail_perp_bar2 CW h1 h2 v1 = trail_perp_barCW2 h1 h2 v1 +trail_perp_bar2 _ h1 h2 v1 = trail_perp_barCW2 (-h1) (-h2) v1 + + +trail_perp_barCW2 :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u +trail_perp_barCW2 h1 h2 v1 = + trail_theta_up h1 ang + <> orthoCatTrail (vlength v1) (negate $ h1 - h2) ang + <> trail_theta_down h2 ang + where + ang = vdirection v1 + + +-- | Independent leg size. +-- +trail_vflam :: (Real u, Floating u) + => ClockDirection -> u -> u -> Vec2 u -> CatTrail u +trail_vflam CW h1 h2 v1 = trail_vflamCW h1 h2 v1 +trail_vflam _ h1 h2 v1 = trail_vflamCW (-h1) (-h2) v1 + + +trail_vflamCW :: (Real u, Floating u) => u -> u -> Vec2 u -> CatTrail u +trail_vflamCW h1 h2 v1 = + diffLines [ p0, p0 .+^ vvec h1, p1 .+^ vvec h2, p1 ] + where + p0 = zeroPt + p1 = p0 .+^ v1 + + +-- | Height is minimum leg height. Ortho bar is horizontal. +-- +trail_ortho_hbar :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +trail_ortho_hbar CW h v1 = trail_ortho_hbarCW h v1 +trail_ortho_hbar _ h v1 = trail_ortho_hbarCCW h v1 + + +trail_ortho_hbarCW :: (Real u, Floating u) + => u -> Vec2 u -> CatTrail u +trail_ortho_hbarCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of + QUAD_NE -> trail_up ymaj <> trail_right x <> trail_down ymin + QUAD_SE -> trail_up ymin <> trail_right x <> trail_down ymaj + QUAD_NW -> trail_down ymin <> trail_left (abs x) <> trail_up ymaj + QUAD_SW -> trail_down ymaj <> trail_left (abs x) <> trail_up ymin + where + ymaj = ymin + abs y + + + + +trail_ortho_hbarCCW :: (Real u, Floating u) + => u -> Vec2 u -> CatTrail u +trail_ortho_hbarCCW ymin v1@(V2 x y) = case quadrant $ vdirection v1 of + QUAD_NE -> trail_down ymin <> trail_right x <> trail_up ymaj + QUAD_SE -> trail_down ymaj <> trail_right x <> trail_up ymin + QUAD_NW -> trail_up ymaj <> trail_left (abs x) <> trail_down ymin + QUAD_SW -> trail_up ymin <> trail_left (abs x) <> trail_down ymaj + where + ymaj = ymin + abs y + + + + +-- | Width is minimum leg width. Ortho bar is vertical. +-- +trail_ortho_vbar :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +trail_ortho_vbar CW w v1 = trail_ortho_vbarCW w v1 +trail_ortho_vbar _ w v1 = trail_ortho_vbarCCW w v1 + + +trail_ortho_vbarCW :: (Real u, Floating u) + => u -> Vec2 u -> CatTrail u +trail_ortho_vbarCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of + QUAD_NE -> trail_left xmin <> trail_up y <> trail_right xmaj + QUAD_NW -> trail_left xmaj <> trail_up y <> trail_right xmin + QUAD_SE -> trail_right xmaj <> trail_down (abs y) <> trail_left xmin + QUAD_SW -> trail_right xmin <> trail_down (abs y) <> trail_left xmaj + where + xmaj = xmin + abs x + + + +trail_ortho_vbarCCW :: (Real u, Floating u) + => u -> Vec2 u -> CatTrail u +trail_ortho_vbarCCW xmin v1@(V2 x y) = case quadrant $ vdirection v1 of + QUAD_NE -> trail_right xmaj <> trail_up y <> trail_left xmin + QUAD_NW -> trail_right xmin <> trail_up y <> trail_left xmaj + QUAD_SE -> trail_left xmin <> trail_down (abs y) <> trail_right xmaj + QUAD_SW -> trail_left xmaj <> trail_down (abs y) <> trail_right xmin + where + xmaj = xmin + abs x + + +trail_hright :: Num u => Vec2 u -> CatTrail u +trail_hright (V2 x y) = trail_right x <> trail_up y + + +trail_vright :: Num u => Vec2 u -> CatTrail u +trail_vright (V2 x y) = trail_up y <> trail_right x + +trail_hrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u +trail_hrr x1 (V2 x y) = + trail_theta_right x1 ang + <> trail_theta_up y ang + <> trail_theta_right (abs x - x1) ang + where + ang = if x < 0 then pi else 0 + +trail_vrr :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u +trail_vrr y1 (V2 x y) = + trail_theta_up y1 ang + <> trail_theta_right x ang + <> trail_theta_up (abs y - y1) ang + where + ang = if y < 0 then pi else 0 + + +trail_rrh :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u +trail_rrh x1 (V2 x y) = + trail_theta_right (abs x - x1) ang + <> trail_theta_up y ang + <> trail_theta_right x1 ang + where + ang = if x < 0 then pi else 0 + +trail_rrv :: (Floating u, Ord u) => u -> Vec2 u -> CatTrail u +trail_rrv y1 (V2 x y) = + trail_theta_up (abs y - y1) ang + <> trail_theta_right x ang + <> trail_theta_up y1 ang + where + ang = if y < 0 then pi else 0 + + +trail_rect_loop :: (Real u, Floating u) + => ClockDirection -> u -> u -> u -> Vec2 u -> CatTrail u +trail_rect_loop CW = trail_rect_loopCW +trail_rect_loop _ = trail_rect_loopCCW + +trail_rect_loopCW :: (Real u, Floating u) + => u -> u -> u -> Vec2 u -> CatTrail u +trail_rect_loopCW extl extr h v1 = + trail_theta_left extl ang + <> trail_theta_up h ang + <> trail_theta_right (len + extl + extr) ang + <> trail_theta_down h ang + <> trail_theta_left extr ang + where + ang = vdirection v1 + len = vlength v1 + +trail_rect_loopCCW :: (Real u, Floating u) + => u -> u -> u -> Vec2 u -> CatTrail u +trail_rect_loopCCW extl extr h v1 = + trail_theta_left extl ang + <> trail_theta_down h ang + <> trail_theta_right (len + extl + extr) ang + <> trail_theta_up h ang + <> trail_theta_left extr ang + where + ang = vdirection v1 + len = vlength v1 + + +-- | 'triCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination. +-- +vtriCurve :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +vtriCurve clk h v1 = triCurve clk (vlength v1) h (vdirection v1) + + +-- | 'rectCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination. +-- +vrectCurve :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +vrectCurve clk h v1 = rectCurve clk (vlength v1) h (vdirection v1) + + +-- | 'trapCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination. +-- +vtrapCurve :: (Real u, Floating u) + => ClockDirection -> u -> Radian -> Vec2 u -> CatTrail u +vtrapCurve clk h interior_ang v1 = + trapCurve clk (vlength v1) h interior_ang (vdirection v1) + + +-- | 'bowCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination. +-- +vbowCurve :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +vbowCurve clk h v1 = bowCurve clk (vlength v1) h (vdirection v1) + +-- | 'wedgeCurve' formulated with a /base vector/ rather than +-- base-width and angle of inclination. +-- +vwedgeCurve :: (Real u, Floating u) + => ClockDirection -> u -> Vec2 u -> CatTrail u +vwedgeCurve clk h v1 = wedgeCurve clk (vlength v1) h (vdirection v1) + diff --git a/src/Wumpus/Drawing/Basis/ShapeTrails.hs b/src/Wumpus/Drawing/Basis/ShapeTrails.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Basis/ShapeTrails.hs @@ -0,0 +1,213 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Basis.ShapeTrails +-- Copyright : (c) Stephen Tetley 2011-2012 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Basis.ShapeTrails + ( + + circle_trail + , rcircle_trail + + , ellipse_trail + , rellipse_trail + + , rectangle_trail + , rrectangle_trail + + , diamond_trail + , rdiamond_trail + + , isosceles_triangle_trail + , risosceles_triangle_trail + + , semicircle_trail + , rsemicircle_trail + + , semiellipse_trail + , rsemiellipse_trail + + , parallelogram_trail + , rparallelogram_trail + + , trapezium_trail + , rtrapezium_trail + + ) + + where + +import Wumpus.Drawing.Basis.InclineTrails + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +-- import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Data.Monoid + + +-- Shapes... + +circle_trail :: (Real u, Floating u) => u -> AnaTrail u +circle_trail r = rcircle_trail r 0 + +rcircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u +rcircle_trail r ang = + modifyAna (\v -> v ^-^ avec ang r) $ incline_circle $ avec ang (2 * r) + + + +ellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u +ellipse_trail rx ry = rellipse_trail rx ry 0 + +rellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u +rellipse_trail rx ry ang = + modifyAna (\v -> v ^-^ avec ang rx) $ incline_ellipse ry $ avec ang (2 * rx) + + +rectangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u +rectangle_trail w h = rrectangle_trail w h 0 + + +rrectangle_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u +rrectangle_trail w h ang = + anaCatTrail (orthoVec (negate $ 0.5 * w) (negate $ 0.5 * h) ang) catt + where + catt = mconcat [ trail_theta_right w ang + , trail_theta_up h ang + , trail_theta_left w ang + , trail_theta_down h ang + ] + + +diamond_trail :: (Real u, Floating u) => u -> u -> AnaTrail u +diamond_trail w h = rdiamond_trail w h 0 + +rdiamond_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u +rdiamond_trail w h ang = + anaCatTrail (theta_right hw ang) catt + where + hw = 0.5 * w + hh = 0.5 * h + catt = mconcat [ orthoCatTrail (-hw) hh ang + , orthoCatTrail (-hw) (-hh) ang + , orthoCatTrail hw (-hh) ang + , orthoCatTrail hw hh ang + ] + + +isosceles_triangle_trail :: (Real u, Floating u) => u -> u -> AnaTrail u +isosceles_triangle_trail bw h = risosceles_triangle_trail bw h 0 + +-- | Drawn at the centroid (1/3 * h). +-- +risosceles_triangle_trail :: (Real u, Floating u) + => u -> u -> Radian -> AnaTrail u +risosceles_triangle_trail bw h ang = + anaCatTrail (orthoVec (negate hbw) (negate $ h / 3) ang) catt + where + hbw = 0.5 * bw + catt = mconcat [ trail_theta_right bw ang + , orthoCatTrail (-hbw) h ang + , orthoCatTrail (-hbw) (-h) ang + ] + + +semicircle_trail :: (Real u, Floating u) => u -> AnaTrail u +semicircle_trail r = rsemicircle_trail r 0 + +rsemicircle_trail :: (Real u, Floating u) => u -> Radian -> AnaTrail u +rsemicircle_trail r ang = + anaCatTrail (orthoVec (negate r) (negate hminor) ang) catt + where + -- hminor is the centroid formula for semicircle + hminor = (4 * r) / (3 * pi) + catt = trail_theta_right (2 * r) ang + <> semicircleTrail CCW (avec ang (negate $ 2 * r) ) + + + +semiellipse_trail :: (Real u, Floating u) => u -> u -> AnaTrail u +semiellipse_trail rx ry = rsemiellipse_trail rx ry 0 + +rsemiellipse_trail :: (Real u, Floating u) => u -> u -> Radian -> AnaTrail u +rsemiellipse_trail rx ry ang = + anaCatTrail (orthoVec (negate rx) (negate hminor) ang) catt + where + -- hminor is the centroid formula for semiellipse + hminor = (4 * ry) / (3 * pi) + catt = trail_theta_right (2 * rx) ang + <> semiellipseTrail CCW ry (avec ang (negate $ 2 * rx) ) + +-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown. +-- +parallelogram_trail :: Floating u => u -> u -> Radian -> AnaTrail u +parallelogram_trail w h bottom_left_ang = + rparallelogram_trail w h bottom_left_ang 0 + +-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown. +-- +rparallelogram_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u +rparallelogram_trail w h bl_ang ang + | bl_ang >= ang180 = + error "rparallelogram_trail - bottom left angle >= 180." + | otherwise = anaCatTrail ctr_to_bl catt + where + -- Note - base_minor is negative for angles > 90 + base_minor = h / (fromRadian $ tan bl_ang) + + vbase = theta_right w ang + vrhs = orthoVec base_minor h ang + vtop = vreverse vbase + vlhs = vreverse vrhs + ctr_to_bl = vreverse $ 0.5 *^ (vbase ^+^ vrhs) + catt = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ] + + +-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown. +-- +-- Also, no checking is perfomed on the relation between height +-- and bottom_left ang. Out of range values will draw \"twisted\" +-- trapezoids. +-- +trapezium_trail :: Floating u => u -> u -> Radian -> AnaTrail u +trapezium_trail w h bottom_left_ang = + rtrapezium_trail w h bottom_left_ang 0 + + +-- | Note - bottom left angle must be smaller than 180deg, +-- otherwise a runtime error is thrown. +-- +rtrapezium_trail :: Floating u => u -> u -> Radian -> Radian -> AnaTrail u +rtrapezium_trail bw h bl_ang ang + | bl_ang >= ang180 = error "rtrapezium_trail - bottom left angle >= 180." + | otherwise = anaCatTrail ctr_to_bl catt + where + -- Note - base_minor is negative for angles > 90 + base_minor = h / (fromRadian $ tan bl_ang) + top_width = bw - (2 * base_minor) + vbase = theta_right bw ang + vrhs = orthoVec (-base_minor) h ang + vtop = theta_left top_width ang + vlhs = orthoVec (-base_minor) (-h) ang + ctr_to_bl = orthoVec (negate $ 0.5 * bw) (negate $ 0.5 * h) ang + catt = mconcat $ map catline [ vbase, vrhs, vtop, vlhs ] + + diff --git a/src/Wumpus/Drawing/Basis/Symbols.hs b/src/Wumpus/Drawing/Basis/Symbols.hs --- a/src/Wumpus/Drawing/Basis/Symbols.hs +++ b/src/Wumpus/Drawing/Basis/Symbols.hs @@ -21,17 +21,35 @@ module Wumpus.Drawing.Basis.Symbols ( - ocircle + scircle + , fcircle + , fscircle + + , ssquare + , fsquare + , fssquare + + , sleft_slice + , fleft_slice + , fsleft_slice + + , sright_slice + , fright_slice + , fsright_slice + + , sleft_triangle + , fleft_triangle + , fsleft_triangle + + , sright_triangle + , fright_triangle + , fsright_triangle + , ochar , ocharUpright , ocharDescender , ocurrency - , left_slice - , right_slice - , left_triangle - , right_triangle - , empty_box , hbar @@ -50,6 +68,8 @@ -- import Data.AffineSpace -- package: vector-space +import Data.Monoid + -- -- DESIGN NOTE -- @@ -57,33 +77,251 @@ -- /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/. +-- expected to be redefined elsewhere (possibly at fixed size) +-- with the re-definitions used in /user code/ rather than these +-- primitives. -- -- Using camelCase here, then under_score in the DocText versions -- adds double the function signatures to the Haddock docs. -- +-- Also - should the names encode start pos, or can all start +-- positions be center? +-- +-- +-- TikZ uses o to indicated /circled/. +-- +-- Using o as a prefix for /open/ i.e. stroked has the problem +-- that there aren\'t any other characters ideographic for filled +-- or filled stroked. +-- +-- scircle +-- fcircle +-- fscircle -ocircle :: InterpretUnit u => u -> LocGraphic u -ocircle radius = dcDisk DRAW_STROKE radius + +-- | Stroked circle. +-- +-- Start pos - center. +-- +scircle :: InterpretUnit u => u -> LocGraphic u +scircle radius = dcDisk DRAW_STROKE radius + +-- | Filled circle. +-- +-- Start pos - center. +-- +fcircle :: InterpretUnit u => u -> LocGraphic u +fcircle radius = dcDisk DRAW_FILL radius + +-- | Filled-stroked circle. +-- +-- Start pos - center. +-- +fscircle :: InterpretUnit u => u -> LocGraphic u +fscircle radius = dcDisk DRAW_FILL_STROKE radius + + + + +-- | Stroked square. +-- +-- Start pos - center. +-- +ssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +ssquare w = renderAnaTrail CSTROKE $ rectangleTrail w w + + +-- | Filled square. +-- +-- Start pos - center. +-- +fsquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +fsquare w = renderAnaTrail CFILL $ rectangleTrail w w + + +-- | Filled-stroked square. +-- +-- Start pos - center. +-- +fssquare :: (Fractional u, InterpretUnit u) => u -> LocGraphic u +fssquare w = renderAnaTrail CFILL_STROKE $ rectangleTrail w w + + + +-- | Implementation. +-- +lslice :: (Real u, Floating u, InterpretUnit u) + => DrawMode -> u -> LocGraphic u +lslice mode radius = moveStart (go_left $ 0.5 * radius) lwedge + where + lwedge = supplyIncline 0 $ wedge mode radius quarter_pi + +-- | Stroked left slice (wedge). +-- +-- Start pos - .... +-- +sleft_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +sleft_slice = lslice DRAW_STROKE + + +-- | Filled left slice (wedge). +-- +-- Start pos - .... +-- +fleft_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fleft_slice = lslice DRAW_FILL + + +-- | Filled-stroked left slice (wedge). +-- +-- Start pos - .... +-- +fsleft_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fsleft_slice = lslice DRAW_FILL_STROKE + + + +-- | Implementation. +-- +rslice :: (Real u, Floating u, InterpretUnit u) + => DrawMode -> u -> LocGraphic u +rslice mode radius = moveStart (go_right $ 0.5 * radius) rwedge + where + rwedge = supplyIncline pi $ wedge mode radius quarter_pi + + +-- | Stroked right slice (wedge). +-- +-- Start pos - .... +-- +sright_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +sright_slice = rslice DRAW_STROKE + + +-- | Filled right slice (wedge). +-- +-- Start pos - .... +-- +fright_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fright_slice = rslice DRAW_FILL + + +-- | Filled-stroked right slice (wedge). +-- +-- Start pos - .... +-- +fsright_slice :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fsright_slice = rslice DRAW_FILL_STROKE + + + +-- | Implementation. +-- +left_tri :: (Fractional u, InterpretUnit u) + => PathMode -> u -> LocGraphic u +left_tri mode w = + renderAnaTrail mode $ anaCatTrail (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 + + +-- | Stroked left triangle. +-- +-- Start pos - .... +-- +sleft_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +sleft_triangle = left_tri CSTROKE + + +-- | Filled left triangle. +-- +-- Start pos - .... +-- +fleft_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fleft_triangle = left_tri CFILL + + +-- | Filled-stroked left triangle. +-- +-- Start pos - .... +-- +fsleft_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fsleft_triangle = left_tri CFILL_STROKE + + +-- | Implementation +-- +right_tri :: (Fractional u, InterpretUnit u) + => PathMode -> u -> LocGraphic u +right_tri mode w = + renderAnaTrail mode $ anaCatTrail (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 + + +-- | Stroked right triangle. +-- +-- Start pos - .... +-- +sright_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +sright_triangle = right_tri CSTROKE + + +-- | Filled right triangle. +-- +-- Start pos - .... +-- +fright_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fright_triangle = right_tri CFILL + + +-- | Filled-stroked right triangle. +-- +-- Start pos - .... +-- +fsright_triangle :: (Real u, Floating u, InterpretUnit u) + => u -> LocGraphic u +fsright_triangle = right_tri CFILL_STROKE + + + -- | Note this looks horrible for chars with descenders. -- ochar :: (Fractional u, InterpretUnit u) - => EscapedChar -> LocGraphic 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) + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (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) + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h) ocharDescender :: (Fractional u, InterpretUnit u) => EscapedChar -> LocGraphic u @@ -91,12 +329,12 @@ 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) + circ1 = localize (set_line_width 0.75) $ capHeight >>= \h -> scircle (0.85 * h) ocurrency :: (Floating u, InterpretUnit u) => u -> LocGraphic u -ocurrency ra = ocircle ra <> lne <> lnw <> lsw <> lse +ocurrency ra = scircle ra <> lne <> lnw <> lsw <> lse where ra3 = 0.33 * ra lne = moveStart (go_north_east ra) $ locStraightLine $ go_north_east ra3 @@ -104,52 +342,18 @@ 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 +empty_box w = renderAnaTrail 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 + renderAnaTrail OSTROKE $ anaCatTrail (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 + renderAnaTrail OSTROKE $ anaCatTrail (go_down $ 0.5 * u) $ trail_up u dbl_hbar :: (Fractional u, InterpretUnit u) => u -> LocGraphic u dbl_hbar u = line1 <> line2 diff --git a/src/Wumpus/Drawing/Connectors.hs b/src/Wumpus/Drawing/Connectors.hs --- a/src/Wumpus/Drawing/Connectors.hs +++ b/src/Wumpus/Drawing/Connectors.hs @@ -20,12 +20,10 @@ ( module Wumpus.Drawing.Connectors.Arrowheads , module Wumpus.Drawing.Connectors.Base - , module Wumpus.Drawing.Connectors.BoxConnectors , 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.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 @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Connectors.Arrowheads --- Copyright : (c) Stephen Tetley 2011 +-- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -12,6 +12,8 @@ -- -- Arrowheads. -- +-- \*\* WARNING \*\* - naming scheme due to change. +-- -------------------------------------------------------------------------------- module Wumpus.Drawing.Connectors.Arrowheads @@ -59,104 +61,86 @@ ) where -import Wumpus.Drawing.Basis.DrawingPrimitives +import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.Base import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space +-- import Data.AffineSpace -- package: vector-space import Data.VectorSpace +import Data.Monoid --- | Arrow tips are drawn with a sloid line even if the connector + + + +-- | Arrow tips are drawn with a solid line even if the connector -- line is dashed (tips also override round corners) solid_stroke_tip :: DrawingContextF -solid_stroke_tip = reset_drawing_metrics +solid_stroke_tip = solid_line -- reset_drawing_metrics -type PointGen = Radian -> [Vec2 En] +type TrailGen = Radian -> AnaTrail En -filledTipPath :: PointGen -> LocThetaGraphic En -filledTipPath gen = - localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta -> - cStraightLines DRAW_FILL $ map (pt .+^) $ gen theta +fillTrailTip :: TrailGen -> LocThetaGraphic En +fillTrailTip gen_pt = + localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta -> + supplyLoc pt $ renderAnaTrail CFILL $ gen_pt theta -closedTipPath :: PointGen -> LocThetaGraphic En -closedTipPath gen = +closedTrailTip :: TrailGen -> LocThetaGraphic En +closedTrailTip gen_pt = localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> - cStraightLines DRAW_STROKE $ map (pt .+^) $ gen theta + supplyLoc pt $ renderAnaTrail CSTROKE $ gen_pt theta -openTipPath :: PointGen -> LocThetaGraphic En -openTipPath gen = +openTrailTip :: TrailGen -> LocThetaGraphic En +openTrailTip gen_pt = localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> - oStraightLines $ map (pt .+^) $ gen theta + supplyLoc pt $ renderAnaTrail OSTROKE $ gen_pt theta --- | Return @o-a@ and @o-b@: --- --- > a --- > .\ --- > . \ --- > .....o --- > . / --- > ./ --- > b --- -tripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En)) -tripointsFromTip baselen ang = \theta -> - (avec (theta + au) hyp, avec (theta + ad) hyp) - where - half_ang = 0.5 * ang - au = pi - half_ang - ad = half_ang + pi - hyp = baselen / (fromRadian $ cos half_ang) - --- | Return @o-x@ and @o-a@ and @o-b@: --- --- > a --- > /. --- > / . --- > .. x..o --- > \ . --- > \. --- > b +-- | All three lines are stated. -- -revTripointsFromTip :: En -> Radian -> (Radian -> (Vec2 En, Vec2 En, Vec2 En)) -revTripointsFromTip baselen ang = \theta -> - (avec theta (-baselen), oa theta, ob theta) - where - half_ang = 0.5 * ang - half_height = baselen * (fromRadian $ tan half_ang) - oa = \theta -> avec (theta + ang90) half_height - ob = \theta -> avec (theta - ang90) half_height - - - +closedTriTrail :: Radian -> TrailGen +closedTriTrail ang = \theta -> + modifyAna (\v1 -> v1 ^+^ theta_left 1 theta) $ + incline_triangle ang (avec theta 1) filledTri :: Radian -> ArrowTip filledTri ang = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = filledTipPath spec + , tip_deco = fillTrailTip $ closedTriTrail ang } - where - spec theta = let (v1,v2) = tripointsFromTip 1 ang theta - in [zeroVec, v1, v2] +-- +-- DESIGN NOTE +-- +-- Naming scheme should change. +-- +-- The \"wumpus way\" of naming seems to be coalescing to favour +-- underscore separated names rather than camelCase for /data/ +-- objects. +-- +-- These data objects can still be functions but they are +-- distinguished by drawing differently - roughly speaking +-- the difference between a barb tip and a triangle tip is +-- \"what they draw not what they mean\". +-- + -- | Filled triangle - apex is 90 deg. -- tri90 :: ArrowTip @@ -176,13 +160,10 @@ strokedClosedTri :: Radian -> ArrowTip strokedClosedTri ang = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = closedTipPath spec + , tip_deco = closedTrailTip $ closedTriTrail ang } - where - spec theta = let (v1,v2) = tripointsFromTip 1 ang theta - in [zeroVec, v1, v2] otri90 :: ArrowTip @@ -195,17 +176,21 @@ otri45 = strokedClosedTri ang45 +-- | All three lines are stated. +-- +revClosedTriSpec :: Radian -> TrailGen +revClosedTriSpec ang = \theta -> incline_triangle ang (avec theta (-1)) + + filledRevTri :: Radian -> ArrowTip filledRevTri ang = ArrowTip - { retract_distance = const 1 + { retract_distance = 0.5 , tip_half_len = 0.5 - , tip_deco = filledTipPath spec + , tip_deco = fillTrailTip $ revClosedTriSpec ang } - where - spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta - in [v0, v1, v2] + revtri90 :: ArrowTip revtri90 = filledRevTri ang90 @@ -219,15 +204,11 @@ strokedClosedRevTri :: Radian -> ArrowTip strokedClosedRevTri ang = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = closedTipPath spec + , tip_deco = closedTrailTip $ revClosedTriSpec ang } - where - spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta - in [v0, v1, v2] - orevtri90 :: ArrowTip orevtri90 = strokedClosedRevTri ang90 @@ -238,19 +219,19 @@ orevtri45 = strokedClosedRevTri ang45 +barbSpec :: Radian -> TrailGen +barbSpec ang = \theta -> + modifyAna (\v1 -> v1 ^+^ avec theta (-1)) $ incline_barb ang (avec theta 1) + strokedBarb :: Radian -> ArrowTip strokedBarb ang = ArrowTip - { retract_distance = const 0 + { retract_distance = 0 , tip_half_len = 0.5 - , tip_deco = openTipPath spec + , tip_deco = openTrailTip $ barbSpec ang } - where - spec theta = let (v1,v2) = tripointsFromTip 1 ang theta - in [v1,zeroVec,v2] - barb90 :: ArrowTip barb90 = strokedBarb ang90 @@ -261,17 +242,18 @@ barb45 = strokedBarb ang45 +revBarbSpec :: Radian -> TrailGen +revBarbSpec ang = \theta -> incline_barb ang (avec theta (-1)) + strokedRevBarb :: Radian -> ArrowTip strokedRevBarb ang = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = openTipPath spec + , tip_deco = openTrailTip $ revBarbSpec ang } - where - spec theta = let (v0,v1,v2) = revTripointsFromTip 1 ang theta - in [v1,v0,v2] + revbarb90 :: ArrowTip revbarb90 = strokedRevBarb ang90 @@ -282,98 +264,87 @@ revbarb45 = strokedRevBarb ang45 +perpSpec :: TrailGen +perpSpec ang = + anaCatTrail (theta_up 0.5 ang) $ trail_theta_down 1 ang perp :: ArrowTip perp = ArrowTip - { retract_distance = const 0 + { retract_distance = 0 , tip_half_len = 0 - , tip_deco = openTipPath spec + , tip_deco = openTrailTip perpSpec } + + +bracketSpec :: TrailGen +bracketSpec ang = anaCatTrail (orthoVec (-0.5) 0.5 ang) catt where - spec theta = let oa = avec (theta + ang90) 0.5 - ob = avec (theta - ang90) 0.5 - in [oa, ob] + catt = mconcat [ trail_theta_right 0.5 ang + , trail_theta_down 1.0 ang + , trail_theta_left 0.5 ang + ] bracket :: ArrowTip bracket = ArrowTip - { retract_distance = const 0 + { retract_distance = 0.0 , tip_half_len = 0.5 - , tip_deco = openTipPath spec + , tip_deco = openTrailTip bracketSpec } - where - spec theta = let oa = avec (theta + ang90) 0.5 - ob = avec (theta - ang90) 0.5 - dv = avec theta (-0.5) - in [ oa ^+^ dv, oa, ob, ob ^+^ dv ] - +diskBody :: DrawMode -> Radian -> LocGraphic En +diskBody mode theta = + localize fill_use_stroke_colour $ moveStart vback $ dcDisk mode 0.5 + where + vback = theta_left 0.5 theta diskTip :: ArrowTip diskTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 0.5 , tip_half_len = 0.5 - , tip_deco = promoteLocTheta $ \pt theta -> body theta `at` pt + , tip_deco = promoteLocTheta $ \pt theta -> + diskBody DRAW_FILL theta `at` pt } - where - body :: Radian -> LocGraphic En - body theta = let v1 = avec theta (-0.5) - in localize fill_use_stroke_colour $ - moveStart v1 (dcDisk DRAW_FILL 0.5) odiskTip :: ArrowTip odiskTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = promoteLocTheta $ \pt theta -> body theta `at` pt + , tip_deco = promoteLocTheta $ \pt theta -> + diskBody DRAW_STROKE theta `at` pt } - where - body :: Radian -> LocGraphic En - body theta = let v1 = avec theta (-0.5) - in localize solid_stroke_tip $ - moveStart v1 (dcDisk DRAW_STROKE 0.5) --- | squareSpec: --- --- > --- > ,-----a --- > | | --- > ...v.....o --- > | | --- > `-----b +-- | Note - need to draw square East-West rather than West-East +-- hence the base_width is negative. -- -squareSpec :: PointGen -squareSpec theta = [ oa ^+^ ov, oa, ob, ob ^+^ ov ] - where - oa = avec (theta + ang90) 0.5 - ob = avec (theta - ang90) 0.5 - ov = avec theta (-1) - +squareSpec :: TrailGen +squareSpec theta = incline_square $ avec theta (-1) + squareTip :: ArrowTip squareTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = filledTipPath squareSpec + , tip_deco = fillTrailTip squareSpec } + osquareTip :: ArrowTip osquareTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = closedTipPath squareSpec + , tip_deco = closedTrailTip squareSpec } - -- | squareSpec: -- -- > @@ -383,52 +354,46 @@ -- > \ / -- > b -- -diamondSpec :: En -> PointGen -diamondSpec width theta = [ ow, oa, zeroVec, ob ] - where - ow = avec theta (-width) - ov = avec theta (negate $ 0.5 * width) - oa = ov ^+^ avec (theta + ang90) 0.5 - ob = ov ^+^ avec (theta - ang90) 0.5 - +diamondSpec :: En -> TrailGen +diamondSpec w theta = incline_diamond 1 $ avec theta (-w) diamondTip :: ArrowTip diamondTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 0.5 , tip_half_len = 0.5 - , tip_deco = filledTipPath (diamondSpec 1) + , tip_deco = fillTrailTip $ diamondSpec 1 } odiamondTip :: ArrowTip odiamondTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 - , tip_deco = closedTipPath (diamondSpec 1) + , tip_deco = closedTrailTip $ diamondSpec 1 } diamondWideTip :: ArrowTip diamondWideTip = ArrowTip - { retract_distance = const 2 + { retract_distance = 1.0 , tip_half_len = 1.0 - , tip_deco = filledTipPath (diamondSpec 2) + , tip_deco = fillTrailTip $ diamondSpec 2 } odiamondWideTip :: ArrowTip odiamondWideTip = ArrowTip - { retract_distance = const 2 + { retract_distance = 2.0 , tip_half_len = 1.0 - , tip_deco = closedTipPath (diamondSpec 2) + , tip_deco = closedTrailTip $ diamondSpec 2 } -curveTipTrail :: Radian -> PlacedTrail En -curveTipTrail theta = - placeCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2 +curveTipSpec :: TrailGen +curveTipSpec theta = + anaCatTrail dv $ vectrapCCW v1 <> vectrapCCW v2 where dv = orthoVec (-1.0) 0.75 theta -- back and up v1 = orthoVec 1.0 (-0.75) theta -- fwd and down @@ -436,7 +401,7 @@ vectrapCW :: (Real u, Floating u) => Vec2 u -> CatTrail u -vectrapCW v1 = trapcurveCW w h ang45 ang +vectrapCW v1 = trapCurve CW w h quarter_pi ang where w = vlength v1 h = w / 4 @@ -444,7 +409,7 @@ vectrapCCW :: (Real u, Floating u) => Vec2 u -> CatTrail u -vectrapCCW v1 = trapcurveCCW w h quarter_pi ang +vectrapCCW v1 = trapCurve CCW w h quarter_pi ang where w = vlength v1 h = w / 4 @@ -454,20 +419,19 @@ curveTip :: ArrowTip curveTip = ArrowTip - { retract_distance = const 0 + { retract_distance = 0 , tip_half_len = 0.5 , tip_deco = body } where - body = promoteLocTheta $ \pt theta -> - localize (join_bevel . solid_stroke_tip) $ - supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipTrail theta + body = localize (cap_round . join_round . solid_stroke_tip) $ + openTrailTip curveTipSpec -curveTipRevTrail :: Radian -> PlacedTrail En -curveTipRevTrail theta = - placeCatTrail dv $ vectrapCW v1 <> vectrapCW v2 +curveTipRevSpec :: TrailGen +curveTipRevSpec theta = + anaCatTrail dv $ vectrapCW v1 <> vectrapCW v2 where dv = orthoVec 0.0 0.75 theta -- just up v1 = orthoVec (-1.0) (-0.75) theta -- back and down @@ -478,13 +442,12 @@ revcurveTip :: ArrowTip revcurveTip = ArrowTip - { retract_distance = const 1 + { retract_distance = 1 , tip_half_len = 0.5 , tip_deco = body } where - body = promoteLocTheta $ \pt theta -> - localize (join_bevel . solid_stroke_tip) $ - supplyLoc pt $ drawPlacedTrail OSTROKE $ curveTipRevTrail theta + body = localize (cap_round . join_round . solid_stroke_tip) $ + openTrailTip curveTipRevSpec 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 @@ -19,19 +19,24 @@ ConnectorPathQuery + , SpacingProjection , ArrowTip(..) , ArrowConnector - , leftArrow - , rightArrow - , leftRightArrow - , uniformArrow + , ConnectorConfig(..) + , ConnectorPathSpec(..) + , renderConnectorConfig - , rightArrowPath + , arrowDecoratePath + , leftArrowConnector + , rightArrowConnector + , uniformArrowConnector + ) where +import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Drawing.Paths import Wumpus.Basic.Kernel -- package: wumpus-basic @@ -43,151 +48,121 @@ --- | The type of Connectors - a query from start and end point to --- a Path. +type SpacingProjection u = + ConnectorProps -> Point2 u -> Point2 u -> Query u (Point2 u) + + + +-- | The type of Connectors - a query from start and end point +-- returning an AbsPath. -- type ConnectorPathQuery u = ConnectorQuery u (AbsPath u) + + -- | Arrowhead /algorithm/ - the components of an arrowhead. -- --- Retract distance may have to account for line width. +-- Retract distance is rather vague - depending on the arrowhead +-- it may represent a flush join between the path and the tip +-- or a join that uses the z-order (tip over path) to create the +-- join. -- +-- \*\* WARNING \*\* - pending revision... +-- data ArrowTip = ArrowTip - { retract_distance :: Double -> En + { retract_distance :: En , tip_half_len :: En , tip_deco :: LocThetaGraphic En } --- Ideally there should be a plus operation to combine tips --- allowing double tips. --- -type ArrowConnector u = ConnectorImage u (AbsPath u) - - - -runArrowTip :: InterpretUnit u - => ArrowTip -> Query u (u, u, LocThetaGraphic u) -runArrowTip (ArrowTip df len deco) = - getLineWidth >>= \lw -> - uconvertCtx1 (df lw) >>= \uretd -> - uconvertCtx1 len >>= \ulen -> - return (uretd, ulen, uconvF deco) - - --- | Connector with an arrow tip at the end point (i.e right). --- -rightArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u -rightArrow alg conn = promoteConn $ \p0 p1 -> - applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> - rightArrowPath alg full_path - - - --- | Connector with an arrow tip at the start point (i.e left). --- -leftArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u -leftArrow alg conn = promoteConn $ \p0 p1 -> - applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> - leftArrowPath alg full_path - - --- | Connector with different arrow tips at the start point and --- end points. --- -leftRightArrow :: (Real u, Floating u, InterpretUnit 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 - - +newtype ConnectorPathSpec u = ConnectorPathSpec { + getConnectorPathSpec :: ConnectorProps -> ConnectorPathQuery u } --- | Connector with the same arrow tip at the start point and --- end points. +-- | total_path is the path before accounting for arrow +-- retract distances. -- -uniformArrow :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> ConnectorPathQuery u -> ArrowConnector u -uniformArrow alg conn = promoteConn $ \p0 p1 -> - applyConn (liftConnectorQuery conn) p0 p1 >>= \full_path -> - leftRightArrowPath alg alg full_path +data ConnectorConfig u = ConnectorConfig + { conn_arrowl :: Maybe ArrowTip + , conn_arrowr :: Maybe ArrowTip + , conn_path_spec :: ConnectorPathSpec u + } --- TODO - possible there are opportunities to be more --- compositional here. - - --- | Path with an arrow tip at the start point (i.e left). --- --- TODO - shortening a curve does not seem to be working properly... +-- Ideally there should be a plus operation to combine tips +-- allowing double tips. -- --- -leftArrowPath :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> AbsPath u -> Image u (AbsPath u) -leftArrowPath alg full_path = - liftQuery (runArrowTip alg) >>= \(retract, len, deco) -> - let short_path = if retract > 0 then shortenL retract full_path - else full_path - mid_ang = tipDirectionL len full_path - tip = applyLocTheta deco (tipL full_path) mid_ang - in replaceAns full_path $ - sdecorate tip $ drawPath OSTROKE short_path - - --- | Path with an arrow tip at the end point (i.e right). --- --- TODO - shortening a curve does not seem to be working properly... --- --- -rightArrowPath :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> AbsPath u -> Image u (AbsPath u) -rightArrowPath alg full_path = - liftQuery (runArrowTip alg) >>= \(retract, len, deco) -> - let short_path = if retract > 0 then shortenR retract full_path - else full_path - mid_ang = tipDirectionR len full_path - tip = applyLocTheta deco (tipR full_path) mid_ang - in replaceAns full_path $ - sdecorate tip $ drawPath OSTROKE short_path +type ArrowConnector u = ConnectorImage u (AbsPath u) --- | Path with an arrow tip at the end point (i.e right). --- --- TODO - shortening a curve does not seem to be working properly... +-- | NOTE - the prefix /render/ needs (re-) consideration... -- +-- If it is a good prefix other functions e.g. drawPath should +-- use render rather than draw. -- -leftRightArrowPath :: (Real u, Floating u, InterpretUnit u) - => ArrowTip -> ArrowTip -> AbsPath u -> Image u (AbsPath u) -leftRightArrowPath algl algr full_path = - liftQuery (runArrowTip algl) >>= \(retractl, lenl, decol) -> - liftQuery (runArrowTip algr) >>= \(retractr, lenr, decor) -> - let short_path = shortenPath retractl retractr full_path - mid_angl = tipDirectionL lenl full_path - mid_angr = tipDirectionR lenr full_path - tipl = applyLocTheta decol (tipL full_path) mid_angl - tipr = applyLocTheta decor (tipR full_path) mid_angr - in replaceAns full_path $ - sdecorate (tipl `mappend` tipr) $ drawPath OSTROKE short_path - +renderConnectorConfig :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps + -> ConnectorConfig u + -> ConnectorImage u (AbsPath u) +renderConnectorConfig props (ConnectorConfig mbl mbr pspec) = + promoteConn $ \src dst -> + liftQuery (qapplyConn path_spec src dst) >>= \tot_path -> + connectorSrcSpace props >>= \sepl -> + connectorDstSpace props >>= \sepr -> + arrowDecoratePath mbl mbr $ shortenL sepl $ shortenR sepr tot_path + where + path_spec = getConnectorPathSpec pspec props +arrowDecoratePath :: (Real u, Floating u, InterpretUnit u) + => Maybe ArrowTip -> Maybe ArrowTip -> (AbsPath u) + -> Image u (AbsPath u) +arrowDecoratePath mbl mbr initial_path = + uconvertCtx1 (maybe 0 retract_distance mbl) >>= \retl -> + uconvertCtx1 (maybe 0 retract_distance mbr) >>= \retr -> + let (p1,theta1) = atstart initial_path + (p2,theta2) = atend initial_path + new_path = shortenL retl $ shortenR retr initial_path + arrl = mbTip p1 (pi + theta1) mbl + arrr = mbTip p2 theta2 mbr + in replaceAns initial_path $ + decorate ZABOVE (renderPath OSTROKE new_path) (arrl `mappend` arrr) + where + mbTip pt ang = maybe emptyImage (supplyLocTheta pt ang . uconvF . tip_deco) --- | Helper - direction looks best at half the retract distance. + +-- | Shorthand... -- -tipDirectionL :: (Real u, Floating u) => u -> AbsPath u -> Radian -tipDirectionL u absp | u <= 0 = directionL absp - |otherwise = directionL $ shortenL (0.5*u) absp - -tipDirectionR :: (Real u, Floating u) => u -> AbsPath u -> Radian -tipDirectionR u absp | u <= 0 = directionR absp - |otherwise = directionR $ shortenR (0.5*u) absp - +leftArrowConnector :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps -> ConnectorPathSpec u -> ArrowTip + -> ConnectorImage u (AbsPath u) +leftArrowConnector props cpath tip = renderConnectorConfig props cfg + where + cfg = ConnectorConfig { conn_arrowl = Just tip + , conn_arrowr = Nothing + , conn_path_spec = cpath } +rightArrowConnector :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps -> ConnectorPathSpec u -> ArrowTip + -> ConnectorImage u (AbsPath u) +rightArrowConnector props cpath tip = renderConnectorConfig props cfg + where + cfg = ConnectorConfig { conn_arrowl = Nothing + , conn_arrowr = Just tip + , conn_path_spec = cpath } + +uniformArrowConnector :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps -> ConnectorPathSpec u -> ArrowTip + -> ConnectorImage u (AbsPath u) +uniformArrowConnector props cpath tip = renderConnectorConfig props cfg + where + cfg = ConnectorConfig { conn_arrowl = Just tip + , conn_arrowr = Just tip + , conn_path_spec = cpath } + 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 @@ -17,22 +17,27 @@ module Wumpus.Drawing.Connectors.BoxConnectors ( ConnectorBox - , connbox - , conntube + , ConnectorBoxSpec(..) + , renderConnectorBoxSpec + , conn_box + , conn_tube + , conn_chamf_box + + ) where --- import Wumpus.Drawing.Connectors.Base +import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core +import Data.VectorSpace -- package: vector-space -import Data.Monoid --- NOTE - boxes (currently) seem to only support stroke otherwise +-- NOTE - boxes seem to only support stroke otherwise -- they would obliterate what they connect. @@ -45,67 +50,67 @@ -- type ConnectorBox u = ConnectorGraphic u +newtype ConnectorBoxSpec u = ConnectorBoxSpec { + getConnectorBoxSpec :: ConnectorProps -> ConnectorBox u } + +renderConnectorBoxSpec :: (Real u, Floating u, InterpretUnit u) + => ConnectorProps + -> ConnectorBoxSpec u + -> ConnectorBox u +renderConnectorBoxSpec props spec = + getConnectorBoxSpec spec props + + + + + -- -- DESIGN NOTE - boxes (probably) should not use source and dest -- separators. -- - --- | Draw a stroked, rectangular box around the connector points. --- --- The rectangle will be inclined to the line. --- -connbox :: (Real u, Floating u, InterpretUnit u) - => ConnectorProps -> ConnectorBox u -connbox props = promoteConn $ \p0 p1 -> - connectorBoxHalfSize props >>= \sz -> - applyLoc (drawPlacedTrail CSTROKE $ cfconnbox sz (pvec p0 p1)) p0 +boxConnector :: (Floating u, Ord u, InterpretUnit u) + => (ConnectorProps -> Point2 u -> Point2 u -> Image u a) + -> ConnectorBoxSpec u +boxConnector mf = ConnectorBoxSpec $ \props -> + promoteConn $ \p0 p1 -> ignoreAns $ mf props p0 p1 -conntube :: (Real u, Floating u, InterpretUnit u) - => ConnectorProps -> ConnectorBox u -conntube props = promoteConn $ \p0 p1 -> +adaptAnaTrail :: (Real u, Floating u, Ord u, InterpretUnit u) + => (u -> Vec2 u -> AnaTrail u) + -> ConnectorBoxSpec u +adaptAnaTrail fn = boxConnector $ \props p0 p1 -> connectorBoxHalfSize props >>= \sz -> - applyLoc (drawPlacedTrail CSTROKE $ cfconntube sz (pvec p0 p1)) p0 - + let v0 = pvec p0 p1 + v1 = v0 ^+^ avec (vdirection v0) (2*sz) + vinit = avec (vdirection v0) (-sz) + in applyLoc (renderAnaTrail CSTROKE $ fn sz v1) (displace vinit p0) + --- Box connectors aren\'t especially coordinate free. - --- | @v1@ is the /interior/ vector. +-- | Draw a stroked, rectangular box around the connector points. -- -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 - +-- The rectangle will be inclined to the line. +-- +conn_box :: (Real u, Floating u, InterpretUnit u) + => ConnectorBoxSpec u +conn_box = adaptAnaTrail (\sz -> incline_rect (2 * sz)) --- | @v1@ is the /interior/ vector. +-- | Draw a stroked, tube around the connector points. -- -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) - - +-- The tube will be inclined to the line. +-- +conn_tube :: (Real u, Floating u, InterpretUnit u) + => ConnectorBoxSpec u +conn_tube = adaptAnaTrail (\sz -> incline_tube (2 * sz)) +-- | Draw a stroked, chamfered box around the connector points. +-- +-- The tube will be inclined to the line. +-- +conn_chamf_box :: (Real u, Floating u, InterpretUnit u) + => ConnectorBoxSpec u +conn_chamf_box = adaptAnaTrail (\sz -> incline_chamf_rect (2 * sz)) 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 @@ -17,194 +17,85 @@ module Wumpus.Drawing.Connectors.ConnectorPaths ( - connline - , connarc - , connhdiagh - , connvdiagv + conn_line + + , conna_arc + , connb_arc + + , conn_hdiagh + , conn_vdiagv - , conndiagh - , conndiagv + , conn_diagh + , conn_diagv - , connhdiag - , connvdiag + , conn_hdiag + , conn_vdiag - , connabar - , connbbar + , conna_bar + , connb_bar + + , conna_flam + , connb_flam - , connaright - , connbright + , conna_orthohbar + , connb_orthohbar - , connhrr - , connrrh - , connvrr - , connrrv + , conna_orthovbar + , connb_orthovbar - , connaloop - , connbloop + , conna_right + , connb_right - , connhbezier - , connvbezier + , conn_hrr + , conn_rrh + , conn_vrr + , conn_rrv + , conna_loop + , connb_loop + + , conn_hbezier + , conn_vbezier + ) where +import Wumpus.Drawing.Basis.InclineTrails import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Connectors.ConnectorProps import Wumpus.Drawing.Paths -import Wumpus.Basic.Geometry.Quadrant -- package: wumpus-basic -import Wumpus.Basic.Kernel hiding ( promoteConn ) +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space +import Control.Applicative -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. +-- | Build as Path as a CatTrail between two points. -- -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 - - - - +catConnector :: (Floating u, Ord u, InterpretUnit u, Tolerance u) + => (ConnectorProps -> Point2 u -> Point2 u -> Query u (CatTrail u)) + -> ConnectorPathSpec u +catConnector mf = ConnectorPathSpec $ \props -> + qpromoteConn $ \p0 p1 -> catTrailPath p0 <$> mf props p0 p1 +horizontally :: (Real u, Floating u) + => (Vec2 u -> a) -> (Vec2 u -> a) -> Vec2 u -> a +horizontally rightf leftf v1 = + case horizontalDirection $ vdirection v1 of + RIGHTWARDS -> rightf v1 + LEFTWARDS -> leftf v1 -- | Straight line connector. -- -connline :: (Real u, Floating u, InterpretUnit u) - => ConnectorProps -> ConnectorPathQuery u -connline props = buildConn props inlineSrc inlineDst $ \p0 p1 -> - return $ line1 p0 p1 +conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathSpec u +conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1 @@ -218,17 +109,28 @@ -- The notion of /above/ is respective to the line direction, of -- course. -- +-- TODO - above and below versions... -- -connarc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) - => ConnectorProps -> ConnectorPathQuery u -connarc props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) + => ConnectorPathSpec u +conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW) + +-- | Below version of 'conna_arc'. +-- +connb_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) + => ConnectorPathSpec u +connb_arc = connArcBody (vtriCurve CCW) (vtriCurve CW) + + +connArcBody :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) + => (u -> Vec2 u -> CatTrail u) + -> (u -> Vec2 u -> CatTrail u) + -> ConnectorPathSpec u +connArcBody rightf leftf = catConnector $ \props 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 - cp1 = p1 .+^ avec (pi + ang - arc_ang) hlen - in return $ curve1 p0 cp0 cp1 p1 + h = (0.5 * vlength v1) * (fromRadian $ tan arc_ang) + in return $ horizontally (rightf h) (leftf h) v1 @@ -242,22 +144,14 @@ -- Horizontal /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms. -- -connhdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> left p0 p1 src_arm dst_arm - where - right p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .+^ hvec h0 - , p1 .-^ hvec h1, p1 ] - - left p0 p1 h0 h1 = return $ vertexPath [ p0, p0 .-^ hvec h0 - , p1 .+^ hvec h1, p1 ] +conn_hdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_hdiagh = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg, dst_leg) -> + return $ trail_hdiagh src_leg dst_leg $ pvec p0 p1 +-- probably want trail_hdiagh as a library function -- | Vertical-diagonal-vertical connector. -- @@ -270,21 +164,11 @@ -- Vertical /arms/ are drawn from the start and end points, a -- diagonal segment joins the arms. -- -connvdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> down p0 p1 src_arm dst_arm - where - up p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .+^ vvec v0 - , p1 .-^ vvec v1, p1 ] - - down p0 p1 v0 v1 = return $ vertexPath [ p0, p0 .-^ vvec v0 - , p1 .+^ vvec v1, p1 ] - +conn_vdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_vdiagv = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg, dst_leg) -> + return $ trail_vdiagv src_leg dst_leg $ pvec p0 p1 -- | Diagonal-horizontal connector. @@ -297,18 +181,11 @@ -- from the start point joining a horizontal arm drawn from the -- end point -- -conndiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> left p0 p1 dst_arm - where - right p0 p1 h1 = return $ vertexPath [ p0, p1 .-^ hvec h1, p1 ] - - left p0 p1 h1 = return $ vertexPath [ p0, p1 .+^ hvec h1, p1 ] +conn_diagh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_diagh = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(_, dst_leg) -> + return $ trail_diagh dst_leg $ pvec p0 p1 -- | Diagonal-vertical connector. @@ -322,18 +199,11 @@ -- from the start point joining a vertical arm drawn from the end -- point. -- -conndiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> down p0 p1 dst_arm - where - up p0 p1 v1 = return $ vertexPath [ p0, p1 .-^ vvec v1, p1 ] - - down p0 p1 v1 = return $ vertexPath [ p0, p1 .+^ vvec v1, p1 ] +conn_diagv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_diagv = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(_, dst_leg) -> + return $ trail_diagv dst_leg $ pvec p0 p1 @@ -347,18 +217,11 @@ -- from the start point joining a diagonal segment drawn from the -- end point. -- -connhdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> left p0 p1 src_arm - where - right p0 p1 h1 = return $ vertexPath [ p0, p0 .+^ hvec h1, p1 ] - - left p0 p1 h1 = return $ vertexPath [ p0, p0 .-^ hvec h1, p1 ] +conn_hdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_hdiag = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg, _) -> + return $ trail_hdiag src_leg $ pvec p0 p1 -- | Vertical-diagonal connector. @@ -372,23 +235,16 @@ -- from the start point joining a vertical segment drawn from the -- end point. -- -connvdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 - _ -> down p0 p1 src_arm - where - up p0 p1 v1 = return $ vertexPath [ p0, p0 .+^ vvec v1, p1 ] - - down p0 p1 v1 = return $ vertexPath [ p0, p0 .-^ vvec v1, p1 ] +conn_vdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_vdiag = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg, _) -> + return $ trail_vdiag src_leg $ pvec p0 p1 -- DESIGN NOTE - should the concept of /above/ and /below/ use --- quadrants? +-- ClockDirection instead? -- @@ -400,13 +256,9 @@ -- -- The bar is drawn /above/ the points. -- -connabar :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 ] +conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW) -- | Bar connector. @@ -417,16 +269,104 @@ -- -- The bar is drawn /below/ the points. -- -connbbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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 ] +connb_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_bar = connBarBody (trail_perp_bar2 CCW) (trail_perp_bar2 CW) +connBarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => (u -> u -> Vec2 u -> CatTrail u) + -> (u -> u -> Vec2 u -> CatTrail u) + -> ConnectorPathSpec u +connBarBody rightf leftf = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src, dst) -> + return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1 + + +-- | /Flam/ connector. +-- +-- > ,- ' +-- > ,- | +-- > | | +-- > o @ +-- +-- The bar is drawn /above/ the points. +-- +conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW) + +-- | /Flam/ connector - bleow. +-- +connb_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_flam = connFlamBody (trail_vflam CCW) (trail_vflam CW) + + +connFlamBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => (u -> u -> Vec2 u -> CatTrail u) + -> (u -> u -> Vec2 u -> CatTrail u) + -> ConnectorPathSpec u +connFlamBody rightf leftf = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src,dst) -> + return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1 + + + + +-- | Bar connector - always orthonormal . +-- +-- > +-- > ,----, +-- > | | +-- > o @ +-- +-- The bar is drawn /above/ the points. +-- +conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW) + +-- | Bar connector orthonormal - below. +-- +connb_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_orthohbar = connOrthobarBody (trail_ortho_hbar CCW) (trail_ortho_hbar CW) + + + +connOrthobarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => (u -> Vec2 u -> CatTrail u) + -> (u -> Vec2 u -> CatTrail u) + -> ConnectorPathSpec u +connOrthobarBody rightf leftf = catConnector $ \props p0 p1 -> + connectorLoopSize props >>= \looph -> + return $ horizontally (rightf looph) (leftf looph) $ pvec p0 p1 + + +-- | Bar connector - always orthonormal. +-- +-- > +-- > ,--- o +-- > | +-- > '--- @ +-- > +-- +-- The bar is drawn /left/ of the points. +-- +conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW) + +-- | Bar connector orthonormal - right of the points. +-- +connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW) + + + -- | Right angle connector. -- -- > ,----@ @@ -435,11 +375,10 @@ -- -- The bar is drawn /above/ the points. -- -connaright :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] +conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_right = catConnector $ \_ p0 p1 -> + return $ trail_vright $ pvec p0 p1 -- | Right angle connector. @@ -450,24 +389,15 @@ -- -- The bar is drawn /below/ the points. -- -connbright :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] +connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_right = catConnector $ \_ p0 p1 -> + return $ trail_hright $ pvec p0 p1 --- Helper --- | Derive the direction aka. sign of an arm. --- -directional :: (Num u, Ord u) => u -> u -> u -> u -directional src dst arm = if src < dst then arm else negate arm - - - --- | Connector with two horizontal segements and a joining +-- | Connector with two horizontal segments and a joining -- vertical segment. -- -- > ,--@ @@ -475,17 +405,14 @@ -- > o----' -- -- The length of the first horizontal segment is the source arm --- length. The length of the final segment is the remaing +-- length. The length of the final segment is the remaining -- horizontal distance. -- -connhrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] +conn_hrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_hrr = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg,_) -> + return $ trail_hrr src_leg $ pvec p0 p1 -- | Connector with two horizontal segements and a joining @@ -495,18 +422,15 @@ -- > | -- > o--' -- --- The length of the final horizontal segment is the distination +-- The length of the final horizontal segment is the destination -- arm length. The length of the initial segment is the remaining -- horizontal distance. -- -connrrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] +conn_rrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_rrh = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(_,dst_leg) -> + return $ trail_rrh dst_leg $ pvec p0 p1 -- | Connector with two right angles... @@ -517,14 +441,15 @@ -- > | -- > o -- -connvrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] +-- The length of the first vertical segment is the source arm +-- length. The length of the final segment is the remaining +-- vertical distance. +-- +conn_vrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_vrr = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src_leg,_) -> + return $ trail_vrr src_leg $ pvec p0 p1 -- | Connector with two right angles... @@ -535,15 +460,15 @@ -- > | -- > o -- -connrrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => 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] - +-- The length of the final vertical segment is the destination +-- arm length. The length of the initial segment is the remaining +-- vertical distance. +-- +conn_rrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conn_rrv = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(_,dst_leg) -> + return $ trail_rrv dst_leg $ pvec p0 p1 @@ -555,9 +480,10 @@ -- -- The loop is drawn /above/ the points. -- -connaloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => ConnectorProps -> ConnectorPathQuery u -connaloop = loopbody id +conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW) + -- | Loop connector. -- @@ -565,26 +491,25 @@ -- > | | -- > '---------' -- --- The loop is drawn /above/ the points. +-- The loop is drawn /below/ the points. -- -connbloop :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => ConnectorProps -> ConnectorPathQuery u -connbloop = loopbody negate +connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => ConnectorPathSpec u +connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW) --- | Looping just differs on a negate... --- -loopbody :: (Real u, Floating u, Tolerance u, InterpretUnit u) - => (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 - z0 = dispParallel dst_arm ang p1 - z1 = dispPerpendicular (fn loop_len) ang z0 - in return $ vertexPath [ p0, a0, a1, z1, z0, p1 ] +connLoopBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) + => (u -> u -> u -> Vec2 u -> CatTrail u) + -> (u -> u -> u -> Vec2 u -> CatTrail u) + -> ConnectorPathSpec u +connLoopBody rightf leftf = catConnector $ \props p0 p1 -> + connectorLegs props >>= \(src,dst) -> + connectorLoopSize props >>= \looph -> + return $ horizontally (rightf src dst looph) (leftf src dst looph) + $ pvec p0 p1 + + + -- | Bezier curve connector - the control points are positioned -- horizontally respective to the source and dest. -- @@ -596,17 +521,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) - => ConnectorProps -> ConnectorPathQuery u -connhbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conn_hbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathSpec u +conn_hbezier = ConnectorPathSpec $ \props -> + qpromoteConn $ \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 - _ -> left p0 p1 src_arm dst_arm + case horizontalDirection $ vdirection $ pvec p0 p1 of + RIGHTWARDS -> right p0 p1 src_arm dst_arm + _ -> left p0 p1 src_arm dst_arm where right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1 @@ -625,20 +547,16 @@ -- 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) - => ConnectorProps -> ConnectorPathQuery u -connvbezier props = buildConn props inlineSrc inlineDst $ \p0 p1 -> +conn_vbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ConnectorPathSpec u +conn_vbezier = ConnectorPathSpec $ \props -> + qpromoteConn $ \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 - _ -> down p0 p1 src_arm dst_arm + case verticalDirection $ vdirection $ pvec p0 p1 of + UPWARDS -> up p0 p1 src_arm dst_arm + _ -> down p0 p1 src_arm dst_arm where up p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1 - down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1 diff --git a/src/Wumpus/Drawing/Connectors/ConnectorProps.hs b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs --- a/src/Wumpus/Drawing/Connectors/ConnectorProps.hs +++ b/src/Wumpus/Drawing/Connectors/ConnectorProps.hs @@ -25,6 +25,7 @@ , connectorSrcSpace , connectorDstSpace , connectorArms + , connectorLegs , connectorLoopSize , connectorBoxHalfSize @@ -131,6 +132,15 @@ connectorArms props = (\sz -> ( uconvert1 sz $ conn_src_arm props , uconvert1 sz $ conn_dst_arm props) ) + <$> pointSize + +-- | /legs/ are Arms + spacing. +-- +connectorLegs :: (DrawingCtxM m, InterpretUnit u) + => ConnectorProps -> m (u,u) +connectorLegs props = + (\sz -> ( uconvert1 sz $ conn_src_space props + conn_src_arm props + , uconvert1 sz $ conn_dst_space props + conn_dst_arm 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 @@ -65,9 +65,9 @@ import Wumpus.Drawing.Dots.SimpleDots ( MarkSize ) import qualified Wumpus.Drawing.Dots.SimpleDots as SD +import Wumpus.Drawing.Paths.Intersection -import Wumpus.Basic.Geometry -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -141,17 +141,7 @@ rectCardinal hw _ ctr WEST = ctr .+^ (hvec (-hw)) rectCardinal hw hh ctr NORTH_WEST = ctr .+^ (vec (-hw) hh) -polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u -polyCardinal f NORTH = f (0.5 * pi) -polyCardinal f NORTH_EAST = f (0.25 * pi) -polyCardinal f EAST = f 0 -polyCardinal f SOUTH_EAST = f (1.75 * pi) -polyCardinal f SOUTH = f (1.5 * pi) -polyCardinal f SOUTH_WEST = f (1.25 * pi) -polyCardinal f WEST = f pi -polyCardinal f NORTH_WEST = f (0.75 * pi) - -- | All anchors are the center! -- zeroAnchor :: Point2 u -> DotAnchor u @@ -161,15 +151,27 @@ , cardinal_anchor = const ctr } -rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u +rectangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr = DotAnchor { center_anchor = ctr , radial_anchor = fn , cardinal_anchor = rectCardinal hw hh ctr } where - fn theta = displace (rectRadialVector hw hh theta) ctr + fn theta = let mb_v1 = rectangleRadialIntersect (2*hw) (2*hh) theta + in displace (maybe zeroVec id mb_v1) ctr +triangleAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Point2 u -> DotAnchor u +triangleAnchor hh ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = fn + , cardinal_anchor = radialCardinal hh ctr } + where + fn theta = let mb_v1 = isoscelesTriangleRadialIntersect (2*hh) (2*hh) theta + in displace (maybe zeroVec id mb_v1) ctr + circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u circleAnchor rad ctr = DotAnchor { center_anchor = ctr @@ -179,19 +181,9 @@ fn theta = displace (avec theta rad) ctr -polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => [Point2 u] -> Point2 u -> DotAnchor u -polygonAnchor ps ctr = - DotAnchor { center_anchor = ctr - , radial_anchor = fn - , cardinal_anchor = polyCardinal fn } - where - fn theta = maybe ctr id $ findIntersect ctr theta - $ polygonLineSegments ps - - -bboxRectAnchor :: (Real u, Floating u) => BoundingBox u -> DotAnchor u +bboxRectAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => BoundingBox u -> DotAnchor u bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) = let hw = 0.5 * (x2 - x1) hh = 0.5 * (y2 - y1) @@ -201,7 +193,7 @@ zeroLDO :: InterpretUnit u => LocQuery u (DotAnchor u) zeroLDO = qpromoteLoc $ \pt -> return $ zeroAnchor pt -rectangleLDO :: (Real u, Floating u, InterpretUnit u) +rectangleLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) => MarkSize -> MarkSize -> LocQuery u (DotAnchor u) rectangleLDO w h = qpromoteLoc $ \pt -> (\uw uh -> rectangleAnchor (uw*0.5) (uh*0.5) pt) @@ -224,12 +216,8 @@ triangleLDO :: (Real u, Floating u, Tolerance u, InterpretUnit u) => MarkSize -> LocQuery u (DotAnchor u) triangleLDO h = qpromoteLoc $ \pt -> - uconvertCtx1 h >>= \uh -> - let alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices uh - in (\ps -> polygonAnchor ps pt) - <$> qapplyLoc (placedTrailPoints alg) pt - where - fn3 (a,b,c) = [a,b,c] + (\uh -> triangleAnchor (uh*0.5) pt) + <$> uconvertCtx1 h -------------------------------------------------------------------------------- @@ -260,7 +248,8 @@ largeCirc = intoLocImage (circleLDO 1.00) SD.largeCirc -dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u +dotChar :: (Floating u, Real u, InterpretUnit u, Tolerance u) + => Char -> DotLocImage u dotChar ch = dotText [ch] @@ -271,7 +260,8 @@ -- -dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u +dotText :: (Floating u, Real u, InterpretUnit u, Tolerance u) + => String -> DotLocImage u dotText ss = fmap bboxRectAnchor $ runPosObjectBBox CENTER $ posText ss @@ -307,7 +297,8 @@ dotDisk = intoLocImage (circleLDO 0.5) SD.dotDisk -dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u +dotSquare :: (Floating u, Real u, InterpretUnit u, Tolerance u) + => DotLocImage u dotSquare = intoLocImage (rectangleLDO 1 1) SD.dotSquare 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 @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Dots.SimpleDots --- Copyright : (c) Stephen Tetley 2011 +-- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -67,9 +67,9 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Basis.Symbols -import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -128,13 +128,13 @@ -- | Stroked disk (circle) - radius 0.25 MarkSize. -- smallCirc :: InterpretUnit u => LocGraphic u -smallCirc = umark $ ocircle 0.25 +smallCirc = umark $ scircle 0.25 -- | Stroked disk (circle) - radius 1.0 MarkSize. -- largeCirc :: InterpretUnit u => LocGraphic u -largeCirc = umark $ ocircle 1 +largeCirc = umark $ scircle 1 -- possibly: @@ -197,15 +197,15 @@ dotDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotDiamond = umark $ drawPlacedTrail CSTROKE (diamondTrail 0.5 0.66) +dotDiamond = umark $ renderAnaTrail CSTROKE (diamondTrail 0.5 0.66) dotFDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotFDiamond = umark $ drawPlacedTrail CFILL (diamondTrail 0.5 0.66) +dotFDiamond = umark $ renderAnaTrail CFILL (diamondTrail 0.5 0.66) dotBDiamond :: (Fractional u, InterpretUnit u) => LocGraphic u -dotBDiamond = umark $ drawPlacedTrail CFILL_STROKE (diamondTrail 0.5 0.66) +dotBDiamond = umark $ renderAnaTrail CFILL_STROKE (diamondTrail 0.5 0.66) -- | Note disk is filled. @@ -216,11 +216,11 @@ dotSquare :: (Fractional u, InterpretUnit u) => LocGraphic u -dotSquare = umark $ drawPlacedTrail CSTROKE (rectangleTrail 1 1) +dotSquare = umark $ renderAnaTrail CSTROKE (rectangleTrail 1 1) dotCircle :: (Fractional u, InterpretUnit u) => LocGraphic u -dotCircle = umark $ ocircle 0.5 +dotCircle = umark $ scircle 0.5 dotBCircle :: (Fractional u, InterpretUnit u) => LocGraphic u @@ -229,7 +229,7 @@ dotPentagon :: (Floating u, InterpretUnit u) => LocGraphic u -dotPentagon = umark $ drawPlacedTrail CSTROKE (polygonTrail 5 0.5) +dotPentagon = umark $ renderAnaTrail CSTROKE (polygonTrail 5 0.5) @@ -241,7 +241,7 @@ => u -> LocGraphic u starLines hh = promoteLoc $ \ctr -> let alg = polygonTrail 5 hh - in liftQuery (qapplyLoc (placedTrailPoints alg) ctr) >>= \ps -> + in liftQuery (qapplyLoc (anaTrailPoints alg) ctr) >>= \ps -> step $ map (fn ctr) ps where fn p0 p1 = straightLine p0 p1 @@ -278,7 +278,4 @@ dotTriangle :: (Floating u, InterpretUnit u) => LocGraphic u -dotTriangle = umark $ drawPlacedTrail CSTROKE alg - where - alg = trailIterateLocus $ fn3 $ equilateralTriangleVertices 1 - fn3 = \(a,b,c) -> [a,b,c] +dotTriangle = umark $ renderAnaTrail CSTROKE $ isosceles_triangle_trail 1 1 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 @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Extras.Axes --- Copyright : (c) Stephen Tetley 2011 +-- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -37,11 +37,11 @@ -- | Simple orthonormal axes using snap grid units. -- -orthontAxes :: (Real u, Floating u, InterpretUnit u) +orthontAxes :: (Real u, Floating u, InterpretUnit u, Tolerance u) => (Int,Int) -> (Int,Int) -> LocGraphic u orthontAxes (xl,xr) (yl,yr) = promoteLoc $ \(P2 x y) -> snapmove (1,1) >>= \(V2 uw uh) -> - let conn1 = rightArrow barb45 connline + let conn1 = ignoreAns conn_line xPtl = P2 (x - (uw * fromIntegral xl)) y xPtr = P2 (x + (uw * fromIntegral xr)) y yPtl = P2 x (y - (uh * fromIntegral yl)) @@ -51,24 +51,25 @@ -horizontalLabels :: (Num a, Fractional u, InterpretUnit u) +horizontalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) => RectAddress -> [a] -> LocGraphic u horizontalLabels addr ns = - snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (runChainH uw $ mapM mf ns) + snapmove (1,1) >>= \(V2 uw _) -> ignoreAns (distribH uw $ map mf ns) where - mf n = chain1 $ runPosObject addr $ posTextUpright $ show n + mf n = runPosObject addr $ posTextUpright $ show n -verticalLabels :: (Num a, Fractional u, InterpretUnit u) +verticalLabels :: (Num a, Show a, Fractional u, InterpretUnit u) => RectAddress -> [a] -> LocGraphic u verticalLabels addr ns = - snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (runChainV uh $ mapM mf ns) + snapmove (1,1) >>= \(V2 _ uh) -> ignoreAns (distribV uh $ map mf ns) where - mf n = chain1 $ runPosObject addr $ posTextUpright $ show n + mf n = runPosObject addr $ posTextUpright $ show n --- Cf. Parsec\'s Token module... +-- Cf. Parsec\'s Token module - remake with same name... -- -connline :: (Real u, Floating u, InterpretUnit u) => ConnectorPathQuery u -connline = C.connline default_connector_props +conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => ArrowConnector u +conn_line = rightArrowConnector default_connector_props C.conn_line barb45 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 @@ -16,8 +16,10 @@ module Wumpus.Drawing.Extras.Loop ( - loop - , loopPoints + + loopPath + , loopTrail + ) where @@ -31,33 +33,28 @@ import Data.AffineSpace -- package: vector-space --- TODO - Loop is a decoration not a connector. --- It should probably have the same signature as wedge / arc. +import Data.Monoid --- | Generate a loop - suitable for decorating a circle. --- --- The radius and the (implicit) start point are the center and --- radius of the initial circle not the loop itself. --- -loop :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> Point2 u -> Radian -> Query u (AbsPath u) -loop zradius zctr ang = return $ curvePath $ loopPoints zradius zctr ang +loopPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Point2 u -> Radian -> AbsPath u +loopPath zradius ctr incl = anaTrailPath ctr $ loopTrail zradius incl --- Should be able to use trig to get a loop suitable for --- decorating rectangles (provided the start-to-end arc is smaller --- than the side length +-- This is a legacy definition updated to use Trails, hence it is +-- not so clear. --- | Note - intermediate names and quadrants represent a loop --- drawn upwards. --- -loopPoints :: (Real u, Floating u) => u -> Point2 u -> Radian -> [Point2 u] -loopPoints circ_radius circ_ctr incl = - [ startl, cp1, cp2, kitel, cp3, cp4, top, cp5, cp6, kiter, cp7, cp8, startr ] +loopTrail :: (Real u, Floating u) => u -> Radian -> AnaTrail u +loopTrail circ_radius incl = + anaCatTrail (pvec zeroPt startl) $ + mconcat [ diffCurve startl cp1 cp2 kitel + , diffCurve kitel cp3 cp4 top + , diffCurve top cp5 cp6 kiter + , diffCurve kiter cp7 cp8 startr + ] where hw = 1.25 * circ_radius height = 3.8 * circ_radius @@ -71,12 +68,12 @@ top_right = negate $ 0.8 * circ_radius top_left = 0.8 * circ_radius - top = dispParallel height incl circ_ctr - kiter = dispOrtho (V2 hminor (-hw)) incl circ_ctr - kitel = dispOrtho (V2 hminor (hw) ) incl circ_ctr + top = dispParallel height incl zeroPt + kiter = dispOrtho hminor (-hw) incl zeroPt + kitel = dispOrtho hminor hw incl zeroPt - startr = circ_ctr .+^ avec (circularModulo $ incl - theta) circ_radius - startl = circ_ctr .+^ avec (circularModulo $ incl + theta) circ_radius + startr = zeroPt .+^ avec (circularModulo $ incl - theta) circ_radius + startl = zeroPt .+^ avec (circularModulo $ incl + theta) circ_radius -- quadrant III cp1 = startl .+^ end_vec @@ -93,3 +90,4 @@ -- quadrant IV cp7 = dispParallel minor_down incl kiter cp8 = startr .+^ start_vec + diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs --- a/src/Wumpus/Drawing/Paths/Base.hs +++ b/src/Wumpus/Drawing/Paths/Base.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Paths.Base --- Copyright : (c) Stephen Tetley 2010-2011 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -14,6 +14,15 @@ -- -- Absolute path type - this should be more amenable for building -- complex drawings than the PrimPath type in Wumpus-Core. +-- +-- Note - there is no concatenation (i.e. no Monoid instance), +-- this is because concatenating \*\* absolute \*\* paths has no +-- obvious interpretation - draw a join between the paths, move +-- the second path to start where the first ends... +-- +-- Use @CatTrail@ from Wumpus-Basic if you need a relative-path +-- like object that supports concatenation, then convert it in a +-- final step to an @AbsPath@. -- -------------------------------------------------------------------------------- @@ -36,7 +45,7 @@ , vectorPath , vectorPathTheta - , placedTrailPath + , anaTrailPath , catTrailPath -- * Queries @@ -53,19 +62,20 @@ -- * Conversion , toPrimPath - , drawPath - , drawPath_ + , renderPath + , renderPath_ -- * Shortening , shortenPath , shortenL , shortenR - -- * Tips and direction + -- * Tips and inclination , tipL , tipR - , directionL - , directionR + , inclinationL + , inclinationR + , isBezierL , isBezierR @@ -94,15 +104,18 @@ , roundExterior , roundInterior + , deBezier + , pathMajorPoints + , pathAllPoints + -- * Path division , pathdiv ) where - +import Wumpus.Drawing.Basis.BezierCurve -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl , ViewR(..), viewr, cons, snoc ) @@ -210,17 +223,88 @@ -------------------------------------------------------------------------------- -- Translate --- Translate is cheap on AbsPath +-- | AbsPathSegments are build from vectors so they do not +-- respond to translation. +-- +instance Num u => Translate (AbsPathSeg u) where + translate _ _ s1 = s1 + + +instance (Floating u, Ord u, Tolerance u) => Scale (AbsPathSeg u) where + scale sx sy (AbsLineSeg _ v1) = absLineSeg $ scale sx sy v1 + scale sx sy (AbsCurveSeg _ v1 v2 v3) = + absCurveSeg (scale sx sy v1) (scale sx sy v2) (scale sx sy v3) + + + +-- | Translate is cheap on AbsPath it just moves the start and +-- end points. The path itself is otherwise built from vectors +-- so it doesn\'t respond to translation (translate == id). +-- 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) +-- | This is expensive on paths - needs a traversal. +-- +instance (Floating u, Ord u, Tolerance u) => Scale (AbsPath u) where + scale sx sy = rebuildPath (scale sx sy) (scale sx sy) + (\v1 v2 v3 -> ( scale sx sy v1 + , scale sx sy v2 + , scale sx sy v3 )) + + +-- | This is expensive on paths - needs a traversal. +-- +instance (Real u, Floating u, Ord u, Tolerance u) => Rotate (AbsPath u) where + rotate ang = rebuildPath (rotate ang) (rotate ang) + (\v1 v2 v3 -> ( rotate ang v1 + , rotate ang v2 + , rotate ang v3 )) + +-- | This is expensive on paths - needs a traversal. +-- +instance (Real u, Floating u, Ord u, Tolerance u) => RotateAbout (AbsPath u) where + rotateAbout ang pt = + rebuildPath (rotateAbout ang pt) (rotateAbout ang pt) + (\v1 v2 v3 -> ( rotateAbout ang pt v1 + , rotateAbout ang pt v2 + , rotateAbout ang pt v3 )) + + + + +rebuildPath :: (Floating u, Ord u, Tolerance u) + => (Point2 u -> Point2 u) + -> (Vec2 u -> Vec2 u) + -> (Vec2 u -> Vec2 u -> Vec2 u -> (Vec2 u, Vec2 u, Vec2 u)) + -> AbsPath u + -> AbsPath u +rebuildPath pointf linef curvef (AbsPath _ sp segs _) = + step (emptyPath $ pointf sp) (viewl segs) + where + step ac EmptyL = ac + + step ac (AbsLineSeg _ v1 :< xs) = + step (snocLine ac $ linef v1) (viewl xs) + + step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = + step (snocCurve ac $ curvef v1 v2 v3) (viewl xs) + -------------------------------------------------------------------------------- -- Construction +absLineSeg :: Floating u => Vec2 u -> AbsPathSeg u +absLineSeg v1 = AbsLineSeg (vlength v1) v1 + +absCurveSeg :: (Floating u, Ord u, Tolerance u) + => Vec2 u -> Vec2 u -> Vec2 u -> AbsPathSeg u +absCurveSeg v1 v2 v3 = + AbsCurveSeg (bezierLength $ vbezierCurve v1 v2 v3 zeroPt) v1 v2 v3 + -- | Create the empty path. -- -- Note - an absolute path needs /locating/ and cannot be built @@ -237,10 +321,9 @@ -- supplied points. -- line1 :: Floating u => Point2 u -> Point2 u -> AbsPath u -line1 p0 p1 = AbsPath len p0 (JL.one $ AbsLineSeg len v1) p1 +line1 p0 p1 = AbsPath len p0 (JL.one s1) p1 where - v1 = pvec p0 p1 - len = vlength v1 + s1@(AbsLineSeg len _) = absLineSeg $ pvec p0 p1 -- | Create an absolute path from a single cubic Bezier curve. -- @@ -320,10 +403,10 @@ 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 +anaTrailPath :: (Floating u, Ord u, Tolerance u) + => Point2 u -> AnaTrail u -> AbsPath u +anaTrailPath pt trl = + let (v1,ss) = destrAnaTrail trl in step (emptyPath $ pt .+^ v1) ss where step ac [] = ac step ac (TLine v1:xs) = step (ac `snocLine` v1) xs @@ -468,15 +551,15 @@ -drawPath :: InterpretUnit u +renderPath :: InterpretUnit u => PathMode -> AbsPath u -> Image u (AbsPath u) -drawPath mode rp = replaceAns rp $ +renderPath mode rp = replaceAns rp $ liftQuery (toPrimPath rp) >>= dcPath mode -drawPath_ :: InterpretUnit u +renderPath_ :: InterpretUnit u => PathMode -> AbsPath u -> Graphic u -drawPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode +renderPath_ mode rp = liftQuery (toPrimPath rp) >>= dcPath mode -- | Turn a Path into an ordinary PrimPath. @@ -552,7 +635,7 @@ => u -> Point2 u -> AbsPathSeg u -> (Point2 u, AbsPathSeg u) shortenSegL n sp (AbsLineSeg u v1) = let v2 = shortenVec n v1 - sp' = sp .+^ (v1 ^-^ v2) + sp' = sp .+^ avec (vdirection v1) n in (sp', AbsLineSeg (u-n) v2) shortenSegL n sp (AbsCurveSeg u v1 v2 v3) = @@ -586,7 +669,7 @@ | otherwise = step n (viewr segs) endpt where step _ EmptyR _ = AbsPath 0 sp mempty sp - step d (se :> e) ep = let z = segmentLength e + 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 @@ -606,7 +689,7 @@ => u -> AbsPathSeg u -> Point2 u -> (AbsPathSeg u, Point2 u) shortenSegR n (AbsLineSeg u v1) ep = let v2 = shortenVec n v1 - ep' = ep .-^ (v1 ^+^ v2) + ep' = ep .-^ avec (vdirection v1) n in (AbsLineSeg (u-n) v2, ep') shortenSegR n (AbsCurveSeg u v1 v2 v3) ep = @@ -636,24 +719,28 @@ -------------------------------------------------------------------------------- -- 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 +inclinationL :: (Real u, Floating u) => AbsPath u -> Radian +inclinationL (AbsPath _ _ se _) = step $ viewl se where - step (AbsLineSeg _ v1 :< _) = vdirection $ negateV v1 - step (AbsCurveSeg _ v1 _ _ :< _) = vdirection $ negateV v1 + step (AbsLineSeg _ v1 :< _) = vdirection v1 + step (AbsCurveSeg _ v1 _ _ :< _) = vdirection 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 +inclinationR :: (Real u, Floating u) => AbsPath u -> Radian +inclinationR (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? -- @@ -682,7 +769,7 @@ 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) + | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, inclinationR pa1) -- Just the midway point. -- @@ -691,14 +778,14 @@ atstart :: (Real u, Floating u) => AbsPath u -> (Point2 u, Radian) -atstart pa@(AbsPath _ sp _ _) = (sp, directionL pa) +atstart pa@(AbsPath _ sp _ _) = (sp, inclinationL 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 pa@(AbsPath _ _ _ ep) = (ep, inclinationR pa) atend_ :: AbsPath u -> Point2 u @@ -857,7 +944,7 @@ -- -- 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 +-- straight line joins are rounded, joins to or from Bezier -- curves are not rounded. -- -- Caution - all path segments are expected to be longer than @@ -896,7 +983,8 @@ base_vec = tv1 ^+^ tv2 bw = vlength base_vec h = sqrt $ pow2 du - (pow2 $ 0.5 * bw) - tcurve = tricurve bw (-h) (vdirection base_vec) + clockd = clockDirection v1 v2 + tcurve = triCurve clockd bw (-h) (vdirection base_vec) -- note the (-h) in tricurve is wrong, we need to account -- for CCW or CW properly... @@ -946,6 +1034,54 @@ step1 _ _ [] = error "roundExteriorCat - unreachable 2." + + +-- | Redraw an 'AbsPath' replacing the Bezier curves with three +-- lines along the control vectors. +-- +deBezier :: Floating u => AbsPath u -> AbsPath u +deBezier (AbsPath _ sp segs _) = + step (emptyPath sp) (viewl segs) + where + step ac EmptyL = ac + + step ac (AbsLineSeg _ v1 :< xs) = + step (ac `snocLine` v1) (viewl xs) + + step ac (AbsCurveSeg _ v1 v2 v3 :< xs) = + step (ac `snocLine` v1 `snocLine` v2 `snocLine` v3) (viewl xs) + +-- | This does not extract the control points of Bezier curves. +-- +pathMajorPoints :: Num u => AbsPath u -> [Point2 u] +pathMajorPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs) + where + step _ EmptyL = [] + + step pt (AbsLineSeg _ v1 :< xs) = + let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) + + step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = + let p1 = pt .+^ v1 in p1 : step (p1 .+^ (v2 ^+^ v3)) (viewl xs) + + +-- | This extracts the control points of Bezier curves. +-- +pathAllPoints :: Num u => AbsPath u -> [Point2 u] +pathAllPoints (AbsPath _ sp segs _) = sp : step sp (viewl segs) + where + step _ EmptyL = [] + + step pt (AbsLineSeg _ v1 :< xs) = + let p1 = pt .+^ v1 in p1 : step p1 (viewl xs) + + step pt (AbsCurveSeg _ v1 v2 v3 :< xs) = + let p1 = pt .+^ v1 + p2 = p1 .+^ v2 + p3 = p2 .+^ v3 + in p1 : p2 : p3 : step p3 (viewl xs) + + -------------------------------------------------------------------------------- -- Path division diff --git a/src/Wumpus/Drawing/Paths/Illustrate.hs b/src/Wumpus/Drawing/Paths/Illustrate.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Illustrate.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Illustrate +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Illustrate a path - show the construction of its Bezier curves. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Illustrate + ( + + path_as_control_box + , path_with_control_points + + ) where + +import Wumpus.Drawing.Paths.Base + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour +import Data.Monoid + + + +grey1 :: RGBi +grey1 = RGBi 200 200 200 + +-- | Illustrate the control points as a /boxed/ path - Bezier +-- curves are replaced with straight lines spanning the +-- control points. +-- +path_as_control_box :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u +path_as_control_box path1 = pic1 `mappend` pic2 + where + pic1 = localize (set_line_width 8 . stroke_colour grey1) $ + renderPath_ OSTROKE path1 + pic2 = localize (set_line_width 1 . stroke_colour black) $ + renderPath_ OSTROKE $ deBezier path1 + + +path_with_control_points :: (Floating u, InterpretUnit u) => AbsPath u -> Graphic u +path_with_control_points path1 = pic1 `mappend` pic2 + where + pic1 = localize (fill_colour grey1) $ + mconcat $ map (disk1 `at`) $ pathAllPoints path1 + + pic2 = localize (set_line_width 1 . stroke_colour black) $ + renderPath_ OSTROKE path1 + + disk1 = dcDisk DRAW_FILL 3 + diff --git a/src/Wumpus/Drawing/Paths/Intersection.hs b/src/Wumpus/Drawing/Paths/Intersection.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Intersection.hs @@ -0,0 +1,318 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Intersection +-- Copyright : (c) Stephen Tetley 2011-2012 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Intersection of Paths with (infinite) lines. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Intersection + ( + + Line(..) + , inclinedLine + , vectorLine + , Ray(..) + , inclinedRay + + , lineLineIntersection + , linePathIntersection + , linePathSegmentIntersection + , rayPathIntersection + , rayPathSegmentIntersection + + , rectangleRadialIntersect + , isoscelesTriangleRadialIntersect + + ) where + +import Wumpus.Drawing.Basis.BezierCurve +import Wumpus.Drawing.Basis.ShapeTrails +import Wumpus.Drawing.Paths.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +-------------------------------------------------------------------------------- + + +-- +-- Private types - LineEquation, 2x2 matrix and bezier curve. +-- +-- Although these types are /general/ exposing them just leads +-- to a bloated API. +-- +-- If these types are fund to be more useful - they can go into +-- @Drawing.Basis@. +-- + + +-- | Line in equational form, i.e. @Ax + By + C = 0@. +-- +data LineEquation u = LineEquation + { _line_eqn_A :: !u + , _line_eqn_B :: !u + , _line_eqn_C :: !u + } + deriving (Eq,Show) + +type instance DUnit (LineEquation u) = u + + +-- | 'lineEquation' : @ point1 * point2 -> LineEquation @ +-- +-- Construct a line in equational form bisecting the supplied +-- points. +-- +lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u +lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c + where + a = y1 - y2 + b = x2 - x1 + c = (x1*y2) - (x2*y1) + +-- | 2x2 matrix, considered to be in row-major form. +-- +-- > (M2'2 a b +-- > c d) +-- +-- + +data Matrix2'2 u = M2'2 !u !u !u !u + deriving (Eq) + +type instance DUnit (Matrix2'2 u) = u + + +-- | Determinant of a 2x2 matrix. +-- +det2'2 :: Num u => Matrix2'2 u -> u +det2'2 (M2'2 a b c d) = a*d - b*c + + + + + +-------------------------------------------------------------------------------- + +-- | Infinite line represented by two points. +-- +data Line u = Line (Point2 u) (Point2 u) + deriving (Eq,Show) + +type instance DUnit (Line u) = u + + + +-- | 'inclinedLine' : @ point * ang -> Line @ +-- + + +-- | Make an infinite line passing through the supplied point +-- inclined by @ang@. +-- +inclinedLine :: Floating u => Point2 u -> Radian -> Line u +inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100) + +vectorLine :: Num u => Vec2 u -> Point2 u -> Line u +vectorLine v1 p0 = Line p0 (p0 .+^ v1) + + +-- | A 'Ray' extends from the first point, through the second to +-- infinity. +-- +-- ('Line' extends to infinity in both directions. +-- +data Ray u = Ray (Point2 u) (Point2 u) + deriving (Eq,Show) + +type instance DUnit (Ray u) = u + + +-- | Make an infinite ray starting from the supplied point +-- inclined by @ang@. +-- +inclinedRay :: Floating u => Point2 u -> Radian -> Ray u +inclinedRay ray_ogin ang = Ray ray_ogin (ray_ogin .+^ avec ang 100) + + + + + +pointOnLineSeg :: (Real u, Floating u, Ord u, Tolerance u) + => Point2 u -> (Point2 u, Point2 u) -> Bool +pointOnLineSeg pt (p0,p1) + | pt == p0 || pt == p1 = True + | otherwise = + vdirection v1 == vdirection v0 && vlength v1 `tLTE` vlength v0 + where + v0 = pvec p0 p1 + v1 = pvec p0 pt + + +-- | 'interLineLine' : @ line1 * line2 -> Maybe Point @ +-- +-- Find the intersection of two lines, if there is one. +-- +-- Lines are infinite they are represented by points on them, +-- they are not line segments. +-- +-- An answer of @Nothing@ may indicate either the lines coincide +-- or the are parallel. +-- +lineLineIntersection :: (Fractional u, Ord u, Tolerance u) + => Line u -> Line u -> Maybe (Point2 u) +lineLineIntersection (Line p1 p2) (Line q1 q2) = + if det_co `tEQ` 0 then Nothing + else Just $ P2 (det_xm / det_co) (det_ym / det_co) + where + -- Ax + By + C = 0 + LineEquation a1 b1 c1 = lineEquation p1 p2 + LineEquation a2 b2 c2 = lineEquation q1 q2 + + coeffM = M2'2 a1 b1 a2 b2 + det_co = det2'2 coeffM + + xM = M2'2 (negate c1) b1 (negate c2) b2 + det_xm = det2'2 xM + + yM = M2'2 a1 (negate c1) a2 (negate c2) + det_ym = det2'2 yM + + +linePathIntersection :: (Real u, Floating u, Ord u, Tolerance u) + => Line u -> AbsPath u -> Maybe (Point2 u) +linePathIntersection ln = step . pathViewL + where + step EmptyPathL = Nothing + step (a :<< bs) = let ans = linePathSegmentIntersection ln a + in case ans of + Nothing -> step (pathViewL bs) + _ -> ans + +linePathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) + => Line u -> PathSegment u -> Maybe (Point2 u) +linePathSegmentIntersection ln1 (LineSeg _ p0 p1) = + mbWithin p0 p1 $ lineLineIntersection ln1 (Line p0 p1) + +linePathSegmentIntersection (Line pa pb) (CurveSeg _ p0 p1 p2 p3) = + lineEqnCurveIntersection (lineEquation pa pb) (BezierCurve p0 p1 p2 p3) + + +mbWithin :: (Real u, Floating u, Ord u, Tolerance u) + => Point2 u -> Point2 u -> Maybe (Point2 u) -> Maybe (Point2 u) +mbWithin p0 p1 mb = mb >>= \pt -> + if pointOnLineSeg pt (p0,p1) then Just pt else Nothing + +lineEqnCurveIntersection :: (Floating u, Ord u, Tolerance u) + => LineEquation u -> BezierCurve u -> Maybe (Point2 u) +lineEqnCurveIntersection eqnline c0 = step c0 + where + step c = case cut eqnline c of + Left pt -> Just pt -- cut at start or end + Right False -> Nothing + Right True -> let (a,b) = subdivide c + in case step a of + Just pt -> Just pt + Nothing -> step b + + +rayPathIntersection :: (Real u, Floating u, Ord u, Tolerance u) + => Ray u -> AbsPath u -> Maybe (Point2 u) +rayPathIntersection ry = step . pathViewL + where + step EmptyPathL = Nothing + step (a :<< bs) = let ans = rayPathSegmentIntersection ry a + in case ans of + Nothing -> step (pathViewL bs) + _ -> ans + +rayPathSegmentIntersection :: (Real u, Floating u, Ord u, Tolerance u) + => Ray u -> PathSegment u -> Maybe (Point2 u) +rayPathSegmentIntersection (Ray p0 p1) seg = + test =<< linePathSegmentIntersection (Line p0 p1) seg + where + test pt = if vdirection (pvec p0 p1) == vdirection (pvec p0 pt) + then Just pt else Nothing + +-- | Is the curve cut by the line? +-- +-- The curve might cut at the start or end points - which is good +-- as it saves performing a subdivision, but it makes the return +-- type a bit involved. +-- +cut :: (Floating u , Ord u, Tolerance u) + => LineEquation u -> BezierCurve u -> Either (Point2 u) Bool +cut eqnline (BezierCurve p0 p1 p2 p3) = + if d0 `tEQ` 0 then Left p0 else + if d3 `tEQ` 0 then Left p3 else + let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds + where + pve = (>= 0) + nve = (< 0) + d0 = pointLineDistance p0 eqnline + d1 = pointLineDistance p1 eqnline + d2 = pointLineDistance p2 eqnline + d3 = pointLineDistance p3 eqnline + + + + +-- | 'pointLineDistance' : @ point -> line -> Distance @ +-- +-- Find the distance from a point to a line in equational form +-- using this formula: +-- +-- > P(u,v) +-- > L: Ax + By + C = 0 +-- > +-- > (A*u) + (B*v) + C +-- > ----------------- +-- > sqrt $ (A^2) +(B^2) +-- +-- A positive distance indicates the point is above the line, +-- negative indicates below. +-- +pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u +pointLineDistance (P2 u v) (LineEquation a b c) = + ((a*u) + (b*v) + c) / base + where + base = sqrt $ (a^two) + (b^two) + two :: Integer + two = 2 + + +-------------------------------------------------------------------------------- +-- Intersections on common shapes + +-- | Answer is vector from center. +-- +rectangleRadialIntersect :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Radian -> Maybe (Vec2 u) +rectangleRadialIntersect w h ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp + where + rp = anaTrailPath zeroPt $ rectangle_trail w h + + + +-- | Answer is vector from centroid. +-- +isoscelesTriangleRadialIntersect :: (Real u, Floating u + , InterpretUnit u, Tolerance u) + => u -> u -> Radian -> Maybe (Vec2 u) +isoscelesTriangleRadialIntersect bw h ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp + where + rp = anaTrailPath zeroPt $ isosceles_triangle_trail bw h diff --git a/src/Wumpus/Drawing/Paths/PathBuilder.hs b/src/Wumpus/Drawing/Paths/PathBuilder.hs --- a/src/Wumpus/Drawing/Paths/PathBuilder.hs +++ b/src/Wumpus/Drawing/Paths/PathBuilder.hs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Paths.PathBuilder --- Copyright : (c) Stephen Tetley 2011 +-- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -90,7 +90,7 @@ getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) } type instance DUnit (GenPathSpec st u a) = u -type instance UState (GenPathSpec st u) = st +type instance UState (GenPathSpec st u a) = st type PathSpec u a = GenPathSpec () u a @@ -228,7 +228,7 @@ 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) + (_,w2) = runImage pctx (renderActivePen mode $ st_active_pen s1) wfinal = cpmove (V2 dx dy) $ w1 `mappend` w2 in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal @@ -293,9 +293,9 @@ -- | Helper. -- -drawActivePen :: PathMode -> ActivePen -> DGraphic -drawActivePen _ PEN_UP = mempty -drawActivePen mode (PEN_DOWN abs_path) = drawPath_ mode abs_path +renderActivePen :: PathMode -> ActivePen -> DGraphic +renderActivePen _ PEN_UP = mempty +renderActivePen mode (PEN_DOWN abs_path) = renderPath_ mode abs_path @@ -317,7 +317,7 @@ 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 + (_,w2) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s1 wfinal = w1 `mappend` w2 in primGraphic $ cpmove (negateV v1) wfinal where @@ -393,7 +393,7 @@ 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 + (_,w1) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s cpath = snocLine (st_cumulative_path s) dv1 in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1) @@ -433,7 +433,7 @@ 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 + (_,w1) = runImage pctx $ renderActivePen 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 @@ -443,7 +443,7 @@ 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) + let (_,w1) = runImage pctx $ renderActivePen (fn mode) (st_active_pen s) in ((), s { st_active_pen = PEN_UP }, w1) where fn DRAW_STROKE = CSTROKE 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 @@ -43,7 +43,7 @@ where conn = promoteConn $ \p1 p2 -> let dir = vdirection $ pvec p1 p2 - in drawPath_ CSTROKE $ vectorPathTheta path1 dir p1 + in renderPath_ CSTROKE $ vectorPathTheta path1 dir p1 hdiam = 0.5 * diam path1 = [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] 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 @@ -42,6 +42,7 @@ , makeShapeCTM , ctmCenter , ctmAngle + , ctmLocale , projectFromCtr ) where @@ -132,7 +133,7 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -dblStrokedShape sh = sdecorate back fore +dblStrokedShape sh = decorateAbove back fore where img = shapeToLoc (dcClosedPath DRAW_STROKE) sh back = getLineWidth >>= \lw -> @@ -155,7 +156,7 @@ applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt 0 >>= \a -> applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt 0 >>= \spath -> let g2 = atIncline (shape_decoration sh) pt 0 - in replaceAns a (sdecorate g2 $ liftQuery (toPrimPath spath) >>= drawF) + in replaceAns a (decorateAbove g2 $ liftQuery (toPrimPath spath) >>= drawF) @@ -177,7 +178,7 @@ applyLocTheta (liftLocThetaQuery $ shape_ans_fun sh) pt theta >>= \a -> applyLocTheta (liftLocThetaQuery $ shape_path_fun sh) pt theta >>= \spath -> let g2 = atIncline (shape_decoration sh) pt theta - in replaceAns a $ sdecorate g2 (liftQuery (toPrimPath spath) >>= drawF) + in replaceAns a $ decorateAbove g2 (liftQuery (toPrimPath spath) >>= drawF) @@ -246,6 +247,9 @@ ctmAngle :: ShapeCTM u -> Radian ctmAngle = ctm_rotation + +ctmLocale :: ShapeCTM u -> (Point2 u, Radian) +ctmLocale ctm = (ctm_center ctm, ctm_rotation ctm) instance (Fractional u) => Scale (ShapeCTM u) where 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,14 @@ ) where + +import Wumpus.Drawing.Basis.ShapeTrails +import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Quadrant -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -123,14 +125,21 @@ -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Diamond u) where radialAnchor ang = runDisplaceCenter $ \hw hh -> - diamondRadialVector hw hh ang + maybe zeroVec id $ diamondRadialAnchor hw hh ang +diamondRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Radian -> Maybe (Vec2 u) +diamondRadialAnchor hw hh ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp + where + rp = anaTrailPath zeroPt $ diamond_trail (2*hw) (2*hh) + -------------------------------------------------------------------------------- -- Construction @@ -140,7 +149,7 @@ -- diamond :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Shape Diamond u -diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath 0 hw hh) +diamond hw hh = makeShape (mkDiamond hw hh) (mkDiamondPath hw hh) mkDiamond :: InterpretUnit u => u -> u -> LocThetaQuery u (Diamond u) @@ -152,11 +161,7 @@ mkDiamondPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkDiamondPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> - qapplyLoc (placedTrailPoints $ diamondTrail hw hh) ctr >>= \ps -> - roundCornerShapePath rnd $ map (rotateAbout theta ctr) ps - - - + => u -> u -> LocThetaQuery u (AbsPath u) +mkDiamondPath hw hh = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rdiamond_trail (2*hw) (2*hh) theta 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,6 +27,7 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base @@ -148,8 +149,7 @@ mkEllipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> LocThetaQuery u (AbsPath u) -mkEllipsePath rx ry = qpromoteLocTheta $ \pt theta -> - let xs = map (rotateAbout theta pt) $ bezierEllipse rx ry pt - in return $ curvePath xs +mkEllipsePath rx ry = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rellipse_trail rx ry theta diff --git a/src/Wumpus/Drawing/Shapes/InvSemicircle.hs b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs --- a/src/Wumpus/Drawing/Shapes/InvSemicircle.hs +++ b/src/Wumpus/Drawing/Shapes/InvSemicircle.hs @@ -100,7 +100,7 @@ west = runRotateAnchor east -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (InvSemicircle u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest @@ -109,7 +109,7 @@ -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (InvSemicircle u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) diff --git a/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs --- a/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs +++ b/src/Wumpus/Drawing/Shapes/InvSemiellipse.hs @@ -93,7 +93,7 @@ topLeftCorner = runRotateAnchor bottomRightCorner topRightCorner = runRotateAnchor bottomLeftCorner -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor (InvSemiellipse u) where north = runRotateAnchor south south = runRotateAnchor north @@ -101,7 +101,7 @@ west = runRotateAnchor east -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (InvSemiellipse u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest @@ -110,7 +110,7 @@ -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (InvSemiellipse u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) diff --git a/src/Wumpus/Drawing/Shapes/InvTriangle.hs b/src/Wumpus/Drawing/Shapes/InvTriangle.hs --- a/src/Wumpus/Drawing/Shapes/InvTriangle.hs +++ b/src/Wumpus/Drawing/Shapes/InvTriangle.hs @@ -25,11 +25,11 @@ ) where +import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Shapes.Base import Wumpus.Drawing.Shapes.Triangle -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 @@ -122,7 +122,7 @@ west = runRotateAnchor east -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (InvTriangle u) where northeast = runRotateAnchor southwest southeast = runRotateAnchor northwest @@ -131,7 +131,7 @@ -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (InvTriangle u) where radialAnchor theta = runRotateAnchor (radialAnchor $ circularModulo $ pi+theta) 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,12 +27,15 @@ ) where +import Wumpus.Drawing.Basis.Geometry +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic + import Wumpus.Core -- package: wumpus-core import Data.VectorSpace -- package: vector-space @@ -48,10 +51,10 @@ -- | A Paralleogram. -- data Parallelogram u = Parallelogram - { pll_ctm :: ShapeCTM u - , pll_base_width :: !u - , pll_height :: !u - , pll_base_l_ang :: Radian + { pll_ctm :: ShapeCTM u + , pll_base_width :: !u + , pll_height :: !u + , pll_base_left_ang :: Radian } type instance DUnit (Parallelogram u) = u @@ -88,21 +91,28 @@ -------------------------------------------------------------------------------- -- Anchors --- | 'runDisplaceCenter' : @ ( half_base_width --- * half_height +-- | 'runDisplaceCenter' : @ ( base_width +-- * height -- * base_minor --- * base_major -> Vec ) * parallelogram -> Point @ +-- -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u) => (u -> u -> Radian -> Vec2 u) -> Parallelogram u -> Anchor u -runDisplaceCenter fn (Parallelogram { pll_ctm = ctm - , pll_base_width = bw - , pll_height = h - , pll_base_l_ang = lang }) = - projectFromCtr (fn (0.5 * bw) (0.5 * h) lang) ctm +runDisplaceCenter fn (Parallelogram { pll_ctm = ctm + , pll_base_width = bw + , pll_height = h + , pll_base_left_ang = lang }) = + projectFromCtr (fn bw h lang) ctm +runDisplaceCenterHalves :: (Real u, Floating u) + => (u -> u -> Radian -> Vec2 u) + -> Parallelogram u + -> Anchor u +runDisplaceCenterHalves fn = + runDisplaceCenter $ \bw h bl_ang -> fn (0.5*bw) (0.5*h) bl_ang + instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where center = runDisplaceCenter $ \_ _ _ -> V2 0 0 @@ -115,18 +125,18 @@ instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where - topLeftCorner = runDisplaceCenter $ \hw hh lang -> + topLeftCorner = runDisplaceCenterHalves $ \hw hh lang -> let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang hypo - topRightCorner = runDisplaceCenter $ \hw hh lang -> + topRightCorner = runDisplaceCenterHalves $ \hw hh lang -> let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang hypo instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where - bottomLeftCorner = runDisplaceCenter $ \hw hh lang -> + bottomLeftCorner = runDisplaceCenterHalves $ \hw hh lang -> let hypo = hh / (fromRadian $ sin lang) in hvec (-hw) ^+^ avec lang (-hypo) - bottomRightCorner = runDisplaceCenter $ \hw hh lang -> + bottomRightCorner = runDisplaceCenterHalves $ \hw hh lang -> let hypo = hh / (fromRadian $ sin lang) in hvec hw ^+^ avec lang (-hypo) @@ -142,28 +152,30 @@ -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor (Parallelogram u) where - north = runDisplaceCenter $ \_ hh _ -> V2 0 hh - south = runDisplaceCenter $ \_ hh _ -> V2 0 (-hh) - east = runDisplaceCenter $ \hw _ _ -> V2 hw 0 - west = runDisplaceCenter $ \hw _ _ -> V2 (-hw) 0 + north = radialAnchor (0.5 * pi) + south = radialAnchor (1.5 * pi) + east = radialAnchor 0 + west = radialAnchor pi instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Parallelogram u) where - northeast = pllRadialAnchor (0.25*pi) - southeast = pllRadialAnchor (1.75*pi) - southwest = pllRadialAnchor (1.25*pi) - northwest = pllRadialAnchor (0.75*pi) + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Parallelogram u) where - radialAnchor = pllRadialAnchor + radialAnchor ang = runDisplaceCenter $ \bw h bl_ang-> + maybe zeroVec id $ pllRadialAnchor bw h bl_ang ang + -- | Note - it is not worth changing this to a quadrantAlg. -- -- There are pathological parallelograms that the current @@ -171,19 +183,12 @@ -- needed (rather than better implementation of QuadrantAlg). -- pllRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => Radian -> Parallelogram u -> Anchor u -pllRadialAnchor theta (Parallelogram { pll_ctm = ctm - , pll_base_width = bw - , pll_height = h - , pll_base_l_ang = lang }) = - post $ findIntersect zeroPt theta $ polygonLineSegments ps - where - ps = runVertices4 zeroPt $ parallelogramVertices bw h lang + => u -> u -> Radian -> Radian -> Maybe (Vec2 u) +pllRadialAnchor bw h bl_ang ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp + where + rp = anaTrailPath zeroPt $ parallelogram_trail bw h bl_ang - post = \ans -> case ans of - Nothing -> projectFromCtr (V2 0 0) ctm - Just (P2 x y) -> projectFromCtr (V2 x y) ctm - -------------------------------------------------------------------------------- -- Construction @@ -195,7 +200,7 @@ parallelogram :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Radian -> Shape Parallelogram u parallelogram bw h lang = - makeShape (mkParallelogram bw h lang) (mkParallelogramPath 0 bw h lang) + makeShape (mkParallelogram bw h lang) (mkParallelogramPath bw h lang) -- | 'zparallelogram' : @ base_width * height -> Parallelogram @ @@ -213,21 +218,21 @@ mkParallelogram :: (Real u, Fractional u, InterpretUnit u, Tolerance u) => u -> u -> Radian -> LocThetaQuery u (Parallelogram u) -mkParallelogram bw h lang = qpromoteLocTheta $ \ctr theta -> - pure $ Parallelogram { pll_ctm = makeShapeCTM ctr theta - , pll_base_width = bw - , pll_height = h - , pll_base_l_ang = lang +mkParallelogram bw h bl_ang = qpromoteLocTheta $ \ctr theta -> + pure $ Parallelogram { pll_ctm = makeShapeCTM ctr theta + , pll_base_width = bw + , pll_height = h + , pll_base_left_ang = bl_ang } mkParallelogramPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> Radian -> LocThetaQuery u (AbsPath u) -mkParallelogramPath rnd bw h lang = qpromoteLocTheta $ \ctr theta -> - let xs = runVertices4 ctr $ parallelogramVertices bw h lang - in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs + => u -> u -> Radian -> LocThetaQuery u (AbsPath u) +mkParallelogramPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rparallelogram_trail bw h bl_ang theta + 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,10 +27,11 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core @@ -124,7 +125,7 @@ east = runDisplaceCenter $ \hw _ -> V2 hw 0 west = runDisplaceCenter $ \hw _ -> V2 (-hw) 0 -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Rectangle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -132,11 +133,10 @@ northwest = radialAnchor (0.75*pi) -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Rectangle u) where - radialAnchor theta = runDisplaceCenter $ \hw hh -> - rectRadialVector hw hh theta - + radialAnchor ang = runDisplaceCenter $ \hw hh -> + maybe zeroVec id $ rectangleRadialIntersect (2*hw) (2*hh) ang -------------------------------------------------------------------------------- @@ -148,7 +148,7 @@ rectangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Shape Rectangle u rectangle w h = - makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath 0 (0.5*w) (0.5*h)) + makeShape (mkRectangle (0.5*w) (0.5*h)) (mkRectPath (0.5*w) (0.5*h)) mkRectangle :: InterpretUnit u => u -> u -> LocThetaQuery u (Rectangle u) @@ -158,12 +158,12 @@ , rect_hh = hh } - mkRectPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkRectPath rnd hw hh = qpromoteLocTheta $ \ctr theta -> - let xs = runVertices4 ctr $ rectangleVertices hw hh - in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs - + => u -> u -> LocThetaQuery u (AbsPath u) +mkRectPath hw hh = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rrectangle_trail (2*hw) (2*hh) theta + + + 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,18 +24,16 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Intersection -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space - import Control.Applicative @@ -50,15 +48,6 @@ type instance DUnit (Semicircle u) = u --- | Height minor and major. --- -data SyntheticProps u = SP - { sc_hminor :: u - , sc_hmajor :: u - } - -type instance DUnit (SyntheticProps u) = u - type DSemicircle = Semicircle Double @@ -76,14 +65,15 @@ -- -- to get the yminor. -- -synthesizeProps :: Floating u => u -> SyntheticProps u -synthesizeProps radius = - SP { sc_hminor = hminor, sc_hmajor = hmajor } - where - hminor = (4 * radius) / (3 * pi) - hmajor = radius - hminor +hminor :: Floating u => u -> u +hminor radius = (4 * radius) / (3 * pi) + +hmajor :: Floating u => u -> u +hmajor radius = radius - hminor radius + + -------------------------------------------------------------------------------- -- Affine trans @@ -112,34 +102,31 @@ -- * height_major -> Vec ) * semicircle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> Vec2 u) -> Semicircle u -> Anchor u + => (u -> Vec2 u) -> Semicircle u -> Anchor u runDisplaceCenter fn (Semicircle { sc_ctm = ctm , sc_radius = radius }) = - projectFromCtr (fn radius hminor hmajor) ctm - where - props = synthesizeProps radius - hminor = sc_hminor props - hmajor = sc_hmajor props + projectFromCtr (fn radius) ctm + instance (Real u, Floating u) => CenterAnchor (Semicircle u) where - center = runDisplaceCenter $ \_ _ _ -> V2 0 0 + center = runDisplaceCenter $ \_ -> V2 0 0 instance (Real u, Floating u) => ApexAnchor (Semicircle u) where - apex = runDisplaceCenter $ \_ _ cmaj -> V2 0 cmaj + apex = runDisplaceCenter $ \r -> V2 0 (hmajor r) instance (Real u, Floating u) => BottomCornerAnchor (Semicircle u) where - bottomLeftCorner = runDisplaceCenter $ \r hminor _ -> V2 (-r) (-hminor) - bottomRightCorner = runDisplaceCenter $ \r hminor _ -> V2 r (-hminor) + bottomLeftCorner = runDisplaceCenter $ \r -> V2 (-r) (negate $ hminor r) + bottomRightCorner = runDisplaceCenter $ \r -> V2 r (negate $ hminor r) instance (Real u, Floating u) => CardinalAnchor (Semicircle u) where north = apex - south = runDisplaceCenter $ \_ cmin _ -> V2 0 (-cmin) - east = runDisplaceCenter $ \r cmin _ -> let x = pyth r cmin in V2 x 0 - west = runDisplaceCenter $ \r cmin _ -> let x = pyth r cmin in V2 (-x) 0 + south = runDisplaceCenter $ \r -> V2 0 (negate $ hminor r) + east = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 x 0 + west = runDisplaceCenter $ \r -> let x = pyth r (hminor r) in V2 (-x) 0 -- | Use Pythagoras formula for working out the /east/ and /west/ -- distances. A right-triangle is formed below the centroid, @@ -151,7 +138,7 @@ pow2 = (^ (2::Int)) -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Semicircle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -161,70 +148,21 @@ -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Semicircle u) where - radialAnchor theta = runDisplaceCenter (scRadialVec theta) - --- helpers - --- | Semicircle does not fit into a QuadrantAlg easily. --- --- So all the work has to be done here. --- -scRadialVec :: (Real u, Floating u, Ord u, Tolerance u) - => Radian -> u -> u -> u -> Vec2 u -scRadialVec theta radius hminor _ = go (circularModulo theta) - where - (lang,rang) = baselineRange radius hminor - (bctr, br, _, bl) = constructionPoints radius hminor - plane = inclinedLine zeroPt theta - base_line = LineSegment bl br - left_curve = mkCurve radius half_pi bctr - right_curve = mkCurve radius 0 bctr - post = maybe (V2 0 0) (\(P2 x y) -> V2 x y) - go a - | lang <= a && a <= rang = post $ interLinesegLine base_line plane - | half_pi <= a && a < lang = post $ interCurveLine left_curve plane - | otherwise = post $ interCurveLine right_curve plane - - - -mkCurve :: Floating u => u -> Radian -> Point2 u -> BezierCurve u -mkCurve radius theta ctr = BezierCurve p0 p1 p2 p3 - where - (BezierCurve p0 p1 p2 p3) = bezierMinorArc half_pi radius theta ctr + radialAnchor ang = runDisplaceCenter $ \r -> + maybe zeroVec id $ semicircleRadialAnchor r ang --- | 'constructionPoints' : @ radius * hminor -> --- (base_ctr, base_right, apex, base_left) @ --- --- Assumes centroid is (0,0). --- -constructionPoints :: Num u - => u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u) -constructionPoints radius hminor = (bctr, br, apx, bl) +semicircleRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> Radian -> Maybe (Vec2 u) +semicircleRadialAnchor r ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp where - bctr = P2 0 (-hminor) - br = bctr .+^ hvec radius - apx = bctr .+^ vvec radius - bl = bctr .+^ hvec (-radius) - - + rp = anaTrailPath zeroPt $ semicircle_trail r --- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @ --- --- Find the angle range where a ray from the centroid will cross --- the baseline rather than cut the curve. --- -baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian) -baselineRange radius hminor = (lang, rang) - where - ang = toRadian $ atan (radius / hminor) - lang = (1.5*pi) - ang - rang = (1.5*pi) + ang - -------------------------------------------------------------------------------- -- Construction @@ -232,10 +170,7 @@ -- semicircle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> Shape Semicircle u -semicircle radius = - let props = synthesizeProps radius - in makeShape (mkSemicircle radius) - (mkSemicirclePath radius (sc_hminor props)) +semicircle radius = makeShape (mkSemicircle radius) (mkSemicirclePath radius) @@ -252,8 +187,7 @@ -- the center properly... -- mkSemicirclePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> LocThetaQuery u (AbsPath u) -mkSemicirclePath radius cminor = qpromoteLocTheta $ \pt theta -> - let ctr = dispPerpendicular (-cminor) theta pt - in pure $ curvePath $ bezierArcPoints pi radius theta ctr + => u -> LocThetaQuery u (AbsPath u) +mkSemicirclePath radius = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rsemicircle_trail radius theta 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,17 +24,15 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry.Base -- package: wumpus-basic -import Wumpus.Basic.Geometry.Intersection -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space - import Control.Applicative @@ -51,12 +49,6 @@ type instance DUnit (Semiellipse u) = u -data SyntheticProps u = SP - { se_hminor :: u - , se_hmajor :: u - } - -type instance DUnit (SyntheticProps u) = u type DSemiellipse = Semiellipse Double @@ -65,14 +57,13 @@ -synthesizeProps :: Floating u => u -> SyntheticProps u -synthesizeProps ry = - SP { se_hminor = ry_minor, se_hmajor = ry_major } - where - ry_minor = (4 * ry) / (3 * pi) - ry_major = ry - ry_minor +ryminor :: Floating u => u -> u +ryminor ry = (4 * ry) / (3 * pi) +rymajor :: Floating u => u -> u +rymajor ry = ry - ryminor ry + -------------------------------------------------------------------------------- -- Affine trans @@ -103,41 +94,37 @@ -- * ry_major -> Vec ) * semiellipse -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> u -> Vec2 u) -> Semiellipse u -> Anchor u + => (u -> u -> Vec2 u) -> Semiellipse u -> Anchor u runDisplaceCenter fn (Semiellipse { se_ctm = ctm , se_rx = rx , se_ry = ry }) = - projectFromCtr (fn rx ry hminor hmajor) ctm - where - props = synthesizeProps ry - hminor = se_hminor props - hmajor = se_hmajor props + projectFromCtr (fn rx ry) ctm instance (Real u, Floating u) => CenterAnchor (Semiellipse u) where - center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 + center = runDisplaceCenter $ \_ _ -> V2 0 0 instance (Real u, Floating u, Tolerance u) => ApexAnchor (Semiellipse u) where - apex = runDisplaceCenter $ \_ _ _ ry_major -> V2 0 ry_major + apex = runDisplaceCenter $ \_ ry -> V2 0 (rymajor ry) instance (Real u, Floating u) => BottomCornerAnchor (Semiellipse u) where - bottomLeftCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 (-rx) (-ry_minor) - bottomRightCorner = runDisplaceCenter $ \rx _ ry_minor _ -> V2 rx (-ry_minor) + bottomLeftCorner = runDisplaceCenter $ \rx ry -> V2 (-rx) (negate $ ryminor ry) + bottomRightCorner = runDisplaceCenter $ \rx ry -> V2 rx (negate $ ryminor ry) -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor (Semiellipse u) where north = apex - south = runDisplaceCenter $ \_ _ ry_minor _ -> V2 0 (-ry_minor) + south = runDisplaceCenter $ \_ ry -> V2 0 (negate $ ryminor ry) east = radialAnchor 0 west = radialAnchor pi -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Semiellipse u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -146,56 +133,18 @@ -instance (Real u, Floating u, Tolerance u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Semiellipse u) where - radialAnchor theta = runDisplaceCenter (seRadialVec theta) - - -seRadialVec :: (Real u, Floating u, Ord u, Tolerance u) - => Radian -> u -> u -> u -> u -> Vec2 u -seRadialVec theta rx ry hminor _ = go theta - where - (lang,rang) = baselineRange rx hminor - (bctr, br, _, bl) = constructionPoints rx ry hminor - plane = inclinedLine zeroPt theta - base_line = LineSegment bl br - (right_curve,left_curve) = bezierSemiellipse rx ry bctr - post = maybe (V2 0 0) (\(P2 x y) -> V2 x y) - go a | lang <= a && a <= rang = post $ interLinesegLine base_line plane - | half_pi <= a && a < lang = post $ interCurveLine left_curve plane - | otherwise = post $ interCurveLine right_curve plane - - - --- | 'constructionPoints' : @ rx * ry * hminor -> --- (base_ctr, base_right, apex, base_left) @ --- --- Assumes centroid is (0,0). --- -constructionPoints :: Num u - => u -> u -> u -> (Point2 u, Point2 u, Point2 u, Point2 u) -constructionPoints rx ry hminor = (bctr, br, apx, bl) - where - bctr = P2 0 (-hminor) - br = bctr .+^ hvec rx - apx = bctr .+^ vvec ry - bl = bctr .+^ hvec (-rx) - - + radialAnchor ang = runDisplaceCenter $ \rx ry -> + maybe zeroVec id $ semiellipseRadialAnchor rx ry ang --- | 'baselineRange' : @ radius * hminor -> (left_base_ang, right_base_ang) @ --- --- Find the angle range where a ray from the centroid will cross --- the baseline rather than cut the curve. --- -baselineRange :: (Real u, Floating u) => u -> u -> (Radian, Radian) -baselineRange rx hminor = (lang, rang) +semiellipseRadialAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) + => u -> u -> Radian -> Maybe (Vec2 u) +semiellipseRadialAnchor rx ry ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp where - ang = toRadian $ atan (rx / hminor) - lang = (1.5*pi) - ang - rang = (1.5*pi) + ang - + rp = anaTrailPath zeroPt $ semiellipse_trail rx ry -------------------------------------------------------------------------------- @@ -206,10 +155,7 @@ -- semiellipse :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Shape Semiellipse u -semiellipse rx ry = - let props = synthesizeProps ry - in makeShape (mkSemiellipse rx ry) - (mkSemiellipsePath rx ry (se_hminor props)) +semiellipse rx ry = makeShape (mkSemiellipse rx ry) (mkSemiellipsePath rx ry) @@ -224,46 +170,7 @@ mkSemiellipsePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> LocThetaQuery u (AbsPath u) -mkSemiellipsePath rx ry hminor = qpromoteLocTheta $ \pt theta -> - let ctr = dispPerpendicular (-hminor) theta pt - xs = bezierSemiellipsePoints rx ry ctr - in return $ curvePath $ map (rotateAbout theta ctr) xs - - -bezierSemiellipsePoints :: Floating u - => u -> u -> Point2 u -> [Point2 u] -bezierSemiellipsePoints rx ry pt = [ p0, c1,c2,p3, c4,c5,p6 ] - where - (BezierCurve p0 c1 c2 p3, BezierCurve _ c4 c5 p6) = bezierSemiellipse rx ry pt - - --- For Geometry? - --- | Generate the bezier arcs for quadrants I and II. --- --- Drawing is expected to proceed CCW. --- --- Note - Point is the (full) ellipse center. --- -bezierSemiellipse :: Floating u - => u -> u -> Point2 u -> (BezierCurve u, BezierCurve u) -bezierSemiellipse rx ry (P2 x y) = - (BezierCurve p00 c01 c02 p03, BezierCurve p03 c04 c05 p06) - where - lrx = rx * kappa - lry = ry * kappa - p00 = P2 (x + rx) y - c01 = p00 .+^ vvec lry - c02 = p03 .+^ hvec lrx - - p03 = P2 x (y + ry) - c04 = p03 .+^ hvec (-lrx) - c05 = p06 .+^ vvec lry - - p06 = P2 (x - rx) y - - + => u -> u -> LocThetaQuery u (AbsPath u) +mkSemiellipsePath rx ry = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rsemiellipse_trail rx ry theta -kappa :: Floating u => u -kappa = 4 * ((sqrt 2 - 1) / 3) 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,11 +25,12 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -46,10 +47,11 @@ -- | A trapezium. -- data Trapezium u = Trapezium - { tz_ctm :: ShapeCTM u - , tz_base_width :: !u - , tz_top_width :: !u - , tz_height :: !u + { tz_ctm :: ShapeCTM u + , tz_base_width :: !u + , tz_top_width :: !u + , tz_height :: !u + , tz_bottom_left_ang :: Radian } type instance DUnit (Trapezium u) = u @@ -57,7 +59,8 @@ type DTrapezium = Trapezium Double instance Functor Trapezium where - fmap f (Trapezium ctm bw tw h) = Trapezium (fmap f ctm) (f bw) (f tw) (f h) + fmap f (Trapezium ctm bw tw h ang) = + Trapezium (fmap f ctm) (f bw) (f tw) (f h) ang -------------------------------------------------------------------------------- -- Affine trans @@ -83,20 +86,34 @@ -- Anchors - --- | 'runDisplaceCenter' : @ ( half_base_width --- * half_top_width --- * half_height -> Vec ) * trapezium -> Point @ +-- | 'runDisplaceCenter' : @ ( base_width +-- * height +-- * bl_ang -> Vec ) * trapezium -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> Vec2 u) + => (u -> u -> Radian -> Vec2 u) -> Trapezium u -> Anchor u -runDisplaceCenter fn (Trapezium { tz_ctm = ctm - , tz_base_width = bw - , tz_top_width = tw - , tz_height = h }) = +runDisplaceCenter fn (Trapezium { tz_ctm = ctm + , tz_base_width = bw + , tz_height = h + , tz_bottom_left_ang = bl_ang }) = + projectFromCtr (fn bw h bl_ang) ctm + + +-- | 'runDisplaceCenterHalves' : @ ( half_base_width +-- * half_top_width +-- * half_height -> Vec ) * trapezium -> Point @ +-- +runDisplaceCenterHalves :: (Real u, Floating u) + => (u -> u -> u -> Vec2 u) + -> Trapezium u -> Anchor u +runDisplaceCenterHalves fn (Trapezium { tz_ctm = ctm + , tz_base_width = bw + , tz_top_width = tw + , tz_height = h }) = projectFromCtr (fn (0.5 * bw) (0.5 * tw) (0.5 * h)) ctm + instance (Real u, Floating u) => CenterAnchor (Trapezium u) where center = runDisplaceCenter $ \_ _ _ -> V2 0 0 @@ -105,8 +122,8 @@ instance (Real u, Floating u) => BottomCornerAnchor (Trapezium u) where - bottomLeftCorner = runDisplaceCenter $ \hbw _ hh -> V2 (-hbw) (-hh) - bottomRightCorner = runDisplaceCenter $ \hbw _ hh -> V2 hbw (-hh) + bottomLeftCorner = runDisplaceCenterHalves $ \hbw _ hh -> V2 (-hbw) (-hh) + bottomRightCorner = runDisplaceCenterHalves $ \hbw _ hh -> V2 hbw (-hh) @@ -114,8 +131,8 @@ instance (Real u, Floating u) => TopCornerAnchor (Trapezium u) where - topLeftCorner = runDisplaceCenter $ \_ htw hh -> V2 (-htw) hh - topRightCorner = runDisplaceCenter $ \_ htw hh -> V2 htw hh + topLeftCorner = runDisplaceCenterHalves $ \_ htw hh -> V2 (-htw) hh + topRightCorner = runDisplaceCenterHalves $ \_ htw hh -> V2 htw hh instance (Real u, Floating u, Tolerance u) => @@ -131,39 +148,36 @@ instance (Real u, Floating u, Tolerance u) => CardinalAnchor (Trapezium u) where - north = runDisplaceCenter $ \_ _ hh -> V2 0 hh - south = runDisplaceCenter $ \_ _ hh -> V2 0 (-hh) - east = tzRadialAnchor 0 - west = tzRadialAnchor pi + north = radialAnchor half_pi + south = radialAnchor (1.5 * pi) + east = radialAnchor 0 + west = radialAnchor pi instance (Real u, Floating u, Tolerance u) => CardinalAnchor2 (Trapezium u) where - northeast = tzRadialAnchor (0.25*pi) - southeast = tzRadialAnchor (1.75*pi) - southwest = tzRadialAnchor (1.25*pi) - northwest = tzRadialAnchor (0.75*pi) + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) instance (Real u, Floating u, Tolerance u) => RadialAnchor (Trapezium u) where - radialAnchor = tzRadialAnchor + radialAnchor ang = runDisplaceCenter $ \bw h bl_ang -> + maybe zeroVec id $ trapeziumRadialAnchor bw h bl_ang ang + -- -tzRadialAnchor :: (Real u, Floating u, Tolerance u) - => Radian -> Trapezium u -> Anchor u -tzRadialAnchor theta (Trapezium { tz_ctm = ctm - , tz_base_width = bw - , tz_top_width = tw - , tz_height = h }) = - post $ findIntersect zeroPt theta $ polygonLineSegments ps - where - ps = runVertices4 zeroPt $ isoscelesTrapeziumVertices bw tw h - post = \ans -> case ans of - Nothing -> projectFromCtr (V2 0 0) ctm - Just (P2 x y) -> projectFromCtr (V2 x y) ctm - +trapeziumRadialAnchor :: (Real u, Floating u, Tolerance u) + => u -> u -> Radian -> Radian -> Maybe (Vec2 u) +trapeziumRadialAnchor bw h bl_ang ang = + fmap (pvec zeroPt) $ rayPathIntersection (inclinedRay zeroPt ang) rp + where + rp = anaTrailPath zeroPt $ trapezium_trail bw h bl_ang + + -------------------------------------------------------------------------------- -- Construction @@ -174,9 +188,9 @@ -- -- trapezium :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> Shape Trapezium u -trapezium bw tw h = - makeShape (mkTrapezium bw tw h) (mkTrapeziumPath 0 bw tw h) + => u -> u -> Radian -> Shape Trapezium u +trapezium bw h base_ang = + makeShape (mkTrapezium bw h base_ang) (mkTrapeziumPath bw h base_ang) @@ -185,19 +199,22 @@ mkTrapezium :: (Real u, Fractional u, InterpretUnit u) - => u -> u -> u -> LocThetaQuery u (Trapezium u) -mkTrapezium bw tw h = qpromoteLocTheta $ \ctr theta -> - pure $ Trapezium { tz_ctm = makeShapeCTM ctr theta - , tz_base_width = bw - , tz_top_width = tw - , tz_height = h + => u -> u -> Radian -> LocThetaQuery u (Trapezium u) +mkTrapezium bw h base_ang = qpromoteLocTheta $ \ctr theta -> + pure $ Trapezium { tz_ctm = makeShapeCTM ctr theta + , tz_base_width = bw + , tz_top_width = tw + , tz_height = h + , tz_bottom_left_ang = base_ang } + where + base_minor = h / (fromRadian $ tan base_ang) + tw = bw - (2 * base_minor) mkTrapeziumPath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) -mkTrapeziumPath rnd bw tw h = qpromoteLocTheta $ \ctr theta -> - let xs = runVertices4 ctr $ isoscelesTrapeziumVertices bw tw h - in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs + => u -> u -> Radian -> LocThetaQuery u (AbsPath u) +mkTrapeziumPath bw h bl_ang = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ rtrapezium_trail bw h bl_ang theta 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,11 +24,13 @@ ) where +import Wumpus.Drawing.Basis.ShapeTrails +import Wumpus.Drawing.Basis.Geometry import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.Intersection import Wumpus.Drawing.Shapes.Base -import Wumpus.Basic.Geometry -- package: wumpus-basic -import Wumpus.Basic.Kernel +import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core @@ -49,36 +51,21 @@ } type instance DUnit (Triangle u) = u - -data SyntheticProps u = SyntheticProps - { tri_hmajor :: u - , tri_hminor :: u - , tri_base_ang :: Radian - , tri_apex_ang :: Radian - } - type DTriangle = Triangle Double instance Functor Triangle where fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h) -synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u -synthesizeProps bw h = - SyntheticProps { tri_hmajor = hmajor - , tri_hminor = hminor - , tri_base_ang = base_ang - , tri_apex_ang = apex_ang - } - where - half_base = 0.5 * bw - hminor = h / 3 - hmajor = 2 * hminor - base_ang = atan $ toRadian (h / half_base) - apex_ang = 2 * ((pi/4) - base_ang) +hminor :: Fractional u => u -> u +hminor h = h / 3 +hmajor :: Fractional u => u -> u +hmajor h = 2 * (h / 3) + + -------------------------------------------------------------------------------- -- Affine trans @@ -107,33 +94,29 @@ -- * base_ang -> Vec ) * traingle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) - => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Anchor u + => (u -> u -> Vec2 u) -> Triangle u -> Anchor u runDisplaceCenter fn (Triangle { tri_ctm = ctm , tri_base_width = bw , tri_height = h }) = - projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm - where - props = synthesizeProps bw h - hminor = tri_hminor props - hmajor = tri_hmajor props - base_ang = tri_base_ang props - + projectFromCtr (fn bw h) ctm instance (Real u, Floating u) => CenterAnchor (Triangle u) where - center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 + center = runDisplaceCenter $ \_ _ -> V2 0 0 instance (Real u, Floating u) => ApexAnchor (Triangle u) where - apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj + apex = runDisplaceCenter $ \_ h -> V2 0 (hmajor h) instance (Real u, Floating u) => BottomCornerAnchor (Triangle u) where - bottomLeftCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 (-hbw) (-hmin) - bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 hbw (-hmin) + bottomLeftCorner = runDisplaceCenter $ \bw h -> + V2 (negate $ 0.5 * bw) (negate $ hminor h) + bottomRightCorner = runDisplaceCenter $ \bw h -> + V2 (0.5 * bw) (negate $ hminor h) -- east and west should be parallel to the centroid. @@ -141,10 +124,10 @@ instance (Real u, Floating u) => CardinalAnchor (Triangle u) where - north = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj - south = runDisplaceCenter $ \_ hmin _ _ -> V2 0 (-hmin) - east = runDisplaceCenter $ \hbw hmin _ ang -> findEast hbw hmin ang - west = runDisplaceCenter $ \hbw hmin _ ang -> findWest hbw hmin ang + north = runDisplaceCenter $ \_ h -> V2 0 (hmajor h) + south = runDisplaceCenter $ \_ h -> V2 0 (negate $ hminor h) + east = runDisplaceCenter $ \bw h -> findEast bw h + west = runDisplaceCenter $ \bw h -> findWest bw h instance (Real u, Floating u) => @@ -156,18 +139,20 @@ step _ = midpoint (bottomRightCorner a) (apex a) -findEast :: Fractional u => u -> u -> Radian -> Vec2 u -findEast half_base_width hminor base_ang = V2 xdist 0 +findEast :: (Real u, Fractional u) => u -> u -> Vec2 u +findEast bw h = V2 xdist 0 where - b1 = hminor / (fromRadian $ tan base_ang) - xdist = half_base_width - b1 + half_base = 0.5 * bw + base_ang = atan $ toRadian (h / half_base) + b1 = (hminor h) / (fromRadian $ tan base_ang) + xdist = (0.5 * bw) - b1 -findWest :: Fractional u => u -> u -> Radian -> Vec2 u -findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (-xdist) 0 +findWest :: (Real u, Fractional u) => u -> u -> Vec2 u +findWest bw h = let (V2 xdist 0) = findEast bw h in V2 (-xdist) 0 -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => CardinalAnchor2 (Triangle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) @@ -176,11 +161,14 @@ -instance (Real u, Floating u) => +instance (Real u, Floating u, InterpretUnit u, Tolerance u) => RadialAnchor (Triangle u) where - radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> - triangleRadialVector hbw hmin hmaj theta - + radialAnchor ang = runDisplaceCenter $ \bw h -> + maybe zeroVec id $ isoscelesTriangleRadialIntersect bw h ang + + + + -------------------------------------------------------------------------------- -- Construction @@ -190,11 +178,7 @@ -- triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Shape Triangle u -triangle bw h = - let props = synthesizeProps bw h - hminor = tri_hminor props - hmajor = tri_hmajor props - in makeShape (mkTriangle bw h) (mkTrianglePath 0 bw hminor hmajor) +triangle bw h = makeShape (mkTriangle bw h) (mkTrianglePath bw h) @@ -213,19 +197,7 @@ mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) - => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) -mkTrianglePath rnd bw hminor hmajor = qpromoteLocTheta $ \ctr theta -> - let xs = runVertices3 ctr $ trianglePath bw hminor hmajor - in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs - - - -trianglePath :: (Real u, Floating u) - => u -> u -> u -> Vertices3 u -trianglePath bw hminor hmajor = (br, apx, bl) - where - half_base = 0.5 * bw - br = V2 half_base (-hminor) - apx = V2 0 hmajor - bl = V2 (-half_base) (-hminor) + => u -> u -> LocThetaQuery u (AbsPath u) +mkTrianglePath bw h = qpromoteLocTheta $ \ctr theta -> + return $ anaTrailPath ctr $ risosceles_triangle_trail bw h theta 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 @@ -72,7 +72,7 @@ newtype GenDoc st u a = GenDoc { getGenDoc :: DocEnv -> GenPosObject st u a } type instance DUnit (GenDoc st u a) = u -type instance UState (GenDoc st u) = st +type instance UState (GenDoc st u a) = st type GenDocGraphic st u = GenDoc st u (UNil u) @@ -243,20 +243,20 @@ strikethrough :: (Fractional u, InterpretUnit u) => GenDoc st u a -> GenDoc st u a -strikethrough = decorateDoc SUPERIOR drawStrikethrough +strikethrough = decorateDoc ZABOVE drawStrikethrough underline :: (Fractional u, InterpretUnit u) => GenDoc st u a -> GenDoc st u a -underline = decorateDoc SUPERIOR drawUnderline +underline = decorateDoc ZABOVE drawUnderline highlight :: (Fractional u, InterpretUnit u) => RGBi -> GenDoc st u a -> GenDoc st u a -highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb) +highlight rgb = decorateDoc ZBELOW (drawBackfill rgb) decorateDoc :: InterpretUnit u - => ZDeco -> (Orientation u -> LocGraphic u) -> GenDoc st u a + => ZOrder -> (Orientation u -> LocGraphic u) -> GenDoc st u a -> GenDoc st u a decorateDoc zdec fn ma = GenDoc $ \env -> decoratePosObject zdec fn $ getGenDoc ma env 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 @@ -59,7 +59,7 @@ -> LocImage u a -> LocImage u a locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> - selaborate (obj `at` pt) (\a -> ignoreAns $ mklabel rpos `at` fn a) + elaborateAbove (obj `at` pt) (\a -> ignoreAns $ mklabel rpos `at` fn a) @@ -96,7 +96,7 @@ -> Image u (AbsPath u) -> Image u (AbsPath u) connectorPathLabel fn rpos lbl img = - selaborate img (\a -> ignoreAns $ lbl rpos `at` (fn a)) + elaborateAbove img (\a -> ignoreAns $ lbl rpos `at` (fn a)) label_midway_of :: (Real u, Floating u, InterpretUnit u) diff --git a/src/Wumpus/Drawing/Text/DocSymbols.hs b/src/Wumpus/Drawing/Text/DocSymbols.hs --- a/src/Wumpus/Drawing/Text/DocSymbols.hs +++ b/src/Wumpus/Drawing/Text/DocSymbols.hs @@ -44,7 +44,7 @@ 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) + gf = capHeight >>= \h -> moveStart (go_up $ 0.5 * h) (S.scircle $ 0.5 * h) @@ -52,7 +52,7 @@ 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) + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.scircle $ 0.25 * h) empty_box :: (Fractional u, InterpretUnit u) => GenDocGraphic st u empty_box = embedPosObject $ makePosObject qy gf @@ -66,13 +66,13 @@ 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) + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sleft_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) + gf = capHeight >>= \h -> moveStart (go_up $ 0.33 * h) (S.sright_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 @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.VersionNumber --- Copyright : (c) Stephen Tetley 2010-2011 +-- Copyright : (c) Stephen Tetley 2010-2012 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,7,0) +-- > (0,9,0) -- wumpus_drawing_version :: (Int,Int,Int) -wumpus_drawing_version = (0,7,0) +wumpus_drawing_version = (0,9,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.7.0 +version: 0.9.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -38,8 +38,23 @@ . Changelog: . - v0.6.0 to v0.7.0 + v0.8.0 to v0.9.0: + . + * Updated to work with wumpus-basic-0.24.0. . + * Removed monoid mappend alias @(<>)@ as it is now defined by + Data.Monoid. + . + v0.7.0 to v0.8.0: + . + * Changed API to make Connectors. + . + * Added InclineTrails to Drawing.Basis. + . + * Reworked @Extras.Loop@. + . + 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 @@ -53,7 +68,7 @@ . * Added a tube box connector. . - v0.5.0 to v0.6.0 + v0.5.0 to v0.6.0: . * Removed @LocTrace@ and @RefTrace@ from @Wumpus.Drawing.Basis@, they are superseded by @LocDrawing@ in Wumpus-Basic. @@ -91,11 +106,15 @@ containers >= 0.3 && <= 0.6, vector-space >= 0.6 && < 1.0, wumpus-core >= 0.52.0 && < 0.53.0, - wumpus-basic == 0.22.0 + wumpus-basic == 0.24.0 exposed-modules: + Wumpus.Drawing.Basis.BezierCurve, Wumpus.Drawing.Basis.DrawingPrimitives, + Wumpus.Drawing.Basis.Geometry, + Wumpus.Drawing.Basis.InclineTrails, + Wumpus.Drawing.Basis.ShapeTrails, Wumpus.Drawing.Basis.Symbols, Wumpus.Drawing.Colour.SVGColours, Wumpus.Drawing.Colour.X11Colours, @@ -113,6 +132,8 @@ Wumpus.Drawing.Extras.Loop, Wumpus.Drawing.Paths, Wumpus.Drawing.Paths.Base, + Wumpus.Drawing.Paths.Illustrate, + Wumpus.Drawing.Paths.Intersection, Wumpus.Drawing.Paths.PathBuilder, Wumpus.Drawing.Paths.Vamps, Wumpus.Drawing.Shapes,