diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,43 @@ +0.13.0 to 0.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. + +0.12.0 to 0.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 + constructor @Drawing (ctx -> pt -> prim)@ rather than + partially outside it @pt -> Drawing (ctx -> prim)@. + @Drawing@ monad renamed @TraceDrawing@ and @DrawingT@ + transformer renamed @TraceDrawingT@. + + * Rudimentary font loading added, only AFM files are supported. + + * @Basic.Shapes.Coordinate@ re-worked. The Coordinate type is + now more like the Shapes types (excepting the intentional + difference in drawing style). + + * @Basic.Shapes.Plaintext@ removed. + + * @Basic.Text.LRText@ completely redesigned. 0.11.0 to 0.12.0: diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs deleted file mode 100644 --- a/demo/ArrowCircuit.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - - --- Acknowledgment - the Arrow diagram is taken from Ross --- Paterson\'s slides /Arrows and Computation/. - - -module ArrowCircuit where - -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 - -import FontLoaderUtils - - -import Data.AffineSpace - -import System.Directory - - -main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing - writeEPS "./out/arrow_circuit01.eps" pic1 - writeSVG "./out/arrow_circuit01.svg" pic1 - -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing - writeEPS "./out/arrow_circuit02.eps" pic1 - writeSVG "./out/arrow_circuit02.svg" pic1 - - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace times_roman . metricsContext 11 - - - --- Note - quite a bit of this diagram was produced /by eye/, --- rather than using anchors directly - e.g. the placing of the --- ptext labels and the anchors displaced by vectors. --- - --- Note `at` currently does not work for Shapes. - -circuit_drawing :: Drawing Double -circuit_drawing = drawTracing $ do - a1 <- drawi $ strokedShape $ rrectangle 12 66 30 $ P2 0 72 - atext a1 "CONST 0" - a2 <- drawi $ strokedShape $ circle 16 $ P2 120 60 - atext a2 "IF" - a3 <- drawi $ strokedShape $ circle 16 $ P2 240 28 - atext a3 "+1" - a4 <- drawi $ strokedShape $ rectangle 66 30 $ P2 120 0 - atext a4 "DELAY 0" - connWith connLine (east a1) (east a1 .+^ hvec 76) - connWith connLine (east a2) (east a2 .+^ hvec 180) - connWith connLine (north a2 .+^ vvec 40) (north a2) - connWith connLine (north a3 .+^ vvec 16) (north a3) - connWith connRightVH (south a3) (east a4) - connWith (connRightHVH (-30)) (west a4) (southwest a2) - ptext (P2 40 10) "next" - ptext (P2 152 100) "reset" - ptext (P2 252 72) "output" - return () - - - -connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m - , Real u, Floating u, FromPtSize u ) - => ConnectorPath u -> Point2 u -> Point2 u -> m () -connWith con p0 p1 = localize doublesize $ - drawi_ $ apply2R2 (strokeConnector (rightArrow con tri45)) p0 p1 - - -atext :: ( CenterAnchor t, DUnit t ~ u - , Real u, Floating u, FromPtSize u - , TraceM m, DrawingCtxM m, u ~ MonUnit m ) - => t -> String -> m () -atext ancr ss = let pt = center ancr in - drawi_ $ 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 (fontAttr times_italic 14) $ - drawi_ $ ctrCenterLine ss `at` pt diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs deleted file mode 100644 --- a/demo/Arrowheads.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# OPTIONS -Wall #-} - -module Arrowheads where - - -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 - -import Data.AffineSpace -- package: vector-space - -import Control.Monad -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runDrawingU std_ctx arrow_drawing - writeEPS "./out/arrowheads01.eps" pic1 - writeSVG "./out/arrowheads01.svg" pic1 - -arrow_drawing :: Drawing Double -arrow_drawing = drawTracing $ tableGraphic arrtable - -arrtable :: [(Arrowhead Double, Arrowhead Double)] -arrtable = - [ (tri90, tri90) - , (tri60, tri60) - , (tri45, tri45) - , (otri90, otri90) - , (otri60, otri60) - , (otri45, otri45) - , (revtri90, revtri90) - , (revtri60, revtri60) - , (revtri45, revtri45) - , (orevtri90, orevtri90) - , (orevtri60, orevtri60) - , (orevtri45, orevtri45) - , (barb90, barb90) - , (barb60, barb60) - , (barb45, barb45) - , (revbarb90, revbarb90) - , (revbarb60, revbarb60) - , (revbarb45, revbarb45) - , (perp, perp) - , (bracket, bracket) - , (diskTip, diskTip) - , (odiskTip, odiskTip) - , (squareTip, squareTip) - , (osquareTip, osquareTip) - , (diamondTip, diamondTip) - , (odiamondTip, odiamondTip) - , (curveTip, curveTip) - , (revcurveTip, revcurveTip) - ] - -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u () -tableGraphic tips = zipWithM_ makeArrowDrawing tips ps - where - ps = unchain (coordinateScalingContext 120 24) $ tableDown 20 4 - - - -std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 18 - - - -makeArrowDrawing :: (Real u, Floating u, FromPtSize u) - => (Arrowhead u, Arrowhead u) -> Point2 u - -> TraceDrawing u () -makeArrowDrawing (arrl,arrr) p0 = - drawi_ $ apply2R2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1 - where - p1 = p0 .+^ hvec 100 - - diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs deleted file mode 100644 --- a/demo/ClipPic.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# OPTIONS -Wall #-} - --- Note - how the background is built in this example is very --- expensive, i.e. it generates large PostScript and SVG files --- because the text elements are drawn many more times than they --- are actually seen. --- --- This example just illustrates that clipping-paths work and --- uses a complicated background to make that point. --- - - -module ClipPic where - -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 - -import Data.AffineSpace -- package: vector-space - -import System.Directory - - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic = runDrawingU pic_drawing_ctx big_pic - writeEPS "./out/clip_pic.eps" pic - writeSVG "./out/clip_pic.svg" pic - - -pic_drawing_ctx :: DrawingContext -pic_drawing_ctx = standardContext 14 - - -big_pic :: DDrawing -big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4] - -fillPath :: Num u => Path u -> Graphic u -fillPath = filledPath . toPrimPath - -pic1 :: DDrawing -pic1 = drawTracing $ - localize (fillColour medium_slate_blue) $ do - draw $ fillPath path01 - localize (fillColour powder_blue) $ - draw $ fillPath path02 - draw $ fillPath path03 - draw $ fillPath path04 - - -background :: RGBi -> DDrawing -background rgb = drawTracing $ - localize (strokeColour rgb) $ mapM_ iheartHaskell ps - where - ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8 - -cpic1 :: DDrawing -cpic1 = clipDrawing (toPrimPath path01) (background black) - -cpic2 :: DDrawing -cpic2 = clipDrawing (toPrimPath path02) (background medium_violet_red) - -cpic3 :: DDrawing -cpic3 = clipDrawing (toPrimPath path03) (background black) - -cpic4 :: DDrawing -cpic4 = clipDrawing (toPrimPath path04) (background black) - - -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) - - -path01 :: Floating u => Path u -path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) - >> rlineto (vec (-112) 160) - >> hline (-80) - >> rlineto (vec 112 (-160)) - >> rlineto (vec (-112) (-160)) - - -path02 :: Floating u => Path u -path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112) - >> rlineto (vec 72 (-112)) - >> hline 80 - >> rlineto (vec (-224) 320) - >> hline (-80) - >> rlineto (vec 112 (-160)) - >> rlineto (vec (-112) (-160)) - -path03 :: Floating u => Path u -path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) - -path04 :: Floating u => Path u -path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) - diff --git a/demo/ColourChartUtils.hs b/demo/ColourChartUtils.hs deleted file mode 100644 --- a/demo/ColourChartUtils.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : ColourChartUtils --- Copyright : (c) Stephen Tetley 2009 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- All the SVG / X11 \"named colours\" listed in tables. --- --------------------------------------------------------------------------------- - -module ColourChartUtils - ( - -- * Tables of all colours - all_x11_colours - , all_svg_colours - - ) where - -import qualified Wumpus.Drawing.Colour.SVGColours as SVG -import qualified Wumpus.Drawing.Colour.X11Colours as X11 - -import Wumpus.Core.Colour ( RGBi ) - - -all_svg_colours :: [(String,RGBi)] -all_svg_colours = - [ ("alice_blue", SVG.alice_blue) - , ("antique_white", SVG.antique_white) - , ("aqua", SVG.aqua) - , ("aquamarine", SVG.aquamarine) - , ("azure", SVG.azure) - , ("beige", SVG.beige) - , ("bisque", SVG.bisque) - , ("black", SVG.black) - , ("blanched_almond", SVG.blanched_almond) - , ("blue", SVG.blue) - , ("blue_violet", SVG.blue_violet) - , ("brown", SVG.brown) - , ("burlywood", SVG.burlywood) - , ("cadet_blue", SVG.cadet_blue) - , ("chartreuse", SVG.chartreuse) - , ("chocolate", SVG.chocolate) - , ("coral", SVG.coral) - , ("cornflower_blue", SVG.cornflower_blue) - , ("cornsilk", SVG.cornsilk) - , ("crimson", SVG.crimson) - , ("cyan", SVG.cyan) - , ("dark_blue", SVG.dark_blue) - , ("dark_cyan", SVG.dark_cyan) - , ("dark_goldenrod", SVG.dark_goldenrod) - , ("dark_gray", SVG.dark_gray) - , ("dark_green", SVG.dark_green) - , ("dark_grey", SVG.dark_grey) - , ("dark_khaki", SVG.dark_khaki) - , ("dark_magenta", SVG.dark_magenta) - , ("dark_olive_green", SVG.dark_olive_green) - , ("dark_orange", SVG.dark_orange) - , ("dark_orchid", SVG.dark_orchid) - , ("dark_red", SVG.dark_red) - , ("dark_salmon", SVG.dark_salmon) - , ("dark_sea_green", SVG.dark_sea_green) - , ("dark_slate_blue", SVG.dark_slate_blue) - , ("dark_slate_gray", SVG.dark_slate_gray) - , ("dark_slate_grey", SVG.dark_slate_grey) - , ("dark_turquoise", SVG.dark_turquoise) - , ("dark_violet", SVG.dark_violet) - , ("deep_pink", SVG.deep_pink) - , ("deep_sky_blue", SVG.deep_sky_blue) - , ("dim_gray", SVG.dim_gray) - , ("dim_grey", SVG.dim_grey) - , ("dodger_blue", SVG.dodger_blue) - , ("firebrick", SVG.firebrick) - , ("floral_white", SVG.floral_white) - , ("forest_green", SVG.forest_green) - , ("fuchsia", SVG.fuchsia) - , ("gainsboro", SVG.gainsboro) - , ("ghost_white", SVG.ghost_white) - , ("gold", SVG.gold) - , ("goldenrod", SVG.goldenrod) - , ("gray", SVG.gray) - , ("grey", SVG.grey) - , ("green", SVG.green) - , ("green_yellow", SVG.green_yellow) - , ("honeydew", SVG.honeydew) - , ("hot_pink", SVG.hot_pink) - , ("indian_red", SVG.indian_red) - , ("indigo", SVG.indigo) - , ("ivory", SVG.ivory) - , ("khaki", SVG.khaki) - , ("lavender", SVG.lavender) - , ("lavender_blush", SVG.lavender_blush) - , ("lawn_green", SVG.lawn_green) - , ("lemon_chiffon", SVG.lemon_chiffon) - , ("light_blue", SVG.light_blue) - , ("light_coral", SVG.light_coral) - , ("light_cyan", SVG.light_cyan) - , ("light_goldenrod_yellow", SVG.light_goldenrod_yellow) - , ("light_gray", SVG.light_gray) - , ("light_green", SVG.light_green) - , ("light_grey", SVG.light_grey) - , ("light_pink", SVG.light_pink) - , ("light_salmon", SVG.light_salmon) - , ("light_sea_green", SVG.light_sea_green) - , ("light_sky_blue", SVG.light_sky_blue) - , ("light_slate_gray", SVG.light_slate_gray) - , ("light_slate_grey", SVG.light_slate_grey) - , ("light_steel_blue", SVG.light_steel_blue) - , ("light_yellow", SVG.light_yellow) - , ("lime", SVG.lime) - , ("lime_green", SVG.lime_green) - , ("linen", SVG.linen) - , ("magenta", SVG.magenta) - , ("maroon", SVG.maroon) - , ("medium_aquamarine", SVG.medium_aquamarine) - , ("medium_blue", SVG.medium_blue) - , ("medium_orchid", SVG.medium_orchid) - , ("medium_purple", SVG.medium_purple) - , ("medium_sea_green", SVG.medium_sea_green) - , ("medium_slate_blue", SVG.medium_slate_blue) - , ("medium_spring_green", SVG.medium_spring_green) - , ("medium_turquoise", SVG.medium_turquoise) - , ("medium_violet_red", SVG.medium_violet_red) - , ("midnight_blue", SVG.midnight_blue) - , ("mintcream", SVG.mintcream) - , ("mistyrose", SVG.mistyrose) - , ("moccasin", SVG.moccasin) - , ("navajo_white", SVG.navajo_white) - , ("navy", SVG.navy) - , ("old_lace", SVG.old_lace) - , ("olive", SVG.olive) - , ("olive_drab", SVG.olive_drab) - , ("orange", SVG.orange) - , ("orange_red", SVG.orange_red) - , ("orchid", SVG.orchid) - , ("pale_goldenrod", SVG.pale_goldenrod) - , ("pale_green", SVG.pale_green) - , ("pale_turquoise", SVG.pale_turquoise) - , ("pale_violet_red", SVG.pale_violet_red) - , ("papaya_whip", SVG.papaya_whip) - , ("peach_puff", SVG.peach_puff) - , ("peru", SVG.peru) - , ("pink", SVG.pink) - , ("plum", SVG.plum) - , ("powder_blue", SVG.powder_blue) - , ("purple", SVG.purple) - , ("red", SVG.red) - , ("rosy_brown", SVG.rosy_brown) - , ("royal_blue", SVG.royal_blue) - , ("saddle_brown", SVG.saddle_brown) - , ("salmon", SVG.salmon) - , ("sandy_brown", SVG.sandy_brown) - , ("sea_green", SVG.sea_green) - , ("seashell", SVG.seashell) - , ("sienna", SVG.sienna) - , ("silver", SVG.silver) - , ("sky_blue", SVG.sky_blue) - , ("slate_blue", SVG.slate_blue) - , ("slate_gray", SVG.slate_gray) - , ("slate_grey", SVG.slate_grey) - , ("snow", SVG.snow) - , ("spring_green", SVG.spring_green) - , ("steel_blue", SVG.steel_blue) - , ("tan", SVG.tan) - , ("teal", SVG.teal) - , ("thistle", SVG.thistle) - , ("tomato", SVG.tomato) - , ("turquoise", SVG.turquoise) - , ("violet", SVG.violet) - , ("wheat", SVG.wheat) - , ("white", SVG.white) - , ("whitesmoke", SVG.whitesmoke) - , ("yellow", SVG.yellow) - , ("yellow_green", SVG.yellow_green) - ] - - - -all_x11_colours :: [(String,RGBi)] -all_x11_colours = - [ ("antique_white1", X11.antique_white1) - , ("antique_white2", X11.antique_white2) - , ("antique_white3", X11.antique_white3) - , ("antique_white4", X11.antique_white4) - , ("aquamarine1", X11.aquamarine1) - , ("aquamarine2", X11.aquamarine2) - , ("aquamarine3", X11.aquamarine3) - , ("aquamarine4", X11.aquamarine4) - , ("azure1", X11.azure1) - , ("azure2", X11.azure2) - , ("azure3", X11.azure3) - , ("azure4", X11.azure4) - , ("bisque1", X11.bisque1) - , ("bisque2", X11.bisque2) - , ("bisque3", X11.bisque3) - , ("bisque4", X11.bisque4) - , ("blue1", X11.blue1) - , ("blue2", X11.blue2) - , ("blue3", X11.blue3) - , ("blue4", X11.blue4) - , ("brown1", X11.brown1) - , ("brown2", X11.brown2) - , ("brown3", X11.brown3) - , ("brown4", X11.brown4) - , ("burlywood1", X11.burlywood1) - , ("burlywood2", X11.burlywood2) - , ("burlywood3", X11.burlywood3) - , ("burlywood4", X11.burlywood4) - , ("cadet_blue1", X11.cadet_blue1) - , ("cadet_blue2", X11.cadet_blue2) - , ("cadet_blue3", X11.cadet_blue3) - , ("cadet_blue4", X11.cadet_blue4) - , ("chartreuse1", X11.chartreuse1) - , ("chartreuse2", X11.chartreuse2) - , ("chartreuse3", X11.chartreuse3) - , ("chartreuse4", X11.chartreuse4) - , ("chocolate1", X11.chocolate1) - , ("chocolate2", X11.chocolate2) - , ("chocolate3", X11.chocolate3) - , ("chocolate4", X11.chocolate4) - , ("coral1", X11.coral1) - , ("coral2", X11.coral2) - , ("coral3", X11.coral3) - , ("coral4", X11.coral4) - , ("cornsilk1", X11.cornsilk1) - , ("cornsilk2", X11.cornsilk2) - , ("cornsilk3", X11.cornsilk3) - , ("cornsilk4", X11.cornsilk4) - , ("cyan1", X11.cyan1) - , ("cyan2", X11.cyan2) - , ("cyan3", X11.cyan3) - , ("cyan4", X11.cyan4) - , ("dark_goldenrod1", X11.dark_goldenrod1) - , ("dark_goldenrod2", X11.dark_goldenrod2) - , ("dark_goldenrod3", X11.dark_goldenrod3) - , ("dark_goldenrod4", X11.dark_goldenrod4) - , ("dark_olive_green1", X11.dark_olive_green1) - , ("dark_olive_green2", X11.dark_olive_green2) - , ("dark_olive_green3", X11.dark_olive_green3) - , ("dark_olive_green4", X11.dark_olive_green4) - , ("dark_orange1", X11.dark_orange1) - , ("dark_orange2", X11.dark_orange2) - , ("dark_orange3", X11.dark_orange3) - , ("dark_orange4", X11.dark_orange4) - , ("dark_orchid1", X11.dark_orchid1) - , ("dark_orchid2", X11.dark_orchid2) - , ("dark_orchid3", X11.dark_orchid3) - , ("dark_orchid4", X11.dark_orchid4) - , ("dark_sea_green1", X11.dark_sea_green1) - , ("dark_sea_green2", X11.dark_sea_green2) - , ("dark_sea_green3", X11.dark_sea_green3) - , ("dark_sea_green4", X11.dark_sea_green4) - , ("dark_slate_gray1", X11.dark_slate_gray1) - , ("dark_slate_gray2", X11.dark_slate_gray2) - , ("dark_slate_gray3", X11.dark_slate_gray3) - , ("dark_slate_gray4", X11.dark_slate_gray4) - , ("deep_pink1", X11.deep_pink1) - , ("deep_pink2", X11.deep_pink2) - , ("deep_pink3", X11.deep_pink3) - , ("deep_pink4", X11.deep_pink4) - , ("deep_sky_blue1", X11.deep_sky_blue1) - , ("deep_sky_blue2", X11.deep_sky_blue2) - , ("deep_sky_blue3", X11.deep_sky_blue3) - , ("deep_sky_blue4", X11.deep_sky_blue4) - , ("dodger_blue1", X11.dodger_blue1) - , ("dodger_blue2", X11.dodger_blue2) - , ("dodger_blue3", X11.dodger_blue3) - , ("dodger_blue4", X11.dodger_blue4) - , ("firebrick1", X11.firebrick1) - , ("firebrick2", X11.firebrick2) - , ("firebrick3", X11.firebrick3) - , ("firebrick4", X11.firebrick4) - , ("gold1", X11.gold1) - , ("gold2", X11.gold2) - , ("gold3", X11.gold3) - , ("gold4", X11.gold4) - , ("goldenrod1", X11.goldenrod1) - , ("goldenrod2", X11.goldenrod2) - , ("goldenrod3", X11.goldenrod3) - , ("goldenrod4", X11.goldenrod4) - , ("green1", X11.green1) - , ("green2", X11.green2) - , ("green3", X11.green3) - , ("green4", X11.green4) - , ("honeydew1", X11.honeydew1) - , ("honeydew2", X11.honeydew2) - , ("honeydew3", X11.honeydew3) - , ("honeydew4", X11.honeydew4) - , ("hot_pink1", X11.hot_pink1) - , ("hot_pink2", X11.hot_pink2) - , ("hot_pink3", X11.hot_pink3) - , ("hot_pink4", X11.hot_pink4) - , ("indian_red1", X11.indian_red1) - , ("indian_red2", X11.indian_red2) - , ("indian_red3", X11.indian_red3) - , ("indian_red4", X11.indian_red4) - , ("ivory1", X11.ivory1) - , ("ivory2", X11.ivory2) - , ("ivory3", X11.ivory3) - , ("ivory4", X11.ivory4) - , ("khaki1", X11.khaki1) - , ("khaki2", X11.khaki2) - , ("khaki3", X11.khaki3) - , ("khaki4", X11.khaki4) - , ("lavender_blush1", X11.lavender_blush1) - , ("lavender_blush2", X11.lavender_blush2) - , ("lavender_blush3", X11.lavender_blush3) - , ("lavender_blush4", X11.lavender_blush4) - , ("lemon_chiffon1", X11.lemon_chiffon1) - , ("lemon_chiffon2", X11.lemon_chiffon2) - , ("lemon_chiffon3", X11.lemon_chiffon3) - , ("lemon_chiffon4", X11.lemon_chiffon4) - , ("light_blue1", X11.light_blue1) - , ("light_blue2", X11.light_blue2) - , ("light_blue3", X11.light_blue3) - , ("light_blue4", X11.light_blue4) - , ("light_cyan1", X11.light_cyan1) - , ("light_cyan2", X11.light_cyan2) - , ("light_cyan3", X11.light_cyan3) - , ("light_cyan4", X11.light_cyan4) - , ("light_goldenrod1", X11.light_goldenrod1) - , ("light_goldenrod2", X11.light_goldenrod2) - , ("light_goldenrod3", X11.light_goldenrod3) - , ("light_goldenrod4", X11.light_goldenrod4) - , ("light_pink1", X11.light_pink1) - , ("light_pink2", X11.light_pink2) - , ("light_pink3", X11.light_pink3) - , ("light_pink4", X11.light_pink4) - , ("light_salmon1", X11.light_salmon1) - , ("light_salmon2", X11.light_salmon2) - , ("light_salmon3", X11.light_salmon3) - , ("light_salmon4", X11.light_salmon4) - , ("light_sky_blue1", X11.light_sky_blue1) - , ("light_sky_blue2", X11.light_sky_blue2) - , ("light_sky_blue3", X11.light_sky_blue3) - , ("light_sky_blue4", X11.light_sky_blue4) - , ("light_steel_blue1", X11.light_steel_blue1) - , ("light_steel_blue2", X11.light_steel_blue2) - , ("light_steel_blue3", X11.light_steel_blue3) - , ("light_steel_blue4", X11.light_steel_blue4) - , ("light_yellow1", X11.light_yellow1) - , ("light_yellow2", X11.light_yellow2) - , ("light_yellow3", X11.light_yellow3) - , ("light_yellow4", X11.light_yellow4) - , ("magenta1", X11.magenta1) - , ("magenta2", X11.magenta2) - , ("magenta3", X11.magenta3) - , ("magenta4", X11.magenta4) - , ("maroon1", X11.maroon1) - , ("maroon2", X11.maroon2) - , ("maroon3", X11.maroon3) - , ("maroon4", X11.maroon4) - , ("medium_orchid1", X11.medium_orchid1) - , ("medium_orchid2", X11.medium_orchid2) - , ("medium_orchid3", X11.medium_orchid3) - , ("medium_orchid4", X11.medium_orchid4) - , ("medium_purple1", X11.medium_purple1) - , ("medium_purple2", X11.medium_purple2) - , ("medium_purple3", X11.medium_purple3) - , ("medium_purple4", X11.medium_purple4) - , ("misty_rose1", X11.misty_rose1) - , ("misty_rose2", X11.misty_rose2) - , ("misty_rose3", X11.misty_rose3) - , ("misty_rose4", X11.misty_rose4) - , ("navajo_white1", X11.navajo_white1) - , ("navajo_white2", X11.navajo_white2) - , ("navajo_white3", X11.navajo_white3) - , ("navajo_white4", X11.navajo_white4) - , ("olive_drab1", X11.olive_drab1) - , ("olive_drab2", X11.olive_drab2) - , ("olive_drab3", X11.olive_drab3) - , ("olive_drab4", X11.olive_drab4) - , ("orange1", X11.orange1) - , ("orange2", X11.orange2) - , ("orange3", X11.orange3) - , ("orange4", X11.orange4) - , ("orange_red1", X11.orange_red1) - , ("orange_red2", X11.orange_red2) - , ("orange_red3", X11.orange_red3) - , ("orange_red4", X11.orange_red4) - , ("orchid1", X11.orchid1) - , ("orchid2", X11.orchid2) - , ("orchid3", X11.orchid3) - , ("orchid4", X11.orchid4) - , ("pale_green1", X11.pale_green1) - , ("pale_green2", X11.pale_green2) - , ("pale_green3", X11.pale_green3) - , ("pale_green4", X11.pale_green4) - , ("pale_turquoise1", X11.pale_turquoise1) - , ("pale_turquoise2", X11.pale_turquoise2) - , ("pale_turquoise3", X11.pale_turquoise3) - , ("pale_turquoise4", X11.pale_turquoise4) - , ("pale_violet_red1", X11.pale_violet_red1) - , ("pale_violet_red2", X11.pale_violet_red2) - , ("pale_violet_red3", X11.pale_violet_red3) - , ("pale_Violet_red4", X11.pale_violet_red4) - , ("peach_puff1", X11.peach_puff1) - , ("peach_puff2", X11.peach_puff2) - , ("peach_puff3", X11.peach_puff3) - , ("peach_puff4", X11.peach_puff4) - , ("pink1", X11.pink1) - , ("pink2", X11.pink2) - , ("pink3", X11.pink3) - , ("pink4", X11.pink4) - , ("plum1", X11.plum1) - , ("plum2", X11.plum2) - , ("plum3", X11.plum3) - , ("plum4", X11.plum4) - , ("purple1", X11.purple1) - , ("purple2", X11.purple2) - , ("purple3", X11.purple3) - , ("purple4", X11.purple4) - , ("red1", X11.red1) - , ("red2", X11.red2) - , ("red3", X11.red3) - , ("red4", X11.red4) - , ("rosy_brown1", X11.rosy_brown1) - , ("rosy_brown2", X11.rosy_brown2) - , ("rosy_brown3", X11.rosy_brown3) - , ("rosy_brown4", X11.rosy_brown4) - , ("royal_blue1", X11.royal_blue1) - , ("royal_blue2", X11.royal_blue2) - , ("royal_blue3", X11.royal_blue3) - , ("royal_blue4", X11.royal_blue4) - , ("salmon1", X11.salmon1) - , ("salmon2", X11.salmon2) - , ("salmon3", X11.salmon3) - , ("salmon4", X11.salmon4) - , ("sea_green1", X11.sea_green1) - , ("sea_green2", X11.sea_green2) - , ("sea_green3", X11.sea_green3) - , ("sea_green4", X11.sea_green4) - , ("seashell1", X11.seashell1) - , ("seashell2", X11.seashell2) - , ("seashell3", X11.seashell3) - , ("seashell4", X11.seashell4) - , ("sienna1", X11.sienna1) - , ("sienna2", X11.sienna2) - , ("sienna3", X11.sienna3) - , ("sienna4", X11.sienna4) - , ("sky_blue1", X11.sky_blue1) - , ("sky_blue2", X11.sky_blue2) - , ("sky_blue3", X11.sky_blue3) - , ("sky_blue4", X11.sky_blue4) - , ("slate_blue1", X11.slate_blue1) - , ("slate_blue2", X11.slate_blue2) - , ("slate_blue3", X11.slate_blue3) - , ("slate_blue4", X11.slate_blue4) - , ("slate_gray1", X11.slate_gray1) - , ("slate_gray2", X11.slate_gray2) - , ("slate_gray3", X11.slate_gray3) - , ("slate_gray4", X11.slate_gray4) - , ("snow1", X11.snow1) - , ("snow2", X11.snow2) - , ("snow3", X11.snow3) - , ("snow4", X11.snow4) - , ("spring_green1", X11.spring_green1) - , ("spring_green2", X11.spring_green2) - , ("spring_green3", X11.spring_green3) - , ("spring_green4", X11.spring_green4) - , ("steel_blue1", X11.steel_blue1) - , ("steel_blue2", X11.steel_blue2) - , ("steel_blue3", X11.steel_blue3) - , ("steel_blue4", X11.steel_blue4) - , ("tan1", X11.tan1) - , ("tan2", X11.tan2) - , ("tan3", X11.tan3) - , ("tan4", X11.tan4) - , ("thistle1", X11.thistle1) - , ("thistle2", X11.thistle2) - , ("thistle3", X11.thistle3) - , ("thistle4", X11.thistle4) - , ("tomato1", X11.tomato1) - , ("tomato2", X11.tomato2) - , ("tomato3", X11.tomato3) - , ("tomato4", X11.tomato4) - , ("turquoise1", X11.turquoise1) - , ("turquoise2", X11.turquoise2) - , ("turquoise3", X11.turquoise3) - , ("turquoise4", X11.turquoise4) - , ("violet_red1", X11.violet_red1) - , ("violet_red2", X11.violet_red2) - , ("violet_red3", X11.violet_red3) - , ("violet_red4", X11.violet_red4) - , ("wheat1", X11.wheat1) - , ("wheat2", X11.wheat2) - , ("wheat3", X11.wheat3) - , ("wheat4", X11.wheat4) - , ("yellow1", X11.yellow1) - , ("yellow2", X11.yellow2) - , ("yellow3", X11.yellow3) - , ("yellow4", X11.yellow4) - ] - - - - diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs deleted file mode 100644 --- a/demo/ColourCharts.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# OPTIONS -Wall #-} - -module ColourCharts where - -import ColourChartUtils - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Chains - -import Wumpus.Core -- package: wumpus-core - -import Control.Monad -import System.Directory - - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - -- - let svg_pic = runDrawingU draw_ctx svg - writeEPS "./out/SVGcolours.eps" svg_pic - writeSVG "./out/SVGcolours.svg" svg_pic - -- - let x11_p = runDrawingU draw_ctx x11_portrait - writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p - let x11_l = runDrawingU draw_ctx x11_landscape - writeSVG "./out/X11colours.svg" x11_l - -draw_ctx :: DrawingContext -draw_ctx = (standardContext 9) - -svg :: Drawing Double -svg = makeDrawing 52 all_svg_colours - -x11_landscape :: Drawing Double -x11_landscape = makeDrawing 52 all_x11_colours - -x11_portrait :: Drawing Double -x11_portrait = makeDrawing 72 all_x11_colours - -makeDrawing :: Int -> [(String,RGBi)] -> DDrawing -makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs - -tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () -tableGraphic row_count xs = - zipWithM_ (\(name,rgb) pt -> colourSample name rgb pt) xs ps - where - ps = unchain (coordinateScalingContext 152 11) $ tableDown row_count 10 - - -colourSample :: String -> RGBi -> DPoint2 -> TraceDrawing Double () -colourSample name rgb pt = localize (fillColour rgb) $ do - draw $ borderedRectangle 15 10 `at` pt - draw $ textline name `at` displace 20 2 pt - - diff --git a/demo/Connectors.hs b/demo/Connectors.hs deleted file mode 100644 --- a/demo/Connectors.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# OPTIONS -Wall #-} - -module Connectors where - - -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 - -import Data.AffineSpace -- package: vector-space - -import Control.Monad -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runDrawingU std_ctx conn_drawing - writeEPS "./out/connectors01.eps" pic1 - writeSVG "./out/connectors01.svg" pic1 - - - -conn_drawing :: Drawing Double -conn_drawing = drawTracing $ tableGraphic $ conntable - -conntable :: [ConnectorPath Double] -conntable = - [ connLine - , connRightVH - , connRightHV - , connRightVHV 15 - , connRightHVH 15 - , connIsosceles 25 - , connIsosceles (-25) - , connIsosceles2 15 - , connIsosceles2 (-15) - , connLightningBolt 15 - , connLightningBolt (-15) - , connIsoscelesCurve 25 - , connIsoscelesCurve (-25) - , connSquareCurve - , connUSquareCurve - , connTrapezoidCurve 40 0.5 - , connTrapezoidCurve (-40) 0.5 - , connZSquareCurve - , connUZSquareCurve - ] - -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [ConnectorPath u] -> TraceDrawing u () -tableGraphic conns = zipWithM_ makeConnDrawing conns ps - where - ps = unchain (coordinateScalingContext 120 52) $ tableDown 10 6 - - - -std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 18 - - - -makeConnDrawing :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -> Point2 u -> TraceDrawing u () -makeConnDrawing conn p0 = - drawi_ $ connect (strokeConnector (dblArrow conn curveTip)) p0 p1 - where - p1 = p0 .+^ vec 100 40 - - diff --git a/demo/DotPic.hs b/demo/DotPic.hs deleted file mode 100644 --- a/demo/DotPic.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# OPTIONS -Wall #-} - -module DotPic where - - -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 - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Monad -import System.Directory - - - -main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing - 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, msgs) <- loadAfmMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing - writeEPS "./out/dots01_afm.eps" pic1 - writeSVG "./out/dots01_afm.svg" pic1 - - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fillColour peru . fontFace helvetica . metricsContext 24 - - -dot_drawing :: Drawing Double -dot_drawing = drawTracing $ tableGraphic $ - [ dotHLine - , dotVLine - , dotX - , dotPlus - , dotCross - , dotDiamond - , dotDisk - , dotSquare - , dotCircle - , dotPentagon - , dotStar - , dotAsterisk - , dotOPlus - , dotOCross - , dotFOCross - , dotFDiamond - , dotText "%" - , dotTriangle - ] - - -tableGraphic :: (Real u, Floating u, FromPtSize u) - => [DotLocImage u] -> TraceDrawing u () -tableGraphic imgs = zipWithM_ makeDotDrawing imgs ps - where - ps = unchain (coordinateScalingContext 1 36) $ tableDown (length imgs) 1 - - - -makeDotDrawing :: (Real u, Floating u, FromPtSize u) - => DotLocImage u -> Point2 u -> TraceDrawing u () -makeDotDrawing dotF pt = do - dashline - mapM_ (\v -> drawi $ dotF `at` pt .+^ v) displacements - where - all_pts = map (pt .+^) displacements - dashline = localize attrUpd (draw $ openStroke $ vertexPath all_pts) - - attrUpd :: DrawingContext -> DrawingContext - attrUpd = dashPattern (evenDashes 1) . strokeColour cadet_blue - - -displacements :: Num u => [Vec2 u] -displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20] - - --- Should these produce a DashPattern or a StrokeAttr? - -evenDashes :: Int -> DashPattern -evenDashes n = Dash 0 [(n,n)] - -dashOffset :: Int -> DashPattern -> DashPattern -dashOffset _ Solid = Solid -dashOffset n (Dash _ xs) = Dash n xs - diff --git a/demo/DrawingCompo.hs b/demo/DrawingCompo.hs deleted file mode 100644 --- a/demo/DrawingCompo.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# OPTIONS -Wall #-} - -module DrawingCompo where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Colour.SVGColours - -import Wumpus.Core -- package: wumpus-core - -import System.Directory - - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let out1 = runDrawingU pic_drawing_ctx pictures - writeEPS "./out/drawing_composition.eps" out1 - writeSVG "./out/drawing_composition.svg" out1 - - -pic_drawing_ctx :: DrawingContext -pic_drawing_ctx = standardContext 14 - - -pictures :: DDrawing -pictures = vsep 12 [ pic1, pic2, pic3, pic4 - , pic5, pic6, pic7, pic8 - , pic9, pic10, pic11, pic12 ] - - -drawBlueBounds :: (Real u, Floating u, FromPtSize u) - => Drawing u -> Drawing u -drawBlueBounds = modifyDrawing (illustrateBounds blue) - -pic1 :: DDrawing -pic1 = picAnno pic "red `over` green `over` blue" - where - pic :: DDrawing - pic = drawBlueBounds $ rect_red `over` rect_green `over` rect_blue - -pic2 :: DDrawing -pic2 = picAnno pic "red `under` green `under` blue" - where - pic :: DDrawing - pic = drawBlueBounds $ rect_red `under` rect_green `under` rect_blue - - -pic3 :: DDrawing -pic3 = picAnno pic "red `centric` green `centric` blue" - where - pic :: DDrawing - pic = drawBlueBounds $ - rect_red `centric` rect_green `centric` rect_blue - --- Note - nextToH only moves pictures in the horizontal. --- -pic4 :: DDrawing -pic4 = picAnno pic "red `nextToH` green `nextToH` blue" - where - pic :: DDrawing - pic = drawBlueBounds $ - rect_red `nextToH` rect_green `nextToH` rect_blue - --- Note - nextToV only moves pictures in the vertical. --- -pic5 :: DDrawing -pic5 = picAnno pic "red `nextToV` green `nextToV` blue" - where - pic :: DDrawing - pic = drawBlueBounds $ - rect_red `nextToV` rect_green `nextToV` rect_blue - - -pic6 :: DDrawing -pic6 = picAnno pic "zconcat [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - zconcat [rect_red, rect_green, rect_blue] - - -pic7 :: DDrawing -pic7 = picAnno pic "hcat [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - hcat [rect_red, rect_green, rect_blue] - -pic8 :: DDrawing -pic8 = picAnno pic "vcat [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - vcat [rect_red, rect_green, rect_blue] - -pic9 :: DDrawing -pic9 = picAnno pic "hsep 20 [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - hsep 20 [rect_red, rect_green, rect_blue] - -pic10 :: DDrawing -pic10 = picAnno pic "vsep 20 [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - vsep 20 [rect_red, rect_green, rect_blue] - - -pic11 :: DDrawing -pic11 = picAnno pic "hcatA HTop [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - hcatA HTop [rect_red, rect_green, rect_blue] - - -pic12 :: DDrawing -pic12 = picAnno pic "vcatA VCenter [red, green, blue]" - where - pic :: DDrawing - pic = drawBlueBounds $ - vcatA VCenter [rect_red, rect_green, rect_blue] - - --------------------------------------------------------------------------------- - - -picAnno :: DDrawing -> String -> DDrawing -picAnno pic msg = alignHSep HCenter 30 pic lbl - where - lbl = drawTracing $ draw $ textline msg `at` zeroPt - - -rect_red :: DDrawing -rect_red = drawTracing $ - localize (fillColour indian_red) - (draw $ borderedRectangle 30 10 `at` (P2 0 10)) - -rect_green :: DDrawing -rect_green = drawTracing $ - localize (fillColour olive_drab) - (draw $ borderedRectangle 15 15 `at` (P2 10 10)) - - -rect_blue :: DDrawing -rect_blue = drawTracing $ - localize (fillColour powder_blue) - (draw $ borderedRectangle 20 30 `at` (P2 10 0)) - diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs deleted file mode 100644 --- a/demo/FeatureModel.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - - - -module FeatureModel where - -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 - -import FontLoaderUtils - - -import System.Directory - - -main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (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 - -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx base_metrics) feature_model - writeEPS "./out/feature_model02.eps" pic1 - writeSVG "./out/feature_model02.svg" pic1 - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace courier_bold . metricsContext 18 - - --- Note - I haven't worked out how to do @alternative@, @or@ and --- @repetitions@ yet. --- - -feature_model :: Drawing Double -feature_model = drawTracing $ do - lea <- widebox "e" $ P2 150 160 - lra <- widebox "r" $ P2 60 80 - lsa <- widebox "s" $ P2 240 80 - cmandatory_ lea lra - cmandatory_ lea lsa - - uGa <- box "G" $ P2 0 0 - uHa <- box "H" $ P2 60 0 - uIa <- box "I" $ P2 120 0 - - uAa <- box "A" $ P2 180 0 - uBa <- box "B" $ P2 240 0 - uCa <- box "C" $ P2 300 0 - - cmandatory_ lra uGa - cmandatory_ lra uHa - cmandatory_ lra uIa - - cmandatory_ lsa uAa - coptional_ lsa uBa - cmandatory_ lsa uCa - - return () - - -type Box u = Rectangle u - - -makeBox :: (Real u, Floating u, FromPtSize u) - => u -> String -> Point2 u -> TraceDrawing u (Box u) -makeBox w ss pt = do - a <- drawi $ strokedShape $ rectangle w 20 $ pt - drawi_ $ ctrCenterLine ss `at` center a - return a - -box :: (Real u, Floating u, FromPtSize u) - => String -> Point2 u -> TraceDrawing u (Box u) -box = makeBox 40 - -widebox :: (Real u, Floating u, FromPtSize u) - => String -> Point2 u -> TraceDrawing u (Box u) -widebox = makeBox 60 - - -connWith :: ( Real u, Floating u, FromPtSize u ) - => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u) -connWith arrh b0 b1 = do - lw <- getLineWidth - let p0 = south b0 - let p1 = northwards (realToFrac lw) b1 - drawi $ apply2R2 (strokeConnector (rightArrow connLine arrh)) p0 p1 - -infixr 4 `cmandatory`, `coptional`, `cmandatory_`, `coptional_` - -cmandatory :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u (Path u) -cmandatory = connWith diskTip - -coptional :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u (Path u) -coptional = connWith odiskTip - - -cmandatory_ :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u () -cmandatory_ p0 p1 = connWith diskTip p0 p1 >> return () - -coptional_ :: ( Real u, Floating u, FromPtSize u ) - => Box u -> Box u -> TraceDrawing u () -coptional_ p0 p1 = connWith odiskTip p0 p1 >> return () diff --git a/demo/FontDeltaPic.hs b/demo/FontDeltaPic.hs new file mode 100644 --- /dev/null +++ b/demo/FontDeltaPic.hs @@ -0,0 +1,51 @@ +{-# OPTIONS -Wall #-} + +-- Note - this demo is not really exemplary - it is only here +-- to check the compilation of Wumpus-Basic. There are more +-- impressive demos in the @Wumpus-Drawing@ package. +-- + +module FontDeltaPic where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + putStrLn $ "Note - the SVG optimization that should be used here" + putStrLn $ "has bit-rotted and is not currently in use.." + -- + let pic1 = runCtxPictureU std_attr drawing01 + writeEPS "./out/font_delta01.eps" pic1 + writeSVG "./out/font_delta01.svg" pic1 + + +std_attr :: DrawingContext +std_attr = standardContext 24 + + +drawing01 :: DCtxPicture +drawing01 = drawTracing $ mf + + +mf :: (Floating u, FromPtSize u) => TraceDrawing u () +mf = do + draw $ line1 `at` (P2 0 100) + draw $ line2 `at` (P2 0 75) + draw $ line3 `at` (P2 0 50) + draw $ line4 `at` (P2 0 25) + draw $ line5 `at` (P2 0 0) + where + line1 = textline "All the lines of this drawing" + line2 = textline "should be grouped within a SVG" + line3 = textline "g-element, from where they" + line4 = textline "inherit the font-family and" + line5 = textline "font-size attributes." + + + + diff --git a/demo/FontLoaderUtils.hs b/demo/FontLoaderUtils.hs deleted file mode 100644 --- a/demo/FontLoaderUtils.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# OPTIONS -Wall #-} - - -module FontLoaderUtils - ( - processCmdLine - , default_font_loader_help - ) where - - -import Control.Applicative -import Control.Monad -import System.Directory -import System.Console.GetOpt -import System.Environment -import System.IO.Error - - -wumpus_gs_font_dir :: String -wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR" - -wumpus_afm_font_dir :: String -wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR" - - -default_font_loader_help :: String -default_font_loader_help = unlines $ - [ "This example uses glyph metrics loaded at runtime." - , "It can use either the metrics files supplied with GhostScript," - , "or the AFM v4.1 metrics for the Core 14 fonts available from" - , "Adobe's website." - , "" - , "To use GhostScripts font metrics set the environemt variable" - , wumpus_gs_font_dir ++ " to point to the GhostScript fonts" - , "directory (e.g. /usr/share/ghostscript/fonts) or use the command" - , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS" - , "" - , "To use the Adode Core 14 font metrics download the archive from" - , "the Adobe website and set the environment variable " - , wumpus_afm_font_dir ++ " to point to it, or use the command line" - , "flag -- afm=PATH_TO_AFM_CORE14_FONTS" - ] - - -data CmdLineFlag = Help - | GS_FontDir String - | AFM_FontDir String - deriving (Eq,Ord,Show) - -processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath) -processCmdLine help_message = - let options = makeCmdLineOptions help_message in do - args <- getArgs - let (opts, _, _) = getOpt Permute options args - if Help `elem` opts then failk help_message - else succk opts - where - failk msg = putStr msg >> return (Nothing,Nothing) - succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags - - -makeCmdLineOptions :: String -> [OptDescr CmdLineFlag] -makeCmdLineOptions help_message = - [ Option ['h'] ["help"] (NoArg Help) help_message - , Option [] ["afm"] (ReqArg AFM_FontDir "DIR") "AFM v4.1 metrics dir" - , Option [] ["gs"] (ReqArg GS_FontDir "DIR") "GhoshScript font dir" - ] - - -gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) -gsFontDirectory = step - where - step (GS_FontDir p:xs) = doesDirectoryExist p >>= \check -> - if check then return (Just p) else step xs - - step (_:xs) = step xs - step [] = envLookup wumpus_gs_font_dir - - -afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) -afmFontDirectory = step - where - step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> - if check then return (Just p) else step xs - - step (_:xs) = step xs - step [] = envLookup wumpus_afm_font_dir - - -envLookup :: String -> IO (Maybe String) -envLookup name = liftM fn $ try $ getEnv name - where - fn (Left _) = Nothing - fn (Right a) = Just a - diff --git a/demo/FontPic.hs b/demo/FontPic.hs deleted file mode 100644 --- a/demo/FontPic.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# OPTIONS -Wall #-} - -module FontPic where - -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 - -import Control.Monad - -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - -- - let courier_pic = runDrawingU std_ctx courier_drawing - writeEPS "./out/font_courier.eps" courier_pic - writeSVG "./out/font_courier.svg" courier_pic - -- - let times_pic = runDrawingU std_ctx times_drawing - writeEPS "./out/font_times.eps" times_pic - writeSVG "./out/font_times.svg" times_pic - -- - let helvetica_pic = runDrawingU std_ctx helvetica_drawing - writeEPS "./out/font_helvetica.eps" helvetica_pic - writeSVG "./out/font_helvetica.svg" helvetica_pic - -- - let symbol_pic = runDrawingU std_ctx symbol_drawing - writeEPS "./out/font_symbol.eps" symbol_pic - writeSVG "./out/font_symbol.svg" symbol_pic - - -fontMsg :: FontFace -> Int -> String -fontMsg ff sz = msgF [] - where - msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt" - - -makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic -makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz) - where - upd = fillColour rgb . fontAttr ff sz - --- indian_red1 --- steel_blue - -point_sizes :: [Int] -point_sizes = [10, 12, 18, 24, 36, 48] - -positions :: [Int] -positions = [0, 12, 27, 49, 78, 122] - - -pointChain :: LocChain Int Int Double -pointChain = verticals positions - -fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double () -fontGraphic rgb ff pt = - let ps = unchain (coordinateScalingContext 1 1) $ pointChain pt in - zipWithM_ (\p1 sz -> draw $ makeLabel rgb ff sz `at` p1) ps point_sizes - - -std_ctx :: DrawingContext -std_ctx = standardContext 10 - - -fontDrawing :: [(RGBi,FontFace)] -> DDrawing -fontDrawing xs = drawTracing $ - zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps - where - ps = unchain (coordinateScalingContext 1 180) $ tableDown 4 1 - - - --------------------------------------------------------------------------------- --- Times - -times_drawing :: Drawing Double -times_drawing = - fontDrawing [ (steel_blue, times_roman) - , (indian_red1, times_italic) - , (steel_blue, times_bold) - , (indian_red1, times_bold_italic) - ] - -helvetica_drawing :: Drawing Double -helvetica_drawing = - fontDrawing [ (steel_blue, helvetica) - , (indian_red1, helvetica_oblique) - , (steel_blue, helvetica_bold) - , (indian_red1, helvetica_bold_oblique) - ] - - - --------------------------------------------------------------------------------- - -courier_drawing :: Drawing Double -courier_drawing = - fontDrawing [ (steel_blue, courier) - , (indian_red1, courier_oblique) - , (steel_blue, courier_bold) - , (indian_red1, courier_bold_oblique) - ] - - --------------------------------------------------------------------------------- - - -symbol_drawing :: Drawing Double -symbol_drawing = - fontDrawing [ (steel_blue, symbol) ] diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs deleted file mode 100644 --- a/demo/LeftRightText.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# OPTIONS -Wall #-} - --- Note - @main@ is more convoluted than would normally be --- expected as it supports both sources of glyph metrics - the --- GhostScript distribution or the Core 14 metrics from Adobe. --- --- \"Real\" applications would be expected to choose one source. --- --- I-am-not-a-lawyer, but it does look as though the Adobe font --- metrics are redistributable, the GhostScript metrics are --- seemingly redistributable under the same terms as the larger --- GhostScript distribution. --- - - -module LeftRightText where - - -import Wumpus.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 - - -import Wumpus.Core -- package: wumpus-core - -import System.Directory - - - -main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic1 = runDrawingU (makeCtx gs_metrics) text_drawing - writeEPS "./out/lr_text01.eps" pic1 - writeSVG "./out/lr_text01.svg" pic1 - -makeAfmPicture :: FilePath -> IO () -makeAfmPicture font_dir = do - putStrLn "Using AFM 4.1 metrics..." - (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] - mapM_ putStrLn msgs - let pic2 = runDrawingU (makeCtx afm_metrics) text_drawing - writeEPS "./out/lr_text02.eps" pic2 - writeSVG "./out/lr_text02.svg" pic2 - - - - -makeCtx :: GlyphMetrics -> DrawingContext -makeCtx = fontFace helvetica . metricsContext 18 - - -text_drawing :: Drawing Double -text_drawing = drawTracing $ do - 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) $ baseLeftLine "Baseline-left..." - - -cc_oneline :: BoundedLocGraphic Double -cc_oneline = - localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..." - -blank_text :: BoundedLocGraphic Double -blank_text = - localize (strokeColour dark_slate_gray) $ multiAlignCenter "" - - -left_text :: BoundedLocGraphic Double -left_text = - localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text - - -right_text :: BoundedLocGraphic Double -right_text = - localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text - -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 -dummy_text = unlines $ [ "The quick brown" - , "fox jumps over" - , "the lazy dog." - ] diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs deleted file mode 100644 --- a/demo/PetriNet.hs +++ /dev/null @@ -1,158 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --- Acknowledgment - the petri net is taken from Claus Reinke\'s --- paper /Haskell-Coloured Petri Nets/. - - -module PetriNet where - -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 - - -import System.Directory - - - - -main :: IO () -main = do - (mb_gs, mb_afm) <- processCmdLine default_font_loader_help - createDirectoryIfMissing True "./out/" - maybe gs_failk makeGSPicture $ mb_gs - maybe afm_failk makeAfmPicture $ mb_afm - where - gs_failk = putStrLn "No GhostScript font path supplied..." - afm_failk = putStrLn "No AFM v4.1 font path supplied..." - -makeGSPicture :: FilePath -> IO () -makeGSPicture font_dir = do - putStrLn "Using GhostScript metrics..." - (base_metrics, msgs) <- loadGSMetrics font_dir ["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 - tu1 <- transition 70 140 - rtw <- place 140 140 - tu2 <- transition 210 140 - w <- place 280 140 - tu3 <- transition 350 140 - res <- place 280 70 - pr <- place 0 0 - tl1 <- transition 70 0 - rtr <- place 140 0 - tl2 <- transition 210 0 - r <- place 280 0 - tl3 <- transition 350 0 - connector' (east pw) (west tu1) - connector' (east tu1) (west rtw) - connector' (east rtw) (west tu2) - connector' (east tu2) (west w) - connector' (east w) (west tu3) - connectorC 32 (north tu3) (north pw) - connector' (east pr) (west tl1) - connector' (east tl1) (west rtr) - connector' (east rtr) (west tl2) - connector' (east tl2) (west r) - connector' (east r) (west tl3) - connectorC (-32) (south tl3) (south pr) - connector' (southwest res) (northeast tl2) - connector' (northwest tl3) (southeast res) - connectorD 6 (southwest tu3) (northeast res) - connectorD (-6) (southwest tu3) (northeast res) - connectorD 6 (northwest res) (southeast tu2) - connectorD (-6) (northwest res) (southeast tu2) - draw $ lblParensParens `at` (P2 (-36) 150) - draw $ lblParensParens `at` (P2 300 60) - draw $ lblParensParensParens `at` (P2 (-52) (-14)) - draw $ lblBold "processing_w" `at` (southwards 12 pw) - draw $ lblBold "ready_to_write" `at` (southwards 12 rtw) - draw $ lblBold "writing" `at` (southwards 12 w) - draw $ lblBold' "resource" `at` (P2 300 72) - draw $ lblBold "processing_r" `at` (northwards 12 pr) - draw $ lblBold "ready_to_read" `at` (northwards 12 rtr) - draw $ lblBold "reading" `at` (northwards 12 r) - return () - -greenFill :: DrawingCtxM m => m a -> m a -greenFill = localize (fillColour lime_green) - -place :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) - => u -> u -> m (Circle u) -place x y = greenFill $ drawi $ borderedShape $ circle 14 $ P2 x y - -transition :: (Real u, Floating u, DrawingCtxM m, TraceM m, u ~ MonUnit m) - => u -> u -> m (Rectangle u) -transition x y = - greenFill $ drawi $ borderedShape $ rectangle 32 22 $ P2 x y - - - - -connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m - , Real u, Floating u, FromPtSize u ) - => Point2 u -> Point2 u -> m () -connector' 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_ $ 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_ $ apply2R2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1 - - -lblParensParens :: Num u => LocGraphic u -lblParensParens = localize (fontFace helvetica) $ textline "(),()" - -lblParensParensParens :: Num u => LocGraphic u -lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()" - - -lblBold' :: Num u => String -> LocGraphic u -lblBold' ss = localize (fontFace helvetica_bold) $ textline 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 deleted file mode 100644 --- a/demo/Symbols.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# OPTIONS -Wall #-} - -module Symbols where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Chains -import Wumpus.Drawing.Text.SafeFonts - - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Monad -import Prelude hiding ( pi, product ) - -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runDrawingU std_ctx symbols - writeEPS "./out/symbols.eps" pic1 - writeSVG "./out/symbols.svg" pic1 - - -std_ctx :: DrawingContext -std_ctx = fontFace times_roman $ standardContext 12 - - --- Because the font changes, we draw the all the symbols in one --- run and all the labels in a second run. This helps Wumpus-Core --- generate better PostScript as there are less changes to the --- /graphics state/. --- -symbols :: DDrawing -symbols = drawTracing $ do - localize (fontFace symbol) $ zipWithM_ sdraw all_letters ps - zipWithM_ ldraw all_letters ps - where - sdraw (s,_) pt = draw $ textline s `at` pt - ldraw (_,name) pt = draw $ textline name `at` pt .+^ hvec 16 - ps = unchain (coordinateScalingContext 100 20) $ tableDown 30 6 - -all_letters :: [(String, String)] -all_letters = - [ ("Α", "Alpha") - , ("Β", "Beta") - , ("Χ", "Chi") - , ("Δ", "Delta") - , ("Ε", "Epsilon") - , ("Η", "Eta") - , ("&Euro;", "Euro") - , ("Γ", "Gamma") - , ("&Ifraktur;", "Ifraktur") - , ("Ι", "Iota") - , ("Κ", "Kappa") - , ("Λ", "Lambda") - , ("Μ", "Mu") - , ("Ν", "Nu") - , ("Ω", "Omega") - , ("Ο", "Omicron") - , ("Φ", "Phi") - , ("Π", "Pi") - , ("Ψ", "Psi") - , ("&Rfraktur;", "Rfraktur") - , ("Ρ", "Rho") - , ("Σ", "Sigma") - , ("Τ", "Tau") - , ("Θ", "Theta") - , ("Υ", "Upsilon") - , ("&Upsilon1;", "Upsilon1") - , ("Ξ", "Xi") - , ("Ζ", "Zeta") - , ("ℵ", "aleph") - , ("α", "alpha") - , ("&ersand;", "ampersand") - , ("∠", "angle") - , ("&angleleft;", "angleleft") - , ("&angleright;", "angleright") - , ("&approxequal;", "approxequal") - - -- - , ("&arrowboth;", "arrowboth") - , ("&arrowdblboth;", "arrowdblboth") - , ("&arrowdbldown;", "arrowdbldown") - , ("&arrowdblleft;", "arrowdblleft") - , ("&arrowdblright;", "arrowdblright") - , ("&arrowdblup;", "arrowdblup") - , ("&arrowdown;", "arrowdown") - , ("&arrowleft;", "arrowleft") - , ("&arrowright;", "arrowright") - , ("&arrowup;", "arrowup") - , ("&asteriskmath;", "asteriskmath") - , ("&bar;", "bar") - , ("β", "beta") - , ("&braceleft;", "braceleft") - , ("&braceright;", "braceright") - , ("&bracketleft;", "bracketleft") - , ("&bracketright;", "bracketright") - , ("•", "bullet") - , ("&carriagereturn;", "carriagereturn") - , ("χ", "chi") - - -- - , ("&circlemultiply;", "circlemultiply") - , ("&circleplus;", "circleplus") - , ("&club;", "club") - , (":", "colon") - , (",", "comma") - , ("&congruent;", "congruent") - , ("©rightsans;", "copyrightsans") - , ("©rightserif;", "copyrightserif") - , ("°ree;", "degree") - , ("δ", "delta") - , ("⋄", "diamond") - , ("÷", "divide") - , ("&dotmath;", "dotmath") - , ("&eight;", "eight") - , ("&element;", "element") - , ("&ellipsis;", "ellipsis") - , ("∅", "emptyset") - , ("ε", "epsilon") - , ("&equal;", "equal") - , ("&equivalence;", "equivalence") - , ("η", "eta") - , ("&exclam;", "exclam") - , ("&existential;", "existential") - , ("&five;", "five") - , ("&florin;", "florin") - , ("&four;", "four") - , ("&fraction;", "fraction") - , ("γ", "gamma") - , ("&gradient;", "gradient") - , ("&greater;", "greater") - , ("&greaterequal;", "greaterequal") - , ("&heart;", "heart") - , ("&infinity;", "infinity") - , ("&integral;", "integral") - - -- - , ("&intersection;", "intersection") - , ("ι", "iota") - , ("κ", "kappa") - , ("λ", "lambda") - , ("&less;", "less") - , ("&lessequal;", "lessequal") - , ("&logicaland;", "logicaland") - , ("&logicalnot;", "logicalnot") - , ("&logicalor;", "logicalor") - , ("◊", "lozenge") - , ("−", "minus") - , ("&minute;", "minute") - , ("μ", "mu") - , ("&multiply;", "multiply") - , ("&nine;", "nine") - , ("¬element;", "notelement") - , ("¬equal;", "notequal") - , ("¬subset;", "notsubset") - , ("ν", "nu") - , ("&numbersign;", "numbersign") - , ("ω", "omega") - , ("&omega1;", "omega1") - , ("ο", "omicron") - , ("&one;", "one") - , ("&parenleft;", "parenleft") - , ("&parenright;", "parenright") - - -- - , ("&partialdiff;", "partialdiff") - , ("&percent;", "percent") - , (".", "period") - , ("&perpendicular;", "perpendicular") - , ("φ", "phi") - , ("&phi1;", "phi1") - , ("π", "pi") - , ("+", "plus") - , ("&plusminus;", "plusminus") - , ("&product;", "product") - , ("&propersubset;", "propersubset") - , ("&propersuperset;", "propersuperset") - , ("&proportional;", "proportional") - , ("ψ", "psi") - , ("&question;", "question") - , ("&radical;", "radical") - , ("&radicalex;", "radicalex") - , ("&reflexsubset;", "reflexsubset") - , ("&reflexsuperset;", "reflexsuperset") - , ("®istersans;", "registersans") - , ("®isterserif;", "registerserif") - , ("ρ", "rho") - - -- - , ("&second;", "second") - , ("&semicolon;", "semicolon") - , ("&seven;", "seven") - , ("σ", "sigma") - , ("&sigma1;", "sigma1") - , ("&similar;", "similar") - , ("&six;", "six") - , ("&slash;", "slash") - , ("&space;", "space") - , ("&spade;", "spade") - , ("&suchthat;", "suchthat") - , ("&summation;", "summation") - , ("τ", "tau") - , ("∴", "therefore") - , ("θ", "theta") - , ("&theta1;", "theta1") - , ("&three;", "three") - , ("&trademarksans;", "trademarksans") - , ("&trademarkserif;", "trademarkserif") - , ("&two;", "two") - , ("&underscore;", "underscore") - , ("&union;", "union") - , ("&universal;", "universal") - , ("υ", "upsilon") - , ("&weierstrass;", "weierstrass") - , ("ξ", "xi") - , ("&zero;", "zero") - , ("ζ", "zeta") - ] - diff --git a/src/Wumpus/Basic/Kernel.hs b/src/Wumpus/Basic/Kernel.hs --- a/src/Wumpus/Basic/Kernel.hs +++ b/src/Wumpus/Basic/Kernel.hs @@ -26,13 +26,11 @@ , 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.CtxPicture , module Wumpus.Basic.Kernel.Objects.Graphic , module Wumpus.Basic.Kernel.Objects.TraceDrawing ) where @@ -46,12 +44,10 @@ 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.CtxPicture 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 --- a/src/Wumpus/Basic/Kernel/Base/Anchors.hs +++ b/src/Wumpus/Basic/Kernel/Base/Anchors.hs @@ -96,7 +96,7 @@ extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u extendPtDist d p1 p2 = let v = pvec p1 p2 - ang = direction v + ang = vdirection v len = vlength v in p1 .+^ avec ang (len+d) @@ -210,7 +210,7 @@ => t1 -> t2 -> (Point2 u, Point2 u) radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) where - theta = direction $ pvec (center a) (center b) + theta = vdirection $ pvec (center a) (center b) -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs --- a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +++ b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs @@ -52,7 +52,6 @@ , displacePerpendicular - -- * Monadic drawing , MonUnit @@ -260,6 +259,9 @@ displacePerpendicular :: Floating u => u -> ThetaPointDisplace u displacePerpendicular d = \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d + + + -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs --- a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs +++ b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs @@ -65,6 +65,7 @@ -- * Combinators , at , rot + , atRot , connect , chain1 @@ -328,8 +329,8 @@ --- | Promote a function @from one argument to a Context function@ --- to an arity one @Context function@. +-- | 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: -- @@ -338,8 +339,8 @@ 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@. +-- | 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: -- @@ -350,7 +351,7 @@ --- | Apply an arity-one Context function to a single argument, +-- | Apply an arity-one Context Function to a single argument, -- downcasting it by one level, making an arity-zero Context -- function. -- @@ -362,7 +363,7 @@ apply1R1 mf r1 = CF $ \ctx -> unCF1 mf ctx r1 --- | Apply an arity-two Context function to two arguments, +-- | Apply an arity-two Context Function to two arguments, -- downcasting it by two levels, making an arity-zero Context -- function. -- @@ -373,7 +374,7 @@ 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, +-- | Apply an arity-two Context Function to one argument, -- downcasting it by one level, making an arity-one Context -- function. -- @@ -474,7 +475,7 @@ -- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context function. +-- 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. @@ -487,7 +488,7 @@ -- | Downcast a 'LocThetaCF' function by applying it to the --- supplied angle, making an arity-one Context function (a +-- supplied angle, making an arity-one Context Function (a -- 'LocCF'). -- @@ -495,8 +496,16 @@ rot = apply1R2 +-- | Downcast a 'LocThetaCF' function by applying it to the +-- supplied point and angle, making an arity-zero Context +-- Function (a 'CF'). +-- +atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a +atRot = apply2R2 + + -- | Downcast a 'ConnectorCF' function by applying it to the --- start and end point, making an arity-zero Context function +-- start and end point, making an arity-zero Context Function -- (a 'CF'). -- connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a @@ -507,7 +516,7 @@ infixr 6 `chain1` -- | /Chaining/ combinator - the /answer/ of the --- first Context function is feed to the second Context function. +-- 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 diff --git a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs --- a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs +++ b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs @@ -13,10 +13,10 @@ -- -- 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. +-- \*\* WARNING \*\* - The drawing context modules need systematic +-- naming schemes both for update functions (primaryColour, ...) +-- and for synthesized selectors (e.g. lowerxHeight). The current +-- names in @QueryDC@ and @UpdateDC@ are expected to change. -- -- -------------------------------------------------------------------------------- @@ -28,6 +28,8 @@ DrawingContext(..) , DrawingContextF + , TextMargin(..) + , standardContext , metricsContext @@ -53,7 +55,25 @@ import Control.Applicative import Data.Maybe - +-- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic. +-- DrawingContext is operated on within a Reader monad rather than +-- a State monad so \"updates\" are delineated within a @local@ +-- operation (called @localize@ in Wumpus), rather than permanent +-- until overridden as per @set@ of a State monad. +-- +-- Note - @round_corner_factor@ is only accounted for by some +-- graphic objects (certain Path objects and Shapes in +-- Wumpus-Drawing for instance). There many be many objects that +-- ignore it and are drawn only with angular corners. +-- +-- Also note - in contrast to most other drawing objects in +-- Wumpus, none of the measurement values are parameteric - +-- usually notated with the type variable @u@ in Wumpus. This is +-- so Wumpus can (potentially) support different units e.g. +-- centimeters rather than just Doubles (represening printers +-- points), though adding support for other units has a very low +-- priority. +-- data DrawingContext = DrawingContext { glyph_tables :: GlyphMetrics , fallback_metrics :: MetricsOps @@ -62,13 +82,30 @@ , stroke_colour :: RGBi -- also text colour... , fill_colour :: RGBi , line_spacing_factor :: Double + , round_corner_factor :: Double + , text_margin :: TextMargin } --- TODO - hand craft a Show instance +-- TODO - what parts of the Drawing Context should be strict? + +-- | Type synonym for DrawingContext update functions. +-- type DrawingContextF = DrawingContext -> DrawingContext +-- | The unit of Margin is always Double representing Points, e.g. +-- 1.0 is 1 Point. Margins are not scaled relative to the current +-- font size. +-- +-- The default value is 2 point. +-- +data TextMargin = TextMargin + { text_margin_x :: !Double + , text_margin_y :: !Double + } + + standardContext :: FontSize -> DrawingContext standardContext sz = DrawingContext { glyph_tables = emptyGlyphMetrics @@ -78,23 +115,19 @@ , stroke_colour = wumpus_black , fill_colour = wumpus_light_gray , line_spacing_factor = 1.2 + , round_corner_factor = 0 + , text_margin = standardTextMargin } +standardTextMargin :: TextMargin +standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 } + -- 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 - } - - + let env = standardContext sz in env { glyph_tables = bgm } wumpus_black :: RGBi diff --git a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs --- a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs +++ b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs @@ -30,6 +30,9 @@ , borderedAttr , withBorderedAttr + , getRoundCornerSize + , getTextMargin + , getLineWidth , getFontAttr , getFontSize @@ -103,6 +106,25 @@ fn <$> asksDC fill_colour <*> asksDC stroke_props <*> asksDC stroke_colour + + +-- | Vertical distance between baselines of consecutive text +-- lines. +-- +getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u +getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1) + <$> asksDC round_corner_factor + + + +-- | Vertical distance between baselines of consecutive text +-- lines. +-- +getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u) +getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep)) + <$> asksDC text_margin + where + fn d = (realToFrac d) * fromPtSize 1 diff --git a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs --- a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs +++ b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs @@ -20,176 +20,85 @@ module Wumpus.Basic.Kernel.Base.ScalingContext ( - ScalingM(..) - , ScalingContext(..) - - , Scaling - , runScaling - , ScalingT - , runScalingT + ScalingContext(..) - , regularScalingContext - , coordinateScalingContext + , scaleX + , scaleY + , scalePt + , scaleVec , unitX , unitY + , uniformScaling + , coordinateScaling ) 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... +-- | ScalingContext is a dictionary of two functions for scaling +-- in X and Y. -- -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 +scaleX :: ScalingContext ux uy u -> ux -> u +scaleX ctx ux = (scale_in_x ctx) ux +scaleY :: ScalingContext ux uy u -> uy -> u +scaleY ctx uy = (scale_in_y ctx) uy -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 +scalePt :: ScalingContext ux uy u -> ux -> uy -> Point2 u +scalePt ctx ux uy = P2 (scale_in_x ctx ux) (scale_in_y ctx uy) +scaleVec :: ScalingContext ux uy u -> ux -> uy -> Vec2 u +scaleVec ctx ux uy = V2 (scale_in_x ctx ux) (scale_in_y ctx uy) -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 +unitX :: Num ux => ScalingContext ux uy u -> u +unitX ctx = scaleX ctx 1 + +unitY :: Num uy => ScalingContext ux uy u -> u +unitY ctx = scaleY ctx 1 -------------------------------------------------------------------------------- --- 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 + +-- | Build a ScalingContext where both X and Y are scaled by the +-- same uniform step. +-- +-- The dimensions (types) of the ScalingContext are unified - the +-- output type and the input types are all the same. +-- +uniformScaling :: Num u => u -> ScalingContext u u u +uniformScaling 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 + + +-- | Build a ScalingContext for scaling Int coordinates. +-- +-- The scaling factors in X and Y can be different sizes. +--- +coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u +coordinateScaling 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 --- a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +++ b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs @@ -24,8 +24,12 @@ ( -- * Modifiers + + roundCornerFactor + , textMargin + -- ** Line widths - lineWidth + , lineWidth , thick , ultrathick , thin @@ -83,6 +87,18 @@ updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props + + + +-------------------------------------------------------------------------------- + +roundCornerFactor :: Double -> DrawingContextF +roundCornerFactor d = (\s -> s { round_corner_factor = d }) + +-- | 'textMargin' : @ xsep * ysep -> DrawingContextF @ +-- +textMargin :: Double -> Double -> DrawingContextF +textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep }) -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs b/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Geometry/Intersection.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Geometry/Paths.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# 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/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.CtxPicture +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- A Picture-with-implicit-context object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core. +-- +-- CtxPicture 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.CtxPicture + ( + + CtxPicture + , DCtxPicture + , runCtxPicture + , runCtxPictureU + , drawTracing + + , clipCtxPicture + , mapCtxPicture + + -- * 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 CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) } + +type DCtxPicture = CtxPicture Double + + +type instance DUnit (CtxPicture u) = u + + + + +runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u) +runCtxPicture ctx drw = runCF ctx (getCtxPicture drw) + + +runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u +runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df + where + fk = error "runCtxPictureU - empty CtxPicture." + + + +drawTracing :: (Real u, Floating u, FromPtSize u) + => TraceDrawing u a -> CtxPicture u +drawTracing mf = CtxPicture $ + drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) ) + + +-- Note - cannot get an answer from a TraceDrawing with this +-- CtxPicture type. There is nowhere to put the answer in the type. +-- +-- If the type was extended: +-- +-- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: 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)? +-- +-------------------------------------------------------------------------------- + +clipCtxPicture :: (Num u, Ord u) => (PrimPath u) -> CtxPicture u -> CtxPicture u +clipCtxPicture cpath = mapCtxPicture (clip cpath) + + +mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u +mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture + +instance (Real u, Floating u) => Rotate (CtxPicture u) where + rotate ang = mapCtxPicture (rotate ang) + +instance (Real u, Floating u) => RotateAbout (CtxPicture u) where + rotateAbout r pt = mapCtxPicture (rotateAbout r pt) + +instance (Num u, Ord u) => Scale (CtxPicture u) where + scale sx sy = mapCtxPicture (scale sx sy) + +instance (Num u, Ord u) => Translate (CtxPicture u) where + translate dx dy = mapCtxPicture (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) => CtxPicture u +empty_drawing = drawTracing $ return () + + + + +-------------------------------------------------------------------------------- +-- Composition operators + + +drawingConcat :: (Picture u -> Picture u -> Picture u) + -> CtxPicture u -> CtxPicture u -> CtxPicture u +drawingConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture 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 CtxPictures. +-- +-- 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) + -> CtxPicture u -> CtxPicture u + -> CtxPicture 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) => CtxPicture u -> CtxPicture u -> CtxPicture u +over = drawingConcat picOver + + + +-- | > a `under` b +-- +-- Similarly @under@ draws the first drawing behind +-- the second but move neither. +-- +under :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u +under = flip over + + + +-- | Move in both the horizontal and vertical. +-- +move :: (Num u, Ord u) => Vec2 u -> CtxPicture u -> CtxPicture u +move v = mapCtxPicture (\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) => CtxPicture u -> CtxPicture u -> CtxPicture 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) => CtxPicture u -> CtxPicture u -> CtxPicture 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) => CtxPicture u -> CtxPicture u -> CtxPicture 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) => CtxPicture u -> Point2 u -> CtxPicture u +p `atPoint` (P2 x y) = move (V2 x y) p + + + +-- | Center the picture at the supplied point. +-- +centeredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u +centeredAt d (P2 x y) = mapCtxPicture 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) => [CtxPicture u] -> CtxPicture u +zconcat [] = empty_drawing +zconcat (d:ds) = foldl' over d ds + + + + +-- | Concatenate the list pictures @xs@ horizontally. +-- +hcat :: (Real u, Floating u, FromPtSize u) => [CtxPicture u] -> CtxPicture 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) => [CtxPicture u] -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> CtxPicture u -> CtxPicture u -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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 -> [CtxPicture u] -> CtxPicture 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/Drawing.hs b/src/Wumpus/Basic/Kernel/Objects/Drawing.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Objects/Drawing.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# 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 --- a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs @@ -92,7 +92,6 @@ 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 @@ -404,6 +403,15 @@ drawWith :: (Point2 u -> PrimPath u) -> (PrimPath u -> Graphic u) -> LocGraphic u drawWith g mf = promoteR1 $ \pt -> mf (g pt) + +-- | 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 -- | Supplied point is /bottom left/. -- diff --git a/src/Wumpus/Basic/Utils/JoinList.hs b/src/Wumpus/Basic/Utils/JoinList.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Utils/JoinList.hs @@ -0,0 +1,349 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Utils.JoinList +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- A \"join list\" datatype and operations. +-- +-- A join list is implemented a binary tree, so joining two +-- lists (catenation, aka (++)) is a cheap operation. +-- +-- This constrasts with the regular list datatype which is a +-- cons list: while consing on a regular list is by nature cheap, +-- joining (++) is expensive. +-- +-------------------------------------------------------------------------------- + + +module Wumpus.Basic.Utils.JoinList + ( + -- * Join list datatype, opaque. + JoinList + + -- * Left view as per Data.Sequence + , ViewL(..) + , ViewR(..) + + -- * Conversion between join lists and regular lists + , fromList + , fromListF + , toList + , toListF + , toListM + , zipWithIntoList + + -- * Construction + , empty + , one + , cons + , snoc + , join + + -- * Basic functions + , head + , takeL + , length + + , takeWhileL + , accumMapL + , null + + + -- * Views + , viewl + , viewr + , unViewL + , unViewR + + ) where + + +import Control.Applicative hiding ( empty ) +import Control.Monad hiding ( join ) + +import Data.Foldable ( Foldable ) +import qualified Data.Foldable as F +import Data.Monoid +import Data.Traversable ( Traversable(..) ) + +import Prelude hiding ( head, take, length, mapM, null ) + +data JoinList a = Empty + | One a + | Join (JoinList a) (JoinList a) + deriving (Eq) + +data ViewL a = EmptyL | a :< (JoinList a) + deriving (Eq,Show) + +data ViewR a = EmptyR | (JoinList a) :> a + deriving (Eq,Show) + +-------------------------------------------------------------------------------- + +instance Show a => Show (JoinList a) where + showsPrec _ xs = showString "fromList " . shows (toList xs) + + +instance Monoid (JoinList a) where + mempty = Empty + mappend = join + +instance Functor JoinList where + fmap _ Empty = Empty + fmap f (One a) = One (f a) + fmap f (Join t u) = Join (fmap f t) (fmap f u) + + + +instance Foldable JoinList where + foldMap _ Empty = mempty + foldMap f (One a) = f a + foldMap f (Join t u) = F.foldMap f t `mappend` F.foldMap f u + + foldr = joinfoldr + foldl = joinfoldl + +instance Traversable JoinList where + traverse _ Empty = pure Empty + traverse f (One a) = One <$> f a + traverse f (Join t u) = Join <$> traverse f t <*> traverse f u + + mapM mf = step . viewl + where + step EmptyL = return Empty + step (x :< xs) = liftM2 cons (mf x) (step $ viewl xs) + + +-- Views + +instance Functor ViewL where + fmap _ EmptyL = EmptyL + fmap f (a :< as) = f a :< fmap f as + +instance Functor ViewR where + fmap _ EmptyR = EmptyR + fmap f (as :> a) = fmap f as :> f a + + +-------------------------------------------------------------------------------- +-- Conversion + +-- | Convert a join list to a regular list. +-- +toList :: JoinList a -> [a] +toList = joinfoldl (flip (:)) [] + + + +-- | Build a join list from a regular list. +-- +-- This builds a tall skinny list. +-- +-- WARNING - throws an error on empty list. +-- + +fromList :: [a] -> JoinList a +fromList [] = Empty +fromList [x] = One x +fromList (x:xs) = Join (One x) (fromList xs) + +fromListF :: (a -> b) -> [a] -> JoinList b +fromListF f = step + where + step [] = Empty + step [x] = One (f x) + step (x:xs) = Join (One $ f x) (step xs) + + +toListF :: (a -> b) -> JoinList a -> [b] +toListF f = ($ []) . step + where + step Empty = id + step (One x) = (\ls -> f x : ls) + step (Join t u) = step t . step u + + +toListM :: Monad m => (a -> m b) -> JoinList a -> m [b] +toListM mf = liftM ($ []) . step + where + step Empty = return id + step (One x) = mf x >>= \a -> return (\ls -> a : ls) + step (Join t u) = step t >>= \f -> step u >>= \g -> return (f . g) + + +zipWithIntoList :: (a -> b -> c) -> JoinList a -> [b] -> [c] +zipWithIntoList f jl xs0 = step (viewl jl) xs0 + where + step EmptyL _ = [] + step _ [] = [] + step (a :< as) (x:xs) = f a x : step (viewl as) xs + +-------------------------------------------------------------------------------- + + +null :: JoinList a -> Bool +null Empty = True +null _ = False + + + + +-- | Create an empty join list. +-- +empty :: JoinList a +empty = Empty + + + +-- | Create a singleton join list. +-- +one :: a -> JoinList a +one = One + + + +infixr 5 `cons` + +-- | Cons an element to the front of the join list. +-- +cons :: a -> JoinList a -> JoinList a +cons a xs = Join (One a) xs + +-- | Snoc an element to the tail of the join list. +-- +snoc :: JoinList a -> a -> JoinList a +snoc xs a = Join xs (One a) + + + + +infixr 5 `join` + +-- +join :: JoinList a -> JoinList a -> JoinList a +join Empty b = b +join a Empty = a +join a b = Join a b + + +-------------------------------------------------------------------------------- +-- Basic functions + +-- | Extract the first element of a join list - i.e. the leftmost +-- element of the left spine. An error is thrown if the list is +-- empty. +-- +-- This function performs a traversal down the left spine, so +-- unlike @head@ on regular lists this function is not performed +-- in constant time. +-- +-- This function throws a runtime error on the empty list. +-- +head :: JoinList a -> a +head Empty = error "JoinList - head called on empty list" +head (One a) = a +head (Join t _) = head t + + +takeL :: Int -> JoinList a -> JoinList a +takeL i xs | i < 1 = Empty + | otherwise = case viewl xs of + a :< rest -> cons a $ takeL (i-1) rest + EmptyL -> Empty + +length :: JoinList a -> Int +length = joinfoldr (\_ n -> n+1) 0 + + + +takeWhileL :: (a -> Bool) -> JoinList a -> JoinList a +takeWhileL test = step . viewl + where + step EmptyL = Empty + step (x :< xs) | test x = x `cons` step (viewl xs) + | otherwise = Empty + + +accumMapL :: (x -> st -> (y,st)) -> JoinList x -> st -> (JoinList y,st) +accumMapL f xs st0 = go xs st0 + where + go Empty st = (Empty,st) + go (One x) st = let (y,st') = f x st in (One y,st') + go (Join t u) st = (Join v w, st'') + where (v,st') = go t st + (w,st'') = go u st' + + + + +-- | Right-associative fold of a JoinList. +-- +joinfoldr :: (a -> b -> b) -> b -> JoinList a -> b +joinfoldr f = go + where + go e Empty = e + go e (One a) = f a e + go e (Join t u) = go (go e u) t + + +-- | Left-associative fold of a JoinList. +-- +joinfoldl :: (b -> a -> b) -> b -> JoinList a -> b +joinfoldl f = go + where + go e Empty = e + go e (One a) = f e a + go e (Join t u) = go (go e t) u + +-------------------------------------------------------------------------------- +-- Views + +-- | Access the left end of a sequence. +-- +-- Unlike the corresponing operation on Data.Sequence this is +-- not a cheap operation, the joinlist must be traversed down +-- the left spine to find the leftmost node. +-- +-- Also the traversal may involve changing the shape of the +-- underlying binary tree. +-- +viewl :: JoinList a -> ViewL a +viewl Empty = EmptyL +viewl (One a) = a :< Empty +viewl (Join t u) = step t u + where + step Empty r = viewl r + step (One a) r = a :< r + step (Join t' u') r = step t' (Join u' r) + +-- | Access the right end of a sequence. +-- +-- Unlike the corresponing operation on Data.Sequence this is +-- not a cheap operation, the joinlist must be traversed down +-- the left spine to find the leftmost node. +-- +-- Also the traversal may involve changing the shape of the +-- underlying binary tree. +-- +viewr :: JoinList a -> ViewR a +viewr Empty = EmptyR +viewr (One a) = Empty :> a +viewr (Join t u) = step t u + where + step l Empty = viewr l + step l (One a) = l :> a + step l (Join t' u') = step (Join l t') u' + + +unViewL :: ViewL a -> JoinList a +unViewL EmptyL = Empty +unViewL (x :< xs) = cons x xs + +unViewR :: ViewR a -> JoinList a +unViewR EmptyR = Empty +unViewR (xs :> x) = snoc xs x + 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,14,0) +-- > (0,15,0) -- wumpus_basic_version :: (Int,Int,Int) -wumpus_basic_version = (0,14,0) +wumpus_basic_version = (0,15,0) diff --git a/src/Wumpus/Drawing/Arrows.hs b/src/Wumpus/Drawing/Arrows.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Shim module for arrow connectors and arrowheads. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows - ( - - module Wumpus.Drawing.Arrows.Tips - , module Wumpus.Drawing.Arrows.Connectors - - ) where - -import Wumpus.Drawing.Arrows.Tips -import Wumpus.Drawing.Arrows.Connectors - - diff --git a/src/Wumpus/Drawing/Arrows/Connectors.hs b/src/Wumpus/Drawing/Arrows/Connectors.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows/Connectors.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Draw arrows. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows.Connectors - ( - - 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Arrows/Tips.hs +++ /dev/null @@ -1,505 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Arrows.Tips --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Anchor points on shapes. --- --- \*\* WARNING \*\* this module is an experiment, and may --- change significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Arrows.Tips - ( - - - Arrowhead(..) - - - , tri90 - , tri60 - , tri45 - , otri90 - , otri60 - , otri45 - - , revtri90 - , revtri60 - , revtri45 - , orevtri90 - , orevtri60 - , orevtri45 - - , barb90 - , barb60 - , barb45 - , revbarb90 - , revbarb60 - , revbarb45 - - , perp - - , bracket - - , diskTip - , odiskTip - , squareTip - , osquareTip - , diamondTip - , odiamondTip - - , curveTip - , revcurveTip - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Paths - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative - - --- | Encode an arrowhead as 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Chains --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Shim module. --- --- WARNING - very unstable. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Chains - ( - module Wumpus.Drawing.Chains.Base - , module Wumpus.Drawing.Chains.Derived - - - ) where - - -import Wumpus.Drawing.Chains.Base -import Wumpus.Drawing.Chains.Derived diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains/Base.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Chains/Derived.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Colour/SVGColours.hs +++ /dev/null @@ -1,625 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Colour/X11Colours.hs +++ /dev/null @@ -1,1282 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Dots/AnchorDots.hs +++ /dev/null @@ -1,280 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Dots/Marks.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Base.hs +++ /dev/null @@ -1,529 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Connectors.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.Connectors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Library of connector paths... --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.Connectors - ( - - ConnectorPath - , DConnectorPath - - , 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/Construction.hs +++ /dev/null @@ -1,160 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/ControlPoints.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Paths.ControlPoints --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Collection of point manufacturing functions. --- --- \*\* WARNING \*\* this module is experimental and may change --- significantly in future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Paths.ControlPoints - ( - - midpointIsosceles - , dblpointIsosceles - - , rectangleFromBasePoints - , squareFromBasePoints - , usquareFromBasePoints - - , trapezoidFromBasePoints - - , squareFromCornerPoints - - ) where - -import Wumpus.Basic.Kernel - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - - - --- | 'midpointIsosceles' : --- @ altitude * start_pt * end_pt -> mid_pt @ --- --- Triangular midpoint. --- --- @u@ is the altitude of the triangle - negative values of u --- form the triangle below the line. --- -midpointIsosceles :: (Real u, Floating u) - => u -> Point2 u -> Point2 u -> Point2 u -midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = - mid_pt .+^ avec perp_ang u - where - mid_pt = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1)) - perp_ang = (pi*0.5) + 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Paths/RoundCorners.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Shapes.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Shapes/Base.hs +++ /dev/null @@ -1,227 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Shapes/Coordinate.hs +++ /dev/null @@ -1,141 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Shapes/Derived.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/LRText.hs +++ /dev/null @@ -1,399 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/SafeFonts.hs +++ /dev/null @@ -1,167 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.SafeFonts --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Safe to use \"Core 13\" fonts that are expected to be present --- for any PostScript interpreter. --- --- Note - regrettably Symbol is not safe to use for SVG. --- --- \*\* WARNING \*\* - this module is in flux due to changes to --- Text encoding in Wumpus-Core and adding font metrics to --- Wumpus-Basic. The code here is likely to be revised. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.SafeFonts - ( - -- * Times Roman - times_roman - , times_italic - , times_bold - , times_bold_italic - - -- * Helvetica - , helvetica - , helvetica_oblique - , helvetica_bold - , helvetica_bold_oblique - - -- * Courier - , courier - , courier_oblique - , courier_bold - , courier_bold_oblique - - -- * Symbol - , symbol - - ) where - - - -import Wumpus.Core -import Wumpus.Core.Text.StandardEncoding -import Wumpus.Core.Text.Symbol - --- Supported fonts are: --- --- Times-Roman Times-Italic Times-Bold Times-BoldItalic --- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique --- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique --- Symbol - --------------------------------------------------------------------------------- --- - --- | Times-Roman --- -times_roman :: FontFace -times_roman = - FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding - --- | Times Italic --- -times_italic :: FontFace -times_italic = - FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding - --- | Times Bold --- -times_bold :: FontFace -times_bold = - FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding - --- | Times Bold Italic --- -times_bold_italic :: FontFace -times_bold_italic = FontFace "Times-BoldItalic" - "Times New Roman" - SVG_BOLD_ITALIC - standard_encoding - - --------------------------------------------------------------------------------- --- Helvetica - --- | Helvetica --- -helvetica :: FontFace -helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding - - --- | Helvetica Oblique --- -helvetica_oblique :: FontFace -helvetica_oblique = - FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding - --- | Helvetica Bold --- -helvetica_bold :: FontFace -helvetica_bold = - FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding - - --- | Helvetica Bold Oblique --- -helvetica_bold_oblique :: FontFace -helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" - "Helvetica" - SVG_BOLD_OBLIQUE - standard_encoding - - - --------------------------------------------------------------------------------- - --- | Courier --- -courier :: FontFace -courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding - --- | Courier Oblique --- -courier_oblique :: FontFace -courier_oblique = - FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding - --- | Courier Bold --- -courier_bold :: FontFace -courier_bold = - FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding - - --- | Courier Bold Oblique --- -courier_bold_oblique :: FontFace -courier_bold_oblique = FontFace "Courier-Bold-Oblique" - "Courier New" - SVG_BOLD_OBLIQUE - standard_encoding - --------------------------------------------------------------------------------- --- Symbol - --- | Symbol --- --- Note - Symbol is intentionally not supported for SVG by some --- renderers (Firefox). Chrome is fine, but the use of symbol --- should be still be avoided for web graphics. --- -symbol :: FontFace -symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding - - - - - diff --git a/src/Wumpus/Drawing/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Turtle/TurtleClass.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Turtle/TurtleClass.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Turtle.TurtleClass --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad and monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"coordinate-free\" style of drawing, some types of diagram --- are more easily expressed in the LOGO style. --- --- Note - as turtle drawing with Wumpus is a /local effect/, --- there is only one instance of TurtleM. Potentially TurtleM --- will be removed and the functions implemented directly. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Turtle.TurtleClass - ( - - Coord - - , TurtleM(..) - - , setsLoc - , setsLoc_ - - -- * movement - , resetLoc - , moveLeft - , moveRight - , moveUp - , moveDown - , nextLine - - - ) where - - - -type Coord = (Int,Int) - - -class Monad m => TurtleM m where - getLoc :: m (Int,Int) - setLoc :: (Int,Int) -> m () - getOrigin :: m (Int,Int) - setOrigin :: (Int,Int) -> m () - - - -setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a -setsLoc f = getLoc >>= \coord -> - let (a,coord') = f coord in setLoc coord' >> return a - -setsLoc_ :: TurtleM m => (Coord -> Coord) -> m () -setsLoc_ f = getLoc >>= \coord -> setLoc (f coord) - - -resetLoc :: TurtleM m => m () -resetLoc = getOrigin >>= setLoc - - -moveRight :: TurtleM m => m () -moveRight = setsLoc_ $ \(x,y)-> (x+1, y) - - -moveLeft :: TurtleM m => m () -moveLeft = setsLoc_ $ \(x,y) -> (x-1,y) - -moveUp :: TurtleM m => m () -moveUp = setsLoc_ $ \(x,y) -> (x,y+1) - -moveDown :: TurtleM m => m () -moveDown = setsLoc_ $ \(x,y) -> (x ,y-1) - - -nextLine :: TurtleM m => m () -nextLine = getOrigin >>= \(ox,_) -> - setsLoc_ $ \(_,y) -> (ox,y-1) - diff --git a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Turtle.TurtleMonad --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Turtle monad transformer. --- --- The Turtle monad embodies the LOGO style of imperative --- drawing - sending commands to update the a cursor. --- --- While Wumpus generally aims for a more compositional, --- \"coordinate-free\" style of drawing, some types of --- diagram are more easily expressed in the LOGO style. --- --- Turtle is only a transformer - it is intended to be run within --- a 'Drawing'. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Turtle.TurtleMonad - ( - -- * Re-exports - module Wumpus.Drawing.Turtle.TurtleClass - - -- * Turtle transformer - , TurtleT - , runTurtleT - - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Drawing.Turtle.TurtleClass - - - -import Control.Applicative -import Control.Monad - - --- Note - if Turtle is now just a /local effect/ monad is the --- Turtle class still needed? Afterall, there is (probably) --- only ever going to be one instance. --- - --- Turtle is a Reader / State monad --- --- The env is the horizontal and vertical move distances. --- --- The state is the current coordinate and the origin. --- - -data TurtleState = TurtleState - { _turtle_origin :: (Int,Int) - , _current_coord :: (Int,Int) - } - -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,95 +1,56 @@ name: wumpus-basic -version: 0.14.0 +version: 0.15.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley maintainer: Stephen Tetley homepage: http://code.google.com/p/copperbox/ category: Graphics -synopsis: Common drawing utilities built on wumpus-core. +synopsis: Basic objects and system code built on Wumpus-Core. description: . - \*\* WARNING \*\* - this package is sub-alpha, it was released - to Hackage prematurely and while its capabilities have improved - with subsequent updates it is arguably becoming even less stable - and more experimental (unfortunately the only thing consistent - about the API is that it consistently changes...). + Kernel code for higher-level drawing built on Wumpus-Core. + This package provides font loader code (limited to AFM font + files) and a various /drawing objects/ intended to be a + higher-level basis to make vector drawings than the primitives + (paths, text labels) provided by Wumpus-Core. . - 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/. + \*\* WARNING \*\* - this package is alpha grade and it is + strongly coupled to the package @Wumpus-Drawing@ which is + sub-alpha grade. The packages are split as it is expected they + will have different development speeds - @Wumpus-Basic@ needs + polishing and refinement; @Wumpus-Drawing@ simply needs a lot of + work to move its components from /proof-of-concept/ ideas to + being readily usable. . - NOTE - many of the demos now use font metrics. Font metrics for - the \"Core 14\" PostScript fonts are distributed as @*.afm@ - files with GhostScript in the @fonts@ directory. Wumpus expects - the GhostScript font metrics to be AFM version 2.0 files (this - matches GhostScript 8.63). Alternatively, metrics for the Core - 14 fonts are available from Adode (AFM version 4.1), see the - links below. To run the demos properly you will need one of - these sets of metrics. . - Adobe Font techinal notes: - + NOTE - the demos that were previously included are now in the + package @Wumpus-Drawing@. . - Core 14 AFM metrics: - . - 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: . - 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 - constructor @Drawing (ctx -> pt -> prim)@ rather than - partially outside it @pt -> Drawing (ctx -> prim)@. - @Drawing@ monad renamed @TraceDrawing@ and @DrawingT@ - transformer renamed @TraceDrawingT@. - . - * Rudimentary font loading added, only AFM files are supported. - . - * @Basic.Shapes.Coordinate@ re-worked. The Coordinate type is - now more like the Shapes types (excepting the intentional - difference in drawing style). + v0.14.0 to v0.15.0: + . + * Split previous @Wumpus-Basic@ package into two packages: + @Wumpus-Basic@ and @Wumpus-Drawing@. This is a pratical move + to separate the developed (although not yet polished) @Kernel@ + and @FontLoader@ code from the prototypical @Drawing@ code. . - * @Basic.Shapes.Plaintext@ removed. + * Renamed the @Drawing@ object to @CtxPicture@. Although + @CtxPicture@ is a less pleasant name, it should be less + confusing. A @CtxPicture@ is the essentially the @Picture@ + type from Wumpus-Core with an implicit context - + @ContextPicture@ is simply too long and @CtxPicture@ is + almost jibberish but the previous unrelated name @Drawing@ + was not helpful. . - * @Basic.Text.LRText@ completely redesigned. + * @Kernel.Base.ScalingContext@ has been simplified. + ScalingContexts are no longer manipulated via a custom Reader + monad or transformer as the type signatures were too unwieldy. . + * Added @TextMargin@ to the @DrawingContext@ - Wumpus-Drawing + can now calculate more appealing bounding boxes for text. . build-type: Simple stability: highly unstable @@ -98,20 +59,7 @@ extra-source-files: CHANGES, LICENSE, - demo/ArrowCircuit.hs, - demo/Arrowheads.hs, - demo/ClipPic.hs, - demo/ColourCharts.hs, - demo/ColourChartUtils.hs, - demo/Connectors.hs - demo/DotPic.hs, - demo/DrawingCompo.hs, - demo/FeatureModel.hs, - demo/FontLoaderUtils.hs, - demo/FontPic.hs, - demo/LeftRightText.hs, - demo/PetriNet.hs, - demo/Symbols.hs + demo/FontDeltaPic.hs library hs-source-dirs: src @@ -120,7 +68,7 @@ directory >= 1.0 && < 2.0, filepath >= 1.1 && < 2.0, vector-space >= 0.6 && < 1.0, - wumpus-core == 0.41.0 + wumpus-core >= 0.42.0 && < 0.43.0 exposed-modules: @@ -134,13 +82,11 @@ 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.CtxPicture, Wumpus.Basic.Kernel.Objects.Graphic, Wumpus.Basic.Kernel.Objects.TraceDrawing, Wumpus.Basic.System.FontLoader.Afm, @@ -153,33 +99,10 @@ Wumpus.Basic.System.FontLoader.Base.GSFontMap, Wumpus.Basic.Utils.HList, Wumpus.Basic.Utils.FormatCombinators, + Wumpus.Basic.Utils.JoinList, Wumpus.Basic.Utils.ParserCombinators, Wumpus.Basic.Utils.TokenParsers, - 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 + Wumpus.Basic.VersionNumber other-modules: