diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -8,14 +8,14 @@ module ArrowCircuit where -import Wumpus.Basic.Arrows -import Wumpus.Basic.FontLoader.AfmLoader -import Wumpus.Basic.FontLoader.GSLoader -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Shapes -import Wumpus.Basic.Text.LRText +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -40,7 +40,8 @@ makeGSPicture :: FilePath -> IO () makeGSPicture font_dir = do putStrLn "Using GhostScript metrics..." - base_metrics <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] + (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing writeEPS "./out/arrow_circuit01.eps" pic1 writeSVG "./out/arrow_circuit01.svg" pic1 @@ -48,14 +49,15 @@ makeAfmPicture :: FilePath -> IO () makeAfmPicture font_dir = do putStrLn "Using AFM 4.1 metrics..." - base_metrics <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing writeEPS "./out/arrow_circuit02.eps" pic1 writeSVG "./out/arrow_circuit02.svg" pic1 -makeCtx :: BaseGlyphMetrics -> DrawingContext -makeCtx = fontface times_roman . metricsContext 11 +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace times_roman . metricsContext 11 @@ -93,7 +95,7 @@ , Real u, Floating u, FromPtSize u ) => ConnectorPath u -> Point2 u -> Point2 u -> m () connWith con p0 p1 = localize doublesize $ - drawi_ $ situ2 (strokeConnector (rightArrow con tri45)) p0 p1 + drawi_ $ apply2R2 (strokeConnector (rightArrow con tri45)) p0 p1 atext :: ( CenterAnchor t, DUnit t ~ u @@ -101,11 +103,11 @@ , TraceM m, DrawingCtxM m, u ~ MonUnit m ) => t -> String -> m () atext ancr ss = let pt = center ancr in - drawi_ $ singleLineCC ss `at` pt + drawi_ $ ctrCenterLine ss `at` pt ptext :: ( Real u, Floating u, FromPtSize u , TraceM m, DrawingCtxM m, u ~ MonUnit m ) => Point2 u -> String -> m () -ptext pt ss = localize (fontsize 14 . fontface times_italic) $ - drawi_ $ singleLineCC ss `at` pt +ptext pt ss = localize (fontAttr times_italic 14) $ + drawi_ $ ctrCenterLine ss `at` pt diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -3,11 +3,11 @@ module Arrowheads where -import Wumpus.Basic.Arrows -import Wumpus.Basic.Chains -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths hiding ( length ) +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths hiding ( length ) import Wumpus.Core -- package: wumpus-core @@ -75,7 +75,7 @@ => (Arrowhead u, Arrowhead u) -> Point2 u -> TraceDrawing u () makeArrowDrawing (arrl,arrr) p0 = - drawi_ $ situ2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1 + drawi_ $ apply2R2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1 where p1 = p0 .+^ hvec 100 diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -12,12 +12,11 @@ module ClipPic where -import Wumpus.Basic.Chains -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.DrawingComposition -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths -import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Text.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -76,7 +75,7 @@ iheartHaskell :: Num u => FromPtSize u => Point2 u -> TraceDrawing u () iheartHaskell pt = do draw $ textline "I Haskell" `at` pt - draw $ localize (fontface symbol) $ textline "&heart;" `at` (pt .+^ hvec 7) + draw $ localize (fontFace symbol) $ textline "&heart;" `at` (pt .+^ hvec 7) path01 :: Floating u => Path u diff --git a/demo/ColourChartUtils.hs b/demo/ColourChartUtils.hs --- a/demo/ColourChartUtils.hs +++ b/demo/ColourChartUtils.hs @@ -22,8 +22,8 @@ ) where -import qualified Wumpus.Basic.Colour.SVGColours as SVG -import qualified Wumpus.Basic.Colour.X11Colours as X11 +import qualified Wumpus.Drawing.Colour.SVGColours as SVG +import qualified Wumpus.Drawing.Colour.X11Colours as X11 import Wumpus.Core.Colour ( RGBi ) diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -4,8 +4,8 @@ import ColourChartUtils -import Wumpus.Basic.Chains -import Wumpus.Basic.Graphic +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains import Wumpus.Core -- package: wumpus-core diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -3,11 +3,11 @@ module Connectors where -import Wumpus.Basic.Arrows -import Wumpus.Basic.Chains -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths hiding ( length ) +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths hiding ( length ) import Wumpus.Core -- package: wumpus-core @@ -67,7 +67,7 @@ makeConnDrawing :: (Real u, Floating u, FromPtSize u) => ConnectorPath u -> Point2 u -> TraceDrawing u () makeConnDrawing conn p0 = - drawi_ $ situ2 (strokeConnector (dblArrow conn curveTip)) p0 p1 + drawi_ $ connect (strokeConnector (dblArrow conn curveTip)) p0 p1 where p1 = p0 .+^ vec 100 40 diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -3,13 +3,13 @@ module DotPic where -import Wumpus.Basic.Chains -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Dots.AnchorDots -import Wumpus.Basic.FontLoader.AfmLoader -import Wumpus.Basic.FontLoader.GSLoader -import Wumpus.Basic.Graphic -import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Dots.AnchorDots +import Wumpus.Drawing.Text.SafeFonts import FontLoaderUtils @@ -36,24 +36,26 @@ makeGSPicture :: FilePath -> IO () makeGSPicture font_dir = do putStrLn "Using GhostScript metrics..." - base_metrics <- loadGSMetrics font_dir ["Helvetica"] + (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing - writeEPS "./out/dots01.eps" pic1 - writeSVG "./out/dots01.svg" pic1 + writeEPS "./out/dots01_gs.eps" pic1 + writeSVG "./out/dots01_gs.svg" pic1 makeAfmPicture :: FilePath -> IO () makeAfmPicture font_dir = do putStrLn "Using AFM 4.1 metrics..." - base_metrics <- loadAfmMetrics font_dir ["Helvetica"] + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing - writeEPS "./out/dots02.eps" pic1 - writeSVG "./out/dots02.svg" pic1 + writeEPS "./out/dots01_afm.eps" pic1 + writeSVG "./out/dots01_afm.svg" pic1 -makeCtx :: BaseGlyphMetrics -> DrawingContext -makeCtx = fillColour peru . fontface helvetica . metricsContext 24 +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fillColour peru . fontFace helvetica . metricsContext 24 dot_drawing :: Drawing Double @@ -75,6 +77,7 @@ , dotFOCross , dotFDiamond , dotText "%" + , dotTriangle ] diff --git a/demo/DrawingCompo.hs b/demo/DrawingCompo.hs --- a/demo/DrawingCompo.hs +++ b/demo/DrawingCompo.hs @@ -2,9 +2,8 @@ module DrawingCompo where -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.DrawingComposition -import Wumpus.Basic.Graphic +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Colour.SVGColours import Wumpus.Core -- package: wumpus-core diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -5,14 +5,14 @@ module FeatureModel where -import Wumpus.Basic.Arrows -import Wumpus.Basic.FontLoader.AfmLoader -import Wumpus.Basic.FontLoader.GSLoader -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Shapes -import Wumpus.Basic.Text.LRText +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -35,7 +35,8 @@ makeGSPicture :: FilePath -> IO () makeGSPicture font_dir = do putStrLn "Using GhostScript metrics..." - base_metrics <- loadGSMetrics font_dir ["Courier-Bold"] + (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) feature_model writeEPS "./out/feature_model01.eps" pic1 writeSVG "./out/feature_model01.svg" pic1 @@ -43,13 +44,14 @@ makeAfmPicture :: FilePath -> IO () makeAfmPicture font_dir = do putStrLn "Using AFM 4.1 metrics..." - base_metrics <- loadAfmMetrics font_dir ["Courier-Bold"] + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx base_metrics) feature_model writeEPS "./out/feature_model02.eps" pic1 writeSVG "./out/feature_model02.svg" pic1 -makeCtx :: BaseGlyphMetrics -> DrawingContext -makeCtx = fontface courier_bold . metricsContext 18 +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace courier_bold . metricsContext 18 -- Note - I haven't worked out how to do @alternative@, @or@ and @@ -90,7 +92,7 @@ => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do a <- drawi $ strokedShape $ rectangle w 20 $ pt - drawi_ $ singleLineCC ss `at` center a + drawi_ $ ctrCenterLine ss `at` center a return a box :: (Real u, Floating u, FromPtSize u) @@ -105,10 +107,10 @@ connWith :: ( Real u, Floating u, FromPtSize u ) => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u) connWith arrh b0 b1 = do - lw <- lineWidth + lw <- getLineWidth let p0 = south b0 let p1 = northwards (realToFrac lw) b1 - drawi $ situ2 (strokeConnector (rightArrow connLine arrh)) p0 p1 + drawi $ apply2R2 (strokeConnector (rightArrow connLine arrh)) p0 p1 infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -2,11 +2,11 @@ module FontPic where -import Wumpus.Basic.Chains -import Wumpus.Basic.Graphic -import Wumpus.Basic.Colour.SVGColours ( steel_blue ) -import Wumpus.Basic.Colour.X11Colours ( indian_red1 ) -import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours ( steel_blue ) +import Wumpus.Drawing.Colour.X11Colours ( indian_red1 ) +import Wumpus.Drawing.Text.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -44,7 +44,7 @@ makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz) where - upd = fillColour rgb . fontsize sz . fontface ff + upd = fillColour rgb . fontAttr ff sz -- indian_red1 -- steel_blue diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs --- a/demo/LeftRightText.hs +++ b/demo/LeftRightText.hs @@ -16,13 +16,13 @@ module LeftRightText where -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Dots.Marks -import Wumpus.Basic.FontLoader.GSLoader -import Wumpus.Basic.FontLoader.AfmLoader -import Wumpus.Basic.Graphic -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Text.LRText +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts import FontLoaderUtils @@ -47,56 +47,110 @@ makeGSPicture :: FilePath -> IO () makeGSPicture font_dir = do putStrLn "Using GhostScript metrics..." - gs_metrics <- loadGSMetrics font_dir ["Helvetica"] + (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs let pic1 = runDrawingU (makeCtx gs_metrics) text_drawing - writeEPS "./out/new_text01.eps" pic1 - writeSVG "./out/new_text01.svg" pic1 + writeEPS "./out/lr_text01.eps" pic1 + writeSVG "./out/lr_text01.svg" pic1 makeAfmPicture :: FilePath -> IO () makeAfmPicture font_dir = do putStrLn "Using AFM 4.1 metrics..." - afm_metrics <- loadAfmMetrics font_dir ["Helvetica"] + (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs let pic2 = runDrawingU (makeCtx afm_metrics) text_drawing - writeEPS "./out/new_text02.eps" pic2 - writeSVG "./out/new_text02.svg" pic2 + writeEPS "./out/lr_text02.eps" pic2 + writeSVG "./out/lr_text02.svg" pic2 -makeCtx :: BaseGlyphMetrics -> DrawingContext -makeCtx = fontface helvetica . metricsContext 18 +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace helvetica . metricsContext 18 text_drawing :: Drawing Double text_drawing = drawTracing $ do - drawi_ $ (fn left_text) `at` P2 0 100 - drawi_ $ (fn center_text) `at` P2 200 100 - drawi_ $ (fn right_text) `at` P2 400 100 - drawi_ $ (fn blank_text) `at` P2 0 0 - drawi_ $ (fn bl_oneline) `at` P2 200 0 - drawi_ $ (fn cc_oneline) `at` P2 400 0 - - draw $ redPlus `at` P2 0 100 - draw $ redPlus `at` P2 200 100 - draw $ redPlus `at` P2 400 100 - draw $ redPlus `at` P2 0 0 - draw $ redPlus `at` P2 200 0 - draw $ redPlus `at` P2 400 0 - + drawi_ $ (fn left_text) `at` P2 0 400 + drawi_ $ (fn center_text) `at` P2 200 400 + drawi_ $ (fn right_text) `at` P2 400 400 + drawi_ $ (fn blank_text) `at` P2 0 300 + drawi_ $ (fn bl_oneline) `at` P2 200 300 + drawi_ $ (fn cc_oneline) `at` P2 400 300 + drawi_ $ (fn newblr) `at` P2 0 200 + drawi_ $ (fn newblc) `at` P2 200 200 + drawi_ $ (fn newbll) `at` P2 400 200 + drawi_ $ (fn rnewblr) `at` P2 0 100 + drawi_ $ (fn rnewblc) `at` P2 200 100 + drawi_ $ (fn rnewbll) `at` P2 400 100 + drawi_ $ (fn rleft_text) `at` P2 0 (-75) + drawi_ $ (fn rcenter_text) `at` P2 200 (-75) + drawi_ $ (fn rright_text) `at` P2 400 (-75) + + + draw $ redPlus `at` P2 0 400 + draw $ redPlus `at` P2 200 400 + draw $ redPlus `at` P2 400 400 + draw $ redPlus `at` P2 0 300 + draw $ redPlus `at` P2 200 300 + draw $ redPlus `at` P2 400 300 + draw $ redPlus `at` P2 0 200 + draw $ redPlus `at` P2 200 200 + draw $ redPlus `at` P2 400 200 + draw $ redPlus `at` P2 0 100 + draw $ redPlus `at` P2 200 100 + draw $ redPlus `at` P2 400 100 + draw $ redPlus `at` P2 0 (-75) + draw $ redPlus `at` P2 200 (-75) + draw $ redPlus `at` P2 400 (-75) + where fn = illustrateBoundedLocGraphic - + redPlus :: (Fractional u, FromPtSize u) => LocGraphic u redPlus = localize (strokeColour red) markPlus + +newblc :: BoundedLocGraphic Double +newblc = + localize (strokeColour dark_slate_gray) $ + baseCenterLine "new baseline center" + +newbll :: BoundedLocGraphic Double +newbll = + localize (strokeColour dark_slate_gray) $ + baseLeftLine "new baseline left" + +newblr :: BoundedLocGraphic Double +newblr = + localize (strokeColour dark_slate_gray) $ + baseRightLine "new baseline right" + + +rnewblc :: BoundedLocGraphic Double +rnewblc = + localize (strokeColour dark_slate_gray) $ + rbaseCenterLine "baseline center" `rot` (0.25*pi) + +rnewbll :: BoundedLocGraphic Double +rnewbll = + localize (strokeColour dark_slate_gray) $ + rbaseLeftLine "baseline left" `rot` (0.25*pi) + +rnewblr :: BoundedLocGraphic Double +rnewblr = + localize (strokeColour dark_slate_gray) $ + rbaseRightLine "baseline right" `rot` (0.25 * pi) + + bl_oneline :: BoundedLocGraphic Double bl_oneline = - localize (strokeColour dark_slate_gray) $ singleLineBL "Baseline-left..." + localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..." cc_oneline :: BoundedLocGraphic Double cc_oneline = - localize (strokeColour dark_slate_gray) $ singleLineCC "Center-center..." + localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..." blank_text :: BoundedLocGraphic Double blank_text = @@ -115,6 +169,23 @@ center_text :: BoundedLocGraphic Double center_text = localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text + + +rleft_text :: BoundedLocGraphic Double +rleft_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignLeft dummy_text `rot` (0.25*pi) + + +rright_text :: BoundedLocGraphic Double +rright_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignRight dummy_text `rot` (0.25*pi) + +rcenter_text :: BoundedLocGraphic Double +rcenter_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignCenter dummy_text `rot` (0.25*pi) dummy_text :: String diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs --- a/demo/PetriNet.hs +++ b/demo/PetriNet.hs @@ -7,14 +7,19 @@ module PetriNet where -import Wumpus.Basic.Arrows -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Graphic -- package: wumpus-basic -import Wumpus.Basic.Paths -import Wumpus.Basic.Shapes.Base -import Wumpus.Basic.Shapes.Derived -import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes.Base +import Wumpus.Drawing.Shapes.Derived +import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.LRText +import FontLoaderUtils + import Wumpus.Core -- package: wumpus-core @@ -22,15 +27,40 @@ + main :: IO () main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help createDirectoryIfMissing True "./out/" - let pic1 = runDrawingU (standardContext 14) petri_net - writeEPS "./out/petri_net.eps" pic1 - writeSVG "./out/petri_net.svg" pic1 - + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"] + mapM_ putStrLn msgs + let pic1 = runDrawingU (makeCtx base_metrics) petri_net + writeEPS "./out/petri_net01.eps" pic1 + writeSVG "./out/petri_net01.svg" pic1 +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"] + mapM_ putStrLn msgs + let pic1 = runDrawingU (makeCtx base_metrics) petri_net + writeEPS "./out/petri_net02.eps" pic1 + writeSVG "./out/petri_net02.svg" pic1 + + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace helvetica . metricsContext 14 + + petri_net :: DDrawing petri_net = drawTracing $ do pw <- place 0 140 @@ -95,32 +125,34 @@ , Real u, Floating u, FromPtSize u ) => Point2 u -> Point2 u -> m () connector' p0 p1 = - drawi_ $ situ2 (strokeConnector (rightArrow connLine tri45)) p0 p1 + drawi_ $ apply2R2 (strokeConnector (rightArrow connLine tri45)) p0 p1 connectorC :: ( Real u, Floating u, FromPtSize u , DrawingCtxM m, TraceM m, u ~ MonUnit m ) => u -> Point2 u -> Point2 u -> m () connectorC v p0 p1 = - drawi_ $ situ2 (strokeConnector (rightArrow (connRightVHV v) tri45)) p0 p1 + drawi_ $ apply2R2 (strokeConnector (rightArrow (connRightVHV v) tri45)) p0 p1 connectorD :: ( Real u, Floating u, FromPtSize u , DrawingCtxM m, TraceM m, u ~ MonUnit m ) => u -> Point2 u -> Point2 u -> m () connectorD u p0 p1 = - drawi_ $ situ2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1 + drawi_ $ apply2R2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1 lblParensParens :: Num u => LocGraphic u -lblParensParens = localize (fontface helvetica) $ textline "(),()" +lblParensParens = localize (fontFace helvetica) $ textline "(),()" lblParensParensParens :: Num u => LocGraphic u -lblParensParensParens = localize (fontface helvetica) $ textline "(),(),()" +lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()" lblBold' :: Num u => String -> LocGraphic u -lblBold' ss = localize (fontface helvetica_bold) $ textline ss +lblBold' ss = localize (fontFace helvetica_bold) $ textline ss -lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u -lblBold ss = localize (fontface helvetica_bold) $ centermonoTextline ss +lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u +lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss + where + post = fmap (replaceL uNil) diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -2,9 +2,9 @@ module Symbols where -import Wumpus.Basic.Chains -import Wumpus.Basic.Graphic -import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Text.SafeFonts import Wumpus.Core -- package: wumpus-core @@ -25,7 +25,7 @@ std_ctx :: DrawingContext -std_ctx = fontface times_roman $ standardContext 12 +std_ctx = fontFace times_roman $ standardContext 12 -- Because the font changes, we draw the all the symbols in one @@ -35,7 +35,7 @@ -- symbols :: DDrawing symbols = drawTracing $ do - localize (fontface symbol) $ zipWithM_ sdraw all_letters ps + localize (fontFace symbol) $ zipWithM_ sdraw all_letters ps zipWithM_ ldraw all_letters ps where sdraw (s,_) pt = draw $ textline s `at` pt diff --git a/src/Wumpus/Basic/Arrows.hs b/src/Wumpus/Basic/Arrows.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Arrows.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Arrows --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim module for arrow connectors and arrowheads. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Arrows - ( - - module Wumpus.Basic.Arrows.Tips - , module Wumpus.Basic.Arrows.Connectors - - ) where - -import Wumpus.Basic.Arrows.Tips -import Wumpus.Basic.Arrows.Connectors - - diff --git a/src/Wumpus/Basic/Arrows/Connectors.hs b/src/Wumpus/Basic/Arrows/Connectors.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Arrows/Connectors.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Arrows.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Draw arrows. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Arrows.Connectors - ( - - Connector - , connector - , leftArrow - , rightArrow - , dblArrow - , leftrightArrow - , strokeConnector - - - ) where - -import Wumpus.Basic.Arrows.Tips -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - --- An arrowhead always know how to draw itself (filled triangle, --- stroked barb, etc.) --- --- A Path might will typically be drawn with openStroke, --- eventually there might be scope for drawing --- e.g. parallel lines ==== --- - --- A ConnectorPath gets wrapped with how it is drawn into --- another type. - - -data Connector u = Connector - { connector_path :: ConnectorPath u - , opt_left_arrow :: Maybe (Arrowhead u) - , opt_right_arrow :: Maybe (Arrowhead u) - } - - --- | connector with no arrow heads. --- -connector :: ConnectorPath u -> Connector u -connector cp = - Connector { connector_path = cp - , opt_left_arrow = Nothing - , opt_right_arrow = Nothing - } - -leftArrow :: ConnectorPath u -> Arrowhead u -> Connector u -leftArrow cp la = - Connector { connector_path = cp - , opt_left_arrow = Just la - , opt_right_arrow = Nothing - } - - -rightArrow :: ConnectorPath u -> Arrowhead u -> Connector u -rightArrow cp ra = - Connector { connector_path = cp - , opt_left_arrow = Nothing - , opt_right_arrow = Just ra - } - --- | Same tip both ends. --- -dblArrow :: ConnectorPath u -> Arrowhead u -> Connector u -dblArrow cp arw = leftrightArrow cp arw arw - -leftrightArrow :: ConnectorPath u -> Arrowhead u -> Arrowhead u -> Connector u -leftrightArrow cp la ra = - Connector { connector_path = cp - , opt_left_arrow = Just la - , opt_right_arrow = Just ra - } - - - -strokeConnector :: (Real u, Floating u) - => Connector u -> ConnectorImage u (Path u) -strokeConnector (Connector cpF opt_la opt_ra) = - promote2 $ \p0 p1 -> let pathc = cpF p0 p1 in - tipEval opt_la p0 (directionL pathc) >>= \(dl,gfL) -> - tipEval opt_ra p1 (directionR pathc) >>= \(dr,gfR) -> - intoImage (pure pathc) (postpro (gfR . gfL) $ drawP $ shortenPath dl dr pathc) - where - drawP = openStroke . toPrimPath - - --- for Paths.Base ? --- -shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u -shortenPath l r = shortenL l . shortenR r - -type ArrowMark u = PrimGraphic u -> PrimGraphic u - - --- 'tipEval' is a bit of an oddity. It has to evaluate the --- Arrowhead / Image in the DrawingCtx to get the retract --- distance. But doing so evaluates the tips to PrimGraphics, thus --- it has to wrap the tips back up as Graphics with @pure@ so they --- can be concatenated to the drawn path as GraphicTrafos. --- --- The Arrowhead type could be changed, so rather than returning --- an Image (retract_distance, PrimGraphic) it returns --- (retract_distance, GraphicTrafo) but that would burden all --- arrowheads with some extra complexity. --- --- In short - the code here works but it isn\'t exemplary, and it --- doesn\'t show whether or not GraphicTrafo is a valuable type or --- if it is implemented correctly (as GraphicTrafo could having --- different implementations according to how it regards the --- DrawingCtx). --- - -tipEval :: Num u - => Maybe (Arrowhead u) -> Point2 u -> Radian - -> CF (u, ArrowMark u) -tipEval Nothing _ _ = return (0,unmarked) -tipEval (Just arw) pt theta = makeMark $ unCF2 pt theta (getArrowhead arw) - - -unmarked :: ArrowMark u -unmarked = id - - -makeMark :: Image u a -> CF (a, ArrowMark u) -makeMark = postpro (\(a,prim) -> (a, superior prim)) - - - diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Arrows/Tips.hs +++ /dev/null @@ -1,485 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Arrows.Tips --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Anchor points on shapes. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Arrows.Tips - ( - - - Arrowhead(..) - - - , tri90 - , tri60 - , tri45 - , otri90 - , otri60 - , otri45 - - , revtri90 - , revtri60 - , revtri45 - , orevtri90 - , orevtri60 - , orevtri45 - - , barb90 - , barb60 - , barb45 - , revbarb90 - , revbarb60 - , revbarb45 - - , perp - - , bracket - - , diskTip - , odiskTip - , squareTip - , osquareTip - , diamondTip - , odiamondTip - - , curveTip - , revcurveTip - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative - - --- | Encode an arrowhead as an image where the /answer/ is the --- retract distance. --- --- The retract distance is context sensitive - usually just on --- the markHeight (or halfMarkHeight) so it has to be calculated --- w.r.t. the DrawingCtx. --- -newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u } - - - - --- | Tiplen is length of the tip \*along the line it follows\*. --- --- > |\ --- > | \ --- > | / --- > |/ --- > --- > | | -- tip len --- - --- | Tip width is the distance between upper and lower --- arrow points. --- --- > __ --- > |\ --- > | \ tip --- > | / width --- > |/ __ --- > - - - --- | This one is for triangular tips defined by their tip angle --- e.g. 90deg, 60deg, 45deg. --- --- The tip width will be variable (tip length should be the --- markHeight). --- -triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u) -triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower) - where - hypo_len = tiplen / (fromRadian $ cos halfang) - rtheta = pi + theta -- theta in the opposite direction - vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len - vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len - - - --- | This one is for triangles when the tip height and tip width --- are known. --- -triVecsByDist :: (Real u, Floating u) - => u -> u -> Radian -> (Vec2 u, Vec2 u) -triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower) - where - hypo_len = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth) - halfang = toRadian $ atan (half_tipwidth / tiplen) - rtheta = pi + theta -- theta in the opposite direction - vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len - vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len - - - - -{- -markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u -markHeightPlusLineWidth = - (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth --} - - -markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u -markHeightLessLineWidth = - (\h lw -> h - realToFrac lw) <$> markHeight <*> lineWidth - - --- noRetract ignores both the angle and the point. --- --- Its common for the rectraction not to care about the angle or --- the point and only care about the DrawingCtx. --- -noRetract :: Num u => LocThetaCF u u -noRetract = wrap2 0 - - - - --------------------------------------------------------------------------------- - - - --- | Tripoints takes the \*tip length\* is the mark height. --- --- This means that the 90deg tip has a tip width greater-than the --- mark height (but that is okay - seemingly this is how TikZ --- does it). --- -tripointsByAngle :: (Floating u, FromPtSize u) - => Radian -> LocThetaCF u (Point2 u, Point2 u) -tripointsByAngle triang = markHeight >>= \h -> - raise2 $ \pt theta -> let (vup,vlo) = triVecsByAngle h (0.5*triang) theta - in (pt .+^ vup, pt .+^ vlo) - - -revtripointsByAngle :: (Floating u, FromPtSize u) - => Radian - -> LocThetaCF u (Point2 u, Point2 u, Point2 u) -revtripointsByAngle triang = markHeight >>= \h -> - raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta - (vup,vlo) = triVecsByAngle h (0.5*triang) theta' - back_tip = pt .-^ avec theta h - in (back_tip .+^ vup, back_tip, back_tip .+^ vlo) - - - -tripointsByDist :: (Real u, Floating u, FromPtSize u) - => LocThetaCF u (Point2 u, Point2 u) -tripointsByDist = markHeight >>= \h -> - raise2 $ \pt theta -> let (vup,vlo) = triVecsByDist h (0.5*h) theta - in (pt .+^ vup, pt .+^ vlo) - - - -revtripointsByDist :: (Real u, Floating u, FromPtSize u) - => LocThetaCF u (Point2 u, Point2 u, Point2 u) -revtripointsByDist = markHeight >>= \h -> - raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta - (vup,vlo) = triVecsByDist h (0.5*h) theta' - back_tip = pt .-^ avec theta h - in (back_tip .+^ vup, back_tip, back_tip .+^ vlo) - - - - -bindLocTip :: LocThetaCF u a -> (a -> LocGraphic u) -> LocThetaGraphic u -bindLocTip df da = bind2 df (\a -> static2 $ da a) - -bindLocThetaTip :: LocThetaCF u a -> (a -> LocThetaGraphic u) - -> LocThetaGraphic u -bindLocThetaTip = bind2 - - - --- width = xchar_height --- filled with stroke colour! - -triTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u -triTLG triang drawF = localize bothStrokeColour $ - bindLocTip (tripointsByAngle triang) - (\(u,v) -> promote1 $ \pt -> drawF $ vertexPath [pt,u,v]) - - - -tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri90 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) filledPath) - - -tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri60 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) filledPath) - - -tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -tri45 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) filledPath) - -otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri90 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) closedStroke) - -otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri60 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) closedStroke) - -otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -otri45 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) closedStroke) - - --- width = xchar_height --- filled with stroke colour! - -revtriTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u -revtriTLG triang drawF = localize bothStrokeColour $ - bindLocTip (revtripointsByAngle triang) - (\(u,pt,v) -> static1 $ drawF $ vertexPath [u,pt,v]) - - - -revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri90 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/2) filledPath) - -revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri60 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/3) filledPath) - -revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revtri45 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/4) filledPath) - - -orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri90 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/2) closedStroke) - -orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri60 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/3) closedStroke) - -orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -orevtri45 = Arrowhead $ - intoLocThetaImage (dblstatic markHeightLessLineWidth) - (revtriTLG (pi/4) closedStroke) - - - -barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u -barbTLG ang = - bindLocTip (tripointsByAngle ang) - (\(u,v) -> promote1 $ \pt -> openStroke $ vertexPath [u,pt,v]) - - - -barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2)) - -barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3)) - - -barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4)) - - - -revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u -revbarbTLG ang = - bindLocTip (revtripointsByAngle ang) - (\(u,pt,v) -> static1 $ openStroke $ vertexPath [u,pt,v]) - -revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb90 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/2)) - - -revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb60 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/3)) - -revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -revbarb45 = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/4)) - - -perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u -perpTLG = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> openStroke $ perpPath hh pt theta - - -perpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u -perpPath hh ctr theta = primPath p0 [lineTo p1] - where - p0 = displacePerpendicular hh theta ctr - p1 = displacePerpendicular (-hh) theta ctr - - - -perp :: (Floating u, FromPtSize u) => Arrowhead u -perp = Arrowhead $ intoLocThetaImage noRetract perpTLG - - - -bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u -bracketTLG = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> openStroke $ bracketPath hh pt theta - - -bracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u -bracketPath hh pt theta = vertexPath [p0,p1,p2,p3] - where - p1 = displacePerpendicular hh theta pt - p0 = displaceParallel (-hh) theta p1 - p2 = displacePerpendicular (-hh) theta pt - p3 = displaceParallel (-hh) theta p2 - - - - -bracket :: (Floating u, FromPtSize u) => Arrowhead u -bracket = Arrowhead $ intoLocThetaImage noRetract bracketTLG - - -diskTLG :: (Floating u, FromPtSize u) - => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u -diskTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> let ctr = pt .-^ avec theta hh - in drawF hh ctr - - -diskTip :: (Floating u, FromPtSize u) => Arrowhead u -diskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF) - where - drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt - - -odiskTip :: (Floating u, FromPtSize u) => Arrowhead u -odiskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF) - where - drawF r pt = strokedDisk r `at` pt - - -squareTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> LocThetaGraphic u -squareTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> - let p0 = displacePerpendicular hh theta pt - p3 = displacePerpendicular (-hh) theta pt - p1 = displaceParallel (-2*hh) theta p0 - p2 = displaceParallel (-2*hh) theta p3 - in drawF $ vertexPath [p0,p1,p2,p3] - - -squareTip :: (Floating u, FromPtSize u) => Arrowhead u -squareTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (squareTLG drawF) - where - drawF = localize bothStrokeColour . filledPath - - -osquareTip :: (Floating u, FromPtSize u) => Arrowhead u -osquareTip = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) (squareTLG closedStroke) - - -diamondTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> LocThetaGraphic u -diamondTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> - let ctr = displaceParallel (-2*hh) theta pt - p1 = displacePerpendicular hh theta ctr - p3 = displacePerpendicular (-hh) theta ctr - p2 = displaceParallel (-4*hh) theta pt - in drawF $ vertexPath [pt,p1,p2,p3] - - -diamondTip :: (Floating u, FromPtSize u) => Arrowhead u -diamondTip = Arrowhead $ - intoLocThetaImage (dblstatic $ fmap (2*) markHeightLessLineWidth) - (diamondTLG drawF) - where - drawF = localize bothStrokeColour . filledPath - - -odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u -odiamondTip = Arrowhead $ - intoLocThetaImage (dblstatic $ fmap (2*) markHeight) (diamondTLG closedStroke) - - - --- Note - points flipped to get the second trapezium to --- draw /underneath/. --- -curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u -curveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> - unLocTheta pt theta tripointsByDist >>= \(tup,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt - tpath = curve tup u2 u1 pt `append` curve pt l1 l2 tlo - in localize (joinRound . capRound) - (openStroke $ toPrimPath $ tpath) - - -curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u -curveTip = Arrowhead $ - intoLocThetaImage (dblstatic $ fmap realToFrac lineWidth) curveTLG - - --- Note - points flipped to get the second trapezium to --- draw /underneath/. --- -revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u -revcurveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn - where - fn hh = promote2 $ \pt theta -> - unLocTheta pt theta revtripointsByDist >>= \(tup,p1,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 - tpath = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo - in localize (joinRound . capRound) - (openStroke $ toPrimPath $ tpath) - -revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u -revcurveTip = Arrowhead $ - intoLocThetaImage (dblstatic markHeight) revcurveTLG - diff --git a/src/Wumpus/Basic/Chains.hs b/src/Wumpus/Basic/Chains.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Chains.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Chains --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Shim module. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Chains - ( - module Wumpus.Basic.Chains.Base - , module Wumpus.Basic.Chains.Derived - - - ) where - - -import Wumpus.Basic.Chains.Base -import Wumpus.Basic.Chains.Derived diff --git a/src/Wumpus/Basic/Chains/Base.hs b/src/Wumpus/Basic/Chains/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Chains/Base.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Chains.Base --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Generate points in an iterated chain. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Chains.Base - ( - - - Chain - , LocChain - , chain - , chainFrom - , unchain - - - , AnaAlg(..) - , IterAlg(..) - - , BivariateAlg - , bivariate - - , SequenceAlg - , iteration - - , bounded - , pairOnXs - , pairOnYs - - ) where - -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core - - --- Chain uses the Scaling monad, but it is not itself a monad. - - -newtype Chain ux uy u = Chain { getChain :: Scaling ux uy u [Point2 u] } - - -type LocChain ux uy u = Point2 u -> Chain ux uy u - - - -chain :: BivariateAlg ux uy -> Chain ux uy u -chain alg = Chain (scaledBivariatePt alg) - -chainFrom :: Num u => BivariateAlg ux uy -> LocChain ux uy u -chainFrom alg start = Chain (scaledBivariateVec alg start) - - -unchain :: ScalingContext ux uy u -> Chain ux uy u -> [Point2 u] -unchain ctx ch = runScaling ctx $ getChain ch - - --- | Chains are built as unfolds - AnaAlg avoids the pair --- constructor in the usual definition of unfoldr and makes the --- state strict. --- --- It is expected that all Chains built on unfolds will terminate. --- -data AnaAlg st a = Done | Step a !st - - --- | IterAlg is a variant of AnaAlg that builds infinite --- sequences (iterations). --- --- When lifted to a Chain an iteration is bounded by a count so --- it will terminate. --- -data IterAlg st a = IterStep a !st - - -data BivariateAlg ux uy = forall st. BivariateAlg - { st_zero :: st - , gen_step :: st -> AnaAlg st (ux,uy) - } - -bivariate :: st -> (st -> AnaAlg st (ux,uy)) -> BivariateAlg ux uy -bivariate st0 step_alg = BivariateAlg { st_zero = st0 - , gen_step = step_alg } - - -scaledBivariatePt :: BivariateAlg ux uy -> Scaling ux uy u [Point2 u] -scaledBivariatePt (BivariateAlg { st_zero = st0, gen_step = step}) = - go (step st0) - where - go Done = return [] - go (Step (x,y) next) = scalePt x y >>= \pt -> - go (step next) >>= \rest -> - return (pt:rest) - --- Note - cannot encode this with (.+^) from Data.AffineSpace. --- The u (u ~ MonUnit m) extracted from the Scaling Context is --- not compatible with the u that forms Points (u ~ Diff (Point2 u)). - -scaledBivariateVec :: Num u - => BivariateAlg ux uy - -> Point2 u - -> Scaling ux uy u [Point2 u] -scaledBivariateVec (BivariateAlg { st_zero = st0, gen_step = step}) (P2 x0 y0) = - go (step st0) - where - go Done = return [] - go (Step (x,y) next) = scaleVec x y >>= \(V2 dx dy) -> - go (step next) >>= \rest -> - return (P2 (x0+dx) (y0+dy):rest) - - -data SequenceAlg a = forall st. SequenceAlg - { initial_st :: st - , iter_step :: st -> IterAlg st a - } - -iteration :: (a -> a) -> a -> SequenceAlg a -iteration fn s0 = SequenceAlg { initial_st = s0, iter_step = step } - where - step s = IterStep s (fn s) - - -bounded :: Int -> SequenceAlg (ux,uy) -> BivariateAlg ux uy -bounded n (SequenceAlg a0 fn) = - BivariateAlg { st_zero = (0,a0) - , gen_step = gstep } - where - gstep (i,s) | i < n = let (IterStep ans next) = fn s in Step ans (i+1,next) - gstep _ = Done - - - - -pairOnXs :: (ux -> uy) -> SequenceAlg ux -> SequenceAlg (ux,uy) -pairOnXs fn (SequenceAlg { initial_st = s0, iter_step = step }) = - SequenceAlg s0 step2 - where - step2 s = let (IterStep a s') = step s in IterStep (a, fn a) s' - - -pairOnYs :: (r -> l) -> SequenceAlg r -> SequenceAlg (l,r) -pairOnYs fn (SequenceAlg { initial_st = s0, iter_step = step }) = - SequenceAlg s0 step2 - where - step2 s = let (IterStep a s') = step s in IterStep (fn a, a) s' - diff --git a/src/Wumpus/Basic/Chains/Derived.hs b/src/Wumpus/Basic/Chains/Derived.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Chains/Derived.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Chains.Derived --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Generate points in an iterated chain. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Chains.Derived - ( - - univariateX - , univariateY - - , tableDown - , tableRight - - , horizontal - , vertical - - , horizontals - , verticals - - , rescale - - ) where - -import Wumpus.Basic.Chains.Base - - - - -univariateX :: (Fractional uy, Num ux, Num u) - => [ux] -> LocChain ux uy u -univariateX zs = chainFrom $ bivariate (0,zs) gstep - where - gstep (_,[]) = Done - gstep (n,x:xs) = Step (x,n) (n+i,xs) - len = length zs - i = rescale 0 1 0 (fromIntegral $ len-1) 1 - - -univariateY :: (Fractional ux, Num uy, Num u) - => [uy] -> LocChain ux uy u -univariateY zs = chainFrom $ bivariate (0,zs) gstep - where - gstep (_,[]) = Done - gstep (n,y:ys) = Step (n,y) (n+i,ys) - len = length zs - i = rescale 0 1 0 (fromIntegral $ len-1) 1 - - - --------------------------------------------------------------------------------- --- Tables - - -tableDown :: Int -> Int -> Chain Int Int u -tableDown rows cols = - chain $ bounded (rows*cols) (iteration (downstep rows) (0,rows-1)) - - - -downstep :: Int -> (Int,Int) -> (Int,Int) -downstep row_count (x,y) | y == 0 = (x+1,row_count-1) -downstep _ (x,y) = (x,y-1) - - - -tableRight :: Num u => Int -> Int -> Chain Int Int u -tableRight rows cols = - chain $ bounded (rows*cols) (iteration (rightstep cols) (0,rows-1)) - - -rightstep :: Int -> (Int,Int) -> (Int,Int) -rightstep col_count (x,y) | x == (col_count-1) = (0,y-1) -rightstep _ (x,y) = (x+1,y) - - -horizontal :: Int -> Chain Int Int u -horizontal count = chain $ bivariate 0 alg - where - alg st | st == count = Done - alg st = Step (st,0) (st+1) - - -vertical :: Int -> Chain Int Int u -vertical count = chain $ bivariate 0 alg - where - alg st | st == count = Done - alg st = Step (0,st) (st+1) - - - -horizontals :: (Num ua, Num u) => [ua] -> LocChain ua ua u -horizontals xs0 = chainFrom $ bivariate xs0 alg - where - alg [] = Done - alg (x:xs) = Step (x,0) xs - - -verticals :: (Num ua, Num u) => [ua] -> LocChain ua ua u -verticals ys0 = chainFrom $ bivariate ys0 alg - where - alg [] = Done - alg (y:ys) = Step (0,y) ys - - --------------------------------------------------------------------------------- --- general helpers - -rescale :: Fractional a => a -> a -> a -> a -> a -> a -rescale outmin outmax innmin innmax a = - outmin + innpos * (outrange / innrange) - where - outrange = outmax - outmin - innrange = innmax - innmin - innpos = a - innmin - diff --git a/src/Wumpus/Basic/Colour/SVGColours.hs b/src/Wumpus/Basic/Colour/SVGColours.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Colour/SVGColours.hs +++ /dev/null @@ -1,625 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Colour.SVGColours --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : unstable --- Portability : GHC --- --- The SVG \'named colours\', as rgb [0,1] values --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Colour.SVGColours - ( - - -- * Named colours - alice_blue - , antique_white - , aqua - , aquamarine - , azure - , beige - , bisque - , black - , blanched_almond - , blue - , blue_violet - , brown - , burlywood - , cadet_blue - , chartreuse - , chocolate - , coral - , cornflower_blue - , cornsilk - , crimson - , cyan - , dark_blue - , dark_cyan - , dark_goldenrod - , dark_gray - , dark_green - , dark_grey - , dark_khaki - , dark_magenta - , dark_olive_green - , dark_orange - , dark_orchid - , dark_red - , dark_salmon - , dark_sea_green - , dark_slate_blue - , dark_slate_gray - , dark_slate_grey - , dark_turquoise - , dark_violet - , deep_pink - , deep_sky_blue - , dim_gray - , dim_grey - , dodger_blue - , firebrick - , floral_white - , forest_green - , fuchsia - , gainsboro - , ghost_white - , gold - , goldenrod - , gray - , grey - , green - , green_yellow - , honeydew - , hot_pink - , indian_red - , indigo - , ivory - , khaki - , lavender - , lavender_blush - , lawn_green - , lemon_chiffon - , light_blue - , light_coral - , light_cyan - , light_goldenrod_yellow - , light_gray - , light_green - , light_grey - , light_pink - , light_salmon - , light_sea_green - , light_sky_blue - , light_slate_gray - , light_slate_grey - , light_steel_blue - , light_yellow - , lime - , lime_green - , linen - , magenta - , maroon - , medium_aquamarine - , medium_blue - , medium_orchid - , medium_purple - , medium_sea_green - , medium_slate_blue - , medium_spring_green - , medium_turquoise - , medium_violet_red - , midnight_blue - , mintcream - , mistyrose - , moccasin - , navajo_white - , navy - , old_lace - , olive - , olive_drab - , orange - , orange_red - , orchid - , pale_goldenrod - , pale_green - , pale_turquoise - , pale_violet_red - , papaya_whip - , peach_puff - , peru - , pink - , plum - , powder_blue - , purple - , red - , rosy_brown - , royal_blue - , saddle_brown - , salmon - , sandy_brown - , sea_green - , seashell - , sienna - , silver - , sky_blue - , slate_blue - , slate_gray - , slate_grey - , snow - , spring_green - , steel_blue - , tan - , teal - , thistle - , tomato - , turquoise - , violet - , wheat - , white - , whitesmoke - , yellow - , yellow_green - - ) where - - -import Wumpus.Core.Colour ( RGBi(..) ) - - -import Prelude ( ) - - - --------------------------------------------------------------------------------- - -alice_blue :: RGBi -alice_blue = RGBi 0xf0 0xf8 0xff - -antique_white :: RGBi -antique_white = RGBi 0xfa 0xeb 0xd7 - -aqua :: RGBi -aqua = RGBi 0x00 0xff 0xff - -aquamarine :: RGBi -aquamarine = RGBi 0x7f 0xff 0xd4 - -azure :: RGBi -azure = RGBi 0xf0 0xff 0xff - -beige :: RGBi -beige = RGBi 0xf5 0xf5 0xdc - -bisque :: RGBi -bisque = RGBi 0xff 0xe4 0xc4 - -black :: RGBi -black = RGBi 0x00 0x00 0x00 - -blanched_almond :: RGBi -blanched_almond = RGBi 0xff 0xeb 0xcd - -blue :: RGBi -blue = RGBi 0x00 0x00 0xff - -blue_violet :: RGBi -blue_violet = RGBi 0x8a 0x2b 0xe2 - -brown :: RGBi -brown = RGBi 0xa5 0x2a 0x2a - -burlywood :: RGBi -burlywood = RGBi 0xde 0xb8 0x87 - -cadet_blue :: RGBi -cadet_blue = RGBi 0x5f 0x9e 0xa0 - -chartreuse :: RGBi -chartreuse = RGBi 0x7f 0xff 0x00 - -chocolate :: RGBi -chocolate = RGBi 0xd2 0x69 0x1e - -coral :: RGBi -coral = RGBi 0xff 0x7f 0x50 - -cornflower_blue :: RGBi -cornflower_blue = RGBi 0x64 0x95 0xed - -cornsilk :: RGBi -cornsilk = RGBi 0xff 0xf8 0xdc - -crimson :: RGBi -crimson = RGBi 0xdc 0x14 0x3c - -cyan :: RGBi -cyan = RGBi 0x00 0xff 0xff - -dark_blue :: RGBi -dark_blue = RGBi 0x00 0x00 0x8b - -dark_cyan :: RGBi -dark_cyan = RGBi 0x00 0x8b 0x8b - -dark_goldenrod :: RGBi -dark_goldenrod = RGBi 0xb8 0x86 0x0b - -dark_gray :: RGBi -dark_gray = RGBi 0xa9 0xa9 0xa9 - -dark_green :: RGBi -dark_green = RGBi 0x00 0x64 0x00 - -dark_grey :: RGBi -dark_grey = RGBi 0xa9 0xa9 0xa9 - -dark_khaki :: RGBi -dark_khaki = RGBi 0xbd 0xb7 0x6b - -dark_magenta :: RGBi -dark_magenta = RGBi 0x8b 0x00 0x8b - -dark_olive_green :: RGBi -dark_olive_green = RGBi 0x55 0x6b 0x2f - -dark_orange :: RGBi -dark_orange = RGBi 0xff 0x8c 0x00 - -dark_orchid :: RGBi -dark_orchid = RGBi 0x99 0x32 0xcc - -dark_red :: RGBi -dark_red = RGBi 0x8b 0x00 0x00 - -dark_salmon :: RGBi -dark_salmon = RGBi 0xe9 0x96 0x7a - -dark_sea_green :: RGBi -dark_sea_green = RGBi 0x8f 0xbc 0x8f - -dark_slate_blue :: RGBi -dark_slate_blue = RGBi 0x48 0x3d 0x8b - -dark_slate_gray :: RGBi -dark_slate_gray = RGBi 0x2f 0x4f 0x4f - -dark_slate_grey :: RGBi -dark_slate_grey = RGBi 0x2f 0x4f 0x4f - -dark_turquoise :: RGBi -dark_turquoise = RGBi 0x00 0xce 0xd1 - -dark_violet :: RGBi -dark_violet = RGBi 0x94 0x00 0xd3 - -deep_pink :: RGBi -deep_pink = RGBi 0xff 0x14 0x93 - -deep_sky_blue :: RGBi -deep_sky_blue = RGBi 0x00 0xbf 0xff - -dim_gray :: RGBi -dim_gray = RGBi 0x69 0x69 0x69 - -dim_grey :: RGBi -dim_grey = RGBi 0x69 0x69 0x69 - -dodger_blue :: RGBi -dodger_blue = RGBi 0x1e 0x90 0xff - -firebrick :: RGBi -firebrick = RGBi 0xb2 0x22 0x22 - -floral_white :: RGBi -floral_white = RGBi 0xff 0xfa 0xf0 - -forest_green :: RGBi -forest_green = RGBi 0x22 0x8b 0x22 - -fuchsia :: RGBi -fuchsia = RGBi 0xff 0x00 0xff - -gainsboro :: RGBi -gainsboro = RGBi 0xdc 0xdc 0xdc - -ghost_white :: RGBi -ghost_white = RGBi 0xf8 0xf8 0xff - -gold :: RGBi -gold = RGBi 0xff 0xd7 0x00 - -goldenrod :: RGBi -goldenrod = RGBi 0xda 0xa5 0x20 - -gray :: RGBi -gray = RGBi 0x80 0x80 0x80 - -green :: RGBi -green = RGBi 0x00 0x80 0x00 - -green_yellow :: RGBi -green_yellow = RGBi 0xad 0xff 0x2f - -grey :: RGBi -grey = RGBi 0x80 0x80 0x80 - -honeydew :: RGBi -honeydew = RGBi 0xf0 0xff 0xf0 - -hot_pink :: RGBi -hot_pink = RGBi 0xff 0x69 0xb4 - -indian_red :: RGBi -indian_red = RGBi 0xcd 0x5c 0x5c - -indigo :: RGBi -indigo = RGBi 0x4b 0x00 0x82 - -ivory :: RGBi -ivory = RGBi 0xff 0xff 0xf0 - -khaki :: RGBi -khaki = RGBi 0xf0 0xe6 0x8c - -lavender :: RGBi -lavender = RGBi 0xe6 0xe6 0xfa - -lavender_blush :: RGBi -lavender_blush = RGBi 0xff 0xf0 0xf5 - -lawn_green :: RGBi -lawn_green = RGBi 0x7c 0xfc 0x00 - -lemon_chiffon :: RGBi -lemon_chiffon = RGBi 0xff 0xfa 0xcd - -light_blue :: RGBi -light_blue = RGBi 0xad 0xd8 0xe6 - -light_coral :: RGBi -light_coral = RGBi 0xf0 0x80 0x80 - -light_cyan :: RGBi -light_cyan = RGBi 0xe0 0xff 0xff - -light_goldenrod_yellow :: RGBi -light_goldenrod_yellow = RGBi 0xfa 0xfa 0xd2 - -light_gray :: RGBi -light_gray = RGBi 0xd3 0xd3 0xd3 - -light_green :: RGBi -light_green = RGBi 0x90 0xee 0x90 - -light_grey :: RGBi -light_grey = RGBi 0xd3 0xd3 0xd3 - -light_pink :: RGBi -light_pink = RGBi 0xff 0xb6 0xc1 - -light_salmon :: RGBi -light_salmon = RGBi 0xff 0xa0 0x7a - -light_sea_green :: RGBi -light_sea_green = RGBi 0x20 0xb2 0xaa - -light_sky_blue :: RGBi -light_sky_blue = RGBi 0x87 0xce 0xfa - -light_slate_gray :: RGBi -light_slate_gray = RGBi 0x77 0x88 0x99 - -light_slate_grey :: RGBi -light_slate_grey = RGBi 0x77 0x88 0x99 - -light_steel_blue :: RGBi -light_steel_blue = RGBi 0xb0 0xc4 0xde - -light_yellow :: RGBi -light_yellow = RGBi 0xff 0xff 0xe0 - -lime :: RGBi -lime = RGBi 0x00 0xff 0x00 - -lime_green :: RGBi -lime_green = RGBi 0x32 0xcd 0x32 - -linen :: RGBi -linen = RGBi 0xfa 0xf0 0xe6 - -magenta :: RGBi -magenta = RGBi 0xff 0x00 0xff - -maroon :: RGBi -maroon = RGBi 0x80 0x00 0x00 - -medium_aquamarine :: RGBi -medium_aquamarine = RGBi 0x66 0xcd 0xaa - -medium_blue :: RGBi -medium_blue = RGBi 0x00 0x00 0xcd - -medium_orchid :: RGBi -medium_orchid = RGBi 0xba 0x55 0xd3 - -medium_purple :: RGBi -medium_purple = RGBi 0x93 0x70 0xdb - -medium_sea_green :: RGBi -medium_sea_green = RGBi 0x3c 0xb3 0x71 - -medium_slate_blue :: RGBi -medium_slate_blue = RGBi 0x7b 0x68 0xee - -medium_spring_green :: RGBi -medium_spring_green = RGBi 0x00 0xfa 0x9a - -medium_turquoise :: RGBi -medium_turquoise = RGBi 0x48 0xd1 0xcc - -medium_violet_red :: RGBi -medium_violet_red = RGBi 0xc7 0x15 0x85 - -midnight_blue :: RGBi -midnight_blue = RGBi 0x19 0x19 0x70 - -mintcream :: RGBi -mintcream = RGBi 0xf5 0xff 0xfa - -mistyrose :: RGBi -mistyrose = RGBi 0xff 0xe4 0xe1 - -moccasin :: RGBi -moccasin = RGBi 0xff 0xe4 0xb5 - -navajo_white :: RGBi -navajo_white = RGBi 0xff 0xde 0xad - -navy :: RGBi -navy = RGBi 0x00 0x00 0x80 - -old_lace :: RGBi -old_lace = RGBi 0xfd 0xf5 0xe6 - -olive :: RGBi -olive = RGBi 0x80 0x80 0x00 - -olive_drab :: RGBi -olive_drab = RGBi 0x6b 0x8e 0x23 - -orange :: RGBi -orange = RGBi 0xff 0xa5 0x00 - -orange_red :: RGBi -orange_red = RGBi 0xff 0x45 0x00 - -orchid :: RGBi -orchid = RGBi 0xda 0x70 0xd6 - -pale_goldenrod :: RGBi -pale_goldenrod = RGBi 0xee 0xe8 0xaa - -pale_green :: RGBi -pale_green = RGBi 0x98 0xfb 0x98 - -pale_turquoise :: RGBi -pale_turquoise = RGBi 0xaf 0xee 0xee - -pale_violet_red :: RGBi -pale_violet_red = RGBi 0xdb 0x70 0x93 - -papaya_whip :: RGBi -papaya_whip = RGBi 0xff 0xef 0xd5 - -peach_puff :: RGBi -peach_puff = RGBi 0xff 0xda 0xb9 - -peru :: RGBi -peru = RGBi 0xcd 0x85 0x3f - -pink :: RGBi -pink = RGBi 0xff 0xc0 0xcb - -plum :: RGBi -plum = RGBi 0xdd 0xa0 0xdd - -powder_blue :: RGBi -powder_blue = RGBi 0xb0 0xe0 0xe6 - -purple :: RGBi -purple = RGBi 0x80 0x00 0x80 - -red :: RGBi -red = RGBi 0xff 0x00 0x00 - -rosy_brown :: RGBi -rosy_brown = RGBi 0xbc 0x8f 0x8f - -royal_blue :: RGBi -royal_blue = RGBi 0x41 0x69 0xe1 - -saddle_brown :: RGBi -saddle_brown = RGBi 0x8b 0x45 0x13 - -salmon :: RGBi -salmon = RGBi 0xfa 0x80 0x72 - -sandy_brown :: RGBi -sandy_brown = RGBi 0xf4 0xa4 0x60 - -sea_green :: RGBi -sea_green = RGBi 0x2e 0x8b 0x57 - -seashell :: RGBi -seashell = RGBi 0xff 0xf5 0xee - -sienna :: RGBi -sienna = RGBi 0xa0 0x52 0x2d - -silver :: RGBi -silver = RGBi 0xc0 0xc0 0xc0 - -sky_blue :: RGBi -sky_blue = RGBi 0x87 0xce 0xeb - -slate_blue :: RGBi -slate_blue = RGBi 0x6a 0x5a 0xcd - -slate_gray :: RGBi -slate_gray = RGBi 0x70 0x80 0x90 - -slate_grey :: RGBi -slate_grey = RGBi 0x70 0x80 0x90 - -snow :: RGBi -snow = RGBi 0xff 0xfa 0xfa - -spring_green :: RGBi -spring_green = RGBi 0x00 0xff 0x7f - -steel_blue :: RGBi -steel_blue = RGBi 0x46 0x82 0xb4 - -tan :: RGBi -tan = RGBi 0xd2 0xb4 0x8c - -teal :: RGBi -teal = RGBi 0x00 0x80 0x80 - -thistle :: RGBi -thistle = RGBi 0xd8 0xbf 0xd8 - -tomato :: RGBi -tomato = RGBi 0xff 0x63 0x47 - -turquoise :: RGBi -turquoise = RGBi 0x40 0xe0 0xd0 - -violet :: RGBi -violet = RGBi 0xee 0x82 0xee - -wheat :: RGBi -wheat = RGBi 0xf5 0xde 0xb3 - -white :: RGBi -white = RGBi 0xff 0xff 0xff - -whitesmoke :: RGBi -whitesmoke = RGBi 0xf5 0xf5 0xf5 - -yellow :: RGBi -yellow = RGBi 0xff 0xff 0x00 - -yellow_green :: RGBi -yellow_green = RGBi 0x9a 0xcd 0x32 - - - - - diff --git a/src/Wumpus/Basic/Colour/X11Colours.hs b/src/Wumpus/Basic/Colour/X11Colours.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Colour/X11Colours.hs +++ /dev/null @@ -1,1282 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Colour.X11Colours --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : unstable --- Portability : GHC --- --- The X11 \'named colours\', as rgb [0,1] values --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Colour.X11Colours - ( - - -- * Named X11 colours - antique_white1 - , antique_white2 - , antique_white3 - , antique_white4 - , aquamarine1 - , aquamarine2 - , aquamarine3 - , aquamarine4 - , azure1 - , azure2 - , azure3 - , azure4 - , bisque1 - , bisque2 - , bisque3 - , bisque4 - , blue1 - , blue2 - , blue3 - , blue4 - , brown1 - , brown2 - , brown3 - , brown4 - , burlywood1 - , burlywood2 - , burlywood3 - , burlywood4 - , cadet_blue1 - , cadet_blue2 - , cadet_blue3 - , cadet_blue4 - , chartreuse1 - , chartreuse2 - , chartreuse3 - , chartreuse4 - , chocolate1 - , chocolate2 - , chocolate3 - , chocolate4 - , coral1 - , coral2 - , coral3 - , coral4 - , cornsilk1 - , cornsilk2 - , cornsilk3 - , cornsilk4 - , cyan1 - , cyan2 - , cyan3 - , cyan4 - , dark_goldenrod1 - , dark_goldenrod2 - , dark_goldenrod3 - , dark_goldenrod4 - , dark_olive_green1 - , dark_olive_green2 - , dark_olive_green3 - , dark_olive_green4 - , dark_orange1 - , dark_orange2 - , dark_orange3 - , dark_orange4 - , dark_orchid1 - , dark_orchid2 - , dark_orchid3 - , dark_orchid4 - , dark_sea_green1 - , dark_sea_green2 - , dark_sea_green3 - , dark_sea_green4 - , dark_slate_gray1 - , dark_slate_gray2 - , dark_slate_gray3 - , dark_slate_gray4 - , deep_pink1 - , deep_pink2 - , deep_pink3 - , deep_pink4 - , deep_sky_blue1 - , deep_sky_blue2 - , deep_sky_blue3 - , deep_sky_blue4 - , dodger_blue1 - , dodger_blue2 - , dodger_blue3 - , dodger_blue4 - , firebrick1 - , firebrick2 - , firebrick3 - , firebrick4 - , gold1 - , gold2 - , gold3 - , gold4 - , goldenrod1 - , goldenrod2 - , goldenrod3 - , goldenrod4 - , green1 - , green2 - , green3 - , green4 - , honeydew1 - , honeydew2 - , honeydew3 - , honeydew4 - , hot_pink1 - , hot_pink2 - , hot_pink3 - , hot_pink4 - , indian_red1 - , indian_red2 - , indian_red3 - , indian_red4 - , ivory1 - , ivory2 - , ivory3 - , ivory4 - , khaki1 - , khaki2 - , khaki3 - , khaki4 - , lavender_blush1 - , lavender_blush2 - , lavender_blush3 - , lavender_blush4 - , lemon_chiffon1 - , lemon_chiffon2 - , lemon_chiffon3 - , lemon_chiffon4 - , light_blue1 - , light_blue2 - , light_blue3 - , light_blue4 - , light_cyan1 - , light_cyan2 - , light_cyan3 - , light_cyan4 - , light_goldenrod1 - , light_goldenrod2 - , light_goldenrod3 - , light_goldenrod4 - , light_pink1 - , light_pink2 - , light_pink3 - , light_pink4 - , light_salmon1 - , light_salmon2 - , light_salmon3 - , light_salmon4 - , light_sky_blue1 - , light_sky_blue2 - , light_sky_blue3 - , light_sky_blue4 - , light_steel_blue1 - , light_steel_blue2 - , light_steel_blue3 - , light_steel_blue4 - , light_yellow1 - , light_yellow2 - , light_yellow3 - , light_yellow4 - , magenta1 - , magenta2 - , magenta3 - , magenta4 - , maroon1 - , maroon2 - , maroon3 - , maroon4 - , medium_orchid1 - , medium_orchid2 - , medium_orchid3 - , medium_orchid4 - , medium_purple1 - , medium_purple2 - , medium_purple3 - , medium_purple4 - , misty_rose1 - , misty_rose2 - , misty_rose3 - , misty_rose4 - , navajo_white1 - , navajo_white2 - , navajo_white3 - , navajo_white4 - , olive_drab1 - , olive_drab2 - , olive_drab3 - , olive_drab4 - , orange1 - , orange2 - , orange3 - , orange4 - , orange_red1 - , orange_red2 - , orange_red3 - , orange_red4 - , orchid1 - , orchid2 - , orchid3 - , orchid4 - , pale_green1 - , pale_green2 - , pale_green3 - , pale_green4 - , pale_turquoise1 - , pale_turquoise2 - , pale_turquoise3 - , pale_turquoise4 - , pale_violet_red1 - , pale_violet_red2 - , pale_violet_red3 - , pale_violet_red4 - , peach_puff1 - , peach_puff2 - , peach_puff3 - , peach_puff4 - , pink1 - , pink2 - , pink3 - , pink4 - , plum1 - , plum2 - , plum3 - , plum4 - , purple1 - , purple2 - , purple3 - , purple4 - , red1 - , red2 - , red3 - , red4 - , rosy_brown1 - , rosy_brown2 - , rosy_brown3 - , rosy_brown4 - , royal_blue1 - , royal_blue2 - , royal_blue3 - , royal_blue4 - , salmon1 - , salmon2 - , salmon3 - , salmon4 - , sea_green1 - , sea_green2 - , sea_green3 - , sea_green4 - , seashell1 - , seashell2 - , seashell3 - , seashell4 - , sienna1 - , sienna2 - , sienna3 - , sienna4 - , sky_blue1 - , sky_blue2 - , sky_blue3 - , sky_blue4 - , slate_blue1 - , slate_blue2 - , slate_blue3 - , slate_blue4 - , slate_gray1 - , slate_gray2 - , slate_gray3 - , slate_gray4 - , snow1 - , snow2 - , snow3 - , snow4 - , spring_green1 - , spring_green2 - , spring_green3 - , spring_green4 - , steel_blue1 - , steel_blue2 - , steel_blue3 - , steel_blue4 - , tan1 - , tan2 - , tan3 - , tan4 - , thistle1 - , thistle2 - , thistle3 - , thistle4 - , tomato1 - , tomato2 - , tomato3 - , tomato4 - , turquoise1 - , turquoise2 - , turquoise3 - , turquoise4 - , violet_red1 - , violet_red2 - , violet_red3 - , violet_red4 - , wheat1 - , wheat2 - , wheat3 - , wheat4 - , yellow1 - , yellow2 - , yellow3 - , yellow4 - - ) where - -import Wumpus.Core.Colour ( RGBi(..) ) - - --------------------------------------------------------------------------------- - -antique_white1 :: RGBi -antique_white1 = RGBi 0xff 0xef 0xdb - -antique_white2 :: RGBi -antique_white2 = RGBi 0xee 0xdf 0xcc - -antique_white3 :: RGBi -antique_white3 = RGBi 0xcd 0xc0 0xb0 - -antique_white4 :: RGBi -antique_white4 = RGBi 0x8b 0x83 0x78 - -aquamarine1 :: RGBi -aquamarine1 = RGBi 0x7f 0xff 0xd4 - -aquamarine2 :: RGBi -aquamarine2 = RGBi 0x76 0xee 0xc6 - -aquamarine3 :: RGBi -aquamarine3 = RGBi 0x66 0xcd 0xaa - -aquamarine4 :: RGBi -aquamarine4 = RGBi 0x45 0x8b 0x74 - -azure1 :: RGBi -azure1 = RGBi 0xf0 0xff 0xff - -azure2 :: RGBi -azure2 = RGBi 0xe0 0xee 0xee - -azure3 :: RGBi -azure3 = RGBi 0xc1 0xcd 0xcd - -azure4 :: RGBi -azure4 = RGBi 0x83 0x8b 0x8b - -bisque1 :: RGBi -bisque1 = RGBi 0xff 0xe4 0xc4 - -bisque2 :: RGBi -bisque2 = RGBi 0xee 0xd5 0xb7 - -bisque3 :: RGBi -bisque3 = RGBi 0xcd 0xb7 0x9e - -bisque4 :: RGBi -bisque4 = RGBi 0x8b 0x7d 0x6b - -blue1 :: RGBi -blue1 = RGBi 0x00 0x00 0xff - -blue2 :: RGBi -blue2 = RGBi 0x00 0x00 0xee - -blue3 :: RGBi -blue3 = RGBi 0x00 0x00 0xcd - -blue4 :: RGBi -blue4 = RGBi 0x00 0x00 0x8b - -brown1 :: RGBi -brown1 = RGBi 0xff 0x40 0x40 - -brown2 :: RGBi -brown2 = RGBi 0xee 0x3b 0x3b - -brown3 :: RGBi -brown3 = RGBi 0xcd 0x33 0x33 - -brown4 :: RGBi -brown4 = RGBi 0x8b 0x23 0x23 - -burlywood1 :: RGBi -burlywood1 = RGBi 0xff 0xd3 0x9b - -burlywood2 :: RGBi -burlywood2 = RGBi 0xee 0xc5 0x91 - -burlywood3 :: RGBi -burlywood3 = RGBi 0xcd 0xaa 0x7d - -burlywood4 :: RGBi -burlywood4 = RGBi 0x8b 0x73 0x55 - -cadet_blue1 :: RGBi -cadet_blue1 = RGBi 0x98 0xf5 0xff - -cadet_blue2 :: RGBi -cadet_blue2 = RGBi 0x8e 0xe5 0xee - -cadet_blue3 :: RGBi -cadet_blue3 = RGBi 0x7a 0xc5 0xcd - -cadet_blue4 :: RGBi -cadet_blue4 = RGBi 0x53 0x86 0x8b - -chartreuse1 :: RGBi -chartreuse1 = RGBi 0x7f 0xff 0x00 - -chartreuse2 :: RGBi -chartreuse2 = RGBi 0x76 0xee 0x00 - -chartreuse3 :: RGBi -chartreuse3 = RGBi 0x66 0xcd 0x00 - -chartreuse4 :: RGBi -chartreuse4 = RGBi 0x45 0x8b 0x00 - -chocolate1 :: RGBi -chocolate1 = RGBi 0xff 0x7f 0x24 - -chocolate2 :: RGBi -chocolate2 = RGBi 0xee 0x76 0x21 - -chocolate3 :: RGBi -chocolate3 = RGBi 0xcd 0x66 0x1d - -chocolate4 :: RGBi -chocolate4 = RGBi 0x8b 0x45 0x13 - -coral1 :: RGBi -coral1 = RGBi 0xff 0x72 0x56 - -coral2 :: RGBi -coral2 = RGBi 0xee 0x6a 0x50 - -coral3 :: RGBi -coral3 = RGBi 0xcd 0x5b 0x45 - -coral4 :: RGBi -coral4 = RGBi 0x8b 0x3e 0x2f - -cornsilk1 :: RGBi -cornsilk1 = RGBi 0xff 0xf8 0xdc - -cornsilk2 :: RGBi -cornsilk2 = RGBi 0xee 0xe8 0xcd - -cornsilk3 :: RGBi -cornsilk3 = RGBi 0xcd 0xc8 0xb1 - -cornsilk4 :: RGBi -cornsilk4 = RGBi 0x8b 0x88 0x78 - -cyan1 :: RGBi -cyan1 = RGBi 0x00 0xff 0xff - -cyan2 :: RGBi -cyan2 = RGBi 0x00 0xee 0xee - -cyan3 :: RGBi -cyan3 = RGBi 0x00 0xcd 0xcd - -cyan4 :: RGBi -cyan4 = RGBi 0x00 0x8b 0x8b - -dark_goldenrod1 :: RGBi -dark_goldenrod1 = RGBi 0xff 0xb9 0x0f - -dark_goldenrod2 :: RGBi -dark_goldenrod2 = RGBi 0xee 0xad 0x0e - -dark_goldenrod3 :: RGBi -dark_goldenrod3 = RGBi 0xcd 0x95 0x0c - -dark_goldenrod4 :: RGBi -dark_goldenrod4 = RGBi 0x8b 0x65 0x08 - -dark_olive_green1 :: RGBi -dark_olive_green1 = RGBi 0xca 0xff 0x70 - -dark_olive_green2 :: RGBi -dark_olive_green2 = RGBi 0xbc 0xee 0x68 - -dark_olive_green3 :: RGBi -dark_olive_green3 = RGBi 0xa2 0xcd 0x5a - -dark_olive_green4 :: RGBi -dark_olive_green4 = RGBi 0x6e 0x8b 0x3d - -dark_orange1 :: RGBi -dark_orange1 = RGBi 0xff 0x7f 0x00 - -dark_orange2 :: RGBi -dark_orange2 = RGBi 0xee 0x76 0x00 - -dark_orange3 :: RGBi -dark_orange3 = RGBi 0xcd 0x66 0x00 - -dark_orange4 :: RGBi -dark_orange4 = RGBi 0x8b 0x45 0x00 - -dark_orchid1 :: RGBi -dark_orchid1 = RGBi 0xbf 0x3e 0xff - -dark_orchid2 :: RGBi -dark_orchid2 = RGBi 0xb2 0x3a 0xee - -dark_orchid3 :: RGBi -dark_orchid3 = RGBi 0x9a 0x32 0xcd - -dark_orchid4 :: RGBi -dark_orchid4 = RGBi 0x68 0x22 0x8b - -dark_sea_green1 :: RGBi -dark_sea_green1 = RGBi 0xc1 0xff 0xc1 - -dark_sea_green2 :: RGBi -dark_sea_green2 = RGBi 0xb4 0xee 0xb4 - -dark_sea_green3 :: RGBi -dark_sea_green3 = RGBi 0x9b 0xcd 0x9b - -dark_sea_green4 :: RGBi -dark_sea_green4 = RGBi 0x69 0x8b 0x69 - -dark_slate_gray1 :: RGBi -dark_slate_gray1 = RGBi 0x97 0xff 0xff - -dark_slate_gray2 :: RGBi -dark_slate_gray2 = RGBi 0x8d 0xee 0xee - -dark_slate_gray3 :: RGBi -dark_slate_gray3 = RGBi 0x79 0xcd 0xcd - -dark_slate_gray4 :: RGBi -dark_slate_gray4 = RGBi 0x52 0x8b 0x8b - -deep_pink1 :: RGBi -deep_pink1 = RGBi 0xff 0x14 0x93 - -deep_pink2 :: RGBi -deep_pink2 = RGBi 0xee 0x12 0x89 - -deep_pink3 :: RGBi -deep_pink3 = RGBi 0xcd 0x10 0x76 - -deep_pink4 :: RGBi -deep_pink4 = RGBi 0x8b 0x0a 0x50 - -deep_sky_blue1 :: RGBi -deep_sky_blue1 = RGBi 0x00 0xbf 0xff - -deep_sky_blue2 :: RGBi -deep_sky_blue2 = RGBi 0x00 0xb2 0xee - -deep_sky_blue3 :: RGBi -deep_sky_blue3 = RGBi 0x00 0x9a 0xcd - -deep_sky_blue4 :: RGBi -deep_sky_blue4 = RGBi 0x00 0x68 0x8b - -dodger_blue1 :: RGBi -dodger_blue1 = RGBi 0x1e 0x90 0xff - -dodger_blue2 :: RGBi -dodger_blue2 = RGBi 0x1c 0x86 0xee - -dodger_blue3 :: RGBi -dodger_blue3 = RGBi 0x18 0x74 0xcd - -dodger_blue4 :: RGBi -dodger_blue4 = RGBi 0x10 0x4e 0x8b - -firebrick1 :: RGBi -firebrick1 = RGBi 0xff 0x30 0x30 - -firebrick2 :: RGBi -firebrick2 = RGBi 0xee 0x2c 0x2c - -firebrick3 :: RGBi -firebrick3 = RGBi 0xcd 0x26 0x26 - -firebrick4 :: RGBi -firebrick4 = RGBi 0x8b 0x1a 0x1a - -gold1 :: RGBi -gold1 = RGBi 0xff 0xd7 0x00 - -gold2 :: RGBi -gold2 = RGBi 0xee 0xc9 0x00 - -gold3 :: RGBi -gold3 = RGBi 0xcd 0xad 0x00 - -gold4 :: RGBi -gold4 = RGBi 0x8b 0x75 0x00 - -goldenrod1 :: RGBi -goldenrod1 = RGBi 0xff 0xc1 0x25 - -goldenrod2 :: RGBi -goldenrod2 = RGBi 0xee 0xb4 0x22 - -goldenrod3 :: RGBi -goldenrod3 = RGBi 0xcd 0x9b 0x1d - -goldenrod4 :: RGBi -goldenrod4 = RGBi 0x8b 0x69 0x14 - -green1 :: RGBi -green1 = RGBi 0x00 0xff 0x00 - -green2 :: RGBi -green2 = RGBi 0x00 0xee 0x00 - -green3 :: RGBi -green3 = RGBi 0x00 0xcd 0x00 - -green4 :: RGBi -green4 = RGBi 0x00 0x8b 0x00 - -honeydew1 :: RGBi -honeydew1 = RGBi 0xf0 0xff 0xf0 - -honeydew2 :: RGBi -honeydew2 = RGBi 0xe0 0xee 0xe0 - -honeydew3 :: RGBi -honeydew3 = RGBi 0xc1 0xcd 0xc1 - -honeydew4 :: RGBi -honeydew4 = RGBi 0x83 0x8b 0x83 - -hot_pink1 :: RGBi -hot_pink1 = RGBi 0xff 0x6e 0xb4 - -hot_pink2 :: RGBi -hot_pink2 = RGBi 0xee 0x6a 0xa7 - -hot_pink3 :: RGBi -hot_pink3 = RGBi 0xcd 0x60 0x90 - -hot_pink4 :: RGBi -hot_pink4 = RGBi 0x8b 0x3a 0x62 - -indian_red1 :: RGBi -indian_red1 = RGBi 0xff 0x6a 0x6a - -indian_red2 :: RGBi -indian_red2 = RGBi 0xee 0x63 0x63 - -indian_red3 :: RGBi -indian_red3 = RGBi 0xcd 0x55 0x55 - -indian_red4 :: RGBi -indian_red4 = RGBi 0x8b 0x3a 0x3a - -ivory1 :: RGBi -ivory1 = RGBi 0xff 0xff 0xf0 - -ivory2 :: RGBi -ivory2 = RGBi 0xee 0xee 0xe0 - -ivory3 :: RGBi -ivory3 = RGBi 0xcd 0xcd 0xc1 - -ivory4 :: RGBi -ivory4 = RGBi 0x8b 0x8b 0x83 - -khaki1 :: RGBi -khaki1 = RGBi 0xff 0xf6 0x8f - -khaki2 :: RGBi -khaki2 = RGBi 0xee 0xe6 0x85 - -khaki3 :: RGBi -khaki3 = RGBi 0xcd 0xc6 0x73 - -khaki4 :: RGBi -khaki4 = RGBi 0x8b 0x86 0x4e - -lavender_blush1 :: RGBi -lavender_blush1 = RGBi 0xff 0xf0 0xf5 - -lavender_blush2 :: RGBi -lavender_blush2 = RGBi 0xee 0xe0 0xe5 - -lavender_blush3 :: RGBi -lavender_blush3 = RGBi 0xcd 0xc1 0xc5 - -lavender_blush4 :: RGBi -lavender_blush4 = RGBi 0x8b 0x83 0x86 - -lemon_chiffon1 :: RGBi -lemon_chiffon1 = RGBi 0xff 0xfa 0xcd - -lemon_chiffon2 :: RGBi -lemon_chiffon2 = RGBi 0xee 0xe9 0xbf - -lemon_chiffon3 :: RGBi -lemon_chiffon3 = RGBi 0xcd 0xc9 0xa5 - -lemon_chiffon4 :: RGBi -lemon_chiffon4 = RGBi 0x8b 0x89 0x70 - -light_blue1 :: RGBi -light_blue1 = RGBi 0xbf 0xef 0xff - -light_blue2 :: RGBi -light_blue2 = RGBi 0xb2 0xdf 0xee - -light_blue3 :: RGBi -light_blue3 = RGBi 0x9a 0xc0 0xcd - -light_blue4 :: RGBi -light_blue4 = RGBi 0x68 0x83 0x8b - -light_cyan1 :: RGBi -light_cyan1 = RGBi 0xe0 0xff 0xff - -light_cyan2 :: RGBi -light_cyan2 = RGBi 0xd1 0xee 0xee - -light_cyan3 :: RGBi -light_cyan3 = RGBi 0xb4 0xcd 0xcd - -light_cyan4 :: RGBi -light_cyan4 = RGBi 0x7a 0x8b 0x8b - -light_goldenrod1 :: RGBi -light_goldenrod1 = RGBi 0xff 0xec 0x8b - -light_goldenrod2 :: RGBi -light_goldenrod2 = RGBi 0xee 0xdc 0x82 - -light_goldenrod3 :: RGBi -light_goldenrod3 = RGBi 0xcd 0xbe 0x70 - -light_goldenrod4 :: RGBi -light_goldenrod4 = RGBi 0x8b 0x81 0x4c - -light_pink1 :: RGBi -light_pink1 = RGBi 0xff 0xae 0xb9 - -light_pink2 :: RGBi -light_pink2 = RGBi 0xee 0xa2 0xad - -light_pink3 :: RGBi -light_pink3 = RGBi 0xcd 0x8c 0x95 - -light_pink4 :: RGBi -light_pink4 = RGBi 0x8b 0x5f 0x65 - -light_salmon1 :: RGBi -light_salmon1 = RGBi 0xff 0xa0 0x7a - -light_salmon2 :: RGBi -light_salmon2 = RGBi 0xee 0x95 0x72 - -light_salmon3 :: RGBi -light_salmon3 = RGBi 0xcd 0x81 0x62 - -light_salmon4 :: RGBi -light_salmon4 = RGBi 0x8b 0x57 0x42 - -light_sky_blue1 :: RGBi -light_sky_blue1 = RGBi 0xb0 0xe2 0xff - -light_sky_blue2 :: RGBi -light_sky_blue2 = RGBi 0xa4 0xd3 0xee - -light_sky_blue3 :: RGBi -light_sky_blue3 = RGBi 0x8d 0xb6 0xcd - -light_sky_blue4 :: RGBi -light_sky_blue4 = RGBi 0x60 0x7b 0x8b - -light_steel_blue1 :: RGBi -light_steel_blue1 = RGBi 0xca 0xe1 0xff - -light_steel_blue2 :: RGBi -light_steel_blue2 = RGBi 0xbc 0xd2 0xee - -light_steel_blue3 :: RGBi -light_steel_blue3 = RGBi 0xa2 0xb5 0xcd - -light_steel_blue4 :: RGBi -light_steel_blue4 = RGBi 0x6e 0x7b 0x8b - -light_yellow1 :: RGBi -light_yellow1 = RGBi 0xff 0xff 0xe0 - -light_yellow2 :: RGBi -light_yellow2 = RGBi 0xee 0xee 0xd1 - -light_yellow3 :: RGBi -light_yellow3 = RGBi 0xcd 0xcd 0xb4 - -light_yellow4 :: RGBi -light_yellow4 = RGBi 0x8b 0x8b 0x7a - -magenta1 :: RGBi -magenta1 = RGBi 0xff 0x00 0xff - -magenta2 :: RGBi -magenta2 = RGBi 0xee 0x00 0xee - -magenta3 :: RGBi -magenta3 = RGBi 0xcd 0x00 0xcd - -magenta4 :: RGBi -magenta4 = RGBi 0x8b 0x00 0x8b - -maroon1 :: RGBi -maroon1 = RGBi 0xff 0x34 0xb3 - -maroon2 :: RGBi -maroon2 = RGBi 0xee 0x30 0xa7 - -maroon3 :: RGBi -maroon3 = RGBi 0xcd 0x29 0x90 - -maroon4 :: RGBi -maroon4 = RGBi 0x8b 0x1c 0x62 - -medium_orchid1 :: RGBi -medium_orchid1 = RGBi 0xe0 0x66 0xff - -medium_orchid2 :: RGBi -medium_orchid2 = RGBi 0xd1 0x5f 0xee - -medium_orchid3 :: RGBi -medium_orchid3 = RGBi 0xb4 0x52 0xcd - -medium_orchid4 :: RGBi -medium_orchid4 = RGBi 0x7a 0x37 0x8b - -medium_purple1 :: RGBi -medium_purple1 = RGBi 0xab 0x82 0xff - -medium_purple2 :: RGBi -medium_purple2 = RGBi 0x9f 0x79 0xee - -medium_purple3 :: RGBi -medium_purple3 = RGBi 0x89 0x68 0xcd - -medium_purple4 :: RGBi -medium_purple4 = RGBi 0x5d 0x47 0x8b - -misty_rose1 :: RGBi -misty_rose1 = RGBi 0xff 0xe4 0xe1 - -misty_rose2 :: RGBi -misty_rose2 = RGBi 0xee 0xd5 0xd2 - -misty_rose3 :: RGBi -misty_rose3 = RGBi 0xcd 0xb7 0xb5 - -misty_rose4 :: RGBi -misty_rose4 = RGBi 0x8b 0x7d 0x7b - -navajo_white1 :: RGBi -navajo_white1 = RGBi 0xff 0xde 0xad - -navajo_white2 :: RGBi -navajo_white2 = RGBi 0xee 0xcf 0xa1 - -navajo_white3 :: RGBi -navajo_white3 = RGBi 0xcd 0xb3 0x8b - -navajo_white4 :: RGBi -navajo_white4 = RGBi 0x8b 0x79 0x5e - -olive_drab1 :: RGBi -olive_drab1 = RGBi 0xc0 0xff 0x3e - -olive_drab2 :: RGBi -olive_drab2 = RGBi 0xb3 0xee 0x3a - -olive_drab3 :: RGBi -olive_drab3 = RGBi 0x9a 0xcd 0x32 - -olive_drab4 :: RGBi -olive_drab4 = RGBi 0x69 0x8b 0x22 - -orange1 :: RGBi -orange1 = RGBi 0xff 0xa5 0x00 - -orange2 :: RGBi -orange2 = RGBi 0xee 0x9a 0x00 - -orange3 :: RGBi -orange3 = RGBi 0xcd 0x85 0x00 - -orange4 :: RGBi -orange4 = RGBi 0x8b 0x5a 0x00 - -orange_red1 :: RGBi -orange_red1 = RGBi 0xff 0x45 0x00 - -orange_red2 :: RGBi -orange_red2 = RGBi 0xee 0x40 0x00 - -orange_red3 :: RGBi -orange_red3 = RGBi 0xcd 0x37 0x00 - -orange_red4 :: RGBi -orange_red4 = RGBi 0x8b 0x25 0x00 - -orchid1 :: RGBi -orchid1 = RGBi 0xff 0x83 0xfa - -orchid2 :: RGBi -orchid2 = RGBi 0xee 0x7a 0xe9 - -orchid3 :: RGBi -orchid3 = RGBi 0xcd 0x69 0xc9 - -orchid4 :: RGBi -orchid4 = RGBi 0x8b 0x47 0x89 - -pale_green1 :: RGBi -pale_green1 = RGBi 0x9a 0xff 0x9a - -pale_green2 :: RGBi -pale_green2 = RGBi 0x90 0xee 0x90 - -pale_green3 :: RGBi -pale_green3 = RGBi 0x7c 0xcd 0x7c - -pale_green4 :: RGBi -pale_green4 = RGBi 0x54 0x8b 0x54 - -pale_turquoise1 :: RGBi -pale_turquoise1 = RGBi 0xbb 0xff 0xff - -pale_turquoise2 :: RGBi -pale_turquoise2 = RGBi 0xae 0xee 0xee - -pale_turquoise3 :: RGBi -pale_turquoise3 = RGBi 0x96 0xcd 0xcd - -pale_turquoise4 :: RGBi -pale_turquoise4 = RGBi 0x66 0x8b 0x8b - -pale_violet_red1 :: RGBi -pale_violet_red1 = RGBi 0xff 0x82 0xab - -pale_violet_red2 :: RGBi -pale_violet_red2 = RGBi 0xee 0x79 0x9f - -pale_violet_red3 :: RGBi -pale_violet_red3 = RGBi 0xcd 0x68 0x89 - -pale_violet_red4 :: RGBi -pale_violet_red4 = RGBi 0x8b 0x47 0x5d - -peach_puff1 :: RGBi -peach_puff1 = RGBi 0xff 0xda 0xb9 - -peach_puff2 :: RGBi -peach_puff2 = RGBi 0xee 0xcb 0xad - -peach_puff3 :: RGBi -peach_puff3 = RGBi 0xcd 0xaf 0x95 - -peach_puff4 :: RGBi -peach_puff4 = RGBi 0x8b 0x77 0x65 - -pink1 :: RGBi -pink1 = RGBi 0xff 0xb5 0xc5 - -pink2 :: RGBi -pink2 = RGBi 0xee 0xa9 0xb8 - -pink3 :: RGBi -pink3 = RGBi 0xcd 0x91 0x9e - -pink4 :: RGBi -pink4 = RGBi 0x8b 0x63 0x6c - -plum1 :: RGBi -plum1 = RGBi 0xff 0xbb 0xff - -plum2 :: RGBi -plum2 = RGBi 0xee 0xae 0xee - -plum3 :: RGBi -plum3 = RGBi 0xcd 0x96 0xcd - -plum4 :: RGBi -plum4 = RGBi 0x8b 0x66 0x8b - -purple1 :: RGBi -purple1 = RGBi 0x9b 0x30 0xff - -purple2 :: RGBi -purple2 = RGBi 0x91 0x2c 0xee - -purple3 :: RGBi -purple3 = RGBi 0x7d 0x26 0xcd - -purple4 :: RGBi -purple4 = RGBi 0x55 0x1a 0x8b - -red1 :: RGBi -red1 = RGBi 0xff 0x00 0x00 - -red2 :: RGBi -red2 = RGBi 0xee 0x00 0x00 - -red3 :: RGBi -red3 = RGBi 0xcd 0x00 0x00 - -red4 :: RGBi -red4 = RGBi 0x8b 0x00 0x00 - -rosy_brown1 :: RGBi -rosy_brown1 = RGBi 0xff 0xc1 0xc1 - -rosy_brown2 :: RGBi -rosy_brown2 = RGBi 0xee 0xb4 0xb4 - -rosy_brown3 :: RGBi -rosy_brown3 = RGBi 0xcd 0x9b 0x9b - -rosy_brown4 :: RGBi -rosy_brown4 = RGBi 0x8b 0x69 0x69 - -royal_blue1 :: RGBi -royal_blue1 = RGBi 0x48 0x76 0xff - -royal_blue2 :: RGBi -royal_blue2 = RGBi 0x43 0x6e 0xee - -royal_blue3 :: RGBi -royal_blue3 = RGBi 0x3a 0x5f 0xcd - -royal_blue4 :: RGBi -royal_blue4 = RGBi 0x27 0x40 0x8b - - -salmon1 :: RGBi -salmon1 = RGBi 0xff 0x8c 0x69 - -salmon2 :: RGBi -salmon2 = RGBi 0xee 0x82 0x62 - -salmon3 :: RGBi -salmon3 = RGBi 0xcd 0x70 0x54 - -salmon4 :: RGBi -salmon4 = RGBi 0x8b 0x4c 0x39 - -sea_green1 :: RGBi -sea_green1 = RGBi 0x54 0xff 0x9f - -sea_green2 :: RGBi -sea_green2 = RGBi 0x4e 0xee 0x94 - -sea_green3 :: RGBi -sea_green3 = RGBi 0x43 0xcd 0x80 - -sea_green4 :: RGBi -sea_green4 = RGBi 0x2e 0x8b 0x57 - -seashell1 :: RGBi -seashell1 = RGBi 0xff 0xf5 0xee - -seashell2 :: RGBi -seashell2 = RGBi 0xee 0xe5 0xde - -seashell3 :: RGBi -seashell3 = RGBi 0xcd 0xc5 0xbf - -seashell4 :: RGBi -seashell4 = RGBi 0x8b 0x86 0x82 - -sienna1 :: RGBi -sienna1 = RGBi 0xff 0x82 0x47 - -sienna2 :: RGBi -sienna2 = RGBi 0xee 0x79 0x42 - -sienna3 :: RGBi -sienna3 = RGBi 0xcd 0x68 0x39 - -sienna4 :: RGBi -sienna4 = RGBi 0x8b 0x47 0x26 - -sky_blue1 :: RGBi -sky_blue1 = RGBi 0x87 0xce 0xff - -sky_blue2 :: RGBi -sky_blue2 = RGBi 0x7e 0xc0 0xee - -sky_blue3 :: RGBi -sky_blue3 = RGBi 0x6c 0xa6 0xcd - -sky_blue4 :: RGBi -sky_blue4 = RGBi 0x4a 0x70 0x8b - -slate_blue1 :: RGBi -slate_blue1 = RGBi 0x83 0x6f 0xff - -slate_blue2 :: RGBi -slate_blue2 = RGBi 0x7a 0x67 0xee - -slate_blue3 :: RGBi -slate_blue3 = RGBi 0x69 0x59 0xcd - -slate_blue4 :: RGBi -slate_blue4 = RGBi 0x47 0x3c 0x8b - -slate_gray1 :: RGBi -slate_gray1 = RGBi 0xc6 0xe2 0xff - -slate_gray2 :: RGBi -slate_gray2 = RGBi 0xb9 0xd3 0xee - -slate_gray3 :: RGBi -slate_gray3 = RGBi 0x9f 0xb6 0xcd - -slate_gray4 :: RGBi -slate_gray4 = RGBi 0x6c 0x7b 0x8b - -snow1 :: RGBi -snow1 = RGBi 0xff 0xfa 0xfa - -snow2 :: RGBi -snow2 = RGBi 0xee 0xe9 0xe9 - -snow3 :: RGBi -snow3 = RGBi 0xcd 0xc9 0xc9 - -snow4 :: RGBi -snow4 = RGBi 0x8b 0x89 0x89 - -spring_green1 :: RGBi -spring_green1 = RGBi 0x00 0xff 0x7f - -spring_green2 :: RGBi -spring_green2 = RGBi 0x00 0xee 0x76 - -spring_green3 :: RGBi -spring_green3 = RGBi 0x00 0xcd 0x66 - -spring_green4 :: RGBi -spring_green4 = RGBi 0x00 0x8b 0x45 - -steel_blue1 :: RGBi -steel_blue1 = RGBi 0x63 0xb8 0xff - -steel_blue2 :: RGBi -steel_blue2 = RGBi 0x5c 0xac 0xee - -steel_blue3 :: RGBi -steel_blue3 = RGBi 0x4f 0x94 0xcd - -steel_blue4 :: RGBi -steel_blue4 = RGBi 0x36 0x64 0x8b - -tan1 :: RGBi -tan1 = RGBi 0xff 0xa5 0x4f - -tan2 :: RGBi -tan2 = RGBi 0xee 0x9a 0x49 - -tan3 :: RGBi -tan3 = RGBi 0xcd 0x85 0x3f - -tan4 :: RGBi -tan4 = RGBi 0x8b 0x5a 0x2b - -thistle1 :: RGBi -thistle1 = RGBi 0xff 0xe1 0xff - -thistle2 :: RGBi -thistle2 = RGBi 0xee 0xd2 0xee - -thistle3 :: RGBi -thistle3 = RGBi 0xcd 0xb5 0xcd - -thistle4 :: RGBi -thistle4 = RGBi 0x8b 0x7b 0x8b - -tomato1 :: RGBi -tomato1 = RGBi 0xff 0x63 0x47 - -tomato2 :: RGBi -tomato2 = RGBi 0xee 0x5c 0x42 - -tomato3 :: RGBi -tomato3 = RGBi 0xcd 0x4f 0x39 - -tomato4 :: RGBi -tomato4 = RGBi 0x8b 0x36 0x26 - -turquoise1 :: RGBi -turquoise1 = RGBi 0x00 0xf5 0xff - -turquoise2 :: RGBi -turquoise2 = RGBi 0x00 0xe5 0xee - -turquoise3 :: RGBi -turquoise3 = RGBi 0x00 0xc5 0xcd - -turquoise4 :: RGBi -turquoise4 = RGBi 0x00 0x86 0x8b - -violet_red1 :: RGBi -violet_red1 = RGBi 0xff 0x3e 0x96 - -violet_red2 :: RGBi -violet_red2 = RGBi 0xee 0x3a 0x8c - -violet_red3 :: RGBi -violet_red3 = RGBi 0xcd 0x32 0x78 - -violet_red4 :: RGBi -violet_red4 = RGBi 0x8b 0x22 0x52 - -wheat1 :: RGBi -wheat1 = RGBi 0xff 0xe7 0xba - -wheat2 :: RGBi -wheat2 = RGBi 0xee 0xd8 0xae - -wheat3 :: RGBi -wheat3 = RGBi 0xcd 0xba 0x96 - -wheat4 :: RGBi -wheat4 = RGBi 0x8b 0x7e 0x66 - -yellow1 :: RGBi -yellow1 = RGBi 0xff 0xff 0x00 - -yellow2 :: RGBi -yellow2 = RGBi 0xee 0xee 0x00 - -yellow3 :: RGBi -yellow3 = RGBi 0xcd 0xcd 0x00 - -yellow4 :: RGBi -yellow4 = RGBi 0x8b 0x8b 0x00 - - - - - - diff --git a/src/Wumpus/Basic/Dots/AnchorDots.hs b/src/Wumpus/Basic/Dots/AnchorDots.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Dots/AnchorDots.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Dots.AnchorDots --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Dots with anchors. --- --- In many cases a surrounding circle is used to locate anchor --- points - this could be improved to use the actual dot border --- at some point. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Dots.AnchorDots - ( - - -- * Existential anchor type - DotAnchor - - , DotLocImage - , DDotLocImage - - -- * Dots with anchor points - , dotChar - , dotText - , dotHLine - , dotVLine - , dotX - , dotPlus - , dotCross - , dotDiamond - , dotFDiamond - - , dotDisk - , dotSquare - , dotCircle - , dotPentagon - , dotStar - - , dotAsterisk - , dotOPlus - , dotOCross - , dotFOCross - - ) where - -import Wumpus.Basic.Dots.Marks -import Wumpus.Basic.Graphic -import Wumpus.Basic.Text.LRText -import Wumpus.Basic.Utils.Intersection - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - - --- An existential thing that supports anchors. --- This means any dot can retun the same (opaque) structure --- --- But it does mean that which anchor class are supported is --- fixed - the datatype needs a field for each one. --- Supporting north, southeast etc. will also be tedious... --- -data DotAnchor u = forall s. - DotAnchor { center_anchor :: Point2 u - , radial_anchor :: Radian -> Point2 u - , cardinal_anchor :: Cardinal -> Point2 u } - -data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW - deriving (Eq,Show) - -type instance DUnit (DotAnchor u) = u - -instance CenterAnchor (DotAnchor u) where - center (DotAnchor ca _ _) = ca - -instance RadialAnchor (DotAnchor u) where - radialAnchor theta (DotAnchor _ ra _) = ra theta - -instance CardinalAnchor (DotAnchor u) where - north (DotAnchor _ _ c1) = c1 NN - south (DotAnchor _ _ c1) = c1 SS - east (DotAnchor _ _ c1) = c1 EE - west (DotAnchor _ _ c1) = c1 WW - - - -instance CardinalAnchor2 (DotAnchor u) where - northeast (DotAnchor _ _ c1) = c1 NE - southeast (DotAnchor _ _ c1) = c1 SE - southwest (DotAnchor _ _ c1) = c1 SW - northwest (DotAnchor _ _ c1) = c1 NW - - -radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u -radialCardinal rad ctr NN = ctr .+^ (avec (pi/2) rad) -radialCardinal rad ctr NE = ctr .+^ (avec (pi/4) rad) -radialCardinal rad ctr EE = ctr .+^ (avec 0 rad) -radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) -radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) -radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) -radialCardinal rad ctr WW = ctr .+^ (avec pi rad) -radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) - - --- Rectangle cardinal points are at \"middles and corners\". --- - -rectCardinal :: Floating u => u -> u -> Point2 u -> Cardinal -> Point2 u -rectCardinal _ hh ctr NN = ctr .+^ (vvec hh) -rectCardinal hw hh ctr NE = ctr .+^ (vec hw hh) -rectCardinal hw _ ctr EE = ctr .+^ (hvec hw) -rectCardinal hw hh ctr SE = ctr .+^ (vec hw (-hh)) -rectCardinal _ hh ctr SS = ctr .+^ (vvec (-hh)) -rectCardinal hw hh ctr SW = ctr .+^ (vec (-hw) (-hh) ) -rectCardinal hw _ ctr WW = ctr .+^ (hvec (-hw)) -rectCardinal hw hh ctr NW = ctr .+^ (vec (-hw) hh) - - -rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u -rectangleAnchor hw hh ctr = - DotAnchor { center_anchor = ctr - , radial_anchor = fn - , cardinal_anchor = rectCardinal hw hh ctr } - where - fn theta = maybe ctr id $ findIntersect ctr theta - $ rectangleLines ctr hw hh - -bboxRectAnchor :: (Real u, Floating 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) - in rectangleAnchor hw hh (bl .+^ vec hw hh) - -rectangleLDO :: (Real u, Floating u) - => u -> u -> LocDrawingInfo u (DotAnchor u) -rectangleLDO w h = promote1 $ \pt -> wrap $ rectangleAnchor (w*0.5) (h*0.5) pt - - -circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u -circleAnchor rad ctr = DotAnchor ctr - (\theta -> ctr .+^ (avec theta rad)) - (radialCardinal rad ctr) - -circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u) -circleLDO = bind1 (static1 markHeight) $ \diam -> - promote1 $ \pt -> wrap $ circleAnchor (diam * 0.5) pt - - - --------------------------------------------------------------------------------- - -type DotLocImage u = LocImage u (DotAnchor u) - -type DDotLocImage = DotLocImage Double - -dotChar :: (Floating u, Real u, FromPtSize u) - => Char -> DotLocImage u -dotChar ch = dotText [ch] - - --- | Note - dots now use font metrics... --- -dotText :: (Floating u, Real u, FromPtSize u) - => String -> DotLocImage u -dotText ss = locImageMapL bboxRectAnchor (singleLineCC ss) - - --- Is this generally useful? ... --- -locImageMapL :: (a -> b) -> LocImage u a -> LocImage u b -locImageMapL f = postpro1 $ \(a,prim) -> (f a, prim) - - - -dotHLine :: (Floating u, FromPtSize u) => DotLocImage u -dotHLine = intoLocImage circleLDO markHLine - - -dotVLine :: (Floating u, FromPtSize u) => DotLocImage u -dotVLine = intoLocImage circleLDO markVLine - - -dotX :: (Floating u, FromPtSize u) => DotLocImage u -dotX = intoLocImage circleLDO markX - -dotPlus :: (Floating u, FromPtSize u) => DotLocImage u -dotPlus = intoLocImage circleLDO markPlus - -dotCross :: (Floating u, FromPtSize u) => DotLocImage u -dotCross = intoLocImage circleLDO markCross - -dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u -dotDiamond = intoLocImage circleLDO markDiamond - -dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u -dotFDiamond = intoLocImage circleLDO markFDiamond - - - -dotDisk :: (Floating u, FromPtSize u) => DotLocImage u -dotDisk = intoLocImage circleLDO markDisk - - -dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u -dotSquare = bind1 (static1 markHeight) $ \ h -> - intoLocImage (rectangleLDO h h) markSquare - - - - -dotCircle :: (Floating u, FromPtSize u) => DotLocImage u -dotCircle = intoLocImage circleLDO markCircle - - -dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u -dotPentagon = intoLocImage circleLDO markPentagon - -dotStar :: (Floating u, FromPtSize u) => DotLocImage u -dotStar = intoLocImage circleLDO markStar - - -dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u -dotAsterisk = intoLocImage circleLDO markAsterisk - -dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u -dotOPlus = intoLocImage circleLDO markOPlus - -dotOCross :: (Floating u, FromPtSize u) => DotLocImage u -dotOCross = intoLocImage circleLDO markOCross - -dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u -dotFOCross = intoLocImage circleLDO markFOCross diff --git a/src/Wumpus/Basic/Dots/Marks.hs b/src/Wumpus/Basic/Dots/Marks.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Dots/Marks.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Dots.Marks --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Marks - dots without anchor handles. --- --- \*\* WARNING \*\* - names are expected to change - filled and --- background-filled marks need a naming convention. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Dots.Marks - ( - - - -- * Marks - markChar - , markText - - , markHLine - , markVLine - , markX - , markPlus - , markCross - , markDiamond - , markFDiamond - , markBDiamond - , markDisk - , markSquare - , markCircle - , markPentagon - , markStar - , markAsterisk - , markOPlus - , markOCross - , markFOCross - - - ) where - - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Text.LRText - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - -import Control.Applicative -import Data.List - --- Marks should be the height of a lower-case letter... - --- NOTES --- --- TikZ has both stroked and bordered (filled and outline-stroked) --- marks e.g. square and square* --- - - --- | 'polygonPoints' : @ num_points * radius * center -> [point] @ --- -polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u] -polygonPoints n radius ctr = unfoldr phi (0,(pi*0.5)) - where - theta = (pi*2) / fromIntegral n - - phi (i,ang) | i < n = Just (ctr .+^ avec ang radius, (i+1,ang+theta)) - | otherwise = Nothing - - - - -shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u -shiftOrigin dx dy = prepro1 (displace dx dy) - -markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u -markChar ch = markText [ch] - - - - -markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u -markText ss = postpro1 (\(_,b) -> b) $ singleLineCC ss - - - - - --- | Supplied point is the center. --- -axialLine :: Fractional u => Vec2 u -> LocGraphic u -axialLine v = localPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v) - - -markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = bind1 (static1 markHeight) $ \h -> axialLine (hvec h) - - -markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = bind1 (static1 markHeight) $ \h -> axialLine (vvec h) - - -markX :: (Fractional u, FromPtSize u) => LocGraphic u -markX = bind1 (static1 markHeight) $ \h -> - let w = 0.75 * h in axialLine (vec w h) `oplus` axialLine (vec (-w) h) - - - -markPlus :: (Fractional u, FromPtSize u) => LocGraphic u -markPlus = markVLine `oplus` markHLine - - -markCross :: (Floating u, FromPtSize u) => LocGraphic u -markCross = bind1 (static1 markHeight) $ \h -> - (axialLine $ avec ang h) `oplus` (axialLine $ avec (-ang) h) - where - ang = pi*0.25 - --- needs horizontal pinch... - -pathDiamond :: (Fractional u, FromPtSize u) - => LocCF u (PrimPath u) -pathDiamond = bind1 (static1 markHeight) $ \h -> promote1 $ \pt -> - let hh = 0.66 * h; hw = 0.5 * h - s = pt .+^ vvec (-hh) - e = pt .+^ hvec hw - n = pt .+^ vvec hh - w = pt .+^ hvec (-hw) - in pure $ vertexPath [s,e,n,w] - - --- closedStroke :: (a -> ctx -> prim) --- pathDiamond :: (ctx -> pt -> a) --- ans :: (ctx -> pt -> prim) - -markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markDiamond = pathDiamond `bind1` (static1 . closedStroke) - -markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markFDiamond = pathDiamond `bind1` (static1 . filledPath) - - --- Note - the (const . fn) composition doesn\'t /tell/ much about --- what is going on - though obviously it can be decoded - make --- the function obvious to the second argument. --- --- A named combinator might be better. --- - -markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markBDiamond = pathDiamond `bind1` (static1 . borderedPath) - - --- | Note disk is filled. --- -markDisk :: (Fractional u, FromPtSize u) => LocGraphic u -markDisk = bind1 (static1 markHalfHeight) filledDisk - - - -markSquare :: (Fractional u, FromPtSize u) => LocGraphic u -markSquare = bind1 (static1 markHeight) $ \h -> - let d = 0.5*(-h) in shiftOrigin d d $ strokedRectangle h h - - - -markCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markCircle = bind1 (static1 markHalfHeight) strokedDisk - - -markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markBCircle = bind1 (static1 markHalfHeight) borderedDisk - - - -markPentagon :: (Floating u, FromPtSize u) => LocGraphic u -markPentagon = bind1 (static1 markHeight) $ \h -> - promote1 $ \pt -> closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt - - - - -markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar = bind1 (static1 markHeight) $ \h -> - promote1 $ \pt -> let ps = polygonPoints 5 (0.5*h) pt in step $ map (fn pt) ps - where - fn st p1 = openStroke $ primPath st [lineTo p1] - step (x:xs) = oconcat x xs - step _ = error "markStar - unreachable" - - --- Note - relies on the functional instance of OPlus - -markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u -markAsterisk = bind1 (static1 markHeight) $ \h -> - lineF1 h `oplus` lineF2 h `oplus` lineF3 h - where - ang = (pi*2) / 6 - lineF1 z = axialLine (vvec z) - lineF2 z = axialLine (avec ((pi*0.5) + ang) z) - lineF3 z = axialLine (avec ((pi*0.5) + ang + ang) z) - - - -markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u -markOPlus = markCircle `oplus` markPlus - - -markOCross :: (Floating u, FromPtSize u) => LocGraphic u -markOCross = markCircle `oplus` markCross - - -markFOCross :: (Floating u, FromPtSize u) => LocGraphic u -markFOCross = markCross `oplus` markBCircle - - --- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u --- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) - diff --git a/src/Wumpus/Basic/DrawingComposition.hs b/src/Wumpus/Basic/DrawingComposition.hs deleted file mode 100644 --- a/src/Wumpus/Basic/DrawingComposition.hs +++ /dev/null @@ -1,458 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.DrawingComposition --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Composition operators for Drawings. --- --- Note - some operations can produce empty drawings... --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.DrawingComposition - ( - -- * Composition - over - , under - - , centric - , nextToH - , nextToV - - , atPoint - , centeredAt - - , zconcat - - , hcat - , vcat - - - , hspace - , vspace - , hsep - , vsep - - -- * Compose with alignment - , alignH - , alignV - , alignHSep - , alignVSep - , hcatA - , vcatA - , hsepA - , vsepA - - - ) where - -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core - -import Data.AdditiveGroup -import Data.AffineSpace - -import Data.List ( foldl' ) - - - --------------------------------------------------------------------------------- --- Extract anchors - -boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a -boundaryExtr f = f . boundary - --- Operations on bounds - --- | The center of a picture. --- -boundaryCenter :: Fractional u => Picture u -> Point2 u -boundaryCenter = boundaryExtr center - - - --- | Extract the mid point of the top edge. --- -boundaryN :: Fractional u => Picture u -> Point2 u -boundaryN = boundaryExtr north - --- | Extract the mid point of the bottom edge. --- -boundaryS :: Fractional u => Picture u -> Point2 u -boundaryS = boundaryExtr south - --- | Extract the mid point of the left edge. --- -boundaryE :: Fractional u => Picture u -> Point2 u -boundaryE = boundaryExtr east - --- | Extract the mid point of the right edge. --- -boundaryW :: Fractional u => Picture u -> Point2 u -boundaryW = boundaryExtr west - - --- | Extract the top-left corner. --- -boundaryNW :: Fractional u => Picture u -> Point2 u -boundaryNW = boundaryExtr northwest - --- | Extract the top-right corner. --- -boundaryNE :: Picture u -> Point2 u -boundaryNE = boundaryExtr ur_corner - --- | Extract the bottom-left corner. --- -boundarySW :: Picture u -> Point2 u -boundarySW = boundaryExtr ll_corner - --- | Extract the bottom-right corner. --- -boundarySE :: Fractional u => Picture u -> Point2 u -boundarySE = boundaryExtr southeast - - -boundaryLeftEdge :: Picture u -> u -boundaryLeftEdge = boundaryExtr (point_x . ll_corner) - -boundaryRightEdge :: Picture u -> u -boundaryRightEdge = boundaryExtr (point_x . ur_corner) - -boundaryBottomEdge :: Picture u -> u -boundaryBottomEdge = boundaryExtr (point_y . ll_corner) - - -boundaryTopEdge :: Picture u -> u -boundaryTopEdge = boundaryExtr (point_y . ur_corner) - - - - - --- Note - do not export the empty drawing. It is easier to --- pretend it doesn't exist. --- -empty_drawing :: (Real u, Floating u, FromPtSize u) => Drawing u -empty_drawing = drawTracing $ return () - - - --------------------------------------------------------------------------------- --- Composition operators - --- Note - the megaCombR operator is in some way an --- /anti-combinator/. It seems easier to think about composing --- drawings if we do work on the result Pictures directly rather --- than build combinators to manipulate Drawings. --- --- The idea of combining pre- and post- operating combinators --- makes me worry about circular programs even though I know --- lazy evaluation allows me to write them (in some cicumstances). --- - - --- Picture /mega-combiner/ - moves only the second argument aka the --- right picture. --- -megaCombR :: (Num u, Ord u) - => (Picture u -> a) -> (Picture u -> a) - -> (a -> a -> Picture u -> Picture u) - -> Drawing u -> Drawing u - -> Drawing u -megaCombR qL qR trafoR = drawingConcat fn - where - fn pic1 pic2 = let a = qL pic1 - b = qR pic2 - p2 = trafoR a b pic2 - in pic1 `picOver` p2 - - - - --- | > a `over` b --- --- Place \'drawing\' a over b. The idea of @over@ here is in --- terms z-ordering, nither picture a or b are actually moved. --- -over :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u -over = drawingConcat picOver - - - --- | > a `under` b --- --- Similarly @under@ draws the first drawing behind --- the second but move neither. --- -under :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u -under = flip over - - - --- | Move in both the horizontal and vertical. --- -move :: (Num u, Ord u) => Vec2 u -> Drawing u -> Drawing u -move v = modifyDrawing (\p -> p `picMoveBy` v) - - - - --------------------------------------------------------------------------------- --- Composition - -infixr 5 `nextToV` -infixr 6 `nextToH`, `centric` - - - - --- | Draw @a@, move @b@ so its center is at the same center as --- @a@, @b@ is drawn over underneath in the zorder. --- --- > a `centeric` b --- --- -centric :: (Fractional u, Ord u) => Drawing u -> Drawing u -> Drawing u -centric = megaCombR boundaryCenter boundaryCenter moveFun - where - moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v - - - --- | > a `nextToH` b --- --- Horizontal composition - move @b@, placing it to the right --- of @a@. --- -nextToH :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u -nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun - where - moveFun a b pic = pic `picMoveBy` hvec (a - b) - - - --- | > a `nextToV` b --- --- Vertical composition - move @b@, placing it below @a@. --- -nextToV :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u -nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun - where - moveFun a b drw = drw `picMoveBy` vvec (a - b) - - --- | Place the picture at the supplied point. --- --- `atPoint` was previous the `at` operator. --- -atPoint :: (Num u, Ord u) => Drawing u -> Point2 u -> Drawing u -p `atPoint` (P2 x y) = move (V2 x y) p - - - --- | Center the picture at the supplied point. --- -centeredAt :: (Fractional u, Ord u) => Drawing u -> Point2 u -> Drawing u -centeredAt d (P2 x y) = modifyDrawing fn d - where - fn p = let bb = boundary p - dx = x - (boundaryWidth bb * 0.5) - dy = y - (boundaryHeight bb * 0.5) - in p `picMoveBy` vec dx dy - - --- | Concatenate the list of drawings. --- --- No pictures are moved. --- -zconcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u -zconcat [] = empty_drawing -zconcat (d:ds) = foldl' over d ds - - - - --- | Concatenate the list pictures @xs@ horizontally. --- -hcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u -hcat [] = empty_drawing -hcat (d:ds) = foldl' nextToH d ds - - --- | Concatenate the list of pictures @xs@ vertically. --- -vcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u -vcat [] = empty_drawing -vcat (d:ds) = foldl' nextToV d ds - - - - --------------------------------------------------------------------------------- - - - - --- | > hspace n a b --- --- Horizontal composition - move @b@, placing it to the right --- of @a@ with a horizontal gap of @n@ separating the pictures. --- -hspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u -hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun - where - moveFun a b pic = pic `picMoveBy` hvec (n + a - b) - - - - - --- | > vspace n a b --- --- Vertical composition - move @b@, placing it below @a@ with a --- vertical gap of @n@ separating the pictures. --- -vspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u -vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun - where - moveFun a b pic = pic `picMoveBy` vvec (a - b - n) - - - --- | > hsep n xs --- --- Concatenate the list of pictures @xs@ horizontally with --- @hspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -hsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u -hsep _ [] = empty_drawing -hsep n (d:ds) = foldl' (hspace n) d ds - - - --- | > vsep n xs --- --- Concatenate the list of pictures @xs@ vertically with --- @vspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -vsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u -vsep _ [] = empty_drawing -vsep n (d:ds) = foldl' (vspace n) d ds - - --------------------------------------------------------------------------------- --- Aligning pictures - -alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u -alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2) - - - --- | > alignH align a b --- --- Horizontal composition - move @b@, placing it to the right --- of @a@ and align it with the top, center or bottom of @a@. --- -alignH :: (Fractional u, Ord u) - => HAlign -> Drawing u -> Drawing u -> Drawing u -alignH HTop = megaCombR boundaryNE boundaryNW alignMove -alignH HCenter = megaCombR boundaryE boundaryW alignMove -alignH HBottom = megaCombR boundarySE boundarySW alignMove - - --- | > alignV align a b --- --- Vertical composition - move @b@, placing it below @a@ --- and align it with the left, center or right of @a@. --- -alignV :: (Fractional u, Ord u) - => VAlign -> Drawing u -> Drawing u -> Drawing u -alignV VLeft = megaCombR boundarySW boundaryNW alignMove -alignV VCenter = megaCombR boundaryS boundaryN alignMove -alignV VRight = megaCombR boundarySE boundaryNE alignMove - - - -alignMove2 :: (Num u, Ord u) - => Vec2 u -> Point2 u -> Point2 u -> Picture u -> Picture u -alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2)) - - - --- | > alignHSep align sep a b --- --- Spacing version of alignH - move @b@ to the right of @a@ --- separated by @sep@ units, align @b@ according to @align@. --- -alignHSep :: (Fractional u, Ord u) - => HAlign -> u -> Drawing u -> Drawing u -> Drawing u -alignHSep HTop dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx)) -alignHSep HCenter dx = megaCombR boundaryE boundaryW (alignMove2 (hvec dx)) -alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx)) - - --- | > alignVSep align sep a b --- --- Spacing version of alignV - move @b@ below @a@ --- separated by @sep@ units, align @b@ according to @align@. --- -alignVSep :: (Fractional u, Ord u) - => VAlign -> u -> Drawing u -> Drawing u -> Drawing u -alignVSep VLeft dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) -alignVSep VCenter dy = megaCombR boundaryS boundaryN (alignMove2 $ vvec (-dy)) -alignVSep VRight dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy)) - - --- | Variant of 'hcat' that aligns the pictures as well as --- concatenating them. --- -hcatA :: (Real u, Floating u, FromPtSize u) - => HAlign -> [Drawing u] -> Drawing u -hcatA _ [] = empty_drawing -hcatA ha (d:ds) = foldl' (alignH ha) d ds - - - --- | Variant of 'vcat' that aligns the pictures as well as --- concatenating them. --- -vcatA :: (Real u, Floating u, FromPtSize u) - => VAlign -> [Drawing u] -> Drawing u -vcatA _ [] = empty_drawing -vcatA va (d:ds) = foldl' (alignV va) d ds - - --- | Variant of @hsep@ that aligns the pictures as well as --- concatenating and spacing them. --- -hsepA :: (Real u, Floating u, FromPtSize u) - => HAlign -> u -> [Drawing u] -> Drawing u -hsepA _ _ [] = empty_drawing -hsepA ha n (d:ds) = foldl' op d ds - where - a `op` b = alignHSep ha n a b - - --- | Variant of @vsep@ that aligns the pictures as well as --- concatenating and spacing them. --- -vsepA :: (Real u, Floating u, FromPtSize u) - => VAlign -> u -> [Drawing u] -> Drawing u -vsepA _ _ [] = empty_drawing -vsepA va n (d:ds) = foldl' op d ds - where - a `op` b = alignVSep va n a b - - - diff --git a/src/Wumpus/Basic/FontLoader/AfmLoader.hs b/src/Wumpus/Basic/FontLoader/AfmLoader.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/AfmLoader.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.AfmLoader --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Font loader for the Adobe \"Core 14\" glyph metrics. --- --- Use this loader if you have the Adode glyph metrics set --- (AFM v4.1). This metrics set is avaiable from the Adobe --- website. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.AfmLoader - ( - - module Wumpus.Basic.FontLoader.Base - , module Wumpus.Basic.FontLoader.AfmV4Dot1Parser - - , loadAfmMetrics - , afmV4Dot1Loader - - - - ) where - -import Wumpus.Basic.FontLoader.AfmV4Dot1Parser -import Wumpus.Basic.FontLoader.Base -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core - - - -loadAfmMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics -loadAfmMetrics font_dir_path ns = - loadBaseGlyphMetrics (afmV4Dot1Loader font_dir_path) ns - - -afmV4Dot1Loader :: FilePath -> FontLoader AfmUnit -afmV4Dot1Loader font_dir_path = - FontLoader - { unit_scale_fun = afmUnitScale - , path_to_font_dir = font_dir_path - , file_name_locator = buildName - , font_parser = parseAfmV4Dot1File - , post_process = buildGlyphMetricsTable bbox (V2 600 0) 1000 - } - where - buildName :: FontName -> FilePath - buildName font = font ++ ".afm" - - bbox = BBox (P2 (-23) (-250)) (P2 715 805) - - diff --git a/src/Wumpus/Basic/FontLoader/AfmParserBase.hs b/src/Wumpus/Basic/FontLoader/AfmParserBase.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/AfmParserBase.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.AfmParserBase --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Common parsers for AFM files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.AfmParserBase - ( - - afmFileParser - , runQuery - , textQuery - - , getFontBBox - , getEncodingScheme - , getCapHeight - - , charBBox - , metric - , keyStringPair - , versionNumber - , startCharMetrics - - , keyName - , newlineOrEOF - , name - , name1 - , semi - , uptoNewline - , number - , cint - , hexInt - , octInt - - , lexeme - , symbol - , integer - , int - , double - - ) where - -import Wumpus.Basic.FontLoader.Base -import Wumpus.Basic.Utils.ParserCombinators -import qualified Wumpus.Basic.Utils.TokenParsers as P - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - -import Data.Char -import qualified Data.Map as Map - - - -afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile -afmFileParser pgm = do - info <- (versionNumber *> globalInfo) - cms <- (startCharMetrics *> many pgm) - let mb_encoding = getEncodingScheme info - let mb_cap = getCapHeight info - let mb_bbox = getFontBBox info - case mb_bbox of - Nothing -> throwError "No FontBBox field in the AFM file." - Just bb -> return $ AfmFile - { afm_encoding = mb_encoding - , afm_font_bbox = bb - , afm_cap_height = mb_cap - , afm_glyph_metrics = cms - } - -globalInfo :: CharParser GlobalInfo -globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) - <$> manyTill keyStringPair (peek startCharMetrics) - - - -runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a -runQuery field_name p table = - Map.lookup field_name table >>= extr . runParser p - where - extr (Okay a _) = Just a - extr _ = Nothing - -textQuery :: String -> GlobalInfo -> Maybe String -textQuery = Map.lookup - - --- | Strictly speaking a fontBBox is measured in integer units. --- -getFontBBox :: GlobalInfo -> Maybe AfmBoundingBox -getFontBBox = runQuery "FontBBox" fontBBox - -getEncodingScheme :: GlobalInfo -> Maybe String -getEncodingScheme = textQuery "EncodingScheme" - -getCapHeight :: GlobalInfo -> Maybe AfmUnit -getCapHeight = runQuery "CapHeight" number - - -charBBox :: CharParser AfmBoundingBox -charBBox = symbol "B" *> fontBBox <* semi - -fontBBox :: CharParser AfmBoundingBox -fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury)) - <$> number <*> number <*> number <*> number - - - -metric :: String -> a -> CharParser a -> CharParser a -metric iden dfault p = option dfault go - where - go = symbol iden *> p <* semi - - - -keyStringPair :: CharParser (AfmKey,String) -keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF - "key-value line" - -versionNumber :: CharParser String -versionNumber = - symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF - "StartFontMetrics" - - -startCharMetrics :: CharParser Int -startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF - "StartCharMetrics failed" - - - --------------------------------------------------------------------------------- - - -keyName :: CharParser AfmKey -keyName = lexeme (many1 $ satisfy isAlphaNum) - - -newlineOrEOF :: CharParser () -newlineOrEOF = skipOne (lexeme newline) <|> eof - - -uptoNewline :: CharParser String -uptoNewline = many1 (noneOf ['\n']) - - -name :: CharParser String -name = lexeme $ many (noneOf ";\n") - -name1 :: CharParser String -name1 = lexeme $ many (noneOf "; \t\n") - - - -semi :: CharParser Char -semi = lexeme $ char ';' - - - - -number :: CharParser AfmUnit -number = liftA realToFrac double - - -cint :: CharParser Int -cint = hexInt <|> octInt <|> int - - -hexInt :: CharParser Int -hexInt = lexeme $ between (char '<') (char '>') P.hexBase - - -octInt :: CharParser Int -octInt = lexeme $ char '\\' *> P.octBase - - - --------------------------------------------------------------------------------- - --- no newline in whitespace - - -lp :: P.LexemeParser -lp = P.commentLineLexemeParser "Comment" [' ', '\t'] - - -lexeme :: CharParser a -> CharParser a -lexeme = P.lexeme lp - -symbol :: String -> CharParser String -symbol = lexeme . string - --- whiteSpace :: CharParser () --- whiteSpace = P.whiteSpace lp - - -integer :: CharParser Integer -integer = lexeme P.integer - -int :: CharParser Int -int = fromIntegral <$> integer - -double :: CharParser Double -double = lexeme P.double diff --git a/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs b/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.AfmV2 --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- AFM file parser for Version 2.0. --- --- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ --- have numerous differences. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.AfmV2Parser - ( - - parseAfmV2File - - ) where - -import Wumpus.Basic.FontLoader.AfmParserBase -import Wumpus.Basic.FontLoader.Base -import Wumpus.Basic.Utils.ParserCombinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - - - - --------------------------------------------------------------------------------- --- parser - -parseAfmV2File :: FilePath -> IO (Either ParseError AfmFile) -parseAfmV2File filepath = runParserEither p <$> readFile filepath - where - p = afmFileParser charMetricsV2 - - -charMetricsV2 :: CharParser AfmGlyphMetrics -charMetricsV2 = AfmGlyphMetrics <$> - metric "C" (-1) cint - <*> widthVector - <*> metric "N" "" name1 - <* charBBox - <* many (symbol "L" *> ligature_body <* semi) - <* newlineOrEOF - where - ligature_body = ((,) <$> name <*> name) - -widthVector :: CharParser (Vec2 AfmUnit) -widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) - <|> (symbol "W" *> (vec <$> number <*> number) <* semi) - - --------------------------------------------------------------------------------- - - - - diff --git a/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.AfmV4Dot1Parser --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- AFM file parser for Version 4.1. --- --- Adobe distributes font metrics for the /Core 14/ fonts as --- AFM Version 4.1 files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.AfmV4Dot1Parser - ( - - parseAfmV4Dot1File - - ) where - -import Wumpus.Basic.FontLoader.AfmParserBase -import Wumpus.Basic.FontLoader.Base -import Wumpus.Basic.Utils.ParserCombinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - - -parseAfmV4Dot1File :: FilePath -> IO (Either ParseError AfmFile) -parseAfmV4Dot1File filepath = runParserEither p <$> readFile filepath - where - p = afmFileParser charMetricsV4Dot1 - - - -charMetricsV4Dot1 :: CharParser AfmGlyphMetrics -charMetricsV4Dot1 = AfmGlyphMetrics <$> - characterCode - <*> widthVector - <*> metric "N" "" name1 - <* charBBox - <* many (symbol "L" *> ligature_body <* semi) - <* newlineOrEOF - where - ligature_body = ((,) <$> name <*> name) - - --- Note - there are many variants for width vectors in in 4.1. --- Wumpus needs some thought about what to do for them, it also --- needs some facility to tell how successful the parse has been. - -widthVector :: CharParser (Vec2 AfmUnit) -widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) - <|> (symbol "W" *> (vec <$> number <*> number) <* semi) - - --- V4.1 allows C int or CH \ --- -characterCode :: CharParser Int -characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint diff --git a/src/Wumpus/Basic/FontLoader/Base.hs b/src/Wumpus/Basic/FontLoader/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/Base.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.AfmV2 --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- AFM file parser. --- --- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ --- have numerous differences. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.Base - ( - - -- * Afm Unit - AfmUnit - , afmValue - , afmUnitScale - - -- * Glyph metrics - - , PSCharCode - , PSEncodingScheme - , AfmBoundingBox - - , AfmKey - , GlobalInfo - , AfmFile(..) - , AfmGlyphMetrics(..) - - -- * Font loading - , FontLoadErr - , FontLoadResult - , FontLoader(..) - , loadFont - - , BaseGlyphMetrics - , loadBaseGlyphMetrics - - , buildGlyphMetricsTable - - ) where - -import Wumpus.Basic.Graphic - - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.GlyphIndices - -import Data.Foldable ( foldrM ) -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Maybe - -import System.Directory -import System.FilePath - - - --- | Wrapped Double representing 1\/1000 of the scale factor --- (Point size) of a font. AFM files encode all measurements --- as these units. --- -newtype AfmUnit = AfmUnit { getAfmUnit :: Double } - deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) - -instance Show AfmUnit where - showsPrec p d = showsPrec p (getAfmUnit d) - - --- | Compute the size of a measurement in Afm units scaled by the --- point size of the font. --- -afmValue :: FromPtSize u => AfmUnit -> PtSize -> u -afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000) - -afmUnitScale :: AfmUnit -> PtSize -afmUnitScale u = (realToFrac $ getAfmUnit u / 1000) - - --------------------------------------------------------------------------------- - --- | Afm files index glyphs by /PostScript character code/. This --- is not the same as Unicode, ASCII... --- --- It is expected to be determined by @EncodingScheme@ in the --- Global Font Information Section. --- -type PSCharCode = Int - -type PSEncodingScheme = String - -type AfmBoundingBox = BoundingBox AfmUnit - -type AfmKey = String -type GlobalInfo = Map.Map AfmKey String - - - --- | Wumpus needs a very small subset of AFM files, common to both --- version 2.0 and version 4.1. --- --- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1 --- --- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus --- uses cap height in calculations, glyph metrics must be build --- with an arbitrary value if it is not present. --- --- Encoding Scheme is optional in AFM files. --- -data AfmFile = AfmFile - { afm_encoding :: Maybe String - , afm_font_bbox :: AfmBoundingBox - , afm_cap_height :: Maybe AfmUnit - , afm_glyph_metrics :: [AfmGlyphMetrics] - } - deriving (Show) - --- Note BBox is a required field for version 4.1. - - -data AfmGlyphMetrics = AfmGlyphMetrics - { afm_char_code :: !PSCharCode - , afm_width_vector :: !(Vec2 AfmUnit) - , afm_char_name :: !String - } - deriving (Eq,Show) - - - --- Maybe the CharMetricsTable should be scaled to Wumpus units as --- the last part of the parsing process... --- --- No it shouldn\'t - this would disallow drawings in centimeters --- - -type FontLoadErr = String -type FontLoadResult cu = Either FontLoadErr (GlyphMetricsTable cu) - -data FontLoader cu = forall interim. FontLoader - { unit_scale_fun :: cu -> PtSize - , path_to_font_dir :: FilePath - , file_name_locator :: FontName -> FilePath - , font_parser :: FilePath -> IO (Either String interim) - , post_process :: interim -> GlyphMetricsTable cu - } - - -loadFont :: FontLoader cu -> FontName -> IO (FontLoadResult cu) -loadFont loader font_name = - locateStep loader font_name >>= \ans -> case ans of - Nothing -> return $ Left $ "Cannot find font " ++ font_name - Just full_path -> parseStep loader full_path - -locateStep :: FontLoader cu -> FontName -> IO (Maybe FilePath) -locateStep loader font_name = - doesFileExist full_path >>= \check -> - if check then return $ Just full_path - else return $ Nothing - where - full_path = normalise $ path_to_font_dir loader - file_name_locator loader font_name - - -parseStep :: FontLoader cu -> FilePath -> IO (FontLoadResult cu) -parseStep (FontLoader _ _ _ parser post) valid_path = - fmap (either Left (Right . post)) $ parser valid_path - --------------------------------------------------------------------------------- - - - -loadBaseGlyphMetrics :: FontLoader u -> [FontName] -> IO BaseGlyphMetrics -loadBaseGlyphMetrics loader xs = foldrM fn Map.empty xs - where - fn font_name acc = loadFont loader font_name >>= \ans -> - case ans of - Left err -> reportBaseError font_name err >> return acc - Right table -> return $ - Map.insert font_name (tableToGM table) acc - - tableToGM = buildMetrics (unit_scale_fun loader) - -reportBaseError :: FontName -> FontLoadErr -> IO () -reportBaseError font_name err = do - putStrLn $ "The font " ++ font_name ++ " failed to load, with the error:" - putStrLn $ err - - - - -buildGlyphMetricsTable :: BoundingBox AfmUnit - -> Vec2 AfmUnit - -> AfmUnit - -> AfmFile - -> GlyphMetricsTable AfmUnit -buildGlyphMetricsTable bbox dflt_vec dflt_cap_height afm = - GlyphMetricsTable - { glyph_bounding_box = bbox - , glyph_default_adv_vec = dflt_vec - , glyph_adv_vecs = makeAdvVecs $ afm_glyph_metrics afm - , glyph_cap_height = fromMaybe dflt_cap_height $ afm_cap_height afm - } - - -makeAdvVecs :: [AfmGlyphMetrics] -> IntMap.IntMap (Vec2 AfmUnit) -makeAdvVecs = foldr fn IntMap.empty - where - fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of - Nothing -> table - Just i -> IntMap.insert i v table - diff --git a/src/Wumpus/Basic/FontLoader/GSFontMap.hs b/src/Wumpus/Basic/FontLoader/GSFontMap.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/GSFontMap.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.GSFontMap --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- GhostScript Font map. --- --- GhostScript aliases the /Core 14/ PostScript fonts to fonts --- it can freely distribute. This module provides aliases to --- Wumpus so the font loader can find the equivalent GhostScript --- files to the Core 14 set. --- --- The data in this file matches GhostScript 8.63. Other versions --- of GhostScript may need different aliases. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.GSFontMap - ( - - ghostscript_version - - , GSFontMap - , gsMetricsFile - , gsFontAlias - , core14_alias_table - - ) where - - -import Data.Map ( Map ) -import qualified Data.Map as Map - - --- | GhostScript version that the aliases were derived from. --- -ghostscript_version :: String -ghostscript_version = "gs8.54" - -type GSFontMap = Map String (String, FilePath) - - --- | Get the @.afm@ metrics file. --- --- Note this return only the file name and not the path to it. --- The full path must be resolved in client code. --- -gsMetricsFile :: GSFontMap -> String -> Maybe FilePath -gsMetricsFile mp name = fmap snd $ Map.lookup name mp - --- | Get the GhostScript font name alias. --- -gsFontAlias :: GSFontMap -> String -> Maybe String -gsFontAlias mp name = fmap fst $ Map.lookup name mp - --- | Map from PostScript font name to the corresponding --- GhostScript name and file. --- -core14_alias_table :: GSFontMap -core14_alias_table = Map.fromList $ - [ ("Courier", ("NimbusMonL-Regu", "n022003l.afm")) - , ("Courier-Oblique", ("NimbusMonL-ReguObli", "n022023l.afm")) - , ("Courier-Bold", ("NimbusMonL-Bold", "n022004l.afm")) - , ("Courier-BoldOblique", ("NimbusMonL-BoldObli", "n022024l.afm")) - - , ("Helvetica", ("NimbusSanL-Regu", "n019003l.afm")) - , ("Helvetica-Oblique", ("NimbusSanL-ReguItal", "n019023l.afm")) - , ("Helvetica-Bold", ("NimbusSanL-Bold", "n019004l.afm")) - , ("Helvetica-BoldOblique", ("NimbusSanL-BoldItal", "n019024l.afm")) - - , ("Times-Roman", ("NimbusRomNo9L-Regu", "n021003l.afm")) - , ("Times-Italic", ("NimbusRomNo9L-ReguItal", "n021023l.afm")) - , ("Times-Bold", ("NimbusRomNo9L-Medi", "n021004l.afm")) - , ("Times-BoldItalic", ("NimbusRomNo9L-MediItal", "n021024l.afm")) - - , ("Symbol", ("StandardSymL", "s050000l.afm")) - - , ("ZapfDingbats", ("Dingbats", "d050000l.afm")) - ] - diff --git a/src/Wumpus/Basic/FontLoader/GSLoader.hs b/src/Wumpus/Basic/FontLoader/GSLoader.hs deleted file mode 100644 --- a/src/Wumpus/Basic/FontLoader/GSLoader.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.FontLoader.GSLoader --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Font loader for GhostScript glyph metrics. --- --- Use this loader if you have GhostScript installed and you want --- to use the (AFM v2.0) metrics that are distributed with --- GhostScript. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.FontLoader.GSLoader - ( - - module Wumpus.Basic.FontLoader.Base - , module Wumpus.Basic.FontLoader.AfmV2Parser - - , loadGSMetrics - , gsFontLoader - - - - ) where - -import Wumpus.Basic.FontLoader.AfmV2Parser -import Wumpus.Basic.FontLoader.Base -import Wumpus.Basic.FontLoader.GSFontMap -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core - -import Data.Maybe - - -loadGSMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics -loadGSMetrics font_dir_path ns = - loadBaseGlyphMetrics (gsFontLoader font_dir_path) ns - - -gsFontLoader :: FilePath -> FontLoader AfmUnit -gsFontLoader font_dir_path = FontLoader - { unit_scale_fun = afmUnitScale - , path_to_font_dir = font_dir_path - , file_name_locator = buildName - , font_parser = parseAfmV2File - , post_process = buildGlyphMetricsTable bbox (V2 600 0) 1000 - } - where - buildName :: FontName -> FilePath - buildName font = fromMaybe font $ gsMetricsFile core14_alias_table font - - bbox = BBox (P2 (-23) (-250)) (P2 715 805) - - diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Import shim for @Wumpus.Basic.Graphic@ modules. --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic - ( - module Wumpus.Basic.Graphic.Anchors - , module Wumpus.Basic.Graphic.Base - , module Wumpus.Basic.Graphic.ContextFunction - , module Wumpus.Basic.Graphic.Drawing - , module Wumpus.Basic.Graphic.DrawingContext - , module Wumpus.Basic.Graphic.GlyphMetrics - , module Wumpus.Basic.Graphic.GraphicOperations - , module Wumpus.Basic.Graphic.GraphicTypes - , module Wumpus.Basic.Graphic.Query - , module Wumpus.Basic.Graphic.ScalingContext - , module Wumpus.Basic.Graphic.TraceDrawing - ) where - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.Anchors -import Wumpus.Basic.Graphic.ContextFunction -import Wumpus.Basic.Graphic.Drawing -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.GlyphMetrics -import Wumpus.Basic.Graphic.GraphicOperations -import Wumpus.Basic.Graphic.GraphicTypes -import Wumpus.Basic.Graphic.Query -import Wumpus.Basic.Graphic.ScalingContext -import Wumpus.Basic.Graphic.TraceDrawing diff --git a/src/Wumpus/Basic/Graphic/Anchors.hs b/src/Wumpus/Basic/Graphic/Anchors.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/Anchors.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.Anchors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Anchor points on shapes. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.Anchors - ( - - -- * Anchors - CenterAnchor(..) - , CardinalAnchor(..) - , CardinalAnchor2(..) - , RadialAnchor(..) - - -- * Extended anchor points - , northwards - , southwards - , eastwards - , westwards - , northeastwards - , southeastwards - , southwestwards - , northwestwards - - , radialConnectorPoints - - ) where - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -class CenterAnchor t where - center :: DUnit t ~ u => t -> Point2 u - --- | Note - in TikZ cardinal anchors are not necessarily at the --- equivalent radial position, for instance reactangle north-east --- is the top-right corner whether or not this is incident at --- 45deg. --- -class CardinalAnchor t where - north :: DUnit t ~ u => t -> Point2 u - south :: DUnit t ~ u => t -> Point2 u - east :: DUnit t ~ u => t -> Point2 u - west :: DUnit t ~ u => t -> Point2 u - -class CardinalAnchor2 t where - northeast :: DUnit t ~ u => t -> Point2 u - southeast :: DUnit t ~ u => t -> Point2 u - southwest :: DUnit t ~ u => t -> Point2 u - northwest :: DUnit t ~ u => t -> Point2 u - - --- | Anchor on a border that can be identified with and angle. --- -class RadialAnchor t where - radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u - - -extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u -extendPtDist d p1 p2 = let v = pvec p1 p2 - ang = direction v - len = vlength v - in p1 .+^ avec ang (len+d) - - - -northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -northwards u a = extendPtDist u (center a) (north a) - - -southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -southwards u a = extendPtDist u (center a) (south a) - -eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -eastwards u a = extendPtDist u (center a) (east a) - -westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -westwards u a = extendPtDist u (center a) (west a) - - -northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -northeastwards u a = extendPtDist u (center a) (northeast a) - - -southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -southeastwards u a = extendPtDist u (center a) (southeast a) - -southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -southwestwards u a = extendPtDist u (center a) (southwest a) - -northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -northwestwards u a = extendPtDist u (center a) (northwest a) - - --------------------------------------------------------------------------------- - -radialConnectorPoints :: ( Real u, Floating u - , CenterAnchor t1, RadialAnchor t1 - , CenterAnchor t2, RadialAnchor t2 - , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) - => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) - where - theta = direction $ pvec (center a) (center b) - - --------------------------------------------------------------------------------- --- Instances - -instance Fractional u => CenterAnchor (BoundingBox u) where - center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y - where - x = xl+0.5*(xr-xl) - y = ylo+0.5*(yhi-ylo) - - -instance Fractional u => CardinalAnchor (BoundingBox u) where - north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi - south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo - east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) - west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) - - -instance Fractional u => CardinalAnchor2 (BoundingBox u) where - northeast (BBox _ ur) = ur - southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo - southwest (BBox ll _) = ll - northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi - diff --git a/src/Wumpus/Basic/Graphic/Base.hs b/src/Wumpus/Basic/Graphic/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/Base.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.Base --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- The common base drawing objects in Wumpus-Basic - a --- semigroup class, monad classes (TraceM analogue to Writer, --- DrawingCtxM analogue to Reader), a wrapped Hughes list of --- primitives. --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.Base - ( - - -- A semigroup class. - OPlus(..) - , oconcat - , anterior - , superior - - -- * Alignment. - , HAlign(..) - , VAlign(..) - - -- * Drawing monads. - , MonUnit - , TraceM(..) - , DrawingCtxM(..) - , asksDC - - , PointSupplyM(..) - - - -- * Base types - , HPrim - , hprimToList - , singleH - - , PrimGraphic - , getPrimGraphic - , primGraphic - , collectH - - ) where - -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Utils.HList - -import Wumpus.Core -- package: wumpus-core - - -import Control.Applicative -import Data.Monoid - - - -infixr 6 `oplus` - --- | A Semigroup class. --- -class OPlus t where - oplus :: t -> t -> t - -oconcat :: OPlus t => t -> [t] -> t -oconcat t = step t - where - step ac [] = ac - step ac (x:xs) = step (ac `oplus` x) xs - -anterior :: OPlus t => t -> (t -> t) -anterior a = (a `oplus`) - -superior :: OPlus t => t -> (t -> t) -superior a = (`oplus` a) - - - - -instance Ord u => OPlus (BoundingBox u) where - oplus = boundaryUnion - -instance OPlus (Primitive u) where - a `oplus` b = primGroup [a,b] - -instance (OPlus a, OPlus b) => OPlus (a,b) where - (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b') - - -instance OPlus a => OPlus (r -> a) where - f `oplus` g = \x -> f x `oplus` g x - --- The functional instance (r -> a) also covers (r1 -> r2 -> a), --- (r1 -> r2 -> r3 -> a) etc. - - --------------------------------------------------------------------------------- - --- Alignment - --- | Horizontal alignment - align to the top, center or bottom. -data HAlign = HTop | HCenter | HBottom - deriving (Enum,Eq,Ord,Show) - --- | Vertical alignment - align to the left, center or bottom. -data VAlign = VLeft | VCenter | VRight - deriving (Enum,Eq,Ord,Show) - - - - --------------------------------------------------------------------------------- --- Monadic drawing - --- | DUnit is always for fully saturated type constructors, so --- (seemingly) an equivalent type family is needed for monads. - -type family MonUnit m :: * - - --- | Collect elementary graphics as part of a larger drawing. --- --- TraceM works much like a writer monad. --- -class Monad m => TraceM (m :: * -> *) where - trace :: HPrim (MonUnit m) -> m () - -class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where - askDC :: m DrawingContext - localize :: (DrawingContext -> DrawingContext) -> m a -> m a - - --- | Project a value out of a context. --- -asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a -asksDC f = askDC >>= (return . f) - - - --- | A monad that supplies points, e.g. a turtle monad. --- -class Monad m => PointSupplyM (m :: * -> *) where - position :: u ~ MonUnit m => m (Point2 u) - - --------------------------------------------------------------------------------- --- Lists of primitives... - --- | Graphics objects, even simple ones (line, arrow, dot) might --- need more than one primitive (path or text label) for their --- construction. Hence, the primary representation that all the --- others are built upon must support /concatenation/ of --- primitives. --- --- Wumpus-Core has a type Picture - made from one or more --- Primitives - but Pictures include support for affine frames. --- For drawing many simple graphics (dots, connector lines...) --- that do not need individual affine transformations this is a --- penalty. A list of Primitives is therefore more suitable --- representation, and a Hughes list which supports --- efficient concatenation is wise. --- -newtype HPrim u = HPrim { getHPrim :: H (Primitive u) } - --- Note - only a Monoid instance for HPrim - they cannot be --- shown, fmapped etc. - -instance Monoid (HPrim u) where - mempty = HPrim emptyH - ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb - - -hprimToList :: HPrim u -> [Primitive u] -hprimToList = toListH . getHPrim - - -singleH :: Primitive u -> HPrim u -singleH = HPrim . wrapH - --- As of version 0.36.0, Wumpus-Core supports grouping primitives --- together (a common operation in vector drawing editors). --- --- For Wumpus-Basic this means e.g. a line with arrowheads can --- still be a primitive. --- --- Still, we wrap Primitive as a newtype... --- - -newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u } - deriving (Eq,Show) - -type instance DUnit (PrimGraphic u) = u - -instance OPlus (PrimGraphic u) where - oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b - - --- Affine transformations - -instance (Real u, Floating u) => Rotate (PrimGraphic u) where - rotate ang = PrimGraphic . rotate ang . getPrimGraphic - - -instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where - rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic - - -instance Num u => Scale (PrimGraphic u) where - scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic - - -instance Num u => Translate (PrimGraphic u) where - translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic - - -primGraphic :: Primitive u -> PrimGraphic u -primGraphic = PrimGraphic - -collectH :: PrimGraphic u -> HPrim u -collectH = singleH . getPrimGraphic - diff --git a/src/Wumpus/Basic/Graphic/ContextFunction.hs b/src/Wumpus/Basic/Graphic/ContextFunction.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/ContextFunction.hs +++ /dev/null @@ -1,718 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.ContextFunction --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- The primary drawing type and base combinators to manipulate it. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.ContextFunction - ( - - CF - - , LocCF - , LocThetaCF - , ConnectorCF - , DLocCF - , DLocThetaCF - , DConnectorCF - - - - -- * Run functions - , runCF - - -- * Extractors - , drawingCtx - , queryCtx - , locCtx - , locPoint - , locThetaCtx - , locThetaPoint - , locThetaAng - , connCtx - , connStart - , connEnd - - -- * Reducers - , unLoc - , unTheta - , unLocTheta - , unConnector - - , unCF1 - , unCF2 - - -- * Combinators - , wrap - , wrap1 - , wrap2 - - , promote1 - , promote2 - - , raise - , raise1 - , raise2 - - , static1 - , static2 - , dblstatic - - , bind - , bind1 - , bind2 - - - , situ1 - , situ2 - - , apply - , apply1 - , apply2 - - -- * Pre-transformers - , prepro1 - , prepro2 - , prepro2a - , prepro2b - - -- * Post-transformers - , postpro - , postpro1 - , postpro2 - - -- * Post-combiners - , postcomb - , postcomb1 - , postcomb2 - - , accumulate1 - , accumulate2 - - - ) where - --- import Wumpus.Basic.Graphic.Anchors -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.DrawingContext - -import Wumpus.Core -- package: wumpus-core - - -import Control.Applicative -import Data.Monoid - - --------------------------------------------------------------------------------- --- - --- | Most drawing operations in Wumpus-Basic have an implicit --- /graphics state/ the @DrawingContext@, so the most primitive --- building block is a function from the DrawingContext to some --- polymorphic answer. --- --- This functional type is represented concretely as the initials --- @CF@ for /contextual function/. --- --- > CF :: DrawingContext -> a --- -newtype CF a = CF { getCF :: DrawingContext -> a } - - -type LocCF u a = CF (Point2 u -> a) - -type LocThetaCF u a = LocCF u (Radian -> a) - -type ConnectorCF u a = LocCF u (Point2 u -> a) - - - -type DLocCF a = LocCF Double a -type DLocThetaCF a = LocThetaCF Double a -type DConnectorCF a = ConnectorCF Double a - - - --------------------------------------------------------------------------------- --- Drawing instances - -instance Functor CF where - fmap f ma = CF $ \ctx -> f $ getCF ma ctx - - -instance OPlus a => OPlus (CF a) where - fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx - --- The monoid instance seems sensible... --- -instance Monoid a => Monoid (CF a) where - mempty = CF $ \_ -> mempty - fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx - --- Applicative - -instance Applicative CF where - pure a = CF $ \_ -> a - mf <*> ma = CF $ \ctx -> let f = getCF mf ctx - a = getCF ma ctx - in f a --- Monad - -instance Monad CF where - return a = CF $ \_ -> a - ma >>= k = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx - - -instance DrawingCtxM CF where - askDC = CF $ \ctx -> ctx - localize upd df = CF $ \ctx -> getCF df (upd ctx) - - - - --------------------------------------------------------------------------------- --- Run functions - - - --- | Run a /CF/ (context function) with the supplied /DrawingContext/. --- -runCF :: DrawingContext -> CF a -> a -runCF ctx df = getCF df ctx - - --------------------------------------------------------------------------------- --- extractors - --- | Extract the drawing context from a CtxFun. --- --- > (ctx -> ctx) --- -drawingCtx :: CF DrawingContext -drawingCtx = CF $ \ctx -> ctx - --- | Apply the projection function to the drawing context. --- --- > (ctx -> a) -> (ctx -> a) --- -queryCtx :: (DrawingContext -> a) -> CF a -queryCtx f = CF $ \ctx -> f ctx - - --- | Extract the drawing context from a LocCF. --- --- > (ctx -> pt -> ctx) --- -locCtx :: LocCF u DrawingContext -locCtx = CF $ \ctx _ -> ctx - --- | Extract the /start/ point from a LocCF. --- --- > (ctx -> pt -> pt) --- -locPoint :: LocCF u (Point2 u) -locPoint = CF $ \_ pt -> pt - - --- | Extract the drawing context from a LocThetaCF. --- --- > (ctx -> pt -> ang -> ctx) --- -locThetaCtx :: LocThetaCF u DrawingContext -locThetaCtx = CF $ \ctx _ _ -> ctx - - --- | Extract the /start/ point from a LocThetaCF. --- --- > (ctx -> pt -> ang -> pt) --- -locThetaPoint :: LocThetaCF u (Point2 u) -locThetaPoint = CF $ \_ pt _ -> pt - --- | Extract the angle from a LocThetaCF. --- --- > (ctx -> pt -> ang -> ang) --- -locThetaAng :: LocThetaCF u Radian -locThetaAng = CF $ \_ _ ang -> ang - --- | Extract the drawing context from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> ctx) --- -connCtx :: ConnectorCF u DrawingContext -connCtx = CF $ \ctx _ _ -> ctx - --- | Extract the start point from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> pt1) --- -connStart :: ConnectorCF u (Point2 u) -connStart = CF $ \_ pt _ -> pt - --- | Extract the end point from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> pt2) --- -connEnd :: ConnectorCF u (Point2 u) -connEnd = CF $ \_ _ pt -> pt - - --------------------------------------------------------------------------------- --- /Reducers/ - --- | This is unCF1 at a specific type. --- -unLoc :: Point2 u -> LocCF u a -> CF a -unLoc pt mf = CF $ \ctx -> getCF mf ctx pt - -unTheta :: Radian -> LocThetaCF u a -> LocCF u a -unTheta theta mf = CF $ \ctx pt -> getCF mf ctx pt theta - -unLocTheta :: Point2 u -> Radian -> LocThetaCF u a -> CF a -unLocTheta pt theta mf = CF $ \ctx -> getCF mf ctx pt theta - -unConnector :: Point2 u -> Point2 u -> ConnectorCF u a -> CF a -unConnector p0 p1 mf = CF $ \ctx -> getCF mf ctx p0 p1 - - -unCF1 :: r1 -> CF (r1 -> a) -> CF a -unCF1 a mf = CF $ \ctx -> getCF mf ctx a - -unCF2 :: r1 -> r2 -> CF (r1 -> r2 -> a) -> CF a -unCF2 a b mf = CF $ \ctx -> getCF mf ctx a b - - - - --------------------------------------------------------------------------------- --- Combinators - --- | Lift a pure value into a Context functional. The --- DrawingContext is ignored. --- --- > ans -> (ctx -> ans) --- --- Without any other arguments, this is the same as the 'raise' --- combinator for raising into the Context functional. However, --- the /arity family/ of @wrap@ combinators is different. --- -wrap :: a -> CF a -wrap = pure - - --- | Lift a pure value into a Context functional, ignoring both --- the DrawingContext and the /static/ argument, e.g. this would --- ingnore start point for a @LocDrawing@). --- --- > ans -> (ctx -> r1 -> ans) --- -wrap1 :: a -> CF (r1 -> a) -wrap1 = pure . pure - --- | Lift a pure value into a Context functional, ignoring both --- the DrawingContext and the two /static/ arguments, e.g. this --- would ignore the start point and angle for a @LocThetaDrawing@. --- --- > ans -> (ctx -> r1 -> r2 -> ans) --- -wrap2 :: a -> CF (r1 -> r2 -> a) -wrap2 = pure . pure . pure - - - --- | Promote a Context functional with one argument /outside/ --- the functional so that the the argument is /inside/ the --- Context functional. --- --- The type signature is probably more illustrative of the --- operation than this description: --- --- > (r1 -> ctx -> ans) -> (ctx -> r1 -> ans) --- --- This is essentially the @cardinal@ combinator - @flip@ --- in Haskell. --- -promote1 :: (r1 -> CF ans) -> CF (r1 -> ans) -promote1 f = CF $ \ctx a -> getCF (f a) ctx - - --- | Promote a Context functional with two arguments /outside/ --- the functional so that the two arguments are /inside/ the --- Context functional. --- --- The type signature is probably more illustrative of the --- operation than this description: --- --- > (r1 -> r2 -> ctx -> ans) -> (ctx -> r1 -> r2 -> ans) --- -promote2 :: (r1 -> r2 -> CF ans) -> CF (r1 -> r2 -> ans) -promote2 df = CF $ \ctx a b -> getCF (df a b) ctx - - --- | Lift a value into a Context functional. --- --- > ans -> (ctx -> ans) --- --- Essentially this is the @kestrel@ combinator - @const@ in --- Haskell, though due to newtype wrapping it is @pure@ from the --- Applicative class. --- -raise :: a -> CF a -raise = pure - - --- | Lift a one argument function into a Context functional. --- --- This is Applicative\'s 'pure' with a specialized type --- signature. --- -raise1 :: (r1 -> ans) -> CF (r1 -> ans) -raise1 = pure - --- | Lift a two argument function into a Context functional. --- --- This is Applicative\'s 'pure' with a specialized type --- signature. --- -raise2 :: (r1 -> r2 -> ans) -> CF (r1 -> r2 -> ans) -raise2 = pure - - --- | Extend the arity of a /Context functional/, the original --- function is oblivious to the added argument. --- --- Typically this combinator is used to take a @Graphic@ to a --- @LocGraphic@ ingoring the start point (figuratively a @Graphic@ --- is not /coordinate free/). --- --- > (ctx -> ans) -> (ctx -> r1 -> ans) --- --- This was called the J-combinator by Joy, Rayward-Smith and --- Burton (ref. /Compling Functional Languages/ by Antoni --- Diller), however it is not the J combinator commonly in the --- Literature. --- -static1 :: CF ans -> CF (r1 -> ans) -static1 df = CF $ \ctx _ -> getCF df ctx - - --- | Extend the arity of a /Context functional/, the original --- function is oblivious to the added argument. --- --- Typically this combinator is used to take a @LocGraphic@ to a --- @LocThetaGraphic@ ingoring the angle of direction. --- --- > (ctx -> r1 -> ans) -> (ctx -> r1 -> r2 -> ans) --- --- This was called the J-Prime combinator by Joy, Rayward-Smith --- and Burton (ref. /Compling Functional Languages/ by Antoni --- Diller). --- -static2 :: CF (r1 -> ans) -> CF (r1 -> r2 -> ans) -static2 df = CF $ \ctx a _ -> getCF df ctx a - - --- | Complementary combinator to static2. --- --- This combinator raises a function two levels rather than one. --- --- > (ctx -> ans) -> (ctx -> r1 -> r2 -> ans) --- -dblstatic :: CF ans -> CF (r1 -> r2 -> ans) -dblstatic df = CF $ \ctx _ _ -> getCF df ctx - - -infixl 1 `bind`, `bind1`, `bind2` - - --- | Supply the output from the first function to the second --- function. --- --- This is just monadic bind - specialized to the CF functional --- type. --- --- > (ctx -> a) -> (a -> ctx -> ans) -> (ctx -> ans) --- -bind :: CF a -> (a -> CF ans) -> CF ans -bind df dk = CF $ \ctx -> let z = getCF df ctx in getCF (dk z) ctx - - --- | Supply the output from the first function to the second --- function, /sharing/ the drawing context and the static --- argument @r1@. --- --- > (ctx -> r1 -> a) -> (a -> ctx -> -> r1 -> ans) -> (ctx -> r1 -> ans) --- -bind1 :: CF (r1 -> a) -> (a -> CF (r1 -> ans)) -> CF (r1 -> ans) -bind1 df dk = CF $ \ctx a -> let z = getCF df ctx a in getCF (dk z) ctx a - --- | Supply the output from the first function to the second --- function, /sharing/ the DrawingContext and the two static --- arguments @r1@ and @r2@. --- --- > (ctx -> r1 -> r2 -> a) -> (a -> ctx -> -> r1 -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans) --- -bind2 :: CF (r1 -> r2 -> a) -> (a -> CF (r1 -> r2 -> ans)) - -> CF (r1 -> r2 -> ans) -bind2 df dk = CF $ \ctx a b -> - let z = getCF df ctx a b in getCF (dk z) ctx a b - - --- idstar :: (r1 -> r2 -> ans) -> r1 -> r2 -> ans - --- | Supply the arguments to an arity 1 Context functional so it --- can be /situated/. Typically this is supplying the start point --- to a @LocGraphic@ or @LocImage@. --- --- > (ctx -> r1 -> ans) -> r1 -> (ctx -> ans) --- --- This is equivalent to the @id**@ combinator. --- -situ1 :: CF (r1 -> ans) -> r1 -> CF ans -situ1 df a = CF $ \ctx -> getCF df ctx a - - - --- | Supply the arguments to an arity 2 Conterxt functional so --- it can be /situated/. Typically this is supplying the start --- point and angle to a @LocThetaGraphic@ or @LocThetaImage@. --- --- > (ctx -> r1 -> r2 -> ans) -> r1 -> r2 -> (ctx -> ans) --- -situ2 :: CF (r1 -> r2 -> ans) -> r1 -> r2 -> CF ans -situ2 df a b = CF $ \ctx -> getCF df ctx a b - - --- | Apply the the functional produced by the first argument to --- the value produced by the second. --- --- > (ctx -> a -> ans) -> (ctx -> a) -> (ctx -> ans) --- -apply :: CF (a -> ans) -> CF a -> CF ans -apply df da = CF $ \ctx -> getCF df ctx (getCF da ctx) - - --- | Apply the the functional produced by the first argument to --- the value produced by the second /sharing/ the context of the --- first functional argument @r1@ (usually a Point2) as well as --- the DrawingContext. --- --- > (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) --- -apply1 :: CF (r1 -> a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans) -apply1 df da = CF $ \ctx a -> getCF df ctx a (getCF da ctx a) - - --- | Apply the the functional produced by the first argument to --- the value produced by the second /sharing/ the context of the --- two functional arguments @r1@ and @r2@ as well as the --- DrawingContext. --- --- > (ctx -> r1 -> r2 -> a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) --- -apply2 :: CF (r1 -> r2 -> a -> ans) -> CF (r1 -> r2 -> a) - -> CF (r1 -> r2 -> ans) -apply2 df da = CF $ \ctx a b -> getCF df ctx a b (getCF da ctx a b) - - --------------------------------------------------------------------------------- --- Pre-transformers - --- The primary /pre-transformation/ function is @localize@, here --- it is without the newtype wrapper or the specific types: --- --- > fn :: (ctx -> ctx) -> (ctx -> ans) -> ctx -> ans --- > fn f g = \ctx -> g (f ctx) --- --- This a a type restricted version of reverse appliction, the T --- combinator sometimes called queer, sometings @(#)@ in Haskell. --- In Wumpus-Basic it is @localize@ which is overloaded for the --- CF newtype and TraceDrawing monads. --- --- > localizeDR :: (DrawingContext -> DrawingContext) -> CF a -> CF a --- > localizeDR = localize --- --- Figuartively speaking this is an opposite of the fmap function --- instance. Instead of (post-) transforming the output, ... --- (pre-) transforms the input. --- --- Due to Context functionals being stacked in a particular way --- @localize@ always pre-transforms the DrawingContext regardless --- of the arity of the functional: --- --- > localizeDR2 :: (DrawingContext -> DrawingContext) --- > -> CF (r -> a) -> CF (r -> a) --- > localizeDR2 = localize --- - - --- | Apply the static argument transfomer @(r1 -> a)@ to the --- static argument /before/ applying the Context functional. --- --- > (r1 -> a) -> (ctx -> a -> ans) -> (ctx -> r1 -> ans) --- -prepro1 :: (r1 -> a) -> CF (a -> ans) -> CF (r1 -> ans) -prepro1 f mf = CF $ \ctx a -> getCF mf ctx (f a) - - --- | Apply the static argument transfomers to their respective --- static arguments /before/ applying the Context functional. --- --- > (r1 -> a) -> (r2 -> b) -> (ctx -> a -> b -> ans) -> (ctx -> r1 -> r2 -> ans) --- -prepro2 :: (r1 -> a) -> (r2 -> b) -> CF (a -> b -> ans) -> CF (r1 -> r2 -> ans) -prepro2 f g mf = CF $ \ctx a b -> getCF mf ctx (f a) (g b) - - --- | Apply the static argument transfomer to the first static --- argument of a two static argument functional /before/ applying --- the Context functional. --- --- > (r1 -> a) -> (ctx -> a -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans) --- -prepro2a :: (r1 -> a) -> CF (a -> r2 -> ans) -> CF (r1 -> r2 -> ans) -prepro2a f mf = CF $ \ctx a b -> getCF mf ctx (f a) b - --- | Apply the static argument transfomer to the second static --- argument of a two static argument functional /before/ applying --- the Context functional. --- --- > (r2 -> a) -> (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> r2 -> ans) --- -prepro2b :: (r2 -> a) -> CF (r1 -> a -> ans) -> CF (r1 -> r2 -> ans) -prepro2b f mf = CF $ \ctx a b -> getCF mf ctx a (f b) - ------------------------------------------------------------------------------- --- Post-transfomers - --- | Apply the post-transformer to the result of the Context --- functional. --- --- > (a -> ans) -> (ctx -> a) -> (ctx -> ans) --- -postpro :: (a -> ans) -> CF a -> CF ans -postpro = fmap - --- | Apply the post-transformer to the result of the Context --- functional. Version for one static argument. --- --- Note - the DrawingContext is always present so it is never --- counted as a static argument. --- --- > (a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) --- -postpro1 :: (a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans) -postpro1 = postpro . fmap - --- | Apply the post-transformer to the result of the Context --- functional. Version for two static arguments. --- --- Note - the DrawingContext is always present so it is never --- counted as a static argument. --- --- --- > (a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) --- -postpro2 :: (a -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> ans) -postpro2 = postpro1 . fmap - - --------------------------------------------------------------------------------- --- Post-combiners - --- | Combine the results of the two Context Functions with the --- supplied operator. --- --- > (a -> b -> ans) -> (ctx -> a) -> (ctx -> b) -> (ctx -> ans) --- -postcomb :: (a -> b -> ans) -> CF a -> CF b -> CF ans -postcomb op df dg = CF $ \ctx -> getCF df ctx `op` getCF dg ctx - --- | Combine the results of the two one-static-argument Context --- Functions with the supplied operator. --- --- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans) --- -postcomb1 :: (a -> b -> c) -> CF (r1 -> a) -> CF (r1 -> b) -> CF (r1 -> c) -postcomb1 op df dg = CF $ \ctx a -> getCF df ctx a `op` getCF dg ctx a - - --- | Combine the results of the two two-static-argument Context --- Functions with the supplied operator. --- --- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans) --- -postcomb2 :: (a -> b -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> b) - -> CF (r1 -> r2 -> ans) -postcomb2 op df dg = CF $ \ctx a b -> - getCF df ctx a b `op` getCF dg ctx a b - - - --- | Iteration combinator - the initial argument @s1@ is not --- shared bewteen the drawings. --- --- Evaluate the first Context Function with the drawing context --- and the /initial state/ @st0@. The result of the evaluation is --- a new /state/ @st1@ and and answer @a1@. --- --- Evaluate the second Context Function with the drawing context --- and the new state @st1@, producing a new state @s2@ and an --- answer @a2@. --- --- Return the result of combining the answers with --- @op :: (ans -> ans -> ans)@ and the second state @s2@. --- --- @ (ans -> ans -> ans) -> (ctx -> s1 -> (s1,ans)) @ --- @ -> (ctx -> s1 -> (s1,ans)) -> (ctx -> s1 -> (s1,ans)) @ --- --- This models chaining start points together, which is the model --- PostScript uses for text output when succesively calling the --- @show@ operator. --- -accumulate1 :: (ans -> ans -> ans) - -> CF (s1 -> (s1,ans)) -> CF (s1 -> (s1,ans)) - -> CF (s1 -> (s1,ans)) -accumulate1 op f g = CF $ \ctx s -> - let (s1,a1) = getCF f ctx s - (s2,a2) = getCF g ctx s1 - in (s2, a1 `op` a2) - - - --- | Arity two version of accumulate1 - this is not expected to be --- useful! --- --- @ (ans -> ans -> ans) -> (ctx -> s1 -> -> s2 (s1,s2,ans)) @ --- @ -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @ --- @ -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @ --- -accumulate2 :: (ans -> ans -> ans) - -> CF (s1 -> s2 -> (s1,s2,ans)) - -> CF (s1 -> s2 -> (s1,s2,ans)) - -> CF (s1 -> s2 -> (s1,s2,ans)) -accumulate2 op f g = CF $ \ctx s t -> - let (s1,t1,a1) = getCF f ctx s t - (s2,t2,a2) = getCF g ctx s1 t1 - in (s2, t2, a1 `op` a2) - - - - - --------------------------------------------------------------------------------- -{- -instance CenterAnchor a => CenterAnchor (CF a) where - center = postpro center --} diff --git a/src/Wumpus/Basic/Graphic/Drawing.hs b/src/Wumpus/Basic/Graphic/Drawing.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/Drawing.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.Drawing --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- A Drawing object. --- --- This is the corresponding type to Picture in the Wumpus-Core. --- --- Drawing is a function from the DrawingContext to a Picture. --- Internally the result is actually a (Maybe Picture) and not a --- Picture, this is a trick to promote the extraction from --- possibly empty drawings (created by TraceDrawing) to the --- top-level of the type hierarchy where client code can deal --- with empty drawings explicitly (empty Pictures cannot be --- rendered by Wumpus-Core). --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.Drawing - ( - - Drawing - , DDrawing - , runDrawing - , runDrawingU - , drawTracing - - , clipDrawing - , modifyDrawing - , drawingConcat - - ) where - -import Wumpus.Basic.Graphic.ContextFunction -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.TraceDrawing - -import Wumpus.Core -- package: wumpus-core - -newtype Drawing u = Drawing { getDrawing :: CF (Maybe (Picture u)) } - -type DDrawing = Drawing Double - - -type instance DUnit (Drawing u) = u - - - - -runDrawing :: DrawingContext -> Drawing u -> Maybe (Picture u) -runDrawing ctx drw = runCF ctx (getDrawing drw) - - -runDrawingU :: DrawingContext -> Drawing u -> Picture u -runDrawingU ctx df = maybe fk id $ runDrawing ctx df - where - fk = error "runDrawingU - empty Drawing." - - - -drawTracing :: (Real u, Floating u, FromPtSize u) - => TraceDrawing u a -> Drawing u -drawTracing mf = Drawing $ - drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) ) - - --- Note - cannot get an answer from a TraceDrawing with this --- Drawing type. There is nowhere to put the answer in the type. --- --- If the type was extended: --- --- > newtype Drawing u a = Drawing { getDrawing :: CF (a, Maybe (Picture u))) } --- --- It would make things difficult for the drawing composition --- operators. @a@ could be monoidial but are there any types of --- a where this would be useful (rather than just making things --- more complicated)? --- --------------------------------------------------------------------------------- - -clipDrawing :: (Num u, Ord u) => (PrimPath u) -> Drawing u -> Drawing u -clipDrawing cpath = modifyDrawing (clip cpath) - - -modifyDrawing :: (Picture u -> Picture u) -> Drawing u -> Drawing u -modifyDrawing pf = Drawing . postpro (fmap pf) . getDrawing - -instance (Real u, Floating u) => Rotate (Drawing u) where - rotate ang = modifyDrawing (rotate ang) - -instance (Real u, Floating u) => RotateAbout (Drawing u) where - rotateAbout r pt = modifyDrawing (rotateAbout r pt) - -instance (Num u, Ord u) => Scale (Drawing u) where - scale sx sy = modifyDrawing (scale sx sy) - -instance (Num u, Ord u) => Translate (Drawing u) where - translate dx dy = modifyDrawing (translate dx dy) - - - - - -drawingConcat :: (Picture u -> Picture u -> Picture u) - -> Drawing u -> Drawing u -> Drawing u -drawingConcat op a b = Drawing $ mbpostcomb op (getDrawing a) (getDrawing b) - - - -mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a) -mbpostcomb op = postcomb fn - where - fn (Just a) (Just b) = Just $ a `op` b - fn a Nothing = a - fn Nothing b = b diff --git a/src/Wumpus/Basic/Graphic/DrawingContext.hs b/src/Wumpus/Basic/Graphic/DrawingContext.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/DrawingContext.hs +++ /dev/null @@ -1,324 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.DrawingContext --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Drawing attributes --- --- \*\* WARNING \*\* - this module needs systematic naming --- schemes both for update functions (primaryColour, ...) and --- for synthesized selectors (e.g. lowerxHeight). The current --- names will change. --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.DrawingContext - ( - - -- * Drawing context - DrawingContext(..) - , DrawingContextF - - , standardContext - , metricsContext - - , default_drawing_context - - -- * Modifiers - -- ** Line widths - , thick - , ultrathick - , thin - - -- ** Line caps - , capButt - , capRound - , capSquare - - -- ** Line joins - , joinMiter - , joinRound - , joinBevel - - -- ** Dash Pattern - , dashPattern - , unit_dash_pattern - , phase - , dphase - , doublegaps - , doubledashes - - -- * Font properties - , fontsize - , fontface - - -- * Font / mark drawing size - , doublesize - , halfsize - - -- * Colour - , swapColours - , bothStrokeColour - , bothFillColour - , strokeColour - , fillColour - - -- * Glyph metrics - , withFontMetrics - - - ) where - - -import Wumpus.Basic.Graphic.GlyphMetrics - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.StandardEncoding - -import Control.Applicative -import qualified Data.Map as Map -import Data.Maybe - - -data DrawingContext = DrawingContext - { glyph_tables :: BaseGlyphMetrics - , fallback_metrics :: GlyphMetrics - , stroke_props :: StrokeAttr - , font_props :: FontAttr - , stroke_colour :: RGBi -- also text colour... - , fill_colour :: RGBi - , line_spacing_factor :: Double - } - --- TODO - hand craft a Show instance - -type DrawingContextF = DrawingContext -> DrawingContext - - -standardContext :: FontSize -> DrawingContext -standardContext sz = - DrawingContext { glyph_tables = Map.empty - , fallback_metrics = monospace_metrics - , stroke_props = default_stroke_attr - , font_props = FontAttr sz wumpus_courier - , stroke_colour = wumpus_black - , fill_colour = wumpus_light_gray - , line_spacing_factor = 1.2 - } - - -metricsContext :: FontSize -> BaseGlyphMetrics -> DrawingContext -metricsContext sz bgm = - DrawingContext { glyph_tables = bgm - , fallback_metrics = monospace_metrics - , stroke_props = default_stroke_attr - , font_props = FontAttr sz wumpus_courier - , stroke_colour = wumpus_black - , fill_colour = wumpus_light_gray - , line_spacing_factor = 1.2 - } - - - - -wumpus_black :: RGBi -wumpus_black = RGBi 0 0 0 - -wumpus_light_gray :: RGBi -wumpus_light_gray = RGBi 200 200 200 - - --- | Courier --- -wumpus_courier :: FontFace -wumpus_courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding - - - -default_drawing_context :: DrawingContext -default_drawing_context = - standardContext (font_size wumpus_default_font) - - -updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF -updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props - -updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF -updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props - - --------------------------------------------------------------------------------- --- line widths - --- Note - some care might be needed if we ever define other unit --- types... - --- std_line_width :: Double --- std_line_width = 1.0 - -thick_line :: Double -thick_line = 2.0 - -ultra_thick_line :: Double -ultra_thick_line = 4.0 - -thin_line :: Double -thin_line = 0.5 - -setLineWidth :: Double -> DrawingContextF -setLineWidth d = updateStrokeProps (\s -> s { line_width = d }) - --- | Set the line width to a /thick/. --- --- Note this context update is /oblivious/ - operationally the --- line width is set to exactly @2.0@. --- -thick :: DrawingContextF -thick = setLineWidth thick_line - -ultrathick :: DrawingContextF -ultrathick = setLineWidth ultra_thick_line - -thin :: DrawingContextF -thin = setLineWidth thin_line - - -setLineCap :: LineCap -> DrawingContextF -setLineCap d = updateStrokeProps (\s -> s { line_cap = d }) - - -capButt :: DrawingContextF -capButt = setLineCap CapButt - -capRound :: DrawingContextF -capRound = setLineCap CapRound - -capSquare :: DrawingContextF -capSquare = setLineCap CapSquare - - -setLineJoin :: LineJoin -> DrawingContextF -setLineJoin d = updateStrokeProps (\s -> s { line_join = d }) - - -joinMiter :: DrawingContextF -joinMiter = setLineJoin JoinMiter - -joinRound :: DrawingContextF -joinRound = setLineJoin JoinRound - -joinBevel :: DrawingContextF -joinBevel = setLineJoin JoinBevel - - --------------------------------------------------------------------------------- - -dashPattern :: DashPattern -> DrawingContextF -dashPattern d = updateStrokeProps (\s -> s { dash_pattern = d }) - -unit_dash_pattern :: DashPattern -unit_dash_pattern = Dash 0 [(1,1)] - --- oblivious -phase :: Int -> DashPattern -> DashPattern -phase _ Solid = Solid -phase i (Dash _ xs) = Dash i xs - --- non-oblivious -dphase :: Int -> DashPattern -> DashPattern -dphase _ Solid = Solid -dphase d (Dash i xs) = Dash (i+d) xs - -doublegaps :: DashPattern -> DashPattern -doublegaps Solid = Solid -doublegaps (Dash i xs) = Dash i (map fn xs) - where - fn (a,b) = (a,2*b) - -doubledashes :: DashPattern -> DashPattern -doubledashes Solid = Solid -doubledashes (Dash i xs) = Dash i (map fn xs) - where - fn (a,b) = (a*2,b) - - --------------------------------------------------------------------------------- - - -fontface :: FontFace -> DrawingContextF -fontface ff = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff) - -fontsize :: Int -> DrawingContextF -fontsize sz = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) - --------------------------------------------------------------------------------- - --- | Set the font size to double the current size, note the font --- size also controls the size of dots, arrowsheads etc. --- -doublesize :: DrawingContextF -doublesize = (\s sz -> fontsize (sz*2) s) <*> (font_size . font_props) - - --- | Set the font size to half the current size, note the font --- size also controls the size of dots, arrowsheads etc. --- --- As fontsize is an integer this is not exact - half size of --- 15pt type is 7pt. --- -halfsize :: DrawingContextF -halfsize = (\s sz -> fontsize (sz `div` 2) s) - <*> (font_size . font_props) - - --------------------------------------------------------------------------------- - -swapColours :: DrawingContextF -swapColours = - (\s a b -> s { stroke_colour = b, fill_colour = a }) - <*> stroke_colour <*> fill_colour - -bothStrokeColour :: DrawingContextF -bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour - -bothFillColour :: DrawingContextF -bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour - - - -strokeColour :: RGBi -> DrawingContextF -strokeColour rgb = \s -> s { stroke_colour = rgb } - - -fillColour :: RGBi -> DrawingContextF -fillColour rgb = \s -> s { fill_colour = rgb } - - - - - --------------------------------------------------------------------------------- --- Glyph metrics - --- These are directly on the DrawingContext /for efficiency/. - - - -withFontMetrics :: (GlyphMetrics -> PtSize -> u) -> DrawingContext -> u -withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = - fn metric_set point_sz - where - ps_name = ps_font_name $ font_face font_stats - point_sz = fromIntegral $ font_size font_stats - metric_set = fromMaybe (fallback_metrics ctx) $ - Map.lookup ps_name (glyph_tables ctx) - - diff --git a/src/Wumpus/Basic/Graphic/GlyphMetrics.hs b/src/Wumpus/Basic/Graphic/GlyphMetrics.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/GlyphMetrics.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.GlyphMetrics --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Data types representing glyph metrics loaded from font files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.GlyphMetrics - ( - - FontName - , CodePoint - , GlyphMetricsTable(..) - , GlyphMetrics(..) - , buildMetrics - , BaseGlyphMetrics - , monospace_metrics - - - ) where - -import Wumpus.Core -- package: wumpus-core - -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map - -type FontName = String - --- | A Unicode code-point. --- -type CodePoint = Int - - --- | NOTE - GlyphMetrics table is parametric on @cu@ - --- /Character unit/ and not on the usual @u@. --- -data GlyphMetricsTable cu = GlyphMetricsTable - { glyph_bounding_box :: BoundingBox cu - , glyph_default_adv_vec :: Vec2 cu - , glyph_adv_vecs :: IntMap.IntMap (Vec2 cu) - , glyph_cap_height :: cu - } - - --- unit_scale_fun :: PtSize -> cu -> u --- - --- afmValue :: FromPtSize u => AfmUnit -> PtSize -> u --- - -data GlyphMetrics = GlyphMetrics - { get_bounding_box :: forall u. FromPtSize u => PtSize -> BoundingBox u - , get_av_lookup :: forall u. FromPtSize u => PtSize -> (CodePoint -> Vec2 u) - , get_cap_height :: forall u. FromPtSize u => PtSize -> u - } - - -type BaseGlyphMetrics = Map.Map FontName GlyphMetrics - --- | This ignores the Char code lookup and just returns the --- default advance vector. --- -monospace_metrics :: GlyphMetrics -monospace_metrics = GlyphMetrics - { get_bounding_box = \sz -> BBox (lowerLeft sz) (upperRight sz) - , get_av_lookup = \sz _ -> hvec (upscale sz width_vec) - , get_cap_height = \sz -> upscale sz cap_height - } - where - llx = (-23) / 1000 - lly = (-250) / 1000 - urx = 715 / 1000 - ury = 805 / 1000 - width_vec = 600 / 1000 - cap_height = 562 / 1000 - - upscale sz d = fromPtSize $ sz * d - lowerLeft sz = P2 (upscale sz llx) (upscale sz lly) - upperRight sz = P2 (upscale sz urx) (upscale sz ury) - - -buildMetrics :: (cu -> PtSize) -> GlyphMetricsTable cu -> GlyphMetrics - -buildMetrics fn (GlyphMetricsTable (BBox ll ur) (V2 vx vy) - vec_table cap_height) = - GlyphMetrics - { get_bounding_box = \sz -> BBox (scalePt sz ll) (scalePt sz ur) - , get_av_lookup = \sz i -> - maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table - , get_cap_height = \sz -> upscale sz (fn cap_height) - } - where - upscale sz d = fromPtSize $ sz * d - - defaultAV sz = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) - scalePt sz (P2 cx cy) = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) - scaleVec sz (V2 cx cy) = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) - - - diff --git a/src/Wumpus/Basic/Graphic/GraphicOperations.hs b/src/Wumpus/Basic/Graphic/GraphicOperations.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/GraphicOperations.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.GraphicOperations --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Elementary functions for the Graphic and LocGraphic types. --- --- The functions here are generally analogeous to the Picture --- API in @Wumpus.Core@, but here they exploit the implicit --- @DrawingContext@. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.GraphicOperations - ( - drawGraphic - - , openStroke - , closedStroke - , filledPath - , borderedPath - - - , textline - , rtextline - , centermonoTextline - , escapedline - , rescapedline - - , textlineMulti - , hkernline - , vkernline - - - , strokedEllipse - , filledEllipse - , borderedEllipse - - , supplyPt - , localPoint - , vecdisplace - , displace - , hdisplace - , vdisplace - , parallelvec - , perpendicularvec - , displaceParallel - , displacePerpendicular - - - , straightLine - , straightLineBetween - , curveBetween - - - , strokedRectangle - , filledRectangle - , borderedRectangle - - - , strokedCircle - , filledCircle - , borderedCircle - - , strokedDisk - , filledDisk - , borderedDisk - - - , illustrateBoundedGraphic - , illustrateBoundedLocGraphic - - ) where - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.ContextFunction -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.GraphicTypes -import Wumpus.Basic.Graphic.Query - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Colour - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - - - -drawGraphic :: (Real u, Floating u, FromPtSize u) - => DrawingContext -> Graphic u -> Picture u -drawGraphic ctx gf = frame [getPrimGraphic $ runGraphic ctx gf] - - - - -openStroke :: Num u => PrimPath u -> Graphic u -openStroke pp = - withStrokeAttr $ \rgb attr -> primGraphic $ ostroke rgb attr pp - -closedStroke :: Num u => PrimPath u -> Graphic u -closedStroke pp = - withStrokeAttr $ \rgb attr -> primGraphic $ cstroke rgb attr pp - -filledPath :: Num u => PrimPath u -> Graphic u -filledPath pp = withFillAttr $ \rgb -> primGraphic $ fill rgb pp - - - -borderedPath :: Num u => PrimPath u -> Graphic u -borderedPath pp = - withBorderedAttr $ \frgb attr srgb -> - primGraphic $ fillStroke frgb attr srgb pp - - --- Note - clipping needs a picture as well as a path, so there is --- no analogous @clippedPath@ function. - - --------------------------------------------------------------------------------- --- - -locPrimGraphic :: (Point2 u -> Primitive u) -> (Point2 u -> PrimGraphic u) -locPrimGraphic fn = primGraphic . fn - -thetaLocPrimGraphic :: (Point2 u -> Radian -> Primitive u) - -> (Point2 u -> Radian -> PrimGraphic u) -thetaLocPrimGraphic fn = \pt theta -> primGraphic (fn pt theta) - - - - -textline :: Num u => String -> LocGraphic u -textline ss = - withTextAttr $ \rgb attr -> locPrimGraphic (textlabel rgb attr ss) - - - -rtextline :: Num u => String -> LocThetaGraphic u -rtextline ss = - withTextAttr $ \rgb attr -> thetaLocPrimGraphic - (\pt ang -> rtextlabel rgb attr ss pt ang) - - - - --- | As 'textline' but the supplied point is the /center/. --- --- Centered is inexact - it is calculated with monospaced font --- metrics. --- -centermonoTextline :: (Fractional u, Ord u, FromPtSize u) - => String -> LocGraphic u -centermonoTextline ss = monoVecToCenter ss >>= \v -> - moveLoc (vecdisplace (negateV v)) (textline ss) - - - -escapedline :: Num u => EscapedText -> LocGraphic u -escapedline ss = - withTextAttr $ \rgb attr -> locPrimGraphic (escapedlabel rgb attr ss) - - -rescapedline :: Num u => EscapedText -> LocThetaGraphic u -rescapedline ss = - withTextAttr $ \rgb attr -> thetaLocPrimGraphic - (\pt ang -> rescapedlabel rgb attr ss pt ang) - - - --- | Point is the baseline left of the bottom line, text is --- left-aligned. --- -textlineMulti :: Fractional u => [String] -> LocGraphic u -textlineMulti xs = baselineSpacing >>= \dy -> - extrLocGraphic $ go (tmStep dy) xs - where - -- go /starts/ at the end of the list and works back. - go fn [] = fn "" -- not ideal, better than error - go fn [s] = fn s - go fn (s:ss) = let ans = go fn ss in ans `feedPt` fn s - --- LocImage u (Point2 u) deserved to be a new type synonym --- as it models PostScript\'s @show@ - - -tmStep :: Num u => u -> String -> LocImage u (Point2 u) -tmStep dy str = intoLocImage (raise $ \pt -> pt .+^ vvec dy) (textline str) - -feedPt :: LocImage u (Point2 u) -> LocImage u (Point2 u) -> LocImage u (Point2 u) -feedPt = accumulate1 oplus - -hkernline :: Num u => [KerningChar u] -> LocGraphic u -hkernline ks = - withTextAttr $ \rgb attr -> locPrimGraphic (hkernlabel rgb attr ks) - - -vkernline :: Num u => [KerningChar u] -> LocGraphic u -vkernline ks = - withTextAttr $ \rgb attr -> locPrimGraphic (vkernlabel rgb attr ks) - - - --------------------------------------------------------------------------------- - - -strokedEllipse :: Num u => u -> u -> LocGraphic u -strokedEllipse hw hh = - withStrokeAttr $ \rgb attr -> locPrimGraphic (strokeEllipse rgb attr hw hh) - - -filledEllipse :: Num u => u -> u -> LocGraphic u -filledEllipse hw hh = - withFillAttr $ \rgb -> locPrimGraphic (fillEllipse rgb hw hh) - - -borderedEllipse :: Num u => u -> u -> LocGraphic u -borderedEllipse hw hh = - withBorderedAttr $ \frgb attr srgb -> - locPrimGraphic (fillStrokeEllipse frgb attr srgb hw hh) - --------------------------------------------------------------------------------- - - --- | Supplying a point to a 'CFGraphic' takes it to a regular --- 'Graphic'. --- -supplyPt :: Point2 u -> LocGraphic u -> Graphic u -supplyPt pt gf = fmap ($ pt) gf - - - -vecdisplace :: Num u => Vec2 u -> PointDisplace u -vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy) - - -displace :: Num u => u -> u -> PointDisplace u -displace dx dy (P2 x y) = P2 (x+dx) (y+dy) - -hdisplace :: Num u => u -> PointDisplace u -hdisplace dx (P2 x y) = P2 (x+dx) y - -vdisplace :: Num u => u -> PointDisplace u -vdisplace dy (P2 x y) = P2 x (y+dy) - - - - -parallelvec :: Floating u => u -> Radian -> Vec2 u -parallelvec d r = avec (circularModulo r) d - -perpendicularvec :: Floating u => u -> Radian -> Vec2 u -perpendicularvec d r = avec (circularModulo $ (0.5*pi) + r) d - -displaceParallel :: Floating u => u -> Radian -> PointDisplace u -displaceParallel d r pt = pt .+^ parallelvec d r - -displacePerpendicular :: Floating u => u -> Radian -> PointDisplace u -displacePerpendicular d r pt = pt .+^ perpendicularvec d r - - -localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u -localPoint = moveLoc - - - --------------------------------------------------------------------------------- - - -straightLine :: Fractional u => Vec2 u -> LocGraphic u -straightLine v = - promote1 $ \pt -> openStroke $ primPath pt [lineTo $ pt .+^ v] - - -straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u -straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2] - - - -curveBetween :: Fractional u - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u -curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep] - - - --- | Supplied point is /bottom-left/. --- -rectangle :: Num u => u -> u -> Point2 u -> PrimPath u -rectangle w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ] - where - br = bl .+^ hvec w - tr = br .+^ vvec h - tl = bl .+^ vvec h - --- This is basically the cardinal-prime combinator with arguments --- at specific types --- --- > cardinal' :: (a -> r1 -> ans) -> (r2 -> a) -> (r1 -> r2 -> ans) --- - -drawWith :: (PrimPath u -> Graphic u) -> (Point2 u -> PrimPath u) -> LocGraphic u -drawWith mf g = promote1 $ \pt -> (mf $ g pt) - --- | Supplied point is /bottom left/. --- -strokedRectangle :: Fractional u => u -> u -> LocGraphic u -strokedRectangle w h = drawWith closedStroke (rectangle w h) - - --- | Supplied point is /bottom left/. --- -filledRectangle :: Fractional u => u -> u -> LocGraphic u -filledRectangle w h = drawWith borderedPath (rectangle w h) - --- | Supplied point is /bottom left/. --- -borderedRectangle :: Fractional u => u -> u -> LocGraphic u -borderedRectangle w h = drawWith borderedPath (rectangle w h) - - - - --------------------------------------------------------------------------------- - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -strokedCircle :: Floating u => Int -> u -> LocGraphic u -strokedCircle n r = drawWith closedStroke (curvedPath . bezierCircle n r) - - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -filledCircle :: Floating u => Int -> u -> LocGraphic u -filledCircle n r = drawWith filledPath (curvedPath . bezierCircle n r) - - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -borderedCircle :: Floating u => Int -> u -> LocGraphic u -borderedCircle n r = drawWith borderedPath (curvedPath . bezierCircle n r) - - - --- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive. --- --- This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, stroked-circles do not draw well after --- non-uniform scaling - the line width is scaled as well as --- the shape. --- --- For stroked circles that can be scaled, consider making the --- circle from Bezier curves. --- -strokedDisk :: Num u => u -> LocGraphic u -strokedDisk radius = strokedEllipse radius radius - - -filledDisk :: Num u => u -> LocGraphic u -filledDisk radius = filledEllipse radius radius - -borderedDisk :: Num u => u -> LocGraphic u -borderedDisk radius = borderedEllipse radius radius - --------------------------------------------------------------------------------- --- - -illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u -illustrateBoundedGraphic mf = mf >>= \(bb,g1) -> - bbrectangle bb >>= \g2 -> - return (bb, g2 `oplus` g1) - - -illustrateBoundedLocGraphic :: Fractional u - => BoundedLocGraphic u -> BoundedLocGraphic u -illustrateBoundedLocGraphic mf = - promote1 $ \pt -> illustrateBoundedGraphic (unLoc pt mf) - - -bbrectangle :: Fractional u => BoundingBox u -> Graphic u -bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury)) = - localize drawing_props $ rect1 `oplus` cross - where - drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)]) - rect1 = strokedRectangle (urx-llx) (ury-lly) `at` p1 - cross = straightLineBetween p1 p2 - `oplus` straightLineBetween (P2 llx ury) (P2 urx lly) diff --git a/src/Wumpus/Basic/Graphic/GraphicTypes.hs b/src/Wumpus/Basic/Graphic/GraphicTypes.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/GraphicTypes.hs +++ /dev/null @@ -1,441 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.GraphicTypes --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Refined instances of of the Drawing type modelling specific --- graphic types. --- --- \*\* WARNING \*\* - some names are expected to change. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.GraphicTypes - ( - - - -- * Function from Point to Point - PointDisplace - - -- * Advance vector - , AdvanceVec - - -- * Drawing info - , DrawingInfo - , LocDrawingInfo - , LocThetaDrawingInfo - - -- * Graphic - , Graphic - , LocGraphic - , LocThetaGraphic - , ConnectorGraphic - - , DGraphic - , DLocGraphic - , DLocThetaGraphic - , DConnectorGraphic - - - -- * Image - , Image - , LocImage - , LocThetaImage - , ConnectorImage - - , DImage - , DLocImage - , DLocThetaImage - , DConnectorImage - - -- * /Advance vector/ graphic - , AdvGraphic - , DAdvGraphic - - -- * Bounded graphic / loc graphic - , BoundedGraphic - , DBoundedGraphic - , BoundedLocGraphic - , DBoundedLocGraphic - - -- * Extract from an Advance vector - , advanceH - , advanceV - - -- * Run functions - , runGraphic - , runLocGraphic - , runImage - , runLocImage - - -- * Combinators - , moveLoc - , at - - -- * Dropping answers - , extrGraphic - , extrLocGraphic - - - , fontDeltaGraphic - , fontDeltaImage - , xlinkGraphic - , xlinkImage - - , intoImage - , intoLocImage - , intoConnectorImage - , intoLocThetaImage - , makeAdvGraphic - - - ) where - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.ContextFunction -import Wumpus.Basic.Graphic.DrawingContext - -import Wumpus.Core -- package: wumpus-core - - - -type PointDisplace u = Point2 u -> Point2 u - - -type AdvanceVec u = Vec2 u - - - - - - --------------------------------------------------------------------------------- --- DrawingInfo - --- | A query on the DrawingContext. --- --- Alias for 'CF'. --- -type DrawingInfo a = CF a - - --- | A query on the DrawingContext respective to the supplied --- point. --- --- Alias for 'LocCF'. --- -type LocDrawingInfo u a = LocCF u a - - --- | A query on the DrawingContext respective to the supplied --- point and angle. --- --- Alias for 'LocCF'. --- -type LocThetaDrawingInfo u a = LocThetaCF u a - - --------------------------------------------------------------------------------- --- Graphic - --- | Simple drawing - produce a primitive, access the DrawingContext --- if required. --- -type Graphic u = CF (PrimGraphic u) - --- | Commonly graphics take a start point as well as a drawing --- context. --- --- Here they are called a LocGraphic - graphic with a (starting) --- location. --- -type LocGraphic u = LocCF u (PrimGraphic u) - - --- | A function from @point * angle -> graphic@ --- -type LocThetaGraphic u = LocThetaCF u (PrimGraphic u) - --- | ConnectorGraphic is a connector drawn between two points --- contructing a Graphic. --- -type ConnectorGraphic u = ConnectorCF u (PrimGraphic u) - - - - -type DGraphic = Graphic Double -type DLocGraphic = LocGraphic Double -type DLocThetaGraphic = LocThetaGraphic Double -type DConnectorGraphic = ConnectorGraphic Double - - -type instance DUnit (Graphic u) = u - - --------------------------------------------------------------------------------- --- Image - --- | Images return a value as well as drawing. A /node/ is a --- typical example - nodes are drawing but the also support --- taking anchor points. --- -type Image u a = CF (a, PrimGraphic u) - -type LocImage u a = LocCF u (a,PrimGraphic u) - -type LocThetaImage u a = LocThetaCF u (a,PrimGraphic u) - --- | ConnectorImage is a connector drawn between two points --- constructing an Image. --- --- Usually the answer type of a ConnectorImage will be a Path so --- the Points ar @midway@, @atstart@ etc. can be taken on it. --- -type ConnectorImage u a = ConnectorCF u (a, PrimGraphic u) - - - - - -type DImage a = Image Double a -type DLocImage a = LocImage Double a -type DLocThetaImage a = LocThetaImage Double a -type DConnectorImage a = ConnectorImage Double a - - - -type instance DUnit (Image u a) = u - - --------------------------------------------------------------------------------- - - --- | /Advance vector/ graphic - this partially models the --- PostScript @show@ command which moves the /current point/ by the --- width (advance) vector as each character is drawn. --- -type AdvGraphic u = LocImage u (Point2 u) - -type DAdvGraphic = AdvGraphic Double - - -type instance DUnit (AdvGraphic u) = u - - --------------------------------------------------------------------------------- - --- | Graphic with a bounding box. --- -type BoundedGraphic u = Image u (BoundingBox u) - -type DBoundedGraphic = BoundedGraphic Double - - -type instance DUnit (BoundedGraphic u) = u - - --- | LocGraphic with a bounding box. --- -type BoundedLocGraphic u = LocImage u (BoundingBox u) - -type DBoundedLocGraphic = BoundedLocGraphic Double - - -type instance DUnit (BoundedLocGraphic u) = u - - - --------------------------------------------------------------------------------- --- Graphic instances - - --- Affine instances - -instance (Real u, Floating u) => Rotate (Graphic u) where - rotate ang = postpro (rotate ang) - - -instance (Real u, Floating u) => RotateAbout (Graphic u) where - rotateAbout ang pt = postpro (rotateAbout ang pt) - - -instance Num u => Scale (Graphic u) where - scale sx sy = postpro (scale sx sy) - - -instance Num u => Translate (Graphic u) where - translate dx dy = postpro (translate dx dy) - --------------------------------------------------------------------------------- --- Image instances - --- Affine instances - - -instance (Real u, Floating u, Rotate a, DUnit a ~ u) => - Rotate (Image u a) where - rotate ang = postpro (\(a,b) -> (rotate ang a, rotate ang b)) - - -instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => - RotateAbout (Image u a) where - rotateAbout ang pt = - postpro (\(a,b) -> (rotateAbout ang pt a, rotateAbout ang pt b)) - - -instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where - scale sx sy = postpro (\(a,b) -> (scale sx sy a, scale sx sy b)) - - -instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where - translate dx dy = postpro (\(a,b) -> (translate dx dy a, translate dx dy b)) - - - --------------------------------------------------------------------------------- - --- | Extract the horizontal component of an advance vector. --- --- For left-to-right latin text, the vertical component of an --- advance vector is expected to be 0. Ingoring it seems --- permissible, e.g. when calculating bounding boxes for --- left-to-right text. --- -advanceH :: Num u => AdvanceVec u -> u -advanceH (V2 w _) = w - --- | Extract the verticaltal component of an advance vector. --- --- For left-to-right latin text, the vertical component of an --- advance vector is expected to be 0. --- -advanceV :: Num u => AdvanceVec u -> u -advanceV (V2 _ h) = h - - --------------------------------------------------------------------------------- --- Run functions - - - -runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u -runGraphic ctx df = runCF ctx df - - -runLocGraphic :: DrawingContext -> Point2 u -> LocGraphic u -> PrimGraphic u -runLocGraphic ctx pt df = runCF ctx (unCF1 pt df) - - - -runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u) -runImage ctx img = runCF ctx img - -runLocImage :: DrawingContext -> Point2 u -> LocImage u a -> (a, PrimGraphic u) -runLocImage ctx pt img = runCF ctx (unCF1 pt img) - - --------------------------------------------------------------------------------- --- Combinators - -moveLoc :: (Point2 u -> Point2 u) -> LocCF u a -> LocCF u a -moveLoc = prepro1 - - - -infixr 1 `at` -at :: CF (Point2 u -> b) -> Point2 u -> CF b -at = situ1 - - - - -------------------------------------------------------------------------------- --- Dropping /answers/ - - -extrGraphic :: Image u a -> Graphic u -extrGraphic = postpro snd - - -extrLocGraphic :: LocImage u a -> LocGraphic u -extrLocGraphic = postpro1 snd - - - --------------------------------------------------------------------------------- - - -metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u -metamorphPrim f = primGraphic . f . getPrimGraphic - -fontDeltaGraphic :: Graphic u -> Graphic u -fontDeltaGraphic df = - drawingCtx `bind` \ctx -> postpro (fun $ font_props ctx) df - where - fun attr = metamorphPrim (fontDeltaContext attr) - -fontDeltaImage :: Image u a -> Image u a -fontDeltaImage df = - drawingCtx `bind` \ctx -> postpro (fun $ font_props ctx) df - where - fun attr = \(a,prim) -> (a, metamorphPrim (fontDeltaContext attr) prim) - - -xlinkGraphic :: XLink -> Graphic u -> Graphic u -xlinkGraphic hypl = postpro (metamorphPrim (xlink hypl)) - - -xlinkImage :: XLink -> Image u a -> Image u a -xlinkImage hypl = - postpro (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim)) - - - - - -intoImage :: CF a -> Graphic u -> Image u a -intoImage = postcomb (,) - - - -intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a -intoLocImage = postcomb1 (,) - --- Drawing $ \ctx a -> (getDrawing f ctx a, getDrawing g ctx a) - - -intoConnectorImage :: ConnectorCF u a - -> ConnectorGraphic u - -> ConnectorImage u a -intoConnectorImage = postcomb2 (,) - - - -intoLocThetaImage :: LocThetaCF u a - -> LocThetaGraphic u - -> LocThetaImage u a -intoLocThetaImage = postcomb2 (,) - - --- | Construction is different to intoZZ functions hence the --- different name. --- -makeAdvGraphic :: PointDisplace u - -> LocGraphic u - -> AdvGraphic u -makeAdvGraphic pf df = postcomb1 (,) (postpro1 pf locPoint) df - - - - - diff --git a/src/Wumpus/Basic/Graphic/Query.hs b/src/Wumpus/Basic/Graphic/Query.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/Query.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.Query --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Querying the Drawing Context. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.Query - ( - - - textAttr - , withTextAttr - - , strokeAttr - , withStrokeAttr - - , fillAttr - , withFillAttr - - , borderedAttr - , withBorderedAttr - - , lineWidth - , fontSize - , fontFace - , fontAttr - , markHeight - , markHalfHeight - , baselineSpacing - - -- * Glyph metrics - , glyphBoundingBox - , glyphHeightRange - , glyphHeight - , glyphCapHeight - - , avLookupTable - - -- * Default monospace metrics - - , monoFontPointSize - , monoCharWidth - , monoTextWidth - , monoTextLength - , monoCapHeight - , monoLowerxHeight - , monoDescenderDepth - , monoAscenderHeight - , monoTextDimensions - , monoMultiLineHeight - , monoDefaultPadding - , monoVecToCenter - ) where - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.GlyphMetrics - -import Wumpus.Core -- package: wumpus-core -import qualified Wumpus.Core.FontSize as FS - -import Control.Applicative - - -textAttr :: DrawingCtxM m => m (RGBi,FontAttr) -textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props - --- | Because @textAttr@ is so commonly used here is a functional --- version that avoids tupling. --- -withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a -withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props - - -strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) -strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props - -withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a -withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props - - -fillAttr :: DrawingCtxM m => m RGBi -fillAttr = asksDC fill_colour - -withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a -withFillAttr fn = fn <$> asksDC fill_colour - -borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi) -borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props - <*> asksDC stroke_colour - -withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a -withBorderedAttr fn = - fn <$> asksDC fill_colour <*> asksDC stroke_props - <*> asksDC stroke_colour - - - - -lineWidth :: DrawingCtxM m => m Double -lineWidth = line_width <$> asksDC stroke_props - -fontAttr :: DrawingCtxM m => m FontAttr -fontAttr = asksDC font_props - -fontSize :: DrawingCtxM m => m Int -fontSize = font_size <$> asksDC font_props - -fontFace :: DrawingCtxM m => m FontFace -fontFace = font_face <$> asksDC font_props - - - - --- | Vertical distance between baselines of consecutive text --- lines. --- -baselineSpacing :: (DrawingCtxM m, Fractional u) => m u -baselineSpacing = - (\sz factor -> realToFrac $ factor * fromIntegral sz) - <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor - --- | The /mark/ height is the height of a lowercase letter in the --- current font. --- --- Arrowheads, dots etc. should generally be drawn at the mark --- height. --- -markHeight :: (DrawingCtxM m, FromPtSize u) => m u -markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props - - -markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u -markHalfHeight = (0.5*) <$> markHeight - - --- Note - there are probably enough functions that use just --- markHeight to merit a withMarkHeight function. - - --------------------------------------------------------------------------------- - -glyphQuery :: DrawingCtxM m => (GlyphMetrics -> PtSize -> u) -> m u -glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC - -glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) -glyphBoundingBox = glyphQuery get_bounding_box - - -glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u) -glyphHeightRange = fn <$> glyphBoundingBox - where - fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax) - - -glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u -glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange - - -glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u -glyphCapHeight = glyphQuery get_cap_height - -avLookupTable :: (FromPtSize u, DrawingCtxM m) => m (Int -> Vec2 u) -avLookupTable = glyphQuery get_av_lookup - - --------------------------------------------------------------------------------- - -withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u -withFontSize fn = (fn . font_size) <$> asksDC font_props - - --- NOTE - textHeight in Wumpus-Core should be renamed as it is --- (probably) more indiactive of Cap height than /font point size/ --- - -monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u -monoFontPointSize = withFontSize (fromPtSize . fromIntegral) - -monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u -monoCharWidth = withFontSize (fromPtSize . FS.charWidth) - - -monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u -monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n - - -monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u -monoTextLength ss = monoTextWidth $ charCount ss - - -monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoCapHeight = withFontSize (fromPtSize . FS.capHeight) - -monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight) - - - --- | Height of a lower case \'x\' in Courier. --- --- \'x\' has no ascenders or descenders. --- -monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight) - -monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u -monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) - -monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) - - --- | Query the dimensions of the text using the current font size --- but using metrics derived from Courier. --- --- Note - the width will generally be a over-estimate for --- non-monospaced fonts. --- -monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u) - => String -> m (u,u) -monoTextDimensions ss = - (\sz -> post $ textBounds sz zeroPt ss) - <$> asksDC (font_size . font_props) - where - post bb = (boundaryWidth bb, boundaryHeight bb) - - --- | The heigth of @n@ lines of text, which is --- @n lines + n-1 line spacers@ --- -monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) - => Int -> m u -monoMultiLineHeight n | n < 0 = pure 0 -monoMultiLineHeight n = - (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf)) - <$> monoTotalCharHeight <*> asksDC line_spacing_factor - - -- Note as the height calculation has changed in Wumpus-Core this - -- no longer quite works... - - - --- | The default padding is half of the /char width/. --- -monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u -monoDefaultPadding = (0.5*) <$> monoCharWidth - --- | Vector from baseline left to center --- -monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) - => String -> m (Vec2 u) -monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) - <$> monoTextDimensions ss <*> monoDescenderDepth diff --git a/src/Wumpus/Basic/Graphic/ScalingContext.hs b/src/Wumpus/Basic/Graphic/ScalingContext.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/ScalingContext.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.ScalingContext --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Scaling in X and Y --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.ScalingContext - ( - - ScalingM(..) - , ScalingContext(..) - - , Scaling - , runScaling - , ScalingT - , runScalingT - - , regularScalingContext - , coordinateScalingContext - - , unitX - , unitY - - - ) where - -import Wumpus.Basic.Graphic.Base - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - - - --- | Scaling... --- -class Monad m => ScalingM m where - type XDim m :: * - type YDim m :: * - scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u - scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u - scalePt :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) - => ux -> uy -> m (Point2 u) - scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) - => ux -> uy -> m (Vec2 u) - - - -data ScalingContext ux uy u = ScalingContext - { scale_in_x :: ux -> u - , scale_in_y :: uy -> u - } - - - --- Chains (for example) want a plain monad rather than a transformer. --- -newtype Scaling ux uy u a = Scaling { - getScaling :: ScalingContext ux uy u -> a } - - -type instance MonUnit (Scaling ux uy u) = u - - - -instance Functor (Scaling ux uy u) where - fmap f ma = Scaling $ \ctx -> let a = getScaling ma ctx in f a - -instance Applicative (Scaling ux uy u) where - pure a = Scaling $ \_ -> a - mf <*> ma = Scaling $ \ctx -> let f = getScaling mf ctx - a = getScaling ma ctx - in (f a) - -instance Monad (Scaling ux uy u) where - return a = Scaling $ \_ -> a - m >>= k = Scaling $ \ctx -> let a = getScaling m ctx - in (getScaling . k) a ctx - - - -instance ScalingM (Scaling ux uy u) where - type XDim (Scaling ux uy u) = ux - type YDim (Scaling ux uy u) = uy - scaleX ux = Scaling $ \ctx -> (scale_in_x ctx) ux - scaleY uy = Scaling $ \ctx -> (scale_in_y ctx) uy - scalePt ux uy = Scaling $ \ctx -> P2 (scale_in_x ctx ux) (scale_in_y ctx uy) - scaleVec ux uy = Scaling $ \ctx -> V2 (scale_in_x ctx ux) (scale_in_y ctx uy) - -runScaling :: ScalingContext ux uy u -> Scaling ux uy u a -> a -runScaling ctx sf = (getScaling sf) ctx - - - - --------------------------------------------------------------------------------- --- Transformer - --- Turtle (for example) wants a transformer so it can use TraceM --- and DrawingCtxM --- -newtype ScalingT ux uy u m a = ScalingT { - getScalingT :: ScalingContext ux uy u -> m a } - -type instance MonUnit (ScalingT ux uy u m) = u - - -instance Monad m => Functor (ScalingT ux uy u m) where - fmap f ma = ScalingT $ \ctx -> getScalingT ma ctx >>= \a -> return (f a) - -instance Monad m => Applicative (ScalingT ux uy u m) where - pure a = ScalingT $ \_ -> return a - mf <*> ma = ScalingT $ \ctx -> getScalingT mf ctx >>= \f -> - getScalingT ma ctx >>= \a -> - return (f a) - -instance Monad m => Monad (ScalingT ux uy u m) where - return a = ScalingT $ \_ -> return a - m >>= k = ScalingT $ \ctx -> getScalingT m ctx >>= \a -> - (getScalingT . k) a ctx - - -instance Monad m => ScalingM (ScalingT ux uy u m) where - type XDim (ScalingT ux uy u m) = ux - type YDim (ScalingT ux uy u m) = uy - scaleX ux = ScalingT $ \ctx -> return $ (scale_in_x ctx) ux - scaleY uy = ScalingT $ \ctx -> return $ (scale_in_y ctx) uy - scalePt ux uy = ScalingT $ \ctx -> - return $ P2 (scale_in_x ctx ux) (scale_in_y ctx uy) - scaleVec ux uy = ScalingT $ \ctx -> - return $ V2 (scale_in_x ctx ux) (scale_in_y ctx uy) - - - --- Cross instances - needed to run SalingT /locally/ in Drawing. - -instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where - askDC = ScalingT $ \_ -> askDC >>= \dctx -> return dctx - localize upd mf = ScalingT $ \sctx -> localize upd (getScalingT mf sctx) - - -instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where - trace a = ScalingT $ \_ -> trace a - - - - -runScalingT :: ScalingContext ux uy u -> ScalingT ux uy u m a -> m a -runScalingT ctx sf = (getScalingT sf) ctx - --------------------------------------------------------------------------------- --- constructors for scaling context - -regularScalingContext :: Num u => u -> ScalingContext u u u -regularScalingContext u = ScalingContext - { scale_in_x = (\x -> u*x) - , scale_in_y = (\y -> u*y) - } - -coordinateScalingContext :: Num u => u -> u -> ScalingContext Int Int u -coordinateScalingContext sx sy = ScalingContext - { scale_in_x = (\x -> sx * fromIntegral x) - , scale_in_y = (\y -> sy * fromIntegral y) - } - - - --------------------------------------------------------------------------------- --- operations - - - - -unitX :: (ScalingM m, Num ux, ux ~ XDim m, u ~ MonUnit m) => m u -unitX = scaleX 1 - -unitY :: (ScalingM m, Num uy, uy ~ YDim m, u ~ MonUnit m) => m u -unitY = scaleY 1 - - diff --git a/src/Wumpus/Basic/Graphic/TraceDrawing.hs b/src/Wumpus/Basic/Graphic/TraceDrawing.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/TraceDrawing.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.TraceDrawing --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Drawing with /trace/ - a Writer like monad collecting --- intermediate graphics - and /drawing context/ - a reader monad --- of attributes - font_face, fill_colour etc. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.TraceDrawing - ( - - TraceDrawing - , TraceDrawingT - , runTraceDrawing - , execTraceDrawing - , evalTraceDrawing - , runTraceDrawingT - , execTraceDrawingT - , evalTraceDrawingT - - , liftToPictureU - , liftToPictureMb - , mbPictureU - - - , query - , draw - , xdraw - , drawi - , drawi_ - , xdrawi - , xdrawi_ - - , node - , nodei - - ) where - - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.ContextFunction -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.GraphicTypes - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative -import Control.Monad -import Data.Monoid - - - --- Note - TraceDrawing run \once\ - it is supplied with the starting --- environment (DrawingContext) and returns a Picture. --- --- Other Wumpus monads (e.g. Turtle) will typically be run inside --- the TraceDrawing monad as a local effect, rather than built into a --- transformer stack. --- - - -newtype TraceDrawing u a = TraceDrawing { - getTraceDrawing :: DrawingContext -> (a, HPrim u) } - -newtype TraceDrawingT u m a = TraceDrawingT { - getTraceDrawingT :: DrawingContext -> m (a, HPrim u) } - - - -type instance MonUnit (TraceDrawing u) = u -type instance MonUnit (TraceDrawingT u m) = u - - - --- Functor - -instance Functor (TraceDrawing u) where - fmap f ma = TraceDrawing $ \ctx -> - let (a,w) = getTraceDrawing ma ctx in (f a,w) - - -instance Monad m => Functor (TraceDrawingT u m) where - fmap f ma = TraceDrawingT $ \ctx -> - getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w) - - - --- Applicative - -instance Applicative (TraceDrawing u) where - pure a = TraceDrawing $ \_ -> (a, mempty) - mf <*> ma = TraceDrawing $ \ctx -> - let (f,w1) = getTraceDrawing mf ctx - (a,w2) = getTraceDrawing ma ctx - in (f a, w1 `mappend` w2) - - -instance Monad m => Applicative (TraceDrawingT u m) where - pure a = TraceDrawingT $ \_ -> return (a,mempty) - mf <*> ma = TraceDrawingT $ \ctx -> - getTraceDrawingT mf ctx >>= \(f,w1) -> - getTraceDrawingT ma ctx >>= \(a,w2) -> - return (f a, w1 `mappend` w2) - --- Monad - -instance Monad (TraceDrawing u) where - return a = TraceDrawing $ \_ -> (a, mempty) - ma >>= k = TraceDrawing $ \ctx -> - let (a,w1) = getTraceDrawing ma ctx - (b,w2) = (getTraceDrawing . k) a ctx - in (b,w1 `mappend` w2) - - - - -instance Monad m => Monad (TraceDrawingT u m) where - return a = TraceDrawingT $ \_ -> return (a, mempty) - ma >>= k = TraceDrawingT $ \ctx -> - getTraceDrawingT ma ctx >>= \(a,w1) -> - (getTraceDrawingT . k) a ctx >>= \(b,w2) -> - return (b, w1 `mappend` w2) - - - - --- TraceM --- --- Note - @ state `mappend` a @ means the first expression in a --- monadic drawing is the first element in the output file. It is --- also \*\* at the back \*\* in the the Z-Order. --- --- Some control over the Z-Order, possibly by adding /layers/ to --- the drawing model would be valuable. --- - -instance TraceM (TraceDrawing u) where - trace a = TraceDrawing $ \_ -> ((), a) - - -instance Monad m => TraceM (TraceDrawingT u m) where - trace a = TraceDrawingT $ \_ -> return ((), a) - - - --- DrawingCtxM - -instance DrawingCtxM (TraceDrawing u) where - askDC = TraceDrawing $ \ctx -> (ctx, mempty) - localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx) - - - -instance Monad m => DrawingCtxM (TraceDrawingT u m) where - askDC = TraceDrawingT $ \ctx -> return (ctx,mempty) - localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx) - - - --- Note - the result type of runTraceDrawing and friends needs more --- thought and may change. --- --- Possibly a wrapped HPrim that only supports concat and safe --- extraction is best. --- --- Or it could generate a picture, but then separate drawings --- need the picture combinators to put them together. --- - - -runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u) -runTraceDrawing ctx ma = getTraceDrawing ma ctx - --- | Run the drawing returning only the output it produces, drop --- any answer from the monadic computation. --- -execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u -execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma - --- | Run the drawing ignoring the output it produces, return the --- answer from the monadic computation. --- --- Note - this useful for testing, generally one would want the --- opposite behaviour (return the drawing, ignore than the --- answer). --- -evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a -evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma - - - -runTraceDrawingT :: Monad m - => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) -runTraceDrawingT ctx ma = getTraceDrawingT ma ctx - -execTraceDrawingT :: Monad m - => DrawingContext -> TraceDrawingT u m a -> m (HPrim u) -execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma - - -evalTraceDrawingT :: Monad m - => DrawingContext -> TraceDrawingT u m a -> m a -evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma - - - --- | /Unsafe/ promotion of @HPrim@ to @Picture@. --- --- If the HPrim is empty, a run-time error is thrown. --- -liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u -liftToPictureU hf = - let prims = hprimToList hf in if null prims then errK else frame prims - where - errK = error "toPictureU - empty prims list." - --- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@. --- --- If the HPrim is empty, then @Nothing@ is returned. --- -liftToPictureMb :: (Real u, Floating u, FromPtSize u) - => HPrim u -> Maybe (Picture u) -liftToPictureMb hf = let prims = hprimToList hf in - if null prims then Nothing else Just (frame prims) - - - --- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@. --- --- This is equivalent to: --- --- > fromMaybe (error "empty") $ pic --- --- This function is solely a convenience, using it saves one --- import and a few characters. --- --- If the supplied value is @Nothing@ a run-time error is thrown. --- -mbPictureU :: (Real u, Floating u, FromPtSize u) - => Maybe (Picture u) -> Picture u -mbPictureU Nothing = error "mbPictureU - empty picture." -mbPictureU (Just a) = a - --- Note - need an equivalent to Parsec\`s parseTest that provides --- a very simple way to run graphics without concern for return --- type or initial drawing context. - --------------------------------------------------------------------------------- - -query :: DrawingCtxM m => CF a -> m a -query df = askDC >>= \ctx -> return $ runCF ctx df - - --- | Draw a Graphic taking the drawing style from the --- /drawing context/. --- --- This operation is analogeous to @tell@ in a Writer monad. --- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () -draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf) - --- | Hyperlink version of 'draw'. --- -xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Graphic u -> m () -xdraw xl gf = draw (xlinkGraphic xl gf) - - - --- | Draw an Image taking the drawing style from the --- /drawing context/. --- --- The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned. --- -drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a -drawi img = askDC >>= \ctx -> - let (a,o) = runImage ctx img in trace (collectH o) >> return a - --- | Forgetful 'drawi'. --- -drawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m () -drawi_ img = drawi img >> return () - - --- | Hyperlink version of 'drawi'. --- -xdrawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Image u a -> m a -xdrawi xl img = drawi (xlinkImage xl img) - - --- | Forgetful 'xdrawi'. --- -xdrawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Image u a -> m () -xdrawi_ xl img = xdrawi xl img >> return () - - - - -node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) - => LocGraphic u -> m () -node gf = askDC >>= \ctx -> - position >>= \pt -> - let f = runCF ctx gf in trace (collectH $ f pt) - - -nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) - => LocImage u a -> m a -nodei imgL = askDC >>= \ctx -> - position >>= \pt -> - let (a,o) = runLocImage ctx pt imgL - in trace (collectH o) >> return a - diff --git a/src/Wumpus/Basic/Kernel.hs b/src/Wumpus/Basic/Kernel.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Import shim for @Wumpus.Basic.Kernel@ modules. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel + ( + module Wumpus.Basic.Kernel.Base.Anchors + , module Wumpus.Basic.Kernel.Base.BaseDefs + , module Wumpus.Basic.Kernel.Base.ContextFun + , module Wumpus.Basic.Kernel.Base.DrawingContext + , module Wumpus.Basic.Kernel.Base.GlyphMetrics + , module Wumpus.Basic.Kernel.Base.QueryDC + , module Wumpus.Basic.Kernel.Base.ScalingContext + , module Wumpus.Basic.Kernel.Base.UpdateDC + , module Wumpus.Basic.Kernel.Base.WrappedPrimitive + , module Wumpus.Basic.Kernel.Geometry.Intersection + , module Wumpus.Basic.Kernel.Geometry.Paths + , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic + , module Wumpus.Basic.Kernel.Objects.BaseObjects + , module Wumpus.Basic.Kernel.Objects.Bounded + , module Wumpus.Basic.Kernel.Objects.Connector + , module Wumpus.Basic.Kernel.Objects.Drawing + , module Wumpus.Basic.Kernel.Objects.Graphic + , module Wumpus.Basic.Kernel.Objects.TraceDrawing + ) where + +import Wumpus.Basic.Kernel.Base.Anchors +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.GlyphMetrics +import Wumpus.Basic.Kernel.Base.QueryDC +import Wumpus.Basic.Kernel.Base.ScalingContext +import Wumpus.Basic.Kernel.Base.UpdateDC +import Wumpus.Basic.Kernel.Base.WrappedPrimitive +import Wumpus.Basic.Kernel.Geometry.Intersection +import Wumpus.Basic.Kernel.Geometry.Paths +import Wumpus.Basic.Kernel.Objects.AdvanceGraphic +import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.Bounded +import Wumpus.Basic.Kernel.Objects.Connector +import Wumpus.Basic.Kernel.Objects.Drawing +import Wumpus.Basic.Kernel.Objects.Graphic +import Wumpus.Basic.Kernel.Objects.TraceDrawing diff --git a/src/Wumpus/Basic/Kernel/Base/Anchors.hs b/src/Wumpus/Basic/Kernel/Base/Anchors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/Anchors.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.Anchors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Anchor points on shapes, bounding boxes, etc. +-- +-- Anchors are addressable positions, an examplary use is taking +-- anchors on node shapes to get the start and end points for +-- connectors in a network (graph) diagram. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.Anchors + ( + + -- * Anchors + CenterAnchor(..) + , CardinalAnchor(..) + , CardinalAnchor2(..) + , RadialAnchor(..) + + -- * Extended anchor points + , northwards + , southwards + , eastwards + , westwards + , northeastwards + , southeastwards + , southwestwards + , northwestwards + + , radialConnectorPoints + + ) where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +-- | Center of an object. +-- +class CenterAnchor t where + center :: DUnit t ~ u => t -> Point2 u + +-- | Cardinal (compass) positions on an object. +-- +-- Note - in TikZ cardinal anchors are not necessarily at the +-- equivalent radial position, for instance reactangle north-east +-- is the top-right corner whether or not this is incident at +-- 45deg. +-- +-- Wumpus generally follows the TikZ convention. +-- +class CardinalAnchor t where + north :: DUnit t ~ u => t -> Point2 u + south :: DUnit t ~ u => t -> Point2 u + east :: DUnit t ~ u => t -> Point2 u + west :: DUnit t ~ u => t -> Point2 u + + +-- | Secondary group of cardinal (compass) positions on an object. +-- +-- It seems possible that for some objects defining the primary +-- compass points (north, south,...) will be straight-forward +-- whereas defining the secondary compass points may be +-- problemmatic, hence the compass points are split into two +-- classes. +-- +class CardinalAnchor2 t where + northeast :: DUnit t ~ u => t -> Point2 u + southeast :: DUnit t ~ u => t -> Point2 u + southwest :: DUnit t ~ u => t -> Point2 u + northwest :: DUnit t ~ u => t -> Point2 u + + +-- | Anchor on a border that can be addressed by an angle. +-- +-- The angle is counter-clockwise from the right-horizontal, i.e. +-- 0 is /east/. +-- +class RadialAnchor t where + radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u + + + + +extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u +extendPtDist d p1 p2 = let v = pvec p1 p2 + ang = direction v + len = vlength v + in p1 .+^ avec ang (len+d) + + +-- | 'northwards' : @ dist * object -> Point @ +-- +-- Project the anchor along a line from the center that goes +-- through the north anchor. +-- +-- If the distance is zero the answer with be the north anchor. +-- +-- If the distance is negative the answer within the object before +-- the north anchor. +-- +-- If the distance is positive the anchor outside the object. +-- +northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +northwards u a = extendPtDist u (center a) (north a) + + +-- | 'southwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- southwards from the center of the object. +-- +southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +southwards u a = extendPtDist u (center a) (south a) + + +-- | 'eastwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- eastwards from the center of the object. +-- +eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +eastwards u a = extendPtDist u (center a) (east a) + + +-- | 'westwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- westwards from the center of the object. +-- +westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +westwards u a = extendPtDist u (center a) (west a) + + +-- | 'northeastwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- northeastwards from the center of the object. +-- +northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +northeastwards u a = extendPtDist u (center a) (northeast a) + + +-- | 'southeastwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- southeastwards from the center of the object. +-- +southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +southeastwards u a = extendPtDist u (center a) (southeast a) + + +-- | 'southwestwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- southwestwards from the center of the object. +-- +southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +southwestwards u a = extendPtDist u (center a) (southwest a) + + +-- | 'northwestwards' : @ dist * object -> Point @ +-- +-- Variant of the function 'northwards', but projecting the line +-- northwestwards from the center of the object. +-- +northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +northwestwards u a = extendPtDist u (center a) (northwest a) + + +-------------------------------------------------------------------------------- + +-- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @ +-- +-- Find the radial connectors points for objects @a@ and @b@ along +-- the line joining their centers. +-- +radialConnectorPoints :: ( Real u, Floating u + , CenterAnchor t1, RadialAnchor t1 + , CenterAnchor t2, RadialAnchor t2 + , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) + => t1 -> t2 -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) + where + theta = direction $ pvec (center a) (center b) + + +-------------------------------------------------------------------------------- +-- Instances + +instance Fractional u => CenterAnchor (BoundingBox u) where + center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y + where + x = xl+0.5*(xr-xl) + y = ylo+0.5*(yhi-ylo) + + +instance Fractional u => CardinalAnchor (BoundingBox u) where + north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi + south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo + east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) + west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) + + +instance Fractional u => CardinalAnchor2 (BoundingBox u) where + northeast (BBox _ ur) = ur + southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo + southwest (BBox ll _) = ll + northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi + diff --git a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernal.Base.BaseDefs +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- The elementary base types and classes. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.BaseDefs + ( + + -- * A semigroup class + OPlus(..) + , oconcat + + -- * A bifunctor class + , Bimap(..) + , replaceL + , replaceR + + -- * Alignment + , HAlign(..) + , VAlign(..) + + -- * Advance vector + , AdvanceVec + , advanceH + , advanceV + + -- * Moving points + , PointDisplace + , displace + , displaceVec + , displaceH + , displaceV + + , ThetaPointDisplace + , displaceParallel + , displacePerpendicular + + + + -- * Monadic drawing + , MonUnit + + , PointSupplyM(..) + + ) where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +infixr 6 `oplus` + +-- | A Semigroup class. +-- +-- The perhaps unusual name is the TeX name for the circled plus +-- glyph. It would be nice if there was a semigroup class in the +-- Haskell Base libraries... +-- +class OPlus t where + oplus :: t -> t -> t + +oconcat :: OPlus t => t -> [t] -> t +oconcat t = step t + where + step ac [] = ac + step ac (x:xs) = step (ac `oplus` x) xs + + + +instance OPlus () where + _ `oplus` _ = () + +instance OPlus (UNil u) where + _ `oplus` _ = uNil + +instance Ord u => OPlus (BoundingBox u) where + oplus = boundaryUnion + +instance OPlus (Primitive u) where + a `oplus` b = primGroup [a,b] + +instance (OPlus a, OPlus b) => OPlus (a,b) where + (a,b) `oplus` (a',b') = (a `oplus` a', b `oplus` b') + + +instance OPlus a => OPlus (r -> a) where + f `oplus` g = \x -> f x `oplus` g x + +-- The functional instance (r -> a) also covers (r1 -> r2 -> a), +-- (r1 -> r2 -> r3 -> a) etc. + +-------------------------------------------------------------------------------- + +-- | A Bifunctor class. +-- +-- Again, it would be nice if there was a Bifunctor class in the +-- Haskell Base libraries... +-- +class Bimap f where + bimap :: (a -> p) -> (b -> q) -> f a b -> f p q + bimapL :: (a -> p) -> f a b -> f p b + bimapR :: (b -> q) -> f a b -> f a q + + + +instance Bimap (,) where + bimap f g (a,b) = (f a, g b) + bimapL f (a,b) = (f a, b) + bimapR g (a,b) = (a, g b) + +instance Bimap Either where + bimap f _ (Left a) = Left (f a) + bimap _ g (Right b) = Right (g b) + + bimapL f (Left a) = Left (f a) + bimapL _ (Right b) = Right b + + bimapR _ (Left a) = Left a + bimapR g (Right b) = Right (g b) + +replaceL :: Bimap f => p -> f a b -> f p b +replaceL = bimapL . const + +replaceR :: Bimap f => q -> f a b -> f a q +replaceR = bimapR . const + + +-------------------------------------------------------------------------------- + +-- Alignment + +-- | Horizontal alignment - align to the top, center or bottom. +-- +data HAlign = HTop | HCenter | HBottom + deriving (Enum,Eq,Ord,Show) + +-- | Vertical alignment - align to the left, center or bottom. +-- +data VAlign = VLeft | VCenter | VRight + deriving (Enum,Eq,Ord,Show) + + +-------------------------------------------------------------------------------- + +-- | Advance vectors provide an idiom for drawing consecutive +-- graphics. PostScript uses them to draw left-to-right text - +-- each character has an advance vector for the width and +-- as characters are drawn they successively displace the start +-- point for the next character with their advance vector. +-- +-- Type alias for Vec2. +-- +type AdvanceVec u = Vec2 u + + +-- | Extract the horizontal component of an advance vector. +-- +-- For left-to-right latin text, the vertical component of an +-- advance vector is expected to be 0. Ingoring it seems +-- permissible when drawing text. +-- +advanceH :: AdvanceVec u -> u +advanceH (V2 w _) = w + +-- | Extract the verticall component of an advance vector. +-- +advanceV :: AdvanceVec u -> u +advanceV (V2 _ h) = h + +-------------------------------------------------------------------------------- +-- Displacing points + +-- | 'PointDisplace' is a type representing functions +-- @from Point to Point@. +-- +-- It is especially useful for building composite graphics where +-- one part of the graphic is drawn from a different start point +-- to the other part. +-- +type PointDisplace u = Point2 u -> Point2 u + +-- | 'displace' : @ x -> y -> PointDisplace @ +-- +-- Build a combinator to move @Points@ by the supplied @x@ and +-- @y@ distances. +-- +displace :: Num u => u -> u -> PointDisplace u +displace dx dy (P2 x y) = P2 (x+dx) (y+dy) + + +-- | 'displaceV' : @ (V2 x y) -> PointDisplace @ +-- +-- Version of 'displace' where the displacement is supplied as +-- a vector rather than two parameters. +-- +displaceVec :: Num u => Vec2 u -> PointDisplace u +displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy) + + +-- | 'displaceH' : @ x -> PointDisplace @ +-- +-- Build a combinator to move @Points@ by horizontally the +-- supplied @x@ distance. +-- +displaceH :: Num u => u -> PointDisplace u +displaceH dx (P2 x y) = P2 (x+dx) y + +-- | 'displaceV' : @ y -> PointDisplace @ +-- +-- Build a combinator to move @Points@ vertically by the supplied +-- @y@ distance. +-- +displaceV :: Num u => u -> PointDisplace u +displaceV dy (P2 x y) = P2 x (y+dy) + + +-- | 'ThetaPointDisplace' is a type representing functions +-- @from Radian * Point to Point@. +-- +-- It is useful for building arrowheads which are constructed +-- with an implicit angle representing the direction of the line +-- at the arrow tip. +-- +type ThetaPointDisplace u = Radian -> PointDisplace u + + + +-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @ +-- +-- Build a combinator to move @Points@ in parallel to the +-- direction of the implicit angle by the supplied distance +-- @dist@. +-- +displaceParallel :: Floating u => u -> ThetaPointDisplace u +displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d + + +-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @ +-- +-- Build a combinator to move @Points@ perpendicular to the +-- direction of the implicit angle by the supplied distance +-- @dist@. +-- +displacePerpendicular :: Floating u => u -> ThetaPointDisplace u +displacePerpendicular d = + \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d + + +-------------------------------------------------------------------------------- +-- Monadic drawing + +-- | DUnit is always for fully saturated type constructors, so +-- (seemingly) an equivalent type family is needed for monads. + +type family MonUnit m :: * + + +-- | A monad that supplies points, e.g. a turtle monad. +-- +-- \*\* WARNING \*\* - the idea behind this class is somewhat +-- half-baked. It may be revised or even dropped in subsequent +-- versions of Wumpus-Basic. +-- +class Monad m => PointSupplyM (m :: * -> *) where + position :: MonUnit m ~ u => m (Point2 u) diff --git a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs @@ -0,0 +1,541 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.ContextFun +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Function types operating over the DrawingContext as a /static/ +-- argument. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.ContextFun + ( + + -- * /Context functional/ types + CF + , CF1 + , CF2 + + , LocCF + , LocThetaCF + , ConnectorCF + , DLocCF + , DLocThetaCF + , DConnectorCF + + + + -- * Run functions + , runCF + , runCF1 + , runCF2 + + -- * Lift functions + , lift0R1 + , lift0R2 + , lift1R2 + + , promoteR1 + , promoteR2 + + + , apply1R1 + , apply2R2 + , apply1R2 + + -- * Extractors + , drawingCtx + , queryCtx + , locCtx + , locPoint + , locThetaCtx + , locThetaPoint + , locThetaAng + , connCtx + , connStart + , connEnd + + -- * Combinators + , at + , rot + , connect + , chain1 + + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.DrawingContext + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative +import Data.Monoid + + +-------------------------------------------------------------------------------- +-- + +-- | Most drawing operations in Wumpus-Basic have an implicit +-- /graphics state/ the 'DrawingContext', so the most primitive +-- building block is a function from the DrawingContext to some +-- polymorphic answer. +-- +-- This functional type is represented concretely as the initials +-- @CF@ for /contextual function/. +-- +-- > CF :: DrawingContext -> a +-- +newtype CF a = CF { unCF :: DrawingContext -> a } + + +-- | Variation of 'CF' with one parametric /static argument/. +-- +-- The static argument is commonly a point representing the start +-- point / origin of a drawing. +-- +-- > CF1 :: DrawingContext -> r1 -> a +-- +newtype CF1 r1 a = CF1 { unCF1 :: DrawingContext -> r1 -> a } + + +-- | Variation of 'CF' with two parametric /static arguments/. +-- +-- The first argument is commonly a point representing the start +-- point / origin of a drawing. The second argument might +-- typically be the angle of displacement (for drawing arrowheads) +-- or an end point (for drawing connectors between two points). +-- +-- > CF2 :: DrawingContext -> r1 -> r2 -> a +-- +newtype CF2 r1 r2 a = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a } + + + +-- | Type specialized verison of 'CF1' where the /static argument/ +-- is the /start point/. +-- +-- > LocCF :: DrawingContext -> Point2 u -> a +-- +type LocCF u a = CF1 (Point2 u) a + + +-- | Type specialized verison of 'CF2' where the /static arguments/ +-- are the /start point/ and the /angle of displacement/. +-- +-- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a +-- +type LocThetaCF u a = CF2 (Point2 u) Radian a + + +-- | Type specialized verison of 'CF2' where the /static arguments/ +-- are the /start point/ and the /end point/. +-- +-- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a +-- +type ConnectorCF u a = CF2 (Point2 u) (Point2 u) a + + +-- | Alias of 'LocCF' where the unit type is specialized to +-- @Double@. +-- +type DLocCF a = LocCF Double a + + +-- | Alias of 'LocThetaCF' where the unit type is specialized to +-- @Double@. +-- +type DLocThetaCF a = LocThetaCF Double a + +-- | Alias of 'ConnectorCF' where the unit type is specialized to +-- @Double@. +-- +type DConnectorCF a = ConnectorCF Double a + + + +-------------------------------------------------------------------------------- +-- CF instances + +-- OPlus + +instance OPlus a => OPlus (CF a) where + fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx + +instance OPlus a => OPlus (CF1 r1 a) where + fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1 + +instance OPlus a => OPlus (CF2 r1 r2 a) where + fa `oplus` fb = CF2 $ \ctx r1 r2 -> + unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2 + + +-- Monoid + +-- Nothing is stopping monoid instances, though in practice there +-- might be few useful types (more in Semgigroup / OPlus)... + +instance Monoid a => Monoid (CF a) where + mempty = CF $ \_ -> mempty + fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx + +instance Monoid a => Monoid (CF1 r1 a) where + mempty = CF1 $ \_ _ -> mempty + fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1 + +instance Monoid a => Monoid (CF2 r1 r2 a) where + mempty = CF2 $ \_ _ _ -> mempty + fa `mappend` fb = CF2 $ \ctx r1 r2 -> + unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2 + + + +-- Functor + +instance Functor CF where + fmap f ma = CF $ \ctx -> f $ unCF ma ctx + + +instance Functor (CF1 r1) where + fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 + +instance Functor (CF2 r1 r2) where + fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2 + + + +-- Applicative + +instance Applicative CF where + pure a = CF $ \_ -> a + mf <*> ma = CF $ \ctx -> let f = unCF mf ctx + a = unCF ma ctx + in f a + + +instance Applicative (CF1 r1) where + pure a = CF1 $ \_ _ -> a + mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 + a = unCF1 ma ctx r1 + in f a + + +instance Applicative (CF2 r1 r2) where + pure a = CF2 $ \_ _ _ -> a + mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2 + a = unCF2 ma ctx r1 r2 + in f a + + + + +-- Monad + +instance Monad CF where + return a = CF $ \_ -> a + ma >>= k = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx + +instance Monad (CF1 r1) where + return a = CF1 $ \_ _ -> a + ma >>= k = CF1 $ \ctx r1 -> let a = unCF1 ma ctx r1 in (unCF1 . k) a ctx r1 + +instance Monad (CF2 r1 r2) where + return a = CF2 $ \_ _ _ -> a + ma >>= k = CF2 $ \ctx r1 r2 -> + let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2 + + + +-- DrawingCtxM + +instance DrawingCtxM CF where + askDC = CF $ \ctx -> ctx + localize upd df = CF $ \ctx -> unCF df (upd ctx) + + +instance DrawingCtxM (CF1 r1) where + askDC = CF1 $ \ctx _ -> ctx + localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1 + + +instance DrawingCtxM (CF2 r1 r2) where + askDC = CF2 $ \ctx _ _ -> ctx + localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2 + + +-- Note - there is nothing determining a DUnit for the CF types, +-- so it seems appropriate not to define affine instances. +-- +-- However affine instances can be made for the Image type in +-- Objects.BaseObjects. +-- + + +-------------------------------------------------------------------------------- +-- Run functions + +-- | Run a /CF/ (context function) with the supplied +-- /DrawingContext/. +-- +runCF :: DrawingContext -> CF a -> a +runCF ctx df = unCF df ctx + + +-- | Run a /CF1/ (context function) with the supplied +-- /DrawingContext/ and static argument. +-- +runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a +runCF1 ctx r1 df = unCF1 df ctx r1 + + +-- | Run a /CF1/ (context function) with the supplied +-- /DrawingContext/ and two static arguments. +-- +runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a +runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2 + + + +-------------------------------------------------------------------------------- +-- lift functions + + +-- | Lift a zero-arity context function 'CF' to an arity one +-- context function 'CF1'. +-- +lift0R1 :: CF a -> CF1 r1 a +lift0R1 mf = CF1 $ \ctx _ -> unCF mf ctx + +-- | Lift a zero-arity context function 'CF' to an arity two +-- context function 'CF2'. +-- +lift0R2 :: CF a -> CF2 r1 r2 a +lift0R2 mf = CF2 $ \ctx _ _ -> unCF mf ctx + +-- | Lift an arity one context function 'CF1' to an arity two +-- context function 'CF2'. +-- +lift1R2 :: CF1 r1 a -> CF2 r1 r2 a +lift1R2 mf = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1 + + + +-- | Promote a function @from one argument to a Context function@ +-- to an arity one @Context function@. +-- +-- The type signature is as explanatory as a description: +-- +-- > promoteR1 :: (r1 -> CF a) -> CF1 r1 a +-- +promoteR1 :: (r1 -> CF a) -> CF1 r1 a +promoteR1 mf = CF1 $ \ctx r1 -> unCF (mf r1) ctx + +-- | Promote a function @from two arguments to a Context function@ +-- to an arity two @Context function@. +-- +-- The type signature is as explanatory as a description: +-- +-- > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a +-- +promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a +promoteR2 mf = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx + + + +-- | Apply an arity-one Context function to a single argument, +-- downcasting it by one level, making an arity-zero Context +-- function. +-- +-- The type signature is as explanatory as a description: +-- +-- > apply1R1 :: CF1 r1 a -> r1 -> CF a +-- +apply1R1 :: CF1 r1 a -> r1 -> CF a +apply1R1 mf r1 = CF $ \ctx -> unCF1 mf ctx r1 + + +-- | Apply an arity-two Context function to two arguments, +-- downcasting it by two levels, making an arity-zero Context +-- function. +-- +-- The type signature is as explanatory as a description: +-- +-- > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a +-- +apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a +apply2R2 mf r1 r2 = CF $ \ctx -> unCF2 mf ctx r1 r2 + +-- | Apply an arity-two Context function to one argument, +-- downcasting it by one level, making an arity-one Context +-- function. +-- +-- The type signature is as explanatory as a description: +-- +-- > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a +-- +apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a +apply1R2 mf r2 = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2 + + +-------------------------------------------------------------------------------- +-- extractors + +-- | Extract the drawing context from a CtxFun. +-- +-- > (ctx -> ctx) +-- +drawingCtx :: CF DrawingContext +drawingCtx = CF $ \ctx -> ctx + +-- | Apply the projection function to the drawing context. +-- +-- > (ctx -> a) -> (ctx -> a) +-- +queryCtx :: (DrawingContext -> a) -> CF a +queryCtx f = CF $ \ctx -> f ctx + + +-- | Extract the drawing context from a LocCF. +-- +-- > (ctx -> pt -> ctx) +-- +locCtx :: LocCF u DrawingContext +locCtx = CF1 $ \ctx _ -> ctx + +-- | Extract the /start/ point from a LocCF. +-- +-- > (ctx -> pt -> pt) +-- +locPoint :: LocCF u (Point2 u) +locPoint = CF1 $ \_ pt -> pt + + +-- | Extract the drawing context from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> ctx) +-- +locThetaCtx :: LocThetaCF u DrawingContext +locThetaCtx = CF2 $ \ctx _ _ -> ctx + + +-- | Extract the /start/ point from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> pt) +-- +locThetaPoint :: LocThetaCF u (Point2 u) +locThetaPoint = CF2 $ \_ pt _ -> pt + +-- | Extract the angle from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> ang) +-- +locThetaAng :: LocThetaCF u Radian +locThetaAng = CF2 $ \_ _ ang -> ang + +-- | Extract the drawing context from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> ctx) +-- +connCtx :: ConnectorCF u DrawingContext +connCtx = CF2 $ \ctx _ _ -> ctx + +-- | Extract the start point from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> pt1) +-- +connStart :: ConnectorCF u (Point2 u) +connStart = CF2 $ \_ pt _ -> pt + +-- | Extract the end point from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> pt2) +-- +connEnd :: ConnectorCF u (Point2 u) +connEnd = CF2 $ \_ _ pt -> pt + + + + + +-------------------------------------------------------------------------------- +-- Combinators + + + +infixr 1 `at` + + +-- | Downcast a 'LocCF' function by applying it to the supplied +-- point, making an arity-zero Context function. +-- +-- Remember a 'LocCF' function is a 'CF1' context function where +-- the /static argument/ is specialized to a start point. +-- +at :: LocCF u a -> Point2 u -> CF a +at = apply1R1 + + +infixr 1 `rot` + + +-- | Downcast a 'LocThetaCF' function by applying it to the +-- supplied angle, making an arity-one Context function (a +-- 'LocCF'). +-- + +rot :: LocThetaCF u a -> Radian -> LocCF u a +rot = apply1R2 + + +-- | Downcast a 'ConnectorCF' function by applying it to the +-- start and end point, making an arity-zero Context function +-- (a 'CF'). +-- +connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a +connect = apply2R2 + + + +infixr 6 `chain1` + +-- | /Chaining/ combinator - the /answer/ of the +-- first Context function is feed to the second Context function. +-- +-- This contrasts with the usual idiom in @Wumpus-Basic@ where +-- composite graphics are built by applying both functions to the +-- same initial /static argument/. +-- +-- Desciption: +-- +-- Evaluate the first Context Function with the drawing context +-- and the /initial state/ @st0@. The result of the evaluation is +-- a new /state/ @st1@ and and answer @a1@. +-- +-- Evaluate the second Context Function with the drawing context +-- and the new state @st1@, producing a new state @s2@ and an +-- answer @a2@. +-- +-- Return the result of combining the answers with +-- @op :: (ans -> ans -> ans)@ and the second state @s2@. +-- +-- @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @ +-- +-- This models chaining start points together, which is the model +-- PostScript uses for text output when successively calling the +-- @show@ operator. +-- +chain1 :: OPlus w + => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w) +chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s + (s2,a2) = unCF1 g ctx s1 + in (s2, a1 `oplus` a2) + + diff --git a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.DrawingContext +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Drawing attributes +-- +-- \*\* WARNING \*\* - this module needs systematic naming +-- schemes both for update functions (primaryColour, ...) and +-- for synthesized selectors (e.g. lowerxHeight). The current +-- names will change. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.DrawingContext + ( + + -- * Drawing context + DrawingContext(..) + , DrawingContextF + + , standardContext + , metricsContext + + , default_drawing_context + + -- * DrawingCtxM (reader) monad + , DrawingCtxM(..) + , asksDC + + + -- * Glyph metrics + , withFontMetrics + + + ) where + + +import Wumpus.Basic.Kernel.Base.GlyphMetrics + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.StandardEncoding + +import Control.Applicative +import Data.Maybe + + +data DrawingContext = DrawingContext + { glyph_tables :: GlyphMetrics + , fallback_metrics :: MetricsOps + , stroke_props :: StrokeAttr + , font_props :: FontAttr + , stroke_colour :: RGBi -- also text colour... + , fill_colour :: RGBi + , line_spacing_factor :: Double + } + +-- TODO - hand craft a Show instance + +type DrawingContextF = DrawingContext -> DrawingContext + + +standardContext :: FontSize -> DrawingContext +standardContext sz = + DrawingContext { glyph_tables = emptyGlyphMetrics + , fallback_metrics = monospace_metrics + , stroke_props = default_stroke_attr + , font_props = FontAttr sz wumpus_courier + , stroke_colour = wumpus_black + , fill_colour = wumpus_light_gray + , line_spacing_factor = 1.2 + } + +-- out-of-date - should be adding loaded fonts, not replacing the +-- GlyphMetrics Map wholesale. +-- +metricsContext :: FontSize -> GlyphMetrics -> DrawingContext +metricsContext sz bgm = + DrawingContext { glyph_tables = bgm + , fallback_metrics = monospace_metrics + , stroke_props = default_stroke_attr + , font_props = FontAttr sz wumpus_courier + , stroke_colour = wumpus_black + , fill_colour = wumpus_light_gray + , line_spacing_factor = 1.2 + } + + + + +wumpus_black :: RGBi +wumpus_black = RGBi 0 0 0 + +wumpus_light_gray :: RGBi +wumpus_light_gray = RGBi 200 200 200 + + +-- | Courier +-- +wumpus_courier :: FontFace +wumpus_courier = + FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding + + + +default_drawing_context :: DrawingContext +default_drawing_context = + standardContext (font_size wumpus_default_font) + + + +-------------------------------------------------------------------------------- + + +class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where + askDC :: m DrawingContext + localize :: (DrawingContext -> DrawingContext) -> m a -> m a + + +-- | Project a value out of a context. +-- +asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a +asksDC f = askDC >>= (return . f) + + + +-------------------------------------------------------------------------------- +-- Glyph metrics + +-- These are directly on the DrawingContext /for efficiency/. + + + +withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u +withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = + fn metric_set point_sz + where + ps_name = ps_font_name $ font_face font_stats + point_sz = fromIntegral $ font_size font_stats + metric_set = fromMaybe (fallback_metrics ctx) $ + lookupFont ps_name (glyph_tables ctx) + + diff --git a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.GlyphMetrics +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Data types representing glyph metrics loaded from font files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.GlyphMetrics + ( + + FontName + , CodePoint + , CharWidthTable + , MetricsOps(..) + , FontMetricsOps(..) + + , GlyphMetrics + , emptyGlyphMetrics + , lookupFont + , insertFont + + , monospace_metrics + + + ) where + +import Wumpus.Core -- package: wumpus-core + +import qualified Data.Map as Map +import Data.Monoid + + + +type FontName = String + +-- | A Unicode code-point. +-- +type CodePoint = Int + +-- | A lookup from code point to /width vector/. +-- +-- Note - in PostScript terminology a width vector is not obliged +-- to be left-to-right (writing direction 0). It could be +-- top-to-bottom (writing direction 1). +-- +type CharWidthTable u = CodePoint -> Vec2 u + + + +-- | Operations on the metrics set of a font. +-- +-- The is the internal representation used by Wumpus-Basic after +-- parsing the font file. +-- +data MetricsOps = MetricsOps + { get_bounding_box :: forall u. FromPtSize u => PtSize -> BoundingBox u + , get_cw_table :: forall u. FromPtSize u => PtSize -> CharWidthTable u + , get_cap_height :: forall u. FromPtSize u => PtSize -> u + } + +-- | 'MetricsOps' tfor a particular named font. +-- +data FontMetricsOps = FontMetricsOps FontName MetricsOps + + +-- | A map between a font name and MetricsOps. +-- +newtype GlyphMetrics = GlyphMetrics { + getGlyphMetrics :: Map.Map FontName MetricsOps } + +instance Monoid GlyphMetrics where + mempty = emptyGlyphMetrics + a `mappend` b = GlyphMetrics $ getGlyphMetrics a `mappend` getGlyphMetrics b + + +emptyGlyphMetrics :: GlyphMetrics +emptyGlyphMetrics = GlyphMetrics $ Map.empty + +lookupFont :: FontName -> GlyphMetrics -> Maybe MetricsOps +lookupFont name = Map.lookup name . getGlyphMetrics + +insertFont :: FontMetricsOps -> GlyphMetrics -> GlyphMetrics +insertFont (FontMetricsOps name ops) = + GlyphMetrics . Map.insert name ops . getGlyphMetrics + +-- | This ignores the Char code lookup and just returns the +-- default advance vector. +-- +monospace_metrics :: MetricsOps +monospace_metrics = MetricsOps + { get_bounding_box = \sz -> BBox (lowerLeft sz) (upperRight sz) + , get_cw_table = \sz _ -> hvec (upscale sz width_vec) + , get_cap_height = \sz -> upscale sz cap_height + } + where + llx = (-23) / 1000 + lly = (-250) / 1000 + urx = 715 / 1000 + ury = 805 / 1000 + width_vec = 600 / 1000 + cap_height = 562 / 1000 + + upscale sz d = fromPtSize $ sz * d + lowerLeft sz = P2 (upscale sz llx) (upscale sz lly) + upperRight sz = P2 (upscale sz urx) (upscale sz ury) + + diff --git a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs @@ -0,0 +1,263 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.QueryDC +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Querying the Drawing Context. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.QueryDC + ( + + + textAttr + , withTextAttr + + , strokeAttr + , withStrokeAttr + + , fillAttr + , withFillAttr + + , borderedAttr + , withBorderedAttr + + , getLineWidth + , getFontAttr + , getFontSize + , getFontFace + , markHeight + , markHalfHeight + , baselineSpacing + + -- * Glyph metrics + , glyphBoundingBox + , glyphHeightRange + , glyphHeight + , glyphCapHeight + + , cwLookupTable + + -- * Default monospace metrics + + , monoFontPointSize + , monoCharWidth + , monoTextWidth + , monoTextLength + , monoCapHeight + , monoLowerxHeight + , monoDescenderDepth + , monoAscenderHeight + , monoTextDimensions + , monoMultiLineHeight + , monoDefaultPadding + , monoVecToCenter + ) where + +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.GlyphMetrics + +import Wumpus.Core -- package: wumpus-core +import qualified Wumpus.Core.FontSize as FS + +import Control.Applicative + + +textAttr :: DrawingCtxM m => m (RGBi,FontAttr) +textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props + +-- | Because @textAttr@ is so commonly used here is a functional +-- version that avoids tupling. +-- +withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a +withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props + + +strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) +strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props + +withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a +withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props + + +fillAttr :: DrawingCtxM m => m RGBi +fillAttr = asksDC fill_colour + +withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a +withFillAttr fn = fn <$> asksDC fill_colour + +borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi) +borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props + <*> asksDC stroke_colour + +withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a +withBorderedAttr fn = + fn <$> asksDC fill_colour <*> asksDC stroke_props + <*> asksDC stroke_colour + + + + +getLineWidth :: DrawingCtxM m => m Double +getLineWidth = line_width <$> asksDC stroke_props + +getFontAttr :: DrawingCtxM m => m FontAttr +getFontAttr = asksDC font_props + +getFontSize :: DrawingCtxM m => m Int +getFontSize = font_size <$> asksDC font_props + +getFontFace :: DrawingCtxM m => m FontFace +getFontFace = font_face <$> asksDC font_props + + + + +-- | Vertical distance between baselines of consecutive text +-- lines. +-- +baselineSpacing :: (DrawingCtxM m, Fractional u) => m u +baselineSpacing = + (\sz factor -> realToFrac $ factor * fromIntegral sz) + <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor + +-- | The /mark/ height is the height of a lowercase letter in the +-- current font. +-- +-- Arrowheads, dots etc. should generally be drawn at the mark +-- height. +-- +markHeight :: (DrawingCtxM m, FromPtSize u) => m u +markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props + + +markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u +markHalfHeight = (0.5*) <$> markHeight + + +-- Note - there are probably enough functions that use just +-- markHeight to merit a withMarkHeight function. + + +-------------------------------------------------------------------------------- + +glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u +glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC + +glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) +glyphBoundingBox = glyphQuery get_bounding_box + + +glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u) +glyphHeightRange = fn <$> glyphBoundingBox + where + fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax) + + +glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u +glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange + + +glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u +glyphCapHeight = glyphQuery get_cap_height + +cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u) +cwLookupTable = glyphQuery get_cw_table + + +-------------------------------------------------------------------------------- + +withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u +withFontSize fn = (fn . font_size) <$> asksDC font_props + + +-- NOTE - textHeight in Wumpus-Core should be renamed as it is +-- (probably) more indiactive of Cap height than /font point size/ +-- + +monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u +monoFontPointSize = withFontSize (fromPtSize . fromIntegral) + +monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u +monoCharWidth = withFontSize (fromPtSize . FS.charWidth) + + +monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u +monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n + + +monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u +monoTextLength ss = monoTextWidth $ charCount ss + + +monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoCapHeight = withFontSize (fromPtSize . FS.capHeight) + +monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight) + + + +-- | Height of a lower case \'x\' in Courier. +-- +-- \'x\' has no ascenders or descenders. +-- +monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight) + +monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u +monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) + +monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) + + +-- | Query the dimensions of the text using the current font size +-- but using metrics derived from Courier. +-- +-- Note - the width will generally be a over-estimate for +-- non-monospaced fonts. +-- +monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u) + => String -> m (u,u) +monoTextDimensions ss = + (\sz -> post $ textBounds sz zeroPt ss) + <$> asksDC (font_size . font_props) + where + post bb = (boundaryWidth bb, boundaryHeight bb) + + +-- | The heigth of @n@ lines of text, which is +-- @n lines + n-1 line spacers@ +-- +monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) + => Int -> m u +monoMultiLineHeight n | n < 0 = pure 0 +monoMultiLineHeight n = + (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf)) + <$> monoTotalCharHeight <*> asksDC line_spacing_factor + + -- Note as the height calculation has changed in Wumpus-Core this + -- no longer quite works... + + + +-- | The default padding is half of the /char width/. +-- +monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u +monoDefaultPadding = (0.5*) <$> monoCharWidth + +-- | Vector from baseline left to center +-- +monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) + => String -> m (Vec2 u) +monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) + <$> monoTextDimensions ss <*> monoDescenderDepth diff --git a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.ScalingContext +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Scaling in X and Y +-- +-- \*\* WARNING \*\* - half baked. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.ScalingContext + ( + + ScalingM(..) + , ScalingContext(..) + + , Scaling + , runScaling + , ScalingT + , runScalingT + + , regularScalingContext + , coordinateScalingContext + + , unitX + , unitY + + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.WrappedPrimitive + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + + +-- | Scaling... +-- +class Monad m => ScalingM m where + type XDim m :: * + type YDim m :: * + scaleX :: (u ~ MonUnit m, ux ~ XDim m) => ux -> m u + scaleY :: (u ~ MonUnit m, uy ~ YDim m) => uy -> m u + scalePt :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) + => ux -> uy -> m (Point2 u) + scaleVec :: (u ~ MonUnit m, ux ~ XDim m, uy ~ YDim m) + => ux -> uy -> m (Vec2 u) + + + +data ScalingContext ux uy u = ScalingContext + { scale_in_x :: ux -> u + , scale_in_y :: uy -> u + } + + + +-- Chains (for example) want a plain monad rather than a transformer. +-- +newtype Scaling ux uy u a = Scaling { + getScaling :: ScalingContext ux uy u -> a } + + +type instance MonUnit (Scaling ux uy u) = u + + + +instance Functor (Scaling ux uy u) where + fmap f ma = Scaling $ \ctx -> let a = getScaling ma ctx in f a + +instance Applicative (Scaling ux uy u) where + pure a = Scaling $ \_ -> a + mf <*> ma = Scaling $ \ctx -> let f = getScaling mf ctx + a = getScaling ma ctx + in (f a) + +instance Monad (Scaling ux uy u) where + return a = Scaling $ \_ -> a + m >>= k = Scaling $ \ctx -> let a = getScaling m ctx + in (getScaling . k) a ctx + + + +instance ScalingM (Scaling ux uy u) where + type XDim (Scaling ux uy u) = ux + type YDim (Scaling ux uy u) = uy + scaleX ux = Scaling $ \ctx -> (scale_in_x ctx) ux + scaleY uy = Scaling $ \ctx -> (scale_in_y ctx) uy + scalePt ux uy = Scaling $ \ctx -> P2 (scale_in_x ctx ux) (scale_in_y ctx uy) + scaleVec ux uy = Scaling $ \ctx -> V2 (scale_in_x ctx ux) (scale_in_y ctx uy) + +runScaling :: ScalingContext ux uy u -> Scaling ux uy u a -> a +runScaling ctx sf = (getScaling sf) ctx + + + + +-------------------------------------------------------------------------------- +-- Transformer + +-- Turtle (for example) wants a transformer so it can use TraceM +-- and DrawingCtxM +-- +newtype ScalingT ux uy u m a = ScalingT { + getScalingT :: ScalingContext ux uy u -> m a } + +type instance MonUnit (ScalingT ux uy u m) = u + + +instance Monad m => Functor (ScalingT ux uy u m) where + fmap f ma = ScalingT $ \ctx -> getScalingT ma ctx >>= \a -> return (f a) + +instance Monad m => Applicative (ScalingT ux uy u m) where + pure a = ScalingT $ \_ -> return a + mf <*> ma = ScalingT $ \ctx -> getScalingT mf ctx >>= \f -> + getScalingT ma ctx >>= \a -> + return (f a) + +instance Monad m => Monad (ScalingT ux uy u m) where + return a = ScalingT $ \_ -> return a + m >>= k = ScalingT $ \ctx -> getScalingT m ctx >>= \a -> + (getScalingT . k) a ctx + + +instance Monad m => ScalingM (ScalingT ux uy u m) where + type XDim (ScalingT ux uy u m) = ux + type YDim (ScalingT ux uy u m) = uy + scaleX ux = ScalingT $ \ctx -> return $ (scale_in_x ctx) ux + scaleY uy = ScalingT $ \ctx -> return $ (scale_in_y ctx) uy + scalePt ux uy = ScalingT $ \ctx -> + return $ P2 (scale_in_x ctx ux) (scale_in_y ctx uy) + scaleVec ux uy = ScalingT $ \ctx -> + return $ V2 (scale_in_x ctx ux) (scale_in_y ctx uy) + + + +-- Cross instances - needed to run SalingT /locally/ in Drawing. + +instance DrawingCtxM m => DrawingCtxM (ScalingT ux uy u m) where + askDC = ScalingT $ \_ -> askDC >>= \dctx -> return dctx + localize upd mf = ScalingT $ \sctx -> localize upd (getScalingT mf sctx) + + +instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (ScalingT ux uy u m) where + trace a = ScalingT $ \_ -> trace a + + + + +runScalingT :: ScalingContext ux uy u -> ScalingT ux uy u m a -> m a +runScalingT ctx sf = (getScalingT sf) ctx + +-------------------------------------------------------------------------------- +-- constructors for scaling context + +regularScalingContext :: Num u => u -> ScalingContext u u u +regularScalingContext u = ScalingContext + { scale_in_x = (\x -> u*x) + , scale_in_y = (\y -> u*y) + } + +coordinateScalingContext :: Num u => u -> u -> ScalingContext Int Int u +coordinateScalingContext sx sy = ScalingContext + { scale_in_x = (\x -> sx * fromIntegral x) + , scale_in_y = (\y -> sy * fromIntegral y) + } + + + +-------------------------------------------------------------------------------- +-- operations + + + + +unitX :: (ScalingM m, Num ux, ux ~ XDim m, u ~ MonUnit m) => m u +unitX = scaleX 1 + +unitY :: (ScalingM m, Num uy, uy ~ YDim m, u ~ MonUnit m) => m u +unitY = scaleY 1 + + diff --git a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs @@ -0,0 +1,244 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.UpdateDC +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Customize drawing attributes +-- +-- \*\* WARNING \*\* - this module needs systematic naming +-- schemes both for update functions (primaryColour, ...) and +-- for synthesized selectors (e.g. lowerxHeight). The current +-- names will change. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.UpdateDC + ( + + -- * Modifiers + -- ** Line widths + lineWidth + , thick + , ultrathick + , thin + + -- ** Line caps + , capButt + , capRound + , capSquare + + -- ** Line joins + , joinMiter + , joinRound + , joinBevel + + -- ** Dash Pattern + , dashPattern + , unit_dash_pattern + , phase + , dphase + , doublegaps + , doubledashes + + -- * Font properties + , fontAttr + , fontSize + , fontFace + + -- * Font / mark drawing size + , doublesize + , halfsize + + -- * Colour + , swapColours + , bothStrokeColour + , bothFillColour + , strokeColour + , fillColour + + + + ) where + + +import Wumpus.Basic.Kernel.Base.DrawingContext + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +-------------------------------------------------------------------------------- + +updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF +updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props + +updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF +updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props + + +-------------------------------------------------------------------------------- +-- line widths + +-- Note - some care might be needed if we ever define other unit +-- types... + +lineWidth :: Double -> DrawingContextF +lineWidth d = updateStrokeProps (\s -> s { line_width = d }) + + +-- std_line_width :: Double +-- std_line_width = 1.0 + +thick_line :: Double +thick_line = 2.0 + +ultra_thick_line :: Double +ultra_thick_line = 4.0 + +thin_line :: Double +thin_line = 0.5 + + +-- | Set the line width to a /thick/. +-- +-- Note this context update is /oblivious/ - operationally the +-- line width is set to exactly @2.0@. +-- +thick :: DrawingContextF +thick = lineWidth thick_line + +ultrathick :: DrawingContextF +ultrathick = lineWidth ultra_thick_line + +thin :: DrawingContextF +thin = lineWidth thin_line + + +-------------------------------------------------------------------------------- + +setLineCap :: LineCap -> DrawingContextF +setLineCap d = updateStrokeProps (\s -> s { line_cap = d }) + + +capButt :: DrawingContextF +capButt = setLineCap CapButt + +capRound :: DrawingContextF +capRound = setLineCap CapRound + +capSquare :: DrawingContextF +capSquare = setLineCap CapSquare + + +setLineJoin :: LineJoin -> DrawingContextF +setLineJoin d = updateStrokeProps (\s -> s { line_join = d }) + + +joinMiter :: DrawingContextF +joinMiter = setLineJoin JoinMiter + +joinRound :: DrawingContextF +joinRound = setLineJoin JoinRound + +joinBevel :: DrawingContextF +joinBevel = setLineJoin JoinBevel + + +-------------------------------------------------------------------------------- + +dashPattern :: DashPattern -> DrawingContextF +dashPattern d = updateStrokeProps (\s -> s { dash_pattern = d }) + +unit_dash_pattern :: DashPattern +unit_dash_pattern = Dash 0 [(1,1)] + +-- oblivious +phase :: Int -> DashPattern -> DashPattern +phase _ Solid = Solid +phase i (Dash _ xs) = Dash i xs + +-- non-oblivious +dphase :: Int -> DashPattern -> DashPattern +dphase _ Solid = Solid +dphase d (Dash i xs) = Dash (i+d) xs + +doublegaps :: DashPattern -> DashPattern +doublegaps Solid = Solid +doublegaps (Dash i xs) = Dash i (map fn xs) + where + fn (a,b) = (a,2*b) + +doubledashes :: DashPattern -> DashPattern +doubledashes Solid = Solid +doubledashes (Dash i xs) = Dash i (map fn xs) + where + fn (a,b) = (a*2,b) + + +-------------------------------------------------------------------------------- + +fontAttr :: FontFace -> Int -> DrawingContextF +fontAttr ff sz = (\s -> s { font_props = FontAttr sz ff }) + +fontFace :: FontFace -> DrawingContextF +fontFace ff = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff) + +fontSize :: Int -> DrawingContextF +fontSize sz = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) + + +-------------------------------------------------------------------------------- + +-- | Set the font size to double the current size, note the font +-- size also controls the size of dots, arrowsheads etc. +-- +doublesize :: DrawingContextF +doublesize = (\s sz -> fontSize (sz*2) s) + <*> (font_size . font_props) + + +-- | Set the font size to half the current size, note the font +-- size also controls the size of dots, arrowsheads etc. +-- +-- As fontsize is an integer this is not exact - half size of +-- 15pt type is 7pt. +-- +halfsize :: DrawingContextF +halfsize = (\s sz -> fontSize (sz `div` 2) s) + <*> (font_size . font_props) + + +-------------------------------------------------------------------------------- + +swapColours :: DrawingContextF +swapColours = + (\s a b -> s { stroke_colour = b, fill_colour = a }) + <*> stroke_colour <*> fill_colour + +bothStrokeColour :: DrawingContextF +bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour + +bothFillColour :: DrawingContextF +bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour + + + +strokeColour :: RGBi -> DrawingContextF +strokeColour rgb = \s -> s { stroke_colour = rgb } + + +fillColour :: RGBi -> DrawingContextF +fillColour rgb = \s -> s { fill_colour = rgb } + + + + diff --git a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.WrappedPrimitive +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Two /warpped/ versions of the Primitive type from Wumpus-Core. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.WrappedPrimitive + ( + + -- * Primitives + HPrim + , hprimToList + , singleH + + -- * Collect primitives (writer monad) + , TraceM(..) + + , PrimGraphic + + , getPrimGraphic + , primGraphic + , metamorphPrim + , collectH + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Utils.HList + +import Wumpus.Core -- package: wumpus-core + + +import Data.Monoid + + + +-- As of version 0.36.0, Wumpus-Core supports grouping primitives +-- together (a common operation in vector drawing editors). +-- +-- For Wumpus-Basic this means e.g. a line with arrowheads can +-- still be a primitive. +-- +-- Still, we wrap Primitive as a newtype... +-- + +newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u } + deriving (Eq,Show) + + +type instance DUnit (PrimGraphic u) = u + + + +-------------------------------------------------------------------------------- +-- Lists of primitives... + +-- | Graphics objects, even simple ones (line, arrow, dot) might +-- need more than one primitive (path or text label) for their +-- construction. Hence, the primary representation that all the +-- others are built upon must support /concatenation/ of +-- primitives. +-- +-- Wumpus-Core has a type Picture - made from one or more +-- Primitives - but Pictures include support for affine frames. +-- For drawing many simple graphics (dots, connector lines...) +-- that do not need individual affine transformations this is a +-- penalty. A list of Primitives is therefore more suitable +-- representation, and a Hughes list which supports +-- efficient concatenation is wise. +-- +newtype HPrim u = HPrim { getHPrim :: H (Primitive u) } + +-- Note - only a Monoid instance for HPrim - they cannot be +-- shown, fmapped etc. + +instance Monoid (HPrim u) where + mempty = HPrim emptyH + ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb + + +hprimToList :: HPrim u -> [Primitive u] +hprimToList = toListH . getHPrim + + +singleH :: Primitive u -> HPrim u +singleH = HPrim . wrapH + + +-------------------------------------------------------------------------------- + +-- | Collect elementary graphics as part of a larger drawing. +-- +-- TraceM works much like a writer monad. +-- +class TraceM (m :: * -> *) where + trace :: MonUnit m ~ u => HPrim u -> m () + + + + + +-------------------------------------------------------------------------------- +-- instances + +instance OPlus (PrimGraphic u) where + oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b + + +-- Affine transformations + +instance (Real u, Floating u) => Rotate (PrimGraphic u) where + rotate ang = PrimGraphic . rotate ang . getPrimGraphic + + +instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where + rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic + + +instance Num u => Scale (PrimGraphic u) where + scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic + + +instance Num u => Translate (PrimGraphic u) where + translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic + +-------------------------------------------------------------------------------- + +primGraphic :: Primitive u -> PrimGraphic u +primGraphic = PrimGraphic + +metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u +metamorphPrim f = primGraphic . f . getPrimGraphic + +collectH :: PrimGraphic u -> HPrim u +collectH = singleH . getPrimGraphic + diff --git a/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs b/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs @@ -0,0 +1,172 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Geometry.Intersection +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Intersection of line to line and line to plane +-- +-- \*\* - WARNING \*\* - half baked. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Geometry.Intersection + ( + LineSegment(..) + , PointSlope + , pointSlope + , LineEqn + , lineEqn + , toLineEqn + , findIntersect + , intersection + + , rectangleLines + , polygonLines + , langle + ) + where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + + +-- WARNING - This module is not very good (neither particularly +-- robust, nor efficient). +-- +-- I really need to find an algorithm that does this properly. +-- + +data LineSegment u = LS (Point2 u) (Point2 u) + deriving (Eq,Ord,Show) + + +data PointSlope u = PointSlope + { _point_slope_point :: Point2 u + , _point_slope_slope :: u + } + deriving (Eq,Show) + +pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u +pointSlope pt theta = PointSlope pt (fromRadian $ tan theta) + + +-- | Line in equational form, i.e. @Ax + By + C = 0@. +data LineEqn u = LineEqn + { _line_eqn_A :: !u + , _line_eqn_B :: !u + , _line_eqn_C :: !u + } + deriving (Eq,Show) + +lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u +lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c + where + a = y1 - y2 + b = x2 - x1 + c = (x1*y2) - (x2*y1) + + +toLineEqn :: Num u => PointSlope u -> LineEqn u +toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0) + + + + +data IntersectionResult u = Intersects u u | Contained | NoIntersect + deriving (Eq,Show) + + +-- Note the uses a /plane/ so is susceptible to picking the +-- wrong quadrant... +-- +findIntersect :: (Floating u, Real u, Ord u) + => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u) +findIntersect ctr ang0 = step + where + theta = circularModulo ang0 + eqn = toLineEqn $ pointSlope ctr theta + step [] = Nothing + step (x:xs) = case intersection x eqn of + Just pt | quadrantCheck theta ctr pt -> Just pt + _ -> step xs + + +quadrantCheck :: (Real u, Floating u) + => Radian -> Point2 u -> Point2 u -> Bool +quadrantCheck theta ctr pt = theta == langle ctr pt + +intersection :: (Fractional u, Ord u) + => LineSegment u -> LineEqn u -> Maybe (Point2 u) +intersection ls@(LS p q) eqn = case intersect1 ls eqn of + Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t + Contained -> Just p + NoIntersect -> Nothing + + + +intersect1 :: (Num u, Ord u) + => LineSegment u -> LineEqn u -> IntersectionResult u +intersect1 (LS p q) eqn = + if inters fp fq then Intersects fp fq + else if contained fp fq then Contained else NoIntersect + where + inters a b = (a < 0 && b >= 0) || (a > 0 && b <= 0) + contained a b = a == 0 && b == 0 + fp = lineF p eqn + fq = lineF q eqn + +lineF :: Num u => Point2 u -> LineEqn u -> u +lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c + +affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u +affineComb p q t = p .+^ t *^ (q .-. p) + + + + +rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u] +rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br] + where + br = ctr .+^ (vec hw (-hh)) + tr = ctr .+^ (vec hw hh) + tl = ctr .+^ (vec (-hw) hh) + bl = ctr .+^ (vec (-hw) (-hh)) + + +polygonLines :: [Point2 u] -> [LineSegment u] +polygonLines [] = error "polygonLines - emptyList" +polygonLines (x:xs) = step x xs + where + step a [] = [LS a x] + step a (b:bs) = LS a b : step b bs + + + +-- | Calculate the counter-clockwise angle between two points +-- and the x-axis. +-- +langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian +langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) + where + -- north-east quadrant + step x y | pve x && pve y = toRadian $ atan (y/x) + + -- north-west quadrant + step x y | pve y = pi - (toRadian $ atan (y / abs x)) + + -- south-east quadrant + step x y | pve x = (2*pi) - (toRadian $ atan (abs y / x)) + + -- otherwise... south-west quadrant + step x y = pi + (toRadian $ atan (y/x)) + + pve a = signum a >= 0 diff --git a/src/Wumpus/Basic/Kernel/Geometry/Paths.hs b/src/Wumpus/Basic/Kernel/Geometry/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Geometry/Paths.hs @@ -0,0 +1,114 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Geometry.Paths +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Paths for /elementary/ shapes - rectangles... +-- +-- \*\* - WARNING \*\* - half baked. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Geometry.Paths + ( + rectanglePath + , diamondPath + , polygonPoints + , isoscelesTrianglePath + , isoscelesTrianglePoints + , equilateralTrianglePath + , equilateralTrianglePoints + ) + where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +import Data.List ( unfoldr ) + +-- TODO add regular polygon building from old Wumpus-Extra... + +-- | Supplied point is /bottom-left/. +-- +rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u +rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ] + where + br = bl .+^ hvec w + tr = br .+^ vvec h + tl = bl .+^ vvec h + + + +-- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @ +-- +diamondPath :: Num u => u -> u -> Point2 u -> PrimPath u +diamondPath hw hh ctr = primPath s [ lineTo e, lineTo n, lineTo w] + where + s = ctr .+^ vvec (-hh) + e = ctr .+^ hvec hw + n = ctr .+^ vvec hh + w = ctr .+^ hvec (-hw) + + +-- | 'polygonPoints' : @ num_points * radius * center -> [point] @ +-- +polygonPoints :: Floating u => Int -> u -> Point2 u -> [Point2 u] +polygonPoints n radius ctr = unfoldr phi (0,(pi*0.5)) + where + theta = (pi*2) / fromIntegral n + + phi (i,ang) | i < n = Just (ctr .+^ avec ang radius, (i+1,ang+theta)) + | otherwise = Nothing + +-- | @isocelesTriangle bw h pt@ +-- +-- Supplied point is the centriod of the triangle. This has a +-- nicer visual balance than using half-height. +-- +isoscelesTrianglePoints :: Floating u + => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u) +isoscelesTrianglePoints bw h ctr = (bl, br, top) + where + hw = 0.5*bw + theta = atan $ h / hw + centroid_h = hw * tan (0.5*theta) + top = ctr .+^ vvec (h - centroid_h) + br = ctr .+^ V2 hw (-centroid_h) + bl = ctr .+^ V2 (-hw) (-centroid_h) + + + +-- | @isocelesTriangle bw h pt@ +-- +-- Supplied point is the centriod of the triangle. This has a +-- nicer visual balance than using half-height. +-- +isoscelesTrianglePath :: Floating u => u -> u -> Point2 u -> PrimPath u +isoscelesTrianglePath bw h ctr = primPath bl [ lineTo br, lineTo top ] + where + hw = 0.5*bw + theta = atan $ h / hw + centroid_h = hw * tan (0.5*theta) + top = ctr .+^ vvec (h - centroid_h) + br = ctr .+^ V2 hw (-centroid_h) + bl = ctr .+^ V2 (-hw) (-centroid_h) + +equilateralTrianglePoints :: Floating u + => u -> Point2 u -> (Point2 u, Point2 u, Point2 u) +equilateralTrianglePoints sl = isoscelesTrianglePoints sl h + where + h = sl * sin (pi/3) + +equilateralTrianglePath :: Floating u => u -> Point2 u -> PrimPath u +equilateralTrianglePath sl ctr = primPath bl [ lineTo br, lineTo top ] + where + (bl,br,top) = equilateralTrianglePoints sl ctr diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.AdvanceGraphic +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Extended Graphic object - an AdvanceGraphic is a Graphic +-- twinned with and AdvanceV vector. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.AdvanceGraphic + ( + + -- * Advance-vector graphic + AdvGraphic + , DAdvGraphic + + + , makeAdvGraphic + , extractLocGraphic + , runAdvGraphic + + -- * Composition + , advplus + , advconcat + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.WrappedPrimitive +import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.Graphic + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + +-- | /Advance vector/ graphic - this partially models the +-- PostScript @show@ command which moves the /current point/ by the +-- width (advance) vector as each character is drawn. +-- +type AdvGraphic u = LocImage u (Point2 u) + +type DAdvGraphic = AdvGraphic Double + + + +-------------------------------------------------------------------------------- + + + +-- | Construction is different to intoZZ functions hence the +-- different name. +-- +makeAdvGraphic :: DrawingInfo (PointDisplace u) + -> LocGraphic u + -> AdvGraphic u +makeAdvGraphic dispf gf = + promoteR1 $ \pt -> dispf >>= \fn -> fmap (replaceL $ fn pt) (gf `at` pt) + + + + + +-- This should probably go - the name is not exact enough... + +extractLocGraphic :: AdvGraphic u -> LocGraphic u +extractLocGraphic = fmap (replaceL uNil) + +runAdvGraphic :: DrawingContext -> Point2 u -> AdvGraphic u + -> (Point2 u, PrimGraphic u) +runAdvGraphic ctx pt df = runCF1 ctx pt df + + + +-------------------------------------------------------------------------------- +-- composition + +-- Note there are opportunities for extra composition operators +-- like the /picture language/... + +infixr 6 `advplus` + + +-- | \*\* WARNING \*\* - pending removal. +-- +advplus :: AdvGraphic u -> AdvGraphic u -> AdvGraphic u +advplus = chain1 + + +advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u +advconcat [] = makeAdvGraphic (pure id) emptyLocGraphic +advconcat [x] = x +advconcat (x:xs) = x `chain1` advconcat xs diff --git a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.BaseObjects +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Aliases for ContextFun types. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.BaseObjects + ( + + -- * Drawing info + DrawingInfo + , LocDrawingInfo + , LocThetaDrawingInfo + + + + -- * Drawing objects + , ImageAns + , GraphicAns + + , Image + , LocImage + , LocThetaImage + + , DImage + , DLocImage + , DLocThetaImage + + , hyperlink + + ) where + +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.WrappedPrimitive + +import Wumpus.Core -- package: wumpus-core + +-------------------------------------------------------------------------------- +-- DrawingInfo + +-- | A query on the DrawingContext. +-- +-- Alias for 'CF'. +-- +type DrawingInfo a = CF a + + +-- | A query on the DrawingContext respective to the supplied +-- point. +-- +-- Alias for 'LocCF'. +-- +type LocDrawingInfo u a = LocCF u a + + +-- | A query on the DrawingContext respective to the supplied +-- point and angle. +-- +-- Alias for 'LocCF'. +-- +type LocThetaDrawingInfo u a = LocThetaCF u a + + + + +-------------------------------------------------------------------------------- +-- Image + + +-- | An Image always returns a pair of some polymorphic answer @a@ +-- and a PrimGraphic. +-- +-- Note a PrimGraphic cannot be empty. +-- +type ImageAns u a = (a, PrimGraphic u) + + +type GraphicAns u = ImageAns u (UNil u) + + +-- | Draw a PrimGraphic repsective to the 'DrawingContext' and +-- return some answer @a@. +-- +type Image u a = CF (ImageAns u a) + + +-- | Draw a PrimGraphic respective to the 'DrawingContext' and +-- the supplied point, return some answer @a@. +-- +type LocImage u a = LocCF u (ImageAns u a) + + +-- | Draw a PrimGraphic respective to the 'DrawingContext' and +-- the supplied point and angle. +-- +type LocThetaImage u a = LocThetaCF u (ImageAns u a) + + + +type DImage a = Image Double a +type DLocImage a = LocImage Double a +type DLocThetaImage a = LocThetaImage Double a + + +type instance DUnit (Image u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u)) + +type instance DUnit (LocImage u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u)) + +type instance DUnit (LocThetaImage u a) = u + + + +-------------------------------------------------------------------------------- +-- Affine instances + +-- Note - it seems better to have these instances for Image (even +-- though Image is a type synonym) rather than more general +-- instances on a CF. +-- +-- There is nothing determining a DUnit for the CF types. +-- +-- The downside is these instances are effectively orphan +-- instances. +-- + +instance (Real u, Floating u, Rotate a, DUnit a ~ u) => + Rotate (Image u a) where + rotate ang = fmap (rotate ang) + + +instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => + RotateAbout (Image u a) where + rotateAbout ang pt = fmap (rotateAbout ang pt) + + +instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where + scale sx sy = fmap (scale sx sy) + + +instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where + translate dx dy = fmap (translate dx dy) + + +-- \*\* WARNING \*\* - I am not sure having affine instances for +-- LocImage makes sense... +-- +-- Particularly, what is a rotateAbout on a function from Point to +-- Graphic? Is it just a post-transformation, or should the start +-- point be transformed as well. +-- + +instance (Real u, Floating u, Rotate a, DUnit a ~ u) => + Rotate (LocImage u a) where + rotate ang = fmap (rotate ang) + +instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => + RotateAbout (LocImage u a) where + rotateAbout ang pt = fmap (rotateAbout ang pt) + + +instance (Num u, Scale a, DUnit a ~ u) => Scale (LocImage u a) where + scale sx sy = fmap (scale sx sy) + + +instance (Num u, Translate a, DUnit a ~ u) => Translate (LocImage u a) where + translate dx dy = fmap (translate dx dy) + +-------------------------------------------------------------------------------- + + +hyperlink :: XLink -> Image u a -> Image u a +hyperlink hypl = + fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim)) + + + + + + diff --git a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs @@ -0,0 +1,140 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Bounded +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Bounded versions of Graphic and LocGraphic. +-- +-- Bounded meaning they are actually Images that return the +-- bounding box of the Graphic. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Bounded + ( + + + -- * Bounded graphic / loc graphic + BoundedGraphic + , DBoundedGraphic + , BoundedLocGraphic + , DBoundedLocGraphic + , BoundedLocThetaGraphic + , DBoundedLocThetaGraphic + + , emptyBoundedLocGraphic + + , centerOrthoBBox + , illustrateBoundedGraphic + , illustrateBoundedLocGraphic + , illustrateBoundedLocThetaGraphic + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.UpdateDC +import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.Graphic + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour ( blue ) + +import Control.Applicative + +-------------------------------------------------------------------------------- + +-- | Graphic with a bounding box. +-- +type BoundedGraphic u = Image u (BoundingBox u) + +type DBoundedGraphic = BoundedGraphic Double + + + + +-- | LocGraphic with a bounding box. +-- +type BoundedLocGraphic u = LocImage u (BoundingBox u) + +type DBoundedLocGraphic = BoundedLocGraphic Double + + +-- | LocThetaGraphic with a bounding box. +-- +-- Note the size of bounding box for the \"same\" shape will vary +-- according to the rotation. A bounding box is always +-- orthonormal (?) to the x- and y-axes. +-- +type BoundedLocThetaGraphic u = LocThetaImage u (BoundingBox u) + +type DBoundedLocThetaGraphic = BoundedLocThetaGraphic Double + + + + +-- | 'openStroke' : @ theta * bbox -> BBox @ +-- +-- Rotate a bounding box by @theta@ about its center. Take the +-- new bounding box. +-- +-- Remember that bounding boxes are always orthonormal rectangles, +-- so the dimensions as well as the positions may change under +-- rotation. +-- +centerOrthoBBox :: (Real u, Floating u) + => Radian -> BoundingBox u -> BoundingBox u +centerOrthoBBox theta bb = + traceBoundary $ map (rotateAbout theta ctr) ps + where + ps = boundaryCornerList bb + ctr = boundaryCenter bb + + +emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u +emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic + where + fn = promoteR1 $ \pt -> pure (BBox pt pt) + +-------------------------------------------------------------------------------- +-- + +-- This is a common pattern so needs a name... + +illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u +illustrateBoundedGraphic mf = + mf >>= \(bb,g1) -> bbrectangle bb >>= \(_,g0) -> return (bb, g0 `oplus` g1) + + +illustrateBoundedLocGraphic :: Fractional u + => BoundedLocGraphic u -> BoundedLocGraphic u +illustrateBoundedLocGraphic mf = + promoteR1 $ \pt -> illustrateBoundedGraphic $ apply1R1 mf pt + + +illustrateBoundedLocThetaGraphic :: Fractional u + => BoundedLocThetaGraphic u -> BoundedLocThetaGraphic u +illustrateBoundedLocThetaGraphic mf = + promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta + + + +bbrectangle :: Fractional u => BoundingBox u -> Graphic u +bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury)) + | llx == urx && lly == ury = emptyLocGraphic `at` p1 + | otherwise = + localize drawing_props $ rect1 `oplus` cross + where + drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)]) + rect1 = strokedRectangle (urx-llx) (ury-lly) `at` p1 + cross = straightLineBetween p1 p2 + `oplus` straightLineBetween (P2 llx ury) (P2 urx lly) + diff --git a/src/Wumpus/Basic/Kernel/Objects/Connector.hs b/src/Wumpus/Basic/Kernel/Objects/Connector.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Connector.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Connector +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Graphic and Image types representing connectors - connectors +-- have two implicit points - start and end. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Connector + ( + + -- * Connector Graphic + ConnectorGraphic + , DConnectorGraphic + + + -- * Connector Image + , ConnectorImage + , DConnectorImage + + + + ) where + +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Objects.BaseObjects + +-- import Wumpus.Core -- package: wumpus-core + + +-------------------------------------------------------------------------------- +-- Connector Graphic + + +-- | ConnectorGraphic is a connector drawn between two points +-- contructing a Graphic. +-- +type ConnectorGraphic u = ConnectorCF u (GraphicAns u) + + +type DConnectorGraphic = ConnectorGraphic Double + + + + +-------------------------------------------------------------------------------- +-- Connector Image + + +-- | ConnectorImage is a connector drawn between two points +-- constructing an Image. +-- +-- Usually the answer type of a ConnectorImage will be a Path so +-- the Points ar @midway@, @atstart@ etc. can be taken on it. +-- +type ConnectorImage u a = ConnectorCF u (ImageAns u a) + + +type DConnectorImage a = ConnectorImage Double a + + + + diff --git a/src/Wumpus/Basic/Kernel/Objects/Drawing.hs b/src/Wumpus/Basic/Kernel/Objects/Drawing.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Drawing.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Drawing +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- A Drawing object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core. +-- +-- Drawing is a function from the DrawingContext to a Picture. +-- Internally the result is actually a (Maybe Picture) and not a +-- Picture, this is a trick to promote the extraction from +-- possibly empty drawings (created by TraceDrawing) to the +-- top-level of the type hierarchy where client code can deal +-- with empty drawings explicitly (empty Pictures cannot be +-- rendered by Wumpus-Core). +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Drawing + ( + + Drawing + , DDrawing + , runDrawing + , runDrawingU + , drawTracing + + , clipDrawing + , modifyDrawing + + -- * Composition + , over + , under + + , centric + , nextToH + , nextToV + + , atPoint + , centeredAt + + , zconcat + + , hcat + , vcat + + + , hspace + , vspace + , hsep + , vsep + + -- * Compose with alignment + , alignH + , alignV + , alignHSep + , alignVSep + , hcatA + , vcatA + , hsepA + , vsepA + + + ) where + +import Wumpus.Basic.Kernel.Base.Anchors +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Objects.TraceDrawing + +import Wumpus.Core -- package: wumpus-core + +import Data.AdditiveGroup -- package: vector-space +import Data.AffineSpace + +import Control.Applicative +import Data.List ( foldl' ) + + + +newtype Drawing u = Drawing { getDrawing :: CF (Maybe (Picture u)) } + +type DDrawing = Drawing Double + + +type instance DUnit (Drawing u) = u + + + + +runDrawing :: DrawingContext -> Drawing u -> Maybe (Picture u) +runDrawing ctx drw = runCF ctx (getDrawing drw) + + +runDrawingU :: DrawingContext -> Drawing u -> Picture u +runDrawingU ctx df = maybe fk id $ runDrawing ctx df + where + fk = error "runDrawingU - empty Drawing." + + + +drawTracing :: (Real u, Floating u, FromPtSize u) + => TraceDrawing u a -> Drawing u +drawTracing mf = Drawing $ + drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) ) + + +-- Note - cannot get an answer from a TraceDrawing with this +-- Drawing type. There is nowhere to put the answer in the type. +-- +-- If the type was extended: +-- +-- > newtype Drawing u a = Drawing { getDrawing :: CF (a, Maybe (Picture u))) } +-- +-- It would make things difficult for the drawing composition +-- operators. @a@ could be monoidial but are there any types of +-- a where this would be useful (rather than just making things +-- more complicated)? +-- +-------------------------------------------------------------------------------- + +clipDrawing :: (Num u, Ord u) => (PrimPath u) -> Drawing u -> Drawing u +clipDrawing cpath = modifyDrawing (clip cpath) + + +modifyDrawing :: (Picture u -> Picture u) -> Drawing u -> Drawing u +modifyDrawing pf = Drawing . fmap (fmap pf) . getDrawing + +instance (Real u, Floating u) => Rotate (Drawing u) where + rotate ang = modifyDrawing (rotate ang) + +instance (Real u, Floating u) => RotateAbout (Drawing u) where + rotateAbout r pt = modifyDrawing (rotateAbout r pt) + +instance (Num u, Ord u) => Scale (Drawing u) where + scale sx sy = modifyDrawing (scale sx sy) + +instance (Num u, Ord u) => Translate (Drawing u) where + translate dx dy = modifyDrawing (translate dx dy) + + + +-------------------------------------------------------------------------------- + + +-------------------------------------------------------------------------------- +-- Extract anchors + +boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a +boundaryExtr f = f . boundary + +-- Operations on bounds + +-- | The center of a picture. +-- +boundaryCtr :: Fractional u => Picture u -> Point2 u +boundaryCtr = boundaryExtr center + + + +-- | Extract the mid point of the top edge. +-- +boundaryN :: Fractional u => Picture u -> Point2 u +boundaryN = boundaryExtr north + +-- | Extract the mid point of the bottom edge. +-- +boundaryS :: Fractional u => Picture u -> Point2 u +boundaryS = boundaryExtr south + +-- | Extract the mid point of the left edge. +-- +boundaryE :: Fractional u => Picture u -> Point2 u +boundaryE = boundaryExtr east + +-- | Extract the mid point of the right edge. +-- +boundaryW :: Fractional u => Picture u -> Point2 u +boundaryW = boundaryExtr west + + +-- | Extract the top-left corner. +-- +boundaryNW :: Fractional u => Picture u -> Point2 u +boundaryNW = boundaryExtr northwest + +-- | Extract the top-right corner. +-- +boundaryNE :: Picture u -> Point2 u +boundaryNE = boundaryExtr ur_corner + +-- | Extract the bottom-left corner. +-- +boundarySW :: Picture u -> Point2 u +boundarySW = boundaryExtr ll_corner + +-- | Extract the bottom-right corner. +-- +boundarySE :: Fractional u => Picture u -> Point2 u +boundarySE = boundaryExtr southeast + + +boundaryLeftEdge :: Picture u -> u +boundaryLeftEdge = boundaryExtr (point_x . ll_corner) + +boundaryRightEdge :: Picture u -> u +boundaryRightEdge = boundaryExtr (point_x . ur_corner) + +boundaryBottomEdge :: Picture u -> u +boundaryBottomEdge = boundaryExtr (point_y . ll_corner) + + +boundaryTopEdge :: Picture u -> u +boundaryTopEdge = boundaryExtr (point_y . ur_corner) + + + + + +-- Note - do not export the empty drawing. It is easier to +-- pretend it doesn't exist. +-- +empty_drawing :: (Real u, Floating u, FromPtSize u) => Drawing u +empty_drawing = drawTracing $ return () + + + + +-------------------------------------------------------------------------------- +-- Composition operators + + +drawingConcat :: (Picture u -> Picture u -> Picture u) + -> Drawing u -> Drawing u -> Drawing u +drawingConcat op a b = Drawing $ mbpostcomb op (getDrawing a) (getDrawing b) + + + +mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a) +mbpostcomb op = liftA2 fn + where + fn (Just a) (Just b) = Just $ a `op` b + fn a Nothing = a + fn Nothing b = b + + +-- Note - the megaCombR operator is in some way an +-- /anti-combinator/. It seems easier to think about composing +-- drawings if we do work on the result Pictures directly rather +-- than build combinators to manipulate Drawings. +-- +-- The idea of combining pre- and post- operating combinators +-- makes me worry about circular programs even though I know +-- lazy evaluation allows me to write them (in some cicumstances). +-- + + +-- Picture /mega-combiner/ - moves only the second argument aka the +-- right picture. +-- +megaCombR :: (Num u, Ord u) + => (Picture u -> a) -> (Picture u -> a) + -> (a -> a -> Picture u -> Picture u) + -> Drawing u -> Drawing u + -> Drawing u +megaCombR qL qR trafoR = drawingConcat fn + where + fn pic1 pic2 = let a = qL pic1 + b = qR pic2 + p2 = trafoR a b pic2 + in pic1 `picOver` p2 + + + + +-- | > a `over` b +-- +-- Place \'drawing\' a over b. The idea of @over@ here is in +-- terms z-ordering, nither picture a or b are actually moved. +-- +over :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +over = drawingConcat picOver + + + +-- | > a `under` b +-- +-- Similarly @under@ draws the first drawing behind +-- the second but move neither. +-- +under :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +under = flip over + + + +-- | Move in both the horizontal and vertical. +-- +move :: (Num u, Ord u) => Vec2 u -> Drawing u -> Drawing u +move v = modifyDrawing (\p -> p `picMoveBy` v) + + + + +-------------------------------------------------------------------------------- +-- Composition + +infixr 5 `nextToV` +infixr 6 `nextToH`, `centric` + + + + +-- | Draw @a@, move @b@ so its center is at the same center as +-- @a@, @b@ is drawn over underneath in the zorder. +-- +-- > a `centeric` b +-- +-- +centric :: (Fractional u, Ord u) => Drawing u -> Drawing u -> Drawing u +centric = megaCombR boundaryCtr boundaryCtr moveFun + where + moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v + + + +-- | > a `nextToH` b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@. +-- +nextToH :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun + where + moveFun a b pic = pic `picMoveBy` hvec (a - b) + + + +-- | > a `nextToV` b +-- +-- Vertical composition - move @b@, placing it below @a@. +-- +nextToV :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun + where + moveFun a b drw = drw `picMoveBy` vvec (a - b) + + +-- | Place the picture at the supplied point. +-- +-- `atPoint` was previous the `at` operator. +-- +atPoint :: (Num u, Ord u) => Drawing u -> Point2 u -> Drawing u +p `atPoint` (P2 x y) = move (V2 x y) p + + + +-- | Center the picture at the supplied point. +-- +centeredAt :: (Fractional u, Ord u) => Drawing u -> Point2 u -> Drawing u +centeredAt d (P2 x y) = modifyDrawing fn d + where + fn p = let bb = boundary p + dx = x - (boundaryWidth bb * 0.5) + dy = y - (boundaryHeight bb * 0.5) + in p `picMoveBy` vec dx dy + + +-- | Concatenate the list of drawings. +-- +-- No pictures are moved. +-- +zconcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +zconcat [] = empty_drawing +zconcat (d:ds) = foldl' over d ds + + + + +-- | Concatenate the list pictures @xs@ horizontally. +-- +hcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +hcat [] = empty_drawing +hcat (d:ds) = foldl' nextToH d ds + + +-- | Concatenate the list of pictures @xs@ vertically. +-- +vcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +vcat [] = empty_drawing +vcat (d:ds) = foldl' nextToV d ds + + + + +-------------------------------------------------------------------------------- + + + + +-- | > hspace n a b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ with a horizontal gap of @n@ separating the pictures. +-- +hspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u +hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun + where + moveFun a b pic = pic `picMoveBy` hvec (n + a - b) + + + + + +-- | > vspace n a b +-- +-- Vertical composition - move @b@, placing it below @a@ with a +-- vertical gap of @n@ separating the pictures. +-- +vspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u +vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun + where + moveFun a b pic = pic `picMoveBy` vvec (a - b - n) + + + +-- | > hsep n xs +-- +-- Concatenate the list of pictures @xs@ horizontally with +-- @hspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units. +-- +hsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u +hsep _ [] = empty_drawing +hsep n (d:ds) = foldl' (hspace n) d ds + + + +-- | > vsep n xs +-- +-- Concatenate the list of pictures @xs@ vertically with +-- @vspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units. +-- +vsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u +vsep _ [] = empty_drawing +vsep n (d:ds) = foldl' (vspace n) d ds + + +-------------------------------------------------------------------------------- +-- Aligning pictures + +alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u +alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2) + + + +-- | > alignH align a b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ and align it with the top, center or bottom of @a@. +-- +alignH :: (Fractional u, Ord u) + => HAlign -> Drawing u -> Drawing u -> Drawing u +alignH HTop = megaCombR boundaryNE boundaryNW alignMove +alignH HCenter = megaCombR boundaryE boundaryW alignMove +alignH HBottom = megaCombR boundarySE boundarySW alignMove + + +-- | > alignV align a b +-- +-- Vertical composition - move @b@, placing it below @a@ +-- and align it with the left, center or right of @a@. +-- +alignV :: (Fractional u, Ord u) + => VAlign -> Drawing u -> Drawing u -> Drawing u +alignV VLeft = megaCombR boundarySW boundaryNW alignMove +alignV VCenter = megaCombR boundaryS boundaryN alignMove +alignV VRight = megaCombR boundarySE boundaryNE alignMove + + + +alignMove2 :: (Num u, Ord u) + => Vec2 u -> Point2 u -> Point2 u -> Picture u -> Picture u +alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2)) + + + +-- | > alignHSep align sep a b +-- +-- Spacing version of alignH - move @b@ to the right of @a@ +-- separated by @sep@ units, align @b@ according to @align@. +-- +alignHSep :: (Fractional u, Ord u) + => HAlign -> u -> Drawing u -> Drawing u -> Drawing u +alignHSep HTop dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx)) +alignHSep HCenter dx = megaCombR boundaryE boundaryW (alignMove2 (hvec dx)) +alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx)) + + +-- | > alignVSep align sep a b +-- +-- Spacing version of alignV - move @b@ below @a@ +-- separated by @sep@ units, align @b@ according to @align@. +-- +alignVSep :: (Fractional u, Ord u) + => VAlign -> u -> Drawing u -> Drawing u -> Drawing u +alignVSep VLeft dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) +alignVSep VCenter dy = megaCombR boundaryS boundaryN (alignMove2 $ vvec (-dy)) +alignVSep VRight dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy)) + + +-- | Variant of 'hcat' that aligns the pictures as well as +-- concatenating them. +-- +hcatA :: (Real u, Floating u, FromPtSize u) + => HAlign -> [Drawing u] -> Drawing u +hcatA _ [] = empty_drawing +hcatA ha (d:ds) = foldl' (alignH ha) d ds + + + +-- | Variant of 'vcat' that aligns the pictures as well as +-- concatenating them. +-- +vcatA :: (Real u, Floating u, FromPtSize u) + => VAlign -> [Drawing u] -> Drawing u +vcatA _ [] = empty_drawing +vcatA va (d:ds) = foldl' (alignV va) d ds + + +-- | Variant of @hsep@ that aligns the pictures as well as +-- concatenating and spacing them. +-- +hsepA :: (Real u, Floating u, FromPtSize u) + => HAlign -> u -> [Drawing u] -> Drawing u +hsepA _ _ [] = empty_drawing +hsepA ha n (d:ds) = foldl' op d ds + where + a `op` b = alignHSep ha n a b + + +-- | Variant of @vsep@ that aligns the pictures as well as +-- concatenating and spacing them. +-- +vsepA :: (Real u, Floating u, FromPtSize u) + => VAlign -> u -> [Drawing u] -> Drawing u +vsepA _ _ [] = empty_drawing +vsepA va n (d:ds) = foldl' op d ds + where + a `op` b = alignVSep va n a b + + + diff --git a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs @@ -0,0 +1,470 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Graphic +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Graphic type - this is largely equivalent to Primitive in +-- Wumpus-Core, but drawing attributes are implicitly supplied +-- by the DrawingContext. +-- +-- API in @Wumpus.Core@, but here they exploit the implicit +-- @DrawingContext@. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Graphic + ( + + Graphic + , DGraphic + + + -- * LocGraphic + , LocGraphic + , DLocGraphic + + + , LocThetaGraphic + , DLocThetaGraphic + + -- * Functions + , intoImage + , intoLocImage + , intoLocThetaImage + + , moveStartPoint + , moveStartPointTheta + + , locPath + , emptyLocPath + , emptyLocGraphic + + + , openStroke + , closedStroke + , filledPath + , borderedPath + + , textline + , rtextline + , escapedline + , rescapedline + + , hkernline + , vkernline + + , strokedEllipse + , rstrokedEllipse + , filledEllipse + , rfilledEllipse + + , borderedEllipse + , rborderedEllipse + + , straightLine + , straightLineBetween + , curveBetween + + , strokedRectangle + , filledRectangle + , borderedRectangle + + , strokedCircle + , filledCircle + , borderedCircle + + , strokedDisk + , filledDisk + , borderedDisk + + ) where + +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.QueryDC +import Wumpus.Basic.Kernel.Base.WrappedPrimitive +import Wumpus.Basic.Kernel.Geometry.Paths +import Wumpus.Basic.Kernel.Objects.BaseObjects + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + +-------------------------------------------------------------------------------- +-- Graphic + +-- | Simple drawing - produce a primitive, access the DrawingContext +-- as required, e.g for fill colour, stroke colur, line width, etc. +-- +type Graphic u = Image u (UNil u) + +-- | Alias of 'Graphic' where the unit type is specialized to +-- Double. +-- +type DGraphic = Graphic Double + + +-- | /Originated/ drawing - produce a primitive respective to the +-- supplied start-point, access the DrawingContext as required. +-- +type LocGraphic u = LocImage u (UNil u) + +-- | Alias of 'LocGraphic' where the unit type is specialized to +-- Double. +-- +type DLocGraphic = LocGraphic Double + + + + +-- | /Originated/ drawing - produce a primitive respective to the +-- supplied start-point, access the DrawingContext as required. +-- +type LocThetaGraphic u = LocThetaImage u (UNil u) + + +-- | Alias of 'LocThetaGraphic' where the unit type is specialized +-- to Double. +-- +type DLocThetaGraphic = LocThetaGraphic Double + + +-------------------------------------------------------------------------------- +-- Functions + + +-- | Build an Image... +-- +intoImage :: CF a -> Graphic u -> Image u a +intoImage = liftA2 (\a (_,b) -> (a,b)) + + +-- | Build a LocImage... +-- +intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a +intoLocImage = liftA2 (\a (_,b) -> (a,b)) + +-- | Build a LocThetaImage... +-- +intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a +intoLocThetaImage = liftA2 (\a (_,b) -> (a,b)) + + +-- | Move the start-point of a LocImage with the supplied +-- displacement function. +-- +moveStartPoint :: PointDisplace u -> LocCF u a -> LocCF u a +moveStartPoint f ma = promoteR1 $ \pt -> apply1R1 ma (f pt) + + +-- | Move the start-point of a LocImage with the supplied +-- displacement function. +-- +moveStartPointTheta :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a +moveStartPointTheta f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta + +-------------------------------------------------------------------------------- + + + +graphicBody :: Primitive u -> (UNil u, PrimGraphic u) +graphicBody p = (uNil, primGraphic p) + + +-- | This is the analogue to 'vectorPath' in @Wumpus-core@. +-- +locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u) +locPath vs = promoteR1 $ \pt -> pure $ vectorPath pt vs + + +-- | This is the analogue to 'emptyPath' in @Wumpus-core@. +-- +emptyLocPath :: Num u => LocCF u (PrimPath u) +emptyLocPath = locPath [] + +-- | Build an empty LocGraphic - this is a path with a start +-- point but no path segments. +-- +-- The 'emptyLocGraphic' It is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, although it does generate a +-- minimum bounding box at the implicit start point. +-- +emptyLocGraphic :: Num u => LocGraphic u +emptyLocGraphic = emptyLocPath >>= (lift0R1 . openStroke) + + +-- | 'openStroke' : @ path -> Graphic @ +-- +-- This is the analogue to 'ostroke' in @Wumpus-core@, but the +-- drawing properties (colour, line width, etc.) are taken from +-- the implicit 'DrawingContext'. +-- +openStroke :: Num u => PrimPath u -> Graphic u +openStroke pp = + withStrokeAttr $ \rgb attr -> graphicBody $ ostroke rgb attr pp + + +-- | 'closedStroke' : @ path -> Graphic @ +-- +-- This is the analogue to 'cstroke' in @Wumpus-core@, but the +-- drawing properties (colour, line width, etc.) are taken from +-- the implicit 'DrawingContext'. +-- +closedStroke :: Num u => PrimPath u -> Graphic u +closedStroke pp = + withStrokeAttr $ \rgb attr -> graphicBody $ cstroke rgb attr pp + + +-- | 'filledPath' : @ path -> Graphic @ +-- +-- This is the analogue to 'fill' in @Wumpus-core@, but the +-- fill colour is taken from the implicit 'DrawingContext'. +-- +-- +filledPath :: Num u => PrimPath u -> Graphic u +filledPath pp = withFillAttr $ \rgb -> graphicBody $ fill rgb pp + + +-- | 'borderedPath' : @ path -> Graphic @ +-- +-- This is the analogue to 'fillStroke' in @Wumpus-core@, but the +-- drawing properties (fill colour, border colour, line width, +-- etc.) are taken from the implicit 'DrawingContext'. +-- +-- +borderedPath :: Num u => PrimPath u -> Graphic u +borderedPath pp = + withBorderedAttr $ \frgb attr srgb -> + graphicBody $ fillStroke frgb attr srgb pp + + + + +-- | This is the analogue to 'textlabel' in @Wumpus-core@. +-- +textline :: Num u => String -> LocGraphic u +textline ss = + promoteR1 $ \pt -> + withTextAttr $ \rgb attr -> graphicBody (textlabel rgb attr ss pt) + + + + +-- | This is the analogue to 'rtextlabel' in @Wumpus-core@. +-- +rtextline :: Num u => String -> LocThetaGraphic u +rtextline ss = + promoteR2 $ \pt theta -> + withTextAttr $ \rgb attr -> graphicBody (rtextlabel rgb attr ss theta pt) + + + +-- | This is the analogue to 'escapedlabel' in @Wumpus-core@. +-- +escapedline :: Num u => EscapedText -> LocGraphic u +escapedline ss = + promoteR1 $ \pt -> + withTextAttr $ \rgb attr -> graphicBody (escapedlabel rgb attr ss pt) + + + +-- | This is the analogue to 'rescapedlabel' in @Wumpus-core@. +-- +rescapedline :: Num u => EscapedText -> LocThetaGraphic u +rescapedline ss = + promoteR2 $ \pt theta -> + withTextAttr $ \rgb attr -> graphicBody (rescapedlabel rgb attr ss theta pt) + + + + +-- | This is the analogue to 'hkernlabel' in @Wumpus-core@. +-- +hkernline :: Num u => [KerningChar u] -> LocGraphic u +hkernline xs = + promoteR1 $ \pt -> + withTextAttr $ \rgb attr -> graphicBody (hkernlabel rgb attr xs pt) + + +-- | This is the analogue to 'vkernlabel' in @Wumpus-core@. +-- +vkernline :: Num u => [KerningChar u] -> LocGraphic u +vkernline xs = + promoteR1 $ \pt -> + withTextAttr $ \rgb attr -> graphicBody (vkernlabel rgb attr xs pt) + + + + +-------------------------------------------------------------------------------- + + + + + +-- | This is the analogue to 'strokeEllipse' in @Wumpus-core@. +-- +strokedEllipse :: Num u => u -> u -> LocGraphic u +strokedEllipse hw hh = + promoteR1 $ \pt -> + withStrokeAttr $ \rgb attr -> graphicBody (strokeEllipse rgb attr hw hh pt) + + + +-- | This is the analogue to 'rstrokeEllispe' in @Wumpus-core@. +-- +rstrokedEllipse :: Num u => u -> u -> LocThetaGraphic u +rstrokedEllipse hw hh = + promoteR2 $ \ pt theta -> + withStrokeAttr $ \rgb attr -> + graphicBody (rstrokeEllipse rgb attr hw hh theta pt) + + +-- | This is the analogue to 'fillEllispe' in @Wumpus-core@. +-- +filledEllipse :: Num u => u -> u -> LocGraphic u +filledEllipse hw hh = + promoteR1 $ \pt -> + withFillAttr $ \rgb -> graphicBody (fillEllipse rgb hw hh pt) + + +-- | This is the analogue to 'rfillEllispe' in @Wumpus-core@. +-- +rfilledEllipse :: Num u => u -> u -> LocThetaGraphic u +rfilledEllipse hw hh = + promoteR2 $ \pt theta -> + withFillAttr $ \rgb -> graphicBody (rfillEllipse rgb hw hh theta pt) + + + +-- | This is the analogue to 'fillStrokeEllispe' in @Wumpus-core@. +-- +borderedEllipse :: Num u => u -> u -> LocGraphic u +borderedEllipse hw hh = + promoteR1 $ \pt -> + withBorderedAttr $ \frgb attr srgb -> + graphicBody (fillStrokeEllipse frgb attr srgb hw hh pt) + +-- | This is the analogue to 'rfillStrokeEllispe' in @Wumpus-core@. +-- +rborderedEllipse :: Num u => u -> u -> LocThetaGraphic u +rborderedEllipse hw hh = + promoteR2 $ \pt theta -> + withBorderedAttr $ \frgb attr srgb -> + graphicBody (rfillStrokeEllipse frgb attr srgb hw hh theta pt) + + + +-- Note - clipping needs a picture as well as a path, so there is +-- no analogous @clippedPath@ function. + +-------------------------------------------------------------------------------- + + +-- | Draw a straight line formed from displacing the implicit +-- start point with the supplied vector. +-- +straightLine :: Fractional u => Vec2 u -> LocGraphic u +straightLine v = mf >>= (lift0R1 . openStroke) + where + mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v] + + +-- | Draw a straight line - start and end point are supplied +-- explicitly. +-- +straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u +straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2] + + + +-- | Draw a Bezier curve - all points are supplied explicitly. +-- +curveBetween :: Fractional u + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u +curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep] + + +-- This is a permuted version of the cardinal-prime combinator... +-- +-- > (r2 -> a) -> (a -> r1 -> ans) -> (r1 -> r2 -> ans) +-- + +drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u +drawWith g mf = promoteR1 $ \pt -> mf (g pt) + + +-- | Supplied point is /bottom left/. +-- +strokedRectangle :: Fractional u => u -> u -> LocGraphic u +strokedRectangle w h = rectanglePath w h `drawWith` closedStroke + + +-- | Supplied point is /bottom left/. +-- +filledRectangle :: Fractional u => u -> u -> LocGraphic u +filledRectangle w h = rectanglePath w h `drawWith` filledPath + +-- | Supplied point is /bottom left/. +-- +borderedRectangle :: Fractional u => u -> u -> LocGraphic u +borderedRectangle w h = rectanglePath w h `drawWith` borderedPath + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +strokedCircle :: Floating u => Int -> u -> LocGraphic u +strokedCircle n r = (curvedPath . bezierCircle n r) `drawWith` closedStroke + + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +filledCircle :: Floating u => Int -> u -> LocGraphic u +filledCircle n r = (curvedPath . bezierCircle n r) `drawWith` filledPath + + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +borderedCircle :: Floating u => Int -> u -> LocGraphic u +borderedCircle n r = (curvedPath . bezierCircle n r) `drawWith` borderedPath + + +-- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive. +-- +-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated +-- output. However, stroked-circles do not draw well after +-- non-uniform scaling - the line width is scaled as well as +-- the shape. +-- +-- For stroked circles that can be adequately scaled, use +-- 'strokedCircle' instead. +-- +strokedDisk :: Num u => u -> LocGraphic u +strokedDisk radius = strokedEllipse radius radius + +-- | Filled disk... +-- +filledDisk :: Num u => u -> LocGraphic u +filledDisk radius = filledEllipse radius radius + +-- | bordered disk... +-- +borderedDisk :: Num u => u -> LocGraphic u +borderedDisk radius = borderedEllipse radius radius diff --git a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.TraceDrawing +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Drawing with /trace/ - a Writer like monad collecting +-- intermediate graphics - and /drawing context/ - a reader monad +-- of attributes - font_face, fill_colour etc. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.TraceDrawing + ( + + TraceDrawing + , DTraceDrawing + , TraceDrawingT + , DTraceDrawingT + + , runTraceDrawing + , execTraceDrawing + , evalTraceDrawing + , runTraceDrawingT + , execTraceDrawingT + , evalTraceDrawingT + + , liftToPictureU + , liftToPictureMb + , mbPictureU + + + , query + , draw + , xdraw + , drawi + , drawi_ + , xdrawi + , xdrawi_ + + , node + , nodei + + ) where + + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.WrappedPrimitive +import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.Graphic + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Control.Monad +import Data.Monoid + + + +-- Note - TraceDrawing run \once\ - it is supplied with the starting +-- environment (DrawingContext) and returns a Picture. +-- +-- Other Wumpus monads (e.g. Turtle) will typically be run inside +-- the TraceDrawing monad as a local effect, rather than built into a +-- transformer stack. +-- + + +newtype TraceDrawing u a = TraceDrawing { + getTraceDrawing :: DrawingContext -> (a, HPrim u) } + +newtype TraceDrawingT u m a = TraceDrawingT { + getTraceDrawingT :: DrawingContext -> m (a, HPrim u) } + + +type DTraceDrawing a = TraceDrawing Double a +type DTraceDrawingT m a = TraceDrawingT Double m a + + + +type instance MonUnit (TraceDrawing u) = u +type instance MonUnit (TraceDrawingT u m) = u + + + +-- Functor + +instance Functor (TraceDrawing u) where + fmap f ma = TraceDrawing $ \ctx -> + let (a,w) = getTraceDrawing ma ctx in (f a,w) + + +instance Monad m => Functor (TraceDrawingT u m) where + fmap f ma = TraceDrawingT $ \ctx -> + getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w) + + + +-- Applicative + +instance Applicative (TraceDrawing u) where + pure a = TraceDrawing $ \_ -> (a, mempty) + mf <*> ma = TraceDrawing $ \ctx -> + let (f,w1) = getTraceDrawing mf ctx + (a,w2) = getTraceDrawing ma ctx + in (f a, w1 `mappend` w2) + + +instance Monad m => Applicative (TraceDrawingT u m) where + pure a = TraceDrawingT $ \_ -> return (a,mempty) + mf <*> ma = TraceDrawingT $ \ctx -> + getTraceDrawingT mf ctx >>= \(f,w1) -> + getTraceDrawingT ma ctx >>= \(a,w2) -> + return (f a, w1 `mappend` w2) + +-- Monad + +instance Monad (TraceDrawing u) where + return a = TraceDrawing $ \_ -> (a, mempty) + ma >>= k = TraceDrawing $ \ctx -> + let (a,w1) = getTraceDrawing ma ctx + (b,w2) = (getTraceDrawing . k) a ctx + in (b,w1 `mappend` w2) + + + + +instance Monad m => Monad (TraceDrawingT u m) where + return a = TraceDrawingT $ \_ -> return (a, mempty) + ma >>= k = TraceDrawingT $ \ctx -> + getTraceDrawingT ma ctx >>= \(a,w1) -> + (getTraceDrawingT . k) a ctx >>= \(b,w2) -> + return (b, w1 `mappend` w2) + + + + +-- TraceM +-- +-- Note - @ state `mappend` a @ means the first expression in a +-- monadic drawing is the first element in the output file. It is +-- also \*\* at the back \*\* in the the Z-Order. +-- +-- Some control over the Z-Order, possibly by adding /layers/ to +-- the drawing model would be valuable. +-- + +instance TraceM (TraceDrawing u) where + trace a = TraceDrawing $ \_ -> ((), a) + + +instance Monad m => TraceM (TraceDrawingT u m) where + trace a = TraceDrawingT $ \_ -> return ((), a) + + + +-- DrawingCtxM + +instance DrawingCtxM (TraceDrawing u) where + askDC = TraceDrawing $ \ctx -> (ctx, mempty) + localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx) + + + +instance Monad m => DrawingCtxM (TraceDrawingT u m) where + askDC = TraceDrawingT $ \ctx -> return (ctx,mempty) + localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx) + + + +-- Note - the result type of runTraceDrawing and friends needs more +-- thought and may change. +-- +-- Possibly a wrapped HPrim that only supports concat and safe +-- extraction is best. +-- +-- Or it could generate a picture, but then separate drawings +-- need the picture combinators to put them together. +-- + + +runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u) +runTraceDrawing ctx ma = getTraceDrawing ma ctx + +-- | Run the drawing returning only the output it produces, drop +-- any answer from the monadic computation. +-- +execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u +execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma + +-- | Run the drawing ignoring the output it produces, return the +-- answer from the monadic computation. +-- +-- Note - this useful for testing, generally one would want the +-- opposite behaviour (return the drawing, ignore than the +-- answer). +-- +evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a +evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma + + + +runTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) +runTraceDrawingT ctx ma = getTraceDrawingT ma ctx + +execTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m (HPrim u) +execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma + + +evalTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m a +evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma + + + +-- | /Unsafe/ promotion of @HPrim@ to @Picture@. +-- +-- If the HPrim is empty, a run-time error is thrown. +-- +liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u +liftToPictureU hf = + let prims = hprimToList hf in if null prims then errK else frame prims + where + errK = error "toPictureU - empty prims list." + +-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@. +-- +-- If the HPrim is empty, then @Nothing@ is returned. +-- +liftToPictureMb :: (Real u, Floating u, FromPtSize u) + => HPrim u -> Maybe (Picture u) +liftToPictureMb hf = let prims = hprimToList hf in + if null prims then Nothing else Just (frame prims) + + + +-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@. +-- +-- This is equivalent to: +-- +-- > fromMaybe (error "empty") $ pic +-- +-- This function is solely a convenience, using it saves one +-- import and a few characters. +-- +-- If the supplied value is @Nothing@ a run-time error is thrown. +-- +mbPictureU :: (Real u, Floating u, FromPtSize u) + => Maybe (Picture u) -> Picture u +mbPictureU Nothing = error "mbPictureU - empty picture." +mbPictureU (Just a) = a + +-- Note - need an equivalent to Parsec\`s parseTest that provides +-- a very simple way to run graphics without concern for return +-- type or initial drawing context. + +-------------------------------------------------------------------------------- + +query :: DrawingCtxM m => CF a -> m a +query df = askDC >>= \ctx -> return $ runCF ctx df + + +-- | Draw a Graphic taking the drawing style from the +-- /drawing context/. +-- +-- This operation is analogeous to @tell@ in a Writer monad. +-- +draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () +draw gf = askDC >>= \ctx -> trace (collectH $ snd $ runCF ctx gf) + +-- | Hyperlink version of 'draw'. +-- +xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => XLink -> Graphic u -> m () +xdraw xl gf = draw (hyperlink xl gf) + + + +-- | Draw an Image taking the drawing style from the +-- /drawing context/. +-- +-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned. +-- +drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a +drawi img = askDC >>= \ctx -> + let (a,o) = runCF ctx img in trace (collectH o) >> return a + +-- | Forgetful 'drawi'. +-- +drawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) => Image u a -> m () +drawi_ img = drawi img >> return () + + +-- | Hyperlink version of 'drawi'. +-- +xdrawi :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) + => XLink -> Image u a -> m a +xdrawi xl img = drawi (hyperlink xl img) + + +-- | Forgetful 'xdrawi'. +-- +xdrawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) + => XLink -> Image u a -> m () +xdrawi_ xl img = xdrawi xl img >> return () + + + + +node :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) + => LocGraphic u -> m () +node gf = askDC >>= \ctx -> + position >>= \pt -> + let (_,prim) = runCF1 ctx pt gf in trace (collectH prim) + + +nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) + => LocImage u a -> m a +nodei imgL = askDC >>= \ctx -> + position >>= \pt -> + let (a,o) = runCF ctx (apply1R1 imgL pt) + in trace (collectH o) >> return a + diff --git a/src/Wumpus/Basic/Monads/TurtleClass.hs b/src/Wumpus/Basic/Monads/TurtleClass.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/TurtleClass.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.TurtleClass --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad and monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"coordinate-free\" style of drawing, some types of diagram --- are more easily expressed in the LOGO style. --- --- Note - as turtle drawing with Wumpus is a /local effect/, --- there is only one instance of TurtleM. Potentially TurtleM --- will be removed and the functions implemented directly. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.TurtleClass - ( - - Coord - - , TurtleM(..) - - , setsLoc - , setsLoc_ - - -- * movement - , resetLoc - , moveLeft - , moveRight - , moveUp - , moveDown - , nextLine - - - ) where - - - -type Coord = (Int,Int) - - -class Monad m => TurtleM m where - getLoc :: m (Int,Int) - setLoc :: (Int,Int) -> m () - getOrigin :: m (Int,Int) - setOrigin :: (Int,Int) -> m () - - - -setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a -setsLoc f = getLoc >>= \coord -> - let (a,coord') = f coord in setLoc coord' >> return a - -setsLoc_ :: TurtleM m => (Coord -> Coord) -> m () -setsLoc_ f = getLoc >>= \coord -> setLoc (f coord) - - -resetLoc :: TurtleM m => m () -resetLoc = getOrigin >>= setLoc - - -moveRight :: TurtleM m => m () -moveRight = setsLoc_ $ \(x,y)-> (x+1, y) - - -moveLeft :: TurtleM m => m () -moveLeft = setsLoc_ $ \(x,y) -> (x-1,y) - -moveUp :: TurtleM m => m () -moveUp = setsLoc_ $ \(x,y) -> (x,y+1) - -moveDown :: TurtleM m => m () -moveDown = setsLoc_ $ \(x,y) -> (x ,y-1) - - -nextLine :: TurtleM m => m () -nextLine = getOrigin >>= \(ox,_) -> - setsLoc_ $ \(_,y) -> (ox,y-1) - diff --git a/src/Wumpus/Basic/Monads/TurtleMonad.hs b/src/Wumpus/Basic/Monads/TurtleMonad.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Monads/TurtleMonad.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Monads.TurtleMonad --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"coordinate-free\" style of drawing, some types of --- diagram are more easily expressed in the LOGO style. --- --- Turtle is only a transformer - it is intended to be run within --- a 'Drawing'. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Monads.TurtleMonad - ( - -- * Re-exports - module Wumpus.Basic.Monads.TurtleClass - - -- * Turtle transformer - , TurtleT - , runTurtleT - - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Monads.TurtleClass - - - -import Control.Applicative -import Control.Monad - - --- Note - if Turtle is now just a /local effect/ monad is the --- Turtle class still needed? Afterall, there is (probably) --- only ever going to be one instance. --- - --- Turtle is a Reader / State monad --- --- The env is the horizontal and vertical move distances. --- --- The state is the current coordinate and the origin. --- - -data TurtleState = TurtleState - { _turtle_origin :: (Int,Int) - , _current_coord :: (Int,Int) - } - -type TurtleScalingT u m a = ScalingT Int Int u m a - -newtype TurtleT u m a = TurtleT { - getTurtleT :: TurtleState -> TurtleScalingT u m (a, TurtleState) } - -type instance MonUnit (TurtleT u m) = u - - - --- Functor - - - -instance Monad m => Functor (TurtleT u m) where - fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> - return (f a, s') - - --- Applicative - -instance Monad m => Applicative (TurtleT u m) where - pure a = TurtleT $ \s -> return (a,s) - mf <*> ma = TurtleT $ \s -> getTurtleT mf s >>= \(f,s') -> - getTurtleT ma s' >>= \(a,s'') -> - return (f a,s'') - - --- Monad - -instance Monad m => Monad (TurtleT u m) where - return a = TurtleT $ \s -> return (a,s) - m >>= k = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> - (getTurtleT . k) a s' >>= \(b,s'') -> - return (b,s'') - - - - -instance Monad m => TurtleM (TurtleT u m) where - getLoc = TurtleT $ \s@(TurtleState _ c) -> return (c,s) - setLoc c = TurtleT $ \(TurtleState o _) -> return ((),TurtleState o c) - getOrigin = TurtleT $ \s@(TurtleState o _) -> return (o,s) - setOrigin o = TurtleT $ \(TurtleState _ c) -> return ((),TurtleState o c) - - -runTurtleT :: (Monad m, Num u) - => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a -runTurtleT ogin cfg mf = - runScalingT cfg (getTurtleT mf st0) >>= \(a,_) -> return a - where - st0 = TurtleState ogin ogin - - - ----------------------------------------------------------------------------------- --- Cross instances - -instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where - askDC = TurtleT $ \s -> askDC >>= \ ctx -> return (ctx,s) - localize upd mf = TurtleT $ \s -> localize upd (getTurtleT mf s) - - --- This needs undecidable instances... - -instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where - trace a = TurtleT $ \s -> trace a >> return ((),s) - - -instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where - position = TurtleT $ \s@(TurtleState _ (x,y)) -> scalePt x y >>= \pt -> return (pt,s) - diff --git a/src/Wumpus/Basic/Paths.hs b/src/Wumpus/Basic/Paths.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim import module for Paths. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths - ( - - module Wumpus.Basic.Paths.Base - , module Wumpus.Basic.Paths.Connectors - , module Wumpus.Basic.Paths.Construction - , module Wumpus.Basic.Paths.ControlPoints - - ) where - -import Wumpus.Basic.Paths.Base -import Wumpus.Basic.Paths.Connectors -import Wumpus.Basic.Paths.Construction -import Wumpus.Basic.Paths.ControlPoints - diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths/Base.hs +++ /dev/null @@ -1,529 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths.Base --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Extended path type - more amenable for complex drawings than --- the type in Wumpus-Core. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths.Base - ( - - Path - , DPath - , length - , append - , pconcat - , line - , curve - , pivot - , traceLinePoints - , traceCurvePoints - , curveByAngles - - , toPrimPath - - , tipL - , tipR - - , shortenBoth - , shortenL - , shortenR - , directionL - , directionR - - , midway - , midway_ - , atstart - , atstart_ - , atend - , atend_ - - , PathViewL(..) - , DPathViewL - , PathViewR(..) - , DPathViewR - , PathSegment(..) - , DPathSegment - , pathViewL - , pathViewR - - ) where - - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -import Data.VectorSpace - -import Data.List ( foldl' ) -import Data.Sequence ( Seq, (><), ViewL(..), viewl - , ViewR(..), viewr, (<|) , (|>) ) -import qualified Data.Sequence as S - -import Prelude hiding ( length ) - -data Path u = Path { _path_length :: u - , _path_start :: Point2 u - , _path_elements :: Seq (PathSeg u) - , _path_end :: Point2 u - } - deriving (Eq,Ord,Show) - -type DPath = Path Double - --- Annotating each segment with length is \*\* good \*\*. --- Makes it much more efficient to find the midway point. --- --- But what do we do about the start point: --- --- a) put it in the segment - too much info in the type, allows --- consistency problems vis-a-vis gaps in the path. --- --- b) leave it out - too little info in the type, allows --- consistency problems with length. --- --- Option (a) is probably most convenient espcially as the --- constructors won\'t be exported. - --- Annotation is length... --- -data PathSeg u = LineSeg { _line_length :: u - , _line_start :: Point2 u - , _line_end :: Point2 u - } - | CurveSeg { _curve_length :: u - , _curve_start :: Point2 u - , _ctrl_pt_one :: Point2 u - , _ctrl_pt_two :: Point2 u - , _curve_end :: Point2 u - } - deriving (Eq,Ord,Show) - - -type instance DUnit (Path u) = u -type instance DUnit (PathSeg u) = u - - -infixr 1 `append` - -length :: Num u => Path u -> u -length (Path u _ _ _) = u - -append :: Floating u => Path u -> Path u -> Path u -append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) - | end1 == start2 = Path (len1+len2) start1 (se1 >< se2) end2 - | otherwise = let join = lineSegment end1 start2 - total_len = len1 + len2 + segmentLength join - in Path total_len start1 (se1 >< (join <| se2)) end2 - -pconcat :: Floating u => Path u -> [Path u] -> Path u -pconcat p0 ps = foldl' append p0 ps - -segmentLength :: PathSeg u -> u -segmentLength (LineSeg u _ _) = u -segmentLength (CurveSeg u _ _ _ _) = u - - -segmentStart :: PathSeg u -> Point2 u -segmentStart (LineSeg _ p0 _) = p0 -segmentStart (CurveSeg _ p0 _ _ _) = p0 - -segmentEnd :: PathSeg u -> Point2 u -segmentEnd (LineSeg _ _ p1) = p1 -segmentEnd (CurveSeg _ _ _ _ p3) = p3 - - - - -lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u -lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1 - -line :: Floating u => Point2 u -> Point2 u -> Path u -line p0 p1 = let v = vlength $ pvec p0 p1 - in Path v p0 (S.singleton $ LineSeg v p0 p1) p1 - - -curve :: (Floating u, Ord u) - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u -curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3 - in Path v p0 (S.singleton $ CurveSeg v p0 p1 p2 p3) p3 - --- | A draw a /straight line/ of length 0 at the supplied point. --- --- This is /might/ be useful in concatenating curved paths --- as it introduces and extra control point. --- -pivot :: Floating u => Point2 u -> Path u -pivot p0 = Path 0 p0 (S.singleton $ LineSeg 0 p0 p0) p0 - - --- | 'traceLinePoints' throws a runtime error if the supplied list --- is empty. --- -traceLinePoints :: Floating u => [Point2 u] -> Path u -traceLinePoints [] = error "traceLinePoints - empty point list." -traceLinePoints [a] = line a a -traceLinePoints (a:b:xs) = step (line a b) b xs - where - step acc _ [] = acc - step acc e (y:ys) = step (acc `append` line e y) y ys - - --- | 'traceCurvePoints' consumes 4 points from the list on the --- intial step (start, control1, control2, end) then steps --- through the list taking 3 points at a time thereafter --- (control1,control2, end). Leftover points are discarded. --- --- 'traceCurvePoints' throws a runtime error if the supplied list --- is has less than 4 elements (start, control1, control2, end). --- -traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u -traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs - where - step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs - step acc _ _ = acc - -traceCurvePoints _ = error "tracePointsCurve - less than 4 elems." - - -curveByAngles :: (Floating u, Ord u) - => Point2 u -> Radian -> Radian -> Point2 u -> Path u -curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end - where - sz = 0.375 * (vlength $ pvec start end) - v1 = avec cin sz - v2 = avec cout sz - - - --- | Turn a Path into an ordinary PrimPath. --- --- Assumes path is properly formed - i.e. end point of one --- segment is the same point as the start point of the next --- segment. --- -toPrimPath :: Num u => Path u -> PrimPath u -toPrimPath (Path _ _ segs _) = step1 $ viewl segs - where - step1 EmptyL = error "toPrimPath - (not) unreachable." - step1 (e :< se) = let (start,a) = seg1 e in - primPath start $ a : step2 (viewl se) - - step2 EmptyL = [] - step2 (e :< se) = seg2 e : step2 (viewl se) - - seg1 (LineSeg _ p0 p1) = (p0, lineTo p1) - seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3) - - seg2 (LineSeg _ _ p1) = lineTo p1 - seg2 (CurveSeg _ _ p1 p2 p3) = curveTo p1 p2 p3 - - - --------------------------------------------------------------------------------- --- Curve length - -data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u) - -curveLength :: (Floating u, Ord u) - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u -curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3 - - --- | Jens Gravesen\'s bezier arc-length approximation. --- --- Note this implementation is parametrized on error tolerance. --- -gravesenLength :: (Floating u, Ord u) => u -> StrictCurve 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 - - -ctrlPolyLength :: Floating u => StrictCurve u -> u -ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3 - where - len pa pb = vlength $ pvec pa pb - -cordLength :: Floating u => StrictCurve u -> u -cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3 - - --- | mid-point between two points --- -pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u -pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0 - - --- | Curve subdivision via de Casteljau\'s algorithm. --- -subdivide :: Fractional u - => StrictCurve u -> (StrictCurve u, StrictCurve u) -subdivide (Curve p0 p1 p2 p3) = - (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) - where - p01 = pointMidpoint p0 p1 - p12 = pointMidpoint p1 p2 - p23 = pointMidpoint p2 p3 - p012 = pointMidpoint p01 p12 - p123 = pointMidpoint p12 p23 - p0123 = pointMidpoint p012 p123 - --- | subdivide with an affine weight along the line... --- -subdividet :: Real u - => u -> StrictCurve u -> (StrictCurve u, StrictCurve u) -subdividet t (Curve p0 p1 p2 p3) = - (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) - where - p01 = affineCombination t p0 p1 - p12 = affineCombination t p1 p2 - p23 = affineCombination t p2 p3 - p012 = affineCombination t p01 p12 - p123 = affineCombination t p12 p23 - p0123 = affineCombination t p012 p123 - -affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u -affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1) - --------------------------------------------------------------------------------- --- tips - -tipL :: Path u -> Point2 u -tipL (Path _ sp _ _) = sp - - -tipR :: Path u -> Point2 u -tipR (Path _ _ _ ep) = ep - - --- | Shorten both ends... --- --- u should be less-than half the path length --- -shortenBoth :: (Real u, Floating u) => u -> Path u -> Path u -shortenBoth u p = shortenL u $ shortenR u p - --------------------------------------------------------------------------------- --- shorten from the left... - --- | Note - shortening a line from the left by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the end point. --- -shortenL :: (Real u, Floating u) => u -> Path u -> Path u -shortenL n (Path u _ segs ep) - | n >= u = line ep ep - | otherwise = step n (viewl segs) - where - step _ EmptyL = line ep ep -- should be unreachable - step d (e :< se) = let z = segmentLength e in - case compare d z of - GT -> step (d-z) (viewl se) - EQ -> makeLeftPath (u-n) se ep - LT -> let e1 = shortenSegL d e - in Path (u-n) (segmentStart e1) (e1 <| se) ep - - -makeLeftPath :: Floating u => u -> Seq (PathSeg u) -> Point2 u -> Path u -makeLeftPath u se ep = - case viewl se of - EmptyL -> line ep ep - (e :< _) -> Path u (segmentStart e) se ep - - -shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u -shortenSegL n (LineSeg u p0 p1) = - LineSeg (u-n) (shortenLineL n p0 p1) p1 - -shortenSegL n (CurveSeg u p0 p1 p2 p3) = - let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3) - in CurveSeg (u-n) p0' p1' p2' p3' - - -shortenLineL :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -shortenLineL n p0 p1 = p0 .+^ v - where - v0 = p1 .-. p0 - v = avec (direction v0) n - - - --------------------------------------------------------------------------------- --- shorten from the right ... - --- | Note - shortening a line from the right by --- greater-than-or-equal its length is operationally equivalent --- to making a zero-length line at the start point. --- -shortenR :: (Real u, Floating u) => u -> Path u -> Path u -shortenR n (Path u sp segs _) - | n >= u = line sp sp - | otherwise = step n (viewr segs) - where - step _ EmptyR = line sp sp -- should be unreachable - step d (se :> e) = let z = segmentLength e in - case compare d z of - GT -> step (d-z) (viewr se) - EQ -> makeRightPath n sp se - LT -> let e1 = shortenSegR d e - in Path (u-n) sp (se |> e1) (segmentEnd e1) - - -makeRightPath :: Floating u => u -> Point2 u -> Seq (PathSeg u) -> Path u -makeRightPath u sp se = - case viewr se of - EmptyR -> line sp sp - (_ :> e) -> Path u sp se (segmentEnd e) - - - -shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u -shortenSegR n (LineSeg u p0 p1) = - LineSeg (u-n) p0 (shortenLineR n p0 p1) - -shortenSegR n (CurveSeg u p0 p1 p2 p3) = - let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3) - in CurveSeg (u-n) p0' p1' p2' p3' - - -shortenLineR :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -shortenLineR n p0 p1 = p1 .+^ v - where - v0 = p0 .-. p1 - v = avec (direction v0) n - - - - --------------------------------------------------------------------------------- --- line direction - --- | Direction of empty path is considered to be 0. --- -directionL :: (Real u, Floating u) => Path u -> Radian -directionL (Path _ _ se _) = step $ viewl se - where - step (LineSeg _ p0 p1 :< _) = lineDirection p1 p0 -- 1-to-0 - step (CurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0 - step _ = 0 -- should be unreachable - - --- | Direction of empty path is considered to be 0. --- -directionR :: (Real u, Floating u) => Path u -> Radian -directionR (Path _ _ se _) = step $ viewr se - where - step (_ :> LineSeg _ p0 p1) = lineDirection p0 p1 - step (_ :> CurveSeg _ _ _ p2 p3) = lineDirection p2 p3 - step _ = 0 -- should be unreachable - - - - --------------------------------------------------------------------------------- - - --- Return direction as well because the calculation is expensive... --- -midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -midway pa@(Path u sp _ _) - | u == 0 = (sp,0) - | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) - --- Just the midway point. --- -midway_ :: (Real u, Floating u) => Path u -> Point2 u -midway_ = fst . midway - - -atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -atstart pa@(Path _ sp _ _) = (sp, directionL pa) - -atstart_ :: Path u -> Point2 u -atstart_ (Path _ sp _ _) = sp - - -atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian) -atend pa@(Path _ _ _ ep) = (ep, directionR pa) - - -atend_ :: Path u -> Point2 u -atend_ (Path _ _ _ ep) = ep - - --- nearstart, nearend, verynear ... - - --------------------------------------------------------------------------------- - -data PathViewL u = PathOneL (PathSegment u) - | PathSegment u :<< Path u - deriving (Eq,Ord,Show) - -type DPathViewL = PathViewL Double - -data PathViewR u = PathOneR (PathSegment u) - | Path u :>> PathSegment u - deriving (Eq,Ord,Show) - -type DPathViewR = PathViewR Double - - -data PathSegment u = Line1 (Point2 u) (Point2 u) - | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u) - deriving (Eq,Ord,Show) - -type DPathSegment = PathSegment Double - -type instance DUnit (PathViewL u) = u -type instance DUnit (PathViewR u) = u -type instance DUnit (PathSegment u) = u - -pathViewL :: Num u => Path u -> PathViewL u -pathViewL (Path u _ segs ep) = go (viewl segs) - where - go EmptyL = error "pathViewL - (not) unreachable." - - go (LineSeg v p0 p1 :< se) - | S.null se = PathOneL (Line1 p0 p1) - | otherwise = Line1 p0 p1 :<< Path (u-v) p1 se ep - - go (CurveSeg v p0 p1 p2 p3 :< se) - | S.null se = PathOneL (Curve1 p0 p1 p2 p3) - | otherwise = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep - - -pathViewR :: Num u => Path u -> PathViewR u -pathViewR (Path u _ segs ep) = go (viewr segs) - where - go EmptyR = error "pathViewR - (not) unreachable." - - go (se :> LineSeg v p0 p1) - | S.null se = PathOneR (Line1 p0 p1) - | otherwise = Path (u-v) p1 se ep :>> Line1 p0 p1 - - go (se :> CurveSeg v p0 p1 p2 p3) - | S.null se = PathOneR (Curve1 p0 p1 p2 p3) - | otherwise = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3 - diff --git a/src/Wumpus/Basic/Paths/Connectors.hs b/src/Wumpus/Basic/Paths/Connectors.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths/Connectors.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Library of connector paths... --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths.Connectors - ( - - ConnectorPath - , DConnectorPath - - , connLine - - , connRightVH - , connRightHV - , connRightVHV - , connRightHVH - - , connIsosceles - , connIsosceles2 - , connLightningBolt - - - , connIsoscelesCurve - , connSquareCurve - , connUSquareCurve - - , connTrapezoidCurve - , connZSquareCurve - , connUZSquareCurve - - ) where - -import Wumpus.Basic.Paths.Base -import Wumpus.Basic.Paths.ControlPoints - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Prelude hiding ( length ) - - - -type ConnectorPath u = Point2 u -> Point2 u -> Path u - -type DConnectorPath = ConnectorPath Double - --------------------------------------------------------------------------------- - --- | Connect with a straight line. --- -connLine :: Floating u => ConnectorPath u -connLine = line - --- | Right-angled connector - go vertical, then go horizontal. --- -connRightVH :: Floating u => ConnectorPath u -connRightVH p1@(P2 x1 _) p2@(P2 _ y2) = - let mid = P2 x1 y2 in traceLinePoints [p1, mid, p2] - --- | Right-angled connector - go horizontal, then go vertical. --- -connRightHV :: Floating u => ConnectorPath u -connRightHV p1@(P2 _ y1) p2@(P2 x2 _) = - let mid = P2 x2 y1 in traceLinePoints [p1, mid, p2] - --- | Right-angled connector - go vertical for the supplied --- distance, go horizontal, go vertical again for the --- remaining distance. --- -connRightVHV :: Floating u => u -> ConnectorPath u -connRightVHV v p1@(P2 x1 _) p2@(P2 x2 _) = traceLinePoints [p1, a1, a2, p2] - where - a1 = p1 .+^ vvec v - a2 = a1 .+^ hvec (x2 - x1) - - --- | Right-angled connector - go horizontal for the supplied --- distance, go verical, go horizontal again for the --- remaining distance. --- -connRightHVH :: Floating u => u -> ConnectorPath u -connRightHVH h p1@(P2 _ y1) p2@(P2 _ y2) = traceLinePoints [p1,a1,a2,p2] - where - a1 = p1 .+^ hvec h - a2 = a1 .+^ vvec (y2 - y1) - - --- | /Triangular/ joint. --- --- @u@ is the altitude of the triangle. --- -connIsosceles :: (Real u, Floating u) => u -> ConnectorPath u -connIsosceles dy p1 p2 = traceLinePoints [p1, mid_pt, p2] - where - mid_pt = midpointIsosceles dy p1 p2 - - - --- | Double /triangular/ joint. --- --- @u@ is the altitude of the triangle. --- -connIsosceles2 :: (Real u, Floating u) => u -> ConnectorPath u -connIsosceles2 u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ] - where - (cp1,cp2) = dblpointIsosceles u p1 p2 - - --- | /Lightning bolt/ joint - a two joint connector with an /axis/ --- perpendicular to the connector direction. --- --- @u@ is the half length of the of the axis. --- -connLightningBolt :: (Real u, Floating u) => u -> ConnectorPath u -connLightningBolt u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ] - where - cp1 = midpointIsosceles u p1 p2 - cp2 = midpointIsosceles (-u) p1 p2 - --------------------------------------------------------------------------------- - - - --- | Form a curve inside an isosceles triangle. --- --- The two Bezier control points take the same point - the --- altitude of the triangle. The curve tends to be quite shallow --- relative to the altitude. --- --- @u@ is the altitude of the triangle. --- -connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u -connIsoscelesCurve u p1 p2 = traceCurvePoints [p1, control_pt, control_pt, p2] - where - control_pt = midpointIsosceles u p1 p2 - - - --- | Form a curve inside a square. --- --- The two Bezier control points take the /top/ corners. The --- curve tends to be very deep. --- -connSquareCurve :: (Real u, Floating u) => ConnectorPath u -connSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] - where - (cp1,cp2) = squareFromBasePoints p1 p2 - --- | Form a curve inside a square. --- --- As per 'connSquareCurve' but the curve is drawn /underneath/ --- the line formed between the start and end points. --- --- (Underneath is modulo the direction, of course). --- -connUSquareCurve :: (Real u, Floating u) => ConnectorPath u -connUSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] - where - (cp1,cp2) = usquareFromBasePoints p1 p2 - - - --- | altitude * ratio_to_base --- --- Form a curve inside a trapeziod. --- -connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u -connTrapezoidCurve u ratio_to_base p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] - where - (cp1,cp2) = trapezoidFromBasePoints u ratio_to_base p1 p2 - - --- | Make a curve within a square, following the corner points as --- a Z. --- -connZSquareCurve :: (Real u, Floating u) => ConnectorPath u -connZSquareCurve p1 p2 = traceCurvePoints [p1,cp1,cp2,p2] - where - (cp1,cp2) = squareFromCornerPoints p1 p2 - --- | Make a curve within a square, following the corner points as --- a Z. --- --- The order of tracing flips the control points, so this is an --- /underneath/ version of 'connZSquareCurve'. --- -connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u -connUZSquareCurve p1 p2 = traceCurvePoints [p1,cp2,cp1,p2] - where - (cp1,cp2) = squareFromCornerPoints p1 p2 diff --git a/src/Wumpus/Basic/Paths/Construction.hs b/src/Wumpus/Basic/Paths/Construction.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths/Construction.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths.Construction --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Build paths monadically. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths.Construction - ( - - PathM - , runPath - , execPath - - , tip - - , lineto - , rlineto - , hline - , vline - - , bezierto - , curveto - - , verticalHorizontal - , horizontalVertical - - ) where - -import Wumpus.Basic.Paths.Base -import Wumpus.Basic.Utils.HList - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative -import Data.List - - --- Are connectors and paths quite different things? --- --- It looks like they are - connectors always know start and end --- points. --- - - --- State monad version is quite good - it ameliorates the problem --- of joining to the end point of an empty path... - -data St u = St - { current_point :: Point2 u - , path_acc :: H (Path u) - } - - -newtype PathM u a = PathM { getPathM :: St u -> (a,St u) } - - -instance Functor (PathM u) where - fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1) - - -instance Applicative (PathM u) where - pure a = PathM $ \s -> (a,s) - mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s - (a,s2) = getPathM ma s1 - in (f a,s2) - -instance Monad (PathM u) where - return a = PathM $ \s -> (a,s) - m >>= k = PathM $ \s -> let (a,s1) = getPathM m s in - (getPathM . k) a s1 - - - --- Running the path is (probably) agnostic to the DrawingCtx. --- -runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u) -runPath start mf = - let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s') - where - s = St { current_point = start - , path_acc = emptyH - } - post [] = line start start - post (x:xs) = foldl' append x xs - -execPath :: Floating u => Point2 u -> PathM u a -> Path u -execPath start mf = snd $ runPath start mf - -snocline :: Floating u => Vec2 u -> PathM u () -snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v - in ((), St ep (ac `snocH` line pt ep)) - - -tip :: PathM u (Point2 u) -tip = PathM $ \s -> (current_point s,s) - - -lineto :: Floating u => Point2 u -> PathM u () -lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt)) - -rlineto :: Floating u => Vec2 u -> PathM u () -rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) - - -hline :: Floating u => u -> PathM u () -hline len = snocline (hvec len) - -vline :: Floating u => u -> PathM u () -vline len = snocline (vvec len) - - - -bezierto :: (Floating u, Ord u) - => Point2 u -> Point2 u -> Point2 u -> PathM u () -bezierto c1 c2 ep = PathM $ \(St p0 ac) -> - ((), St ep (ac `snocH` curve p0 c1 c2 ep)) - - - - - --- - - -curveto :: (Floating u, Ord u) - => Radian -> Radian -> Point2 u -> PathM u () -curveto cin cout end = PathM $ \(St p0 ac) -> - let seg = curveByAngles p0 cin cout end - ac1 = ac `snocH` seg - end1 = tipR seg - in ((), St end1 ac1) - - - - -verticalHorizontal :: Floating u => Point2 u -> PathM u () -verticalHorizontal (P2 x y) = - tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y) - -horizontalVertical :: Floating u => Point2 u -> PathM u () -horizontalVertical (P2 x y) = - tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y) - diff --git a/src/Wumpus/Basic/Paths/ControlPoints.hs b/src/Wumpus/Basic/Paths/ControlPoints.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths/ControlPoints.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths.ControlPoints --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Collection of point manufacturing functions. --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths.ControlPoints - ( - - midpointIsosceles - , dblpointIsosceles - - , rectangleFromBasePoints - , squareFromBasePoints - , usquareFromBasePoints - - , trapezoidFromBasePoints - - , squareFromCornerPoints - - ) where - -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - - - --- | 'midpointIsosceles' : --- @ altitude * start_pt * end_pt -> mid_pt @ --- --- Triangular midpoint. --- --- @u@ is the altitude of the triangle - negative values of u --- form the triangle below the line. --- -midpointIsosceles :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = - mid_pt .+^ avec perp_ang u - where - mid_pt = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1)) - perp_ang = (pi*0.5) + direction (pvec p1 p2) - - - --- | 'dblpointIsosceles' : --- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @ --- --- Double triangular joint - one joint at a third of the line --- length, the other at two thirds. --- -dblpointIsosceles :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) -dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = - (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u) - where - mid1 = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1)) - mid2 = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1)) - perp_ang = (pi*0.5) + direction (pvec p1 p2) - - --------------------------------------------------------------------------------- - - - --- | 'rectangleFromBasePoints' : --- @ altitude * start_pt * end_pt * (top_left, top_right) @ --- --- Control points forming a rectangle. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -rectangleFromBasePoints :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) -rectangleFromBasePoints u p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - theta = direction base_vec - cp1 = displacePerpendicular u theta p1 - cp2 = displacePerpendicular u theta p2 - - --- | 'squareFromBasePoints' : --- @ start_pt -> end_pt -> (top_left, top_right) @ --- --- Control points forming a square - side_len derived from the --- distance between start and end points. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -squareFromBasePoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 - where - side_len = vlength $ pvec p1 p2 - - --- | 'usquareFromBasePoints' : --- @ start_pt -> end_pt -> (bottom_left, bottom_right) @ --- --- Control points forming a square - side_len derived from the --- distance between start and end points. --- --- As per 'squareFromBasePoints' but the square is drawn --- /underneath/ the line formed between the start and end points. --- (Underneath is modulo the direction, of course). --- --- The two manufactured control points form the /bottom/ corners, --- so the supplied points map as @start_point == top_left@ and --- @end_point == top_right@. --- -usquareFromBasePoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 - where - side_len = negate $ vlength $ pvec p1 p2 - - - - - --- | 'trapezoidFromBasePoints' : --- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @ --- --- Control points form an isosceles trapezoid. --- --- The two manufactured control points form the top corners, --- so the supplied points map as @start_point == bottom_left@ and --- @end_point == bottom_right@. --- -trapezoidFromBasePoints :: (Real u, Floating u) - => u -> u -> Point2 u -> Point2 u - -> (Point2 u, Point2 u) -trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - base_len = vlength base_vec - theta = direction base_vec - half_ulen = 0.5 * ratio_to_base * base_len - base_mid = displaceParallel (0.5 * base_len) theta p1 - ubase_mid = displacePerpendicular u theta base_mid - cp1 = displaceParallel (-half_ulen) theta ubase_mid - cp2 = displaceParallel half_ulen theta ubase_mid - - - - --- | 'squareFromCornerPoints' : --- @ altitude * start_pt * end_pt * (top_left, bottom_right) @ --- --- Control points forming a square bisected by the line from --- start_pt to end_pt. --- --- The two manufactured control points form the top_left and --- bottom_right corners, so the supplied points map as --- @start_point == bottom_left@ and @end_point == top_right@. --- -squareFromCornerPoints :: (Real u, Floating u) - => Point2 u -> Point2 u -> (Point2 u, Point2 u) -squareFromCornerPoints p1 p2 = (cp1, cp2) - where - base_vec = pvec p1 p2 - half_len = 0.5 * (vlength base_vec) - theta = direction base_vec - base_mid = displaceParallel half_len theta p1 - cp1 = displacePerpendicular half_len theta base_mid - cp2 = displacePerpendicular (-half_len) theta base_mid - diff --git a/src/Wumpus/Basic/Paths/RoundCorners.hs b/src/Wumpus/Basic/Paths/RoundCorners.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Paths/RoundCorners.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Paths.RoundCorners --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Drawing round cornered polygons. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Paths.RoundCorners - ( - cornerCurve - , illustratePath - , roundEvery - - ) where - -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths.Base hiding ( length ) -import Wumpus.Basic.Utils.Intersection - - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - --- | The length of the control-point vector wants to be slighly --- longer than half of /d/ (d - being the distance between the --- /truncated/ points and the corner). --- -cornerCurve :: (Real u, Floating u) - => Point2 u -> Point2 u -> Point2 u -> Path u -cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3 - where - len1 = 0.6 * (vlength $ pvec p1 p2) - len2 = 0.6 * (vlength $ pvec p3 p2) - cp1 = p1 .+^ (avec (langle p1 p2) len1) - cp2 = p3 .+^ (avec (langle p3 p2) len2) - - --- | 'roundEvery' throws a runtime error if the input list has --- less than 3 eleemnts. --- -roundEvery :: (Real u, Floating u) - => u -> [Point2 u] -> Path u -roundEvery u (start:b:c:xs) = step (twoParts u start b c) (b:c:xs) - where - step acc (m:n:o:ps) = step (acc `append` twoParts u m n o) (n:o:ps) - step acc [n,o] = acc `append` twoParts u n o start - `append` twoParts u o start b - step acc _ = acc - -roundEvery _ _ = error "roundEvery - input list too short." - - --- | Two parts - line and corner curve... --- -twoParts :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -> Path u -twoParts u a b c = line p1 p2 `append` cornerCurve p2 b p3 - where - p1 = a .+^ (avec (direction $ pvec a b) u) - p2 = b .+^ (avec (direction $ pvec b a) u) - p3 = b .+^ (avec (direction $ pvec b c) u) - - - --------------------------------------------------------------------------------- --- - --- This needs moving outside of the Path modules as it has --- dependencies on SVGColour and Graphic (the Path modules should --- be /neutral/ to wards depenedencies on other parts of --- Wumpus-Basic). --- - -illustratePath :: Fractional u => Path u -> Graphic u -illustratePath = localize (strokeColour black) . step1 . pathViewL - where - step1 (PathOneL e) = drawPath1 e - step1 (e :<< se) = drawPathBoth e `oplus` rest (pathViewL se) - - rest (PathOneL e) = drawPath1 e - rest (e :<< se) = drawPath1 e `oplus` rest (pathViewL se) - -drawPathBoth :: Fractional u => PathSegment u -> Graphic u -drawPathBoth pa@(Line1 p1 _) = drawPath1 pa `oplus` pathPoint p1 -drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `oplus` pathPoint p1 - - - - -drawPath1 :: Fractional u => PathSegment u -> Graphic u -drawPath1 (Line1 p1 p2) = - straightLineBetween p1 p2 `oplus` pathPoint p2 - -drawPath1 (Curve1 p1 p2 p3 p4) = - oconcat (bezierCtrl p1 p2) [ bezierCtrl p4 p3, curveBetween p1 p2 p3 p4 - , pathPoint p4 ] - - --- WARNING - This indicates that straightLineBetween is not --- consistent with other prim graphics... - -bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u -bezierCtrl p1 p2 = localize (strokeColour light_steel_blue . fillColour red) $ - straightLineBetween p1 p2 `oplus` (filledDisk 1 `at` p2) - - -pathPoint :: Num u => Point2 u -> Graphic u -pathPoint pt = localize bothStrokeColour (filledDisk 1 `at` pt) - diff --git a/src/Wumpus/Basic/SafeFonts.hs b/src/Wumpus/Basic/SafeFonts.hs deleted file mode 100644 --- a/src/Wumpus/Basic/SafeFonts.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.SafeFonts --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Safe to use \"Core 13\" fonts that are expected to be present --- for any PostScript interpreter. --- --- Note - regrettably Symbol is not safe to use for SVG. --- --- \*\* WARNING \*\* - this module is in flux due to changes to --- Text encoding in Wumpus-Core and adding font metrics to --- Wumpus-Basic. The code here is likely to be revised. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.SafeFonts - ( - -- * Times Roman - times_roman - , times_italic - , times_bold - , times_bold_italic - - -- * Helvetica - , helvetica - , helvetica_oblique - , helvetica_bold - , helvetica_bold_oblique - - -- * Courier - , courier - , courier_oblique - , courier_bold - , courier_bold_oblique - - -- * Symbol - , symbol - - ) where - - - -import Wumpus.Core -import Wumpus.Core.Text.StandardEncoding -import Wumpus.Core.Text.Symbol - --- Supported fonts are: --- --- Times-Roman Times-Italic Times-Bold Times-BoldItalic --- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique --- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique --- Symbol - --------------------------------------------------------------------------------- --- - --- | Times-Roman --- -times_roman :: FontFace -times_roman = - FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding - --- | Times Italic --- -times_italic :: FontFace -times_italic = - FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding - --- | Times Bold --- -times_bold :: FontFace -times_bold = - FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding - --- | Times Bold Italic --- -times_bold_italic :: FontFace -times_bold_italic = FontFace "Times-BoldItalic" - "Times New Roman" - SVG_BOLD_ITALIC - standard_encoding - - --------------------------------------------------------------------------------- --- Helvetica - --- | Helvetica --- -helvetica :: FontFace -helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding - - --- | Helvetica Oblique --- -helvetica_oblique :: FontFace -helvetica_oblique = - FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding - --- | Helvetica Bold --- -helvetica_bold :: FontFace -helvetica_bold = - FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding - - --- | Helvetica Bold Oblique --- -helvetica_bold_oblique :: FontFace -helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" - "Helvetica" - SVG_BOLD_OBLIQUE - standard_encoding - - - --------------------------------------------------------------------------------- - --- | Courier --- -courier :: FontFace -courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding - --- | Courier Oblique --- -courier_oblique :: FontFace -courier_oblique = - FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding - --- | Courier Bold --- -courier_bold :: FontFace -courier_bold = - FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding - - --- | Courier Bold Oblique --- -courier_bold_oblique :: FontFace -courier_bold_oblique = FontFace "Courier-Bold-Oblique" - "Courier New" - SVG_BOLD_OBLIQUE - standard_encoding - --------------------------------------------------------------------------------- --- Symbol - --- | Symbol --- --- Note - Symbol is intentionally not supported for SVG by some --- renderers (Firefox). Chrome is fine, but the use of symbol --- should be still be avoided for web graphics. --- -symbol :: FontFace -symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding - - - - - diff --git a/src/Wumpus/Basic/Shapes.hs b/src/Wumpus/Basic/Shapes.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Shapes.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Shapes --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim module for Shapes. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Shapes - ( - module Wumpus.Basic.Shapes.Base - , module Wumpus.Basic.Shapes.Coordinate - , module Wumpus.Basic.Shapes.Derived - - ) where - -import Wumpus.Basic.Shapes.Base -import Wumpus.Basic.Shapes.Coordinate -import Wumpus.Basic.Shapes.Derived hiding ( mkRectangle ) diff --git a/src/Wumpus/Basic/Shapes/Base.hs b/src/Wumpus/Basic/Shapes/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Shapes/Base.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Shapes.Base --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Common core for shapes --- --- \*\* WARNING \*\* - the types of Shapes are not ideal and are --- pending revision. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Shapes.Base - ( - - - Shape - , LocShape - , makeShape - - , ShapeConstructor - - , borderedShape - , filledShape - , strokedShape - - -- * ShapeCTM - , ShapeCTM - , makeShapeCTM - - , ShapeGeom - , runShapeGeom - , askCTM - , projectPoint - , shapeCenter - , shapeAngle - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths - -import Wumpus.Core -- package: wumpus-core - - -import Control.Applicative - - --- Currently shapes that aren\'t paths: --- --- > Coordinate --- > FreeLabel --- --- Alternative --- --- > out_fun :: ShapeCTM u -> (Path u,sh) --- --- All shapes expect FreeLabel are oblivious to the --- DrawingContext for the /shape/ --- - -newtype ShapeR u a = ShapeR { getShapeR :: ShapeCTM u -> a } - -runShapeR :: ShapeCTM u -> ShapeR u a -> a -runShapeR ctm sf = getShapeR sf ctm - - -data Shape u t = Shape - { shape_ctm :: ShapeCTM u - , path_fun :: ShapeR u (Path u) - , cons_fun :: ShapeR u (t u) - } - -type instance DUnit (Shape u sh) = u - - -type LocShape u t = Point2 u -> Shape u t - -type ShapeConstructor u t = ShapeCTM u -> t u - - -makeShape :: Num u - => (ShapeCTM u -> Path u) -> (ShapeCTM u -> t u) -> LocShape u t -makeShape pf mkf = \pt -> Shape { shape_ctm = makeShapeCTM pt - , path_fun = ShapeR pf - , cons_fun = ShapeR mkf - } - - -shapeImage :: Num u => (PrimPath u -> Graphic u) -> Shape u t -> Image u (t u) -shapeImage drawF (Shape { shape_ctm = ctm, path_fun = pf, cons_fun = objf }) = - intoImage (pure $ runShapeR ctm objf) - (drawF $ toPrimPath $ runShapeR ctm pf) - - -borderedShape :: Num u => Shape u t -> Image u (t u) -borderedShape = shapeImage borderedPath - -filledShape :: Num u => Shape u t -> Image u (t u) -filledShape = shapeImage filledPath - -strokedShape :: Num u => Shape u t -> Image u (t u) -strokedShape = shapeImage closedStroke - - - -instance (Real u, Floating u) => Rotate (Shape u sh) where - rotate r = updateCTM (rotate r) - -instance (Real u, Floating u) => RotateAbout (Shape u sh) where - rotateAbout r pt = updateCTM (rotateAbout r pt) - -instance Num u => Scale (Shape u sh) where - scale sx sy = updateCTM (scale sx sy) - -instance Num u => Translate (Shape u sh) where - translate dx dy = updateCTM (translate dx dy) - - -updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh -updateCTM fn (Shape ctm pf mkf) = Shape (fn ctm) pf mkf - --------------------------------------------------------------------------------- --- CTM - --- Note - all shapes need a location (usually/always the center) --- so this needs to be stored in the CTM. --- - -data ShapeCTM u = ShapeCTM - { ctm_center :: Point2 u - , ctm_scale_x :: !u - , ctm_scale_y :: !u - , ctm_rotation :: Radian - } - deriving (Eq,Ord,Show) - - -type instance DUnit (ShapeCTM u) = u - -makeShapeCTM :: Num u => Point2 u -> ShapeCTM u -makeShapeCTM pt = ShapeCTM { ctm_center = pt - , ctm_scale_x = 1 - , ctm_scale_y = 1 - , ctm_rotation = 0 } - - - - - -instance Num u => Scale (ShapeCTM u) where - scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy }) - <*> ctm_scale_x <*> ctm_scale_y - - -instance Rotate (ShapeCTM u) where - rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang }) - <*> ctm_rotation - -instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where - rotateAbout ang pt = - (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang - , ctm_center = rotateAbout ang pt ctr }) - <*> ctm_center <*> ctm_rotation - - -instance Num u => Translate (ShapeCTM u) where - translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) }) - <*> ctm_center - - --------------------------------------------------------------------------------- - -newtype ShapeGeom u a = ShapeGeom { getShapeGeom :: ShapeCTM u -> a } - - -type instance MonUnit (ShapeGeom u) = u - - -instance Functor (ShapeGeom u) where - fmap f ma = ShapeGeom $ \ctx -> let a = getShapeGeom ma ctx in f a - -instance Applicative (ShapeGeom u) where - pure a = ShapeGeom $ \_ -> a - mf <*> ma = ShapeGeom $ \ctx -> let f = getShapeGeom mf ctx - a = getShapeGeom ma ctx - in (f a) - -instance Monad (ShapeGeom u) where - return a = ShapeGeom $ \_ -> a - m >>= k = ShapeGeom $ \ctx -> let a = getShapeGeom m ctx - in (getShapeGeom . k) a ctx - - - -runShapeGeom :: ShapeCTM u -> ShapeGeom u a -> a -runShapeGeom ctm mf = getShapeGeom mf ctm - -askCTM :: ShapeGeom u (ShapeCTM u) -askCTM = ShapeGeom $ \ctm -> ctm - -shapeCenter :: ShapeGeom u (Point2 u) -shapeCenter = ShapeGeom $ \ctm -> ctm_center ctm - -shapeAngle :: ShapeGeom u Radian -shapeAngle = ShapeGeom $ \ctm -> ctm_rotation ctm - - - -projectPoint :: (Real u, Floating u) => Point2 u -> ShapeGeom u (Point2 u) -projectPoint (P2 x y) = ShapeGeom $ - \(ShapeCTM { ctm_center = (P2 dx dy) - , ctm_scale_x = sx - , ctm_scale_y = sy - , ctm_rotation = theta }) -> - translate dx dy $ rotate theta $ P2 (sx*x) (sy*y) - diff --git a/src/Wumpus/Basic/Shapes/Coordinate.hs b/src/Wumpus/Basic/Shapes/Coordinate.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Shapes/Coordinate.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Shapes.Coordinate --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- A Coordinate is operationally like a shape but it can only be --- drawn as a dot or a cross and it only supports @CenterAnchor@. --- --- Coordinates support affine transformations, however --- transfomations only displace a coordinate\'s origin they do --- not change how it is drawn (one cannot elongate the drawing of --- a coordinate with a scale). This is why coordinates are not --- Shapes, though one major use of coordinates is to illustrate --- anchor points on Shapes. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Shapes.Coordinate - ( - CoordinateAnchor - , DCoordinateAnchor - , Coordinate - , DCoordinate - , coordinate - - , coordinateDot - , coordinateX - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Shapes.Base - -import Wumpus.Core -- package: wumpus-core - -import Control.Monad - --- Note - a CoordinateAnchor should _NOT_ have affine instances. --- --- However, a coordinate supports affine transformations. This --- follows the logic where Shapes transform but representations --- of their anchors (i.e. the concrete types Rectangle, Circle...) --- do not transform. --- - - --------------------------------------------------------------------------------- --- | Coordinate - -newtype CoordinateAnchor u = CoordinateAnchor { getCoordAnchor :: ShapeCTM u } - deriving (Eq,Ord,Show) - -type DCoordinateAnchor = CoordinateAnchor Double - -type instance DUnit (CoordinateAnchor u) = u - -newtype Coordinate u = Coordinate { getCoordinate :: CoordinateAnchor u } - deriving (Eq,Ord,Show) - -type DCoordinate = Coordinate Double - -type instance DUnit (Coordinate u) = u - -type LocCoordinate u = Point2 u -> Coordinate u - - - -runCoordinate :: ShapeGeom u a -> CoordinateAnchor u -> a -runCoordinate mf a = runShapeGeom (getCoordAnchor a) mf - - -instance (Real u, Floating u) => CenterAnchor (CoordinateAnchor u) where - center = runCoordinate shapeCenter - -cMap :: (ShapeCTM u -> ShapeCTM u) -> Coordinate u -> Coordinate u -cMap fn = Coordinate . CoordinateAnchor . fn . getCoordAnchor . getCoordinate - - --- Affine instances - -instance (Real u, Floating u) => Rotate (Coordinate u) where - rotate r = cMap (rotate r) - -instance (Real u, Floating u) => RotateAbout (Coordinate u) where - rotateAbout r pt = cMap (rotateAbout r pt) - -instance Num u => Scale (Coordinate u) where - scale sx sy = cMap (scale sx sy) - -instance Num u => Translate (Coordinate u) where - translate dx dy = cMap (translate dx dy) - - - -coordinate :: Num u => LocCoordinate u -coordinate = Coordinate . CoordinateAnchor . makeShapeCTM - - -coordinateDot :: (Real u, Floating u, FromPtSize u) - => Coordinate u -> Image u (CoordinateAnchor u) -coordinateDot x = intoImage (return $ getCoordinate x) (drawDot x) - - - --- | Note - the @x@ is drawn /regardless/ of any scaling or rotation. --- -coordinateX :: (Real u, Floating u, FromPtSize u) - => Coordinate u -> Image u (CoordinateAnchor u) -coordinateX x = intoImage (return $ getCoordinate x) (drawX x) - - - -quarterMarkHeight :: (Fractional u, FromPtSize u) => CF u -quarterMarkHeight = liftM (0.25*) markHeight - -drawDot :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u -drawDot coord = quarterMarkHeight >>= \qh -> - localize bothStrokeColour (filledEllipse qh qh `at` ctr) - where - ctr = center $ getCoordinate coord - -drawX :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u -drawX coord = quarterMarkHeight >>= \qh -> line1 qh `oplus` line2 qh - where - P2 x y = center $ getCoordinate coord - line1 h = straightLineBetween (P2 (x-h) (y-h)) (P2 (x+h) (y+h)) - line2 h = straightLineBetween (P2 (x+h) (y-h)) (P2 (x-h) (y+h)) - diff --git a/src/Wumpus/Basic/Shapes/Derived.hs b/src/Wumpus/Basic/Shapes/Derived.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Shapes/Derived.hs +++ /dev/null @@ -1,372 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Shapes.Derived --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Simple shapes - rectangle, circle diamond, ellipse. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Shapes.Derived - ( - Rectangle - , DRectangle - , rectangle - , rrectangle - - , mkRectangle -- hidden in Shim module - - , Circle - , DCircle - , circle - - , Diamond - , DDiamond - , diamond - , rdiamond - - , Ellipse - , DEllipse - , ellipse - - - ) where - -import Wumpus.Basic.Graphic -import Wumpus.Basic.Paths -import Wumpus.Basic.Paths.RoundCorners -import Wumpus.Basic.Shapes.Base -import Wumpus.Basic.Utils.Intersection - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - -import Control.Applicative - - --- Note - Specific shapes - Rectangle, Circle, etc. - should _NOT_ --- have affine instances. --- --- Transformations should only operate on the Shape type. Once a --- Shape has been drawn the resultant Rectangle, Circle... cannot --- be further transformed, as this would dis-associate the Anchors --- from the Graphic. --- - --------------------------------------------------------------------------------- --- Rectangle - -data Rectangle u = Rectangle - { rect_ctm :: ShapeCTM u - , rect_hw :: !u - , rect_hh :: !u - } - deriving (Eq,Ord,Show) - -type DRectangle = Rectangle Double - - -type instance DUnit (Rectangle u) = u - - -runRectangle :: (u -> u -> ShapeGeom u a) -> Rectangle u -> a -runRectangle mf (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = - runShapeGeom ctm $ mf hw hh - -instance (Real u, Floating u) => CenterAnchor (Rectangle u) where - center = runRectangle (\ _ _ -> shapeCenter) - - -instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where - north = runRectangle $ \_ hh -> projectPoint $ P2 0 hh - south = runRectangle $ \_ hh -> projectPoint $ P2 0 (-hh) - east = runRectangle $ \hw _ -> projectPoint $ P2 hw 0 - west = runRectangle $ \hw _ -> projectPoint $ P2 (-hw) 0 - -instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where - northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh - southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh) - southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh) - northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh - - -instance (Real u, Floating u) => RadialAnchor (Rectangle u) where - radialAnchor theta = runRectangle $ \hw hh -> - projectPoint $ rectangleIntersect hw hh theta - --- Note - the answer needs projecting with the CTM... --- -rectangleIntersect :: (Real u, Floating u) - => u -> u -> Radian -> Point2 u -rectangleIntersect hw hh theta = - maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh - - --- | 'rectangle' : @ width * height -> shape @ --- -rectangle :: (Real u, Floating u) => u -> u -> LocShape u Rectangle -rectangle w h = - makeShape (traceLinePoints . rectanglePoints (0.5*w) (0.5*h)) - (mkRectangle (0.5*w) (0.5*h)) - - --- | 'rectangle' : @ round_length * width * height -> shape @ --- -rrectangle :: (Real u, Floating u) => u -> u -> u -> LocShape u Rectangle -rrectangle round_dist w h = - makeShape (roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h)) - (mkRectangle (0.5*w) (0.5*h)) - - - - -mkRectangle :: u -> u -> ShapeConstructor u Rectangle -mkRectangle hw hh = \ctm -> - Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh } - - - -rectanglePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] -rectanglePoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [se,ne,nw,sw] - where - se = P2 hw (-hh) - ne = P2 hw hh - nw = P2 (-hw) hh - sw = P2 (-hw) (-hh) - - - - - --------------------------------------------------------------------------------- --- Circle - -data Circle u = Circle - { circ_ctm :: ShapeCTM u - , circ_radius :: !u - } - deriving (Eq,Show) - -type DCircle = Circle Double - -type instance DUnit (Circle u) = u - -runCircle :: (u -> ShapeGeom u a) -> Circle u -> a -runCircle mf (Circle { circ_ctm =ctm, circ_radius = radius }) = - runShapeGeom ctm $ mf radius - - -instance (Real u, Floating u) => CenterAnchor (Circle u) where - center = runCircle (\_ -> shapeCenter) - - -instance (Real u, Floating u) => CardinalAnchor (Circle u) where - north = runCircle $ \r -> projectPoint $ P2 0 r - south = runCircle $ \r -> projectPoint $ P2 0 (-r) - east = runCircle $ \r -> projectPoint $ P2 r 0 - west = runCircle $ \r -> projectPoint $ P2 (-r) 0 - - -instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where - northeast = radialAnchor (0.25*pi) - southeast = radialAnchor (1.75*pi) - southwest = radialAnchor (1.25*pi) - northwest = radialAnchor (0.75*pi) - - -instance (Real u, Floating u) => RadialAnchor (Circle u) where - radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r - - - --- | 'circle' : @ radius -> shape @ --- -circle :: (Real u, Floating u) => u -> LocShape u Circle -circle radius = makeShape (traceCurvePoints . circlePoints radius) - (mkCircle radius) - - - -mkCircle :: u -> ShapeConstructor u Circle -mkCircle radius = \ctm -> Circle { circ_ctm = ctm, circ_radius = radius } - - -circlePoints :: (Real u, Floating u) => u -> ShapeCTM u -> [Point2 u] -circlePoints radius ctm = runShapeGeom ctm $ mapM projectPoint all_points - where - all_points = bezierCircle 2 radius zeroPt - - - --------------------------------------------------------------------------------- --- Diamond - - -data Diamond u = Diamond - { dia_ctm :: ShapeCTM u - , dia_hw :: !u - , dia_hh :: !u - } - -type DDiamond = Diamond Double - -type instance DUnit (Diamond u) = u - - - -runDiamond :: (u -> u -> ShapeGeom u a) -> Diamond u -> a -runDiamond mf (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = - runShapeGeom ctm $ mf hw hh - - -instance (Real u, Floating u) => CenterAnchor (Diamond u) where - center = runDiamond (\_ _ -> shapeCenter) - -instance (Real u, Floating u) => CardinalAnchor (Diamond u) where - north = runDiamond $ \_ hh -> projectPoint $ P2 0 hh - south = runDiamond $ \_ hh -> projectPoint $ P2 0 (-hh) - east = runDiamond $ \hw _ -> projectPoint $ P2 hw 0 - west = runDiamond $ \hw _ -> projectPoint $ P2 (-hw) 0 - -instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where - northeast x = midpoint (north x) (east x) - southeast x = midpoint (south x) (east x) - southwest x = midpoint (south x) (west x) - northwest x = midpoint (north x) (west x) - - - -instance (Real u, Floating u) => RadialAnchor (Diamond u) where - radialAnchor = diamondIntersect - --- Utils.Intersection needs improving... - - -diamondIntersect :: (Real u, Floating u) - => Radian -> Diamond u -> Point2 u -diamondIntersect theta = runDiamond $ \hw hh -> - (\ctr ctm -> let ps = diamondPoints hw hh ctm - in maybe ctr id $ findIntersect ctr theta $ polygonLines ps) - <$> shapeCenter <*> askCTM - - -midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u -midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v - --- | 'diamond' : @ half_width * half_height -> shape @ --- --- Note - args might change to tull_width and full_height... --- -diamond :: (Real u, Floating u) => u -> u -> LocShape u Diamond -diamond hw hh = - makeShape (traceLinePoints . diamondPoints hw hh) - (mkDiamond hw hh) - - --- | 'rdiamond' : @ round_length * half_width * half_height -> shape @ --- --- Note - args might change to full_width and full_height... --- -rdiamond :: (Real u, Floating u) => u -> u -> u -> LocShape u Diamond -rdiamond round_dist hw hh = - makeShape (roundEvery round_dist . diamondPoints hw hh) - (mkDiamond hw hh) - - - - - -mkDiamond :: (Real u, Floating u) => u -> u -> ShapeConstructor u Diamond -mkDiamond hw hh = \ctm -> Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh } - - -diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] -diamondPoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [ s, e, n, w ] - where - s = P2 0 (-hh) - e = P2 hw 0 - n = P2 0 hh - w = P2 (-hw) 0 - - --------------------------------------------------------------------------------- --- Ellipse - - -data Ellipse u = Ellipse - { ell_ctm :: ShapeCTM u - , ell_rx :: !u - , ell_ry :: !u - } - -type DEllipse = Ellipse Double - -type instance DUnit (Ellipse u) = u - - -runEllipse :: (u -> u -> ShapeGeom u a) -> Ellipse u -> a -runEllipse mf (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = - runShapeGeom ctm $ mf rx ry - - --- | x_radius is the unit length. --- -scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t -scaleEll rx ry = scale 1 (ry/rx) - - -instance (Real u, Floating u) => CenterAnchor (Ellipse u) where - center = runEllipse $ \_ _ -> shapeCenter - - -instance (Real u, Floating u) => RadialAnchor (Ellipse u) where - radialAnchor theta = runEllipse $ \rx ry -> - projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx - - -instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where - north = radialAnchor (0.5*pi) - south = radialAnchor (1.5*pi) - east = radialAnchor 0 - west = radialAnchor pi - - -instance (Real u, Floating u) => CardinalAnchor2 (Ellipse u) where - northeast = radialAnchor (0.25*pi) - southeast = radialAnchor (1.75*pi) - southwest = radialAnchor (1.25*pi) - northwest = radialAnchor (0.75*pi) - - --- | 'ellipse' : @ x_radii * y_radii -> shape @ --- -ellipse :: (Real u, Floating u) => u -> u -> LocShape u Ellipse -ellipse rx ry = - makeShape (traceCurvePoints . ellipsePoints rx ry) - (mkEllipse rx ry) - - -mkEllipse :: (Real u, Floating u) => u -> u -> ShapeConstructor u Ellipse -mkEllipse rx ry = \ctm -> Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry } - - -ellipsePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] -ellipsePoints rx ry ctm = - runShapeGeom ctm $ mapM (projectPoint . scaleEll rx ry) all_points - where - all_points = bezierCircle 2 rx zeroPt - - - diff --git a/src/Wumpus/Basic/System/FontLoader/Afm.hs b/src/Wumpus/Basic/System/FontLoader/Afm.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Afm.hs @@ -0,0 +1,82 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Afm +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font loader / import shim for the Adobe \"Core 14\" glyph +-- metrics. +-- +-- Use this loader if you have the Adode glyph metrics set +-- (AFM v4.1). This metrics set is avaiable from the Adobe +-- website. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Afm + ( + loadAfmMetrics + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser +import Wumpus.Basic.System.FontLoader.Base.Datatypes +import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad + + +import Wumpus.Core -- package: wumpus-core + +import Control.Monad +import Data.Monoid + +-- The file names of the Afm fonts match there PostScript names, +-- the only difference is the addition of a @.afm@ extension. +-- + +-- | 'loadAfmMetrics' : +-- @ path_to_afm_fonts * [font_name] -> IO (metrics, messages) @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadAfmMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String]) +loadAfmMetrics font_dir_path ns = + liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns + where + mkFun = afmLoadFontCalcs font_dir_path + + post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable... + post (Right xs,ss) = (foldr insertFont mempty xs, ss) + + + + +afmLoadFontCalcs :: FilePath -> FontName -> FontLoadIO FontMetricsOps +afmLoadFontCalcs font_dir_path name = do + logLoadMsg $ "Loading " ++ name + path <- checkFontPath font_dir_path (name ++ ".afm") + ans <- runParserFLIO path afmV4Dot1Parser + props <- buildAfmFontProps afm_mono_defaults_4_1 ans + return $ FontMetricsOps name (buildMetricsOps afmUnitScale props) + + + +-- | These are values extracted from Courier in the core 14 fonts. +-- +afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit +afm_mono_defaults_4_1 = + MonospaceDefaults { default_letter_bbox = bbox + , default_cap_height = 562 + , default_char_width = V2 600 0 + } + where + bbox = BBox (P2 (-23) (-250)) (P2 715 805) diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs @@ -0,0 +1,210 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Base.AfmParserBase +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common parsers for AFM files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.AfmParserBase + ( + + afmFileParser + , runQuery + , textQuery + + , getFontBBox + , getEncodingScheme + , getCapHeight + + , charBBox + , metric + , keyStringPair + , versionNumber + , startCharMetrics + + , keyName + , newlineOrEOF + , name + , name1 + , semi + , uptoNewline + , number + , cint + , hexInt + , octInt + + , lexeme + , symbol + , integer + , int + , double + + ) where + +import Wumpus.Basic.System.FontLoader.Base.Datatypes + +import Wumpus.Basic.Utils.ParserCombinators +import qualified Wumpus.Basic.Utils.TokenParsers as P + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +import Data.Char +import qualified Data.Map as Map + + +afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile +afmFileParser pgm = do + info <- (versionNumber *> globalInfo) + cms <- (startCharMetrics *> many pgm) + return $ AfmFile + { afm_encoding = getEncodingScheme info + , afm_letter_bbox = getFontBBox info + , afm_cap_height = getCapHeight info + , afm_glyph_metrics = cms + } + +globalInfo :: CharParser GlobalInfo +globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) + <$> manyTill keyStringPair (peek startCharMetrics) + + + +runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a +runQuery field_name p table = + Map.lookup field_name table >>= extr . runParser p + where + extr (Okay a _) = Just a + extr _ = Nothing + +textQuery :: String -> GlobalInfo -> Maybe String +textQuery = Map.lookup + + +-- | Strictly speaking a fontBBox is measured in integer units. +-- +getFontBBox :: GlobalInfo -> Maybe AfmBoundingBox +getFontBBox = runQuery "FontBBox" fontBBox + +getEncodingScheme :: GlobalInfo -> Maybe String +getEncodingScheme = textQuery "EncodingScheme" + +getCapHeight :: GlobalInfo -> Maybe AfmUnit +getCapHeight = runQuery "CapHeight" number + + +charBBox :: CharParser AfmBoundingBox +charBBox = symbol "B" *> fontBBox <* semi + +fontBBox :: CharParser AfmBoundingBox +fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury)) + <$> number <*> number <*> number <*> number + + + +metric :: String -> a -> CharParser a -> CharParser a +metric iden dfault p = option dfault go + where + go = symbol iden *> p <* semi + + + +keyStringPair :: CharParser (AfmKey,String) +keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF + "key-value line" + +versionNumber :: CharParser String +versionNumber = + symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF + "StartFontMetrics" + + +startCharMetrics :: CharParser Int +startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF + "StartCharMetrics failed" + + + +-------------------------------------------------------------------------------- + + +keyName :: CharParser AfmKey +keyName = lexeme (many1 $ satisfy isAlphaNum) + + +newlineOrEOF :: CharParser () +newlineOrEOF = skipOne (lexeme newline) <|> eof + + +uptoNewline :: CharParser String +uptoNewline = many1 (noneOf ['\n']) + + +name :: CharParser String +name = lexeme $ many (noneOf ";\n") + +name1 :: CharParser String +name1 = lexeme $ many (noneOf "; \t\n") + + + +semi :: CharParser Char +semi = lexeme $ char ';' + + + + +number :: CharParser AfmUnit +number = liftA realToFrac double + + +cint :: CharParser Int +cint = hexInt <|> octInt <|> int + + +hexInt :: CharParser Int +hexInt = lexeme $ between (char '<') (char '>') P.hexBase + + +octInt :: CharParser Int +octInt = lexeme $ char '\\' *> P.octBase + + + +-------------------------------------------------------------------------------- + +-- no newline in whitespace + + +lp :: P.LexemeParser +lp = P.commentLineLexemeParser "Comment" [' ', '\t'] + + +lexeme :: CharParser a -> CharParser a +lexeme = P.lexeme lp + +symbol :: String -> CharParser String +symbol = lexeme . string + +-- whiteSpace :: CharParser () +-- whiteSpace = P.whiteSpace lp + + +integer :: CharParser Integer +integer = lexeme P.integer + +int :: CharParser Int +int = fromIntegral <$> integer + +double :: CharParser Double +double = lexeme P.double diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Internal.AfmV2Parser +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 2.0. +-- +-- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ +-- have numerous differences. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.AfmV2Parser + ( + afmV2Parser + + ) where + +import Wumpus.Basic.System.FontLoader.Base.AfmParserBase +import Wumpus.Basic.System.FontLoader.Base.Datatypes +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + + + +-------------------------------------------------------------------------------- +-- parser + + +afmV2Parser :: CharParser AfmFile +afmV2Parser = afmFileParser charMetricsV2 + + +charMetricsV2 :: CharParser AfmGlyphMetrics +charMetricsV2 = AfmGlyphMetrics <$> + metric "C" (-1) cint + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-------------------------------------------------------------------------------- + + + + diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs @@ -0,0 +1,63 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 4.1. +-- +-- Adobe distributes font metrics for the /Core 14/ fonts as +-- AFM Version 4.1 files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser + ( + + afmV4Dot1Parser + ) where + +import Wumpus.Basic.System.FontLoader.Base.AfmParserBase +import Wumpus.Basic.System.FontLoader.Base.Datatypes +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +afmV4Dot1Parser :: CharParser AfmFile +afmV4Dot1Parser = afmFileParser charMetricsV4Dot1 + + +charMetricsV4Dot1 :: CharParser AfmGlyphMetrics +charMetricsV4Dot1 = AfmGlyphMetrics <$> + characterCode + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + + +-- Note - there are many variants for width vectors in in 4.1. +-- Wumpus needs some thought about what to do for them, it also +-- needs some facility to tell how successful the parse has been. + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-- V4.1 allows C int or CH \ +-- +characterCode :: CharParser Int +characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint diff --git a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Base.Datatypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Datatypes +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.Datatypes + ( + + -- * Afm Unit + AfmUnit + , afmValue + , afmUnitScale + + -- * Glyph metrics + + , PSCharCode + , PSEncodingScheme + , AfmBoundingBox + + , AfmKey + , GlobalInfo + , AfmFile(..) + , AfmGlyphMetrics(..) + + , MonospaceDefaults(..) + + , FontProps(..) + , buildMetricsOps + + ) where + + +import Wumpus.Basic.Kernel.Base.GlyphMetrics + +import Wumpus.Core -- package: wumpus-core + +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map + + + +-- | Wrapped Double representing 1\/1000 of the scale factor +-- (Point size) of a font. AFM files encode all measurements +-- as these units. +-- +newtype AfmUnit = AfmUnit { getAfmUnit :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + +instance Show AfmUnit where + showsPrec p d = showsPrec p (getAfmUnit d) + + +-- | Compute the size of a measurement in Afm units scaled by the +-- point size of the font. +-- +afmValue :: FromPtSize u => AfmUnit -> PtSize -> u +afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000) + +afmUnitScale :: AfmUnit -> PtSize +afmUnitScale u = (realToFrac $ getAfmUnit u / 1000) + + +-------------------------------------------------------------------------------- + +-- | Afm files index glyphs by /PostScript character code/. This +-- is not the same as Unicode, ASCII... +-- +-- It is expected to be determined by @EncodingScheme@ in the +-- Global Font Information Section. +-- +type PSCharCode = Int + +type PSEncodingScheme = String + +type AfmBoundingBox = BoundingBox AfmUnit + +type AfmKey = String +type GlobalInfo = Map.Map AfmKey String + + + +-- | Wumpus needs a very small subset of AFM files, common to both +-- version 2.0 and version 4.1. +-- +-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1 +-- +-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus +-- uses cap height in calculations, glyph metrics must be build +-- with an arbitrary value if it is not present. +-- +-- Encoding Scheme is optional in AFM files. +-- +data AfmFile = AfmFile + { afm_encoding :: Maybe String + , afm_letter_bbox :: Maybe AfmBoundingBox + , afm_cap_height :: Maybe AfmUnit + , afm_glyph_metrics :: [AfmGlyphMetrics] + } + deriving (Show) + +-- Note - for AfmFile BBox is a required field for version 4.1, +-- but it appears to be optional for version 2.0. +-- + + +data AfmGlyphMetrics = AfmGlyphMetrics + { afm_char_code :: !PSCharCode + , afm_width_vector :: !(Vec2 AfmUnit) + , afm_char_name :: !String + } + deriving (Eq,Show) + + +-- | Monospace defaults are used if the font loader fails to +-- extract the necessary fields. +-- +-- The values are taken from the font correpsonding to Courier +-- in the distributed font files. +-- +data MonospaceDefaults cu = MonospaceDefaults + { default_letter_bbox :: BoundingBox cu + , default_cap_height :: cu + , default_char_width :: Vec2 cu + } + deriving (Eq,Show) + + + +-- | The metrics read from a font file by a font loader. +-- +-- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and +-- not on the usual @u@. A typical character unit is 'AfmUnit', +-- the unit of measurement for AFM files (1000th of a point). +-- +-- The is the initial representation used by Wumpus-Basic as an +-- syntax tree when loading font files. +-- +data FontProps cu = FontProps + { fp_bounding_box :: BoundingBox cu + , fp_default_adv_vec :: Vec2 cu + , fp_adv_vecs :: IntMap.IntMap (Vec2 cu) + , fp_cap_height :: cu + } + + +-- | Build a MetricsOps function table, from a character unit +-- scaling function and FontProps read from a file. +-- +buildMetricsOps :: (cu -> PtSize) -> FontProps cu -> MetricsOps +buildMetricsOps fn (FontProps (BBox ll ur) (V2 vx vy) + vec_table cap_height) = + MetricsOps + { get_bounding_box = \sz -> BBox (scalePt sz ll) (scalePt sz ur) + , get_cw_table = \sz i -> + maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table + , get_cap_height = \sz -> upscale sz (fn cap_height) + } + where + upscale sz d = fromPtSize $ sz * d + + defaultAV sz = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) + scalePt sz (P2 cx cy) = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) + scaleVec sz (V2 cx cy) = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) + + + diff --git a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Base.FontLoadMonad +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font load monad handling IO (file system access), failure and +-- logging. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.FontLoadMonad + ( + FontLoadErr + , FontLoadIO + , runFontLoadIO + , evalFontLoadIO + , loadError + , logLoadMsg + , promoteIO + , promoteEither + , runParserFLIO + + , sequenceAll + + -- * Font loading + + , buildAfmFontProps + , checkFontPath + + ) where + +import Wumpus.Basic.System.FontLoader.Base.Datatypes +import Wumpus.Basic.Utils.HList +import Wumpus.Basic.Utils.ParserCombinators + + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + + +import Control.Monad +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Monoid +import System.Directory +import System.FilePath + + + +-------------------------------------------------------------------------------- +-- FontLoadIO monad - IO plus Error + + + +type FontLoadErr = String + +newtype FontLoadLog = FontLoadLog { getFontLoadLog :: H String } + + +instance Monoid FontLoadLog where + mempty = FontLoadLog $ emptyH + a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b + + + +newtype FontLoadIO a = FontLoadIO { + getFontLoadIO :: IO (Either FontLoadErr a, FontLoadLog ) } + +instance Functor FontLoadIO where + fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w) + +instance Monad FontLoadIO where + return a = FontLoadIO $ return (Right a, mempty) + m >>= k = FontLoadIO $ getFontLoadIO m >>= fn + where + fn (Left err, w) = return (Left err, w) + fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> + return (b, w1 `mappend` w2) + +runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a,[String]) +runFontLoadIO ma = liftM post $ getFontLoadIO ma + where + post (ans,w) = (ans, toListH $ getFontLoadLog w) + + +evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a) +evalFontLoadIO ma = liftM post $ getFontLoadIO ma + where + post (ans,_) = ans + + +loadError :: FontLoadErr -> FontLoadIO a +loadError msg = FontLoadIO $ return (Left msg, mempty) + +logLoadMsg :: String -> FontLoadIO () +logLoadMsg msg = FontLoadIO $ return (Right (), message1 msg ) + + +message1 :: String -> FontLoadLog +message1 = FontLoadLog . wrapH + + +-- | aka liftIO +promoteIO :: IO a -> FontLoadIO a +promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty) + +promoteEither :: Either FontLoadErr a -> FontLoadIO a +promoteEither = either loadError return + +runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a +runParserFLIO filepath p = + promoteIO (readFile filepath) >>= promoteEither . runParserEither p + + +-- | The standard monadic @sequence@ would finish on first fail +-- for the FontLoadIO monad. As we want to be able to sequence +-- the loading of a list of fonts, this is not really the +-- behaviour we want for Wumpus. Instead we prefer to use fallback +-- metrics and produce an inaccurate drawing on a font load error +-- rather than fail and produce no drawing. +-- +sequenceAll :: [FontLoadIO a] -> FontLoadIO [a] +sequenceAll = FontLoadIO . step + where + step [] = return (Right [], mempty) + step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) + +cons :: (Either FontLoadErr a, FontLoadLog) + -> (Either FontLoadErr [a], FontLoadLog) + -> (Either FontLoadErr [a], FontLoadLog) +cons (Right a, w1) (Right as, w2) = + (Right $ a:as, w1 `mappend` w2) + +cons (Right a, w1) (Left e2, w2) = + (Right [a], w1 `mappend` w2 `mappend` message1 e2) + +cons (Left e1, w1) (Right as, w2) = + (Right as, w1 `mappend` message1 e1 `mappend` w2) + +cons (Left e1, w1) (Left e2, w2) = + (Right [], w1 `mappend` message1 e1 `mappend` w2 `mappend` message1 e2) + + + +-------------------------------------------------------------------------------- + + +-- | Afm files do not have a default advance vec so use the +-- monospace default. +-- +-- Afm files hopefully have @CapHeight@ and @FontBBox@ properties +-- in the header. Use the monospace default only if they are +-- missing. +-- +buildAfmFontProps :: MonospaceDefaults AfmUnit + -> AfmFile + -> FontLoadIO (FontProps AfmUnit) +buildAfmFontProps defaults afm = do + cap_height <- extractCapHeight defaults afm + bbox <- extractFontBBox defaults afm + return $ FontProps + { fp_bounding_box = bbox + , fp_default_adv_vec = default_char_width defaults + , fp_adv_vecs = char_widths + , fp_cap_height = cap_height + } + where + char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm + + fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of + Nothing -> table + Just i -> IntMap.insert i v table + + +extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit +extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm + where + errk = logLoadMsg "WARNING - Could not extract CapHeight" >> + return (default_cap_height defaults) + + +extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile + -> FontLoadIO (BoundingBox AfmUnit) +extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm + where + errk = logLoadMsg "WARNING - Could not extract CapHeight" >> + return (default_letter_bbox defaults) + + + +checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath +checkFontPath path_root font_file_name = + let full_path = normalise (path_root font_file_name) + in do { check <- promoteIO (doesFileExist full_path) + ; if check then return full_path + else loadError $ "Could not resolve path: " ++ full_path + } diff --git a/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs b/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Base.GSFontMap +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- GhostScript Font map. +-- +-- GhostScript aliases the /Core 14/ PostScript fonts to fonts +-- it can freely distribute. This module provides aliases to +-- Wumpus so the font loader can find the equivalent GhostScript +-- files to the Core 14 set. +-- +-- The data in this file matches GhostScript 8.63. Other versions +-- of GhostScript may need different aliases. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Base.GSFontMap + ( + + GSFontMap(..) + , gsMetricsFile + , gsFontAlias + , gsVersionNumber + , ghostscript_fontmap_8_54 + + ) where + + +import Data.Map ( Map ) +import qualified Data.Map as Map + + +-- | GhostScript version that the aliases were derived from. +-- +-- ghostscript_version :: String +-- ghostscript_version = "gs8.54" + + +-- | A map from standard /Adode PostScript/ font name to the +-- equivalent GhostScript font and AFM file name. +-- +-- It is expected that all GhostScript AFM files will be located +-- in the same directory. +-- +data GSFontMap = GSFontMap + { ghostscript_version :: String + , ghostscript_fontmap :: Map String (String, FilePath) + } + + +-- | Get the @.afm@ metrics file. +-- +-- Note this return only the file name and not the path to it. +-- The full path must be resolved in client code. +-- +gsMetricsFile :: GSFontMap -> String -> Maybe FilePath +gsMetricsFile mp name = fmap snd $ Map.lookup name (ghostscript_fontmap mp) + +-- | Get the GhostScript font name alias. +-- +gsFontAlias :: GSFontMap -> String -> Maybe String +gsFontAlias mp name = fmap fst $ Map.lookup name (ghostscript_fontmap mp) + + +-- | Get the GhostScript version number that the FontMap +-- represents. +-- +gsVersionNumber :: GSFontMap -> String +gsVersionNumber = ghostscript_version + + +-- | Map from PostScript font name to the corresponding +-- GhostScript name and file. +-- +-- Naming is correct for GhostSCript version 8.54. +-- +ghostscript_fontmap_8_54 :: GSFontMap +ghostscript_fontmap_8_54 = GSFontMap "8.54" body + where + body = Map.fromList $ + [ ("Courier", ("NimbusMonL-Regu", "n022003l.afm")) + , ("Courier-Oblique", ("NimbusMonL-ReguObli", "n022023l.afm")) + , ("Courier-Bold", ("NimbusMonL-Bold", "n022004l.afm")) + , ("Courier-BoldOblique", ("NimbusMonL-BoldObli", "n022024l.afm")) + + , ("Helvetica", ("NimbusSanL-Regu", "n019003l.afm")) + , ("Helvetica-Oblique", ("NimbusSanL-ReguItal", "n019023l.afm")) + , ("Helvetica-Bold", ("NimbusSanL-Bold", "n019004l.afm")) + , ("Helvetica-BoldOblique", ("NimbusSanL-BoldItal", "n019024l.afm")) + + , ("Times-Roman", ("NimbusRomNo9L-Regu", "n021003l.afm")) + , ("Times-Italic", ("NimbusRomNo9L-ReguItal", "n021023l.afm")) + , ("Times-Bold", ("NimbusRomNo9L-Medi", "n021004l.afm")) + , ("Times-BoldItalic", ("NimbusRomNo9L-MediItal", "n021024l.afm")) + + , ("Symbol", ("StandardSymL", "s050000l.afm")) + + , ("ZapfDingbats", ("Dingbats", "d050000l.afm")) + ] + diff --git a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs @@ -0,0 +1,86 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.GhostScript +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font loader / import shim for GhostScript glyph metrics. +-- +-- Use this loader if you have GhostScript installed and you want +-- to use the (AFM v2.0) metrics that are distributed with +-- GhostScript. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.GhostScript + ( + + loadGSMetrics + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Base.AfmV2Parser +import Wumpus.Basic.System.FontLoader.Base.Datatypes +import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad +import Wumpus.Basic.System.FontLoader.Base.GSFontMap + +import Wumpus.Core -- package: wumpus-core + +import Control.Monad +import Data.Monoid + + +-- | 'loadGSMetrics' : +-- @ path_to_gs_fonts * [font_name] -> IO (metrics, messages) @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadGSMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String]) +loadGSMetrics font_dir_path ns = + liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns + where + mkFun = gsLoadFontCalcs font_dir_path ghostscript_fontmap_8_54 + + post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable... + post (Right xs,ss) = (foldr insertFont mempty xs, ss) + + +gsLoadFontCalcs :: FilePath -> GSFontMap -> FontName + -> FontLoadIO FontMetricsOps +gsLoadFontCalcs font_dir_path fm name = do + logLoadMsg $ "Loading " ++ name + font_file <- resolveFontFile fm name + path <- checkFontPath font_dir_path font_file + ans <- runParserFLIO path afmV2Parser + props <- buildAfmFontProps ghostscript_mono_defaults_8_54 ans + return $ FontMetricsOps name (buildMetricsOps afmUnitScale props) + + +resolveFontFile :: GSFontMap -> FontName -> FontLoadIO FilePath +resolveFontFile fm name = maybe errk return $ gsMetricsFile fm name + where + errk = loadError $ "Could note resolve GhostScript alias for " ++ name + + +-- | These are values extracted from the file @n022003l.afm@ +-- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent +-- font for the core 14 font Courier. +-- +ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit +ghostscript_mono_defaults_8_54 = + MonospaceDefaults { default_letter_bbox = bbox + , default_cap_height = 563 + , default_char_width = V2 600 0 + } + where + bbox = BBox (P2 (-46) (-273)) (P2 650 820) diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Text/LRText.hs +++ /dev/null @@ -1,239 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Text.LRText --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Left-to-right measured text. The text uses glyph metrics so it --- can be positioned accurately. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Text.LRText - ( - - - singleLineBL - , singleLineCC - - , multiAlignLeft - , multiAlignCenter - , multiAlignRight - - - ) where - - -import Wumpus.Basic.Graphic - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.GlyphIndices - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - -import Data.Char -import Data.Foldable ( foldrM ) -import qualified Data.Map as Map -import Data.Maybe - - --- One line of multiline text --- -data InterimText1 u = InterimText1 - { text1_escaped :: EscapedText - , text1_advance :: (AdvanceVec u) - } - deriving (Eq,Show) - - -singleLineBL :: (Ord u, FromPtSize u) - => String -> BoundedLocGraphic u -singleLineBL ss = interimText1 ss >>= singleLRText id - -singleLineCC :: (Fractional u, Ord u, FromPtSize u) - => String -> BoundedLocGraphic u -singleLineCC ss = glyphCapHeight >>= \cap_h -> - interimText1 ss >>= \interim -> - let hw = 0.5 * advanceH (text1_advance interim) - in singleLRText (.-^ vec hw (0.5 * cap_h)) interim - --- | Draw multi-line text, aligned to the left. --- --- The input string is split on newline with the Prelude function --- @lines@. The supplied point is the center of the text. --- -multiAlignLeft :: (Fractional u, Ord u, FromPtSize u) - => String -> BoundedLocGraphic u -multiAlignLeft = - multiAligned drawLeftAligned1 (\wv pt -> pt .-^ hvec (0.5 * advanceH wv)) - - --- | Draw multi-line text, aligned on the horizontal center. --- --- The input string is split on newline with the Prelude function --- @lines@. The supplied point is the center of the text. --- -multiAlignCenter :: (Fractional u, Ord u, FromPtSize u) - => String -> BoundedLocGraphic u -multiAlignCenter = - multiAligned drawCenterAligned1 (\_ pt -> pt) - --- | Draw multi-line text, aligned to the right. --- --- The input string is split on newline with the Prelude function --- @lines@. The supplied point is the center of the text. --- -multiAlignRight :: (Fractional u, Ord u, FromPtSize u) - => String -> BoundedLocGraphic u -multiAlignRight = - multiAligned drawRightAligned1 (\wv pt -> pt .+^ hvec (0.5 * advanceH wv)) - - --- Build multi-line aligned text. --- --- The drawF functions regard the supplied point differently, for --- instance @drawRightAligned1@ regards the point as --- baseline-right. --- --- The dispF are applied to a point which is initially in the --- center of the drawing - for right aligned text it is displaced --- to the right (half the max width vectoer), for left aligned --- text it is displaced to the left. Center aligned text is not --- displaced. --- -multiAligned :: (Fractional u, Ord u, FromPtSize u) - => (InterimText1 u -> Point2 u -> BoundedGraphic u) - -> (AdvanceVec u -> Point2 u -> Point2 u) - -> String -> BoundedLocGraphic u -multiAligned drawF dispF ss = - linesToInterims ss >>= \(wv,xs) -> - glyphCapHeight >>= \cap_h -> - baselineSpacing >>= \base_span -> - promote1 $ \p0 -> let p1 = dispF wv p0 - axs = annotateStartPoints cap_h base_span p1 xs - in mergeLines drawF p1 axs - --- This needs sorting out so as not to throw an error --- -mergeLines :: (Num u, Ord u) - => (InterimText1 u -> Point2 u -> BoundedGraphic u) - -> Point2 u - -> [(InterimText1 u, Point2 u)] -> BoundedGraphic u -mergeLines fn fallback_pt = step - where - step [(x,pt)] = fn x pt - step ((x,pt):ys) = fn x pt `oplus` step ys - step _ = fn empty_fallback fallback_pt - - empty_fallback = InterimText1 (escapeString "") (hvec 0) - - - - -singleLRText :: (Ord u, FromPtSize u) - => (Point2 u -> Point2 u) -> InterimText1 u - -> BoundedLocGraphic u -singleLRText dispF (InterimText1 esc av) = - glyphHeightRange >>= \(ymin, ymax) -> - promote1 $ \p0 -> let pt = dispF p0 - w = advanceH av - ll = pt .+^ vvec ymin - ur = pt .+^ vec w ymax - bb = boundingBox ll ur - in (escapedline esc `at` pt) >>= \prim -> - return (bb, prim) - - - --- Point is baseline-left --- -drawLeftAligned1 :: (Ord u, FromPtSize u) - => InterimText1 u -> Point2 u -> BoundedGraphic u -drawLeftAligned1 itext pt = singleLRText id itext `at` pt - --- Point is baseline-center --- -drawCenterAligned1 :: (Fractional u, Ord u, FromPtSize u) - => InterimText1 u -> Point2 u -> BoundedGraphic u -drawCenterAligned1 itext pt = - let hw = 0.5 * advanceH (text1_advance itext) - in singleLRText (.-^ hvec hw) itext `at` pt - --- Point is baseline-right --- -drawRightAligned1 :: (Fractional u, Ord u, FromPtSize u) - => InterimText1 u -> Point2 u -> BoundedGraphic u -drawRightAligned1 itext pt = - let w = advanceH (text1_advance itext) - in singleLRText (.-^ hvec w) itext `at` pt - - - - --- This isn't worth the complexity to get to one traversal... - -linesToInterims :: (FromPtSize u, Ord u) - => String -> DrawingInfo (AdvanceVec u, [InterimText1 u]) -linesToInterims = fmap post . mapM interimText1 . lines - where - post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs) - fn a vmax = avMaxWidth (text1_advance a) vmax - -avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u -avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a - -interimText1 :: FromPtSize u => String -> DrawingInfo (InterimText1 u) -interimText1 ss = let esc = escapeString ss in - postpro (mk esc) $ textVector esc - where - mk a b = InterimText1 { text1_escaped = a - , text1_advance = b } - - -textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u) -textVector esc = let cs = getEscapedText esc in - foldrM (\c v -> charVector c >>= \cv -> return (v ^+^ cv)) (vec 0 0) cs - - -charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u) -charVector (CharLiteral c) = unCF1 (ord c) avLookupTable -charVector (CharEscInt i) = unCF1 i avLookupTable -charVector (CharEscName s) = unCF1 ix avLookupTable - where - ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices - - - --- baseline_span is the vertical distance from one baseline to --- the next it is not /gap_height/. --- - -annotateStartPoints :: Fractional u - => u -> u -> Point2 u -> [InterimText1 u] - -> [(InterimText1 u, Point2 u)] -annotateStartPoints _ _ _ [] = [] -annotateStartPoints cap_height baseline_span (P2 x y) (z:rest) = - let y0 = if odd list_len then odd_start_y else even_start_y - p0 = P2 x y0 - in (z,p0) : step (moveDown1 p0) rest - where - list_len = 1 + length rest - halfn = fromIntegral $ list_len `div` 2 - center_to_bl = 0.5 * cap_height - half_gap_height = 0.5 * (baseline_span - cap_height) - odd_start_y = y - center_to_bl + halfn * baseline_span - even_start_y = y - half_gap_height - cap_height + halfn * baseline_span - - moveDown1 = \pt -> pt .-^ vvec baseline_span - - step _ [] = [] - step pt (a:as) = (a,pt) : step (moveDown1 pt) as - diff --git a/src/Wumpus/Basic/Utils/Intersection.hs b/src/Wumpus/Basic/Utils/Intersection.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Utils/Intersection.hs +++ /dev/null @@ -1,171 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Utils.Intersection --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Intersection of line to line and line to plane --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Utils.Intersection - ( - LineSegment(..) - , PointSlope - , pointSlope - , LineEqn - , lineEqn - , toLineEqn - , findIntersect - , intersection - - , rectangleLines - , polygonLines - , langle - ) - where - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - - --- WARNING - This module is not very good (neither particularly --- robust, nor efficient). --- --- I really need to find an algorithm that does this properly. --- - -data LineSegment u = LS (Point2 u) (Point2 u) - deriving (Eq,Ord,Show) - - -data PointSlope u = PointSlope - { _point_slope_point :: Point2 u - , _point_slope_slope :: u - } - deriving (Eq,Show) - -pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u -pointSlope pt theta = PointSlope pt (fromRadian $ tan theta) - - --- | Line in equational form, i.e. @Ax + By + C = 0@. -data LineEqn u = LineEqn - { _line_eqn_A :: !u - , _line_eqn_B :: !u - , _line_eqn_C :: !u - } - deriving (Eq,Show) - -lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u -lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c - where - a = y1 - y2 - b = x2 - x1 - c = (x1*y2) - (x2*y1) - - -toLineEqn :: Num u => PointSlope u -> LineEqn u -toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0) - - - - -data IntersectionResult u = Intersects u u | Contained | NoIntersect - deriving (Eq,Show) - - --- Note the uses a /plane/ so is susceptible to picking the --- wrong quadrant... --- -findIntersect :: (Floating u, Real u, Ord u) - => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u) -findIntersect ctr ang0 = step - where - theta = circularModulo ang0 - eqn = toLineEqn $ pointSlope ctr theta - step [] = Nothing - step (x:xs) = case intersection x eqn of - Just pt | quadrantCheck theta ctr pt -> Just pt - _ -> step xs - - -quadrantCheck :: (Real u, Floating u) - => Radian -> Point2 u -> Point2 u -> Bool -quadrantCheck theta ctr pt = theta == langle ctr pt - -intersection :: (Fractional u, Ord u) - => LineSegment u -> LineEqn u -> Maybe (Point2 u) -intersection ls@(LS p q) eqn = case intersect1 ls eqn of - Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t - Contained -> Just p - NoIntersect -> Nothing - - - -intersect1 :: (Num u, Ord u) - => LineSegment u -> LineEqn u -> IntersectionResult u -intersect1 (LS p q) eqn = - if inters fp fq then Intersects fp fq - else if contained fp fq then Contained else NoIntersect - where - inters a b = (a < 0 && b >= 0) || (a > 0 && b <= 0) - contained a b = a == 0 && b == 0 - fp = lineF p eqn - fq = lineF q eqn - -lineF :: Num u => Point2 u -> LineEqn u -> u -lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c - -affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u -affineComb p q t = p .+^ t *^ (q .-. p) - - - - -rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u] -rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br] - where - br = ctr .+^ (vec hw (-hh)) - tr = ctr .+^ (vec hw hh) - tl = ctr .+^ (vec (-hw) hh) - bl = ctr .+^ (vec (-hw) (-hh)) - - -polygonLines :: [Point2 u] -> [LineSegment u] -polygonLines [] = error "polygonLines - emptyList" -polygonLines (x:xs) = step x xs - where - step a [] = [LS a x] - step a (b:bs) = LS a b : step b bs - - - --- | Calculate the counter-clockwise angle between two points --- and the x-axis. --- -langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian -langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) - where - -- north-east quadrant - step x y | pve x && pve y = toRadian $ atan (y/x) - - -- north-west quadrant - step x y | pve y = pi - (toRadian $ atan (y / abs x)) - - -- south-east quadrant - step x y | pve x = (2*pi) - (toRadian $ atan (abs y / x)) - - -- otherwise... south-west quadrant - step x y = pi + (toRadian $ atan (y/x)) - - pve a = signum a >= 0 diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs --- a/src/Wumpus/Basic/VersionNumber.hs +++ b/src/Wumpus/Basic/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,13,0) +-- > (0,14,0) -- wumpus_basic_version :: (Int,Int,Int) -wumpus_basic_version = (0,13,0) +wumpus_basic_version = (0,14,0) diff --git a/src/Wumpus/Drawing/Arrows.hs b/src/Wumpus/Drawing/Arrows.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim module for arrow connectors and arrowheads. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows + ( + + module Wumpus.Drawing.Arrows.Tips + , module Wumpus.Drawing.Arrows.Connectors + + ) where + +import Wumpus.Drawing.Arrows.Tips +import Wumpus.Drawing.Arrows.Connectors + + diff --git a/src/Wumpus/Drawing/Arrows/Connectors.hs b/src/Wumpus/Drawing/Arrows/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows/Connectors.hs @@ -0,0 +1,149 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows.Connectors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Draw arrows. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows.Connectors + ( + + Connector + , connector + , leftArrow + , rightArrow + , dblArrow + , leftrightArrow + , strokeConnector + + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows.Tips +import Wumpus.Drawing.Paths + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +-- An arrowhead always know how to draw itself (filled triangle, +-- stroked barb, etc.) +-- +-- A Path might will typically be drawn with openStroke, +-- eventually there might be scope for drawing +-- e.g. parallel lines ==== +-- + +-- A ConnectorPath gets wrapped with how it is drawn into +-- another type. + + +data Connector u = Connector + { connector_path :: ConnectorPath u + , opt_left_arrow :: Maybe (Arrowhead u) + , opt_right_arrow :: Maybe (Arrowhead u) + } + + +-- | connector with no arrow heads. +-- +connector :: ConnectorPath u -> Connector u +connector cp = + Connector { connector_path = cp + , opt_left_arrow = Nothing + , opt_right_arrow = Nothing + } + +leftArrow :: ConnectorPath u -> Arrowhead u -> Connector u +leftArrow cp la = + Connector { connector_path = cp + , opt_left_arrow = Just la + , opt_right_arrow = Nothing + } + + +rightArrow :: ConnectorPath u -> Arrowhead u -> Connector u +rightArrow cp ra = + Connector { connector_path = cp + , opt_left_arrow = Nothing + , opt_right_arrow = Just ra + } + +-- | Same tip both ends. +-- +dblArrow :: ConnectorPath u -> Arrowhead u -> Connector u +dblArrow cp arw = leftrightArrow cp arw arw + +leftrightArrow :: ConnectorPath u -> Arrowhead u -> Arrowhead u -> Connector u +leftrightArrow cp la ra = + Connector { connector_path = cp + , opt_left_arrow = Just la + , opt_right_arrow = Just ra + } + + + +strokeConnector :: (Real u, Floating u) + => Connector u -> ConnectorImage u (Path u) +strokeConnector (Connector cpF opt_la opt_ra) = + promoteR2 $ \p0 p1 -> let pathc = cpF p0 p1 in + tipEval opt_la p0 (directionL pathc) >>= \(dl,gfL) -> + tipEval opt_ra p1 (directionR pathc) >>= \(dr,gfR) -> + intoImage (pure pathc) + (fmap (bimapR (gfR . gfL)) $ drawP $ shortenPath dl dr pathc) + where + drawP = openStroke . toPrimPath + + +-- for Paths.Base ? +-- +shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u +shortenPath l r = shortenL l . shortenR r + +type ArrowMark u = PrimGraphic u -> PrimGraphic u + + +-- 'tipEval' is a bit of an oddity. It has to evaluate the +-- Arrowhead / Image in the DrawingCtx to get the retract +-- distance. But doing so evaluates the tips to PrimGraphics, thus +-- it has to wrap the tips back up as Graphics with @pure@ so they +-- can be concatenated to the drawn path as GraphicTrafos. +-- +-- The Arrowhead type could be changed, so rather than returning +-- an Image (retract_distance, PrimGraphic) it returns +-- (retract_distance, GraphicTrafo) but that would burden all +-- arrowheads with some extra complexity. +-- +-- In short - the code here works but it isn\'t exemplary, and it +-- doesn\'t show whether or not GraphicTrafo is a valuable type or +-- if it is implemented correctly (as GraphicTrafo could having +-- different implementations according to how it regards the +-- DrawingCtx). +-- + +tipEval :: Num u + => Maybe (Arrowhead u) -> Point2 u -> Radian + -> CF (u, ArrowMark u) +tipEval Nothing _ _ = return (0,unmarked) +tipEval (Just arw) pt theta = makeMark $ apply2R2 (getArrowhead arw) pt theta + + +unmarked :: ArrowMark u +unmarked = id + + +makeMark :: Image u a -> CF (a, ArrowMark u) +makeMark = fmap (\(a,prim) -> (a, (`oplus` prim))) + + + diff --git a/src/Wumpus/Drawing/Arrows/Tips.hs b/src/Wumpus/Drawing/Arrows/Tips.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows/Tips.hs @@ -0,0 +1,505 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows.Tips +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Anchor points on shapes. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows.Tips + ( + + + Arrowhead(..) + + + , tri90 + , tri60 + , tri45 + , otri90 + , otri60 + , otri45 + + , revtri90 + , revtri60 + , revtri45 + , orevtri90 + , orevtri60 + , orevtri45 + + , barb90 + , barb60 + , barb45 + , revbarb90 + , revbarb60 + , revbarb45 + + , perp + + , bracket + + , diskTip + , odiskTip + , squareTip + , osquareTip + , diamondTip + , odiamondTip + + , curveTip + , revcurveTip + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Paths + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + + +-- | Encode an arrowhead as an image where the /answer/ is the +-- retract distance. +-- +-- The retract distance is context sensitive - usually just on +-- the markHeight (or halfMarkHeight) so it has to be calculated +-- w.r.t. the DrawingCtx. +-- +newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u } + + + + +-- | Tiplen is length of the tip \*along the line it follows\*. +-- +-- > |\ +-- > | \ +-- > | / +-- > |/ +-- > +-- > | | -- tip len +-- + +-- | Tip width is the distance between upper and lower +-- arrow points. +-- +-- > __ +-- > |\ +-- > | \ tip +-- > | / width +-- > |/ __ +-- > + + + +-- | This one is for triangular tips defined by their tip angle +-- e.g. 90deg, 60deg, 45deg. +-- +-- The tip width will be variable (tip length should be the +-- markHeight). +-- +triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u) +triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower) + where + hypo_len = tiplen / (fromRadian $ cos halfang) + rtheta = pi + theta -- theta in the opposite direction + vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len + vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len + + + +-- | This one is for triangles when the tip height and tip width +-- are known. +-- +triVecsByDist :: (Real u, Floating u) + => u -> u -> Radian -> (Vec2 u, Vec2 u) +triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower) + where + hypo_len = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth) + halfang = toRadian $ atan (half_tipwidth / tiplen) + rtheta = pi + theta -- theta in the opposite direction + vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len + vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len + + + + +{- +markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u +markHeightPlusLineWidth = + (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth +-} + + +markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u +markHeightLessLineWidth = + (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth + + +-- noRetract ignores both the angle and the point. +-- +-- Its common for the rectraction not to care about the angle or +-- the point and only care about the DrawingCtx. +-- +noRetract :: Num u => LocThetaCF u u +noRetract = promoteR2 $ \_ _ -> pure 0 + + + +-------------------------------------------------------------------------------- + +tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a +tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h + +-- | Tripoints takes the \*tip length\* is the mark height. +-- +-- This means that the 90deg tip has a tip width greater-than the +-- mark height (but that is okay - seemingly this is how TikZ +-- does it). +-- +tripointsByAngle :: (Floating u, FromPtSize u) + => Radian -> LocThetaCF u (Point2 u, Point2 u) +tripointsByAngle triang = + tipBody $ \pt theta h -> + let (vup,vlo) = triVecsByAngle h (0.5*triang) theta + in pure (pt .+^ vup, pt .+^ vlo) + + +revtripointsByAngle :: (Floating u, FromPtSize u) + => Radian + -> LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByAngle triang = + tipBody $ \pt theta h -> + let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByAngle h (0.5*triang) theta' + back_tip = pt .-^ avec theta h + in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + + + +tripointsByDist :: (Real u, Floating u, FromPtSize u) + => LocThetaCF u (Point2 u, Point2 u) +tripointsByDist = + tipBody $ \pt theta h -> + let (vup,vlo) = triVecsByDist h (0.5*h) theta + in pure (pt .+^ vup, pt .+^ vlo) + + + +revtripointsByDist :: (Real u, Floating u, FromPtSize u) + => LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByDist = + tipBody $ \pt theta h -> + let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByDist h (0.5*h) theta' + back_tip = pt .-^ avec theta h + in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + + + + + +-- width = xchar_height +-- filled with stroke colour! + +triTLG :: (Floating u, Real u, FromPtSize u) + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +triTLG triang drawF = + promoteR2 $ \pt theta -> + localize bothStrokeColour $ + apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> + drawF $ vertexPath [pt,u,v] + + + +tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri90 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/2) filledPath) + + +tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri60 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/3) filledPath) + + +tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri45 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/4) filledPath) + +otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri90 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/2) closedStroke) + +otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri60 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/3) closedStroke) + +otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri45 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (triTLG (pi/4) closedStroke) + + +-- width = xchar_height +-- filled with stroke colour! + +revtriTLG :: (Floating u, Real u, FromPtSize u) + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +revtriTLG triang drawF = + promoteR2 $ \pt theta -> + localize bothStrokeColour $ + apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> + drawF $ vertexPath [u,pt',v] + + + +revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri90 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/2) filledPath) + +revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri60 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/3) filledPath) + +revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri45 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/4) filledPath) + + +orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri90 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/2) closedStroke) + +orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri60 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/3) closedStroke) + +orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri45 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeightLessLineWidth) + (revtriTLG (pi/4) closedStroke) + + + +barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +barbTLG ang = + promoteR2 $ \pt theta -> + apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> + openStroke $ vertexPath [u,pt,v] + + + +barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2)) + +barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3)) + + +barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4)) + + + +revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +revbarbTLG ang = + promoteR2 $ \pt theta -> + apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> + openStroke $ vertexPath [u,pt',v] + +revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb90 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/2)) + + +revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb60 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/3)) + +revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb45 = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (revbarbTLG (pi/4)) + + +perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +perpTLG = + tipBody $ \pt theta h -> + let hh = 0.5*h in openStroke $ rperpPath hh pt theta + + +rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +rperpPath hh ctr theta = primPath p0 [lineTo p1] + where + p0 = displacePerpendicular hh theta ctr + p1 = displacePerpendicular (-hh) theta ctr + + + +perp :: (Floating u, FromPtSize u) => Arrowhead u +perp = Arrowhead $ intoLocThetaImage noRetract perpTLG + + + +bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +bracketTLG = + tipBody $ \pt theta h -> + let hh = 0.5*h in openStroke $ rbracketPath hh pt theta + + +rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +rbracketPath hh pt theta = vertexPath [p0,p1,p2,p3] + where + p1 = displacePerpendicular hh theta pt + p0 = displaceParallel (-hh) theta p1 + p2 = displacePerpendicular (-hh) theta pt + p3 = displaceParallel (-hh) theta p2 + + + + +bracket :: (Floating u, FromPtSize u) => Arrowhead u +bracket = Arrowhead $ intoLocThetaImage noRetract bracketTLG + + +diskTLG :: (Floating u, FromPtSize u) + => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u +diskTLG drawF = + tipBody $ \pt theta h -> let hh = 0.5*h + ctr = pt .-^ avec theta hh + in drawF hh ctr + + +diskTip :: (Floating u, FromPtSize u) => Arrowhead u +diskTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (diskTLG drawF) + where + drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt + + +odiskTip :: (Floating u, FromPtSize u) => Arrowhead u +odiskTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (diskTLG drawF) + where + drawF r pt = strokedDisk r `at` pt + + +squareTLG :: (Floating u, FromPtSize u) + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +squareTLG drawF = + tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h) + + +rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u +rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3] + where + p0 = displacePerpendicular hh theta pt + p3 = displacePerpendicular (-hh) theta pt + p1 = displaceParallel (-2*hh) theta p0 + p2 = displaceParallel (-2*hh) theta p3 + + +squareTip :: (Floating u, FromPtSize u) => Arrowhead u +squareTip = Arrowhead $ intoLocThetaImage (lift0R2 markHeight) (squareTLG drawF) + where + drawF = localize bothStrokeColour . filledPath + + +osquareTip :: (Floating u, FromPtSize u) => Arrowhead u +osquareTip = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) (squareTLG closedStroke) + + +diamondTLG :: (Floating u, FromPtSize u) + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +diamondTLG drawF = + tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h) + + +rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u +rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3] + where + ctr = displaceParallel (-2*hh) theta pt + p1 = displacePerpendicular hh theta ctr + p3 = displacePerpendicular (-hh) theta ctr + p2 = displaceParallel (-4*hh) theta pt + + + +diamondTip :: (Floating u, FromPtSize u) => Arrowhead u +diamondTip = Arrowhead $ + intoLocThetaImage (lift0R2 $ fmap (2*) markHeightLessLineWidth) + (diamondTLG drawF) + where + drawF = localize bothStrokeColour . filledPath + + +odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u +odiamondTip = Arrowhead $ + intoLocThetaImage (lift0R2 $ fmap (2*) markHeight) (diamondTLG closedStroke) + + + + +-- Note - points flipped to get the second trapezium to +-- draw /underneath/. +-- +curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +curveTLG = + tipBody $ \pt theta h -> + cxCurvePath pt theta (0.5*h) >>= \path -> + localize (joinRound . capRound) (openStroke path) + + +cxCurvePath :: (Real u, Floating u, FromPtSize u) + => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) +cxCurvePath pt theta hh = + apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt + in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo + + + + +curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u +curveTip = Arrowhead $ + intoLocThetaImage (lift0R2 $ fmap realToFrac getLineWidth) curveTLG + + +-- Note - points flipped to get the second trapezium to +-- draw /underneath/. +-- +revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +revcurveTLG = + tipBody $ \pt theta h -> + cxRevcurvePath pt theta (0.5*h) >>= \path -> + localize (joinRound . capRound) (openStroke path) + +cxRevcurvePath :: (Real u, Floating u, FromPtSize u) + => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) +cxRevcurvePath pt theta hh = + apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 + in pure$ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo + + +revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u +revcurveTip = Arrowhead $ + intoLocThetaImage (lift0R2 markHeight) revcurveTLG + diff --git a/src/Wumpus/Drawing/Chains.hs b/src/Wumpus/Drawing/Chains.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Shim module. +-- +-- WARNING - very unstable. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains + ( + module Wumpus.Drawing.Chains.Base + , module Wumpus.Drawing.Chains.Derived + + + ) where + + +import Wumpus.Drawing.Chains.Base +import Wumpus.Drawing.Chains.Derived diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains/Base.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains.Base +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Generate points in an iterated chain. +-- +-- WARNING - very unstable. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains.Base + ( + + + Chain + , LocChain + , chain + , chainFrom + , unchain + + + , AnaAlg(..) + , IterAlg(..) + + , BivariateAlg + , bivariate + + , SequenceAlg + , iteration + + , bounded + , pairOnXs + , pairOnYs + + ) where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + + +-- Chain uses the Scaling monad, but it is not itself a monad. + + +newtype Chain ux uy u = Chain { getChain :: Scaling ux uy u [Point2 u] } + + +type LocChain ux uy u = Point2 u -> Chain ux uy u + + + +chain :: BivariateAlg ux uy -> Chain ux uy u +chain alg = Chain (scaledBivariatePt alg) + +chainFrom :: Num u => BivariateAlg ux uy -> LocChain ux uy u +chainFrom alg start = Chain (scaledBivariateVec alg start) + + +unchain :: ScalingContext ux uy u -> Chain ux uy u -> [Point2 u] +unchain ctx ch = runScaling ctx $ getChain ch + + +-- | Chains are built as unfolds - AnaAlg avoids the pair +-- constructor in the usual definition of unfoldr and makes the +-- state strict. +-- +-- It is expected that all Chains built on unfolds will terminate. +-- +data AnaAlg st a = Done | Step a !st + + +-- | IterAlg is a variant of AnaAlg that builds infinite +-- sequences (iterations). +-- +-- When lifted to a Chain an iteration is bounded by a count so +-- it will terminate. +-- +data IterAlg st a = IterStep a !st + + +data BivariateAlg ux uy = forall st. BivariateAlg + { st_zero :: st + , gen_step :: st -> AnaAlg st (ux,uy) + } + +bivariate :: st -> (st -> AnaAlg st (ux,uy)) -> BivariateAlg ux uy +bivariate st0 step_alg = BivariateAlg { st_zero = st0 + , gen_step = step_alg } + + +scaledBivariatePt :: BivariateAlg ux uy -> Scaling ux uy u [Point2 u] +scaledBivariatePt (BivariateAlg { st_zero = st0, gen_step = step}) = + go (step st0) + where + go Done = return [] + go (Step (x,y) next) = scalePt x y >>= \pt -> + go (step next) >>= \rest -> + return (pt:rest) + +-- Note - cannot encode this with (.+^) from Data.AffineSpace. +-- The u (u ~ MonUnit m) extracted from the Scaling Context is +-- not compatible with the u that forms Points (u ~ Diff (Point2 u)). + +scaledBivariateVec :: Num u + => BivariateAlg ux uy + -> Point2 u + -> Scaling ux uy u [Point2 u] +scaledBivariateVec (BivariateAlg { st_zero = st0, gen_step = step}) (P2 x0 y0) = + go (step st0) + where + go Done = return [] + go (Step (x,y) next) = scaleVec x y >>= \(V2 dx dy) -> + go (step next) >>= \rest -> + return (P2 (x0+dx) (y0+dy):rest) + + +data SequenceAlg a = forall st. SequenceAlg + { initial_st :: st + , iter_step :: st -> IterAlg st a + } + +iteration :: (a -> a) -> a -> SequenceAlg a +iteration fn s0 = SequenceAlg { initial_st = s0, iter_step = step } + where + step s = IterStep s (fn s) + + +bounded :: Int -> SequenceAlg (ux,uy) -> BivariateAlg ux uy +bounded n (SequenceAlg a0 fn) = + BivariateAlg { st_zero = (0,a0) + , gen_step = gstep } + where + gstep (i,s) | i < n = let (IterStep ans next) = fn s in Step ans (i+1,next) + gstep _ = Done + + + + +pairOnXs :: (ux -> uy) -> SequenceAlg ux -> SequenceAlg (ux,uy) +pairOnXs fn (SequenceAlg { initial_st = s0, iter_step = step }) = + SequenceAlg s0 step2 + where + step2 s = let (IterStep a s') = step s in IterStep (a, fn a) s' + + +pairOnYs :: (r -> l) -> SequenceAlg r -> SequenceAlg (l,r) +pairOnYs fn (SequenceAlg { initial_st = s0, iter_step = step }) = + SequenceAlg s0 step2 + where + step2 s = let (IterStep a s') = step s in IterStep (fn a, a) s' + diff --git a/src/Wumpus/Drawing/Chains/Derived.hs b/src/Wumpus/Drawing/Chains/Derived.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains/Derived.hs @@ -0,0 +1,129 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains.Derived +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Generate points in an iterated chain. +-- +-- WARNING - very unstable. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains.Derived + ( + + univariateX + , univariateY + + , tableDown + , tableRight + + , horizontal + , vertical + + , horizontals + , verticals + + , rescale + + ) where + +import Wumpus.Drawing.Chains.Base + + + + +univariateX :: (Fractional uy, Num ux, Num u) + => [ux] -> LocChain ux uy u +univariateX zs = chainFrom $ bivariate (0,zs) gstep + where + gstep (_,[]) = Done + gstep (n,x:xs) = Step (x,n) (n+i,xs) + len = length zs + i = rescale 0 1 0 (fromIntegral $ len-1) 1 + + +univariateY :: (Fractional ux, Num uy, Num u) + => [uy] -> LocChain ux uy u +univariateY zs = chainFrom $ bivariate (0,zs) gstep + where + gstep (_,[]) = Done + gstep (n,y:ys) = Step (n,y) (n+i,ys) + len = length zs + i = rescale 0 1 0 (fromIntegral $ len-1) 1 + + + +-------------------------------------------------------------------------------- +-- Tables + + +tableDown :: Int -> Int -> Chain Int Int u +tableDown rows cols = + chain $ bounded (rows*cols) (iteration (downstep rows) (0,rows-1)) + + + +downstep :: Int -> (Int,Int) -> (Int,Int) +downstep row_count (x,y) | y == 0 = (x+1,row_count-1) +downstep _ (x,y) = (x,y-1) + + + +tableRight :: Num u => Int -> Int -> Chain Int Int u +tableRight rows cols = + chain $ bounded (rows*cols) (iteration (rightstep cols) (0,rows-1)) + + +rightstep :: Int -> (Int,Int) -> (Int,Int) +rightstep col_count (x,y) | x == (col_count-1) = (0,y-1) +rightstep _ (x,y) = (x+1,y) + + +horizontal :: Int -> Chain Int Int u +horizontal count = chain $ bivariate 0 alg + where + alg st | st == count = Done + alg st = Step (st,0) (st+1) + + +vertical :: Int -> Chain Int Int u +vertical count = chain $ bivariate 0 alg + where + alg st | st == count = Done + alg st = Step (0,st) (st+1) + + + +horizontals :: (Num ua, Num u) => [ua] -> LocChain ua ua u +horizontals xs0 = chainFrom $ bivariate xs0 alg + where + alg [] = Done + alg (x:xs) = Step (x,0) xs + + +verticals :: (Num ua, Num u) => [ua] -> LocChain ua ua u +verticals ys0 = chainFrom $ bivariate ys0 alg + where + alg [] = Done + alg (y:ys) = Step (0,y) ys + + +-------------------------------------------------------------------------------- +-- general helpers + +rescale :: Fractional a => a -> a -> a -> a -> a -> a +rescale outmin outmax innmin innmax a = + outmin + innpos * (outrange / innrange) + where + outrange = outmax - outmin + innrange = innmax - innmin + innpos = a - innmin + diff --git a/src/Wumpus/Drawing/Colour/SVGColours.hs b/src/Wumpus/Drawing/Colour/SVGColours.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Colour/SVGColours.hs @@ -0,0 +1,625 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Colour.SVGColours +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : unstable +-- Portability : GHC +-- +-- The SVG \'named colours\', as rgb [0,1] values +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Colour.SVGColours + ( + + -- * Named colours + alice_blue + , antique_white + , aqua + , aquamarine + , azure + , beige + , bisque + , black + , blanched_almond + , blue + , blue_violet + , brown + , burlywood + , cadet_blue + , chartreuse + , chocolate + , coral + , cornflower_blue + , cornsilk + , crimson + , cyan + , dark_blue + , dark_cyan + , dark_goldenrod + , dark_gray + , dark_green + , dark_grey + , dark_khaki + , dark_magenta + , dark_olive_green + , dark_orange + , dark_orchid + , dark_red + , dark_salmon + , dark_sea_green + , dark_slate_blue + , dark_slate_gray + , dark_slate_grey + , dark_turquoise + , dark_violet + , deep_pink + , deep_sky_blue + , dim_gray + , dim_grey + , dodger_blue + , firebrick + , floral_white + , forest_green + , fuchsia + , gainsboro + , ghost_white + , gold + , goldenrod + , gray + , grey + , green + , green_yellow + , honeydew + , hot_pink + , indian_red + , indigo + , ivory + , khaki + , lavender + , lavender_blush + , lawn_green + , lemon_chiffon + , light_blue + , light_coral + , light_cyan + , light_goldenrod_yellow + , light_gray + , light_green + , light_grey + , light_pink + , light_salmon + , light_sea_green + , light_sky_blue + , light_slate_gray + , light_slate_grey + , light_steel_blue + , light_yellow + , lime + , lime_green + , linen + , magenta + , maroon + , medium_aquamarine + , medium_blue + , medium_orchid + , medium_purple + , medium_sea_green + , medium_slate_blue + , medium_spring_green + , medium_turquoise + , medium_violet_red + , midnight_blue + , mintcream + , mistyrose + , moccasin + , navajo_white + , navy + , old_lace + , olive + , olive_drab + , orange + , orange_red + , orchid + , pale_goldenrod + , pale_green + , pale_turquoise + , pale_violet_red + , papaya_whip + , peach_puff + , peru + , pink + , plum + , powder_blue + , purple + , red + , rosy_brown + , royal_blue + , saddle_brown + , salmon + , sandy_brown + , sea_green + , seashell + , sienna + , silver + , sky_blue + , slate_blue + , slate_gray + , slate_grey + , snow + , spring_green + , steel_blue + , tan + , teal + , thistle + , tomato + , turquoise + , violet + , wheat + , white + , whitesmoke + , yellow + , yellow_green + + ) where + + +import Wumpus.Core.Colour ( RGBi(..) ) + + +import Prelude ( ) + + + +-------------------------------------------------------------------------------- + +alice_blue :: RGBi +alice_blue = RGBi 0xf0 0xf8 0xff + +antique_white :: RGBi +antique_white = RGBi 0xfa 0xeb 0xd7 + +aqua :: RGBi +aqua = RGBi 0x00 0xff 0xff + +aquamarine :: RGBi +aquamarine = RGBi 0x7f 0xff 0xd4 + +azure :: RGBi +azure = RGBi 0xf0 0xff 0xff + +beige :: RGBi +beige = RGBi 0xf5 0xf5 0xdc + +bisque :: RGBi +bisque = RGBi 0xff 0xe4 0xc4 + +black :: RGBi +black = RGBi 0x00 0x00 0x00 + +blanched_almond :: RGBi +blanched_almond = RGBi 0xff 0xeb 0xcd + +blue :: RGBi +blue = RGBi 0x00 0x00 0xff + +blue_violet :: RGBi +blue_violet = RGBi 0x8a 0x2b 0xe2 + +brown :: RGBi +brown = RGBi 0xa5 0x2a 0x2a + +burlywood :: RGBi +burlywood = RGBi 0xde 0xb8 0x87 + +cadet_blue :: RGBi +cadet_blue = RGBi 0x5f 0x9e 0xa0 + +chartreuse :: RGBi +chartreuse = RGBi 0x7f 0xff 0x00 + +chocolate :: RGBi +chocolate = RGBi 0xd2 0x69 0x1e + +coral :: RGBi +coral = RGBi 0xff 0x7f 0x50 + +cornflower_blue :: RGBi +cornflower_blue = RGBi 0x64 0x95 0xed + +cornsilk :: RGBi +cornsilk = RGBi 0xff 0xf8 0xdc + +crimson :: RGBi +crimson = RGBi 0xdc 0x14 0x3c + +cyan :: RGBi +cyan = RGBi 0x00 0xff 0xff + +dark_blue :: RGBi +dark_blue = RGBi 0x00 0x00 0x8b + +dark_cyan :: RGBi +dark_cyan = RGBi 0x00 0x8b 0x8b + +dark_goldenrod :: RGBi +dark_goldenrod = RGBi 0xb8 0x86 0x0b + +dark_gray :: RGBi +dark_gray = RGBi 0xa9 0xa9 0xa9 + +dark_green :: RGBi +dark_green = RGBi 0x00 0x64 0x00 + +dark_grey :: RGBi +dark_grey = RGBi 0xa9 0xa9 0xa9 + +dark_khaki :: RGBi +dark_khaki = RGBi 0xbd 0xb7 0x6b + +dark_magenta :: RGBi +dark_magenta = RGBi 0x8b 0x00 0x8b + +dark_olive_green :: RGBi +dark_olive_green = RGBi 0x55 0x6b 0x2f + +dark_orange :: RGBi +dark_orange = RGBi 0xff 0x8c 0x00 + +dark_orchid :: RGBi +dark_orchid = RGBi 0x99 0x32 0xcc + +dark_red :: RGBi +dark_red = RGBi 0x8b 0x00 0x00 + +dark_salmon :: RGBi +dark_salmon = RGBi 0xe9 0x96 0x7a + +dark_sea_green :: RGBi +dark_sea_green = RGBi 0x8f 0xbc 0x8f + +dark_slate_blue :: RGBi +dark_slate_blue = RGBi 0x48 0x3d 0x8b + +dark_slate_gray :: RGBi +dark_slate_gray = RGBi 0x2f 0x4f 0x4f + +dark_slate_grey :: RGBi +dark_slate_grey = RGBi 0x2f 0x4f 0x4f + +dark_turquoise :: RGBi +dark_turquoise = RGBi 0x00 0xce 0xd1 + +dark_violet :: RGBi +dark_violet = RGBi 0x94 0x00 0xd3 + +deep_pink :: RGBi +deep_pink = RGBi 0xff 0x14 0x93 + +deep_sky_blue :: RGBi +deep_sky_blue = RGBi 0x00 0xbf 0xff + +dim_gray :: RGBi +dim_gray = RGBi 0x69 0x69 0x69 + +dim_grey :: RGBi +dim_grey = RGBi 0x69 0x69 0x69 + +dodger_blue :: RGBi +dodger_blue = RGBi 0x1e 0x90 0xff + +firebrick :: RGBi +firebrick = RGBi 0xb2 0x22 0x22 + +floral_white :: RGBi +floral_white = RGBi 0xff 0xfa 0xf0 + +forest_green :: RGBi +forest_green = RGBi 0x22 0x8b 0x22 + +fuchsia :: RGBi +fuchsia = RGBi 0xff 0x00 0xff + +gainsboro :: RGBi +gainsboro = RGBi 0xdc 0xdc 0xdc + +ghost_white :: RGBi +ghost_white = RGBi 0xf8 0xf8 0xff + +gold :: RGBi +gold = RGBi 0xff 0xd7 0x00 + +goldenrod :: RGBi +goldenrod = RGBi 0xda 0xa5 0x20 + +gray :: RGBi +gray = RGBi 0x80 0x80 0x80 + +green :: RGBi +green = RGBi 0x00 0x80 0x00 + +green_yellow :: RGBi +green_yellow = RGBi 0xad 0xff 0x2f + +grey :: RGBi +grey = RGBi 0x80 0x80 0x80 + +honeydew :: RGBi +honeydew = RGBi 0xf0 0xff 0xf0 + +hot_pink :: RGBi +hot_pink = RGBi 0xff 0x69 0xb4 + +indian_red :: RGBi +indian_red = RGBi 0xcd 0x5c 0x5c + +indigo :: RGBi +indigo = RGBi 0x4b 0x00 0x82 + +ivory :: RGBi +ivory = RGBi 0xff 0xff 0xf0 + +khaki :: RGBi +khaki = RGBi 0xf0 0xe6 0x8c + +lavender :: RGBi +lavender = RGBi 0xe6 0xe6 0xfa + +lavender_blush :: RGBi +lavender_blush = RGBi 0xff 0xf0 0xf5 + +lawn_green :: RGBi +lawn_green = RGBi 0x7c 0xfc 0x00 + +lemon_chiffon :: RGBi +lemon_chiffon = RGBi 0xff 0xfa 0xcd + +light_blue :: RGBi +light_blue = RGBi 0xad 0xd8 0xe6 + +light_coral :: RGBi +light_coral = RGBi 0xf0 0x80 0x80 + +light_cyan :: RGBi +light_cyan = RGBi 0xe0 0xff 0xff + +light_goldenrod_yellow :: RGBi +light_goldenrod_yellow = RGBi 0xfa 0xfa 0xd2 + +light_gray :: RGBi +light_gray = RGBi 0xd3 0xd3 0xd3 + +light_green :: RGBi +light_green = RGBi 0x90 0xee 0x90 + +light_grey :: RGBi +light_grey = RGBi 0xd3 0xd3 0xd3 + +light_pink :: RGBi +light_pink = RGBi 0xff 0xb6 0xc1 + +light_salmon :: RGBi +light_salmon = RGBi 0xff 0xa0 0x7a + +light_sea_green :: RGBi +light_sea_green = RGBi 0x20 0xb2 0xaa + +light_sky_blue :: RGBi +light_sky_blue = RGBi 0x87 0xce 0xfa + +light_slate_gray :: RGBi +light_slate_gray = RGBi 0x77 0x88 0x99 + +light_slate_grey :: RGBi +light_slate_grey = RGBi 0x77 0x88 0x99 + +light_steel_blue :: RGBi +light_steel_blue = RGBi 0xb0 0xc4 0xde + +light_yellow :: RGBi +light_yellow = RGBi 0xff 0xff 0xe0 + +lime :: RGBi +lime = RGBi 0x00 0xff 0x00 + +lime_green :: RGBi +lime_green = RGBi 0x32 0xcd 0x32 + +linen :: RGBi +linen = RGBi 0xfa 0xf0 0xe6 + +magenta :: RGBi +magenta = RGBi 0xff 0x00 0xff + +maroon :: RGBi +maroon = RGBi 0x80 0x00 0x00 + +medium_aquamarine :: RGBi +medium_aquamarine = RGBi 0x66 0xcd 0xaa + +medium_blue :: RGBi +medium_blue = RGBi 0x00 0x00 0xcd + +medium_orchid :: RGBi +medium_orchid = RGBi 0xba 0x55 0xd3 + +medium_purple :: RGBi +medium_purple = RGBi 0x93 0x70 0xdb + +medium_sea_green :: RGBi +medium_sea_green = RGBi 0x3c 0xb3 0x71 + +medium_slate_blue :: RGBi +medium_slate_blue = RGBi 0x7b 0x68 0xee + +medium_spring_green :: RGBi +medium_spring_green = RGBi 0x00 0xfa 0x9a + +medium_turquoise :: RGBi +medium_turquoise = RGBi 0x48 0xd1 0xcc + +medium_violet_red :: RGBi +medium_violet_red = RGBi 0xc7 0x15 0x85 + +midnight_blue :: RGBi +midnight_blue = RGBi 0x19 0x19 0x70 + +mintcream :: RGBi +mintcream = RGBi 0xf5 0xff 0xfa + +mistyrose :: RGBi +mistyrose = RGBi 0xff 0xe4 0xe1 + +moccasin :: RGBi +moccasin = RGBi 0xff 0xe4 0xb5 + +navajo_white :: RGBi +navajo_white = RGBi 0xff 0xde 0xad + +navy :: RGBi +navy = RGBi 0x00 0x00 0x80 + +old_lace :: RGBi +old_lace = RGBi 0xfd 0xf5 0xe6 + +olive :: RGBi +olive = RGBi 0x80 0x80 0x00 + +olive_drab :: RGBi +olive_drab = RGBi 0x6b 0x8e 0x23 + +orange :: RGBi +orange = RGBi 0xff 0xa5 0x00 + +orange_red :: RGBi +orange_red = RGBi 0xff 0x45 0x00 + +orchid :: RGBi +orchid = RGBi 0xda 0x70 0xd6 + +pale_goldenrod :: RGBi +pale_goldenrod = RGBi 0xee 0xe8 0xaa + +pale_green :: RGBi +pale_green = RGBi 0x98 0xfb 0x98 + +pale_turquoise :: RGBi +pale_turquoise = RGBi 0xaf 0xee 0xee + +pale_violet_red :: RGBi +pale_violet_red = RGBi 0xdb 0x70 0x93 + +papaya_whip :: RGBi +papaya_whip = RGBi 0xff 0xef 0xd5 + +peach_puff :: RGBi +peach_puff = RGBi 0xff 0xda 0xb9 + +peru :: RGBi +peru = RGBi 0xcd 0x85 0x3f + +pink :: RGBi +pink = RGBi 0xff 0xc0 0xcb + +plum :: RGBi +plum = RGBi 0xdd 0xa0 0xdd + +powder_blue :: RGBi +powder_blue = RGBi 0xb0 0xe0 0xe6 + +purple :: RGBi +purple = RGBi 0x80 0x00 0x80 + +red :: RGBi +red = RGBi 0xff 0x00 0x00 + +rosy_brown :: RGBi +rosy_brown = RGBi 0xbc 0x8f 0x8f + +royal_blue :: RGBi +royal_blue = RGBi 0x41 0x69 0xe1 + +saddle_brown :: RGBi +saddle_brown = RGBi 0x8b 0x45 0x13 + +salmon :: RGBi +salmon = RGBi 0xfa 0x80 0x72 + +sandy_brown :: RGBi +sandy_brown = RGBi 0xf4 0xa4 0x60 + +sea_green :: RGBi +sea_green = RGBi 0x2e 0x8b 0x57 + +seashell :: RGBi +seashell = RGBi 0xff 0xf5 0xee + +sienna :: RGBi +sienna = RGBi 0xa0 0x52 0x2d + +silver :: RGBi +silver = RGBi 0xc0 0xc0 0xc0 + +sky_blue :: RGBi +sky_blue = RGBi 0x87 0xce 0xeb + +slate_blue :: RGBi +slate_blue = RGBi 0x6a 0x5a 0xcd + +slate_gray :: RGBi +slate_gray = RGBi 0x70 0x80 0x90 + +slate_grey :: RGBi +slate_grey = RGBi 0x70 0x80 0x90 + +snow :: RGBi +snow = RGBi 0xff 0xfa 0xfa + +spring_green :: RGBi +spring_green = RGBi 0x00 0xff 0x7f + +steel_blue :: RGBi +steel_blue = RGBi 0x46 0x82 0xb4 + +tan :: RGBi +tan = RGBi 0xd2 0xb4 0x8c + +teal :: RGBi +teal = RGBi 0x00 0x80 0x80 + +thistle :: RGBi +thistle = RGBi 0xd8 0xbf 0xd8 + +tomato :: RGBi +tomato = RGBi 0xff 0x63 0x47 + +turquoise :: RGBi +turquoise = RGBi 0x40 0xe0 0xd0 + +violet :: RGBi +violet = RGBi 0xee 0x82 0xee + +wheat :: RGBi +wheat = RGBi 0xf5 0xde 0xb3 + +white :: RGBi +white = RGBi 0xff 0xff 0xff + +whitesmoke :: RGBi +whitesmoke = RGBi 0xf5 0xf5 0xf5 + +yellow :: RGBi +yellow = RGBi 0xff 0xff 0x00 + +yellow_green :: RGBi +yellow_green = RGBi 0x9a 0xcd 0x32 + + + + + diff --git a/src/Wumpus/Drawing/Colour/X11Colours.hs b/src/Wumpus/Drawing/Colour/X11Colours.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Colour/X11Colours.hs @@ -0,0 +1,1282 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Colour.X11Colours +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : unstable +-- Portability : GHC +-- +-- The X11 \'named colours\', as rgb [0,1] values +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Colour.X11Colours + ( + + -- * Named X11 colours + antique_white1 + , antique_white2 + , antique_white3 + , antique_white4 + , aquamarine1 + , aquamarine2 + , aquamarine3 + , aquamarine4 + , azure1 + , azure2 + , azure3 + , azure4 + , bisque1 + , bisque2 + , bisque3 + , bisque4 + , blue1 + , blue2 + , blue3 + , blue4 + , brown1 + , brown2 + , brown3 + , brown4 + , burlywood1 + , burlywood2 + , burlywood3 + , burlywood4 + , cadet_blue1 + , cadet_blue2 + , cadet_blue3 + , cadet_blue4 + , chartreuse1 + , chartreuse2 + , chartreuse3 + , chartreuse4 + , chocolate1 + , chocolate2 + , chocolate3 + , chocolate4 + , coral1 + , coral2 + , coral3 + , coral4 + , cornsilk1 + , cornsilk2 + , cornsilk3 + , cornsilk4 + , cyan1 + , cyan2 + , cyan3 + , cyan4 + , dark_goldenrod1 + , dark_goldenrod2 + , dark_goldenrod3 + , dark_goldenrod4 + , dark_olive_green1 + , dark_olive_green2 + , dark_olive_green3 + , dark_olive_green4 + , dark_orange1 + , dark_orange2 + , dark_orange3 + , dark_orange4 + , dark_orchid1 + , dark_orchid2 + , dark_orchid3 + , dark_orchid4 + , dark_sea_green1 + , dark_sea_green2 + , dark_sea_green3 + , dark_sea_green4 + , dark_slate_gray1 + , dark_slate_gray2 + , dark_slate_gray3 + , dark_slate_gray4 + , deep_pink1 + , deep_pink2 + , deep_pink3 + , deep_pink4 + , deep_sky_blue1 + , deep_sky_blue2 + , deep_sky_blue3 + , deep_sky_blue4 + , dodger_blue1 + , dodger_blue2 + , dodger_blue3 + , dodger_blue4 + , firebrick1 + , firebrick2 + , firebrick3 + , firebrick4 + , gold1 + , gold2 + , gold3 + , gold4 + , goldenrod1 + , goldenrod2 + , goldenrod3 + , goldenrod4 + , green1 + , green2 + , green3 + , green4 + , honeydew1 + , honeydew2 + , honeydew3 + , honeydew4 + , hot_pink1 + , hot_pink2 + , hot_pink3 + , hot_pink4 + , indian_red1 + , indian_red2 + , indian_red3 + , indian_red4 + , ivory1 + , ivory2 + , ivory3 + , ivory4 + , khaki1 + , khaki2 + , khaki3 + , khaki4 + , lavender_blush1 + , lavender_blush2 + , lavender_blush3 + , lavender_blush4 + , lemon_chiffon1 + , lemon_chiffon2 + , lemon_chiffon3 + , lemon_chiffon4 + , light_blue1 + , light_blue2 + , light_blue3 + , light_blue4 + , light_cyan1 + , light_cyan2 + , light_cyan3 + , light_cyan4 + , light_goldenrod1 + , light_goldenrod2 + , light_goldenrod3 + , light_goldenrod4 + , light_pink1 + , light_pink2 + , light_pink3 + , light_pink4 + , light_salmon1 + , light_salmon2 + , light_salmon3 + , light_salmon4 + , light_sky_blue1 + , light_sky_blue2 + , light_sky_blue3 + , light_sky_blue4 + , light_steel_blue1 + , light_steel_blue2 + , light_steel_blue3 + , light_steel_blue4 + , light_yellow1 + , light_yellow2 + , light_yellow3 + , light_yellow4 + , magenta1 + , magenta2 + , magenta3 + , magenta4 + , maroon1 + , maroon2 + , maroon3 + , maroon4 + , medium_orchid1 + , medium_orchid2 + , medium_orchid3 + , medium_orchid4 + , medium_purple1 + , medium_purple2 + , medium_purple3 + , medium_purple4 + , misty_rose1 + , misty_rose2 + , misty_rose3 + , misty_rose4 + , navajo_white1 + , navajo_white2 + , navajo_white3 + , navajo_white4 + , olive_drab1 + , olive_drab2 + , olive_drab3 + , olive_drab4 + , orange1 + , orange2 + , orange3 + , orange4 + , orange_red1 + , orange_red2 + , orange_red3 + , orange_red4 + , orchid1 + , orchid2 + , orchid3 + , orchid4 + , pale_green1 + , pale_green2 + , pale_green3 + , pale_green4 + , pale_turquoise1 + , pale_turquoise2 + , pale_turquoise3 + , pale_turquoise4 + , pale_violet_red1 + , pale_violet_red2 + , pale_violet_red3 + , pale_violet_red4 + , peach_puff1 + , peach_puff2 + , peach_puff3 + , peach_puff4 + , pink1 + , pink2 + , pink3 + , pink4 + , plum1 + , plum2 + , plum3 + , plum4 + , purple1 + , purple2 + , purple3 + , purple4 + , red1 + , red2 + , red3 + , red4 + , rosy_brown1 + , rosy_brown2 + , rosy_brown3 + , rosy_brown4 + , royal_blue1 + , royal_blue2 + , royal_blue3 + , royal_blue4 + , salmon1 + , salmon2 + , salmon3 + , salmon4 + , sea_green1 + , sea_green2 + , sea_green3 + , sea_green4 + , seashell1 + , seashell2 + , seashell3 + , seashell4 + , sienna1 + , sienna2 + , sienna3 + , sienna4 + , sky_blue1 + , sky_blue2 + , sky_blue3 + , sky_blue4 + , slate_blue1 + , slate_blue2 + , slate_blue3 + , slate_blue4 + , slate_gray1 + , slate_gray2 + , slate_gray3 + , slate_gray4 + , snow1 + , snow2 + , snow3 + , snow4 + , spring_green1 + , spring_green2 + , spring_green3 + , spring_green4 + , steel_blue1 + , steel_blue2 + , steel_blue3 + , steel_blue4 + , tan1 + , tan2 + , tan3 + , tan4 + , thistle1 + , thistle2 + , thistle3 + , thistle4 + , tomato1 + , tomato2 + , tomato3 + , tomato4 + , turquoise1 + , turquoise2 + , turquoise3 + , turquoise4 + , violet_red1 + , violet_red2 + , violet_red3 + , violet_red4 + , wheat1 + , wheat2 + , wheat3 + , wheat4 + , yellow1 + , yellow2 + , yellow3 + , yellow4 + + ) where + +import Wumpus.Core.Colour ( RGBi(..) ) + + +-------------------------------------------------------------------------------- + +antique_white1 :: RGBi +antique_white1 = RGBi 0xff 0xef 0xdb + +antique_white2 :: RGBi +antique_white2 = RGBi 0xee 0xdf 0xcc + +antique_white3 :: RGBi +antique_white3 = RGBi 0xcd 0xc0 0xb0 + +antique_white4 :: RGBi +antique_white4 = RGBi 0x8b 0x83 0x78 + +aquamarine1 :: RGBi +aquamarine1 = RGBi 0x7f 0xff 0xd4 + +aquamarine2 :: RGBi +aquamarine2 = RGBi 0x76 0xee 0xc6 + +aquamarine3 :: RGBi +aquamarine3 = RGBi 0x66 0xcd 0xaa + +aquamarine4 :: RGBi +aquamarine4 = RGBi 0x45 0x8b 0x74 + +azure1 :: RGBi +azure1 = RGBi 0xf0 0xff 0xff + +azure2 :: RGBi +azure2 = RGBi 0xe0 0xee 0xee + +azure3 :: RGBi +azure3 = RGBi 0xc1 0xcd 0xcd + +azure4 :: RGBi +azure4 = RGBi 0x83 0x8b 0x8b + +bisque1 :: RGBi +bisque1 = RGBi 0xff 0xe4 0xc4 + +bisque2 :: RGBi +bisque2 = RGBi 0xee 0xd5 0xb7 + +bisque3 :: RGBi +bisque3 = RGBi 0xcd 0xb7 0x9e + +bisque4 :: RGBi +bisque4 = RGBi 0x8b 0x7d 0x6b + +blue1 :: RGBi +blue1 = RGBi 0x00 0x00 0xff + +blue2 :: RGBi +blue2 = RGBi 0x00 0x00 0xee + +blue3 :: RGBi +blue3 = RGBi 0x00 0x00 0xcd + +blue4 :: RGBi +blue4 = RGBi 0x00 0x00 0x8b + +brown1 :: RGBi +brown1 = RGBi 0xff 0x40 0x40 + +brown2 :: RGBi +brown2 = RGBi 0xee 0x3b 0x3b + +brown3 :: RGBi +brown3 = RGBi 0xcd 0x33 0x33 + +brown4 :: RGBi +brown4 = RGBi 0x8b 0x23 0x23 + +burlywood1 :: RGBi +burlywood1 = RGBi 0xff 0xd3 0x9b + +burlywood2 :: RGBi +burlywood2 = RGBi 0xee 0xc5 0x91 + +burlywood3 :: RGBi +burlywood3 = RGBi 0xcd 0xaa 0x7d + +burlywood4 :: RGBi +burlywood4 = RGBi 0x8b 0x73 0x55 + +cadet_blue1 :: RGBi +cadet_blue1 = RGBi 0x98 0xf5 0xff + +cadet_blue2 :: RGBi +cadet_blue2 = RGBi 0x8e 0xe5 0xee + +cadet_blue3 :: RGBi +cadet_blue3 = RGBi 0x7a 0xc5 0xcd + +cadet_blue4 :: RGBi +cadet_blue4 = RGBi 0x53 0x86 0x8b + +chartreuse1 :: RGBi +chartreuse1 = RGBi 0x7f 0xff 0x00 + +chartreuse2 :: RGBi +chartreuse2 = RGBi 0x76 0xee 0x00 + +chartreuse3 :: RGBi +chartreuse3 = RGBi 0x66 0xcd 0x00 + +chartreuse4 :: RGBi +chartreuse4 = RGBi 0x45 0x8b 0x00 + +chocolate1 :: RGBi +chocolate1 = RGBi 0xff 0x7f 0x24 + +chocolate2 :: RGBi +chocolate2 = RGBi 0xee 0x76 0x21 + +chocolate3 :: RGBi +chocolate3 = RGBi 0xcd 0x66 0x1d + +chocolate4 :: RGBi +chocolate4 = RGBi 0x8b 0x45 0x13 + +coral1 :: RGBi +coral1 = RGBi 0xff 0x72 0x56 + +coral2 :: RGBi +coral2 = RGBi 0xee 0x6a 0x50 + +coral3 :: RGBi +coral3 = RGBi 0xcd 0x5b 0x45 + +coral4 :: RGBi +coral4 = RGBi 0x8b 0x3e 0x2f + +cornsilk1 :: RGBi +cornsilk1 = RGBi 0xff 0xf8 0xdc + +cornsilk2 :: RGBi +cornsilk2 = RGBi 0xee 0xe8 0xcd + +cornsilk3 :: RGBi +cornsilk3 = RGBi 0xcd 0xc8 0xb1 + +cornsilk4 :: RGBi +cornsilk4 = RGBi 0x8b 0x88 0x78 + +cyan1 :: RGBi +cyan1 = RGBi 0x00 0xff 0xff + +cyan2 :: RGBi +cyan2 = RGBi 0x00 0xee 0xee + +cyan3 :: RGBi +cyan3 = RGBi 0x00 0xcd 0xcd + +cyan4 :: RGBi +cyan4 = RGBi 0x00 0x8b 0x8b + +dark_goldenrod1 :: RGBi +dark_goldenrod1 = RGBi 0xff 0xb9 0x0f + +dark_goldenrod2 :: RGBi +dark_goldenrod2 = RGBi 0xee 0xad 0x0e + +dark_goldenrod3 :: RGBi +dark_goldenrod3 = RGBi 0xcd 0x95 0x0c + +dark_goldenrod4 :: RGBi +dark_goldenrod4 = RGBi 0x8b 0x65 0x08 + +dark_olive_green1 :: RGBi +dark_olive_green1 = RGBi 0xca 0xff 0x70 + +dark_olive_green2 :: RGBi +dark_olive_green2 = RGBi 0xbc 0xee 0x68 + +dark_olive_green3 :: RGBi +dark_olive_green3 = RGBi 0xa2 0xcd 0x5a + +dark_olive_green4 :: RGBi +dark_olive_green4 = RGBi 0x6e 0x8b 0x3d + +dark_orange1 :: RGBi +dark_orange1 = RGBi 0xff 0x7f 0x00 + +dark_orange2 :: RGBi +dark_orange2 = RGBi 0xee 0x76 0x00 + +dark_orange3 :: RGBi +dark_orange3 = RGBi 0xcd 0x66 0x00 + +dark_orange4 :: RGBi +dark_orange4 = RGBi 0x8b 0x45 0x00 + +dark_orchid1 :: RGBi +dark_orchid1 = RGBi 0xbf 0x3e 0xff + +dark_orchid2 :: RGBi +dark_orchid2 = RGBi 0xb2 0x3a 0xee + +dark_orchid3 :: RGBi +dark_orchid3 = RGBi 0x9a 0x32 0xcd + +dark_orchid4 :: RGBi +dark_orchid4 = RGBi 0x68 0x22 0x8b + +dark_sea_green1 :: RGBi +dark_sea_green1 = RGBi 0xc1 0xff 0xc1 + +dark_sea_green2 :: RGBi +dark_sea_green2 = RGBi 0xb4 0xee 0xb4 + +dark_sea_green3 :: RGBi +dark_sea_green3 = RGBi 0x9b 0xcd 0x9b + +dark_sea_green4 :: RGBi +dark_sea_green4 = RGBi 0x69 0x8b 0x69 + +dark_slate_gray1 :: RGBi +dark_slate_gray1 = RGBi 0x97 0xff 0xff + +dark_slate_gray2 :: RGBi +dark_slate_gray2 = RGBi 0x8d 0xee 0xee + +dark_slate_gray3 :: RGBi +dark_slate_gray3 = RGBi 0x79 0xcd 0xcd + +dark_slate_gray4 :: RGBi +dark_slate_gray4 = RGBi 0x52 0x8b 0x8b + +deep_pink1 :: RGBi +deep_pink1 = RGBi 0xff 0x14 0x93 + +deep_pink2 :: RGBi +deep_pink2 = RGBi 0xee 0x12 0x89 + +deep_pink3 :: RGBi +deep_pink3 = RGBi 0xcd 0x10 0x76 + +deep_pink4 :: RGBi +deep_pink4 = RGBi 0x8b 0x0a 0x50 + +deep_sky_blue1 :: RGBi +deep_sky_blue1 = RGBi 0x00 0xbf 0xff + +deep_sky_blue2 :: RGBi +deep_sky_blue2 = RGBi 0x00 0xb2 0xee + +deep_sky_blue3 :: RGBi +deep_sky_blue3 = RGBi 0x00 0x9a 0xcd + +deep_sky_blue4 :: RGBi +deep_sky_blue4 = RGBi 0x00 0x68 0x8b + +dodger_blue1 :: RGBi +dodger_blue1 = RGBi 0x1e 0x90 0xff + +dodger_blue2 :: RGBi +dodger_blue2 = RGBi 0x1c 0x86 0xee + +dodger_blue3 :: RGBi +dodger_blue3 = RGBi 0x18 0x74 0xcd + +dodger_blue4 :: RGBi +dodger_blue4 = RGBi 0x10 0x4e 0x8b + +firebrick1 :: RGBi +firebrick1 = RGBi 0xff 0x30 0x30 + +firebrick2 :: RGBi +firebrick2 = RGBi 0xee 0x2c 0x2c + +firebrick3 :: RGBi +firebrick3 = RGBi 0xcd 0x26 0x26 + +firebrick4 :: RGBi +firebrick4 = RGBi 0x8b 0x1a 0x1a + +gold1 :: RGBi +gold1 = RGBi 0xff 0xd7 0x00 + +gold2 :: RGBi +gold2 = RGBi 0xee 0xc9 0x00 + +gold3 :: RGBi +gold3 = RGBi 0xcd 0xad 0x00 + +gold4 :: RGBi +gold4 = RGBi 0x8b 0x75 0x00 + +goldenrod1 :: RGBi +goldenrod1 = RGBi 0xff 0xc1 0x25 + +goldenrod2 :: RGBi +goldenrod2 = RGBi 0xee 0xb4 0x22 + +goldenrod3 :: RGBi +goldenrod3 = RGBi 0xcd 0x9b 0x1d + +goldenrod4 :: RGBi +goldenrod4 = RGBi 0x8b 0x69 0x14 + +green1 :: RGBi +green1 = RGBi 0x00 0xff 0x00 + +green2 :: RGBi +green2 = RGBi 0x00 0xee 0x00 + +green3 :: RGBi +green3 = RGBi 0x00 0xcd 0x00 + +green4 :: RGBi +green4 = RGBi 0x00 0x8b 0x00 + +honeydew1 :: RGBi +honeydew1 = RGBi 0xf0 0xff 0xf0 + +honeydew2 :: RGBi +honeydew2 = RGBi 0xe0 0xee 0xe0 + +honeydew3 :: RGBi +honeydew3 = RGBi 0xc1 0xcd 0xc1 + +honeydew4 :: RGBi +honeydew4 = RGBi 0x83 0x8b 0x83 + +hot_pink1 :: RGBi +hot_pink1 = RGBi 0xff 0x6e 0xb4 + +hot_pink2 :: RGBi +hot_pink2 = RGBi 0xee 0x6a 0xa7 + +hot_pink3 :: RGBi +hot_pink3 = RGBi 0xcd 0x60 0x90 + +hot_pink4 :: RGBi +hot_pink4 = RGBi 0x8b 0x3a 0x62 + +indian_red1 :: RGBi +indian_red1 = RGBi 0xff 0x6a 0x6a + +indian_red2 :: RGBi +indian_red2 = RGBi 0xee 0x63 0x63 + +indian_red3 :: RGBi +indian_red3 = RGBi 0xcd 0x55 0x55 + +indian_red4 :: RGBi +indian_red4 = RGBi 0x8b 0x3a 0x3a + +ivory1 :: RGBi +ivory1 = RGBi 0xff 0xff 0xf0 + +ivory2 :: RGBi +ivory2 = RGBi 0xee 0xee 0xe0 + +ivory3 :: RGBi +ivory3 = RGBi 0xcd 0xcd 0xc1 + +ivory4 :: RGBi +ivory4 = RGBi 0x8b 0x8b 0x83 + +khaki1 :: RGBi +khaki1 = RGBi 0xff 0xf6 0x8f + +khaki2 :: RGBi +khaki2 = RGBi 0xee 0xe6 0x85 + +khaki3 :: RGBi +khaki3 = RGBi 0xcd 0xc6 0x73 + +khaki4 :: RGBi +khaki4 = RGBi 0x8b 0x86 0x4e + +lavender_blush1 :: RGBi +lavender_blush1 = RGBi 0xff 0xf0 0xf5 + +lavender_blush2 :: RGBi +lavender_blush2 = RGBi 0xee 0xe0 0xe5 + +lavender_blush3 :: RGBi +lavender_blush3 = RGBi 0xcd 0xc1 0xc5 + +lavender_blush4 :: RGBi +lavender_blush4 = RGBi 0x8b 0x83 0x86 + +lemon_chiffon1 :: RGBi +lemon_chiffon1 = RGBi 0xff 0xfa 0xcd + +lemon_chiffon2 :: RGBi +lemon_chiffon2 = RGBi 0xee 0xe9 0xbf + +lemon_chiffon3 :: RGBi +lemon_chiffon3 = RGBi 0xcd 0xc9 0xa5 + +lemon_chiffon4 :: RGBi +lemon_chiffon4 = RGBi 0x8b 0x89 0x70 + +light_blue1 :: RGBi +light_blue1 = RGBi 0xbf 0xef 0xff + +light_blue2 :: RGBi +light_blue2 = RGBi 0xb2 0xdf 0xee + +light_blue3 :: RGBi +light_blue3 = RGBi 0x9a 0xc0 0xcd + +light_blue4 :: RGBi +light_blue4 = RGBi 0x68 0x83 0x8b + +light_cyan1 :: RGBi +light_cyan1 = RGBi 0xe0 0xff 0xff + +light_cyan2 :: RGBi +light_cyan2 = RGBi 0xd1 0xee 0xee + +light_cyan3 :: RGBi +light_cyan3 = RGBi 0xb4 0xcd 0xcd + +light_cyan4 :: RGBi +light_cyan4 = RGBi 0x7a 0x8b 0x8b + +light_goldenrod1 :: RGBi +light_goldenrod1 = RGBi 0xff 0xec 0x8b + +light_goldenrod2 :: RGBi +light_goldenrod2 = RGBi 0xee 0xdc 0x82 + +light_goldenrod3 :: RGBi +light_goldenrod3 = RGBi 0xcd 0xbe 0x70 + +light_goldenrod4 :: RGBi +light_goldenrod4 = RGBi 0x8b 0x81 0x4c + +light_pink1 :: RGBi +light_pink1 = RGBi 0xff 0xae 0xb9 + +light_pink2 :: RGBi +light_pink2 = RGBi 0xee 0xa2 0xad + +light_pink3 :: RGBi +light_pink3 = RGBi 0xcd 0x8c 0x95 + +light_pink4 :: RGBi +light_pink4 = RGBi 0x8b 0x5f 0x65 + +light_salmon1 :: RGBi +light_salmon1 = RGBi 0xff 0xa0 0x7a + +light_salmon2 :: RGBi +light_salmon2 = RGBi 0xee 0x95 0x72 + +light_salmon3 :: RGBi +light_salmon3 = RGBi 0xcd 0x81 0x62 + +light_salmon4 :: RGBi +light_salmon4 = RGBi 0x8b 0x57 0x42 + +light_sky_blue1 :: RGBi +light_sky_blue1 = RGBi 0xb0 0xe2 0xff + +light_sky_blue2 :: RGBi +light_sky_blue2 = RGBi 0xa4 0xd3 0xee + +light_sky_blue3 :: RGBi +light_sky_blue3 = RGBi 0x8d 0xb6 0xcd + +light_sky_blue4 :: RGBi +light_sky_blue4 = RGBi 0x60 0x7b 0x8b + +light_steel_blue1 :: RGBi +light_steel_blue1 = RGBi 0xca 0xe1 0xff + +light_steel_blue2 :: RGBi +light_steel_blue2 = RGBi 0xbc 0xd2 0xee + +light_steel_blue3 :: RGBi +light_steel_blue3 = RGBi 0xa2 0xb5 0xcd + +light_steel_blue4 :: RGBi +light_steel_blue4 = RGBi 0x6e 0x7b 0x8b + +light_yellow1 :: RGBi +light_yellow1 = RGBi 0xff 0xff 0xe0 + +light_yellow2 :: RGBi +light_yellow2 = RGBi 0xee 0xee 0xd1 + +light_yellow3 :: RGBi +light_yellow3 = RGBi 0xcd 0xcd 0xb4 + +light_yellow4 :: RGBi +light_yellow4 = RGBi 0x8b 0x8b 0x7a + +magenta1 :: RGBi +magenta1 = RGBi 0xff 0x00 0xff + +magenta2 :: RGBi +magenta2 = RGBi 0xee 0x00 0xee + +magenta3 :: RGBi +magenta3 = RGBi 0xcd 0x00 0xcd + +magenta4 :: RGBi +magenta4 = RGBi 0x8b 0x00 0x8b + +maroon1 :: RGBi +maroon1 = RGBi 0xff 0x34 0xb3 + +maroon2 :: RGBi +maroon2 = RGBi 0xee 0x30 0xa7 + +maroon3 :: RGBi +maroon3 = RGBi 0xcd 0x29 0x90 + +maroon4 :: RGBi +maroon4 = RGBi 0x8b 0x1c 0x62 + +medium_orchid1 :: RGBi +medium_orchid1 = RGBi 0xe0 0x66 0xff + +medium_orchid2 :: RGBi +medium_orchid2 = RGBi 0xd1 0x5f 0xee + +medium_orchid3 :: RGBi +medium_orchid3 = RGBi 0xb4 0x52 0xcd + +medium_orchid4 :: RGBi +medium_orchid4 = RGBi 0x7a 0x37 0x8b + +medium_purple1 :: RGBi +medium_purple1 = RGBi 0xab 0x82 0xff + +medium_purple2 :: RGBi +medium_purple2 = RGBi 0x9f 0x79 0xee + +medium_purple3 :: RGBi +medium_purple3 = RGBi 0x89 0x68 0xcd + +medium_purple4 :: RGBi +medium_purple4 = RGBi 0x5d 0x47 0x8b + +misty_rose1 :: RGBi +misty_rose1 = RGBi 0xff 0xe4 0xe1 + +misty_rose2 :: RGBi +misty_rose2 = RGBi 0xee 0xd5 0xd2 + +misty_rose3 :: RGBi +misty_rose3 = RGBi 0xcd 0xb7 0xb5 + +misty_rose4 :: RGBi +misty_rose4 = RGBi 0x8b 0x7d 0x7b + +navajo_white1 :: RGBi +navajo_white1 = RGBi 0xff 0xde 0xad + +navajo_white2 :: RGBi +navajo_white2 = RGBi 0xee 0xcf 0xa1 + +navajo_white3 :: RGBi +navajo_white3 = RGBi 0xcd 0xb3 0x8b + +navajo_white4 :: RGBi +navajo_white4 = RGBi 0x8b 0x79 0x5e + +olive_drab1 :: RGBi +olive_drab1 = RGBi 0xc0 0xff 0x3e + +olive_drab2 :: RGBi +olive_drab2 = RGBi 0xb3 0xee 0x3a + +olive_drab3 :: RGBi +olive_drab3 = RGBi 0x9a 0xcd 0x32 + +olive_drab4 :: RGBi +olive_drab4 = RGBi 0x69 0x8b 0x22 + +orange1 :: RGBi +orange1 = RGBi 0xff 0xa5 0x00 + +orange2 :: RGBi +orange2 = RGBi 0xee 0x9a 0x00 + +orange3 :: RGBi +orange3 = RGBi 0xcd 0x85 0x00 + +orange4 :: RGBi +orange4 = RGBi 0x8b 0x5a 0x00 + +orange_red1 :: RGBi +orange_red1 = RGBi 0xff 0x45 0x00 + +orange_red2 :: RGBi +orange_red2 = RGBi 0xee 0x40 0x00 + +orange_red3 :: RGBi +orange_red3 = RGBi 0xcd 0x37 0x00 + +orange_red4 :: RGBi +orange_red4 = RGBi 0x8b 0x25 0x00 + +orchid1 :: RGBi +orchid1 = RGBi 0xff 0x83 0xfa + +orchid2 :: RGBi +orchid2 = RGBi 0xee 0x7a 0xe9 + +orchid3 :: RGBi +orchid3 = RGBi 0xcd 0x69 0xc9 + +orchid4 :: RGBi +orchid4 = RGBi 0x8b 0x47 0x89 + +pale_green1 :: RGBi +pale_green1 = RGBi 0x9a 0xff 0x9a + +pale_green2 :: RGBi +pale_green2 = RGBi 0x90 0xee 0x90 + +pale_green3 :: RGBi +pale_green3 = RGBi 0x7c 0xcd 0x7c + +pale_green4 :: RGBi +pale_green4 = RGBi 0x54 0x8b 0x54 + +pale_turquoise1 :: RGBi +pale_turquoise1 = RGBi 0xbb 0xff 0xff + +pale_turquoise2 :: RGBi +pale_turquoise2 = RGBi 0xae 0xee 0xee + +pale_turquoise3 :: RGBi +pale_turquoise3 = RGBi 0x96 0xcd 0xcd + +pale_turquoise4 :: RGBi +pale_turquoise4 = RGBi 0x66 0x8b 0x8b + +pale_violet_red1 :: RGBi +pale_violet_red1 = RGBi 0xff 0x82 0xab + +pale_violet_red2 :: RGBi +pale_violet_red2 = RGBi 0xee 0x79 0x9f + +pale_violet_red3 :: RGBi +pale_violet_red3 = RGBi 0xcd 0x68 0x89 + +pale_violet_red4 :: RGBi +pale_violet_red4 = RGBi 0x8b 0x47 0x5d + +peach_puff1 :: RGBi +peach_puff1 = RGBi 0xff 0xda 0xb9 + +peach_puff2 :: RGBi +peach_puff2 = RGBi 0xee 0xcb 0xad + +peach_puff3 :: RGBi +peach_puff3 = RGBi 0xcd 0xaf 0x95 + +peach_puff4 :: RGBi +peach_puff4 = RGBi 0x8b 0x77 0x65 + +pink1 :: RGBi +pink1 = RGBi 0xff 0xb5 0xc5 + +pink2 :: RGBi +pink2 = RGBi 0xee 0xa9 0xb8 + +pink3 :: RGBi +pink3 = RGBi 0xcd 0x91 0x9e + +pink4 :: RGBi +pink4 = RGBi 0x8b 0x63 0x6c + +plum1 :: RGBi +plum1 = RGBi 0xff 0xbb 0xff + +plum2 :: RGBi +plum2 = RGBi 0xee 0xae 0xee + +plum3 :: RGBi +plum3 = RGBi 0xcd 0x96 0xcd + +plum4 :: RGBi +plum4 = RGBi 0x8b 0x66 0x8b + +purple1 :: RGBi +purple1 = RGBi 0x9b 0x30 0xff + +purple2 :: RGBi +purple2 = RGBi 0x91 0x2c 0xee + +purple3 :: RGBi +purple3 = RGBi 0x7d 0x26 0xcd + +purple4 :: RGBi +purple4 = RGBi 0x55 0x1a 0x8b + +red1 :: RGBi +red1 = RGBi 0xff 0x00 0x00 + +red2 :: RGBi +red2 = RGBi 0xee 0x00 0x00 + +red3 :: RGBi +red3 = RGBi 0xcd 0x00 0x00 + +red4 :: RGBi +red4 = RGBi 0x8b 0x00 0x00 + +rosy_brown1 :: RGBi +rosy_brown1 = RGBi 0xff 0xc1 0xc1 + +rosy_brown2 :: RGBi +rosy_brown2 = RGBi 0xee 0xb4 0xb4 + +rosy_brown3 :: RGBi +rosy_brown3 = RGBi 0xcd 0x9b 0x9b + +rosy_brown4 :: RGBi +rosy_brown4 = RGBi 0x8b 0x69 0x69 + +royal_blue1 :: RGBi +royal_blue1 = RGBi 0x48 0x76 0xff + +royal_blue2 :: RGBi +royal_blue2 = RGBi 0x43 0x6e 0xee + +royal_blue3 :: RGBi +royal_blue3 = RGBi 0x3a 0x5f 0xcd + +royal_blue4 :: RGBi +royal_blue4 = RGBi 0x27 0x40 0x8b + + +salmon1 :: RGBi +salmon1 = RGBi 0xff 0x8c 0x69 + +salmon2 :: RGBi +salmon2 = RGBi 0xee 0x82 0x62 + +salmon3 :: RGBi +salmon3 = RGBi 0xcd 0x70 0x54 + +salmon4 :: RGBi +salmon4 = RGBi 0x8b 0x4c 0x39 + +sea_green1 :: RGBi +sea_green1 = RGBi 0x54 0xff 0x9f + +sea_green2 :: RGBi +sea_green2 = RGBi 0x4e 0xee 0x94 + +sea_green3 :: RGBi +sea_green3 = RGBi 0x43 0xcd 0x80 + +sea_green4 :: RGBi +sea_green4 = RGBi 0x2e 0x8b 0x57 + +seashell1 :: RGBi +seashell1 = RGBi 0xff 0xf5 0xee + +seashell2 :: RGBi +seashell2 = RGBi 0xee 0xe5 0xde + +seashell3 :: RGBi +seashell3 = RGBi 0xcd 0xc5 0xbf + +seashell4 :: RGBi +seashell4 = RGBi 0x8b 0x86 0x82 + +sienna1 :: RGBi +sienna1 = RGBi 0xff 0x82 0x47 + +sienna2 :: RGBi +sienna2 = RGBi 0xee 0x79 0x42 + +sienna3 :: RGBi +sienna3 = RGBi 0xcd 0x68 0x39 + +sienna4 :: RGBi +sienna4 = RGBi 0x8b 0x47 0x26 + +sky_blue1 :: RGBi +sky_blue1 = RGBi 0x87 0xce 0xff + +sky_blue2 :: RGBi +sky_blue2 = RGBi 0x7e 0xc0 0xee + +sky_blue3 :: RGBi +sky_blue3 = RGBi 0x6c 0xa6 0xcd + +sky_blue4 :: RGBi +sky_blue4 = RGBi 0x4a 0x70 0x8b + +slate_blue1 :: RGBi +slate_blue1 = RGBi 0x83 0x6f 0xff + +slate_blue2 :: RGBi +slate_blue2 = RGBi 0x7a 0x67 0xee + +slate_blue3 :: RGBi +slate_blue3 = RGBi 0x69 0x59 0xcd + +slate_blue4 :: RGBi +slate_blue4 = RGBi 0x47 0x3c 0x8b + +slate_gray1 :: RGBi +slate_gray1 = RGBi 0xc6 0xe2 0xff + +slate_gray2 :: RGBi +slate_gray2 = RGBi 0xb9 0xd3 0xee + +slate_gray3 :: RGBi +slate_gray3 = RGBi 0x9f 0xb6 0xcd + +slate_gray4 :: RGBi +slate_gray4 = RGBi 0x6c 0x7b 0x8b + +snow1 :: RGBi +snow1 = RGBi 0xff 0xfa 0xfa + +snow2 :: RGBi +snow2 = RGBi 0xee 0xe9 0xe9 + +snow3 :: RGBi +snow3 = RGBi 0xcd 0xc9 0xc9 + +snow4 :: RGBi +snow4 = RGBi 0x8b 0x89 0x89 + +spring_green1 :: RGBi +spring_green1 = RGBi 0x00 0xff 0x7f + +spring_green2 :: RGBi +spring_green2 = RGBi 0x00 0xee 0x76 + +spring_green3 :: RGBi +spring_green3 = RGBi 0x00 0xcd 0x66 + +spring_green4 :: RGBi +spring_green4 = RGBi 0x00 0x8b 0x45 + +steel_blue1 :: RGBi +steel_blue1 = RGBi 0x63 0xb8 0xff + +steel_blue2 :: RGBi +steel_blue2 = RGBi 0x5c 0xac 0xee + +steel_blue3 :: RGBi +steel_blue3 = RGBi 0x4f 0x94 0xcd + +steel_blue4 :: RGBi +steel_blue4 = RGBi 0x36 0x64 0x8b + +tan1 :: RGBi +tan1 = RGBi 0xff 0xa5 0x4f + +tan2 :: RGBi +tan2 = RGBi 0xee 0x9a 0x49 + +tan3 :: RGBi +tan3 = RGBi 0xcd 0x85 0x3f + +tan4 :: RGBi +tan4 = RGBi 0x8b 0x5a 0x2b + +thistle1 :: RGBi +thistle1 = RGBi 0xff 0xe1 0xff + +thistle2 :: RGBi +thistle2 = RGBi 0xee 0xd2 0xee + +thistle3 :: RGBi +thistle3 = RGBi 0xcd 0xb5 0xcd + +thistle4 :: RGBi +thistle4 = RGBi 0x8b 0x7b 0x8b + +tomato1 :: RGBi +tomato1 = RGBi 0xff 0x63 0x47 + +tomato2 :: RGBi +tomato2 = RGBi 0xee 0x5c 0x42 + +tomato3 :: RGBi +tomato3 = RGBi 0xcd 0x4f 0x39 + +tomato4 :: RGBi +tomato4 = RGBi 0x8b 0x36 0x26 + +turquoise1 :: RGBi +turquoise1 = RGBi 0x00 0xf5 0xff + +turquoise2 :: RGBi +turquoise2 = RGBi 0x00 0xe5 0xee + +turquoise3 :: RGBi +turquoise3 = RGBi 0x00 0xc5 0xcd + +turquoise4 :: RGBi +turquoise4 = RGBi 0x00 0x86 0x8b + +violet_red1 :: RGBi +violet_red1 = RGBi 0xff 0x3e 0x96 + +violet_red2 :: RGBi +violet_red2 = RGBi 0xee 0x3a 0x8c + +violet_red3 :: RGBi +violet_red3 = RGBi 0xcd 0x32 0x78 + +violet_red4 :: RGBi +violet_red4 = RGBi 0x8b 0x22 0x52 + +wheat1 :: RGBi +wheat1 = RGBi 0xff 0xe7 0xba + +wheat2 :: RGBi +wheat2 = RGBi 0xee 0xd8 0xae + +wheat3 :: RGBi +wheat3 = RGBi 0xcd 0xba 0x96 + +wheat4 :: RGBi +wheat4 = RGBi 0x8b 0x7e 0x66 + +yellow1 :: RGBi +yellow1 = RGBi 0xff 0xff 0x00 + +yellow2 :: RGBi +yellow2 = RGBi 0xee 0xee 0x00 + +yellow3 :: RGBi +yellow3 = RGBi 0xcd 0xcd 0x00 + +yellow4 :: RGBi +yellow4 = RGBi 0x8b 0x8b 0x00 + + + + + + diff --git a/src/Wumpus/Drawing/Dots/AnchorDots.hs b/src/Wumpus/Drawing/Dots/AnchorDots.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Dots/AnchorDots.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Dots.AnchorDots +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Dots with anchors. +-- +-- In many cases a surrounding circle is used to locate anchor +-- points - this could be improved to use the actual dot border +-- at some point. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Dots.AnchorDots + ( + + -- * Existential anchor type + DotAnchor + + , DotLocImage + , DDotLocImage + + -- * Dots with anchor points + , dotChar + , dotText + , dotHLine + , dotVLine + , dotX + , dotPlus + , dotCross + , dotDiamond + , dotFDiamond + + , dotDisk + , dotSquare + , dotCircle + , dotPentagon + , dotStar + + , dotAsterisk + , dotOPlus + , dotOCross + , dotFOCross + + , dotTriangle + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Dots.Marks + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +import Control.Applicative + +-- An existential thing that supports anchors. +-- This means any dot can retun the same (opaque) structure +-- +-- But it does mean that which anchor class are supported is +-- fixed - the datatype needs a field for each one. +-- Supporting north, southeast etc. will also be tedious... +-- +data DotAnchor u = forall s. + DotAnchor { center_anchor :: Point2 u + , radial_anchor :: Radian -> Point2 u + , cardinal_anchor :: Cardinal -> Point2 u } + +data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW + deriving (Eq,Show) + +type instance DUnit (DotAnchor u) = u + +instance CenterAnchor (DotAnchor u) where + center (DotAnchor ca _ _) = ca + +instance RadialAnchor (DotAnchor u) where + radialAnchor theta (DotAnchor _ ra _) = ra theta + +instance CardinalAnchor (DotAnchor u) where + north (DotAnchor _ _ c1) = c1 NN + south (DotAnchor _ _ c1) = c1 SS + east (DotAnchor _ _ c1) = c1 EE + west (DotAnchor _ _ c1) = c1 WW + + + +instance CardinalAnchor2 (DotAnchor u) where + northeast (DotAnchor _ _ c1) = c1 NE + southeast (DotAnchor _ _ c1) = c1 SE + southwest (DotAnchor _ _ c1) = c1 SW + northwest (DotAnchor _ _ c1) = c1 NW + + +radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u +radialCardinal rad ctr NN = ctr .+^ (avec (pi/2) rad) +radialCardinal rad ctr NE = ctr .+^ (avec (pi/4) rad) +radialCardinal rad ctr EE = ctr .+^ (avec 0 rad) +radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) +radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) +radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) +radialCardinal rad ctr WW = ctr .+^ (avec pi rad) +radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) + + +-- Rectangle cardinal points are at \"middles and corners\". +-- + +rectCardinal :: Floating u => u -> u -> Point2 u -> Cardinal -> Point2 u +rectCardinal _ hh ctr NN = ctr .+^ (vvec hh) +rectCardinal hw hh ctr NE = ctr .+^ (vec hw hh) +rectCardinal hw _ ctr EE = ctr .+^ (hvec hw) +rectCardinal hw hh ctr SE = ctr .+^ (vec hw (-hh)) +rectCardinal _ hh ctr SS = ctr .+^ (vvec (-hh)) +rectCardinal hw hh ctr SW = ctr .+^ (vec (-hw) (-hh) ) +rectCardinal hw _ ctr WW = ctr .+^ (hvec (-hw)) +rectCardinal hw hh ctr NW = ctr .+^ (vec (-hw) hh) + +polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u +polyCardinal f NN = f (0.5 * pi) +polyCardinal f NE = f (0.25 * pi) +polyCardinal f EE = f 0 +polyCardinal f SE = f (1.75 * pi) +polyCardinal f SS = f (1.5 * pi) +polyCardinal f SW = f (1.25 * pi) +polyCardinal f WW = f pi +polyCardinal f NW = f (0.75 * pi) + + + +rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u +rectangleAnchor hw hh ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = fn + , cardinal_anchor = rectCardinal hw hh ctr } + where + fn theta = maybe ctr id $ findIntersect ctr theta + $ rectangleLines ctr hw hh + + +polygonAnchor :: (Real u, Floating 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 $ polygonLines ps + + + +bboxRectAnchor :: (Real u, Floating 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) + in rectangleAnchor hw hh (bl .+^ vec hw hh) + +rectangleLDO :: (Real u, Floating u) + => u -> u -> LocDrawingInfo u (DotAnchor u) +rectangleLDO w h = + promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt + + +circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u +circleAnchor rad ctr = DotAnchor ctr + (\theta -> ctr .+^ (avec theta rad)) + (radialCardinal rad ctr) + +circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u) +circleLDO = + promoteR1 $ \pt -> + markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt + + +-- This might be better taking a function: ctr -> poly_points +-- ... +-- +polygonLDO :: (Real u, Floating u, FromPtSize u) + => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u) +polygonLDO mk = + promoteR1 $ \ctr -> + markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr + + +-------------------------------------------------------------------------------- + +-- Is this more generally useful? +-- + + +type DotLocImage u = LocImage u (DotAnchor u) + +type DDotLocImage = DotLocImage Double + +dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u +dotChar ch = dotText [ch] + + +-- | Note - dotText now uses font metrics... +-- +dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u +dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss) + + +dotHLine :: (Floating u, FromPtSize u) => DotLocImage u +dotHLine = intoLocImage circleLDO markHLine + + +dotVLine :: (Floating u, FromPtSize u) => DotLocImage u +dotVLine = intoLocImage circleLDO markVLine + + +dotX :: (Floating u, FromPtSize u) => DotLocImage u +dotX = intoLocImage circleLDO markX + +dotPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotPlus = intoLocImage circleLDO markPlus + +dotCross :: (Floating u, FromPtSize u) => DotLocImage u +dotCross = intoLocImage circleLDO markCross + +dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotDiamond = intoLocImage circleLDO markDiamond + +dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotFDiamond = intoLocImage circleLDO markFDiamond + + + +dotDisk :: (Floating u, FromPtSize u) => DotLocImage u +dotDisk = intoLocImage circleLDO markDisk + + +dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u +dotSquare = + lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare + + + + +dotCircle :: (Floating u, FromPtSize u) => DotLocImage u +dotCircle = intoLocImage circleLDO markCircle + + +dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u +dotPentagon = intoLocImage circleLDO markPentagon + +dotStar :: (Floating u, FromPtSize u) => DotLocImage u +dotStar = intoLocImage circleLDO markStar + + +dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u +dotAsterisk = intoLocImage circleLDO markAsterisk + +dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotOPlus = intoLocImage circleLDO markOPlus + +dotOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotOCross = intoLocImage circleLDO markOCross + +dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotFOCross = intoLocImage circleLDO markFOCross + + +dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u +dotTriangle = intoLocImage (polygonLDO fn) markTriangle + where + fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top] diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Dots/Marks.hs @@ -0,0 +1,238 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Dots.Marks +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Marks - dots without anchor handles. +-- +-- The text and char marks need loaded glyph metrics for proper +-- centering. +-- +-- \*\* WARNING \*\* - names are expected to change - filled and +-- background-filled marks need a naming convention. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Dots.Marks + ( + + + -- * Marks + markChar + , markText + + , markHLine + , markVLine + , markX + , markPlus + , markCross + , markDiamond + , markFDiamond + , markBDiamond + , markDisk + , markSquare + , markCircle + , markPentagon + , markStar + , markAsterisk + , markOPlus + , markOCross + , markFOCross + , markTriangle + + ) where + + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Text.LRText + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative + +-- Marks should be the height of a lower-case letter... + +-- NOTES +-- +-- TikZ has both stroked and bordered (filled and outline-stroked) +-- marks e.g. square and square* +-- + + + + +infixr 9 `renderPathWith` + +renderPathWith :: LocDrawingInfo u (PrimPath u) + -> (PrimPath u -> Graphic u) + -> LocGraphic u +renderPathWith m k = m >>= (lift0R1 . k) + + + +markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u +markChar ch = markText [ch] + + + + +markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u +markText ss = fmap (replaceL uNil) $ ctrCenterLine ss + + + + +-- | Supplied point is the center. +-- +axialLine :: Fractional u => Vec2 u -> LocGraphic u +axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v) + + +markHLine :: (Fractional u, FromPtSize u) => LocGraphic u +markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h) + + +markVLine :: (Fractional u, FromPtSize u) => LocGraphic u +markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) + + +markX :: (Fractional u, FromPtSize u) => LocGraphic u +markX = lift0R1 markHeight >>= mkX + where + mkX h = let w = 0.75 * h + in axialLine (vec w h) `oplus` axialLine (vec (-w) h) + + + +markPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markPlus = markVLine `oplus` markHLine + + +markCross :: (Floating u, FromPtSize u) => LocGraphic u +markCross = markHeight >>= mkCross + where + mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h) + ang = pi*0.25 + +-- Note - height is extended slightly to look good... + +pathDiamond :: (Fractional u, FromPtSize u) + => LocDrawingInfo u (PrimPath u) +pathDiamond = + promoteR1 $ \pt -> + markHeight >>= \h -> pure $ diamondPath (0.5*h) (0.66*h) pt + + + +-- closedStroke :: (a -> ctx -> prim) +-- pathDiamond :: (ctx -> pt -> a) +-- ans :: (ctx -> pt -> prim) + +markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markDiamond = pathDiamond `renderPathWith` closedStroke + +markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markFDiamond = pathDiamond `renderPathWith` filledPath + + +-- Note - the (const . fn) composition doesn\'t /tell/ much about +-- what is going on - though obviously it can be decoded - make +-- the function obvious to the second argument. +-- +-- A named combinator might be better. +-- + +markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markBDiamond = pathDiamond `renderPathWith` borderedPath + + +-- | Note disk is filled. +-- +markDisk :: (Fractional u, FromPtSize u) => LocGraphic u +markDisk = lift0R1 markHalfHeight >>= filledDisk + + + +markSquare :: (Fractional u, FromPtSize u) => LocGraphic u +markSquare = + lift0R1 markHeight >>= \h -> + let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h + + + +markCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markCircle = lift0R1 markHalfHeight >>= strokedDisk + + +markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markBCircle = lift0R1 markHalfHeight >>= borderedDisk + + + +markPentagon :: (Floating u, FromPtSize u) => LocGraphic u +markPentagon = + promoteR1 $ \pt -> + markHeight >>= \h -> closedStroke $ vertexPath $ pentagonPath pt (0.5*h) + where + pentagonPath pt hh = polygonPoints 5 hh pt + + + + +markStar :: (Floating u, FromPtSize u) => LocGraphic u +markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h) + +starLines :: Floating u => u -> LocGraphic u +starLines hh = + promoteR1 $ \ctr -> step $ map (fn ctr) $ polygonPoints 5 hh ctr + where + fn p0 p1 = openStroke $ primPath p0 [lineTo p1] + step (x:xs) = oconcat x xs + step _ = error "starLines - unreachable" + + +markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u +markAsterisk = lift0R1 markHeight >>= asteriskLines + +asteriskLines :: Floating u => u -> LocGraphic u +asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3 + where + ang = (pi*2) / 6 + lineF1 = axialLine (vvec h) + lineF2 = axialLine (avec ((pi*0.5) + ang) h) + lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h) + + +markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markOPlus = markCircle `oplus` markPlus + + +markOCross :: (Floating u, FromPtSize u) => LocGraphic u +markOCross = markCircle `oplus` markCross + + +markFOCross :: (Floating u, FromPtSize u) => LocGraphic u +markFOCross = markCross `oplus` markBCircle + + +-- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u +-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) + + + +markTriangle :: (Floating u, FromPtSize u) => LocGraphic u +markTriangle = tripath `renderPathWith` closedStroke + where + tripath = promoteR1 $ \pt -> + markHeight >>= \h -> pure $ equilateralTrianglePath h pt + diff --git a/src/Wumpus/Drawing/Paths.hs b/src/Wumpus/Drawing/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim import module for Paths. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths + ( + + module Wumpus.Drawing.Paths.Base + , module Wumpus.Drawing.Paths.Connectors + , module Wumpus.Drawing.Paths.Construction + , module Wumpus.Drawing.Paths.ControlPoints + + ) where + +import Wumpus.Drawing.Paths.Base +import Wumpus.Drawing.Paths.Connectors +import Wumpus.Drawing.Paths.Construction +import Wumpus.Drawing.Paths.ControlPoints + diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base.hs @@ -0,0 +1,529 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Base +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Extended path type - more amenable for complex drawings than +-- the type in Wumpus-Core. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base + ( + + Path + , DPath + , length + , append + , pconcat + , line + , curve + , pivot + , traceLinePoints + , traceCurvePoints + , curveByAngles + + , toPrimPath + + , tipL + , tipR + + , shortenBoth + , shortenL + , shortenR + , directionL + , directionR + + , midway + , midway_ + , atstart + , atstart_ + , atend + , atend_ + + , PathViewL(..) + , DPathViewL + , PathViewR(..) + , DPathViewR + , PathSegment(..) + , DPathSegment + , pathViewL + , pathViewR + + ) where + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace +import Data.VectorSpace + +import Data.List ( foldl' ) +import Data.Sequence ( Seq, (><), ViewL(..), viewl + , ViewR(..), viewr, (<|) , (|>) ) +import qualified Data.Sequence as S + +import Prelude hiding ( length ) + +data Path u = Path { _path_length :: u + , _path_start :: Point2 u + , _path_elements :: Seq (PathSeg u) + , _path_end :: Point2 u + } + deriving (Eq,Ord,Show) + +type DPath = Path Double + +-- Annotating each segment with length is \*\* good \*\*. +-- Makes it much more efficient to find the midway point. +-- +-- But what do we do about the start point: +-- +-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path. +-- +-- b) leave it out - too little info in the type, allows +-- consistency problems with length. +-- +-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported. + +-- Annotation is length... +-- +data PathSeg u = LineSeg { _line_length :: u + , _line_start :: Point2 u + , _line_end :: Point2 u + } + | CurveSeg { _curve_length :: u + , _curve_start :: Point2 u + , _ctrl_pt_one :: Point2 u + , _ctrl_pt_two :: Point2 u + , _curve_end :: Point2 u + } + deriving (Eq,Ord,Show) + + +type instance DUnit (Path u) = u +type instance DUnit (PathSeg u) = u + + +infixr 1 `append` + +length :: Num u => Path u -> u +length (Path u _ _ _) = u + +append :: Floating u => Path u -> Path u -> Path u +append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) + | end1 == start2 = Path (len1+len2) start1 (se1 >< se2) end2 + | otherwise = let join = lineSegment end1 start2 + total_len = len1 + len2 + segmentLength join + in Path total_len start1 (se1 >< (join <| se2)) end2 + +pconcat :: Floating u => Path u -> [Path u] -> Path u +pconcat p0 ps = foldl' append p0 ps + +segmentLength :: PathSeg u -> u +segmentLength (LineSeg u _ _) = u +segmentLength (CurveSeg u _ _ _ _) = u + + +segmentStart :: PathSeg u -> Point2 u +segmentStart (LineSeg _ p0 _) = p0 +segmentStart (CurveSeg _ p0 _ _ _) = p0 + +segmentEnd :: PathSeg u -> Point2 u +segmentEnd (LineSeg _ _ p1) = p1 +segmentEnd (CurveSeg _ _ _ _ p3) = p3 + + + + +lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u +lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1 + +line :: Floating u => Point2 u -> Point2 u -> Path u +line p0 p1 = let v = vlength $ pvec p0 p1 + in Path v p0 (S.singleton $ LineSeg v p0 p1) p1 + + +curve :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u +curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3 + in Path v p0 (S.singleton $ CurveSeg v p0 p1 p2 p3) p3 + +-- | A draw a /straight line/ of length 0 at the supplied point. +-- +-- This is /might/ be useful in concatenating curved paths +-- as it introduces and extra control point. +-- +pivot :: Floating u => Point2 u -> Path u +pivot p0 = Path 0 p0 (S.singleton $ LineSeg 0 p0 p0) p0 + + +-- | 'traceLinePoints' throws a runtime error if the supplied list +-- is empty. +-- +traceLinePoints :: Floating u => [Point2 u] -> Path u +traceLinePoints [] = error "traceLinePoints - empty point list." +traceLinePoints [a] = line a a +traceLinePoints (a:b:xs) = step (line a b) b xs + where + step acc _ [] = acc + step acc e (y:ys) = step (acc `append` line e y) y ys + + +-- | 'traceCurvePoints' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter +-- (control1,control2, end). Leftover points are discarded. +-- +-- 'traceCurvePoints' throws a runtime error if the supplied list +-- is has less than 4 elements (start, control1, control2, end). +-- +traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u +traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs + where + step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs + step acc _ _ = acc + +traceCurvePoints _ = error "tracePointsCurve - less than 4 elems." + + +curveByAngles :: (Floating u, Ord u) + => Point2 u -> Radian -> Radian -> Point2 u -> Path u +curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end + where + sz = 0.375 * (vlength $ pvec start end) + v1 = avec cin sz + v2 = avec cout sz + + + +-- | Turn a Path into an ordinary PrimPath. +-- +-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next +-- segment. +-- +toPrimPath :: Num u => Path u -> PrimPath u +toPrimPath (Path _ _ segs _) = step1 $ viewl segs + where + step1 EmptyL = error "toPrimPath - (not) unreachable." + step1 (e :< se) = let (start,a) = seg1 e in + primPath start $ a : step2 (viewl se) + + step2 EmptyL = [] + step2 (e :< se) = seg2 e : step2 (viewl se) + + seg1 (LineSeg _ p0 p1) = (p0, lineTo p1) + seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3) + + seg2 (LineSeg _ _ p1) = lineTo p1 + seg2 (CurveSeg _ _ p1 p2 p3) = curveTo p1 p2 p3 + + + +-------------------------------------------------------------------------------- +-- Curve length + +data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u) + +curveLength :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u +curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3 + + +-- | Jens Gravesen\'s bezier arc-length approximation. +-- +-- Note this implementation is parametrized on error tolerance. +-- +gravesenLength :: (Floating u, Ord u) => u -> StrictCurve 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 + + +ctrlPolyLength :: Floating u => StrictCurve u -> u +ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3 + where + len pa pb = vlength $ pvec pa pb + +cordLength :: Floating u => StrictCurve u -> u +cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3 + + +-- | mid-point between two points +-- +pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u +pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0 + + +-- | Curve subdivision via de Casteljau\'s algorithm. +-- +subdivide :: Fractional u + => StrictCurve u -> (StrictCurve u, StrictCurve u) +subdivide (Curve p0 p1 p2 p3) = + (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) + where + p01 = pointMidpoint p0 p1 + p12 = pointMidpoint p1 p2 + p23 = pointMidpoint p2 p3 + p012 = pointMidpoint p01 p12 + p123 = pointMidpoint p12 p23 + p0123 = pointMidpoint p012 p123 + +-- | subdivide with an affine weight along the line... +-- +subdividet :: Real u + => u -> StrictCurve u -> (StrictCurve u, StrictCurve u) +subdividet t (Curve p0 p1 p2 p3) = + (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) + where + p01 = affineCombination t p0 p1 + p12 = affineCombination t p1 p2 + p23 = affineCombination t p2 p3 + p012 = affineCombination t p01 p12 + p123 = affineCombination t p12 p23 + p0123 = affineCombination t p012 p123 + +affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u +affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1) + +-------------------------------------------------------------------------------- +-- tips + +tipL :: Path u -> Point2 u +tipL (Path _ sp _ _) = sp + + +tipR :: Path u -> Point2 u +tipR (Path _ _ _ ep) = ep + + +-- | Shorten both ends... +-- +-- u should be less-than half the path length +-- +shortenBoth :: (Real u, Floating u) => u -> Path u -> Path u +shortenBoth u p = shortenL u $ shortenR u p + +-------------------------------------------------------------------------------- +-- shorten from the left... + +-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point. +-- +shortenL :: (Real u, Floating u) => u -> Path u -> Path u +shortenL n (Path u _ segs ep) + | n >= u = line ep ep + | otherwise = step n (viewl segs) + where + step _ EmptyL = line ep ep -- should be unreachable + step d (e :< se) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewl se) + EQ -> makeLeftPath (u-n) se ep + LT -> let e1 = shortenSegL d e + in Path (u-n) (segmentStart e1) (e1 <| se) ep + + +makeLeftPath :: Floating u => u -> Seq (PathSeg u) -> Point2 u -> Path u +makeLeftPath u se ep = + case viewl se of + EmptyL -> line ep ep + (e :< _) -> Path u (segmentStart e) se ep + + +shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u +shortenSegL n (LineSeg u p0 p1) = + LineSeg (u-n) (shortenLineL n p0 p1) p1 + +shortenSegL n (CurveSeg u p0 p1 p2 p3) = + let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3) + in CurveSeg (u-n) p0' p1' p2' p3' + + +shortenLineL :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineL n p0 p1 = p0 .+^ v + where + v0 = p1 .-. p0 + v = avec (direction v0) n + + + +-------------------------------------------------------------------------------- +-- shorten from the right ... + +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point. +-- +shortenR :: (Real u, Floating u) => u -> Path u -> Path u +shortenR n (Path u sp segs _) + | n >= u = line sp sp + | otherwise = step n (viewr segs) + where + step _ EmptyR = line sp sp -- should be unreachable + step d (se :> e) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewr se) + EQ -> makeRightPath n sp se + LT -> let e1 = shortenSegR d e + in Path (u-n) sp (se |> e1) (segmentEnd e1) + + +makeRightPath :: Floating u => u -> Point2 u -> Seq (PathSeg u) -> Path u +makeRightPath u sp se = + case viewr se of + EmptyR -> line sp sp + (_ :> e) -> Path u sp se (segmentEnd e) + + + +shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u +shortenSegR n (LineSeg u p0 p1) = + LineSeg (u-n) p0 (shortenLineR n p0 p1) + +shortenSegR n (CurveSeg u p0 p1 p2 p3) = + let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3) + in CurveSeg (u-n) p0' p1' p2' p3' + + +shortenLineR :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineR n p0 p1 = p1 .+^ v + where + v0 = p0 .-. p1 + v = avec (direction v0) n + + + + +-------------------------------------------------------------------------------- +-- line direction + +-- | Direction of empty path is considered to be 0. +-- +directionL :: (Real u, Floating u) => Path u -> Radian +directionL (Path _ _ se _) = step $ viewl se + where + step (LineSeg _ p0 p1 :< _) = lineDirection p1 p0 -- 1-to-0 + step (CurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0 + step _ = 0 -- should be unreachable + + +-- | Direction of empty path is considered to be 0. +-- +directionR :: (Real u, Floating u) => Path u -> Radian +directionR (Path _ _ se _) = step $ viewr se + where + step (_ :> LineSeg _ p0 p1) = lineDirection p0 p1 + step (_ :> CurveSeg _ _ _ p2 p3) = lineDirection p2 p3 + step _ = 0 -- should be unreachable + + + + +-------------------------------------------------------------------------------- + + +-- Return direction as well because the calculation is expensive... +-- +midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +midway pa@(Path u sp _ _) + | u == 0 = (sp,0) + | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) + +-- Just the midway point. +-- +midway_ :: (Real u, Floating u) => Path u -> Point2 u +midway_ = fst . midway + + +atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +atstart pa@(Path _ sp _ _) = (sp, directionL pa) + +atstart_ :: Path u -> Point2 u +atstart_ (Path _ sp _ _) = sp + + +atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +atend pa@(Path _ _ _ ep) = (ep, directionR pa) + + +atend_ :: Path u -> Point2 u +atend_ (Path _ _ _ ep) = ep + + +-- nearstart, nearend, verynear ... + + +-------------------------------------------------------------------------------- + +data PathViewL u = PathOneL (PathSegment u) + | PathSegment u :<< Path u + deriving (Eq,Ord,Show) + +type DPathViewL = PathViewL Double + +data PathViewR u = PathOneR (PathSegment u) + | Path u :>> PathSegment u + deriving (Eq,Ord,Show) + +type DPathViewR = PathViewR Double + + +data PathSegment u = Line1 (Point2 u) (Point2 u) + | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u) + deriving (Eq,Ord,Show) + +type DPathSegment = PathSegment Double + +type instance DUnit (PathViewL u) = u +type instance DUnit (PathViewR u) = u +type instance DUnit (PathSegment u) = u + +pathViewL :: Num u => Path u -> PathViewL u +pathViewL (Path u _ segs ep) = go (viewl segs) + where + go EmptyL = error "pathViewL - (not) unreachable." + + go (LineSeg v p0 p1 :< se) + | S.null se = PathOneL (Line1 p0 p1) + | otherwise = Line1 p0 p1 :<< Path (u-v) p1 se ep + + go (CurveSeg v p0 p1 p2 p3 :< se) + | S.null se = PathOneL (Curve1 p0 p1 p2 p3) + | otherwise = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep + + +pathViewR :: Num u => Path u -> PathViewR u +pathViewR (Path u _ segs ep) = go (viewr segs) + where + go EmptyR = error "pathViewR - (not) unreachable." + + go (se :> LineSeg v p0 p1) + | S.null se = PathOneR (Line1 p0 p1) + | otherwise = Path (u-v) p1 se ep :>> Line1 p0 p1 + + go (se :> CurveSeg v p0 p1 p2 p3) + | S.null se = PathOneR (Curve1 p0 p1 p2 p3) + | otherwise = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3 + diff --git a/src/Wumpus/Drawing/Paths/Connectors.hs b/src/Wumpus/Drawing/Paths/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Connectors.hs @@ -0,0 +1,206 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Connectors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Library of connector paths... +-- +-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Connectors + ( + + ConnectorPath + , DConnectorPath + + , connLine + + , connRightVH + , connRightHV + , connRightVHV + , connRightHVH + + , connIsosceles + , connIsosceles2 + , connLightningBolt + + + , connIsoscelesCurve + , connSquareCurve + , connUSquareCurve + + , connTrapezoidCurve + , connZSquareCurve + , connUZSquareCurve + + ) where + +import Wumpus.Drawing.Paths.Base +import Wumpus.Drawing.Paths.ControlPoints + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Prelude hiding ( length ) + + + +type ConnectorPath u = Point2 u -> Point2 u -> Path u + +type DConnectorPath = ConnectorPath Double + +-------------------------------------------------------------------------------- + +-- | Connect with a straight line. +-- +connLine :: Floating u => ConnectorPath u +connLine = line + +-- | Right-angled connector - go vertical, then go horizontal. +-- +connRightVH :: Floating u => ConnectorPath u +connRightVH p1@(P2 x1 _) p2@(P2 _ y2) = + let mid = P2 x1 y2 in traceLinePoints [p1, mid, p2] + +-- | Right-angled connector - go horizontal, then go vertical. +-- +connRightHV :: Floating u => ConnectorPath u +connRightHV p1@(P2 _ y1) p2@(P2 x2 _) = + let mid = P2 x2 y1 in traceLinePoints [p1, mid, p2] + +-- | Right-angled connector - go vertical for the supplied +-- distance, go horizontal, go vertical again for the +-- remaining distance. +-- +connRightVHV :: Floating u => u -> ConnectorPath u +connRightVHV v p1@(P2 x1 _) p2@(P2 x2 _) = traceLinePoints [p1, a1, a2, p2] + where + a1 = p1 .+^ vvec v + a2 = a1 .+^ hvec (x2 - x1) + + +-- | Right-angled connector - go horizontal for the supplied +-- distance, go verical, go horizontal again for the +-- remaining distance. +-- +connRightHVH :: Floating u => u -> ConnectorPath u +connRightHVH h p1@(P2 _ y1) p2@(P2 _ y2) = traceLinePoints [p1,a1,a2,p2] + where + a1 = p1 .+^ hvec h + a2 = a1 .+^ vvec (y2 - y1) + + +-- | /Triangular/ joint. +-- +-- @u@ is the altitude of the triangle. +-- +connIsosceles :: (Real u, Floating u) => u -> ConnectorPath u +connIsosceles dy p1 p2 = traceLinePoints [p1, mid_pt, p2] + where + mid_pt = midpointIsosceles dy p1 p2 + + + +-- | Double /triangular/ joint. +-- +-- @u@ is the altitude of the triangle. +-- +connIsosceles2 :: (Real u, Floating u) => u -> ConnectorPath u +connIsosceles2 u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ] + where + (cp1,cp2) = dblpointIsosceles u p1 p2 + + +-- | /Lightning bolt/ joint - a two joint connector with an /axis/ +-- perpendicular to the connector direction. +-- +-- @u@ is the half length of the of the axis. +-- +connLightningBolt :: (Real u, Floating u) => u -> ConnectorPath u +connLightningBolt u p1 p2 = traceLinePoints [ p1, cp1, cp2, p2 ] + where + cp1 = midpointIsosceles u p1 p2 + cp2 = midpointIsosceles (-u) p1 p2 + +-------------------------------------------------------------------------------- + + + +-- | Form a curve inside an isosceles triangle. +-- +-- The two Bezier control points take the same point - the +-- altitude of the triangle. The curve tends to be quite shallow +-- relative to the altitude. +-- +-- @u@ is the altitude of the triangle. +-- +connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u +connIsoscelesCurve u p1 p2 = traceCurvePoints [p1, control_pt, control_pt, p2] + where + control_pt = midpointIsosceles u p1 p2 + + + +-- | Form a curve inside a square. +-- +-- The two Bezier control points take the /top/ corners. The +-- curve tends to be very deep. +-- +connSquareCurve :: (Real u, Floating u) => ConnectorPath u +connSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] + where + (cp1,cp2) = squareFromBasePoints p1 p2 + +-- | Form a curve inside a square. +-- +-- As per 'connSquareCurve' but the curve is drawn /underneath/ +-- the line formed between the start and end points. +-- +-- (Underneath is modulo the direction, of course). +-- +connUSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUSquareCurve p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] + where + (cp1,cp2) = usquareFromBasePoints p1 p2 + + + +-- | altitude * ratio_to_base +-- +-- Form a curve inside a trapeziod. +-- +connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u +connTrapezoidCurve u ratio_to_base p1 p2 = traceCurvePoints [p1, cp1, cp2, p2] + where + (cp1,cp2) = trapezoidFromBasePoints u ratio_to_base p1 p2 + + +-- | Make a curve within a square, following the corner points as +-- a Z. +-- +connZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connZSquareCurve p1 p2 = traceCurvePoints [p1,cp1,cp2,p2] + where + (cp1,cp2) = squareFromCornerPoints p1 p2 + +-- | Make a curve within a square, following the corner points as +-- a Z. +-- +-- The order of tracing flips the control points, so this is an +-- /underneath/ version of 'connZSquareCurve'. +-- +connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUZSquareCurve p1 p2 = traceCurvePoints [p1,cp2,cp1,p2] + where + (cp1,cp2) = squareFromCornerPoints p1 p2 diff --git a/src/Wumpus/Drawing/Paths/Construction.hs b/src/Wumpus/Drawing/Paths/Construction.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Construction.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Construction +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Build paths monadically. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Construction + ( + + PathM + , runPath + , execPath + + , tip + + , lineto + , rlineto + , hline + , vline + + , bezierto + , curveto + + , verticalHorizontal + , horizontalVertical + + ) where + +import Wumpus.Basic.Utils.HList +import Wumpus.Drawing.Paths.Base + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative +import Data.List + + +-- Are connectors and paths quite different things? +-- +-- It looks like they are - connectors always know start and end +-- points. +-- + + +-- State monad version is quite good - it ameliorates the problem +-- of joining to the end point of an empty path... + +data St u = St + { current_point :: Point2 u + , path_acc :: H (Path u) + } + + +newtype PathM u a = PathM { getPathM :: St u -> (a,St u) } + + +instance Functor (PathM u) where + fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1) + + +instance Applicative (PathM u) where + pure a = PathM $ \s -> (a,s) + mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s + (a,s2) = getPathM ma s1 + in (f a,s2) + +instance Monad (PathM u) where + return a = PathM $ \s -> (a,s) + m >>= k = PathM $ \s -> let (a,s1) = getPathM m s in + (getPathM . k) a s1 + + + +-- Running the path is (probably) agnostic to the DrawingCtx. +-- +runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u) +runPath start mf = + let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s') + where + s = St { current_point = start + , path_acc = emptyH + } + post [] = line start start + post (x:xs) = foldl' append x xs + +execPath :: Floating u => Point2 u -> PathM u a -> Path u +execPath start mf = snd $ runPath start mf + +snocline :: Floating u => Vec2 u -> PathM u () +snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v + in ((), St ep (ac `snocH` line pt ep)) + + +tip :: PathM u (Point2 u) +tip = PathM $ \s -> (current_point s,s) + + +lineto :: Floating u => Point2 u -> PathM u () +lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt)) + +rlineto :: Floating u => Vec2 u -> PathM u () +rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) + + +hline :: Floating u => u -> PathM u () +hline len = snocline (hvec len) + +vline :: Floating u => u -> PathM u () +vline len = snocline (vvec len) + + + +bezierto :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> PathM u () +bezierto c1 c2 ep = PathM $ \(St p0 ac) -> + ((), St ep (ac `snocH` curve p0 c1 c2 ep)) + + + + + +-- + + +curveto :: (Floating u, Ord u) + => Radian -> Radian -> Point2 u -> PathM u () +curveto cin cout end = PathM $ \(St p0 ac) -> + let seg = curveByAngles p0 cin cout end + ac1 = ac `snocH` seg + end1 = tipR seg + in ((), St end1 ac1) + + + + +verticalHorizontal :: Floating u => Point2 u -> PathM u () +verticalHorizontal (P2 x y) = + tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y) + +horizontalVertical :: Floating u => Point2 u -> PathM u () +horizontalVertical (P2 x y) = + tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y) + diff --git a/src/Wumpus/Drawing/Paths/ControlPoints.hs b/src/Wumpus/Drawing/Paths/ControlPoints.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/ControlPoints.hs @@ -0,0 +1,189 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.ControlPoints +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Collection of point manufacturing functions. +-- +-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.ControlPoints + ( + + midpointIsosceles + , dblpointIsosceles + + , rectangleFromBasePoints + , squareFromBasePoints + , usquareFromBasePoints + + , trapezoidFromBasePoints + + , squareFromCornerPoints + + ) where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + + + +-- | 'midpointIsosceles' : +-- @ altitude * start_pt * end_pt -> mid_pt @ +-- +-- Triangular midpoint. +-- +-- @u@ is the altitude of the triangle - negative values of u +-- form the triangle below the line. +-- +midpointIsosceles :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = + mid_pt .+^ avec perp_ang u + where + mid_pt = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1)) + perp_ang = (pi*0.5) + direction (pvec p1 p2) + + + +-- | 'dblpointIsosceles' : +-- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @ +-- +-- Double triangular joint - one joint at a third of the line +-- length, the other at two thirds. +-- +dblpointIsosceles :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) +dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = + (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u) + where + mid1 = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1)) + mid2 = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1)) + perp_ang = (pi*0.5) + direction (pvec p1 p2) + + +-------------------------------------------------------------------------------- + + + +-- | 'rectangleFromBasePoints' : +-- @ altitude * start_pt * end_pt * (top_left, top_right) @ +-- +-- Control points forming a rectangle. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +rectangleFromBasePoints :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) +rectangleFromBasePoints u p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + theta = direction base_vec + cp1 = displacePerpendicular u theta p1 + cp2 = displacePerpendicular u theta p2 + + +-- | 'squareFromBasePoints' : +-- @ start_pt -> end_pt -> (top_left, top_right) @ +-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +squareFromBasePoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 + where + side_len = vlength $ pvec p1 p2 + + +-- | 'usquareFromBasePoints' : +-- @ start_pt -> end_pt -> (bottom_left, bottom_right) @ +-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points. +-- +-- As per 'squareFromBasePoints' but the square is drawn +-- /underneath/ the line formed between the start and end points. +-- (Underneath is modulo the direction, of course). +-- +-- The two manufactured control points form the /bottom/ corners, +-- so the supplied points map as @start_point == top_left@ and +-- @end_point == top_right@. +-- +usquareFromBasePoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 + where + side_len = negate $ vlength $ pvec p1 p2 + + + + + +-- | 'trapezoidFromBasePoints' : +-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @ +-- +-- Control points form an isosceles trapezoid. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +trapezoidFromBasePoints :: (Real u, Floating u) + => u -> u -> Point2 u -> Point2 u + -> (Point2 u, Point2 u) +trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + base_len = vlength base_vec + theta = direction base_vec + half_ulen = 0.5 * ratio_to_base * base_len + base_mid = displaceParallel (0.5 * base_len) theta p1 + ubase_mid = displacePerpendicular u theta base_mid + cp1 = displaceParallel (-half_ulen) theta ubase_mid + cp2 = displaceParallel half_ulen theta ubase_mid + + + + +-- | 'squareFromCornerPoints' : +-- @ altitude * start_pt * end_pt * (top_left, bottom_right) @ +-- +-- Control points forming a square bisected by the line from +-- start_pt to end_pt. +-- +-- The two manufactured control points form the top_left and +-- bottom_right corners, so the supplied points map as +-- @start_point == bottom_left@ and @end_point == top_right@. +-- +squareFromCornerPoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +squareFromCornerPoints p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + half_len = 0.5 * (vlength base_vec) + theta = direction base_vec + base_mid = displaceParallel half_len theta p1 + cp1 = displacePerpendicular half_len theta base_mid + cp2 = displacePerpendicular (-half_len) theta base_mid + diff --git a/src/Wumpus/Drawing/Paths/RoundCorners.hs b/src/Wumpus/Drawing/Paths/RoundCorners.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/RoundCorners.hs @@ -0,0 +1,120 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.RoundCorners +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Drawing round cornered polygons. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.RoundCorners + ( + cornerCurve + , illustratePath + , roundEvery + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths.Base hiding ( length ) + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +-- | The length of the control-point vector wants to be slighly +-- longer than half of /d/ (d - being the distance between the +-- /truncated/ points and the corner). +-- +cornerCurve :: (Real u, Floating u) + => Point2 u -> Point2 u -> Point2 u -> Path u +cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3 + where + len1 = 0.6 * (vlength $ pvec p1 p2) + len2 = 0.6 * (vlength $ pvec p3 p2) + cp1 = p1 .+^ (avec (langle p1 p2) len1) + cp2 = p3 .+^ (avec (langle p3 p2) len2) + + +-- | 'roundEvery' throws a runtime error if the input list has +-- less than 3 eleemnts. +-- +roundEvery :: (Real u, Floating u) + => u -> [Point2 u] -> Path u +roundEvery u (start:b:c:xs) = step (twoParts u start b c) (b:c:xs) + where + step acc (m:n:o:ps) = step (acc `append` twoParts u m n o) (n:o:ps) + step acc [n,o] = acc `append` twoParts u n o start + `append` twoParts u o start b + step acc _ = acc + +roundEvery _ _ = error "roundEvery - input list too short." + + +-- | Two parts - line and corner curve... +-- +twoParts :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u -> Path u +twoParts u a b c = line p1 p2 `append` cornerCurve p2 b p3 + where + p1 = a .+^ (avec (direction $ pvec a b) u) + p2 = b .+^ (avec (direction $ pvec b a) u) + p3 = b .+^ (avec (direction $ pvec b c) u) + + + +-------------------------------------------------------------------------------- +-- + +-- This needs moving outside of the Path modules as it has +-- dependencies on SVGColour and Graphic (the Path modules should +-- be /neutral/ to wards depenedencies on other parts of +-- Wumpus-Basic). +-- + +illustratePath :: Fractional u => Path u -> Graphic u +illustratePath = localize (strokeColour black) . step1 . pathViewL + where + step1 (PathOneL e) = drawPath1 e + step1 (e :<< se) = drawPathBoth e `oplus` rest (pathViewL se) + + rest (PathOneL e) = drawPath1 e + rest (e :<< se) = drawPath1 e `oplus` rest (pathViewL se) + +drawPathBoth :: Fractional u => PathSegment u -> Graphic u +drawPathBoth pa@(Line1 p1 _) = drawPath1 pa `oplus` pathPoint p1 +drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `oplus` pathPoint p1 + + + + +drawPath1 :: Fractional u => PathSegment u -> Graphic u +drawPath1 (Line1 p1 p2) = + straightLineBetween p1 p2 `oplus` pathPoint p2 + +drawPath1 (Curve1 p1 p2 p3 p4) = + oconcat (bezierCtrl p1 p2) [ bezierCtrl p4 p3, curveBetween p1 p2 p3 p4 + , pathPoint p4 ] + + +-- WARNING - This indicates that straightLineBetween is not +-- consistent with other prim graphics... + +bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u +bezierCtrl p1 p2 = localize (strokeColour light_steel_blue . fillColour red) $ + straightLineBetween p1 p2 `oplus` (filledDisk 1 `at` p2) + + +pathPoint :: Num u => Point2 u -> Graphic u +pathPoint pt = localize bothStrokeColour (filledDisk 1 `at` pt) + diff --git a/src/Wumpus/Drawing/Shapes.hs b/src/Wumpus/Drawing/Shapes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes.hs @@ -0,0 +1,27 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim module for Shapes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes + ( + module Wumpus.Drawing.Shapes.Base + , module Wumpus.Drawing.Shapes.Coordinate + , module Wumpus.Drawing.Shapes.Derived + + ) where + +import Wumpus.Drawing.Shapes.Base +import Wumpus.Drawing.Shapes.Coordinate +import Wumpus.Drawing.Shapes.Derived hiding ( mkRectangle ) diff --git a/src/Wumpus/Drawing/Shapes/Base.hs b/src/Wumpus/Drawing/Shapes/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Base.hs @@ -0,0 +1,227 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Base +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common core for shapes +-- +-- \*\* WARNING \*\* - the types of Shapes are not ideal and are +-- pending revision. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Base + ( + + + Shape + , LocShape + , makeShape + + , ShapeConstructor + + , borderedShape + , filledShape + , strokedShape + + -- * ShapeCTM + , ShapeCTM + , makeShapeCTM + + , ShapeGeom + , runShapeGeom + , askCTM + , projectPoint + , shapeCenter + , shapeAngle + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Paths + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + + +-- Currently shapes that aren\'t paths: +-- +-- > Coordinate +-- > FreeLabel +-- +-- Alternative +-- +-- > out_fun :: ShapeCTM u -> (Path u,sh) +-- +-- All shapes expect FreeLabel are oblivious to the +-- DrawingContext for the /shape/ +-- + +newtype ShapeR u a = ShapeR { getShapeR :: ShapeCTM u -> a } + +runShapeR :: ShapeCTM u -> ShapeR u a -> a +runShapeR ctm sf = getShapeR sf ctm + + +data Shape u t = Shape + { shape_ctm :: ShapeCTM u + , path_fun :: ShapeR u (Path u) + , cons_fun :: ShapeR u (t u) + } + +type instance DUnit (Shape u sh) = u + + +type LocShape u t = Point2 u -> Shape u t + +type ShapeConstructor u t = ShapeCTM u -> t u + + +makeShape :: Num u + => (ShapeCTM u -> Path u) -> (ShapeCTM u -> t u) -> LocShape u t +makeShape pf mkf = \pt -> Shape { shape_ctm = makeShapeCTM pt + , path_fun = ShapeR pf + , cons_fun = ShapeR mkf + } + + +shapeImage :: Num u => (PrimPath u -> Graphic u) -> Shape u t -> Image u (t u) +shapeImage drawF (Shape { shape_ctm = ctm, path_fun = pf, cons_fun = objf }) = + liftA2 fn (pure $ runShapeR ctm objf) + (drawF $ toPrimPath $ runShapeR ctm pf) + where + fn a (_,b) = (a,b) + +borderedShape :: Num u => Shape u t -> Image u (t u) +borderedShape = shapeImage borderedPath + +filledShape :: Num u => Shape u t -> Image u (t u) +filledShape = shapeImage filledPath + +strokedShape :: Num u => Shape u t -> Image u (t u) +strokedShape = shapeImage closedStroke + + + +instance (Real u, Floating u) => Rotate (Shape u sh) where + rotate r = updateCTM (rotate r) + +instance (Real u, Floating u) => RotateAbout (Shape u sh) where + rotateAbout r pt = updateCTM (rotateAbout r pt) + +instance Num u => Scale (Shape u sh) where + scale sx sy = updateCTM (scale sx sy) + +instance Num u => Translate (Shape u sh) where + translate dx dy = updateCTM (translate dx dy) + + +updateCTM :: (ShapeCTM u -> ShapeCTM u) -> Shape u sh -> Shape u sh +updateCTM fn (Shape ctm pf mkf) = Shape (fn ctm) pf mkf + +-------------------------------------------------------------------------------- +-- CTM + +-- Note - all shapes need a location (usually/always the center) +-- so this needs to be stored in the CTM. +-- + +data ShapeCTM u = ShapeCTM + { ctm_center :: Point2 u + , ctm_scale_x :: !u + , ctm_scale_y :: !u + , ctm_rotation :: Radian + } + deriving (Eq,Ord,Show) + + +type instance DUnit (ShapeCTM u) = u + +makeShapeCTM :: Num u => Point2 u -> ShapeCTM u +makeShapeCTM pt = ShapeCTM { ctm_center = pt + , ctm_scale_x = 1 + , ctm_scale_y = 1 + , ctm_rotation = 0 } + + + + + +instance Num u => Scale (ShapeCTM u) where + scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy }) + <*> ctm_scale_x <*> ctm_scale_y + + +instance Rotate (ShapeCTM u) where + rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang }) + <*> ctm_rotation + +instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where + rotateAbout ang pt = + (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang + , ctm_center = rotateAbout ang pt ctr }) + <*> ctm_center <*> ctm_rotation + + +instance Num u => Translate (ShapeCTM u) where + translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) }) + <*> ctm_center + + +-------------------------------------------------------------------------------- + +newtype ShapeGeom u a = ShapeGeom { getShapeGeom :: ShapeCTM u -> a } + + +type instance MonUnit (ShapeGeom u) = u + + +instance Functor (ShapeGeom u) where + fmap f ma = ShapeGeom $ \ctx -> let a = getShapeGeom ma ctx in f a + +instance Applicative (ShapeGeom u) where + pure a = ShapeGeom $ \_ -> a + mf <*> ma = ShapeGeom $ \ctx -> let f = getShapeGeom mf ctx + a = getShapeGeom ma ctx + in (f a) + +instance Monad (ShapeGeom u) where + return a = ShapeGeom $ \_ -> a + m >>= k = ShapeGeom $ \ctx -> let a = getShapeGeom m ctx + in (getShapeGeom . k) a ctx + + + +runShapeGeom :: ShapeCTM u -> ShapeGeom u a -> a +runShapeGeom ctm mf = getShapeGeom mf ctm + +askCTM :: ShapeGeom u (ShapeCTM u) +askCTM = ShapeGeom $ \ctm -> ctm + +shapeCenter :: ShapeGeom u (Point2 u) +shapeCenter = ShapeGeom $ \ctm -> ctm_center ctm + +shapeAngle :: ShapeGeom u Radian +shapeAngle = ShapeGeom $ \ctm -> ctm_rotation ctm + + + +projectPoint :: (Real u, Floating u) => Point2 u -> ShapeGeom u (Point2 u) +projectPoint (P2 x y) = ShapeGeom $ + \(ShapeCTM { ctm_center = (P2 dx dy) + , ctm_scale_x = sx + , ctm_scale_y = sy + , ctm_rotation = theta }) -> + translate dx dy $ rotate theta $ P2 (sx*x) (sy*y) + diff --git a/src/Wumpus/Drawing/Shapes/Coordinate.hs b/src/Wumpus/Drawing/Shapes/Coordinate.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Coordinate.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Coordinate +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- A Coordinate is operationally like a shape but it can only be +-- drawn as a dot or a cross and it only supports @CenterAnchor@. +-- +-- Coordinates support affine transformations, however +-- transfomations only displace a coordinate\'s origin they do +-- not change how it is drawn (one cannot elongate the drawing of +-- a coordinate with a scale). This is why coordinates are not +-- Shapes, though one major use of coordinates is to illustrate +-- anchor points on Shapes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Coordinate + ( + CoordinateAnchor + , DCoordinateAnchor + , Coordinate + , DCoordinate + , coordinate + + , coordinateDot + , coordinateX + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Control.Monad + +-- Note - a CoordinateAnchor should _NOT_ have affine instances. +-- +-- However, a coordinate supports affine transformations. This +-- follows the logic where Shapes transform but representations +-- of their anchors (i.e. the concrete types Rectangle, Circle...) +-- do not transform. +-- + + +-------------------------------------------------------------------------------- +-- | Coordinate + +newtype CoordinateAnchor u = CoordinateAnchor { getCoordAnchor :: ShapeCTM u } + deriving (Eq,Ord,Show) + +type DCoordinateAnchor = CoordinateAnchor Double + +type instance DUnit (CoordinateAnchor u) = u + +newtype Coordinate u = Coordinate { getCoordinate :: CoordinateAnchor u } + deriving (Eq,Ord,Show) + +type DCoordinate = Coordinate Double + +type instance DUnit (Coordinate u) = u + +type LocCoordinate u = Point2 u -> Coordinate u + + + +runCoordinate :: ShapeGeom u a -> CoordinateAnchor u -> a +runCoordinate mf a = runShapeGeom (getCoordAnchor a) mf + + +instance (Real u, Floating u) => CenterAnchor (CoordinateAnchor u) where + center = runCoordinate shapeCenter + +cMap :: (ShapeCTM u -> ShapeCTM u) -> Coordinate u -> Coordinate u +cMap fn = Coordinate . CoordinateAnchor . fn . getCoordAnchor . getCoordinate + + +-- Affine instances + +instance (Real u, Floating u) => Rotate (Coordinate u) where + rotate r = cMap (rotate r) + +instance (Real u, Floating u) => RotateAbout (Coordinate u) where + rotateAbout r pt = cMap (rotateAbout r pt) + +instance Num u => Scale (Coordinate u) where + scale sx sy = cMap (scale sx sy) + +instance Num u => Translate (Coordinate u) where + translate dx dy = cMap (translate dx dy) + + + +coordinate :: Num u => LocCoordinate u +coordinate = Coordinate . CoordinateAnchor . makeShapeCTM + + +coordinateDot :: (Real u, Floating u, FromPtSize u) + => Coordinate u -> Image u (CoordinateAnchor u) +coordinateDot x = liftA2 fn (return $ getCoordinate x) (drawDot x) + where + fn a (_,b) = (a,b) + + + +-- | Note - the @x@ is drawn /regardless/ of any scaling or rotation. +-- +coordinateX :: (Real u, Floating u, FromPtSize u) + => Coordinate u -> Image u (CoordinateAnchor u) +coordinateX x = liftA2 fn (return $ getCoordinate x) (drawX x) + where + fn a (_,b) = (a,b) + + + +quarterMarkHeight :: (Fractional u, FromPtSize u) => CF u +quarterMarkHeight = liftM (0.25*) markHeight + +drawDot :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u +drawDot coord = quarterMarkHeight >>= \qh -> + localize bothStrokeColour (filledEllipse qh qh `at` ctr) + where + ctr = center $ getCoordinate coord + +drawX :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u +drawX coord = quarterMarkHeight >>= \qh -> line1 qh `oplus` line2 qh + where + P2 x y = center $ getCoordinate coord + line1 h = straightLineBetween (P2 (x-h) (y-h)) (P2 (x+h) (y+h)) + line2 h = straightLineBetween (P2 (x+h) (y-h)) (P2 (x-h) (y+h)) + diff --git a/src/Wumpus/Drawing/Shapes/Derived.hs b/src/Wumpus/Drawing/Shapes/Derived.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Derived.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Derived +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Simple shapes - rectangle, circle diamond, ellipse. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Derived + ( + Rectangle + , DRectangle + , rectangle + , rrectangle + + , mkRectangle -- hidden in Shim module + + , Circle + , DCircle + , circle + + , Diamond + , DDiamond + , diamond + , rdiamond + + , Ellipse + , DEllipse + , ellipse + + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Paths.RoundCorners +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative + + +-- Note - Specific shapes - Rectangle, Circle, etc. - should _NOT_ +-- have affine instances. +-- +-- Transformations should only operate on the Shape type. Once a +-- Shape has been drawn the resultant Rectangle, Circle... cannot +-- be further transformed, as this would dis-associate the Anchors +-- from the Graphic. +-- + +-------------------------------------------------------------------------------- +-- Rectangle + +data Rectangle u = Rectangle + { rect_ctm :: ShapeCTM u + , rect_hw :: !u + , rect_hh :: !u + } + deriving (Eq,Ord,Show) + +type DRectangle = Rectangle Double + + +type instance DUnit (Rectangle u) = u + + +runRectangle :: (u -> u -> ShapeGeom u a) -> Rectangle u -> a +runRectangle mf (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = + runShapeGeom ctm $ mf hw hh + +instance (Real u, Floating u) => CenterAnchor (Rectangle u) where + center = runRectangle (\ _ _ -> shapeCenter) + + +instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where + north = runRectangle $ \_ hh -> projectPoint $ P2 0 hh + south = runRectangle $ \_ hh -> projectPoint $ P2 0 (-hh) + east = runRectangle $ \hw _ -> projectPoint $ P2 hw 0 + west = runRectangle $ \hw _ -> projectPoint $ P2 (-hw) 0 + +instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where + northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh + southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh) + southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh) + northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh + + +instance (Real u, Floating u) => RadialAnchor (Rectangle u) where + radialAnchor theta = runRectangle $ \hw hh -> + projectPoint $ rectangleIntersect hw hh theta + +-- Note - the answer needs projecting with the CTM... +-- +rectangleIntersect :: (Real u, Floating u) + => u -> u -> Radian -> Point2 u +rectangleIntersect hw hh theta = + maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh + + +-- | 'rectangle' : @ width * height -> shape @ +-- +rectangle :: (Real u, Floating u) => u -> u -> LocShape u Rectangle +rectangle w h = + makeShape (traceLinePoints . rectanglePoints (0.5*w) (0.5*h)) + (mkRectangle (0.5*w) (0.5*h)) + + +-- | 'rectangle' : @ round_length * width * height -> shape @ +-- +rrectangle :: (Real u, Floating u) => u -> u -> u -> LocShape u Rectangle +rrectangle round_dist w h = + makeShape (roundEvery round_dist . rectanglePoints (0.5*w) (0.5*h)) + (mkRectangle (0.5*w) (0.5*h)) + + + + +mkRectangle :: u -> u -> ShapeConstructor u Rectangle +mkRectangle hw hh = \ctm -> + Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh } + + + +rectanglePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] +rectanglePoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [se,ne,nw,sw] + where + se = P2 hw (-hh) + ne = P2 hw hh + nw = P2 (-hw) hh + sw = P2 (-hw) (-hh) + + + + + +-------------------------------------------------------------------------------- +-- Circle + +data Circle u = Circle + { circ_ctm :: ShapeCTM u + , circ_radius :: !u + } + deriving (Eq,Show) + +type DCircle = Circle Double + +type instance DUnit (Circle u) = u + +runCircle :: (u -> ShapeGeom u a) -> Circle u -> a +runCircle mf (Circle { circ_ctm =ctm, circ_radius = radius }) = + runShapeGeom ctm $ mf radius + + +instance (Real u, Floating u) => CenterAnchor (Circle u) where + center = runCircle (\_ -> shapeCenter) + + +instance (Real u, Floating u) => CardinalAnchor (Circle u) where + north = runCircle $ \r -> projectPoint $ P2 0 r + south = runCircle $ \r -> projectPoint $ P2 0 (-r) + east = runCircle $ \r -> projectPoint $ P2 r 0 + west = runCircle $ \r -> projectPoint $ P2 (-r) 0 + + +instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) + + +instance (Real u, Floating u) => RadialAnchor (Circle u) where + radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r + + + +-- | 'circle' : @ radius -> shape @ +-- +circle :: (Real u, Floating u) => u -> LocShape u Circle +circle radius = makeShape (traceCurvePoints . circlePoints radius) + (mkCircle radius) + + + +mkCircle :: u -> ShapeConstructor u Circle +mkCircle radius = \ctm -> Circle { circ_ctm = ctm, circ_radius = radius } + + +circlePoints :: (Real u, Floating u) => u -> ShapeCTM u -> [Point2 u] +circlePoints radius ctm = runShapeGeom ctm $ mapM projectPoint all_points + where + all_points = bezierCircle 2 radius zeroPt + + + +-------------------------------------------------------------------------------- +-- Diamond + + +data Diamond u = Diamond + { dia_ctm :: ShapeCTM u + , dia_hw :: !u + , dia_hh :: !u + } + +type DDiamond = Diamond Double + +type instance DUnit (Diamond u) = u + + + +runDiamond :: (u -> u -> ShapeGeom u a) -> Diamond u -> a +runDiamond mf (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = + runShapeGeom ctm $ mf hw hh + + +instance (Real u, Floating u) => CenterAnchor (Diamond u) where + center = runDiamond (\_ _ -> shapeCenter) + +instance (Real u, Floating u) => CardinalAnchor (Diamond u) where + north = runDiamond $ \_ hh -> projectPoint $ P2 0 hh + south = runDiamond $ \_ hh -> projectPoint $ P2 0 (-hh) + east = runDiamond $ \hw _ -> projectPoint $ P2 hw 0 + west = runDiamond $ \hw _ -> projectPoint $ P2 (-hw) 0 + +instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where + northeast x = midpoint (north x) (east x) + southeast x = midpoint (south x) (east x) + southwest x = midpoint (south x) (west x) + northwest x = midpoint (north x) (west x) + + + +instance (Real u, Floating u) => RadialAnchor (Diamond u) where + radialAnchor = diamondIntersect + +-- Utils.Intersection needs improving... + + +diamondIntersect :: (Real u, Floating u) + => Radian -> Diamond u -> Point2 u +diamondIntersect theta = runDiamond $ \hw hh -> + (\ctr ctm -> let ps = diamondPoints hw hh ctm + in maybe ctr id $ findIntersect ctr theta $ polygonLines ps) + <$> shapeCenter <*> askCTM + + +midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u +midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v + +-- | 'diamond' : @ half_width * half_height -> shape @ +-- +-- Note - args might change to tull_width and full_height... +-- +diamond :: (Real u, Floating u) => u -> u -> LocShape u Diamond +diamond hw hh = + makeShape (traceLinePoints . diamondPoints hw hh) + (mkDiamond hw hh) + + +-- | 'rdiamond' : @ round_length * half_width * half_height -> shape @ +-- +-- Note - args might change to full_width and full_height... +-- +rdiamond :: (Real u, Floating u) => u -> u -> u -> LocShape u Diamond +rdiamond round_dist hw hh = + makeShape (roundEvery round_dist . diamondPoints hw hh) + (mkDiamond hw hh) + + + + + +mkDiamond :: (Real u, Floating u) => u -> u -> ShapeConstructor u Diamond +mkDiamond hw hh = \ctm -> Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh } + + +diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] +diamondPoints hw hh ctm = runShapeGeom ctm $ mapM projectPoint [ s, e, n, w ] + where + s = P2 0 (-hh) + e = P2 hw 0 + n = P2 0 hh + w = P2 (-hw) 0 + + +-------------------------------------------------------------------------------- +-- Ellipse + + +data Ellipse u = Ellipse + { ell_ctm :: ShapeCTM u + , ell_rx :: !u + , ell_ry :: !u + } + +type DEllipse = Ellipse Double + +type instance DUnit (Ellipse u) = u + + +runEllipse :: (u -> u -> ShapeGeom u a) -> Ellipse u -> a +runEllipse mf (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = + runShapeGeom ctm $ mf rx ry + + +-- | x_radius is the unit length. +-- +scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t +scaleEll rx ry = scale 1 (ry/rx) + + +instance (Real u, Floating u) => CenterAnchor (Ellipse u) where + center = runEllipse $ \_ _ -> shapeCenter + + +instance (Real u, Floating u) => RadialAnchor (Ellipse u) where + radialAnchor theta = runEllipse $ \rx ry -> + projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx + + +instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where + north = radialAnchor (0.5*pi) + south = radialAnchor (1.5*pi) + east = radialAnchor 0 + west = radialAnchor pi + + +instance (Real u, Floating u) => CardinalAnchor2 (Ellipse u) where + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) + + +-- | 'ellipse' : @ x_radii * y_radii -> shape @ +-- +ellipse :: (Real u, Floating u) => u -> u -> LocShape u Ellipse +ellipse rx ry = + makeShape (traceCurvePoints . ellipsePoints rx ry) + (mkEllipse rx ry) + + +mkEllipse :: (Real u, Floating u) => u -> u -> ShapeConstructor u Ellipse +mkEllipse rx ry = \ctm -> Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry } + + +ellipsePoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] +ellipsePoints rx ry ctm = + runShapeGeom ctm $ mapM (projectPoint . scaleEll rx ry) all_points + where + all_points = bezierCircle 2 rx zeroPt + + + diff --git a/src/Wumpus/Drawing/Text/LRText.hs b/src/Wumpus/Drawing/Text/LRText.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/LRText.hs @@ -0,0 +1,399 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.LRText +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Left-to-right measured text. The text uses glyph metrics so it +-- can be positioned accurately. +-- +-- \*\* WARNING \*\* - the API for this module has not been +-- decided. The function names are expected to change. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.LRText + ( + + baseCenterLine + , baseLeftLine + , baseRightLine + + , rbaseCenterLine + , rbaseLeftLine + , rbaseRightLine + + , ctrCenterLine + , baseCenterEscChar + + , multiAlignLeft + , multiAlignCenter + , multiAlignRight + + , rmultiAlignLeft + , rmultiAlignCenter + , rmultiAlignRight + + + ) where + + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.Char +import qualified Data.Map as Map +import Data.Maybe + + +-- Note - BoundedLocThetaGraphic is probably an adequate type +-- even though the same text will have a different bounding box +-- if it is rotated (the sides of the BBox are always parallel to +-- the x and y axes even if the text is not parrale to the +-- x-axis). +-- +-- I cannot think of any compelling graphics that need a more +-- accurate type. The execption is text cannot have exact anchors +-- however this is a moot /if/ text is considered as a labelling +-- of an existing rectangle (which may or may not have been +-- rotated). +-- + + + +-- One line of multiline text +-- +data OnelineText u = OnelineText EscapedText (AdvanceVec u) + + +-- | max_width * oneline_text -> LocThetaGraphic +-- +type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u + + +-- | max_width * oneline_text -> LocThetaGraphic +-- +type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u + + +-- | Draw one line of left-aligned text, knowing the max_width +-- of all the lines of text. +-- +-- All left-aligned text is moved left by half the max_width. +-- +-- Note - implicit point is baseline-center, this is perhaps +-- unintituitive given the functions name but it is an +-- advantage for drawing multi-line text. +-- +drawLeftAligned :: Floating u => LocThetaDrawOneline u +drawLeftAligned max_width (OnelineText esc _) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel ((-0.5) * max_width) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + + +-- | Draw one line of center-aligned text. Center aligned text is +-- oblivious to the max_width of all the lines of text. +-- +-- Each line of center-aligned text is moved left by half its +-- advance vector. +-- +-- Implicit point is baseline-center. +-- +drawCenterAligned :: Floating u => LocThetaDrawOneline u +drawCenterAligned _ (OnelineText esc av) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel (negate $ 0.5 * advanceH av) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + +-- | Draw one line of right-aligned text, knowing the max_width +-- of all the lines of text. +-- +-- Each right-aligned text line is moved by the width component +-- of the advance vector minus half the max width. +-- +-- Note - implicit point is baseline-center, this is perhaps +-- unintituitive given the functions name but it is an +-- advantage for drawing multi-line text. +-- +drawRightAligned :: Floating u => LocThetaDrawOneline u +drawRightAligned max_width (OnelineText esc av) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel ((0.5 * max_width) - advanceH av) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + + + +-- Impilict point is baseline-center. +-- +onelineBBox :: (Real u, Floating u, FromPtSize u) + => OnelineText u -> LocThetaDrawingInfo u (BoundingBox u) +onelineBBox (OnelineText _ av) = + promoteR2 $ \baseline_ctr theta -> + glyphHeightRange >>= \(ymin, ymax) -> + let hw = 0.5 * advanceH av + bl = baseline_ctr .+^ vec (-hw) ymin + tr = baseline_ctr .+^ vec hw ymax + in pure $ centerOrthoBBox theta (BBox bl tr) + + + + + +-- This should have max_width as a param... +-- +makeMoveableLine :: (Real u, Floating u, FromPtSize u) + => LocThetaDrawOneline u + -> BoundedLocThetaOneline u +makeMoveableLine drawF max_width oline = + intoLocThetaImage (onelineBBox oline) (drawF max_width oline) + +onelineAlg :: (Real u, Floating u, FromPtSize u) + => DisplaceFun u + -> LocThetaDrawOneline u + -> EscapedText + -> BoundedLocThetaGraphic u +onelineAlg ptMoveF drawF esc = + promoteR2 $ \pt theta -> + onelineEscText esc >>= \ans@(OnelineText _ av) -> + let max_width = advanceH av + move = ptMoveF max_width ans theta + in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta + + + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-left. +-- + +baseLeftLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseLeftLine ss = rbaseLeftLine ss `rot` 0 + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-center. +-- +baseCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseCenterLine ss = rbaseCenterLine ss `rot` 0 + + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-right. +-- +baseRightLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseRightLine ss = rbaseRightLine ss `rot` 0 + + + +rbaseLeftLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseLeftLine ss = + onelineAlg leftToCenter drawLeftAligned (escapeString ss) + + +rbaseCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseCenterLine ss = + onelineAlg centerToCenter drawCenterAligned (escapeString ss) + + +rbaseRightLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseRightLine ss = + onelineAlg rightToCenter drawRightAligned (escapeString ss) + + +-- Note - assumes the ymin of the font is 0 or less. +-- +ctrCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +ctrCenterLine ss = + glyphHeightRange >>= \(ymin, ymax) -> + let hh = 0.5 * ymax - ymin in + moveStartPoint (displaceV $ negate $ hh - abs ymin) $ baseCenterLine ss + + + +baseCenterEscChar :: (Real u, Floating u, FromPtSize u) + => EscapedChar -> BoundedLocGraphic u +baseCenterEscChar esc = body `rot` 0 + where + body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc) + + + + + + +-- | max_width * interim_text * theta -> (Point -> Point) +-- +type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u + +centerToCenter :: DisplaceFun u +centerToCenter _ _ _ = id + +leftToCenter :: Floating u => DisplaceFun u +leftToCenter max_width _ theta = + displaceParallel (0.5 * max_width) theta + +rightToCenter :: Floating u => DisplaceFun u +rightToCenter max_width (OnelineText _ av) theta = + displaceParallel ((0.5 * max_width) - advanceH av) theta + + + + +multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignLeft ss = rmultiAlignLeft ss `rot` 0 + + +multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignCenter ss = rmultiAlignCenter ss `rot` 0 + + + + +multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignRight ss = rmultiAlignRight ss `rot` 0 + + +rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned) + + +rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned) + + +rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned) + + + +multilineTEXT :: (Floating u, Ord u, FromPtSize u) + => BoundedLocThetaOneline u + -> String + -> BoundedLocThetaGraphic u +multilineTEXT _ [] = lift1R2 emptyBoundedLocGraphic +multilineTEXT mf ss = + lift0R2 (linesToInterims ss) >>= \(max_av, itexts) -> + centralPoints (length itexts) >>= \pts -> + zipMultis (advanceH max_av) mf itexts pts + + + + +zipMultis :: (Ord u, FromPtSize u) + => u + -> BoundedLocThetaOneline u + -> [OnelineText u] -> [Point2 u] + -> BoundedLocThetaGraphic u +zipMultis _ _ [] _ = lift1R2 $ emptyBoundedLocGraphic +zipMultis _ _ _ [] = lift1R2 $ emptyBoundedLocGraphic +zipMultis max_w mf (a:as) (b:bs) = step a b as bs + where + mkGraphic itext pt = promoteR2 $ \_ theta -> + apply2R2 (mf max_w itext) pt theta + step r s (r2:rs) (s2:ss) = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss) + step r s _ _ = mkGraphic r s + + + + +-- | @ana@ is an /anacrusis/ factor - if there are even points +-- half the baseline_spacing is added to get the top point +-- +centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u] +centralPoints n | n < 2 = promoteR2 $ \ctr _ -> return [ctr] + | even n = body (n `div` 2) (0.5*) + | otherwise = body (n `div` 2) (0 *) + where + body halfn ana = promoteR2 $ \ctr theta -> + baselineSpacing >>= \h -> + let y0 = (h * fromIntegral halfn) + ana h + top = displacePerpendicular y0 theta ctr + in pure $ trailPoints n h theta top + + + +trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u] +trailPoints n height theta top = take n $ iterate fn top + where + fn pt = displacePerpendicular (-height) theta pt + + + +-------------------------------------------------------------------------------- + +-- This isn't worth the complexity to get down to one traversal... + +linesToInterims :: (FromPtSize u, Ord u) + => String -> DrawingInfo (AdvanceVec u, [OnelineText u]) +linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines + where + post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs) + fn (OnelineText _ av) vmax = avMaxWidth av vmax + +avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u +avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a + +onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u) +onelineEscText esc = fmap (OnelineText esc) $ textVector esc + + + +textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u) +textVector esc = + cwLookupTable >>= \table -> + let cs = destrEscapedText id esc + in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs + + + + +charWidth :: FromPtSize u + => CharWidthTable u -> EscapedChar -> AdvanceVec u +charWidth fn (CharLiteral c) = fn $ ord c +charWidth fn (CharEscInt i) = fn i +charWidth fn (CharEscName s) = fn ix + where + ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices diff --git a/src/Wumpus/Drawing/Text/SafeFonts.hs b/src/Wumpus/Drawing/Text/SafeFonts.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/SafeFonts.hs @@ -0,0 +1,167 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.SafeFonts +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Safe to use \"Core 13\" fonts that are expected to be present +-- for any PostScript interpreter. +-- +-- Note - regrettably Symbol is not safe to use for SVG. +-- +-- \*\* WARNING \*\* - this module is in flux due to changes to +-- Text encoding in Wumpus-Core and adding font metrics to +-- Wumpus-Basic. The code here is likely to be revised. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.SafeFonts + ( + -- * Times Roman + times_roman + , times_italic + , times_bold + , times_bold_italic + + -- * Helvetica + , helvetica + , helvetica_oblique + , helvetica_bold + , helvetica_bold_oblique + + -- * Courier + , courier + , courier_oblique + , courier_bold + , courier_bold_oblique + + -- * Symbol + , symbol + + ) where + + + +import Wumpus.Core +import Wumpus.Core.Text.StandardEncoding +import Wumpus.Core.Text.Symbol + +-- Supported fonts are: +-- +-- Times-Roman Times-Italic Times-Bold Times-BoldItalic +-- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique +-- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique +-- Symbol + +-------------------------------------------------------------------------------- +-- + +-- | Times-Roman +-- +times_roman :: FontFace +times_roman = + FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding + +-- | Times Italic +-- +times_italic :: FontFace +times_italic = + FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding + +-- | Times Bold +-- +times_bold :: FontFace +times_bold = + FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding + +-- | Times Bold Italic +-- +times_bold_italic :: FontFace +times_bold_italic = FontFace "Times-BoldItalic" + "Times New Roman" + SVG_BOLD_ITALIC + standard_encoding + + +-------------------------------------------------------------------------------- +-- Helvetica + +-- | Helvetica +-- +helvetica :: FontFace +helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding + + +-- | Helvetica Oblique +-- +helvetica_oblique :: FontFace +helvetica_oblique = + FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding + +-- | Helvetica Bold +-- +helvetica_bold :: FontFace +helvetica_bold = + FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding + + +-- | Helvetica Bold Oblique +-- +helvetica_bold_oblique :: FontFace +helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" + "Helvetica" + SVG_BOLD_OBLIQUE + standard_encoding + + + +-------------------------------------------------------------------------------- + +-- | Courier +-- +courier :: FontFace +courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding + +-- | Courier Oblique +-- +courier_oblique :: FontFace +courier_oblique = + FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding + +-- | Courier Bold +-- +courier_bold :: FontFace +courier_bold = + FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding + + +-- | Courier Bold Oblique +-- +courier_bold_oblique :: FontFace +courier_bold_oblique = FontFace "Courier-Bold-Oblique" + "Courier New" + SVG_BOLD_OBLIQUE + standard_encoding + +-------------------------------------------------------------------------------- +-- Symbol + +-- | Symbol +-- +-- Note - Symbol is intentionally not supported for SVG by some +-- renderers (Firefox). Chrome is fine, but the use of symbol +-- should be still be avoided for web graphics. +-- +symbol :: FontFace +symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding + + + + + diff --git a/src/Wumpus/Drawing/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Turtle/TurtleClass.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Turtle/TurtleClass.hs @@ -0,0 +1,91 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Turtle.TurtleClass +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Turtle monad and monad transformer. +-- +-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor. +-- +-- While Wumpus generally aims for a more compositional, +-- \"coordinate-free\" style of drawing, some types of diagram +-- are more easily expressed in the LOGO style. +-- +-- Note - as turtle drawing with Wumpus is a /local effect/, +-- there is only one instance of TurtleM. Potentially TurtleM +-- will be removed and the functions implemented directly. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Turtle.TurtleClass + ( + + Coord + + , TurtleM(..) + + , setsLoc + , setsLoc_ + + -- * movement + , resetLoc + , moveLeft + , moveRight + , moveUp + , moveDown + , nextLine + + + ) where + + + +type Coord = (Int,Int) + + +class Monad m => TurtleM m where + getLoc :: m (Int,Int) + setLoc :: (Int,Int) -> m () + getOrigin :: m (Int,Int) + setOrigin :: (Int,Int) -> m () + + + +setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a +setsLoc f = getLoc >>= \coord -> + let (a,coord') = f coord in setLoc coord' >> return a + +setsLoc_ :: TurtleM m => (Coord -> Coord) -> m () +setsLoc_ f = getLoc >>= \coord -> setLoc (f coord) + + +resetLoc :: TurtleM m => m () +resetLoc = getOrigin >>= setLoc + + +moveRight :: TurtleM m => m () +moveRight = setsLoc_ $ \(x,y)-> (x+1, y) + + +moveLeft :: TurtleM m => m () +moveLeft = setsLoc_ $ \(x,y) -> (x-1,y) + +moveUp :: TurtleM m => m () +moveUp = setsLoc_ $ \(x,y) -> (x,y+1) + +moveDown :: TurtleM m => m () +moveDown = setsLoc_ $ \(x,y) -> (x ,y-1) + + +nextLine :: TurtleM m => m () +nextLine = getOrigin >>= \(ox,_) -> + setsLoc_ $ \(_,y) -> (ox,y-1) + diff --git a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Turtle.TurtleMonad +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Turtle monad transformer. +-- +-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor. +-- +-- While Wumpus generally aims for a more compositional, +-- \"coordinate-free\" style of drawing, some types of +-- diagram are more easily expressed in the LOGO style. +-- +-- Turtle is only a transformer - it is intended to be run within +-- a 'Drawing'. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Turtle.TurtleMonad + ( + -- * Re-exports + module Wumpus.Drawing.Turtle.TurtleClass + + -- * Turtle transformer + , TurtleT + , runTurtleT + + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Turtle.TurtleClass + + + +import Control.Applicative +import Control.Monad + + +-- Note - if Turtle is now just a /local effect/ monad is the +-- Turtle class still needed? Afterall, there is (probably) +-- only ever going to be one instance. +-- + +-- Turtle is a Reader / State monad +-- +-- The env is the horizontal and vertical move distances. +-- +-- The state is the current coordinate and the origin. +-- + +data TurtleState = TurtleState + { _turtle_origin :: (Int,Int) + , _current_coord :: (Int,Int) + } + +type TurtleScalingT u m a = ScalingT Int Int u m a + +newtype TurtleT u m a = TurtleT { + getTurtleT :: TurtleState -> TurtleScalingT u m (a, TurtleState) } + +type instance MonUnit (TurtleT u m) = u + + + +-- Functor + + + +instance Monad m => Functor (TurtleT u m) where + fmap f m = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> + return (f a, s') + + +-- Applicative + +instance Monad m => Applicative (TurtleT u m) where + pure a = TurtleT $ \s -> return (a,s) + mf <*> ma = TurtleT $ \s -> getTurtleT mf s >>= \(f,s') -> + getTurtleT ma s' >>= \(a,s'') -> + return (f a,s'') + + +-- Monad + +instance Monad m => Monad (TurtleT u m) where + return a = TurtleT $ \s -> return (a,s) + m >>= k = TurtleT $ \s -> getTurtleT m s >>= \(a,s') -> + (getTurtleT . k) a s' >>= \(b,s'') -> + return (b,s'') + + + + +instance Monad m => TurtleM (TurtleT u m) where + getLoc = TurtleT $ \s@(TurtleState _ c) -> return (c,s) + setLoc c = TurtleT $ \(TurtleState o _) -> return ((),TurtleState o c) + getOrigin = TurtleT $ \s@(TurtleState o _) -> return (o,s) + setOrigin o = TurtleT $ \(TurtleState _ c) -> return ((),TurtleState o c) + + +runTurtleT :: (Monad m, Num u) + => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a +runTurtleT ogin cfg mf = + runScalingT cfg (getTurtleT mf st0) >>= \(a,_) -> return a + where + st0 = TurtleState ogin ogin + + + +---------------------------------------------------------------------------------- +-- Cross instances + +instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where + askDC = TurtleT $ \s -> askDC >>= \ ctx -> return (ctx,s) + localize upd mf = TurtleT $ \s -> localize upd (getTurtleT mf s) + + +-- This needs undecidable instances... + +instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where + trace a = TurtleT $ \s -> trace a >> return ((),s) + + +instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where + position = TurtleT $ \s@(TurtleState _ (x,y)) -> scalePt x y >>= \pt -> return (pt,s) + diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal --- a/wumpus-basic.cabal +++ b/wumpus-basic.cabal @@ -1,5 +1,5 @@ name: wumpus-basic -version: 0.13.0 +version: 0.14.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -15,13 +15,16 @@ and more experimental (unfortunately the only thing consistent about the API is that it consistently changes...). . - Version 0.13.0 significantly differs form the previous release - as font metrics support has been added and the core graphic - types have been redesigned. With these re-workings some modules - that were previously fairly stable have changed substantially or - are likely to change soon (@Basic.PictureLanguage@ has become - @Basic.DrawingComposition@; @Basic.SafeFonts@ no longer seems - very /SVG safe/ so it is marked as pending change). + Version 0.14.0 breaks up Wumpus-Basic into two /layers/ - + @Wumpus.Basic@ for core data types, general utilities and + /System/ utilities (currently only font loading); the other + layer, @Wumpus.Drawing@, is for for specific drawing + \"objects\" - arrowheads, dots, and the like. The APIs of the + @Drawing@ modules have not been given much attention as the + underlying graphic types have changed, they are due for + substantial revision. This includes modules that were previously + considered fairly stable such as the @Basic.SafeFonts@ module + which no longer seems very /SVG safe/. . NOTE - many of the demos now use font metrics. Font metrics for the \"Core 14\" PostScript fonts are distributed as @*.afm@ @@ -38,17 +41,37 @@ Core 14 AFM metrics: . - WARNING - the font metrics parsing in version 0.13.0 is - essentially a proof-of-concept and is not very robust. - Generally, if a font cannot be parsed, fallback metrics will be - used. At the moment there no error logging, so there is little - indication of whether Wumpus has used the correct metrics or the - fallback for a requested font. + Also note that Wumpus uses fallback metrics (derived from the + monospaced Courier font) when font loading fails, rather than + throwing a terminal error. Applications should ideally check + the font loading log to ensure that fonts have loaded correctly + (the demos print this log to standard out). . Changelog: . - 0.12.0 to 0.13.0: + v0.13.0 to v0.14.0: . + * Re-organised module hierarchy, Wumpus-Basic is now divided + into two layers - Basic (Font loader, utils, kernel drawing) + and Drawing - /constructed/ graphic objects like arrows, dots, + etc. + . + * Re-designed the /ContextFunction/ function types. Context + functions with different numbers of /static arguments/ are + now separate newtypes. This has allowed a major cull of the + combinators operating on context functions (@prepro@, + @postpro@, @situ@, etc.) and now only a handful of special + combinators are needed. As the newtypes are instances of + Monad and Applicative the usual Applicative and Monad + combinators are now more readily useful. + . + * Work on the font loader code to improve its robustness, and + improved error signalling on load failure. Loading glyph + metrics now returns both the metrics (possibly fallback + metrics if parsing failed) and a log. + . + v0.12.0 to v0.13.0: + . * Major changes to @Basic.Graphic@ modules. @DrawingR@ is renamed @Drawing@ and is substantially re-worked. Graphic /functional/ types are now encapulated in the Drawing @@ -93,64 +116,70 @@ library hs-source-dirs: src build-depends: base < 5, - containers >= 0.3 && <= 0.4, + containers >= 0.3 && <= 0.6, directory >= 1.0 && < 2.0, filepath >= 1.1 && < 2.0, vector-space >= 0.6 && < 1.0, - wumpus-core == 0.40.0 + wumpus-core == 0.41.0 exposed-modules: - Wumpus.Basic.Arrows, - Wumpus.Basic.Arrows.Connectors, - Wumpus.Basic.Arrows.Tips, - Wumpus.Basic.Chains, - Wumpus.Basic.Chains.Base, - Wumpus.Basic.Chains.Derived, - Wumpus.Basic.Colour.SVGColours, - Wumpus.Basic.Colour.X11Colours, - Wumpus.Basic.Dots.AnchorDots, - Wumpus.Basic.Dots.Marks, - Wumpus.Basic.DrawingComposition, - Wumpus.Basic.FontLoader.AfmLoader, - Wumpus.Basic.FontLoader.AfmParserBase, - Wumpus.Basic.FontLoader.AfmV2Parser, - Wumpus.Basic.FontLoader.AfmV4Dot1Parser, - Wumpus.Basic.FontLoader.Base, - Wumpus.Basic.FontLoader.GSFontMap, - Wumpus.Basic.FontLoader.GSLoader, - Wumpus.Basic.Graphic, - Wumpus.Basic.Graphic.Anchors, - Wumpus.Basic.Graphic.Base, - Wumpus.Basic.Graphic.ContextFunction, - Wumpus.Basic.Graphic.Drawing, - Wumpus.Basic.Graphic.DrawingContext, - Wumpus.Basic.Graphic.GlyphMetrics - Wumpus.Basic.Graphic.GraphicOperations, - Wumpus.Basic.Graphic.GraphicTypes, - Wumpus.Basic.Graphic.Query, - Wumpus.Basic.Graphic.ScalingContext, - Wumpus.Basic.Graphic.TraceDrawing, - Wumpus.Basic.Monads.TurtleClass, - Wumpus.Basic.Monads.TurtleMonad, - Wumpus.Basic.Paths, - Wumpus.Basic.Paths.Base, - Wumpus.Basic.Paths.Connectors, - Wumpus.Basic.Paths.Construction, - Wumpus.Basic.Paths.ControlPoints, - Wumpus.Basic.Paths.RoundCorners, - Wumpus.Basic.SafeFonts, - Wumpus.Basic.Shapes, - Wumpus.Basic.Shapes.Base, - Wumpus.Basic.Shapes.Coordinate, - Wumpus.Basic.Shapes.Derived, - Wumpus.Basic.Text.LRText, + Wumpus.Basic.Kernel, + Wumpus.Basic.Kernel.Base.Anchors, + Wumpus.Basic.Kernel.Base.BaseDefs, + Wumpus.Basic.Kernel.Base.ContextFun, + Wumpus.Basic.Kernel.Base.DrawingContext, + Wumpus.Basic.Kernel.Base.GlyphMetrics, + Wumpus.Basic.Kernel.Base.QueryDC, + Wumpus.Basic.Kernel.Base.ScalingContext, + Wumpus.Basic.Kernel.Base.UpdateDC, + Wumpus.Basic.Kernel.Base.WrappedPrimitive, + Wumpus.Basic.Kernel.Geometry.Intersection, + Wumpus.Basic.Kernel.Geometry.Paths, + Wumpus.Basic.Kernel.Objects.AdvanceGraphic, + Wumpus.Basic.Kernel.Objects.BaseObjects, + Wumpus.Basic.Kernel.Objects.Bounded, + Wumpus.Basic.Kernel.Objects.Connector, + Wumpus.Basic.Kernel.Objects.Drawing, + Wumpus.Basic.Kernel.Objects.Graphic, + Wumpus.Basic.Kernel.Objects.TraceDrawing, + Wumpus.Basic.System.FontLoader.Afm, + Wumpus.Basic.System.FontLoader.GhostScript, + Wumpus.Basic.System.FontLoader.Base.AfmParserBase, + Wumpus.Basic.System.FontLoader.Base.AfmV2Parser, + Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser, + Wumpus.Basic.System.FontLoader.Base.Datatypes, + Wumpus.Basic.System.FontLoader.Base.FontLoadMonad, + Wumpus.Basic.System.FontLoader.Base.GSFontMap, Wumpus.Basic.Utils.HList, Wumpus.Basic.Utils.FormatCombinators, - Wumpus.Basic.Utils.Intersection, Wumpus.Basic.Utils.ParserCombinators, Wumpus.Basic.Utils.TokenParsers, - Wumpus.Basic.VersionNumber + Wumpus.Basic.VersionNumber, + Wumpus.Drawing.Arrows, + Wumpus.Drawing.Arrows.Connectors, + Wumpus.Drawing.Arrows.Tips, + Wumpus.Drawing.Chains, + Wumpus.Drawing.Chains.Base, + Wumpus.Drawing.Chains.Derived, + Wumpus.Drawing.Colour.SVGColours, + Wumpus.Drawing.Colour.X11Colours, + Wumpus.Drawing.Dots.AnchorDots, + Wumpus.Drawing.Dots.Marks, + Wumpus.Drawing.Paths, + Wumpus.Drawing.Paths.Base, + Wumpus.Drawing.Paths.Connectors, + Wumpus.Drawing.Paths.Construction, + Wumpus.Drawing.Paths.ControlPoints, + Wumpus.Drawing.Paths.RoundCorners, + Wumpus.Drawing.Shapes, + Wumpus.Drawing.Shapes.Base, + Wumpus.Drawing.Shapes.Coordinate, + Wumpus.Drawing.Shapes.Derived, + Wumpus.Drawing.Text.LRText, + Wumpus.Drawing.Text.SafeFonts, + Wumpus.Drawing.Turtle.TurtleClass, + Wumpus.Drawing.Turtle.TurtleMonad other-modules: