diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,5 +1,27 @@ +0.11.0 to 0.12.0: + + * Changes Base types in @Basic.Graphic@. The @Graphic@ and + @Image@ types now produce (wrapped) @Primitives@, rather than + Hughes lists of @Primitives@. This means they can now be + transformed with the affine transformations. Removed the + function @ati@, it is replaced by @at@. + + * Added @Basic.Utils.Combinators@. + + * Arrowheads and Connectors reworked - Arrowheads are now a + functional type, Connectors use new Image combining + operations from @Basic.Graphic.Base@. + + * Path connectors re-worked and renamed. + + * Dot hierarchy changed - @Basic.Dots@ becomes + @Basic.Dots.AnchorDots@; @Basic.Dots.Primitive@ becomes + @Basic.Dots.Marks@. + + * @Basic.Shapes@ - internals reworked. + 0.10.0 to 0.11.0: * Reworked arrowheads and connectors - connectors are now diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -8,15 +8,20 @@ module ArrowCircuit where -import Wumpus.Basic.Anchors import Wumpus.Basic.Arrows +import Wumpus.Basic.FontLoader.AfmLoader +import Wumpus.Basic.FontLoader.GSLoader import Wumpus.Basic.Graphic import Wumpus.Basic.Paths import Wumpus.Basic.SafeFonts import Wumpus.Basic.Shapes +import Wumpus.Basic.Text.LRText import Wumpus.Core -- package: wumpus-core +import FontLoaderUtils + + import Data.AffineSpace import System.Directory @@ -24,27 +29,52 @@ main :: IO () main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help createDirectoryIfMissing True "./out/" - writeEPS_latin1 "./out/arrow_circuit.eps" pic1 - writeSVG_latin1 "./out/arrow_circuit.svg" pic1 + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." -times_ctx :: DrawingContext -times_ctx = fontface times_roman $ standardContext 11 +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + base_metrics <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] + 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 <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] + let pic1 = runDrawingU (makeCtx base_metrics) circuit_drawing + writeEPS "./out/arrow_circuit02.eps" pic1 + writeSVG "./out/arrow_circuit02.svg" pic1 + + +makeCtx :: BaseGlyphMetrics -> DrawingContext +makeCtx = fontface times_roman . metricsContext 11 + + + -- 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. -pic1 :: Picture Double -pic1 = liftToPictureU $ execDrawing times_ctx $ do - a1 <- drawi $ strokedShape $ rrectangle 12 66 30 `at` P2 0 72 +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 `at` P2 120 60 + a2 <- drawi $ strokedShape $ circle 16 $ P2 120 60 atext a2 "IF" - a3 <- drawi $ strokedShape $ circle 16 `at` P2 240 28 + a3 <- drawi $ strokedShape $ circle 16 $ P2 240 28 atext a3 "+1" - a4 <- drawi $ strokedShape $ rectangle 66 30 `at` P2 120 0 + 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) @@ -58,25 +88,24 @@ return () --- Note - conn from Basic.Graphic is now questionable... 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_ $ strokeConnector (rightArrow con tri45) p0 p1 + drawi_ $ situ2 (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 (P2 x y) = center ancr in - drawi_ $ drawText $ translate x y $ plaintext ss +atext ancr ss = let pt = center ancr in + drawi_ $ singleLineCC ss `at` pt ptext :: ( Real u, Floating u, FromPtSize u , TraceM m, DrawingCtxM m, u ~ MonUnit m ) => Point2 u -> String -> m () -ptext (P2 x y) ss = localize (fontsize 14 . fontface times_italic) $ - drawi_ $ drawText $ translate x y $ plaintext ss +ptext pt ss = localize (fontsize 14 . fontface times_italic) $ + drawi_ $ singleLineCC ss `at` pt diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -19,19 +19,12 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - demo01 - -pt2 :: Point2 Double -pt2 = P2 100 10 - - -demo01 :: IO () -demo01 = do - writeEPS_latin1 "./out/arrowheads01.eps" pic1 - writeSVG_latin1 "./out/arrowheads01.svg" pic1 + let pic1 = runDrawingU std_ctx arrow_drawing + writeEPS "./out/arrowheads01.eps" pic1 + writeSVG "./out/arrowheads01.svg" pic1 -pic1 :: Picture Double -pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ arrtable +arrow_drawing :: Drawing Double +arrow_drawing = drawTracing $ tableGraphic arrtable arrtable :: [(Arrowhead Double, Arrowhead Double)] arrtable = @@ -66,7 +59,7 @@ ] tableGraphic :: (Real u, Floating u, FromPtSize u) - => [(Arrowhead u, Arrowhead u)] -> Drawing u () + => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u () tableGraphic tips = zipWithM_ makeArrowDrawing tips ps where ps = unchain (coordinateScalingContext 120 24) $ tableDown 20 4 @@ -79,9 +72,10 @@ makeArrowDrawing :: (Real u, Floating u, FromPtSize u) - => (Arrowhead u, Arrowhead u) -> Point2 u -> Drawing u () + => (Arrowhead u, Arrowhead u) -> Point2 u + -> TraceDrawing u () makeArrowDrawing (arrl,arrr) p0 = - drawi_ $ strokeConnector (leftrightArrow connLine arrl arrr) p0 p1 + drawi_ $ situ2 (strokeConnector (leftrightArrow connLine arrl arrr)) p0 p1 where p1 = p0 .+^ hvec 100 diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -14,36 +14,38 @@ import Wumpus.Basic.Chains import Wumpus.Basic.Colour.SVGColours +import Wumpus.Basic.DrawingComposition import Wumpus.Basic.Graphic import Wumpus.Basic.Paths -import Wumpus.Basic.PictureLanguage -import Wumpus.Basic.Text.LRSymbol -import Wumpus.Basic.Text.LRText +import Wumpus.Basic.SafeFonts import Wumpus.Core -- package: wumpus-core +import Data.AffineSpace -- package: vector-space + import System.Directory main :: IO () main = do createDirectoryIfMissing True "./out/" - >> writeEPS_latin1 "./out/clip_pic.eps" pic - >> writeSVG_latin1 "./out/clip_pic.svg" pic + 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 -pic :: DPicture -pic = pic1 `nextToV` (stackOver [cpic1, cpic2, cpic3] cpic4) +big_pic :: DDrawing +big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4] fillPath :: Num u => Path u -> Graphic u fillPath = filledPath . toPrimPath -pic1 :: DPicture -pic1 = liftToPictureU $ execDrawing pic_drawing_ctx $ +pic1 :: DDrawing +pic1 = drawTracing $ localize (fillColour medium_slate_blue) $ do draw $ fillPath path01 localize (fillColour powder_blue) $ @@ -52,30 +54,29 @@ draw $ fillPath path04 -background :: RGBi -> DPicture -background rgb = liftToPictureU $ execDrawing pic_drawing_ctx $ - localize (strokeColour rgb) $ do - mapM_ iheartHaskell ps - +background :: RGBi -> DDrawing +background rgb = drawTracing $ + localize (strokeColour rgb) $ mapM_ iheartHaskell ps where ps = unchain (coordinateScalingContext 86 16) $ tableDown 18 8 -cpic1 :: DPicture -cpic1 = clip (toPrimPath path01) (background black) +cpic1 :: DDrawing +cpic1 = clipDrawing (toPrimPath path01) (background black) -cpic2 :: DPicture -cpic2 = clip (toPrimPath path02) (background medium_violet_red) +cpic2 :: DDrawing +cpic2 = clipDrawing (toPrimPath path02) (background medium_violet_red) -cpic3 :: DPicture -cpic3 = clip (toPrimPath path03) (background black) +cpic3 :: DDrawing +cpic3 = clipDrawing (toPrimPath path03) (background black) -cpic4 :: DPicture -cpic4 = clip (toPrimPath path04) (background black) +cpic4 :: DDrawing +cpic4 = clipDrawing (toPrimPath path04) (background black) -iheartHaskell :: Num u => FromPtSize u => Point2 u -> Drawing u () -iheartHaskell pt = - draw $ (execLRText $ char 'I' >> heart >> mapM_ char "Haskell") `at` pt +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 diff --git a/demo/ColourChartUtils.hs b/demo/ColourChartUtils.hs new file mode 100644 --- /dev/null +++ b/demo/ColourChartUtils.hs @@ -0,0 +1,502 @@ +{-# 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.Basic.Colour.SVGColours as SVG +import qualified Wumpus.Basic.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 --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -2,7 +2,7 @@ module ColourCharts where -import ColourDefns +import ColourChartUtils import Wumpus.Basic.Chains import Wumpus.Basic.Graphic @@ -16,33 +16,39 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - writeEPS_latin1 "./out/SVGcolours.eps" svg - writeSVG_latin1 "./out/SVGcolours.svg" svg - writeEPS_latin1 "./out/X11colours.eps" $ uniformScale 0.75 x11_portrait - writeSVG_latin1 "./out/X11colours.svg" x11_landscape + -- + 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 -svg :: Picture Double -svg = makePicture 52 all_svg_colours +draw_ctx :: DrawingContext +draw_ctx = (standardContext 9) -x11_landscape :: Picture Double -x11_landscape = makePicture 52 all_x11_colours +svg :: Drawing Double +svg = makeDrawing 52 all_svg_colours -x11_portrait :: Picture Double -x11_portrait = makePicture 72 all_x11_colours +x11_landscape :: Drawing Double +x11_landscape = makeDrawing 52 all_x11_colours -makePicture :: Int -> [(String,RGBi)] -> DPicture -makePicture row_count xs = - liftToPictureU $ execDrawing (standardContext 9) $ - tableGraphic row_count xs +x11_portrait :: Drawing Double +x11_portrait = makeDrawing 72 all_x11_colours -tableGraphic :: Int -> [(String,RGBi)] -> Drawing Double () +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 -> Drawing Double () +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/ColourDefns.hs b/demo/ColourDefns.hs deleted file mode 100644 --- a/demo/ColourDefns.hs +++ /dev/null @@ -1,502 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : ColourDefns --- 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 ColourDefns - ( - -- * Tables of all colours - all_x11_colours - , all_svg_colours - - ) where - -import qualified Wumpus.Basic.Colour.SVGColours as SVG -import qualified Wumpus.Basic.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/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -19,19 +19,14 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - demo01 + let pic1 = runDrawingU std_ctx conn_drawing + writeEPS "./out/connectors01.eps" pic1 + writeSVG "./out/connectors01.svg" pic1 -pt2 :: Point2 Double -pt2 = P2 100 10 -demo01 :: IO () -demo01 = do - writeEPS_latin1 "./out/connectors01.eps" pic1 - writeSVG_latin1 "./out/connectors01.svg" pic1 - -pic1 :: Picture Double -pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ conntable +conn_drawing :: Drawing Double +conn_drawing = drawTracing $ tableGraphic $ conntable conntable :: [ConnectorPath Double] conntable = @@ -57,7 +52,7 @@ ] tableGraphic :: (Real u, Floating u, FromPtSize u) - => [ConnectorPath u] -> Drawing u () + => [ConnectorPath u] -> TraceDrawing u () tableGraphic conns = zipWithM_ makeConnDrawing conns ps where ps = unchain (coordinateScalingContext 120 52) $ tableDown 10 6 @@ -70,9 +65,9 @@ makeConnDrawing :: (Real u, Floating u, FromPtSize u) - => ConnectorPath u -> Point2 u -> Drawing u () + => ConnectorPath u -> Point2 u -> TraceDrawing u () makeConnDrawing conn p0 = - drawi_ $ strokeConnector (dblArrow conn curveTip) p0 p1 + drawi_ $ situ2 (strokeConnector (dblArrow conn curveTip)) p0 p1 where p1 = p0 .+^ vec 100 40 diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -6,8 +6,13 @@ import Wumpus.Basic.Chains import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Dots.AnchorDots +import Wumpus.Basic.FontLoader.AfmLoader +import Wumpus.Basic.FontLoader.GSLoader import Wumpus.Basic.Graphic +import Wumpus.Basic.SafeFonts +import FontLoaderUtils + import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space @@ -15,22 +20,44 @@ import Control.Monad import System.Directory + + main :: IO () main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help createDirectoryIfMissing True "./out/" - demo01 + 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..." -pt2 :: Point2 Double -pt2 = P2 100 10 +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + base_metrics <- loadGSMetrics font_dir ["Helvetica"] + let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing + writeEPS "./out/dots01.eps" pic1 + writeSVG "./out/dots01.svg" pic1 -demo01 :: IO () -demo01 = do - writeEPS_latin1 "./out/dots01.eps" pic1 - writeSVG_latin1 "./out/dots01.svg" pic1 + -pic1 :: Picture Double -pic1 = liftToPictureU $ execDrawing std_ctx $ tableGraphic $ +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + base_metrics <- loadAfmMetrics font_dir ["Helvetica"] + let pic1 = runDrawingU (makeCtx base_metrics) dot_drawing + writeEPS "./out/dots02.eps" pic1 + writeSVG "./out/dots02.svg" pic1 + + +makeCtx :: BaseGlyphMetrics -> DrawingContext +makeCtx = fillColour peru . fontface helvetica . metricsContext 24 + + +dot_drawing :: Drawing Double +dot_drawing = drawTracing $ tableGraphic $ [ dotHLine , dotVLine , dotX @@ -52,20 +79,15 @@ tableGraphic :: (Real u, Floating u, FromPtSize u) - => [DotLocImage u] -> Drawing u () + => [DotLocImage u] -> TraceDrawing u () tableGraphic imgs = zipWithM_ makeDotDrawing imgs ps where ps = unchain (coordinateScalingContext 1 36) $ tableDown (length imgs) 1 - -std_ctx :: DrawingContext -std_ctx = fillColour peru $ standardContext 24 - - makeDotDrawing :: (Real u, Floating u, FromPtSize u) - => DotLocImage u -> Point2 u -> Drawing u () + => DotLocImage u -> Point2 u -> TraceDrawing u () makeDotDrawing dotF pt = do dashline mapM_ (\v -> drawi $ dotF `at` pt .+^ v) displacements diff --git a/demo/DrawingCompo.hs b/demo/DrawingCompo.hs new file mode 100644 --- /dev/null +++ b/demo/DrawingCompo.hs @@ -0,0 +1,152 @@ +{-# OPTIONS -Wall #-} + +module DrawingCompo where + +import Wumpus.Basic.Colour.SVGColours +import Wumpus.Basic.DrawingComposition +import Wumpus.Basic.Graphic + +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 new file mode 100644 --- /dev/null +++ b/demo/FeatureModel.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + + + +module FeatureModel where + +import Wumpus.Basic.Arrows +import Wumpus.Basic.FontLoader.AfmLoader +import Wumpus.Basic.FontLoader.GSLoader +import Wumpus.Basic.Graphic +import Wumpus.Basic.Paths +import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Shapes +import Wumpus.Basic.Text.LRText + +import Wumpus.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 <- loadGSMetrics font_dir ["Courier-Bold"] + 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 <- loadAfmMetrics font_dir ["Courier-Bold"] + let pic1 = runDrawingU (makeCtx base_metrics) feature_model + writeEPS "./out/feature_model02.eps" pic1 + writeSVG "./out/feature_model02.svg" pic1 + +makeCtx :: BaseGlyphMetrics -> DrawingContext +makeCtx = fontface courier_bold . metricsContext 18 + + +-- 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_ $ singleLineCC 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 <- lineWidth + let p0 = south b0 + let p1 = northwards (realToFrac lw) b1 + drawi $ situ2 (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/FontLoaderUtils.hs b/demo/FontLoaderUtils.hs new file mode 100644 --- /dev/null +++ b/demo/FontLoaderUtils.hs @@ -0,0 +1,95 @@ +{-# OPTIONS -Wall #-} + + +module FontLoaderUtils + ( + processCmdLine + , default_font_loader_help + ) where + + +import Control.Applicative +import Control.Monad +import System.Directory +import System.Console.GetOpt +import System.Environment +import System.IO.Error + + +wumpus_gs_font_dir :: String +wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR" + +wumpus_afm_font_dir :: String +wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR" + + +default_font_loader_help :: String +default_font_loader_help = unlines $ + [ "This example uses glyph metrics loaded at runtime." + , "It can use either the metrics files supplied with GhostScript," + , "or the AFM v4.1 metrics for the Core 14 fonts available from" + , "Adobe's website." + , "" + , "To use GhostScripts font metrics set the environemt variable" + , wumpus_gs_font_dir ++ " to point to the GhostScript fonts" + , "directory (e.g. /usr/share/ghostscript/fonts) or use the command" + , "line flag --gs=PATH_TO_GHOSTSCRIPT_FONTS" + , "" + , "To use the Adode Core 14 font metrics download the archive from" + , "the Adobe website and set the environment variable " + , wumpus_afm_font_dir ++ " to point to it, or use the command line" + , "flag -- afm=PATH_TO_AFM_CORE14_FONTS" + ] + + +data CmdLineFlag = Help + | GS_FontDir String + | AFM_FontDir String + deriving (Eq,Ord,Show) + +processCmdLine :: String -> IO (Maybe FilePath, Maybe FilePath) +processCmdLine help_message = + let options = makeCmdLineOptions help_message in do + args <- getArgs + let (opts, _, _) = getOpt Permute options args + if Help `elem` opts then failk help_message + else succk opts + where + failk msg = putStr msg >> return (Nothing,Nothing) + succk flags = (,) <$> gsFontDirectory flags <*> afmFontDirectory flags + + +makeCmdLineOptions :: String -> [OptDescr CmdLineFlag] +makeCmdLineOptions help_message = + [ Option ['h'] ["help"] (NoArg Help) help_message + , Option [] ["afm"] (ReqArg AFM_FontDir "DIR") "AFM v4.1 metrics dir" + , Option [] ["gs"] (ReqArg GS_FontDir "DIR") "GhoshScript font dir" + ] + + +gsFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) +gsFontDirectory = step + where + step (GS_FontDir p:xs) = doesDirectoryExist p >>= \check -> + if check then return (Just p) else step xs + + step (_:xs) = step xs + step [] = envLookup wumpus_gs_font_dir + + +afmFontDirectory :: [CmdLineFlag] -> IO (Maybe FilePath) +afmFontDirectory = step + where + step (AFM_FontDir p:xs) = doesDirectoryExist p >>= \check -> + if check then return (Just p) else step xs + + step (_:xs) = step xs + step [] = envLookup wumpus_afm_font_dir + + +envLookup :: String -> IO (Maybe String) +envLookup name = liftM fn $ try $ getEnv name + where + fn (Left _) = Nothing + fn (Right a) = Just a + diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -17,24 +17,32 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - writeEPS_latin1 "./out/font_courier.eps" courier_pic - writeSVG_latin1 "./out/font_courier.svg" courier_pic - writeEPS_latin1 "./out/font_times.eps" times_pic - writeSVG_latin1 "./out/font_times.svg" times_pic - writeEPS_latin1 "./out/font_helvetica.eps" helvetica_pic - writeSVG_latin1 "./out/font_helvetica.svg" helvetica_pic - writeEPS_latin1 "./out/font_symbol.eps" symbol_pic - writeSVG_latin1 "./out/font_symbol.svg" symbol_pic + -- + 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 (font_name ff) . showChar ' ' . shows sz . showString "pt" + 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) +makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz) where upd = fillColour rgb . fontsize sz . fontface ff @@ -51,7 +59,7 @@ pointChain :: LocChain Int Int Double pointChain = verticals positions -fontGraphic :: RGBi -> FontFace -> DPoint2 -> Drawing Double () +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 @@ -61,9 +69,9 @@ std_ctx = standardContext 10 -fontPicture :: [(RGBi,FontFace)] -> DPicture -fontPicture xs = liftToPictureU $ execDrawing std_ctx $ - zipWithM (\(rgb,ff) pt -> fontGraphic rgb ff pt) xs ps +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 @@ -72,17 +80,17 @@ -------------------------------------------------------------------------------- -- Times -times_pic :: Picture Double -times_pic = - fontPicture [ (steel_blue, times_roman) +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_pic :: Picture Double -helvetica_pic = - fontPicture [ (steel_blue, helvetica) +helvetica_drawing :: Drawing Double +helvetica_drawing = + fontDrawing [ (steel_blue, helvetica) , (indian_red1, helvetica_oblique) , (steel_blue, helvetica_bold) , (indian_red1, helvetica_bold_oblique) @@ -92,9 +100,9 @@ -------------------------------------------------------------------------------- -courier_pic :: Picture Double -courier_pic = - fontPicture [ (steel_blue, courier) +courier_drawing :: Drawing Double +courier_drawing = + fontDrawing [ (steel_blue, courier) , (indian_red1, courier_oblique) , (steel_blue, courier_bold) , (indian_red1, courier_bold_oblique) @@ -104,6 +112,6 @@ -------------------------------------------------------------------------------- -symbol_pic :: Picture Double -symbol_pic = - fontPicture [ (steel_blue, symbol) ] +symbol_drawing :: Drawing Double +symbol_drawing = + fontDrawing [ (steel_blue, symbol) ] diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs new file mode 100644 --- /dev/null +++ b/demo/LeftRightText.hs @@ -0,0 +1,124 @@ +{-# 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.Colour.SVGColours +import Wumpus.Basic.Dots.Marks +import Wumpus.Basic.FontLoader.GSLoader +import Wumpus.Basic.FontLoader.AfmLoader +import Wumpus.Basic.Graphic +import Wumpus.Basic.SafeFonts +import Wumpus.Basic.Text.LRText + +import 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 <- loadGSMetrics font_dir ["Helvetica"] + let pic1 = runDrawingU (makeCtx gs_metrics) text_drawing + writeEPS "./out/new_text01.eps" pic1 + writeSVG "./out/new_text01.svg" pic1 + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + afm_metrics <- loadAfmMetrics font_dir ["Helvetica"] + let pic2 = runDrawingU (makeCtx afm_metrics) text_drawing + writeEPS "./out/new_text02.eps" pic2 + writeSVG "./out/new_text02.svg" pic2 + + + + +makeCtx :: BaseGlyphMetrics -> DrawingContext +makeCtx = fontface helvetica . metricsContext 18 + + +text_drawing :: Drawing Double +text_drawing = drawTracing $ do + drawi_ $ (fn left_text) `at` P2 0 100 + drawi_ $ (fn center_text) `at` P2 200 100 + drawi_ $ (fn right_text) `at` P2 400 100 + drawi_ $ (fn blank_text) `at` P2 0 0 + drawi_ $ (fn bl_oneline) `at` P2 200 0 + drawi_ $ (fn cc_oneline) `at` P2 400 0 + + draw $ redPlus `at` P2 0 100 + draw $ redPlus `at` P2 200 100 + draw $ redPlus `at` P2 400 100 + draw $ redPlus `at` P2 0 0 + draw $ redPlus `at` P2 200 0 + draw $ redPlus `at` P2 400 0 + + where + fn = illustrateBoundedLocGraphic + +redPlus :: (Fractional u, FromPtSize u) => LocGraphic u +redPlus = localize (strokeColour red) markPlus + +bl_oneline :: BoundedLocGraphic Double +bl_oneline = + localize (strokeColour dark_slate_gray) $ singleLineBL "Baseline-left..." + + +cc_oneline :: BoundedLocGraphic Double +cc_oneline = + localize (strokeColour dark_slate_gray) $ singleLineCC "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 + + +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 --- a/demo/PetriNet.hs +++ b/demo/PetriNet.hs @@ -7,7 +7,6 @@ module PetriNet where -import Wumpus.Basic.Anchors import Wumpus.Basic.Arrows import Wumpus.Basic.Colour.SVGColours import Wumpus.Basic.Graphic -- package: wumpus-basic @@ -26,67 +25,68 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - writeEPS_latin1 "./out/petri_net.eps" petri_net - writeSVG_latin1 "./out/petri_net.svg" petri_net + let pic1 = runDrawingU (standardContext 14) petri_net + writeEPS "./out/petri_net.eps" pic1 + writeSVG "./out/petri_net.svg" pic1 -petri_net :: DPicture -petri_net = liftToPictureU $ execDrawing (standardContext 14) $ 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 () +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 `at` P2 x y +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 `at` P2 x y + greenFill $ drawi $ borderedShape $ rectangle 32 22 $ P2 x y @@ -95,32 +95,32 @@ , Real u, Floating u, FromPtSize u ) => Point2 u -> Point2 u -> m () connector' p0 p1 = - drawi_ $ strokeConnector (rightArrow connLine tri45) p0 p1 + drawi_ $ situ2 (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_ $ strokeConnector (rightArrow (connRightVHV v) tri45) p0 p1 + drawi_ $ situ2 (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_ $ strokeConnector (rightArrow (connIsosceles u) tri45) p0 p1 + drawi_ $ situ2 (strokeConnector (rightArrow (connIsosceles u) tri45)) p0 p1 lblParensParens :: Num u => LocGraphic u -lblParensParens = localize (fontface helvetica) . textline "(),()" +lblParensParens = localize (fontface helvetica) $ textline "(),()" lblParensParensParens :: Num u => LocGraphic u -lblParensParensParens = localize (fontface helvetica) . textline "(),(),()" +lblParensParensParens = localize (fontface helvetica) $ textline "(),(),()" lblBold' :: Num u => String -> LocGraphic u -lblBold' ss = localize (fontface helvetica_bold) . textline ss +lblBold' ss = localize (fontface helvetica_bold) $ textline ss lblBold :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u -lblBold ss = localize (fontface helvetica_bold) . centermonoTextline ss +lblBold ss = localize (fontface helvetica_bold) $ centermonoTextline ss diff --git a/demo/Picture.hs b/demo/Picture.hs deleted file mode 100644 --- a/demo/Picture.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# OPTIONS -Wall #-} - -module Picture where - -import Wumpus.Basic.Colour.SVGColours -import Wumpus.Basic.Graphic -import Wumpus.Basic.PictureLanguage - -import Wumpus.Core -- package: wumpus-core - -import System.Directory - - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - >> writeEPS_latin1 "./out/picture_lang.eps" pictures - >> writeSVG_latin1 "./out/picture_lang.svg" pictures - -pictures :: DPicture -pictures = vsep 12 pic1 [ pic2, pic3, pic4, pic5 - , pic6, pic7, pic8, pic9 - , pic10, pic11, pic12, pic13 ] - -pic1 :: DPicture -pic1 = picAnno pic "red `over` green `over` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ rect_red `over` rect_green `over` rect_blue - -pic2 :: DPicture -pic2 = picAnno pic "red `under` green `under` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ rect_red `under` rect_green `under` rect_blue - - -pic3 :: DPicture -pic3 = picAnno pic "red `centerOver` green `centerOver` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ - rect_red `centerOver` rect_green `centerOver` rect_blue - --- Note - nextToH only moves pictures in the horizontal. --- -pic4 :: DPicture -pic4 = picAnno pic "red `nextToH` green `nextToH` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ - rect_red `nextToH` rect_green `nextToH` rect_blue - --- Note - nextToV only moves pictures in the vertical. --- -pic5 :: DPicture -pic5 = picAnno pic "red `nextToV` green `nextToV` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ - rect_red `nextToV` rect_green `nextToV` rect_blue - - -pic6 :: DPicture -pic6 = picAnno pic "[red, green] `stackOver` blue" - where - pic :: DPicture - pic = illustrateBounds blue $ - [rect_red, rect_green] `stackOver` rect_blue - -pic7 :: DPicture -pic7 = picAnno pic "zconcat red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - zconcat rect_red [rect_green, rect_blue] - - -pic8 :: DPicture -pic8 = picAnno pic "hcat red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - hcat rect_red [rect_green, rect_blue] - -pic9 :: DPicture -pic9 = picAnno pic "vcat red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - vcat rect_red [rect_green, rect_blue] - -pic10 :: DPicture -pic10 = picAnno pic "hsep 20 red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - hsep 20 rect_red [rect_green, rect_blue] - -pic11 :: DPicture -pic11 = picAnno pic "vsep 20 red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - vsep 20 rect_red [rect_green, rect_blue] - - -pic12 :: DPicture -pic12 = picAnno pic "hcatA HTop red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - hcatA HTop rect_red [rect_green, rect_blue] - - -pic13 :: DPicture -pic13 = picAnno pic "vcatA VCenter red [green, blue]" - where - pic :: DPicture - pic = illustrateBounds blue $ - vcatA VCenter rect_red [rect_green, rect_blue] - - --------------------------------------------------------------------------------- - -pic_drawing_ctx :: DrawingContext -pic_drawing_ctx = standardContext 14 - -picAnno :: DPicture -> String -> DPicture -picAnno pic msg = alignHSep HCenter 30 pic lbl - where - lbl = liftToPictureU $ execDrawing pic_drawing_ctx $ - draw $ textline msg `at` zeroPt - - -rect_red :: DPicture -rect_red = liftToPictureU $ execDrawing pic_drawing_ctx $ - localize (fillColour indian_red) - (draw $ borderedRectangle 30 10 `at` (P2 0 10)) - -rect_green :: DPicture -rect_green = liftToPictureU $ execDrawing pic_drawing_ctx $ - localize (fillColour olive_drab) - (draw $ borderedRectangle 15 15 `at` (P2 10 10)) - - -rect_blue :: DPicture -rect_blue = liftToPictureU $ execDrawing pic_drawing_ctx $ - localize (fillColour powder_blue) - (draw $ borderedRectangle 20 30 `at` (P2 10 0)) - diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -2,10 +2,9 @@ module Symbols where +import Wumpus.Basic.Chains import Wumpus.Basic.Graphic import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Text.LRSymbol -import Wumpus.Basic.Text.LRText import Wumpus.Core -- package: wumpus-core @@ -20,242 +19,205 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - demo01 + let pic1 = runDrawingU std_ctx symbols + writeEPS "./out/symbols.eps" pic1 + writeSVG "./out/symbols.svg" pic1 -demo01 :: IO () -demo01 = do - writeEPS_latin1 "./out/symbols.eps" pic1 - writeSVG_latin1 "./out/symbols.svg" pic1 - std_ctx :: DrawingContext std_ctx = fontface times_roman $ standardContext 12 -pic1 :: DPicture -pic1 = liftToPictureU $ execDrawing std_ctx $ do - zipWithM_ mdraw letters_01 column_01 - zipWithM_ sdraw letters_01 column_01 - zipWithM_ mdraw letters_02 column_02 - zipWithM_ sdraw letters_02 column_02 - zipWithM_ mdraw letters_03 column_03 - zipWithM_ sdraw letters_03 column_03 - zipWithM_ mdraw letters_04 column_04 - zipWithM_ sdraw letters_04 column_04 - zipWithM_ mdraw letters_05 column_05 - zipWithM_ sdraw letters_05 column_05 - zipWithM_ mdraw letters_06 column_06 - zipWithM_ sdraw letters_06 column_06 +-- 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 - mdraw (_,ma) pt = draw $ execLRText ma `at` pt - sdraw (s,_) pt = draw $ textline s `at` pt .+^ hvec 16 - -letters_01 :: [(String, LRText Double ())] -letters_01 = - [ ("uAlpha", uAlpha) - , ("uBeta", uBeta) - , ("uChi", uChi) - , ("uDelta", uDelta) - , ("uEpsilon", uEpsilon) - , ("uEta", uEta) - , ("uEuro", uEuro) - , ("uGamma", uGamma) - , ("uIfraktur", uIfraktur) - , ("uIota", uIota) - , ("uKappa", uKappa) - , ("uLambda", uLambda) - , ("uMu", uMu) - , ("uNu", uNu) - , ("uOmega", uOmega) - , ("uOmicron", uOmicron) - , ("uPhi", uPhi) - , ("uPi", uPi) - , ("uPsi", uPsi) - , ("uRfraktur", uRfraktur) - , ("uRho", uRho) - , ("uSigma", uSigma) - , ("uTau", uTau) - , ("uTheta", uTheta) - , ("uUpsilon", uUpsilon) - , ("uUpsilon1", uUpsilon1) - , ("uXi", uXi) - , ("uZeta", uZeta) - , ("aleph", aleph) - , ("alpha", alpha) - , ("ampersand", ampersand) - , ("angle", angle) - , ("angleleft", angleleft) - , ("angleright", angleright) - , ("approxequal", approxequal) - ] - -letters_02 :: [(String, LRText Double ())] -letters_02 = - [ ("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", beta) - , ("braceleft", braceleft) - , ("braceright", braceright) - , ("bracketleft", bracketleft) - , ("bracketright", bracketright) - , ("bullet", bullet) - , ("carriagereturn", carriagereturn) - , ("chi", chi) - ] + 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 -letters_03 :: [(String, LRText Double ())] -letters_03 = - [ ("circlemultiply", circlemultiply) - , ("circleplus", circleplus) - , ("club", club) - , ("colon", colon) - , ("comma", comma) - , ("congruent", congruent) - , ("copyrightsans", copyrightsans) - , ("copyrightserif", copyrightserif) - , ("degree", degree) - , ("delta", delta) - , ("diamond", diamond) - , ("divide", divide) - , ("dotmath", dotmath) - , ("eight", eight) - , ("element", element) - , ("ellipsis", ellipsis) - , ("emptyset", emptyset) - , ("epsilon", epsilon) - , ("equal", equal) - , ("equivalence", equivalence) - , ("eta", eta) - , ("exclam", exclam) - , ("existential", existential) - , ("five", five) - , ("florin", florin) - , ("four", four) - , ("fraction", fraction) - , ("gamma", gamma) - , ("gradient", gradient) - , ("greater", greater) - , ("greaterequal", greaterequal) - , ("heart", heart) - , ("infinity", infinity) - , ("integral", integral) - ] +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") -letters_04 :: [(String, LRText Double ())] -letters_04 = - [ ("intersection", intersection) - , ("iota", iota) - , ("kappa", kappa) - , ("lambda", lambda) - , ("less", less) - , ("lessequal", lessequal) - , ("logicaland", logicaland) - , ("logicalnot", logicalnot) - , ("logicalor", logicalor) - , ("lozenge", lozenge) - , ("minus", minus) - , ("minute", minute) - , ("mu", mu) - , ("multiply", multiply) - , ("nine", nine) - , ("notelement", notelement) - , ("notequal", notequal) - , ("notsubset", notsubset) - , ("nu", nu) - , ("numbersign", numbersign) - , ("omega", omega) - , ("omega1", omega1) - , ("omicron", omicron) - , ("one", one) - , ("parenleft", parenleft) - , ("parenright", parenright) - ] + -- + , ("&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") -letters_05 :: [(String, LRText Double ())] -letters_05 = - [ ("partialdiff", partialdiff) - , ("percent", percent) - , ("period", period) - , ("perpendicular", perpendicular) - , ("phi", phi) - , ("phi1", phi1) - , ("pi", pi) - , ("plus", plus) - , ("plusminus", plusminus) - , ("product", product) - , ("propersubset", propersubset) - , ("propersuperset", propersuperset) - , ("proportional", proportional) - , ("psi", psi) - , ("question", question) - , ("radical", radical) - , ("radicalex", radicalex) - , ("reflexsubset", reflexsubset) - , ("reflexsuperset", reflexsuperset) - , ("registersans", registersans) - , ("registerserif", registerserif) - , ("rho", rho) - ] + -- + , ("&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") -letters_06 :: [(String, LRText Double ())] -letters_06 = - [ ("second", second) - , ("semicolon", semicolon) - , ("seven", seven) - , ("sigma", sigma) - , ("sigma1", sigma1) - , ("similar", similar) - , ("six", six) - , ("slash", slash) - , ("space", space) - , ("spade", spade) - , ("suchthat", suchthat) - , ("summation", summation) - , ("tau", tau) - , ("therefore", therefore) - , ("theta", theta) - , ("theta1", theta1) - , ("three", three) - , ("trademarksans", trademarksans) - , ("trademarkserif", trademarkserif) - , ("two", two) - , ("underscore", underscore) - , ("union", union) - , ("universal", universal) - , ("upsilon", upsilon) - , ("weierstrass", weierstrass) - , ("xi", xi) - , ("zero", zero) - , ("zeta", zeta) + -- + , ("&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") ] --- TODO - this should use a chain when the Chain API stablizes. - -column_01 :: Num u => [Point2 u] -column_01 = iterate (.+^ vvec (-16)) (P2 0 600) - -column_02 :: Num u => [Point2 u] -column_02 = iterate (.+^ vvec (-16)) (P2 100 600) - -column_03 :: Num u => [Point2 u] -column_03 = iterate (.+^ vvec (-16)) (P2 200 600) - -column_04 :: Num u => [Point2 u] -column_04 = iterate (.+^ vvec (-16)) (P2 300 600) - -column_05 :: Num u => [Point2 u] -column_05 = iterate (.+^ vvec (-16)) (P2 400 600) - -column_06 :: Num u => [Point2 u] -column_06 = iterate (.+^ vvec (-16)) (P2 500 600) diff --git a/src/Wumpus/Basic/Anchors.hs b/src/Wumpus/Basic/Anchors.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Anchors.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Anchors --- 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 or even be dropped from future revisions. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Anchors - ( - - -- * Anchors - CenterAnchor(..) - , CardinalAnchor(..) - , CardinalAnchor2(..) - , RadialAnchor(..) - - -- * extended anchor points - , northwards - , southwards - , eastwards - , westwards - , northeastwards - , southeastwards - , southwestwards - , northwestwards - - , radialConnectorPoints - - ) where - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -class CenterAnchor t where - center :: DUnit t ~ u => t -> Point2 u - --- Note - in TikZ cardinal anchors are not necessarily at the --- equivalent radial position, for instance reactangle north-east --- is the top-right corner whether or not this is incident at --- 45deg. --- - -class CardinalAnchor t where - north :: DUnit t ~ u => t -> Point2 u - south :: DUnit t ~ u => t -> Point2 u - east :: DUnit t ~ u => t -> Point2 u - west :: DUnit t ~ u => t -> Point2 u - -class CardinalAnchor2 t where - northeast :: DUnit t ~ u => t -> Point2 u - southeast :: DUnit t ~ u => t -> Point2 u - southwest :: DUnit t ~ u => t -> Point2 u - northwest :: DUnit t ~ u => t -> Point2 u - - --- | Anchor on a border that can be identified with and angle. --- -class RadialAnchor t where - radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u - - -extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u -extendPtDist d p1 p2 = let v = pvec p1 p2 - ang = direction v - len = vlength v - in p1 .+^ avec ang (len+d) - - - -northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -northwards u a = extendPtDist u (center a) (north a) - - -southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -southwards u a = extendPtDist u (center a) (south a) - -eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -eastwards u a = extendPtDist u (center a) (east a) - -westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t - , u ~ DUnit t ) - => u -> t -> Point2 u -westwards u a = extendPtDist u (center a) (west a) - - -northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -northeastwards u a = extendPtDist u (center a) (northeast a) - - -southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -southeastwards u a = extendPtDist u (center a) (southeast a) - -southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -southwestwards u a = extendPtDist u (center a) (southwest a) - -northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t - , u ~ DUnit t ) - => u -> t -> Point2 u -northwestwards u a = extendPtDist u (center a) (northwest a) - - --------------------------------------------------------------------------------- - -radialConnectorPoints :: ( Real u, Floating u - , CenterAnchor t1, RadialAnchor t1 - , CenterAnchor t2, RadialAnchor t2 - , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) - => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) - where - theta = direction $ pvec (center a) (center b) - diff --git a/src/Wumpus/Basic/Arrows/Connectors.hs b/src/Wumpus/Basic/Arrows/Connectors.hs --- a/src/Wumpus/Basic/Arrows/Connectors.hs +++ b/src/Wumpus/Basic/Arrows/Connectors.hs @@ -93,23 +93,25 @@ - strokeConnector :: (Real u, Floating u) => Connector u -> ConnectorImage u (Path u) -strokeConnector (Connector cpF opt_la opt_ra) p0 p1 = - tipEval opt_la (directionL pathc) p0 >>= \(dl,gfL) -> - tipEval opt_ra (directionR pathc) p1 >>= \(dr,gfR) -> - intoImage (pure pathc) (gfR $ gfL $ drawP $ shortenPath dl dr pathc) +strokeConnector (Connector cpF opt_la opt_ra) = + promote2 $ \p0 p1 -> let pathc = cpF p0 p1 in + tipEval opt_la p0 (directionL pathc) >>= \(dl,gfL) -> + tipEval opt_ra p1 (directionR pathc) >>= \(dr,gfR) -> + intoImage (pure pathc) (postpro (gfR . gfL) $ drawP $ shortenPath dl dr pathc) where - pathc = cpF p0 p1 drawP = openStroke . toPrimPath + -- for Paths.Base ? -- -shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u +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 @@ -129,18 +131,18 @@ -- tipEval :: Num u - => Maybe (Arrowhead u) -> Radian -> Point2 u - -> DrawingR (u, GraphicTrafoF u) -tipEval Nothing _ _ = return (0,unmarked) -tipEval (Just arw) theta pt = getArrowhead arw theta pt >>= \(dx,prim) -> - return (dx, superior $ pure prim) - + => Maybe (Arrowhead u) -> Point2 u -> Radian + -> CF (u, ArrowMark u) +tipEval Nothing _ _ = return (0,unmarked) +tipEval (Just arw) pt theta = makeMark $ unCF2 pt theta (getArrowhead arw) -unmarked :: GraphicTrafoF u +unmarked :: ArrowMark u unmarked = id +makeMark :: Image u a -> CF (a, ArrowMark u) +makeMark = postpro (\(a,prim) -> (a, superior prim)) diff --git a/src/Wumpus/Basic/Arrows/Tips.hs b/src/Wumpus/Basic/Arrows/Tips.hs --- a/src/Wumpus/Basic/Arrows/Tips.hs +++ b/src/Wumpus/Basic/Arrows/Tips.hs @@ -22,6 +22,7 @@ Arrowhead(..) + , tri90 , tri60 @@ -62,7 +63,6 @@ import Wumpus.Basic.Graphic import Wumpus.Basic.Paths -import Wumpus.Basic.Utils.Combinators import Wumpus.Core -- package: wumpus-core @@ -78,7 +78,7 @@ -- the markHeight (or halfMarkHeight) so it has to be calculated -- w.r.t. the DrawingCtx. -- -newtype Arrowhead u = Arrowhead { getArrowhead :: ThetaLocImage u u } +newtype Arrowhead u = Arrowhead { getArrowhead :: LocThetaImage u u } @@ -144,7 +144,7 @@ -} -markHeightLessLineWidth :: (Fractional u, FromPtSize u) => DrawingR u +markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u markHeightLessLineWidth = (\h lw -> h - realToFrac lw) <$> markHeight <*> lineWidth @@ -154,13 +154,16 @@ -- Its common for the rectraction not to care about the angle or -- the point and only care about the DrawingCtx. -- -noRetract :: Num u => ThetaLocDrawingR u u -noRetract = rlift2 $ pure 0 +noRetract :: Num u => LocThetaCF u u +noRetract = wrap2 0 + -------------------------------------------------------------------------------- + + -- | Tripoints takes the \*tip length\* is the mark height. -- -- This means that the 90deg tip has a tip width greater-than the @@ -168,236 +171,269 @@ -- does it). -- tripointsByAngle :: (Floating u, FromPtSize u) - => Radian -> ThetaLocDrawingR u (Point2 u, Point2 u) -tripointsByAngle triang theta pt = - (\h -> let (vupper,vlower) = triVecsByAngle h (0.5*triang) theta - in (pt .+^ vupper, pt .+^ vlower)) - <$> markHeight - + => Radian -> LocThetaCF u (Point2 u, Point2 u) +tripointsByAngle triang = markHeight >>= \h -> + raise2 $ \pt theta -> let (vup,vlo) = triVecsByAngle h (0.5*triang) theta + in (pt .+^ vup, pt .+^ vlo) + revtripointsByAngle :: (Floating u, FromPtSize u) => Radian - -> ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u) -revtripointsByAngle triang theta pt = - (\h -> let theta' = circularModulo $ pi+theta - (vupper,vlower) = triVecsByAngle h (0.5*triang) theta' - back_tip = pt .-^ avec theta h - in (back_tip .+^ vupper, back_tip, back_tip .+^ vlower) ) - <$> markHeight + -> LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByAngle triang = markHeight >>= \h -> + raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByAngle h (0.5*triang) theta' + back_tip = pt .-^ avec theta h + in (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + tripointsByDist :: (Real u, Floating u, FromPtSize u) - => ThetaLocDrawingR u (Point2 u, Point2 u) -tripointsByDist theta pt = - (\h -> let (vup,vlo) = triVecsByDist h (0.5*h) theta - in (pt .+^ vup, pt .+^ vlo)) - <$> markHeight + => LocThetaCF u (Point2 u, Point2 u) +tripointsByDist = markHeight >>= \h -> + raise2 $ \pt theta -> let (vup,vlo) = triVecsByDist h (0.5*h) theta + in (pt .+^ vup, pt .+^ vlo) + revtripointsByDist :: (Real u, Floating u, FromPtSize u) - => ThetaLocDrawingR u (Point2 u, Point2 u, Point2 u) -revtripointsByDist theta pt = - (\h -> let theta' = circularModulo $ pi+theta - (vup,vlo) = triVecsByDist h (0.5*h) theta' - back_tip = pt .-^ avec theta h - in (back_tip .+^ vup, back_tip, back_tip .+^ vlo)) - <$> markHeight + => LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByDist = markHeight >>= \h -> + raise2 $ \pt theta -> let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByDist h (0.5*h) theta' + back_tip = pt .-^ avec theta h + in (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + +bindLocTip :: LocThetaCF u a -> (a -> LocGraphic u) -> LocThetaGraphic u +bindLocTip df da = bind2 df (\a -> static2 $ da a) + +bindLocThetaTip :: LocThetaCF u a -> (a -> LocThetaGraphic u) + -> LocThetaGraphic u +bindLocThetaTip = bind2 + + + -- width = xchar_height -- filled with stroke colour! triTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u -triTLG triang drawF = tripointsByAngle triang `bindR2` \(u,v) -> - rlift1 $ \pt -> localize bothStrokeColour $ drawF $ vertexPath [pt,u,v] - - + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +triTLG triang drawF = localize bothStrokeColour $ + bindLocTip (tripointsByAngle triang) + (\(u,v) -> promote1 $ \pt -> drawF $ vertexPath [pt,u,v]) tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri90 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) filledPath) + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) filledPath) tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri60 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) filledPath) + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) filledPath) tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u tri45 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) filledPath) + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) filledPath) otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri90 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/2) closedStroke) + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/2) closedStroke) otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri60 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/3) closedStroke) + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/3) closedStroke) otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u otri45 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (triTLG (pi/4) closedStroke) - + intoLocThetaImage (dblstatic markHeight) (triTLG (pi/4) closedStroke) -- width = xchar_height -- filled with stroke colour! revtriTLG :: (Floating u, Real u, FromPtSize u) - => Radian -> (PrimPath u -> Graphic u) -> ThetaLocGraphic u -revtriTLG triang drawF = revtripointsByAngle triang `bindR2` \(u,pt,v) -> - rlift2 $ localize bothStrokeColour $ drawF $ vertexPath [u,pt,v] + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +revtriTLG triang drawF = localize bothStrokeColour $ + bindLocTip (revtripointsByAngle triang) + (\(u,pt,v) -> static1 $ drawF $ vertexPath [u,pt,v]) + revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri90 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/2) filledPath) revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri60 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/3) filledPath) revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revtri45 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/4) filledPath) orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri90 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/2) closedStroke) orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri60 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/3) closedStroke) orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u orevtri45 = Arrowhead $ - intoThetaLocImage (rlift2 markHeightLessLineWidth) + intoLocThetaImage (dblstatic markHeightLessLineWidth) (revtriTLG (pi/4) closedStroke) -barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u -barbTLG ang = tripointsByAngle ang `bindR2` \(u,v) -> - rlift1 $ \pt -> openStroke $ vertexPath [u,pt,v] +barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +barbTLG ang = + bindLocTip (tripointsByAngle ang) + (\(u,v) -> promote1 $ \pt -> openStroke $ vertexPath [u,pt,v]) + + barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb90 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/2)) +barb90 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/2)) barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb60 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/3)) +barb60 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/3)) barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u -barb45 = Arrowhead $ intoThetaLocImage noRetract (barbTLG (pi/4)) +barb45 = Arrowhead $ intoLocThetaImage noRetract (barbTLG (pi/4)) -revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> ThetaLocGraphic u -revbarbTLG ang = revtripointsByAngle ang `bindR2` \(u,pt,v) -> - rlift2 $ openStroke $ vertexPath [u,pt,v] +revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +revbarbTLG ang = + bindLocTip (revtripointsByAngle ang) + (\(u,pt,v) -> static1 $ openStroke $ vertexPath [u,pt,v]) revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb90 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/2)) + intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/2)) revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb60 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/3)) + intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/3)) revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u revbarb45 = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (revbarbTLG (pi/4)) + intoLocThetaImage (dblstatic markHeight) (revbarbTLG (pi/4)) -perpTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u -perpTLG = bindAskR2 markHalfHeight $ \hh -> - \theta pt -> let p0 = displacePerpendicular hh theta pt - p1 = displacePerpendicular (-hh) theta pt - in straightLineBetween p0 p1 +perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +perpTLG = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> openStroke $ perpPath hh pt theta +perpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +perpPath hh ctr theta = primPath p0 [lineTo p1] + where + p0 = displacePerpendicular hh theta ctr + p1 = displacePerpendicular (-hh) theta ctr + + + perp :: (Floating u, FromPtSize u) => Arrowhead u -perp = Arrowhead $ intoThetaLocImage noRetract perpTLG +perp = Arrowhead $ intoLocThetaImage noRetract perpTLG -bracketTLG :: (Floating u, FromPtSize u) => ThetaLocGraphic u -bracketTLG = bindAskR2 markHalfHeight $ \hh -> - \theta pt -> let p1 = displacePerpendicular hh theta pt - p0 = displaceParallel (-hh) theta p1 - p2 = displacePerpendicular (-hh) theta pt - p3 = displaceParallel (-hh) theta p2 - in openStroke $ vertexPath [p0,p1,p2,p3] +bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +bracketTLG = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> openStroke $ bracketPath hh pt theta +bracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +bracketPath hh pt theta = vertexPath [p0,p1,p2,p3] + where + p1 = displacePerpendicular hh theta pt + p0 = displaceParallel (-hh) theta p1 + p2 = displacePerpendicular (-hh) theta pt + p3 = displaceParallel (-hh) theta p2 + + bracket :: (Floating u, FromPtSize u) => Arrowhead u -bracket = Arrowhead $ intoThetaLocImage noRetract bracketTLG +bracket = Arrowhead $ intoLocThetaImage noRetract bracketTLG + diskTLG :: (Floating u, FromPtSize u) - => (u -> Point2 u -> Graphic u) -> ThetaLocGraphic u -diskTLG drawF = bindAskR2 markHalfHeight $ \hh -> - \theta pt -> let ctr = pt .-^ avec theta hh - in drawF hh ctr + => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u +diskTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> let ctr = pt .-^ avec theta hh + in drawF hh ctr + diskTip :: (Floating u, FromPtSize u) => Arrowhead u -diskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF) +diskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF) where - drawF r pt = localize bothStrokeColour $ filledDisk r pt + drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt odiskTip :: (Floating u, FromPtSize u) => Arrowhead u -odiskTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (diskTLG drawF) +odiskTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (diskTLG drawF) where - drawF r pt = strokedDisk r pt + drawF r pt = strokedDisk r `at` pt squareTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> ThetaLocGraphic u -squareTLG drawF = bindAskR2 markHalfHeight $ \hh -> - \theta pt -> let p0 = displacePerpendicular hh theta pt - p3 = displacePerpendicular (-hh) theta pt - p1 = displaceParallel (-2*hh) theta p0 - p2 = displaceParallel (-2*hh) theta p3 - in drawF $ vertexPath [p0,p1,p2,p3] + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +squareTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> + let p0 = displacePerpendicular hh theta pt + p3 = displacePerpendicular (-hh) theta pt + p1 = displaceParallel (-2*hh) theta p0 + p2 = displaceParallel (-2*hh) theta p3 + in drawF $ vertexPath [p0,p1,p2,p3] + squareTip :: (Floating u, FromPtSize u) => Arrowhead u -squareTip = Arrowhead $ intoThetaLocImage (rlift2 markHeight) (squareTLG drawF) +squareTip = Arrowhead $ intoLocThetaImage (dblstatic markHeight) (squareTLG drawF) where drawF = localize bothStrokeColour . filledPath osquareTip :: (Floating u, FromPtSize u) => Arrowhead u osquareTip = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) (squareTLG closedStroke) + intoLocThetaImage (dblstatic markHeight) (squareTLG closedStroke) diamondTLG :: (Floating u, FromPtSize u) - => (PrimPath u -> Graphic u) -> ThetaLocGraphic u -diamondTLG drawF = bindAskR2 markHalfHeight $ \hh -> - \theta pt -> let ctr = displaceParallel (-2*hh) theta pt - p1 = displacePerpendicular hh theta ctr - p3 = displacePerpendicular (-hh) theta ctr - p2 = displaceParallel (-4*hh) theta pt - in drawF $ vertexPath [pt,p1,p2,p3] + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +diamondTLG drawF = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> + let ctr = displaceParallel (-2*hh) theta pt + p1 = displacePerpendicular hh theta ctr + p3 = displacePerpendicular (-hh) theta ctr + p2 = displaceParallel (-4*hh) theta pt + in drawF $ vertexPath [pt,p1,p2,p3] diamondTip :: (Floating u, FromPtSize u) => Arrowhead u diamondTip = Arrowhead $ - intoThetaLocImage (rlift2 $ fmap (2*) markHeightLessLineWidth) + intoLocThetaImage (dblstatic $ fmap (2*) markHeightLessLineWidth) (diamondTLG drawF) where drawF = localize bothStrokeColour . filledPath @@ -405,40 +441,45 @@ odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u odiamondTip = Arrowhead $ - intoThetaLocImage (rlift2 $ fmap (2*) markHeight) (diamondTLG closedStroke) + intoLocThetaImage (dblstatic $ fmap (2*) markHeight) (diamondTLG closedStroke) + -- Note - points flipped to get the second trapezium to -- draw /underneath/. -- -curveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u -curveTLG theta pt = - markHalfHeight >>= \hh -> - tripointsByDist theta pt >>= \(tup,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt - tpath = curve tup u2 u1 pt `append` curve pt l1 l2 tlo - in localize (joinRound . capRound) - (openStroke $ toPrimPath $ tpath) +curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +curveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> + unLocTheta pt theta tripointsByDist >>= \(tup,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt + tpath = curve tup u2 u1 pt `append` curve pt l1 l2 tlo + in localize (joinRound . capRound) + (openStroke $ toPrimPath $ tpath) + curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u curveTip = Arrowhead $ - intoThetaLocImage (rlift2 $ fmap realToFrac lineWidth) curveTLG + intoLocThetaImage (dblstatic $ fmap realToFrac lineWidth) curveTLG -- Note - points flipped to get the second trapezium to -- draw /underneath/. -- -revcurveTLG :: (Real u, Floating u, FromPtSize u) => ThetaLocGraphic u -revcurveTLG theta pt = - markHalfHeight >>= \hh -> - revtripointsByDist theta pt >>= \(tup,p1,tlo) -> - let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup - (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 - tpath = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo - in localize (joinRound . capRound) - (openStroke $ toPrimPath $ tpath) +revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +revcurveTLG = bindLocThetaTip (dblstatic markHalfHeight) fn + where + fn hh = promote2 $ \pt theta -> + unLocTheta pt theta revtripointsByDist >>= \(tup,p1,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 + tpath = curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo + in localize (joinRound . capRound) + (openStroke $ toPrimPath $ tpath) revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u revcurveTip = Arrowhead $ - intoThetaLocImage (rlift2 markHeight) revcurveTLG + intoLocThetaImage (dblstatic markHeight) revcurveTLG + diff --git a/src/Wumpus/Basic/Dots/AnchorDots.hs b/src/Wumpus/Basic/Dots/AnchorDots.hs --- a/src/Wumpus/Basic/Dots/AnchorDots.hs +++ b/src/Wumpus/Basic/Dots/AnchorDots.hs @@ -54,17 +54,15 @@ ) where -import Wumpus.Basic.Anchors import Wumpus.Basic.Dots.Marks import Wumpus.Basic.Graphic -import Wumpus.Basic.Utils.Combinators +import Wumpus.Basic.Text.LRText import Wumpus.Basic.Utils.Intersection import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space -import Control.Applicative -- An existential thing that supports anchors. @@ -139,9 +137,15 @@ fn theta = maybe ctr id $ findIntersect ctr theta $ rectangleLines ctr hw hh +bboxRectAnchor :: (Real u, Floating u) => BoundingBox u -> DotAnchor u +bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) = + let hw = 0.5 * (x2 - x1) + hh = 0.5 * (y2 - y1) + in rectangleAnchor hw hh (bl .+^ vec hw hh) + rectangleLDO :: (Real u, Floating u) - => u -> u -> LocDrawingR u (DotAnchor u) -rectangleLDO w h pt = pure $ rectangleAnchor (w*0.5) (h*0.5) pt + => u -> u -> LocDrawingInfo u (DotAnchor u) +rectangleLDO w h = promote1 $ \pt -> wrap $ rectangleAnchor (w*0.5) (h*0.5) pt circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u @@ -149,8 +153,9 @@ (\theta -> ctr .+^ (avec theta rad)) (radialCardinal rad ctr) -circleLDO :: (Floating u, FromPtSize u) => LocDrawingR u (DotAnchor u) -circleLDO pt = (\diam -> circleAnchor (diam * 0.5) pt) <$> markHeight +circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u) +circleLDO = bind1 (static1 markHeight) $ \diam -> + promote1 $ \pt -> wrap $ circleAnchor (diam * 0.5) pt @@ -162,16 +167,23 @@ dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u -dotChar ch = bindAsk (monoTextDimensions [ch]) $ \(w,h) -> - intoLocImage (rectangleLDO w h) (markChar ch) +dotChar ch = dotText [ch] +-- | Note - dots now use font metrics... +-- dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u -dotText ss = bindAsk (monoTextDimensions ss) $ \(w,h) -> - intoLocImage (rectangleLDO w h) (markText ss) +dotText ss = locImageMapL bboxRectAnchor (singleLineCC ss) +-- Is this generally useful? ... +-- +locImageMapL :: (a -> b) -> LocImage u a -> LocImage u b +locImageMapL f = postpro1 $ \(a,prim) -> (f a, prim) + + + dotHLine :: (Floating u, FromPtSize u) => DotLocImage u dotHLine = intoLocImage circleLDO markHLine @@ -202,7 +214,7 @@ dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u -dotSquare = bindAsk markHeight $ \ h -> +dotSquare = bind1 (static1 markHeight) $ \ h -> intoLocImage (rectangleLDO h h) markSquare diff --git a/src/Wumpus/Basic/Dots/Marks.hs b/src/Wumpus/Basic/Dots/Marks.hs --- a/src/Wumpus/Basic/Dots/Marks.hs +++ b/src/Wumpus/Basic/Dots/Marks.hs @@ -48,7 +48,7 @@ import Wumpus.Basic.Graphic -import Wumpus.Basic.Utils.Combinators +import Wumpus.Basic.Text.LRText import Wumpus.Core -- package: wumpus-core @@ -81,7 +81,7 @@ shiftOrigin :: Num u => u -> u -> LocGraphic u -> LocGraphic u -shiftOrigin dx dy f = \pt -> f (displace dx dy pt) +shiftOrigin dx dy = prepro1 (displace dx dy) markChar :: (Fractional u, Ord u, FromPtSize u) => Char -> LocGraphic u markChar ch = markText [ch] @@ -90,7 +90,7 @@ markText :: (Fractional u, Ord u, FromPtSize u) => String -> LocGraphic u -markText ss = centermonoTextline ss +markText ss = postpro1 (\(_,b) -> b) $ singleLineCC ss @@ -103,15 +103,15 @@ markHLine :: (Fractional u, FromPtSize u) => LocGraphic u -markHLine = bindAsk markHeight $ \h -> axialLine (hvec h) +markHLine = bind1 (static1 markHeight) $ \h -> axialLine (hvec h) markVLine :: (Fractional u, FromPtSize u) => LocGraphic u -markVLine = bindAsk markHeight $ \h -> axialLine (vvec h) +markVLine = bind1 (static1 markHeight) $ \h -> axialLine (vvec h) markX :: (Fractional u, FromPtSize u) => LocGraphic u -markX = bindAsk markHeight $ \h -> +markX = bind1 (static1 markHeight) $ \h -> let w = 0.75 * h in axialLine (vec w h) `oplus` axialLine (vec (-w) h) @@ -121,7 +121,7 @@ markCross :: (Floating u, FromPtSize u) => LocGraphic u -markCross = bindAsk markHeight $ \h -> +markCross = bind1 (static1 markHeight) $ \h -> (axialLine $ avec ang h) `oplus` (axialLine $ avec (-ang) h) where ang = pi*0.25 @@ -129,23 +129,25 @@ -- needs horizontal pinch... pathDiamond :: (Fractional u, FromPtSize u) - => Point2 u -> DrawingR (PrimPath u) -pathDiamond pt = (\h -> let hh = 0.66 * h; hw = 0.5 * h - in vertexPath [dvs hh, dve hw,dvn hh, dvw hw]) - <$> markHeight - where - dvs hh = pt .+^ vvec (-hh) - dve hw = pt .+^ hvec hw - dvn hh = pt .+^ vvec hh - dvw hw = pt .+^ hvec (-hw) + => LocCF u (PrimPath u) +pathDiamond = bind1 (static1 markHeight) $ \h -> promote1 $ \pt -> + let hh = 0.66 * h; hw = 0.5 * h + s = pt .+^ vvec (-hh) + e = pt .+^ hvec hw + n = pt .+^ vvec hh + w = pt .+^ hvec (-hw) + in pure $ vertexPath [s,e,n,w] +-- closedStroke :: (a -> ctx -> prim) +-- pathDiamond :: (ctx -> pt -> a) +-- ans :: (ctx -> pt -> prim) markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markDiamond = pathDiamond `bindInto` closedStroke +markDiamond = pathDiamond `bind1` (static1 . closedStroke) markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markFDiamond = pathDiamond `bindInto` filledPath +markFDiamond = pathDiamond `bind1` (static1 . filledPath) -- Note - the (const . fn) composition doesn\'t /tell/ much about @@ -156,43 +158,43 @@ -- markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u -markBDiamond = pathDiamond `bindInto` borderedPath +markBDiamond = pathDiamond `bind1` (static1 . borderedPath) -- | Note disk is filled. -- markDisk :: (Fractional u, FromPtSize u) => LocGraphic u -markDisk = bindAsk markHalfHeight filledDisk +markDisk = bind1 (static1 markHalfHeight) filledDisk markSquare :: (Fractional u, FromPtSize u) => LocGraphic u -markSquare = bindAsk markHeight $ \h -> +markSquare = bind1 (static1 markHeight) $ \h -> let d = 0.5*(-h) in shiftOrigin d d $ strokedRectangle h h markCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markCircle = bindAsk markHalfHeight strokedDisk +markCircle = bind1 (static1 markHalfHeight) strokedDisk markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u -markBCircle = bindAsk markHalfHeight borderedDisk +markBCircle = bind1 (static1 markHalfHeight) borderedDisk markPentagon :: (Floating u, FromPtSize u) => LocGraphic u -markPentagon = bindAsk markHeight $ \h -> - closedStroke . vertexPath . polygonPoints 5 (0.5*h) +markPentagon = bind1 (static1 markHeight) $ \h -> + promote1 $ \pt -> closedStroke $ vertexPath $ polygonPoints 5 (0.5*h) pt markStar :: (Floating u, FromPtSize u) => LocGraphic u -markStar pt = markHeight >>= \h -> - let ps = polygonPoints 5 (0.5*h) pt in step $ map fn ps +markStar = bind1 (static1 markHeight) $ \h -> + promote1 $ \pt -> let ps = polygonPoints 5 (0.5*h) pt in step $ map (fn pt) ps where - fn p1 = openStroke $ path pt [lineTo p1] + fn st p1 = openStroke $ primPath st [lineTo p1] step (x:xs) = oconcat x xs step _ = error "markStar - unreachable" @@ -200,7 +202,7 @@ -- Note - relies on the functional instance of OPlus markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u -markAsterisk = bindAsk markHeight $ \h -> +markAsterisk = bind1 (static1 markHeight) $ \h -> lineF1 h `oplus` lineF2 h `oplus` lineF3 h where ang = (pi*2) / 6 diff --git a/src/Wumpus/Basic/DrawingComposition.hs b/src/Wumpus/Basic/DrawingComposition.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/DrawingComposition.hs @@ -0,0 +1,458 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.DrawingComposition +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Composition operators for Drawings. +-- +-- Note - some operations can produce empty drawings... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.DrawingComposition + ( + -- * Composition + over + , under + + , centric + , nextToH + , nextToV + + , atPoint + , centeredAt + + , zconcat + + , hcat + , vcat + + + , hspace + , vspace + , hsep + , vsep + + -- * Compose with alignment + , alignH + , alignV + , alignHSep + , alignVSep + , hcatA + , vcatA + , hsepA + , vsepA + + + ) where + +import Wumpus.Basic.Graphic + +import Wumpus.Core -- package: wumpus-core + +import Data.AdditiveGroup +import Data.AffineSpace + +import Data.List ( foldl' ) + + + +-------------------------------------------------------------------------------- +-- Extract anchors + +boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a +boundaryExtr f = f . boundary + +-- Operations on bounds + +-- | The center of a picture. +-- +boundaryCenter :: Fractional u => Picture u -> Point2 u +boundaryCenter = boundaryExtr center + + + +-- | Extract the mid point of the top edge. +-- +boundaryN :: Fractional u => Picture u -> Point2 u +boundaryN = boundaryExtr north + +-- | Extract the mid point of the bottom edge. +-- +boundaryS :: Fractional u => Picture u -> Point2 u +boundaryS = boundaryExtr south + +-- | Extract the mid point of the left edge. +-- +boundaryE :: Fractional u => Picture u -> Point2 u +boundaryE = boundaryExtr east + +-- | Extract the mid point of the right edge. +-- +boundaryW :: Fractional u => Picture u -> Point2 u +boundaryW = boundaryExtr west + + +-- | Extract the top-left corner. +-- +boundaryNW :: Fractional u => Picture u -> Point2 u +boundaryNW = boundaryExtr northwest + +-- | Extract the top-right corner. +-- +boundaryNE :: Picture u -> Point2 u +boundaryNE = boundaryExtr ur_corner + +-- | Extract the bottom-left corner. +-- +boundarySW :: Picture u -> Point2 u +boundarySW = boundaryExtr ll_corner + +-- | Extract the bottom-right corner. +-- +boundarySE :: Fractional u => Picture u -> Point2 u +boundarySE = boundaryExtr southeast + + +boundaryLeftEdge :: Picture u -> u +boundaryLeftEdge = boundaryExtr (point_x . ll_corner) + +boundaryRightEdge :: Picture u -> u +boundaryRightEdge = boundaryExtr (point_x . ur_corner) + +boundaryBottomEdge :: Picture u -> u +boundaryBottomEdge = boundaryExtr (point_y . ll_corner) + + +boundaryTopEdge :: Picture u -> u +boundaryTopEdge = boundaryExtr (point_y . ur_corner) + + + + + +-- Note - do not export the empty drawing. It is easier to +-- pretend it doesn't exist. +-- +empty_drawing :: (Real u, Floating u, FromPtSize u) => Drawing u +empty_drawing = drawTracing $ return () + + + +-------------------------------------------------------------------------------- +-- Composition operators + +-- Note - the megaCombR operator is in some way an +-- /anti-combinator/. It seems easier to think about composing +-- drawings if we do work on the result Pictures directly rather +-- than build combinators to manipulate Drawings. +-- +-- The idea of combining pre- and post- operating combinators +-- makes me worry about circular programs even though I know +-- lazy evaluation allows me to write them (in some cicumstances). +-- + + +-- Picture /mega-combiner/ - moves only the second argument aka the +-- right picture. +-- +megaCombR :: (Num u, Ord u) + => (Picture u -> a) -> (Picture u -> a) + -> (a -> a -> Picture u -> Picture u) + -> Drawing u -> Drawing u + -> Drawing u +megaCombR qL qR trafoR = drawingConcat fn + where + fn pic1 pic2 = let a = qL pic1 + b = qR pic2 + p2 = trafoR a b pic2 + in pic1 `picOver` p2 + + + + +-- | > a `over` b +-- +-- Place \'drawing\' a over b. The idea of @over@ here is in +-- terms z-ordering, nither picture a or b are actually moved. +-- +over :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +over = drawingConcat picOver + + + +-- | > a `under` b +-- +-- Similarly @under@ draws the first drawing behind +-- the second but move neither. +-- +under :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +under = flip over + + + +-- | Move in both the horizontal and vertical. +-- +move :: (Num u, Ord u) => Vec2 u -> Drawing u -> Drawing u +move v = modifyDrawing (\p -> p `picMoveBy` v) + + + + +-------------------------------------------------------------------------------- +-- Composition + +infixr 5 `nextToV` +infixr 6 `nextToH`, `centric` + + + + +-- | Draw @a@, move @b@ so its center is at the same center as +-- @a@, @b@ is drawn over underneath in the zorder. +-- +-- > a `centeric` b +-- +-- +centric :: (Fractional u, Ord u) => Drawing u -> Drawing u -> Drawing u +centric = megaCombR boundaryCenter boundaryCenter moveFun + where + moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v + + + +-- | > a `nextToH` b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@. +-- +nextToH :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +nextToH = megaCombR boundaryRightEdge boundaryLeftEdge moveFun + where + moveFun a b pic = pic `picMoveBy` hvec (a - b) + + + +-- | > a `nextToV` b +-- +-- Vertical composition - move @b@, placing it below @a@. +-- +nextToV :: (Num u, Ord u) => Drawing u -> Drawing u -> Drawing u +nextToV = megaCombR boundaryBottomEdge boundaryTopEdge moveFun + where + moveFun a b drw = drw `picMoveBy` vvec (a - b) + + +-- | Place the picture at the supplied point. +-- +-- `atPoint` was previous the `at` operator. +-- +atPoint :: (Num u, Ord u) => Drawing u -> Point2 u -> Drawing u +p `atPoint` (P2 x y) = move (V2 x y) p + + + +-- | Center the picture at the supplied point. +-- +centeredAt :: (Fractional u, Ord u) => Drawing u -> Point2 u -> Drawing u +centeredAt d (P2 x y) = modifyDrawing fn d + where + fn p = let bb = boundary p + dx = x - (boundaryWidth bb * 0.5) + dy = y - (boundaryHeight bb * 0.5) + in p `picMoveBy` vec dx dy + + +-- | Concatenate the list of drawings. +-- +-- No pictures are moved. +-- +zconcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +zconcat [] = empty_drawing +zconcat (d:ds) = foldl' over d ds + + + + +-- | Concatenate the list pictures @xs@ horizontally. +-- +hcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +hcat [] = empty_drawing +hcat (d:ds) = foldl' nextToH d ds + + +-- | Concatenate the list of pictures @xs@ vertically. +-- +vcat :: (Real u, Floating u, FromPtSize u) => [Drawing u] -> Drawing u +vcat [] = empty_drawing +vcat (d:ds) = foldl' nextToV d ds + + + + +-------------------------------------------------------------------------------- + + + + +-- | > hspace n a b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ with a horizontal gap of @n@ separating the pictures. +-- +hspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u +hspace n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun + where + moveFun a b pic = pic `picMoveBy` hvec (n + a - b) + + + + + +-- | > vspace n a b +-- +-- Vertical composition - move @b@, placing it below @a@ with a +-- vertical gap of @n@ separating the pictures. +-- +vspace :: (Num u, Ord u) => u -> Drawing u -> Drawing u -> Drawing u +vspace n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun + where + moveFun a b pic = pic `picMoveBy` vvec (a - b - n) + + + +-- | > hsep n xs +-- +-- Concatenate the list of pictures @xs@ horizontally with +-- @hspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units. +-- +hsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u +hsep _ [] = empty_drawing +hsep n (d:ds) = foldl' (hspace n) d ds + + + +-- | > vsep n xs +-- +-- Concatenate the list of pictures @xs@ vertically with +-- @vspace@ starting at @x@. The pictures are interspersed with +-- spaces of @n@ units. +-- +vsep :: (Real u, Floating u, FromPtSize u) => u -> [Drawing u] -> Drawing u +vsep _ [] = empty_drawing +vsep n (d:ds) = foldl' (vspace n) d ds + + +-------------------------------------------------------------------------------- +-- Aligning pictures + +alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u +alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2) + + + +-- | > alignH align a b +-- +-- Horizontal composition - move @b@, placing it to the right +-- of @a@ and align it with the top, center or bottom of @a@. +-- +alignH :: (Fractional u, Ord u) + => HAlign -> Drawing u -> Drawing u -> Drawing u +alignH HTop = megaCombR boundaryNE boundaryNW alignMove +alignH HCenter = megaCombR boundaryE boundaryW alignMove +alignH HBottom = megaCombR boundarySE boundarySW alignMove + + +-- | > alignV align a b +-- +-- Vertical composition - move @b@, placing it below @a@ +-- and align it with the left, center or right of @a@. +-- +alignV :: (Fractional u, Ord u) + => VAlign -> Drawing u -> Drawing u -> Drawing u +alignV VLeft = megaCombR boundarySW boundaryNW alignMove +alignV VCenter = megaCombR boundaryS boundaryN alignMove +alignV VRight = megaCombR boundarySE boundaryNE alignMove + + + +alignMove2 :: (Num u, Ord u) + => Vec2 u -> Point2 u -> Point2 u -> Picture u -> Picture u +alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2)) + + + +-- | > alignHSep align sep a b +-- +-- Spacing version of alignH - move @b@ to the right of @a@ +-- separated by @sep@ units, align @b@ according to @align@. +-- +alignHSep :: (Fractional u, Ord u) + => HAlign -> u -> Drawing u -> Drawing u -> Drawing u +alignHSep HTop dx = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx)) +alignHSep HCenter dx = megaCombR boundaryE boundaryW (alignMove2 (hvec dx)) +alignHSep HBottom dx = megaCombR boundarySE boundarySW (alignMove2 (hvec dx)) + + +-- | > alignVSep align sep a b +-- +-- Spacing version of alignV - move @b@ below @a@ +-- separated by @sep@ units, align @b@ according to @align@. +-- +alignVSep :: (Fractional u, Ord u) + => VAlign -> u -> Drawing u -> Drawing u -> Drawing u +alignVSep VLeft dy = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) +alignVSep VCenter dy = megaCombR boundaryS boundaryN (alignMove2 $ vvec (-dy)) +alignVSep VRight dy = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy)) + + +-- | Variant of 'hcat' that aligns the pictures as well as +-- concatenating them. +-- +hcatA :: (Real u, Floating u, FromPtSize u) + => HAlign -> [Drawing u] -> Drawing u +hcatA _ [] = empty_drawing +hcatA ha (d:ds) = foldl' (alignH ha) d ds + + + +-- | Variant of 'vcat' that aligns the pictures as well as +-- concatenating them. +-- +vcatA :: (Real u, Floating u, FromPtSize u) + => VAlign -> [Drawing u] -> Drawing u +vcatA _ [] = empty_drawing +vcatA va (d:ds) = foldl' (alignV va) d ds + + +-- | Variant of @hsep@ that aligns the pictures as well as +-- concatenating and spacing them. +-- +hsepA :: (Real u, Floating u, FromPtSize u) + => HAlign -> u -> [Drawing u] -> Drawing u +hsepA _ _ [] = empty_drawing +hsepA ha n (d:ds) = foldl' op d ds + where + a `op` b = alignHSep ha n a b + + +-- | Variant of @vsep@ that aligns the pictures as well as +-- concatenating and spacing them. +-- +vsepA :: (Real u, Floating u, FromPtSize u) + => VAlign -> u -> [Drawing u] -> Drawing u +vsepA _ _ [] = empty_drawing +vsepA va n (d:ds) = foldl' op d ds + where + a `op` b = alignVSep va n a b + + + diff --git a/src/Wumpus/Basic/FontLoader/AfmLoader.hs b/src/Wumpus/Basic/FontLoader/AfmLoader.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/AfmLoader.hs @@ -0,0 +1,62 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.AfmLoader +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font loader for the Adobe \"Core 14\" glyph metrics. +-- +-- Use this loader if you have the Adode glyph metrics set +-- (AFM v4.1). This metrics set is avaiable from the Adobe +-- website. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.AfmLoader + ( + + module Wumpus.Basic.FontLoader.Base + , module Wumpus.Basic.FontLoader.AfmV4Dot1Parser + + , loadAfmMetrics + , afmV4Dot1Loader + + + + ) where + +import Wumpus.Basic.FontLoader.AfmV4Dot1Parser +import Wumpus.Basic.FontLoader.Base +import Wumpus.Basic.Graphic + +import Wumpus.Core -- package: wumpus-core + + + +loadAfmMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics +loadAfmMetrics font_dir_path ns = + loadBaseGlyphMetrics (afmV4Dot1Loader font_dir_path) ns + + +afmV4Dot1Loader :: FilePath -> FontLoader AfmUnit +afmV4Dot1Loader font_dir_path = + FontLoader + { unit_scale_fun = afmUnitScale + , path_to_font_dir = font_dir_path + , file_name_locator = buildName + , font_parser = parseAfmV4Dot1File + , post_process = buildGlyphMetricsTable bbox (V2 600 0) 1000 + } + where + buildName :: FontName -> FilePath + buildName font = font ++ ".afm" + + bbox = BBox (P2 (-23) (-250)) (P2 715 805) + + diff --git a/src/Wumpus/Basic/FontLoader/AfmParserBase.hs b/src/Wumpus/Basic/FontLoader/AfmParserBase.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/AfmParserBase.hs @@ -0,0 +1,215 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.AfmParserBase +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common parsers for AFM files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.AfmParserBase + ( + + afmFileParser + , runQuery + , textQuery + + , getFontBBox + , getEncodingScheme + , getCapHeight + + , charBBox + , metric + , keyStringPair + , versionNumber + , startCharMetrics + + , keyName + , newlineOrEOF + , name + , name1 + , semi + , uptoNewline + , number + , cint + , hexInt + , octInt + + , lexeme + , symbol + , integer + , int + , double + + ) where + +import Wumpus.Basic.FontLoader.Base +import Wumpus.Basic.Utils.ParserCombinators +import qualified Wumpus.Basic.Utils.TokenParsers as P + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +import Data.Char +import qualified Data.Map as Map + + + +afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile +afmFileParser pgm = do + info <- (versionNumber *> globalInfo) + cms <- (startCharMetrics *> many pgm) + let mb_encoding = getEncodingScheme info + let mb_cap = getCapHeight info + let mb_bbox = getFontBBox info + case mb_bbox of + Nothing -> throwError "No FontBBox field in the AFM file." + Just bb -> return $ AfmFile + { afm_encoding = mb_encoding + , afm_font_bbox = bb + , afm_cap_height = mb_cap + , afm_glyph_metrics = cms + } + +globalInfo :: CharParser GlobalInfo +globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) + <$> manyTill keyStringPair (peek startCharMetrics) + + + +runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a +runQuery field_name p table = + Map.lookup field_name table >>= extr . runParser p + where + extr (Okay a _) = Just a + extr _ = Nothing + +textQuery :: String -> GlobalInfo -> Maybe String +textQuery = Map.lookup + + +-- | Strictly speaking a fontBBox is measured in integer units. +-- +getFontBBox :: GlobalInfo -> Maybe AfmBoundingBox +getFontBBox = runQuery "FontBBox" fontBBox + +getEncodingScheme :: GlobalInfo -> Maybe String +getEncodingScheme = textQuery "EncodingScheme" + +getCapHeight :: GlobalInfo -> Maybe AfmUnit +getCapHeight = runQuery "CapHeight" number + + +charBBox :: CharParser AfmBoundingBox +charBBox = symbol "B" *> fontBBox <* semi + +fontBBox :: CharParser AfmBoundingBox +fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury)) + <$> number <*> number <*> number <*> number + + + +metric :: String -> a -> CharParser a -> CharParser a +metric iden dfault p = option dfault go + where + go = symbol iden *> p <* semi + + + +keyStringPair :: CharParser (AfmKey,String) +keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF + "key-value line" + +versionNumber :: CharParser String +versionNumber = + symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF + "StartFontMetrics" + + +startCharMetrics :: CharParser Int +startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF + "StartCharMetrics failed" + + + +-------------------------------------------------------------------------------- + + +keyName :: CharParser AfmKey +keyName = lexeme (many1 $ satisfy isAlphaNum) + + +newlineOrEOF :: CharParser () +newlineOrEOF = skipOne (lexeme newline) <|> eof + + +uptoNewline :: CharParser String +uptoNewline = many1 (noneOf ['\n']) + + +name :: CharParser String +name = lexeme $ many (noneOf ";\n") + +name1 :: CharParser String +name1 = lexeme $ many (noneOf "; \t\n") + + + +semi :: CharParser Char +semi = lexeme $ char ';' + + + + +number :: CharParser AfmUnit +number = liftA realToFrac double + + +cint :: CharParser Int +cint = hexInt <|> octInt <|> int + + +hexInt :: CharParser Int +hexInt = lexeme $ between (char '<') (char '>') P.hexBase + + +octInt :: CharParser Int +octInt = lexeme $ char '\\' *> P.octBase + + + +-------------------------------------------------------------------------------- + +-- no newline in whitespace + + +lp :: P.LexemeParser +lp = P.commentLineLexemeParser "Comment" [' ', '\t'] + + +lexeme :: CharParser a -> CharParser a +lexeme = P.lexeme lp + +symbol :: String -> CharParser String +symbol = lexeme . string + +-- whiteSpace :: CharParser () +-- whiteSpace = P.whiteSpace lp + + +integer :: CharParser Integer +integer = lexeme P.integer + +int :: CharParser Int +int = fromIntegral <$> integer + +double :: CharParser Double +double = lexeme P.double diff --git a/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs b/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/AfmV2Parser.hs @@ -0,0 +1,67 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.AfmV2 +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 2.0. +-- +-- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ +-- have numerous differences. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.AfmV2Parser + ( + + parseAfmV2File + + ) where + +import Wumpus.Basic.FontLoader.AfmParserBase +import Wumpus.Basic.FontLoader.Base +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + + + +-------------------------------------------------------------------------------- +-- parser + +parseAfmV2File :: FilePath -> IO (Either ParseError AfmFile) +parseAfmV2File filepath = runParserEither p <$> readFile filepath + where + p = afmFileParser charMetricsV2 + + +charMetricsV2 :: CharParser AfmGlyphMetrics +charMetricsV2 = AfmGlyphMetrics <$> + metric "C" (-1) cint + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-------------------------------------------------------------------------------- + + + + diff --git a/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/AfmV4Dot1Parser.hs @@ -0,0 +1,67 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.AfmV4Dot1Parser +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 4.1. +-- +-- Adobe distributes font metrics for the /Core 14/ fonts as +-- AFM Version 4.1 files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.AfmV4Dot1Parser + ( + + parseAfmV4Dot1File + + ) where + +import Wumpus.Basic.FontLoader.AfmParserBase +import Wumpus.Basic.FontLoader.Base +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +parseAfmV4Dot1File :: FilePath -> IO (Either ParseError AfmFile) +parseAfmV4Dot1File filepath = runParserEither p <$> readFile filepath + where + p = afmFileParser charMetricsV4Dot1 + + + +charMetricsV4Dot1 :: CharParser AfmGlyphMetrics +charMetricsV4Dot1 = AfmGlyphMetrics <$> + characterCode + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + + +-- Note - there are many variants for width vectors in in 4.1. +-- Wumpus needs some thought about what to do for them, it also +-- needs some facility to tell how successful the parse has been. + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-- V4.1 allows C int or CH \ +-- +characterCode :: CharParser Int +characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint diff --git a/src/Wumpus/Basic/FontLoader/Base.hs b/src/Wumpus/Basic/FontLoader/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/Base.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.AfmV2 +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser. +-- +-- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ +-- have numerous differences. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.Base + ( + + -- * Afm Unit + AfmUnit + , afmValue + , afmUnitScale + + -- * Glyph metrics + + , PSCharCode + , PSEncodingScheme + , AfmBoundingBox + + , AfmKey + , GlobalInfo + , AfmFile(..) + , AfmGlyphMetrics(..) + + -- * Font loading + , FontLoadErr + , FontLoadResult + , FontLoader(..) + , loadFont + + , BaseGlyphMetrics + , loadBaseGlyphMetrics + + , buildGlyphMetricsTable + + ) where + +import Wumpus.Basic.Graphic + + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + +import Data.Foldable ( foldrM ) +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Maybe + +import System.Directory +import System.FilePath + + + +-- | Wrapped Double representing 1\/1000 of the scale factor +-- (Point size) of a font. AFM files encode all measurements +-- as these units. +-- +newtype AfmUnit = AfmUnit { getAfmUnit :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + +instance Show AfmUnit where + showsPrec p d = showsPrec p (getAfmUnit d) + + +-- | Compute the size of a measurement in Afm units scaled by the +-- point size of the font. +-- +afmValue :: FromPtSize u => AfmUnit -> PtSize -> u +afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000) + +afmUnitScale :: AfmUnit -> PtSize +afmUnitScale u = (realToFrac $ getAfmUnit u / 1000) + + +-------------------------------------------------------------------------------- + +-- | Afm files index glyphs by /PostScript character code/. This +-- is not the same as Unicode, ASCII... +-- +-- It is expected to be determined by @EncodingScheme@ in the +-- Global Font Information Section. +-- +type PSCharCode = Int + +type PSEncodingScheme = String + +type AfmBoundingBox = BoundingBox AfmUnit + +type AfmKey = String +type GlobalInfo = Map.Map AfmKey String + + + +-- | Wumpus needs a very small subset of AFM files, common to both +-- version 2.0 and version 4.1. +-- +-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1 +-- +-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus +-- uses cap height in calculations, glyph metrics must be build +-- with an arbitrary value if it is not present. +-- +-- Encoding Scheme is optional in AFM files. +-- +data AfmFile = AfmFile + { afm_encoding :: Maybe String + , afm_font_bbox :: AfmBoundingBox + , afm_cap_height :: Maybe AfmUnit + , afm_glyph_metrics :: [AfmGlyphMetrics] + } + deriving (Show) + +-- Note BBox is a required field for version 4.1. + + +data AfmGlyphMetrics = AfmGlyphMetrics + { afm_char_code :: !PSCharCode + , afm_width_vector :: !(Vec2 AfmUnit) + , afm_char_name :: !String + } + deriving (Eq,Show) + + + +-- Maybe the CharMetricsTable should be scaled to Wumpus units as +-- the last part of the parsing process... +-- +-- No it shouldn\'t - this would disallow drawings in centimeters +-- + +type FontLoadErr = String +type FontLoadResult cu = Either FontLoadErr (GlyphMetricsTable cu) + +data FontLoader cu = forall interim. FontLoader + { unit_scale_fun :: cu -> PtSize + , path_to_font_dir :: FilePath + , file_name_locator :: FontName -> FilePath + , font_parser :: FilePath -> IO (Either String interim) + , post_process :: interim -> GlyphMetricsTable cu + } + + +loadFont :: FontLoader cu -> FontName -> IO (FontLoadResult cu) +loadFont loader font_name = + locateStep loader font_name >>= \ans -> case ans of + Nothing -> return $ Left $ "Cannot find font " ++ font_name + Just full_path -> parseStep loader full_path + +locateStep :: FontLoader cu -> FontName -> IO (Maybe FilePath) +locateStep loader font_name = + doesFileExist full_path >>= \check -> + if check then return $ Just full_path + else return $ Nothing + where + full_path = normalise $ path_to_font_dir loader + file_name_locator loader font_name + + +parseStep :: FontLoader cu -> FilePath -> IO (FontLoadResult cu) +parseStep (FontLoader _ _ _ parser post) valid_path = + fmap (either Left (Right . post)) $ parser valid_path + +-------------------------------------------------------------------------------- + + + +loadBaseGlyphMetrics :: FontLoader u -> [FontName] -> IO BaseGlyphMetrics +loadBaseGlyphMetrics loader xs = foldrM fn Map.empty xs + where + fn font_name acc = loadFont loader font_name >>= \ans -> + case ans of + Left err -> reportBaseError font_name err >> return acc + Right table -> return $ + Map.insert font_name (tableToGM table) acc + + tableToGM = buildMetrics (unit_scale_fun loader) + +reportBaseError :: FontName -> FontLoadErr -> IO () +reportBaseError font_name err = do + putStrLn $ "The font " ++ font_name ++ " failed to load, with the error:" + putStrLn $ err + + + + +buildGlyphMetricsTable :: BoundingBox AfmUnit + -> Vec2 AfmUnit + -> AfmUnit + -> AfmFile + -> GlyphMetricsTable AfmUnit +buildGlyphMetricsTable bbox dflt_vec dflt_cap_height afm = + GlyphMetricsTable + { glyph_bounding_box = bbox + , glyph_default_adv_vec = dflt_vec + , glyph_adv_vecs = makeAdvVecs $ afm_glyph_metrics afm + , glyph_cap_height = fromMaybe dflt_cap_height $ afm_cap_height afm + } + + +makeAdvVecs :: [AfmGlyphMetrics] -> IntMap.IntMap (Vec2 AfmUnit) +makeAdvVecs = foldr fn IntMap.empty + where + fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of + Nothing -> table + Just i -> IntMap.insert i v table + diff --git a/src/Wumpus/Basic/FontLoader/GSFontMap.hs b/src/Wumpus/Basic/FontLoader/GSFontMap.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/GSFontMap.hs @@ -0,0 +1,87 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.GSFontMap +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- GhostScript Font map. +-- +-- GhostScript aliases the /Core 14/ PostScript fonts to fonts +-- it can freely distribute. This module provides aliases to +-- Wumpus so the font loader can find the equivalent GhostScript +-- files to the Core 14 set. +-- +-- The data in this file matches GhostScript 8.63. Other versions +-- of GhostScript may need different aliases. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.GSFontMap + ( + + ghostscript_version + + , GSFontMap + , gsMetricsFile + , gsFontAlias + , core14_alias_table + + ) where + + +import Data.Map ( Map ) +import qualified Data.Map as Map + + +-- | GhostScript version that the aliases were derived from. +-- +ghostscript_version :: String +ghostscript_version = "gs8.54" + +type GSFontMap = Map String (String, FilePath) + + +-- | Get the @.afm@ metrics file. +-- +-- Note this return only the file name and not the path to it. +-- The full path must be resolved in client code. +-- +gsMetricsFile :: GSFontMap -> String -> Maybe FilePath +gsMetricsFile mp name = fmap snd $ Map.lookup name mp + +-- | Get the GhostScript font name alias. +-- +gsFontAlias :: GSFontMap -> String -> Maybe String +gsFontAlias mp name = fmap fst $ Map.lookup name mp + +-- | Map from PostScript font name to the corresponding +-- GhostScript name and file. +-- +core14_alias_table :: GSFontMap +core14_alias_table = Map.fromList $ + [ ("Courier", ("NimbusMonL-Regu", "n022003l.afm")) + , ("Courier-Oblique", ("NimbusMonL-ReguObli", "n022023l.afm")) + , ("Courier-Bold", ("NimbusMonL-Bold", "n022004l.afm")) + , ("Courier-BoldOblique", ("NimbusMonL-BoldObli", "n022024l.afm")) + + , ("Helvetica", ("NimbusSanL-Regu", "n019003l.afm")) + , ("Helvetica-Oblique", ("NimbusSanL-ReguItal", "n019023l.afm")) + , ("Helvetica-Bold", ("NimbusSanL-Bold", "n019004l.afm")) + , ("Helvetica-BoldOblique", ("NimbusSanL-BoldItal", "n019024l.afm")) + + , ("Times-Roman", ("NimbusRomNo9L-Regu", "n021003l.afm")) + , ("Times-Italic", ("NimbusRomNo9L-ReguItal", "n021023l.afm")) + , ("Times-Bold", ("NimbusRomNo9L-Medi", "n021004l.afm")) + , ("Times-BoldItalic", ("NimbusRomNo9L-MediItal", "n021024l.afm")) + + , ("Symbol", ("StandardSymL", "s050000l.afm")) + + , ("ZapfDingbats", ("Dingbats", "d050000l.afm")) + ] + diff --git a/src/Wumpus/Basic/FontLoader/GSLoader.hs b/src/Wumpus/Basic/FontLoader/GSLoader.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/FontLoader/GSLoader.hs @@ -0,0 +1,63 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.FontLoader.GSLoader +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font loader for GhostScript glyph metrics. +-- +-- Use this loader if you have GhostScript installed and you want +-- to use the (AFM v2.0) metrics that are distributed with +-- GhostScript. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.FontLoader.GSLoader + ( + + module Wumpus.Basic.FontLoader.Base + , module Wumpus.Basic.FontLoader.AfmV2Parser + + , loadGSMetrics + , gsFontLoader + + + + ) where + +import Wumpus.Basic.FontLoader.AfmV2Parser +import Wumpus.Basic.FontLoader.Base +import Wumpus.Basic.FontLoader.GSFontMap +import Wumpus.Basic.Graphic + +import Wumpus.Core -- package: wumpus-core + +import Data.Maybe + + +loadGSMetrics :: FilePath -> [FontName] -> IO BaseGlyphMetrics +loadGSMetrics font_dir_path ns = + loadBaseGlyphMetrics (gsFontLoader font_dir_path) ns + + +gsFontLoader :: FilePath -> FontLoader AfmUnit +gsFontLoader font_dir_path = FontLoader + { unit_scale_fun = afmUnitScale + , path_to_font_dir = font_dir_path + , file_name_locator = buildName + , font_parser = parseAfmV2File + , post_process = buildGlyphMetricsTable bbox (V2 600 0) 1000 + } + where + buildName :: FontName -> FilePath + buildName font = fromMaybe font $ gsMetricsFile core14_alias_table font + + bbox = BBox (P2 (-23) (-250)) (P2 715 805) + + diff --git a/src/Wumpus/Basic/Graphic.hs b/src/Wumpus/Basic/Graphic.hs --- a/src/Wumpus/Basic/Graphic.hs +++ b/src/Wumpus/Basic/Graphic.hs @@ -17,17 +17,27 @@ module Wumpus.Basic.Graphic ( - module Wumpus.Basic.Graphic.Base + module Wumpus.Basic.Graphic.Anchors + , module Wumpus.Basic.Graphic.Base + , module Wumpus.Basic.Graphic.ContextFunction , module Wumpus.Basic.Graphic.Drawing , module Wumpus.Basic.Graphic.DrawingContext - , module Wumpus.Basic.Graphic.PrimGraphic + , module Wumpus.Basic.Graphic.GlyphMetrics + , module Wumpus.Basic.Graphic.GraphicOperations + , module Wumpus.Basic.Graphic.GraphicTypes , module Wumpus.Basic.Graphic.Query , module Wumpus.Basic.Graphic.ScalingContext + , module Wumpus.Basic.Graphic.TraceDrawing ) where import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.Anchors +import Wumpus.Basic.Graphic.ContextFunction import Wumpus.Basic.Graphic.Drawing import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.PrimGraphic +import Wumpus.Basic.Graphic.GlyphMetrics +import Wumpus.Basic.Graphic.GraphicOperations +import Wumpus.Basic.Graphic.GraphicTypes import Wumpus.Basic.Graphic.Query import Wumpus.Basic.Graphic.ScalingContext +import Wumpus.Basic.Graphic.TraceDrawing diff --git a/src/Wumpus/Basic/Graphic/Anchors.hs b/src/Wumpus/Basic/Graphic/Anchors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/Anchors.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.Anchors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Anchor points on shapes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.Anchors + ( + + -- * Anchors + CenterAnchor(..) + , CardinalAnchor(..) + , CardinalAnchor2(..) + , RadialAnchor(..) + + -- * Extended anchor points + , northwards + , southwards + , eastwards + , westwards + , northeastwards + , southeastwards + , southwestwards + , northwestwards + + , radialConnectorPoints + + ) where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +class CenterAnchor t where + center :: DUnit t ~ u => t -> Point2 u + +-- | Note - in TikZ cardinal anchors are not necessarily at the +-- equivalent radial position, for instance reactangle north-east +-- is the top-right corner whether or not this is incident at +-- 45deg. +-- +class CardinalAnchor t where + north :: DUnit t ~ u => t -> Point2 u + south :: DUnit t ~ u => t -> Point2 u + east :: DUnit t ~ u => t -> Point2 u + west :: DUnit t ~ u => t -> Point2 u + +class CardinalAnchor2 t where + northeast :: DUnit t ~ u => t -> Point2 u + southeast :: DUnit t ~ u => t -> Point2 u + southwest :: DUnit t ~ u => t -> Point2 u + northwest :: DUnit t ~ u => t -> Point2 u + + +-- | Anchor on a border that can be identified with and angle. +-- +class RadialAnchor t where + radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u + + +extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u +extendPtDist d p1 p2 = let v = pvec p1 p2 + ang = direction v + len = vlength v + in p1 .+^ avec ang (len+d) + + + +northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +northwards u a = extendPtDist u (center a) (north a) + + +southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +southwards u a = extendPtDist u (center a) (south a) + +eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +eastwards u a = extendPtDist u (center a) (east a) + +westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t + , u ~ DUnit t ) + => u -> t -> Point2 u +westwards u a = extendPtDist u (center a) (west a) + + +northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +northeastwards u a = extendPtDist u (center a) (northeast a) + + +southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +southeastwards u a = extendPtDist u (center a) (southeast a) + +southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +southwestwards u a = extendPtDist u (center a) (southwest a) + +northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t + , u ~ DUnit t ) + => u -> t -> Point2 u +northwestwards u a = extendPtDist u (center a) (northwest a) + + +-------------------------------------------------------------------------------- + +radialConnectorPoints :: ( Real u, Floating u + , CenterAnchor t1, RadialAnchor t1 + , CenterAnchor t2, RadialAnchor t2 + , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) + => t1 -> t2 -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) + where + theta = direction $ pvec (center a) (center b) + + +-------------------------------------------------------------------------------- +-- Instances + +instance Fractional u => CenterAnchor (BoundingBox u) where + center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y + where + x = xl+0.5*(xr-xl) + y = ylo+0.5*(yhi-ylo) + + +instance Fractional u => CardinalAnchor (BoundingBox u) where + north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi + south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo + east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) + west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) + + +instance Fractional u => CardinalAnchor2 (BoundingBox u) where + northeast (BBox _ ur) = ur + southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo + southwest (BBox ll _) = ll + northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi + diff --git a/src/Wumpus/Basic/Graphic/Base.hs b/src/Wumpus/Basic/Graphic/Base.hs --- a/src/Wumpus/Basic/Graphic/Base.hs +++ b/src/Wumpus/Basic/Graphic/Base.hs @@ -13,32 +13,12 @@ -- Stability : highly unstable -- Portability : GHC -- --- Base types for Drawing Objects, Graphics / Images (a Graphic --- that also returns an answer), etc. +-- The common base drawing objects in Wumpus-Basic - a +-- semigroup class, monad classes (TraceM analogue to Writer, +-- DrawingCtxM analogue to Reader), a wrapped Hughes list of +-- primitives. -- --- Base classes for monadic drawing. -- --- Notes on prefix and suffix names: --- --- Function types suffixed @F@ are functions from same-to-same, e.g.: --- --- > type Point2F u = Point2 u -> Point2 u --- --- Functional types subfixed @R@ are functions from some static --- context to the answer type (c.f the ReaderMonad), e.g.: --- --- > newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a } --- --- The suffix @M@ is used for classes defining monadic actions. --- --- The prefix @Loc@ indicates a functional type --- /from Point2 to something.../ --- --- The prefix @ThetaLoc@ indicates a functional type --- /from Direction (radian) then Point to something.../ --- --- \*\* WARNING \*\* - some names are expected to change. --- -------------------------------------------------------------------------------- module Wumpus.Basic.Graphic.Base @@ -50,6 +30,10 @@ , anterior , superior + -- * Alignment. + , HAlign(..) + , VAlign(..) + -- * Drawing monads. , MonUnit , TraceM(..) @@ -64,75 +48,14 @@ , hprimToList , singleH - , Point2F - , DPoint2F - - , DrawingR - , LocDrawingR - , DLocDrawingR - - , DrawingTrafoF - - , runDrawingR - , PrimGraphic , getPrimGraphic - , wrapPrim - + , primGraphic , collectH - , Graphic - , DGraphic - , GraphicTrafoF - - , superiorGraphic - , anteriorGraphic - - , runGraphic - , xlinkGraphic - - , LocGraphic - , DLocGraphic - - , Image - , DImage - - , ImageTrafoF - , intoImageTrafo - , imageTrafoDrawing - , imageTrafoGraphic - - , LocImage - , DLocImage - - , runImage - , intoImage - , intoLocImage - , xlinkImage - - , ConnectorDrawingR - , DConnectorDrawingR - , ConnectorGraphic - , DConnectorGraphic - , ConnectorImage - , DConnectorImage - - , intoConnectorImage - - , ThetaLocDrawingR - , DThetaLocDrawingR - , ThetaLocGraphic - , DThetaLocGraphic - , ThetaLocImage - , DThetaLocImage - - , intoThetaLocImage - - ) where import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Utils.Combinators import Wumpus.Basic.Utils.HList import Wumpus.Core -- package: wumpus-core @@ -165,12 +88,8 @@ --- Note - this produces tall-skinny trees in Wumpus-core. --- This does not impact on the generated PostScript but it is --- (probably) inefficient for traversals in Wumpus. --- --- There is scope to modify the Primitive type in Wumpus-Core --- (make Group indepenent of XLink) so wider trees can be made. +instance Ord u => OPlus (BoundingBox u) where + oplus = boundaryUnion instance OPlus (Primitive u) where a `oplus` b = primGroup [a,b] @@ -187,6 +106,21 @@ -------------------------------------------------------------------------------- + +-- Alignment + +-- | Horizontal alignment - align to the top, center or bottom. +data HAlign = HTop | HCenter | HBottom + deriving (Enum,Eq,Ord,Show) + +-- | Vertical alignment - align to the left, center or bottom. +data VAlign = VLeft | VCenter | VRight + deriving (Enum,Eq,Ord,Show) + + + + +-------------------------------------------------------------------------------- -- Monadic drawing -- | DUnit is always for fully saturated type constructors, so @@ -214,9 +148,6 @@ - - - -- | A monad that supplies points, e.g. a turtle monad. -- class Monad m => PointSupplyM (m :: * -> *) where @@ -224,7 +155,7 @@ -------------------------------------------------------------------------------- --- Base types +-- Lists of primitives... -- | Graphics objects, even simple ones (line, arrow, dot) might -- need more than one primitive (path or text label) for their @@ -257,86 +188,6 @@ singleH :: Primitive u -> HPrim u singleH = HPrim . wrapH --- | Point transformation function. --- -type Point2F u = Point2 u -> Point2 u - -type DPoint2F = Point2F Double - --------------------------------------------------------------------------------- --- - --- | Drawings in Wumpus-Basic have an implicit /graphics state/ --- the @DrawingContext@, the most primitive building block is --- a function from the DrawingContext to some polymorphic answer. --- --- This functional type is represented concretely as @DrawingR@. --- --- > DrawingR :: DrawingContext -> a --- -newtype DrawingR a = DrawingR { getDrawingR :: DrawingContext -> a } - - -instance Functor DrawingR where - fmap f ma = DrawingR $ \ctx -> f $ getDrawingR ma ctx - - -instance OPlus a => OPlus (DrawingR a) where - fa `oplus` fb = DrawingR $ \ctx -> - getDrawingR fa ctx `oplus` getDrawingR fb ctx - --- The monoid instance seems sensible... --- -instance Monoid a => Monoid (DrawingR a) where - mempty = DrawingR $ \_ -> mempty - fa `mappend` fb = DrawingR $ \ctx -> - getDrawingR fa ctx `mappend` getDrawingR fb ctx - --- Applicative - -instance Applicative DrawingR where - pure a = DrawingR $ \_ -> a - mf <*> ma = DrawingR $ \ctx -> let f = getDrawingR mf ctx - a = getDrawingR ma ctx - in f a - --- Monad - -instance Monad DrawingR where - return a = DrawingR $ \_ -> a - ma >>= k = DrawingR $ \ctx -> let a = getDrawingR ma ctx - in (getDrawingR . k) a ctx - - -instance DrawingCtxM DrawingR where - askDC = DrawingR $ \ctx -> ctx - localize upd df = DrawingR $ \ctx -> getDrawingR df (upd ctx) - - --- | Run a /Drawing Function/ with the supplied /Drawing Context/. --- -runDrawingR :: DrawingContext -> DrawingR a -> a -runDrawingR ctx df = getDrawingR df ctx - - - - -type LocDrawingR u a = Point2 u -> DrawingR a - -type DLocDrawingR a = LocDrawingR Double a - - -type DrawingTrafoF a = DrawingR a -> DrawingR a - - - - --- Affine instances - cannot be manufactured. There is no --- DUnit @u@ to get a handle on. --- - --------------------------------------------------------------------------------- - -- As of version 0.36.0, Wumpus-Core supports grouping primitives -- together (a common operation in vector drawing editors). -- @@ -373,204 +224,9 @@ translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic -wrapPrim :: Primitive u -> PrimGraphic u -wrapPrim = PrimGraphic +primGraphic :: Primitive u -> PrimGraphic u +primGraphic = PrimGraphic collectH :: PrimGraphic u -> HPrim u collectH = singleH . getPrimGraphic - --------------------------------------------------------------------------------- - --- Simple drawing - produce a primitive, access the DrawingContext --- if required. - -type Graphic u = DrawingR (PrimGraphic u) - -type DGraphic = Graphic Double - -type instance DUnit (Graphic u) = u - - -runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u -runGraphic ctx gf = (getDrawingR gf) ctx - - -xlinkGraphic :: XLink -> Graphic u -> Graphic u -xlinkGraphic xlink gf = DrawingR $ \ctx -> - let a = runGraphic ctx gf - in PrimGraphic $ xlinkGroup xlink [getPrimGraphic a] - - --- Affine instances - -instance (Real u, Floating u) => Rotate (Graphic u) where - rotate ang = liftA (rotate ang) - - -instance (Real u, Floating u) => RotateAbout (Graphic u) where - rotateAbout ang pt = liftA (rotateAbout ang pt) - - -instance Num u => Scale (Graphic u) where - scale sx sy = liftA (scale sx sy) - - -instance Num u => Translate (Graphic u) where - translate dx dy = liftA (translate dx dy) - - - - -type GraphicTrafoF u = Graphic u -> Graphic u - -anteriorGraphic :: Graphic u -> GraphicTrafoF u -anteriorGraphic = anterior - -superiorGraphic :: Graphic u -> GraphicTrafoF u -superiorGraphic = superior - - - - --------------------------------------------------------------------------------- - - --- | Commonly graphics take a start point as well as a drawing --- context. --- --- Here they are called a LocGraphic - graphic with a (starting) --- location. --- -type LocGraphic u = Point2 u -> Graphic u - -type DLocGraphic = LocGraphic Double - - - - --------------------------------------------------------------------------------- - - --- | Images return a value as well as drawing. A /node/ is a --- typical example - nodes are drawing but the also support --- taking anchor points. --- -type Image u a = DrawingR (a, PrimGraphic u) - -type DImage a = Image Double a - -type instance DUnit (Image u a) = u - - - -runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u) -runImage ctx img = (getDrawingR img) ctx - - -intoImage :: DrawingR a -> Graphic u -> Image u a -intoImage f g = forkA f g - - --- Affine instances - -instance (Real u, Floating u, Rotate a, DUnit a ~ u) => - Rotate (Image u a) where - rotate ang = liftA (prod (rotate ang) (rotate ang)) - - -instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => - RotateAbout (Image u a) where - rotateAbout ang pt = liftA (prod (rotateAbout ang pt) (rotateAbout ang pt)) - - -instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where - scale sx sy = liftA (prod (scale sx sy) (scale sx sy)) - - -instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where - translate dx dy = liftA (prod (translate dx dy) (translate dx dy)) - - - -type ImageTrafoF u a = Image u a -> Image u a - - - - -intoImageTrafo :: DrawingTrafoF a -> GraphicTrafoF u -> ImageTrafoF u a -intoImageTrafo df gf img = img >>= \(a,prim) -> - intoImage (df $ pure a) (gf $ pure prim) - -imageTrafoDrawing :: DrawingTrafoF a -> ImageTrafoF u a -imageTrafoDrawing df = intoImageTrafo df id - -imageTrafoGraphic :: GraphicTrafoF u -> ImageTrafoF u a -imageTrafoGraphic gf = intoImageTrafo id gf - - - -type LocImage u a = Point2 u -> Image u a - -type DLocImage a = LocImage Double a - -intoLocImage :: LocDrawingR u a -> LocGraphic u -> LocImage u a -intoLocImage f g pt = forkA (f pt) (g pt) - - -xlinkImage :: XLink -> Image u a -> Image u a -xlinkImage xlink img = DrawingR $ \ctx -> - let (a,pg) = runImage ctx img - in (a, PrimGraphic $ xlinkGroup xlink [getPrimGraphic pg]) - --------------------------------------------------------------------------------- --- - -type ConnectorDrawingR u a = Point2 u -> Point2 u -> DrawingR a - -type DConnectorDrawingR a = ConnectorDrawingR Double a - --- | ConnectorGraphic is a connector drawn between two points --- contructing a Graphic. --- -type ConnectorGraphic u = Point2 u -> Point2 u -> Graphic u - -type DConnectorGraphic = ConnectorGraphic Double - --- | ConnectorImage is a connector drawn between two points --- constructing an Image. --- --- Usually the answer type of a ConnectorImage will be a Path so --- the Points ar @midway@, @atstart@ etc. can be taken on it. --- -type ConnectorImage u a = Point2 u -> Point2 u -> Image u a - -type DConnectorImage a = ConnectorImage Double a - - -intoConnectorImage :: ConnectorDrawingR u a - -> ConnectorGraphic u - -> ConnectorImage u a -intoConnectorImage f g p1 p2 = forkA (f p1 p2) (g p1 p2) - - -type ThetaLocDrawingR u a = Radian -> LocDrawingR u a - -type DThetaLocDrawingR a = ThetaLocDrawingR Double a - --- | A function from /Radian -\> Point -\> Graphic/... --- -type ThetaLocGraphic u = Radian -> LocGraphic u - -type DThetaLocGraphic = ThetaLocGraphic Double - -type ThetaLocImage u a = Radian -> LocImage u a - -type DThetaLocImage a = ThetaLocImage Double a - - -intoThetaLocImage :: ThetaLocDrawingR u a - -> ThetaLocGraphic u - -> ThetaLocImage u a -intoThetaLocImage f g theta pt = forkA (f theta pt) (g theta pt) - diff --git a/src/Wumpus/Basic/Graphic/ContextFunction.hs b/src/Wumpus/Basic/Graphic/ContextFunction.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/ContextFunction.hs @@ -0,0 +1,718 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.ContextFunction +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- The primary drawing type and base combinators to manipulate it. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.ContextFunction + ( + + CF + + , LocCF + , LocThetaCF + , ConnectorCF + , DLocCF + , DLocThetaCF + , DConnectorCF + + + + -- * Run functions + , runCF + + -- * Extractors + , drawingCtx + , queryCtx + , locCtx + , locPoint + , locThetaCtx + , locThetaPoint + , locThetaAng + , connCtx + , connStart + , connEnd + + -- * Reducers + , unLoc + , unTheta + , unLocTheta + , unConnector + + , unCF1 + , unCF2 + + -- * Combinators + , wrap + , wrap1 + , wrap2 + + , promote1 + , promote2 + + , raise + , raise1 + , raise2 + + , static1 + , static2 + , dblstatic + + , bind + , bind1 + , bind2 + + + , situ1 + , situ2 + + , apply + , apply1 + , apply2 + + -- * Pre-transformers + , prepro1 + , prepro2 + , prepro2a + , prepro2b + + -- * Post-transformers + , postpro + , postpro1 + , postpro2 + + -- * Post-combiners + , postcomb + , postcomb1 + , postcomb2 + + , accumulate1 + , accumulate2 + + + ) where + +-- import Wumpus.Basic.Graphic.Anchors +import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.DrawingContext + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative +import Data.Monoid + + +-------------------------------------------------------------------------------- +-- + +-- | Most drawing operations in Wumpus-Basic have an implicit +-- /graphics state/ the @DrawingContext@, so the most primitive +-- building block is a function from the DrawingContext to some +-- polymorphic answer. +-- +-- This functional type is represented concretely as the initials +-- @CF@ for /contextual function/. +-- +-- > CF :: DrawingContext -> a +-- +newtype CF a = CF { getCF :: DrawingContext -> a } + + +type LocCF u a = CF (Point2 u -> a) + +type LocThetaCF u a = LocCF u (Radian -> a) + +type ConnectorCF u a = LocCF u (Point2 u -> a) + + + +type DLocCF a = LocCF Double a +type DLocThetaCF a = LocThetaCF Double a +type DConnectorCF a = ConnectorCF Double a + + + +-------------------------------------------------------------------------------- +-- Drawing instances + +instance Functor CF where + fmap f ma = CF $ \ctx -> f $ getCF ma ctx + + +instance OPlus a => OPlus (CF a) where + fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx + +-- The monoid instance seems sensible... +-- +instance Monoid a => Monoid (CF a) where + mempty = CF $ \_ -> mempty + fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx + +-- Applicative + +instance Applicative CF where + pure a = CF $ \_ -> a + mf <*> ma = CF $ \ctx -> let f = getCF mf ctx + a = getCF ma ctx + in f a +-- Monad + +instance Monad CF where + return a = CF $ \_ -> a + ma >>= k = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx + + +instance DrawingCtxM CF where + askDC = CF $ \ctx -> ctx + localize upd df = CF $ \ctx -> getCF df (upd ctx) + + + + +-------------------------------------------------------------------------------- +-- Run functions + + + +-- | Run a /CF/ (context function) with the supplied /DrawingContext/. +-- +runCF :: DrawingContext -> CF a -> a +runCF ctx df = getCF df ctx + + +-------------------------------------------------------------------------------- +-- extractors + +-- | Extract the drawing context from a CtxFun. +-- +-- > (ctx -> ctx) +-- +drawingCtx :: CF DrawingContext +drawingCtx = CF $ \ctx -> ctx + +-- | Apply the projection function to the drawing context. +-- +-- > (ctx -> a) -> (ctx -> a) +-- +queryCtx :: (DrawingContext -> a) -> CF a +queryCtx f = CF $ \ctx -> f ctx + + +-- | Extract the drawing context from a LocCF. +-- +-- > (ctx -> pt -> ctx) +-- +locCtx :: LocCF u DrawingContext +locCtx = CF $ \ctx _ -> ctx + +-- | Extract the /start/ point from a LocCF. +-- +-- > (ctx -> pt -> pt) +-- +locPoint :: LocCF u (Point2 u) +locPoint = CF $ \_ pt -> pt + + +-- | Extract the drawing context from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> ctx) +-- +locThetaCtx :: LocThetaCF u DrawingContext +locThetaCtx = CF $ \ctx _ _ -> ctx + + +-- | Extract the /start/ point from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> pt) +-- +locThetaPoint :: LocThetaCF u (Point2 u) +locThetaPoint = CF $ \_ pt _ -> pt + +-- | Extract the angle from a LocThetaCF. +-- +-- > (ctx -> pt -> ang -> ang) +-- +locThetaAng :: LocThetaCF u Radian +locThetaAng = CF $ \_ _ ang -> ang + +-- | Extract the drawing context from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> ctx) +-- +connCtx :: ConnectorCF u DrawingContext +connCtx = CF $ \ctx _ _ -> ctx + +-- | Extract the start point from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> pt1) +-- +connStart :: ConnectorCF u (Point2 u) +connStart = CF $ \_ pt _ -> pt + +-- | Extract the end point from a ConnectorCF. +-- +-- > (ctx -> pt1 -> pt2 -> pt2) +-- +connEnd :: ConnectorCF u (Point2 u) +connEnd = CF $ \_ _ pt -> pt + + +-------------------------------------------------------------------------------- +-- /Reducers/ + +-- | This is unCF1 at a specific type. +-- +unLoc :: Point2 u -> LocCF u a -> CF a +unLoc pt mf = CF $ \ctx -> getCF mf ctx pt + +unTheta :: Radian -> LocThetaCF u a -> LocCF u a +unTheta theta mf = CF $ \ctx pt -> getCF mf ctx pt theta + +unLocTheta :: Point2 u -> Radian -> LocThetaCF u a -> CF a +unLocTheta pt theta mf = CF $ \ctx -> getCF mf ctx pt theta + +unConnector :: Point2 u -> Point2 u -> ConnectorCF u a -> CF a +unConnector p0 p1 mf = CF $ \ctx -> getCF mf ctx p0 p1 + + +unCF1 :: r1 -> CF (r1 -> a) -> CF a +unCF1 a mf = CF $ \ctx -> getCF mf ctx a + +unCF2 :: r1 -> r2 -> CF (r1 -> r2 -> a) -> CF a +unCF2 a b mf = CF $ \ctx -> getCF mf ctx a b + + + + +-------------------------------------------------------------------------------- +-- Combinators + +-- | Lift a pure value into a Context functional. The +-- DrawingContext is ignored. +-- +-- > ans -> (ctx -> ans) +-- +-- Without any other arguments, this is the same as the 'raise' +-- combinator for raising into the Context functional. However, +-- the /arity family/ of @wrap@ combinators is different. +-- +wrap :: a -> CF a +wrap = pure + + +-- | Lift a pure value into a Context functional, ignoring both +-- the DrawingContext and the /static/ argument, e.g. this would +-- ingnore start point for a @LocDrawing@). +-- +-- > ans -> (ctx -> r1 -> ans) +-- +wrap1 :: a -> CF (r1 -> a) +wrap1 = pure . pure + +-- | Lift a pure value into a Context functional, ignoring both +-- the DrawingContext and the two /static/ arguments, e.g. this +-- would ignore the start point and angle for a @LocThetaDrawing@. +-- +-- > ans -> (ctx -> r1 -> r2 -> ans) +-- +wrap2 :: a -> CF (r1 -> r2 -> a) +wrap2 = pure . pure . pure + + + +-- | Promote a Context functional with one argument /outside/ +-- the functional so that the the argument is /inside/ the +-- Context functional. +-- +-- The type signature is probably more illustrative of the +-- operation than this description: +-- +-- > (r1 -> ctx -> ans) -> (ctx -> r1 -> ans) +-- +-- This is essentially the @cardinal@ combinator - @flip@ +-- in Haskell. +-- +promote1 :: (r1 -> CF ans) -> CF (r1 -> ans) +promote1 f = CF $ \ctx a -> getCF (f a) ctx + + +-- | Promote a Context functional with two arguments /outside/ +-- the functional so that the two arguments are /inside/ the +-- Context functional. +-- +-- The type signature is probably more illustrative of the +-- operation than this description: +-- +-- > (r1 -> r2 -> ctx -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +promote2 :: (r1 -> r2 -> CF ans) -> CF (r1 -> r2 -> ans) +promote2 df = CF $ \ctx a b -> getCF (df a b) ctx + + +-- | Lift a value into a Context functional. +-- +-- > ans -> (ctx -> ans) +-- +-- Essentially this is the @kestrel@ combinator - @const@ in +-- Haskell, though due to newtype wrapping it is @pure@ from the +-- Applicative class. +-- +raise :: a -> CF a +raise = pure + + +-- | Lift a one argument function into a Context functional. +-- +-- This is Applicative\'s 'pure' with a specialized type +-- signature. +-- +raise1 :: (r1 -> ans) -> CF (r1 -> ans) +raise1 = pure + +-- | Lift a two argument function into a Context functional. +-- +-- This is Applicative\'s 'pure' with a specialized type +-- signature. +-- +raise2 :: (r1 -> r2 -> ans) -> CF (r1 -> r2 -> ans) +raise2 = pure + + +-- | Extend the arity of a /Context functional/, the original +-- function is oblivious to the added argument. +-- +-- Typically this combinator is used to take a @Graphic@ to a +-- @LocGraphic@ ingoring the start point (figuratively a @Graphic@ +-- is not /coordinate free/). +-- +-- > (ctx -> ans) -> (ctx -> r1 -> ans) +-- +-- This was called the J-combinator by Joy, Rayward-Smith and +-- Burton (ref. /Compling Functional Languages/ by Antoni +-- Diller), however it is not the J combinator commonly in the +-- Literature. +-- +static1 :: CF ans -> CF (r1 -> ans) +static1 df = CF $ \ctx _ -> getCF df ctx + + +-- | Extend the arity of a /Context functional/, the original +-- function is oblivious to the added argument. +-- +-- Typically this combinator is used to take a @LocGraphic@ to a +-- @LocThetaGraphic@ ingoring the angle of direction. +-- +-- > (ctx -> r1 -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +-- This was called the J-Prime combinator by Joy, Rayward-Smith +-- and Burton (ref. /Compling Functional Languages/ by Antoni +-- Diller). +-- +static2 :: CF (r1 -> ans) -> CF (r1 -> r2 -> ans) +static2 df = CF $ \ctx a _ -> getCF df ctx a + + +-- | Complementary combinator to static2. +-- +-- This combinator raises a function two levels rather than one. +-- +-- > (ctx -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +dblstatic :: CF ans -> CF (r1 -> r2 -> ans) +dblstatic df = CF $ \ctx _ _ -> getCF df ctx + + +infixl 1 `bind`, `bind1`, `bind2` + + +-- | Supply the output from the first function to the second +-- function. +-- +-- This is just monadic bind - specialized to the CF functional +-- type. +-- +-- > (ctx -> a) -> (a -> ctx -> ans) -> (ctx -> ans) +-- +bind :: CF a -> (a -> CF ans) -> CF ans +bind df dk = CF $ \ctx -> let z = getCF df ctx in getCF (dk z) ctx + + +-- | Supply the output from the first function to the second +-- function, /sharing/ the drawing context and the static +-- argument @r1@. +-- +-- > (ctx -> r1 -> a) -> (a -> ctx -> -> r1 -> ans) -> (ctx -> r1 -> ans) +-- +bind1 :: CF (r1 -> a) -> (a -> CF (r1 -> ans)) -> CF (r1 -> ans) +bind1 df dk = CF $ \ctx a -> let z = getCF df ctx a in getCF (dk z) ctx a + +-- | Supply the output from the first function to the second +-- function, /sharing/ the DrawingContext and the two static +-- arguments @r1@ and @r2@. +-- +-- > (ctx -> r1 -> r2 -> a) -> (a -> ctx -> -> r1 -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +bind2 :: CF (r1 -> r2 -> a) -> (a -> CF (r1 -> r2 -> ans)) + -> CF (r1 -> r2 -> ans) +bind2 df dk = CF $ \ctx a b -> + let z = getCF df ctx a b in getCF (dk z) ctx a b + + +-- idstar :: (r1 -> r2 -> ans) -> r1 -> r2 -> ans + +-- | Supply the arguments to an arity 1 Context functional so it +-- can be /situated/. Typically this is supplying the start point +-- to a @LocGraphic@ or @LocImage@. +-- +-- > (ctx -> r1 -> ans) -> r1 -> (ctx -> ans) +-- +-- This is equivalent to the @id**@ combinator. +-- +situ1 :: CF (r1 -> ans) -> r1 -> CF ans +situ1 df a = CF $ \ctx -> getCF df ctx a + + + +-- | Supply the arguments to an arity 2 Conterxt functional so +-- it can be /situated/. Typically this is supplying the start +-- point and angle to a @LocThetaGraphic@ or @LocThetaImage@. +-- +-- > (ctx -> r1 -> r2 -> ans) -> r1 -> r2 -> (ctx -> ans) +-- +situ2 :: CF (r1 -> r2 -> ans) -> r1 -> r2 -> CF ans +situ2 df a b = CF $ \ctx -> getCF df ctx a b + + +-- | Apply the the functional produced by the first argument to +-- the value produced by the second. +-- +-- > (ctx -> a -> ans) -> (ctx -> a) -> (ctx -> ans) +-- +apply :: CF (a -> ans) -> CF a -> CF ans +apply df da = CF $ \ctx -> getCF df ctx (getCF da ctx) + + +-- | Apply the the functional produced by the first argument to +-- the value produced by the second /sharing/ the context of the +-- first functional argument @r1@ (usually a Point2) as well as +-- the DrawingContext. +-- +-- > (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) +-- +apply1 :: CF (r1 -> a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans) +apply1 df da = CF $ \ctx a -> getCF df ctx a (getCF da ctx a) + + +-- | Apply the the functional produced by the first argument to +-- the value produced by the second /sharing/ the context of the +-- two functional arguments @r1@ and @r2@ as well as the +-- DrawingContext. +-- +-- > (ctx -> r1 -> r2 -> a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) +-- +apply2 :: CF (r1 -> r2 -> a -> ans) -> CF (r1 -> r2 -> a) + -> CF (r1 -> r2 -> ans) +apply2 df da = CF $ \ctx a b -> getCF df ctx a b (getCF da ctx a b) + + +-------------------------------------------------------------------------------- +-- Pre-transformers + +-- The primary /pre-transformation/ function is @localize@, here +-- it is without the newtype wrapper or the specific types: +-- +-- > fn :: (ctx -> ctx) -> (ctx -> ans) -> ctx -> ans +-- > fn f g = \ctx -> g (f ctx) +-- +-- This a a type restricted version of reverse appliction, the T +-- combinator sometimes called queer, sometings @(#)@ in Haskell. +-- In Wumpus-Basic it is @localize@ which is overloaded for the +-- CF newtype and TraceDrawing monads. +-- +-- > localizeDR :: (DrawingContext -> DrawingContext) -> CF a -> CF a +-- > localizeDR = localize +-- +-- Figuartively speaking this is an opposite of the fmap function +-- instance. Instead of (post-) transforming the output, ... +-- (pre-) transforms the input. +-- +-- Due to Context functionals being stacked in a particular way +-- @localize@ always pre-transforms the DrawingContext regardless +-- of the arity of the functional: +-- +-- > localizeDR2 :: (DrawingContext -> DrawingContext) +-- > -> CF (r -> a) -> CF (r -> a) +-- > localizeDR2 = localize +-- + + +-- | Apply the static argument transfomer @(r1 -> a)@ to the +-- static argument /before/ applying the Context functional. +-- +-- > (r1 -> a) -> (ctx -> a -> ans) -> (ctx -> r1 -> ans) +-- +prepro1 :: (r1 -> a) -> CF (a -> ans) -> CF (r1 -> ans) +prepro1 f mf = CF $ \ctx a -> getCF mf ctx (f a) + + +-- | Apply the static argument transfomers to their respective +-- static arguments /before/ applying the Context functional. +-- +-- > (r1 -> a) -> (r2 -> b) -> (ctx -> a -> b -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +prepro2 :: (r1 -> a) -> (r2 -> b) -> CF (a -> b -> ans) -> CF (r1 -> r2 -> ans) +prepro2 f g mf = CF $ \ctx a b -> getCF mf ctx (f a) (g b) + + +-- | Apply the static argument transfomer to the first static +-- argument of a two static argument functional /before/ applying +-- the Context functional. +-- +-- > (r1 -> a) -> (ctx -> a -> r2 -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +prepro2a :: (r1 -> a) -> CF (a -> r2 -> ans) -> CF (r1 -> r2 -> ans) +prepro2a f mf = CF $ \ctx a b -> getCF mf ctx (f a) b + +-- | Apply the static argument transfomer to the second static +-- argument of a two static argument functional /before/ applying +-- the Context functional. +-- +-- > (r2 -> a) -> (ctx -> r1 -> a -> ans) -> (ctx -> r1 -> r2 -> ans) +-- +prepro2b :: (r2 -> a) -> CF (r1 -> a -> ans) -> CF (r1 -> r2 -> ans) +prepro2b f mf = CF $ \ctx a b -> getCF mf ctx a (f b) + +------------------------------------------------------------------------------ +-- Post-transfomers + +-- | Apply the post-transformer to the result of the Context +-- functional. +-- +-- > (a -> ans) -> (ctx -> a) -> (ctx -> ans) +-- +postpro :: (a -> ans) -> CF a -> CF ans +postpro = fmap + +-- | Apply the post-transformer to the result of the Context +-- functional. Version for one static argument. +-- +-- Note - the DrawingContext is always present so it is never +-- counted as a static argument. +-- +-- > (a -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> ans) +-- +postpro1 :: (a -> ans) -> CF (r1 -> a) -> CF (r1 -> ans) +postpro1 = postpro . fmap + +-- | Apply the post-transformer to the result of the Context +-- functional. Version for two static arguments. +-- +-- Note - the DrawingContext is always present so it is never +-- counted as a static argument. +-- +-- +-- > (a -> ans) -> (ctx -> r1 -> r2 -> a) -> (ctx -> r1 -> r2 -> ans) +-- +postpro2 :: (a -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> ans) +postpro2 = postpro1 . fmap + + +-------------------------------------------------------------------------------- +-- Post-combiners + +-- | Combine the results of the two Context Functions with the +-- supplied operator. +-- +-- > (a -> b -> ans) -> (ctx -> a) -> (ctx -> b) -> (ctx -> ans) +-- +postcomb :: (a -> b -> ans) -> CF a -> CF b -> CF ans +postcomb op df dg = CF $ \ctx -> getCF df ctx `op` getCF dg ctx + +-- | Combine the results of the two one-static-argument Context +-- Functions with the supplied operator. +-- +-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans) +-- +postcomb1 :: (a -> b -> c) -> CF (r1 -> a) -> CF (r1 -> b) -> CF (r1 -> c) +postcomb1 op df dg = CF $ \ctx a -> getCF df ctx a `op` getCF dg ctx a + + +-- | Combine the results of the two two-static-argument Context +-- Functions with the supplied operator. +-- +-- > (a -> b -> ans) -> (ctx -> r1 -> a) -> (ctx -> r1 -> b) -> (ctx -> r1 -> ans) +-- +postcomb2 :: (a -> b -> ans) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> b) + -> CF (r1 -> r2 -> ans) +postcomb2 op df dg = CF $ \ctx a b -> + getCF df ctx a b `op` getCF dg ctx a b + + + +-- | Iteration combinator - the initial argument @s1@ is not +-- shared bewteen the drawings. +-- +-- Evaluate the first Context Function with the drawing context +-- and the /initial state/ @st0@. The result of the evaluation is +-- a new /state/ @st1@ and and answer @a1@. +-- +-- Evaluate the second Context Function with the drawing context +-- and the new state @st1@, producing a new state @s2@ and an +-- answer @a2@. +-- +-- Return the result of combining the answers with +-- @op :: (ans -> ans -> ans)@ and the second state @s2@. +-- +-- @ (ans -> ans -> ans) -> (ctx -> s1 -> (s1,ans)) @ +-- @ -> (ctx -> s1 -> (s1,ans)) -> (ctx -> s1 -> (s1,ans)) @ +-- +-- This models chaining start points together, which is the model +-- PostScript uses for text output when succesively calling the +-- @show@ operator. +-- +accumulate1 :: (ans -> ans -> ans) + -> CF (s1 -> (s1,ans)) -> CF (s1 -> (s1,ans)) + -> CF (s1 -> (s1,ans)) +accumulate1 op f g = CF $ \ctx s -> + let (s1,a1) = getCF f ctx s + (s2,a2) = getCF g ctx s1 + in (s2, a1 `op` a2) + + + +-- | Arity two version of accumulate1 - this is not expected to be +-- useful! +-- +-- @ (ans -> ans -> ans) -> (ctx -> s1 -> -> s2 (s1,s2,ans)) @ +-- @ -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @ +-- @ -> (ctx -> s1 -> s2 -> (s1,s2,ans)) @ +-- +accumulate2 :: (ans -> ans -> ans) + -> CF (s1 -> s2 -> (s1,s2,ans)) + -> CF (s1 -> s2 -> (s1,s2,ans)) + -> CF (s1 -> s2 -> (s1,s2,ans)) +accumulate2 op f g = CF $ \ctx s t -> + let (s1,t1,a1) = getCF f ctx s t + (s2,t2,a2) = getCF g ctx s1 t1 + in (s2, t2, a1 `op` a2) + + + + + +-------------------------------------------------------------------------------- +{- +instance CenterAnchor a => CenterAnchor (CF a) where + center = postpro center +-} diff --git a/src/Wumpus/Basic/Graphic/Drawing.hs b/src/Wumpus/Basic/Graphic/Drawing.hs --- a/src/Wumpus/Basic/Graphic/Drawing.hs +++ b/src/Wumpus/Basic/Graphic/Drawing.hs @@ -1,7 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -14,353 +11,114 @@ -- Stability : unstable -- Portability : GHC -- --- Drawing with /trace/ - a Writer like monad collecting --- intermediate graphics - and /drawing context/ - a reader monad --- of attributes - font_face, fill_colour etc. --- +-- A Drawing object. +-- +-- This is the corresponding type to Picture in the Wumpus-Core. +-- +-- Drawing is a function from the DrawingContext to a Picture. +-- Internally the result is actually a (Maybe Picture) and not a +-- Picture, this is a trick to promote the extraction from +-- possibly empty drawings (created by TraceDrawing) to the +-- top-level of the type hierarchy where client code can deal +-- with empty drawings explicitly (empty Pictures cannot be +-- rendered by Wumpus-Core). +-- -------------------------------------------------------------------------------- module Wumpus.Basic.Graphic.Drawing ( Drawing - , DrawingT + , DDrawing , runDrawing - , execDrawing - , evalDrawing - , runDrawingT - , execDrawingT - , evalDrawingT - - , runFdcDrawing - , execFdcDrawing - , runFdcDrawingT - , execFdcDrawingT - - , liftToPictureU - , liftToPictureMb - , mbPictureU - - , draw - , xdraw - , drawi - , drawi_ - , xdrawi - , xdrawi_ - - , at + , runDrawingU + , drawTracing - , node - , nodei + , clipDrawing + , modifyDrawing + , drawingConcat ) where - -import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.ContextFunction import Wumpus.Basic.Graphic.DrawingContext --- import Wumpus.Basic.Utils.HList +import Wumpus.Basic.Graphic.TraceDrawing import Wumpus.Core -- package: wumpus-core -import Control.Applicative -import Control.Monad -import Data.Monoid +newtype Drawing u = Drawing { getDrawing :: CF (Maybe (Picture u)) } +type DDrawing = Drawing Double --- Note - Drawing run \once\ - it is supplied with the starting --- environment (DrawingContext) and returns a Picture. --- --- Other Wumpus monads (e.g. Turtle) will typically be run inside --- the Drawing monad as a local effect, rather than built into a --- transformer stack. --- +type instance DUnit (Drawing u) = u -newtype Drawing u a = Drawing { - getDrawing :: DrawingContext -> (a, HPrim u) } -newtype DrawingT u m a = DrawingT { - getDrawingT :: DrawingContext -> m (a, HPrim u) } - - -type instance MonUnit (Drawing u) = u -type instance MonUnit (DrawingT u m) = u - - - --- Functor - -instance Functor (Drawing u) where - fmap f ma = Drawing $ \ctx -> - let (a,w) = getDrawing ma ctx in (f a,w) - - -instance Monad m => Functor (DrawingT u m) where - fmap f ma = DrawingT $ \ctx -> - getDrawingT ma ctx >>= \(a,w) -> return (f a,w) - - - --- Applicative - -instance Applicative (Drawing u) where - pure a = Drawing $ \_ -> (a, mempty) - mf <*> ma = Drawing $ \ctx -> let (f,w1) = getDrawing mf ctx - (a,w2) = getDrawing ma ctx - in (f a, w1 `mappend` w2) - - -instance Monad m => Applicative (DrawingT u m) where - pure a = DrawingT $ \_ -> return (a,mempty) - mf <*> ma = DrawingT $ \ctx -> getDrawingT mf ctx >>= \(f,w1) -> - getDrawingT ma ctx >>= \(a,w2) -> - return (f a, w1 `mappend` w2) - --- Monad - -instance Monad (Drawing u) where - return a = Drawing $ \_ -> (a, mempty) - ma >>= k = Drawing $ \ctx -> let (a,w1) = getDrawing ma ctx - (b,w2) = (getDrawing . k) a ctx - in (b,w1 `mappend` w2) - - - - -instance Monad m => Monad (DrawingT u m) where - return a = DrawingT $ \_ -> return (a, mempty) - ma >>= k = DrawingT $ \ctx -> getDrawingT ma ctx >>= \(a,w1) -> - (getDrawingT . k) a ctx >>= \(b,w2) -> - return (b, w1 `mappend` w2) - - - - --- TraceM --- --- Note - @ state `mappend` a @ means the first expression in a --- monadic drawing is the first element in the output file. It is --- also \*\* at the back \*\* in the the Z-Order. --- --- Some control over the Z-Order, possibly by adding /layers/ to --- the drawing model would be valuable. --- - -instance TraceM (Drawing u) where - trace a = Drawing $ \_ -> ((), a) - - -instance Monad m => TraceM (DrawingT u m) where - trace a = DrawingT $ \_ -> return ((), a) - - - --- DrawingCtxM - -instance DrawingCtxM (Drawing u) where - askDC = Drawing $ \ctx -> (ctx, mempty) - localize upd ma = Drawing $ \ctx -> getDrawing ma (upd ctx) - - - -instance Monad m => DrawingCtxM (DrawingT u m) where - askDC = DrawingT $ \ctx -> return (ctx,mempty) - localize upd ma = DrawingT $ \ctx -> getDrawingT ma (upd ctx) - - - --- Note - the result type of runDrawing and friends needs more --- thought and may change. --- --- Possibly a wrapped HPrim that only supports concat and safe --- extraction is best. --- --- Or it could generate a picture, but then separate drawings --- need the picture combinators to put them together. --- - - -runDrawing :: DrawingContext -> Drawing u a -> (a, HPrim u) -runDrawing ctx ma = getDrawing ma ctx - --- | Run the drawing returning only the output it produces, drop --- any answer from the monadic computation. --- -execDrawing :: DrawingContext -> Drawing u a -> HPrim u -execDrawing ctx ma = snd $ runDrawing ctx ma - --- | Run the drawing ignoring the output it produces, return the --- answer from the monadic computation. --- --- Note - this useful for testing, generally one would want the --- opposite behaviour (return the drawing, ignore than the --- answer). --- -evalDrawing :: DrawingContext -> Drawing u a -> a -evalDrawing ctx ma = fst $ runDrawing ctx ma - - - -runDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (a, HPrim u) -runDrawingT ctx ma = getDrawingT ma ctx - -execDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m (HPrim u) -execDrawingT ctx ma = liftM snd $ runDrawingT ctx ma - - -evalDrawingT :: Monad m => DrawingContext -> DrawingT u m a -> m a -evalDrawingT ctx ma = liftM fst $ runDrawingT ctx ma - +runDrawing :: DrawingContext -> Drawing u -> Maybe (Picture u) +runDrawing ctx drw = runCF ctx (getDrawing drw) --- | Run the Drawing generating a Picture /within/ a --- \"font delta context\" using the font-family and font-size --- from the intial DrawingContext. --- --- Using a /font delta context/ can reduce the code size of the --- generated SVG file (PostScript ignores the FDC). --- -runFdcDrawing :: (Real u, Floating u, FromPtSize u) - => DrawingContext -> Drawing u a -> (a, Maybe (Picture u)) -runFdcDrawing ctx ma = - let (a,hp) = runDrawing ctx ma - ps = hprimToList hp - fdc = font_props ctx - in if null ps then (a, Nothing) - else (a, Just $ fontDeltaContext fdc $ frame ps) - --- | /exec/ version of 'runFdcContext'. --- -execFdcDrawing :: (Real u, Floating u, FromPtSize u) - => DrawingContext -> Drawing u a -> Maybe (Picture u) -execFdcDrawing ctx ma = snd $ runFdcDrawing ctx ma - --- | Transformer version of 'runFdcDrawing'. --- -runFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m) - => DrawingContext -> DrawingT u m a -> m (a, Maybe (Picture u)) -runFdcDrawingT ctx ma = - runDrawingT ctx ma >>= \(a,hp) -> - let ps = hprimToList hp - fdc = font_props ctx - in if null ps then return (a, Nothing) - else return (a, Just $ fontDeltaContext fdc $ frame ps) - --- | Transformer version of 'execFdcDrawing'. --- -execFdcDrawingT :: (Real u, Floating u, FromPtSize u, Monad m) - => DrawingContext -> DrawingT u m a -> m (Maybe (Picture u)) -execFdcDrawingT ctx ma = liftM snd $ runFdcDrawingT ctx ma - --- | /Unsafe/ promotion of @HPrim@ to @Picture@. --- --- If the HPrim is empty, a run-time error is thrown. --- -liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u -liftToPictureU hf = - let prims = hprimToList hf in if null prims then errK else frame prims +runDrawingU :: DrawingContext -> Drawing u -> Picture u +runDrawingU ctx df = maybe fk id $ runDrawing ctx df where - errK = error "toPictureU - empty prims list." + fk = error "runDrawingU - empty Drawing." --- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@. --- --- If the HPrim is empty, then @Nothing@ is returned. --- -liftToPictureMb :: (Real u, Floating u, FromPtSize u) - => HPrim u -> Maybe (Picture u) -liftToPictureMb hf = let prims = hprimToList hf in - if null prims then Nothing else Just (frame prims) +drawTracing :: (Real u, Floating u, FromPtSize u) + => TraceDrawing u a -> Drawing u +drawTracing mf = Drawing $ + drawingCtx >>= \ctx -> return (liftToPictureMb (execTraceDrawing ctx mf) ) --- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@. + +-- Note - cannot get an answer from a TraceDrawing with this +-- Drawing type. There is nowhere to put the answer in the type. -- --- This is equivalent to: +-- If the type was extended: -- --- > fromMaybe (error "empty") $ pic +-- > newtype Drawing u a = Drawing { getDrawing :: CF (a, Maybe (Picture u))) } -- --- This function is solely a convenience, using it saves one --- import and a few characters. +-- 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)? -- --- If the supplied value is @Nothing@ a run-time error is thrown. --- -mbPictureU :: (Real u, Floating u, FromPtSize u) - => Maybe (Picture u) -> Picture u -mbPictureU Nothing = error "mbPictureU - empty picture." -mbPictureU (Just a) = a - --- Note - need an equivalent to Parsec\`s parseTest that provides --- a very simple way to run graphics without concern for return --- type or initial drawing context. - -------------------------------------------------------------------------------- --- | Draw a Graphic taking the drawing style from the --- /drawing context/. --- --- This operation is analogeous to @tell@ in a Writer monad. --- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () -draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf) +clipDrawing :: (Num u, Ord u) => (PrimPath u) -> Drawing u -> Drawing u +clipDrawing cpath = modifyDrawing (clip cpath) --- | Hyperlink version of 'draw'. --- -xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Graphic u -> m () -xdraw xl gf = draw (xlinkGraphic xl gf) +modifyDrawing :: (Picture u -> Picture u) -> Drawing u -> Drawing u +modifyDrawing pf = Drawing . postpro (fmap pf) . getDrawing +instance (Real u, Floating u) => Rotate (Drawing u) where + rotate ang = modifyDrawing (rotate ang) --- | Draw an Image taking the drawing style from the --- /drawing context/. --- --- The graphic representation of the Image is drawn in the Trace --- monad, and the result is returned. --- -drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a -drawi img = askDC >>= \ctx -> - let (a,o) = runImage ctx img in trace (collectH o) >> return a +instance (Real u, Floating u) => RotateAbout (Drawing u) where + rotateAbout r pt = modifyDrawing (rotateAbout r pt) --- | Forgetful 'drawi'. --- -drawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m () -drawi_ img = drawi img >> return () +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) --- | Hyperlink version of 'drawi'. --- -xdrawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Image u a -> m a -xdrawi xl img = drawi (xlinkImage xl img) --- | Forgetful 'xdrawi'. --- -xdrawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Image u a -> m () -xdrawi_ xl img = xdrawi xl img >> return () -infixr 1 `at` -at :: (Point2 u -> a) -> Point2 u -> a -at = ($) - +drawingConcat :: (Picture u -> Picture u -> Picture u) + -> Drawing u -> Drawing u -> Drawing u +drawingConcat op a b = Drawing $ mbpostcomb op (getDrawing a) (getDrawing b) -node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) - => LocGraphic u -> m () -node gfL = askDC >>= \ctx -> - position >>= \pt -> - trace (collectH $ runGraphic ctx $ gfL pt) - - -nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) - => LocImage u a -> m a -nodei imgL = askDC >>= \ctx -> - position >>= \pt -> - let (a,o) = runImage ctx (imgL pt) - in trace (collectH o) >> return a - +mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a) +mbpostcomb op = postcomb fn + where + fn (Just a) (Just b) = Just $ a `op` b + fn a Nothing = a + fn Nothing b = b diff --git a/src/Wumpus/Basic/Graphic/DrawingContext.hs b/src/Wumpus/Basic/Graphic/DrawingContext.hs --- a/src/Wumpus/Basic/Graphic/DrawingContext.hs +++ b/src/Wumpus/Basic/Graphic/DrawingContext.hs @@ -28,6 +28,8 @@ , DrawingContextF , standardContext + , metricsContext + , default_drawing_context -- * Modifiers @@ -69,41 +71,78 @@ , strokeColour , fillColour - + -- * Glyph metrics + , withFontMetrics ) where -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Colour.SVGColours +import Wumpus.Basic.Graphic.GlyphMetrics -import Wumpus.Core -- package: wumpus-core +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.StandardEncoding import Control.Applicative +import qualified Data.Map as Map +import Data.Maybe + data DrawingContext = DrawingContext - { stroke_props :: StrokeAttr + { glyph_tables :: BaseGlyphMetrics + , fallback_metrics :: GlyphMetrics + , stroke_props :: StrokeAttr , font_props :: FontAttr , stroke_colour :: RGBi -- also text colour... , fill_colour :: RGBi , line_spacing_factor :: Double } - deriving (Eq,Show) +-- TODO - hand craft a Show instance + type DrawingContextF = DrawingContext -> DrawingContext standardContext :: FontSize -> DrawingContext standardContext sz = - DrawingContext { stroke_props = default_stroke_attr - , font_props = FontAttr sz courier - , stroke_colour = black - , fill_colour = light_gray + DrawingContext { glyph_tables = Map.empty + , fallback_metrics = monospace_metrics + , stroke_props = default_stroke_attr + , font_props = FontAttr sz wumpus_courier + , stroke_colour = wumpus_black + , fill_colour = wumpus_light_gray , line_spacing_factor = 1.2 } +metricsContext :: FontSize -> BaseGlyphMetrics -> DrawingContext +metricsContext sz bgm = + DrawingContext { glyph_tables = bgm + , fallback_metrics = monospace_metrics + , stroke_props = default_stroke_attr + , font_props = FontAttr sz wumpus_courier + , stroke_colour = wumpus_black + , fill_colour = wumpus_light_gray + , line_spacing_factor = 1.2 + } + + + + +wumpus_black :: RGBi +wumpus_black = RGBi 0 0 0 + +wumpus_light_gray :: RGBi +wumpus_light_gray = RGBi 200 200 200 + + +-- | Courier +-- +wumpus_courier :: FontFace +wumpus_courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding + + + default_drawing_context :: DrawingContext default_drawing_context = standardContext (font_size wumpus_default_font) @@ -261,4 +300,25 @@ fillColour :: RGBi -> DrawingContextF fillColour rgb = \s -> s { fill_colour = rgb } + + + + + +-------------------------------------------------------------------------------- +-- Glyph metrics + +-- These are directly on the DrawingContext /for efficiency/. + + + +withFontMetrics :: (GlyphMetrics -> PtSize -> u) -> DrawingContext -> u +withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = + fn metric_set point_sz + where + ps_name = ps_font_name $ font_face font_stats + point_sz = fromIntegral $ font_size font_stats + metric_set = fromMaybe (fallback_metrics ctx) $ + Map.lookup ps_name (glyph_tables ctx) + diff --git a/src/Wumpus/Basic/Graphic/GlyphMetrics.hs b/src/Wumpus/Basic/Graphic/GlyphMetrics.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/GlyphMetrics.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.GlyphMetrics +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Data types representing glyph metrics loaded from font files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.GlyphMetrics + ( + + FontName + , CodePoint + , GlyphMetricsTable(..) + , GlyphMetrics(..) + , buildMetrics + , BaseGlyphMetrics + , monospace_metrics + + + ) where + +import Wumpus.Core -- package: wumpus-core + +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map + +type FontName = String + +-- | A Unicode code-point. +-- +type CodePoint = Int + + +-- | NOTE - GlyphMetrics table is parametric on @cu@ - +-- /Character unit/ and not on the usual @u@. +-- +data GlyphMetricsTable cu = GlyphMetricsTable + { glyph_bounding_box :: BoundingBox cu + , glyph_default_adv_vec :: Vec2 cu + , glyph_adv_vecs :: IntMap.IntMap (Vec2 cu) + , glyph_cap_height :: cu + } + + +-- unit_scale_fun :: PtSize -> cu -> u +-- + +-- afmValue :: FromPtSize u => AfmUnit -> PtSize -> u +-- + +data GlyphMetrics = GlyphMetrics + { get_bounding_box :: forall u. FromPtSize u => PtSize -> BoundingBox u + , get_av_lookup :: forall u. FromPtSize u => PtSize -> (CodePoint -> Vec2 u) + , get_cap_height :: forall u. FromPtSize u => PtSize -> u + } + + +type BaseGlyphMetrics = Map.Map FontName GlyphMetrics + +-- | This ignores the Char code lookup and just returns the +-- default advance vector. +-- +monospace_metrics :: GlyphMetrics +monospace_metrics = GlyphMetrics + { get_bounding_box = \sz -> BBox (lowerLeft sz) (upperRight sz) + , get_av_lookup = \sz _ -> hvec (upscale sz width_vec) + , get_cap_height = \sz -> upscale sz cap_height + } + where + llx = (-23) / 1000 + lly = (-250) / 1000 + urx = 715 / 1000 + ury = 805 / 1000 + width_vec = 600 / 1000 + cap_height = 562 / 1000 + + upscale sz d = fromPtSize $ sz * d + lowerLeft sz = P2 (upscale sz llx) (upscale sz lly) + upperRight sz = P2 (upscale sz urx) (upscale sz ury) + + +buildMetrics :: (cu -> PtSize) -> GlyphMetricsTable cu -> GlyphMetrics + +buildMetrics fn (GlyphMetricsTable (BBox ll ur) (V2 vx vy) + vec_table cap_height) = + GlyphMetrics + { get_bounding_box = \sz -> BBox (scalePt sz ll) (scalePt sz ur) + , get_av_lookup = \sz i -> + maybe (defaultAV sz) (scaleVec sz) $ IntMap.lookup i vec_table + , get_cap_height = \sz -> upscale sz (fn cap_height) + } + where + upscale sz d = fromPtSize $ sz * d + + defaultAV sz = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) + scalePt sz (P2 cx cy) = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) + scaleVec sz (V2 cx cy) = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) + + + diff --git a/src/Wumpus/Basic/Graphic/GraphicOperations.hs b/src/Wumpus/Basic/Graphic/GraphicOperations.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/GraphicOperations.hs @@ -0,0 +1,399 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.GraphicOperations +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Elementary functions for the Graphic and LocGraphic types. +-- +-- The functions here are generally analogeous to the Picture +-- API in @Wumpus.Core@, but here they exploit the implicit +-- @DrawingContext@. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.GraphicOperations + ( + drawGraphic + + , openStroke + , closedStroke + , filledPath + , borderedPath + + + , textline + , rtextline + , centermonoTextline + , escapedline + , rescapedline + + , textlineMulti + , hkernline + , vkernline + + + , strokedEllipse + , filledEllipse + , borderedEllipse + + , supplyPt + , localPoint + , vecdisplace + , displace + , hdisplace + , vdisplace + , parallelvec + , perpendicularvec + , displaceParallel + , displacePerpendicular + + + , straightLine + , straightLineBetween + , curveBetween + + + , strokedRectangle + , filledRectangle + , borderedRectangle + + + , strokedCircle + , filledCircle + , borderedCircle + + , strokedDisk + , filledDisk + , borderedDisk + + + , illustrateBoundedGraphic + , illustrateBoundedLocGraphic + + ) where + +import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.ContextFunction +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Graphic.GraphicTypes +import Wumpus.Basic.Graphic.Query + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + + + +drawGraphic :: (Real u, Floating u, FromPtSize u) + => DrawingContext -> Graphic u -> Picture u +drawGraphic ctx gf = frame [getPrimGraphic $ runGraphic ctx gf] + + + + +openStroke :: Num u => PrimPath u -> Graphic u +openStroke pp = + withStrokeAttr $ \rgb attr -> primGraphic $ ostroke rgb attr pp + +closedStroke :: Num u => PrimPath u -> Graphic u +closedStroke pp = + withStrokeAttr $ \rgb attr -> primGraphic $ cstroke rgb attr pp + +filledPath :: Num u => PrimPath u -> Graphic u +filledPath pp = withFillAttr $ \rgb -> primGraphic $ fill rgb pp + + + +borderedPath :: Num u => PrimPath u -> Graphic u +borderedPath pp = + withBorderedAttr $ \frgb attr srgb -> + primGraphic $ fillStroke frgb attr srgb pp + + +-- Note - clipping needs a picture as well as a path, so there is +-- no analogous @clippedPath@ function. + + +-------------------------------------------------------------------------------- +-- + +locPrimGraphic :: (Point2 u -> Primitive u) -> (Point2 u -> PrimGraphic u) +locPrimGraphic fn = primGraphic . fn + +thetaLocPrimGraphic :: (Point2 u -> Radian -> Primitive u) + -> (Point2 u -> Radian -> PrimGraphic u) +thetaLocPrimGraphic fn = \pt theta -> primGraphic (fn pt theta) + + + + +textline :: Num u => String -> LocGraphic u +textline ss = + withTextAttr $ \rgb attr -> locPrimGraphic (textlabel rgb attr ss) + + + +rtextline :: Num u => String -> LocThetaGraphic u +rtextline ss = + withTextAttr $ \rgb attr -> thetaLocPrimGraphic + (\pt ang -> rtextlabel rgb attr ss pt ang) + + + + +-- | As 'textline' but the supplied point is the /center/. +-- +-- Centered is inexact - it is calculated with monospaced font +-- metrics. +-- +centermonoTextline :: (Fractional u, Ord u, FromPtSize u) + => String -> LocGraphic u +centermonoTextline ss = monoVecToCenter ss >>= \v -> + moveLoc (vecdisplace (negateV v)) (textline ss) + + + +escapedline :: Num u => EscapedText -> LocGraphic u +escapedline ss = + withTextAttr $ \rgb attr -> locPrimGraphic (escapedlabel rgb attr ss) + + +rescapedline :: Num u => EscapedText -> LocThetaGraphic u +rescapedline ss = + withTextAttr $ \rgb attr -> thetaLocPrimGraphic + (\pt ang -> rescapedlabel rgb attr ss pt ang) + + + +-- | Point is the baseline left of the bottom line, text is +-- left-aligned. +-- +textlineMulti :: Fractional u => [String] -> LocGraphic u +textlineMulti xs = baselineSpacing >>= \dy -> + extrLocGraphic $ go (tmStep dy) xs + where + -- go /starts/ at the end of the list and works back. + go fn [] = fn "" -- not ideal, better than error + go fn [s] = fn s + go fn (s:ss) = let ans = go fn ss in ans `feedPt` fn s + +-- LocImage u (Point2 u) deserved to be a new type synonym +-- as it models PostScript\'s @show@ + + +tmStep :: Num u => u -> String -> LocImage u (Point2 u) +tmStep dy str = intoLocImage (raise $ \pt -> pt .+^ vvec dy) (textline str) + +feedPt :: LocImage u (Point2 u) -> LocImage u (Point2 u) -> LocImage u (Point2 u) +feedPt = accumulate1 oplus + +hkernline :: Num u => [KerningChar u] -> LocGraphic u +hkernline ks = + withTextAttr $ \rgb attr -> locPrimGraphic (hkernlabel rgb attr ks) + + +vkernline :: Num u => [KerningChar u] -> LocGraphic u +vkernline ks = + withTextAttr $ \rgb attr -> locPrimGraphic (vkernlabel rgb attr ks) + + + +-------------------------------------------------------------------------------- + + +strokedEllipse :: Num u => u -> u -> LocGraphic u +strokedEllipse hw hh = + withStrokeAttr $ \rgb attr -> locPrimGraphic (strokeEllipse rgb attr hw hh) + + +filledEllipse :: Num u => u -> u -> LocGraphic u +filledEllipse hw hh = + withFillAttr $ \rgb -> locPrimGraphic (fillEllipse rgb hw hh) + + +borderedEllipse :: Num u => u -> u -> LocGraphic u +borderedEllipse hw hh = + withBorderedAttr $ \frgb attr srgb -> + locPrimGraphic (fillStrokeEllipse frgb attr srgb hw hh) + +-------------------------------------------------------------------------------- + + +-- | Supplying a point to a 'CFGraphic' takes it to a regular +-- 'Graphic'. +-- +supplyPt :: Point2 u -> LocGraphic u -> Graphic u +supplyPt pt gf = fmap ($ pt) gf + + + +vecdisplace :: Num u => Vec2 u -> PointDisplace u +vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy) + + +displace :: Num u => u -> u -> PointDisplace u +displace dx dy (P2 x y) = P2 (x+dx) (y+dy) + +hdisplace :: Num u => u -> PointDisplace u +hdisplace dx (P2 x y) = P2 (x+dx) y + +vdisplace :: Num u => u -> PointDisplace u +vdisplace dy (P2 x y) = P2 x (y+dy) + + + + +parallelvec :: Floating u => u -> Radian -> Vec2 u +parallelvec d r = avec (circularModulo r) d + +perpendicularvec :: Floating u => u -> Radian -> Vec2 u +perpendicularvec d r = avec (circularModulo $ (0.5*pi) + r) d + +displaceParallel :: Floating u => u -> Radian -> PointDisplace u +displaceParallel d r pt = pt .+^ parallelvec d r + +displacePerpendicular :: Floating u => u -> Radian -> PointDisplace u +displacePerpendicular d r pt = pt .+^ perpendicularvec d r + + +localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u +localPoint = moveLoc + + + +-------------------------------------------------------------------------------- + + +straightLine :: Fractional u => Vec2 u -> LocGraphic u +straightLine v = + promote1 $ \pt -> openStroke $ primPath pt [lineTo $ pt .+^ v] + + +straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u +straightLineBetween p1 p2 = openStroke $ primPath p1 [lineTo p2] + + + +curveBetween :: Fractional u + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u +curveBetween sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep] + + + +-- | Supplied point is /bottom-left/. +-- +rectangle :: Num u => u -> u -> Point2 u -> PrimPath u +rectangle w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ] + where + br = bl .+^ hvec w + tr = br .+^ vvec h + tl = bl .+^ vvec h + +-- This is basically the cardinal-prime combinator with arguments +-- at specific types +-- +-- > cardinal' :: (a -> r1 -> ans) -> (r2 -> a) -> (r1 -> r2 -> ans) +-- + +drawWith :: (PrimPath u -> Graphic u) -> (Point2 u -> PrimPath u) -> LocGraphic u +drawWith mf g = promote1 $ \pt -> (mf $ g pt) + +-- | Supplied point is /bottom left/. +-- +strokedRectangle :: Fractional u => u -> u -> LocGraphic u +strokedRectangle w h = drawWith closedStroke (rectangle w h) + + +-- | Supplied point is /bottom left/. +-- +filledRectangle :: Fractional u => u -> u -> LocGraphic u +filledRectangle w h = drawWith borderedPath (rectangle w h) + +-- | Supplied point is /bottom left/. +-- +borderedRectangle :: Fractional u => u -> u -> LocGraphic u +borderedRectangle w h = drawWith borderedPath (rectangle w h) + + + + +-------------------------------------------------------------------------------- + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +strokedCircle :: Floating u => Int -> u -> LocGraphic u +strokedCircle n r = drawWith closedStroke (curvedPath . bezierCircle n r) + + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +filledCircle :: Floating u => Int -> u -> LocGraphic u +filledCircle n r = drawWith filledPath (curvedPath . bezierCircle n r) + + + +-- | Supplied point is center. Circle is drawn with Bezier +-- curves. +-- +borderedCircle :: Floating u => Int -> u -> LocGraphic u +borderedCircle n r = drawWith borderedPath (curvedPath . bezierCircle n r) + + + +-- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive. +-- +-- This is a efficient representation of circles using +-- PostScript\'s @arc@ or SVG\'s @circle@ in the generated +-- output. However, stroked-circles do not draw well after +-- non-uniform scaling - the line width is scaled as well as +-- the shape. +-- +-- For stroked circles that can be scaled, consider making the +-- circle from Bezier curves. +-- +strokedDisk :: Num u => u -> LocGraphic u +strokedDisk radius = strokedEllipse radius radius + + +filledDisk :: Num u => u -> LocGraphic u +filledDisk radius = filledEllipse radius radius + +borderedDisk :: Num u => u -> LocGraphic u +borderedDisk radius = borderedEllipse radius radius + +-------------------------------------------------------------------------------- +-- + +illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u +illustrateBoundedGraphic mf = mf >>= \(bb,g1) -> + bbrectangle bb >>= \g2 -> + return (bb, g2 `oplus` g1) + + +illustrateBoundedLocGraphic :: Fractional u + => BoundedLocGraphic u -> BoundedLocGraphic u +illustrateBoundedLocGraphic mf = + promote1 $ \pt -> illustrateBoundedGraphic (unLoc pt mf) + + +bbrectangle :: Fractional u => BoundingBox u -> Graphic u +bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury)) = + localize drawing_props $ rect1 `oplus` cross + where + drawing_props = strokeColour blue . capRound . dashPattern (Dash 0 [(1,2)]) + rect1 = strokedRectangle (urx-llx) (ury-lly) `at` p1 + cross = straightLineBetween p1 p2 + `oplus` straightLineBetween (P2 llx ury) (P2 urx lly) diff --git a/src/Wumpus/Basic/Graphic/GraphicTypes.hs b/src/Wumpus/Basic/Graphic/GraphicTypes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/GraphicTypes.hs @@ -0,0 +1,441 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.GraphicTypes +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Refined instances of of the Drawing type modelling specific +-- graphic types. +-- +-- \*\* WARNING \*\* - some names are expected to change. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.GraphicTypes + ( + + + -- * Function from Point to Point + PointDisplace + + -- * Advance vector + , AdvanceVec + + -- * Drawing info + , DrawingInfo + , LocDrawingInfo + , LocThetaDrawingInfo + + -- * Graphic + , Graphic + , LocGraphic + , LocThetaGraphic + , ConnectorGraphic + + , DGraphic + , DLocGraphic + , DLocThetaGraphic + , DConnectorGraphic + + + -- * Image + , Image + , LocImage + , LocThetaImage + , ConnectorImage + + , DImage + , DLocImage + , DLocThetaImage + , DConnectorImage + + -- * /Advance vector/ graphic + , AdvGraphic + , DAdvGraphic + + -- * Bounded graphic / loc graphic + , BoundedGraphic + , DBoundedGraphic + , BoundedLocGraphic + , DBoundedLocGraphic + + -- * Extract from an Advance vector + , advanceH + , advanceV + + -- * Run functions + , runGraphic + , runLocGraphic + , runImage + , runLocImage + + -- * Combinators + , moveLoc + , at + + -- * Dropping answers + , extrGraphic + , extrLocGraphic + + + , fontDeltaGraphic + , fontDeltaImage + , xlinkGraphic + , xlinkImage + + , intoImage + , intoLocImage + , intoConnectorImage + , intoLocThetaImage + , makeAdvGraphic + + + ) where + +import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.ContextFunction +import Wumpus.Basic.Graphic.DrawingContext + +import Wumpus.Core -- package: wumpus-core + + + +type PointDisplace u = Point2 u -> Point2 u + + +type AdvanceVec u = Vec2 u + + + + + + +-------------------------------------------------------------------------------- +-- DrawingInfo + +-- | A query on the DrawingContext. +-- +-- Alias for 'CF'. +-- +type DrawingInfo a = CF a + + +-- | A query on the DrawingContext respective to the supplied +-- point. +-- +-- Alias for 'LocCF'. +-- +type LocDrawingInfo u a = LocCF u a + + +-- | A query on the DrawingContext respective to the supplied +-- point and angle. +-- +-- Alias for 'LocCF'. +-- +type LocThetaDrawingInfo u a = LocThetaCF u a + + +-------------------------------------------------------------------------------- +-- Graphic + +-- | Simple drawing - produce a primitive, access the DrawingContext +-- if required. +-- +type Graphic u = CF (PrimGraphic u) + +-- | Commonly graphics take a start point as well as a drawing +-- context. +-- +-- Here they are called a LocGraphic - graphic with a (starting) +-- location. +-- +type LocGraphic u = LocCF u (PrimGraphic u) + + +-- | A function from @point * angle -> graphic@ +-- +type LocThetaGraphic u = LocThetaCF u (PrimGraphic u) + +-- | ConnectorGraphic is a connector drawn between two points +-- contructing a Graphic. +-- +type ConnectorGraphic u = ConnectorCF u (PrimGraphic u) + + + + +type DGraphic = Graphic Double +type DLocGraphic = LocGraphic Double +type DLocThetaGraphic = LocThetaGraphic Double +type DConnectorGraphic = ConnectorGraphic Double + + +type instance DUnit (Graphic u) = u + + +-------------------------------------------------------------------------------- +-- Image + +-- | Images return a value as well as drawing. A /node/ is a +-- typical example - nodes are drawing but the also support +-- taking anchor points. +-- +type Image u a = CF (a, PrimGraphic u) + +type LocImage u a = LocCF u (a,PrimGraphic u) + +type LocThetaImage u a = LocThetaCF u (a,PrimGraphic u) + +-- | ConnectorImage is a connector drawn between two points +-- constructing an Image. +-- +-- Usually the answer type of a ConnectorImage will be a Path so +-- the Points ar @midway@, @atstart@ etc. can be taken on it. +-- +type ConnectorImage u a = ConnectorCF u (a, PrimGraphic u) + + + + + +type DImage a = Image Double a +type DLocImage a = LocImage Double a +type DLocThetaImage a = LocThetaImage Double a +type DConnectorImage a = ConnectorImage Double a + + + +type instance DUnit (Image u a) = u + + +-------------------------------------------------------------------------------- + + +-- | /Advance vector/ graphic - this partially models the +-- PostScript @show@ command which moves the /current point/ by the +-- width (advance) vector as each character is drawn. +-- +type AdvGraphic u = LocImage u (Point2 u) + +type DAdvGraphic = AdvGraphic Double + + +type instance DUnit (AdvGraphic u) = u + + +-------------------------------------------------------------------------------- + +-- | Graphic with a bounding box. +-- +type BoundedGraphic u = Image u (BoundingBox u) + +type DBoundedGraphic = BoundedGraphic Double + + +type instance DUnit (BoundedGraphic u) = u + + +-- | LocGraphic with a bounding box. +-- +type BoundedLocGraphic u = LocImage u (BoundingBox u) + +type DBoundedLocGraphic = BoundedLocGraphic Double + + +type instance DUnit (BoundedLocGraphic u) = u + + + +-------------------------------------------------------------------------------- +-- Graphic instances + + +-- Affine instances + +instance (Real u, Floating u) => Rotate (Graphic u) where + rotate ang = postpro (rotate ang) + + +instance (Real u, Floating u) => RotateAbout (Graphic u) where + rotateAbout ang pt = postpro (rotateAbout ang pt) + + +instance Num u => Scale (Graphic u) where + scale sx sy = postpro (scale sx sy) + + +instance Num u => Translate (Graphic u) where + translate dx dy = postpro (translate dx dy) + +-------------------------------------------------------------------------------- +-- Image instances + +-- Affine instances + + +instance (Real u, Floating u, Rotate a, DUnit a ~ u) => + Rotate (Image u a) where + rotate ang = postpro (\(a,b) -> (rotate ang a, rotate ang b)) + + +instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => + RotateAbout (Image u a) where + rotateAbout ang pt = + postpro (\(a,b) -> (rotateAbout ang pt a, rotateAbout ang pt b)) + + +instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where + scale sx sy = postpro (\(a,b) -> (scale sx sy a, scale sx sy b)) + + +instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where + translate dx dy = postpro (\(a,b) -> (translate dx dy a, translate dx dy b)) + + + +-------------------------------------------------------------------------------- + +-- | Extract the horizontal component of an advance vector. +-- +-- For left-to-right latin text, the vertical component of an +-- advance vector is expected to be 0. Ingoring it seems +-- permissible, e.g. when calculating bounding boxes for +-- left-to-right text. +-- +advanceH :: Num u => AdvanceVec u -> u +advanceH (V2 w _) = w + +-- | Extract the verticaltal component of an advance vector. +-- +-- For left-to-right latin text, the vertical component of an +-- advance vector is expected to be 0. +-- +advanceV :: Num u => AdvanceVec u -> u +advanceV (V2 _ h) = h + + +-------------------------------------------------------------------------------- +-- Run functions + + + +runGraphic :: DrawingContext -> Graphic u -> PrimGraphic u +runGraphic ctx df = runCF ctx df + + +runLocGraphic :: DrawingContext -> Point2 u -> LocGraphic u -> PrimGraphic u +runLocGraphic ctx pt df = runCF ctx (unCF1 pt df) + + + +runImage :: DrawingContext -> Image u a -> (a, PrimGraphic u) +runImage ctx img = runCF ctx img + +runLocImage :: DrawingContext -> Point2 u -> LocImage u a -> (a, PrimGraphic u) +runLocImage ctx pt img = runCF ctx (unCF1 pt img) + + +-------------------------------------------------------------------------------- +-- Combinators + +moveLoc :: (Point2 u -> Point2 u) -> LocCF u a -> LocCF u a +moveLoc = prepro1 + + + +infixr 1 `at` +at :: CF (Point2 u -> b) -> Point2 u -> CF b +at = situ1 + + + + +------------------------------------------------------------------------------- +-- Dropping /answers/ + + +extrGraphic :: Image u a -> Graphic u +extrGraphic = postpro snd + + +extrLocGraphic :: LocImage u a -> LocGraphic u +extrLocGraphic = postpro1 snd + + + +-------------------------------------------------------------------------------- + + +metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u +metamorphPrim f = primGraphic . f . getPrimGraphic + +fontDeltaGraphic :: Graphic u -> Graphic u +fontDeltaGraphic df = + drawingCtx `bind` \ctx -> postpro (fun $ font_props ctx) df + where + fun attr = metamorphPrim (fontDeltaContext attr) + +fontDeltaImage :: Image u a -> Image u a +fontDeltaImage df = + drawingCtx `bind` \ctx -> postpro (fun $ font_props ctx) df + where + fun attr = \(a,prim) -> (a, metamorphPrim (fontDeltaContext attr) prim) + + +xlinkGraphic :: XLink -> Graphic u -> Graphic u +xlinkGraphic hypl = postpro (metamorphPrim (xlink hypl)) + + +xlinkImage :: XLink -> Image u a -> Image u a +xlinkImage hypl = + postpro (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim)) + + + + + +intoImage :: CF a -> Graphic u -> Image u a +intoImage = postcomb (,) + + + +intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a +intoLocImage = postcomb1 (,) + +-- Drawing $ \ctx a -> (getDrawing f ctx a, getDrawing g ctx a) + + +intoConnectorImage :: ConnectorCF u a + -> ConnectorGraphic u + -> ConnectorImage u a +intoConnectorImage = postcomb2 (,) + + + +intoLocThetaImage :: LocThetaCF u a + -> LocThetaGraphic u + -> LocThetaImage u a +intoLocThetaImage = postcomb2 (,) + + +-- | Construction is different to intoZZ functions hence the +-- different name. +-- +makeAdvGraphic :: PointDisplace u + -> LocGraphic u + -> AdvGraphic u +makeAdvGraphic pf df = postcomb1 (,) (postpro1 pf locPoint) df + + + + + diff --git a/src/Wumpus/Basic/Graphic/PrimGraphic.hs b/src/Wumpus/Basic/Graphic/PrimGraphic.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Graphic/PrimGraphic.hs +++ /dev/null @@ -1,319 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Graphic.PrimGraphic --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Elementary functions for the Graphic and LocGraphic types. --- --- The functions here are generally analogeous to the Picture --- API in @Wumpus.Core@, but here they exploit the implicit --- @DrawingContext@. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Graphic.PrimGraphic - ( - drawGraphic - - , openStroke - , closedStroke - , filledPath - , borderedPath - - , textline - , rtextline - , centermonoTextline - , textlineMulti - , hkernline - , vkernline - - - , strokedEllipse - , filledEllipse - , borderedEllipse - - , supplyPt - , localPoint - , vecdisplace - , displace - , hdisplace - , vdisplace - , parallelvec - , perpendicularvec - , displaceParallel - , displacePerpendicular - - - , straightLine - , straightLineBetween - , curveBetween - - , strokedRectangle - , filledRectangle - , borderedRectangle - - - , strokedCircle - , filledCircle - , borderedCircle - - , strokedDisk - , filledDisk - , borderedDisk - - - ) where - -import Wumpus.Basic.Graphic.Base -import Wumpus.Basic.Graphic.DrawingContext -import Wumpus.Basic.Graphic.Query - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - -import Control.Applicative -import Data.Foldable ( foldrM ) - - -drawGraphic :: (Real u, Floating u, FromPtSize u) - => DrawingContext -> Graphic u -> Picture u -drawGraphic ctx gf = frame [getPrimGraphic $ runGraphic ctx gf] - - - - --- having the same names is actually not so useful... - -openStroke :: Num u => PrimPath u -> Graphic u -openStroke pp = - withStrokeAttr $ \rgb attr -> wrapPrim $ ostroke rgb attr pp - -closedStroke :: Num u => PrimPath u -> Graphic u -closedStroke pp = - withStrokeAttr $ \rgb attr -> wrapPrim $ cstroke rgb attr pp - -filledPath :: Num u => PrimPath u -> Graphic u -filledPath pp = withFillAttr $ \rgb -> wrapPrim $ fill rgb pp - - - -borderedPath :: Num u => PrimPath u -> Graphic u -borderedPath pp = - withBorderedAttr $ \frgb attr srgb -> wrapPrim $ fillStroke frgb attr srgb pp - - --- Note - clipping needs a picture as well as a path, so there is --- no analogous @clippedPath@ function. - - --------------------------------------------------------------------------------- --- - - - -textline :: Num u => String -> LocGraphic u -textline ss baseline_left = - withTextAttr $ \rgb attr -> wrapPrim $ textlabel rgb attr ss baseline_left - -rtextline :: Num u => String -> ThetaLocGraphic u -rtextline ss theta baseline_left = - withTextAttr $ \rgb attr -> - wrapPrim $ rtextlabel rgb attr ss theta baseline_left - --- | As 'textline' but the supplied point is the /center/. --- --- Centered is inexact - it is calculated with monospaced font --- metrics. --- -centermonoTextline :: (Fractional u, Ord u, FromPtSize u) - => String -> LocGraphic u -centermonoTextline ss pt = monoVecToCenter ss >>= \v -> - textline ss (vecdisplace (negateV v) pt) - - - - - --- | Point is the baseline left of the bottom line, text is --- left-aligned. --- -textlineMulti :: Fractional u => [String] -> LocGraphic u -textlineMulti xs baseline_left = - baselineSpacing >>= \dy -> - foldrM (foldStep dy) (baseline_left,[]) xs >>= \(_,gs) -> - return (wrapPrim $ primGroup gs) - where - foldStep dy str (pt,ac) = (\a -> (pt .+^ vvec dy, (getPrimGraphic a) : ac)) - <$> textline str pt - - - -hkernline :: Num u => [KerningChar u] -> LocGraphic u -hkernline ks baseline_left = - withTextAttr $ \rgb attr -> wrapPrim $ hkernlabel rgb attr ks baseline_left - - -vkernline :: Num u => [KerningChar u] -> LocGraphic u -vkernline ks baseline_left = - withTextAttr $ \rgb attr -> wrapPrim $ vkernlabel rgb attr ks baseline_left - - - --------------------------------------------------------------------------------- - - -strokedEllipse :: Num u => u -> u -> LocGraphic u -strokedEllipse hw hh pt = - withStrokeAttr $ \rgb attr -> wrapPrim $ strokeEllipse rgb attr hw hh pt - - -filledEllipse :: Num u => u -> u -> LocGraphic u -filledEllipse hw hh pt = - withFillAttr $ \rgb -> wrapPrim $ fillEllipse rgb hw hh pt - - -borderedEllipse :: Num u => u -> u -> LocGraphic u -borderedEllipse hw hh pt = - withBorderedAttr $ \frgb attr srgb -> - wrapPrim $ fillStrokeEllipse frgb attr srgb hw hh pt - --------------------------------------------------------------------------------- - - --- | Supplying a point to a 'CFGraphic' takes it to a regular --- 'Graphic'. --- -supplyPt :: Point2 u -> LocGraphic u -> Graphic u -supplyPt pt gf = gf pt - -vecdisplace :: Num u => Vec2 u -> Point2 u -> Point2 u -vecdisplace (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy) - - -displace :: Num u => u -> u -> Point2 u -> Point2 u -displace dx dy (P2 x y) = P2 (x+dx) (y+dy) - -hdisplace :: Num u => u -> Point2 u -> Point2 u -hdisplace dx (P2 x y) = P2 (x+dx) y - -vdisplace :: Num u => u -> Point2 u -> Point2 u -vdisplace dy (P2 x y) = P2 x (y+dy) - - - -parallelvec :: Floating u => u -> Radian -> Vec2 u -parallelvec d r = avec (circularModulo r) d - -perpendicularvec :: Floating u => u -> Radian -> Vec2 u -perpendicularvec d r = avec (circularModulo $ (0.5*pi) + r) d - -displaceParallel :: Floating u => u -> Radian -> Point2F u -displaceParallel d r pt = pt .+^ parallelvec d r - -displacePerpendicular :: Floating u => u -> Radian -> Point2F u -displacePerpendicular d r pt = pt .+^ perpendicularvec d r - - -localPoint :: (Point2 u -> Point2 u) -> LocGraphic u -> LocGraphic u -localPoint upd gf = \pt -> gf (upd pt) - - --------------------------------------------------------------------------------- - - -straightLine :: Fractional u => Vec2 u -> LocGraphic u -straightLine v = \pt -> openStroke $ path pt [lineTo $ pt .+^ v] - - -straightLineBetween :: Fractional u => Point2 u -> Point2 u -> Graphic u -straightLineBetween p1 p2 = openStroke $ path p1 [lineTo p2] - -curveBetween :: Fractional u - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u -curveBetween sp cp1 cp2 ep = openStroke $ path sp [curveTo cp1 cp2 ep] - - - --- | Supplied point is /bottom-left/. --- -rectangle :: Num u => u -> u -> Point2 u -> PrimPath u -rectangle w h bl = path 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/. --- -strokedRectangle :: Fractional u => u -> u -> LocGraphic u -strokedRectangle w h = closedStroke . rectangle w h - - - --- | Supplied point is /bottom left/. --- -filledRectangle :: Fractional u => u -> u -> LocGraphic u -filledRectangle w h = filledPath . rectangle w h - - --- | Supplied point is /bottom left/. --- -borderedRectangle :: Fractional u => u -> u -> LocGraphic u -borderedRectangle w h = borderedPath . rectangle w h - --------------------------------------------------------------------------------- - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -strokedCircle :: Floating u => Int -> u -> LocGraphic u -strokedCircle n r = closedStroke . curvedPath . bezierCircle n r - - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -filledCircle :: Floating u => Int -> u -> LocGraphic u -filledCircle n r = filledPath . curvedPath . bezierCircle n r - - --- | Supplied point is center. Circle is drawn with Bezier --- curves. --- -borderedCircle :: Floating u => Int -> u -> LocGraphic u -borderedCircle n r = borderedPath . curvedPath . bezierCircle n r - - --- | 'disk' is drawn with Wumpus-Core\'s @ellipse@ primitive. --- --- This is a efficient representation of circles using --- PostScript\'s @arc@ or SVG\'s @circle@ in the generated --- output. However, stroked-circles do not draw well after --- non-uniform scaling - the line width is scaled as well as --- the shape. --- --- For stroked circles that can be scaled, consider making the --- circle from Bezier curves. --- -strokedDisk :: Num u => u -> LocGraphic u -strokedDisk radius = strokedEllipse radius radius - - -filledDisk :: Num u => u -> LocGraphic u -filledDisk radius = filledEllipse radius radius - -borderedDisk :: Num u => u -> LocGraphic u -borderedDisk radius = borderedEllipse radius radius diff --git a/src/Wumpus/Basic/Graphic/Query.hs b/src/Wumpus/Basic/Graphic/Query.hs --- a/src/Wumpus/Basic/Graphic/Query.hs +++ b/src/Wumpus/Basic/Graphic/Query.hs @@ -32,31 +32,43 @@ , lineWidth , fontSize + , fontFace + , fontAttr , markHeight , markHalfHeight , baselineSpacing - -- + -- * Glyph metrics + , glyphBoundingBox + , glyphHeightRange + , glyphHeight + , glyphCapHeight + + , avLookupTable + + -- * Default monospace metrics + + , monoFontPointSize , monoCharWidth - , monoSpacerWidth , monoTextWidth , monoTextLength - , monoTextHeight - , monoNumeralHeight + , monoCapHeight , monoLowerxHeight , monoDescenderDepth + , monoAscenderHeight , monoTextDimensions - , monoMultiLineTextHeight + , monoMultiLineHeight , monoDefaultPadding , monoVecToCenter ) where import Wumpus.Basic.Graphic.Base import Wumpus.Basic.Graphic.DrawingContext - - -import Wumpus.Core -- package: wumpus-core +import Wumpus.Basic.Graphic.GlyphMetrics +import Wumpus.Core -- package: wumpus-core +import qualified Wumpus.Core.FontSize as FS + import Control.Applicative @@ -98,9 +110,14 @@ lineWidth :: DrawingCtxM m => m Double lineWidth = line_width <$> asksDC stroke_props +fontAttr :: DrawingCtxM m => m FontAttr +fontAttr = asksDC font_props + fontSize :: DrawingCtxM m => m Int fontSize = font_size <$> asksDC font_props +fontFace :: DrawingCtxM m => m FontFace +fontFace = font_face <$> asksDC font_props @@ -120,7 +137,7 @@ -- height. -- markHeight :: (DrawingCtxM m, FromPtSize u) => m u -markHeight = (fromPtSize . xcharHeight . font_size) <$> asksDC font_props +markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u @@ -131,48 +148,79 @@ -- markHeight to merit a withMarkHeight function. +-------------------------------------------------------------------------------- +glyphQuery :: DrawingCtxM m => (GlyphMetrics -> PtSize -> u) -> m u +glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC +glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) +glyphBoundingBox = glyphQuery get_bounding_box +glyphHeightRange :: (FromPtSize u, DrawingCtxM m) => m (u,u) +glyphHeightRange = fn <$> glyphBoundingBox + where + fn (BBox (P2 _ ymin) (P2 _ ymax)) = (ymin,ymax) + + +glyphHeight :: (FromPtSize u, DrawingCtxM m) => m u +glyphHeight = (\(ymax,ymin) -> ymax - ymin) <$> glyphHeightRange + + +glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u +glyphCapHeight = glyphQuery get_cap_height + +avLookupTable :: (FromPtSize u, DrawingCtxM m) => m (Int -> Vec2 u) +avLookupTable = glyphQuery get_av_lookup + + -------------------------------------------------------------------------------- withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u withFontSize fn = (fn . font_size) <$> asksDC font_props -monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u -monoCharWidth = withFontSize (fromPtSize . charWidth) -monoSpacerWidth :: (DrawingCtxM m, FromPtSize u) => m u -monoSpacerWidth = withFontSize (fromPtSize . spacerWidth) +-- NOTE - textHeight in Wumpus-Core should be renamed as it is +-- (probably) more indiactive of Cap height than /font point size/ +-- +monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u +monoFontPointSize = withFontSize (fromPtSize . fromIntegral) +monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u +monoCharWidth = withFontSize (fromPtSize . FS.charWidth) + + monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u -monoTextWidth n = withFontSize $ \sz -> fromPtSize $ textWidth sz n +monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u monoTextLength ss = monoTextWidth $ charCount ss -monoTextHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoTextHeight = withFontSize (fromPtSize . textHeight) +monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoCapHeight = withFontSize (fromPtSize . FS.capHeight) -monoNumeralHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoNumeralHeight = withFontSize (fromPtSize . numeralHeight) +monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight) + -- | Height of a lower case \'x\' in Courier. -- -- \'x\' has no ascenders or descenders. -- monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoLowerxHeight = withFontSize (fromPtSize . xcharHeight) +monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight) monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u -monoDescenderDepth = withFontSize (fromPtSize . descenderDepth) +monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) +monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u +monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) + -- | Query the dimensions of the text using the current font size -- but using metrics derived from Courier. -- @@ -188,12 +236,19 @@ post bb = (boundaryWidth bb, boundaryHeight bb) -monoMultiLineTextHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) +-- | The heigth of @n@ lines of text, which is +-- @n lines + n-1 line spacers@ +-- +monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => Int -> m u -monoMultiLineTextHeight n | n < 0 = pure 0 -monoMultiLineTextHeight n = +monoMultiLineHeight n | n < 0 = pure 0 +monoMultiLineHeight n = (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf)) - <$> monoTextHeight <*> asksDC line_spacing_factor + <$> monoTotalCharHeight <*> asksDC line_spacing_factor + + -- Note as the height calculation has changed in Wumpus-Core this + -- no longer quite works... + -- | The default padding is half of the /char width/. diff --git a/src/Wumpus/Basic/Graphic/TraceDrawing.hs b/src/Wumpus/Basic/Graphic/TraceDrawing.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Graphic/TraceDrawing.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Graphic.TraceDrawing +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Drawing with /trace/ - a Writer like monad collecting +-- intermediate graphics - and /drawing context/ - a reader monad +-- of attributes - font_face, fill_colour etc. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Graphic.TraceDrawing + ( + + TraceDrawing + , TraceDrawingT + , runTraceDrawing + , execTraceDrawing + , evalTraceDrawing + , runTraceDrawingT + , execTraceDrawingT + , evalTraceDrawingT + + , liftToPictureU + , liftToPictureMb + , mbPictureU + + + , query + , draw + , xdraw + , drawi + , drawi_ + , xdrawi + , xdrawi_ + + , node + , nodei + + ) where + + +import Wumpus.Basic.Graphic.Base +import Wumpus.Basic.Graphic.ContextFunction +import Wumpus.Basic.Graphic.DrawingContext +import Wumpus.Basic.Graphic.GraphicTypes + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative +import Control.Monad +import Data.Monoid + + + +-- Note - TraceDrawing run \once\ - it is supplied with the starting +-- environment (DrawingContext) and returns a Picture. +-- +-- Other Wumpus monads (e.g. Turtle) will typically be run inside +-- the TraceDrawing monad as a local effect, rather than built into a +-- transformer stack. +-- + + +newtype TraceDrawing u a = TraceDrawing { + getTraceDrawing :: DrawingContext -> (a, HPrim u) } + +newtype TraceDrawingT u m a = TraceDrawingT { + getTraceDrawingT :: DrawingContext -> m (a, HPrim u) } + + + +type instance MonUnit (TraceDrawing u) = u +type instance MonUnit (TraceDrawingT u m) = u + + + +-- Functor + +instance Functor (TraceDrawing u) where + fmap f ma = TraceDrawing $ \ctx -> + let (a,w) = getTraceDrawing ma ctx in (f a,w) + + +instance Monad m => Functor (TraceDrawingT u m) where + fmap f ma = TraceDrawingT $ \ctx -> + getTraceDrawingT ma ctx >>= \(a,w) -> return (f a,w) + + + +-- Applicative + +instance Applicative (TraceDrawing u) where + pure a = TraceDrawing $ \_ -> (a, mempty) + mf <*> ma = TraceDrawing $ \ctx -> + let (f,w1) = getTraceDrawing mf ctx + (a,w2) = getTraceDrawing ma ctx + in (f a, w1 `mappend` w2) + + +instance Monad m => Applicative (TraceDrawingT u m) where + pure a = TraceDrawingT $ \_ -> return (a,mempty) + mf <*> ma = TraceDrawingT $ \ctx -> + getTraceDrawingT mf ctx >>= \(f,w1) -> + getTraceDrawingT ma ctx >>= \(a,w2) -> + return (f a, w1 `mappend` w2) + +-- Monad + +instance Monad (TraceDrawing u) where + return a = TraceDrawing $ \_ -> (a, mempty) + ma >>= k = TraceDrawing $ \ctx -> + let (a,w1) = getTraceDrawing ma ctx + (b,w2) = (getTraceDrawing . k) a ctx + in (b,w1 `mappend` w2) + + + + +instance Monad m => Monad (TraceDrawingT u m) where + return a = TraceDrawingT $ \_ -> return (a, mempty) + ma >>= k = TraceDrawingT $ \ctx -> + getTraceDrawingT ma ctx >>= \(a,w1) -> + (getTraceDrawingT . k) a ctx >>= \(b,w2) -> + return (b, w1 `mappend` w2) + + + + +-- TraceM +-- +-- Note - @ state `mappend` a @ means the first expression in a +-- monadic drawing is the first element in the output file. It is +-- also \*\* at the back \*\* in the the Z-Order. +-- +-- Some control over the Z-Order, possibly by adding /layers/ to +-- the drawing model would be valuable. +-- + +instance TraceM (TraceDrawing u) where + trace a = TraceDrawing $ \_ -> ((), a) + + +instance Monad m => TraceM (TraceDrawingT u m) where + trace a = TraceDrawingT $ \_ -> return ((), a) + + + +-- DrawingCtxM + +instance DrawingCtxM (TraceDrawing u) where + askDC = TraceDrawing $ \ctx -> (ctx, mempty) + localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx) + + + +instance Monad m => DrawingCtxM (TraceDrawingT u m) where + askDC = TraceDrawingT $ \ctx -> return (ctx,mempty) + localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx) + + + +-- Note - the result type of runTraceDrawing and friends needs more +-- thought and may change. +-- +-- Possibly a wrapped HPrim that only supports concat and safe +-- extraction is best. +-- +-- Or it could generate a picture, but then separate drawings +-- need the picture combinators to put them together. +-- + + +runTraceDrawing :: DrawingContext -> TraceDrawing u a -> (a, HPrim u) +runTraceDrawing ctx ma = getTraceDrawing ma ctx + +-- | Run the drawing returning only the output it produces, drop +-- any answer from the monadic computation. +-- +execTraceDrawing :: DrawingContext -> TraceDrawing u a -> HPrim u +execTraceDrawing ctx ma = snd $ runTraceDrawing ctx ma + +-- | Run the drawing ignoring the output it produces, return the +-- answer from the monadic computation. +-- +-- Note - this useful for testing, generally one would want the +-- opposite behaviour (return the drawing, ignore than the +-- answer). +-- +evalTraceDrawing :: DrawingContext -> TraceDrawing u a -> a +evalTraceDrawing ctx ma = fst $ runTraceDrawing ctx ma + + + +runTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m (a, HPrim u) +runTraceDrawingT ctx ma = getTraceDrawingT ma ctx + +execTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m (HPrim u) +execTraceDrawingT ctx ma = liftM snd $ runTraceDrawingT ctx ma + + +evalTraceDrawingT :: Monad m + => DrawingContext -> TraceDrawingT u m a -> m a +evalTraceDrawingT ctx ma = liftM fst $ runTraceDrawingT ctx ma + + + +-- | /Unsafe/ promotion of @HPrim@ to @Picture@. +-- +-- If the HPrim is empty, a run-time error is thrown. +-- +liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u +liftToPictureU hf = + let prims = hprimToList hf in if null prims then errK else frame prims + where + errK = error "toPictureU - empty prims list." + +-- | /Safe/ promotion of @HPrim@ to @(Maybe Picture)@. +-- +-- If the HPrim is empty, then @Nothing@ is returned. +-- +liftToPictureMb :: (Real u, Floating u, FromPtSize u) + => HPrim u -> Maybe (Picture u) +liftToPictureMb hf = let prims = hprimToList hf in + if null prims then Nothing else Just (frame prims) + + + +-- | /Unsafe/ promotion of @(Maybe Picture)@ to @Picture@. +-- +-- This is equivalent to: +-- +-- > fromMaybe (error "empty") $ pic +-- +-- This function is solely a convenience, using it saves one +-- import and a few characters. +-- +-- If the supplied value is @Nothing@ a run-time error is thrown. +-- +mbPictureU :: (Real u, Floating u, FromPtSize u) + => Maybe (Picture u) -> Picture u +mbPictureU Nothing = error "mbPictureU - empty picture." +mbPictureU (Just a) = a + +-- Note - need an equivalent to Parsec\`s parseTest that provides +-- a very simple way to run graphics without concern for return +-- type or initial drawing context. + +-------------------------------------------------------------------------------- + +query :: DrawingCtxM m => CF a -> m a +query df = askDC >>= \ctx -> return $ runCF ctx df + + +-- | Draw a Graphic taking the drawing style from the +-- /drawing context/. +-- +-- This operation is analogeous to @tell@ in a Writer monad. +-- +draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () +draw gf = askDC >>= \ctx -> trace (collectH $ runGraphic ctx gf) + +-- | Hyperlink version of 'draw'. +-- +xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => XLink -> Graphic u -> m () +xdraw xl gf = draw (xlinkGraphic xl gf) + + + +-- | Draw an Image taking the drawing style from the +-- /drawing context/. +-- +-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned. +-- +drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a +drawi img = askDC >>= \ctx -> + let (a,o) = runImage ctx img in trace (collectH o) >> return a + +-- | Forgetful 'drawi'. +-- +drawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m () +drawi_ img = drawi img >> return () + + +-- | Hyperlink version of 'drawi'. +-- +xdrawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => XLink -> Image u a -> m a +xdrawi xl img = drawi (xlinkImage xl img) + + +-- | Forgetful 'xdrawi'. +-- +xdrawi_ :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) + => XLink -> Image u a -> m () +xdrawi_ xl img = xdrawi xl img >> return () + + + + +node :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) + => LocGraphic u -> m () +node gf = askDC >>= \ctx -> + position >>= \pt -> + let f = runCF ctx gf in trace (collectH $ f pt) + + +nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, u ~ MonUnit m) + => LocImage u a -> m a +nodei imgL = askDC >>= \ctx -> + position >>= \pt -> + let (a,o) = runLocImage ctx pt imgL + in trace (collectH o) >> return a + diff --git a/src/Wumpus/Basic/Paths/Base.hs b/src/Wumpus/Basic/Paths/Base.hs --- a/src/Wumpus/Basic/Paths/Base.hs +++ b/src/Wumpus/Basic/Paths/Base.hs @@ -217,12 +217,12 @@ -- segment is the same point as the start point of the next -- segment. -- -toPrimPath :: Path u -> PrimPath u +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 - path start $ a : step2 (viewl se) + primPath start $ a : step2 (viewl se) step2 EmptyL = [] step2 (e :< se) = seg2 e : step2 (viewl se) diff --git a/src/Wumpus/Basic/Paths/RoundCorners.hs b/src/Wumpus/Basic/Paths/RoundCorners.hs --- a/src/Wumpus/Basic/Paths/RoundCorners.hs +++ b/src/Wumpus/Basic/Paths/RoundCorners.hs @@ -96,6 +96,9 @@ 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 @@ -105,12 +108,14 @@ , 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 p2 +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 = localize bothStrokeColour . filledDisk 1 +pathPoint pt = localize bothStrokeColour (filledDisk 1 `at` pt) diff --git a/src/Wumpus/Basic/PictureLanguage.hs b/src/Wumpus/Basic/PictureLanguage.hs deleted file mode 100644 --- a/src/Wumpus/Basic/PictureLanguage.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.PictureLanguage --- Copyright : (c) Stephen Tetley 2009-2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Composition operators for Pictures. --- --- Note - empty pictures cannot exist in Wumpus hence the /list/ --- functions in this module are always supplied with an initial --- picture, as well as the (possibly empty) list. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.PictureLanguage - ( - -- * Data types for alignment - HAlign(..) - , VAlign(..) - - -- * Operations on boundary - , centerPoint - - -- * Composition - , over - , under - - , centerOver - , nextToH - , nextToV - - , atPoint - , centeredAt - - , stackOver - , zconcat - - , hcat - , vcat - , stackOverCenter - - - , hspace - , vspace - , hsep - , vsep - - -- * Compose with alignment - , alignH - , alignV - , alignHSep - , alignVSep - , hcatA - , vcatA - , hsepA - , vsepA - - ) where - -import Wumpus.Core - -import Data.AdditiveGroup -import Data.AffineSpace - -import Data.List ( foldl' ) - - --------------------------------------------------------------------------------- --- Data types - --- Alignment - --- | Horizontal alignment - align to the top, center or bottom. -data HAlign = HTop | HCenter | HBottom - deriving (Eq,Show) - --- | Vertical alignment - align to the left, center or bottom. -data VAlign = VLeft | VCenter | VRight - deriving (Eq,Show) - - --------------------------------------------------------------------------------- - --- Operations on bounds - --- Corresponding operations are available on bounding boxes - the --- definitions here have different type class obligations. - --- | The center of a picture. -centerPoint :: Fractional u => Picture u -> Point2 u -centerPoint = fn . boundary - where - fn (BBox (P2 x0 y0) (P2 x1 y1)) = P2 (x0 + ((x1-x0)*0.5)) - (y0 + ((y1-y0)*0.5)) - -rightBound :: Picture u -> u -rightBound = fn . ur_corner . boundary - where - fn (P2 x _) = x - - -leftBound :: Picture u -> u -leftBound = fn . ll_corner . boundary - where - fn (P2 x _) = x - -bottomBound :: Picture u -> u -bottomBound = fn . ll_corner . boundary - where - fn (P2 _ y) = y - -topBound :: Picture u -> u -topBound = fn . ur_corner . boundary - where - fn (P2 _ y) = y - - - --------------------------------------------------------------------------------- --- Composition operators - --- | > a `over` b --- --- Place \'picture\' 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) => Picture u -> Picture u -> Picture u -over = picOver - - --- | > a `under` b --- --- Similarly @under@ draws the first picture behind --- the second but move neither. --- --- @under@ was previously @beneath@. --- -under :: (Num u, Ord u) => Picture u -> Picture u -> Picture u - -under = flip over - - - --- | Move in both the horizontal and vertical. --- -move :: (Num u, Ord u) => Vec2 u -> Picture u -> Picture u -move = flip picMoveBy - - - - - - - --- | Extract the top-left corner. --- -topleft :: Picture u -> Point2 u -topleft = fn . boundary - where - fn (BBox (P2 x0 _) (P2 _ y1)) = P2 x0 y1 - --- | Extract the top-right corner. --- -topright :: Picture u -> Point2 u -topright = ur_corner . boundary - --- | Extract the bottom-left corner. --- -bottomleft :: Picture u -> Point2 u -bottomleft = ll_corner . boundary - --- | Extract the bottom-right corner. --- -bottomright :: Picture u -> Point2 u -bottomright = fn . boundary - where - fn (BBox (P2 _ y0) (P2 x1 _)) = P2 x1 y0 - - --------------------------------------------------------------------------------- --- Internal helpers - -leftmid :: Fractional u => Picture u -> Point2 u -leftmid a = P2 (leftBound a) (midpt (bottomBound a) (topBound a)) - -rightmid :: Fractional u => Picture u -> Point2 u -rightmid a = P2 (rightBound a) (midpt (bottomBound a) (topBound a)) - - -topmid :: Fractional u => Picture u -> Point2 u -topmid a = P2 (midpt (leftBound a) (rightBound a)) (topBound a) - -bottommid :: Fractional u => Picture u -> Point2 u -bottommid a = P2 (midpt (leftBound a) (rightBound a)) (bottomBound a) - - -midpt :: Fractional a => a -> a -> a -midpt a b = a + 0.5*(b-a) - - --------------------------------------------------------------------------------- --- Composition - -infixr 5 `nextToV` -infixr 6 `nextToH`, `centerOver` - - --- Note - `centerOver` moves the first argument, whereas other --- functions move the second... - --- | Draw a centered over b - a is moved, b is static. --- --- > a `centerOver` b --- --- 'centerOver' was previously the (-\@-) operator. --- -centerOver :: (Fractional u, Ord u) => Picture u -> Picture u -> Picture u -p1 `centerOver` p2 = (move v p1) `over` p2 - where - v = centerPoint p2 .-. centerPoint p1 - - --- | > a `nextToH` b --- --- Horizontal composition - move @b@, placing it to the right --- of @a@. --- --- 'nextToH' was previously the (->-) operator. --- -nextToH :: (Num u, Ord u) => Picture u -> Picture u -> Picture u -a `nextToH` b = a `over` move hv b - where - hv = hvec $ rightBound a - leftBound b - - - --- | > a `nextToV` b --- --- Vertical composition - move @b@, placing it below @a@. --- --- nextToV was previously the (-//-) operator. --- -nextToV :: (Num u, Ord u) => Picture u -> Picture u -> Picture u -a `nextToV` b = a `over` move vv b - where - vv = vvec $ bottomBound a - topBound b - - --- | Place the picture at the supplied point. --- --- `atPoint` was previous the `at` operator. --- -atPoint :: (Num u, Ord u) => Picture u -> Point2 u -> Picture u -p `atPoint` (P2 x y) = move (V2 x y) p - - --- | Center the picture at the supplied point. --- -centeredAt :: (Fractional u, Ord u) => Picture u -> Point2 u ->Picture u -centeredAt p (P2 x y) = move (vec dx dy) p - where - bb = boundary p - dx = x - (boundaryWidth bb * 0.5) - dy = y - (boundaryHeight bb * 0.5) - - - --- | > xs `stackOver` x --- --- Stack the list of pictures @xs@ 'over' @x@. --- --- Note, the first picture in the list is drawn at the top, all --- the pictures in the list are drawn \'over\' @x@. No pictures --- are moved --- --- @ [p1,p2,p3] `stackOver` p4 => [p1,p2,p3,p4] @ --- -stackOver :: (Num u, Ord u) => [Picture u] -> Picture u -> Picture u -stackOver = flip (foldr over) - - - --- | > x `zconcat` xs --- --- Concatenate @x@ over the list of pictures @xs@. --- --- @x@ is drawn at the top. No pictures are moved. --- --- @ p1 `zconcat` [p2,p3,p4] => [p1,p2,p3,p4] @ --- -zconcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u -zconcat = foldl' over - - - - - --- | Concatenate the list pictures @xs@ horizontally with @nextToH@ --- starting at @x@. --- -hcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u -hcat = foldl' nextToH - - --- | Concatenate the list of pictures @xs@ vertically with @nextToV@ --- starting at @x@. --- -vcat :: (Num u, Ord u) => Picture u -> [Picture u] -> Picture u -vcat = foldl' nextToV - - - --- | Stack pictures centered ontop of each other - the first --- picture in the list is drawn at the top, last picture is on --- drawn at the bottom. --- -stackOverCenter :: (Fractional u, Ord u) - => [Picture u] -> Picture u -> Picture u -stackOverCenter = flip $ foldr centerOver - - - --------------------------------------------------------------------------------- - - - - --- | > 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 -> Picture u -> Picture u -> Picture u -hspace n a b = a `over` move hv b - where - hv = hvec $ n + rightBound a - leftBound 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 -> Picture u -> Picture u -> Picture u -vspace n a b = a `over` move vv b - where - vv = vvec $ bottomBound a - topBound b - n - - - --- | > hsep n x xs --- --- Concatenate the list of pictures @xs@ horizontally with --- @hspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -hsep :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u -hsep n = foldl' (hspace n) - - - --- | > vsep n x xs --- --- Concatenate the list of pictures @xs@ vertically with --- @vspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -vsep :: (Num u, Ord u) => u -> Picture u -> [Picture u] -> Picture u -vsep n = foldl' (vspace n) - - --------------------------------------------------------------------------------- --- Aligning pictures - -vecMove :: (Num u, Ord u) => Picture u -> Picture u -> (Vec2 u) -> Picture u -vecMove a b v = a `over` (move v b) - - - --- | > 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 -> Picture u -> Picture u -> Picture u -alignH align p1 p2 = vecMove p1 p2 $ fn align - where - fn HTop = topright p1 .-. topleft p2 - fn HCenter = rightmid p1 .-. leftmid p2 - fn HBottom = bottomright p1 .-. bottomleft p2 - - --- | > 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 -> Picture u -> Picture u -> Picture u -alignV align p1 p2 = vecMove p1 p2 $ fn align - where - fn VLeft = bottomleft p1 .-. topleft p2 - fn VCenter = bottommid p1 .-. topmid p2 - fn VRight = bottomright p1 .-. topright 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 -> Picture u -> Picture u -> Picture u -alignHSep align dx p1 p2 = vecMove p1 p2 $ hvec dx ^+^ fn align - where - fn HTop = topright p1 .-. topleft p2 - fn HCenter = rightmid p1 .-. leftmid p2 - fn HBottom = bottomright p1 .-. bottomleft p2 - --- | > alignHSep 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 -> Picture u -> Picture u -> Picture u -alignVSep align dy p1 p2 = vecMove p1 p2 $ vvec (-dy) ^+^ fn align - where - fn VLeft = bottomleft p1 .-. topleft p2 - fn VCenter = bottommid p1 .-. topmid p2 - fn VRight = bottomright p1 .-. topright p2 - - - --- | Variant of 'hcat' that aligns the pictures as well as --- concatenating them. --- -hcatA :: (Fractional u, Ord u) - => HAlign -> Picture u -> [Picture u] -> Picture u -hcatA ha = foldl' (alignH ha) - --- | Variant of 'vcat' that aligns the pictures as well as --- concatenating them. --- -vcatA :: (Fractional u, Ord u) - => VAlign -> Picture u -> [Picture u] -> Picture u -vcatA va = foldl' (alignV va) - - --- | Variant of @hsep@ that aligns the pictures as well as --- concatenating and spacing them. --- -hsepA :: (Fractional u, Ord u) - => HAlign -> u -> Picture u -> [Picture u] -> Picture u -hsepA ha n = foldl' op - where - a `op` b = alignHSep ha n a b - - --- | Variant of @vsep@ that aligns the pictures as well as --- concatenating and spacing them. --- -vsepA :: (Fractional u, Ord u) - => VAlign -> u -> Picture u -> [Picture u] -> Picture u -vsepA va n = foldl' op - where - a `op` b = alignVSep va n a b - - - diff --git a/src/Wumpus/Basic/SafeFonts.hs b/src/Wumpus/Basic/SafeFonts.hs --- a/src/Wumpus/Basic/SafeFonts.hs +++ b/src/Wumpus/Basic/SafeFonts.hs @@ -10,9 +10,15 @@ -- Stability : highly unstable -- Portability : GHC -- --- Safe to use fonts. +-- Safe to use \"Core 13\" fonts that are expected to be present +-- for any PostScript interpreter. -- +-- Note - regrettably Symbol is not safe to use for SVG. -- +-- \*\* WARNING \*\* - this module is in flux due to changes to +-- Text encoding in Wumpus-Core and adding font metrics to +-- Wumpus-Basic. The code here is likely to be revised. +-- -------------------------------------------------------------------------------- module Wumpus.Basic.SafeFonts @@ -43,6 +49,8 @@ import Wumpus.Core +import Wumpus.Core.Text.StandardEncoding +import Wumpus.Core.Text.Symbol -- Supported fonts are: -- @@ -58,19 +66,19 @@ -- times_roman :: FontFace times_roman = - FontFace "Times-Roman" "Times New Roman" SVG_REGULAR latin1_font_encoder + 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 latin1_font_encoder + 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 latin1_font_encoder + FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding -- | Times Bold Italic -- @@ -78,7 +86,7 @@ times_bold_italic = FontFace "Times-BoldItalic" "Times New Roman" SVG_BOLD_ITALIC - latin1_font_encoder + standard_encoding -------------------------------------------------------------------------------- @@ -87,20 +95,20 @@ -- | Helvetica -- helvetica :: FontFace -helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR latin1_font_encoder +helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding -- | Helvetica Oblique -- helvetica_oblique :: FontFace helvetica_oblique = - FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE latin1_font_encoder + FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding -- | Helvetica Bold -- helvetica_bold :: FontFace helvetica_bold = - FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD latin1_font_encoder + FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding -- | Helvetica Bold Oblique @@ -109,7 +117,7 @@ helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" "Helvetica" SVG_BOLD_OBLIQUE - latin1_font_encoder + standard_encoding @@ -118,19 +126,19 @@ -- | Courier -- courier :: FontFace -courier = FontFace "Courier" "Courier New" SVG_REGULAR latin1_font_encoder +courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding -- | Courier Oblique -- courier_oblique :: FontFace courier_oblique = - FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE latin1_font_encoder + FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding -- | Courier Bold -- courier_bold :: FontFace courier_bold = - FontFace "Courier-Bold" "Courier New" SVG_BOLD latin1_font_encoder + FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding -- | Courier Bold Oblique @@ -139,19 +147,19 @@ courier_bold_oblique = FontFace "Courier-Bold-Oblique" "Courier New" SVG_BOLD_OBLIQUE - latin1_font_encoder + standard_encoding -------------------------------------------------------------------------------- -- Symbol -- | Symbol -- --- Note - Symbol does not appear to be well supported by some SVG --- renders. Seemingly Chrome is fine but Firefox defaults to some --- serif font. +-- 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_font_encoder +symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding diff --git a/src/Wumpus/Basic/Shapes.hs b/src/Wumpus/Basic/Shapes.hs --- a/src/Wumpus/Basic/Shapes.hs +++ b/src/Wumpus/Basic/Shapes.hs @@ -19,11 +19,9 @@ module Wumpus.Basic.Shapes.Base , module Wumpus.Basic.Shapes.Coordinate , module Wumpus.Basic.Shapes.Derived - , module Wumpus.Basic.Shapes.Plaintext ) where import Wumpus.Basic.Shapes.Base import Wumpus.Basic.Shapes.Coordinate import Wumpus.Basic.Shapes.Derived hiding ( mkRectangle ) -import Wumpus.Basic.Shapes.Plaintext diff --git a/src/Wumpus/Basic/Shapes/Base.hs b/src/Wumpus/Basic/Shapes/Base.hs --- a/src/Wumpus/Basic/Shapes/Base.hs +++ b/src/Wumpus/Basic/Shapes/Base.hs @@ -14,8 +14,8 @@ -- -- Common core for shapes -- --- \*\* WARNING \*\* - the types of Shapes and Plaintext are not --- ideal and are pending revision. +-- \*\* WARNING \*\* - the types of Shapes are not ideal and are +-- pending revision. -- -------------------------------------------------------------------------------- @@ -42,6 +42,7 @@ , askCTM , projectPoint , shapeCenter + , shapeAngle ) where @@ -207,9 +208,11 @@ askCTM :: ShapeGeom u (ShapeCTM u) askCTM = ShapeGeom $ \ctm -> ctm -shapeCenter :: (Real u, Floating u) => ShapeGeom u (Point2 u) -shapeCenter = ShapeGeom $ \r -> ctm_center r +shapeCenter :: ShapeGeom u (Point2 u) +shapeCenter = ShapeGeom $ \ctm -> ctm_center ctm +shapeAngle :: ShapeGeom u Radian +shapeAngle = ShapeGeom $ \ctm -> ctm_rotation ctm @@ -220,5 +223,4 @@ , ctm_scale_y = sy , ctm_rotation = theta }) -> translate dx dy $ rotate theta $ P2 (sx*x) (sy*y) - diff --git a/src/Wumpus/Basic/Shapes/Coordinate.hs b/src/Wumpus/Basic/Shapes/Coordinate.hs --- a/src/Wumpus/Basic/Shapes/Coordinate.hs +++ b/src/Wumpus/Basic/Shapes/Coordinate.hs @@ -11,12 +11,16 @@ -- Stability : highly unstable -- Portability : GHC -- --- Coordinate is a bit like a shape but does not generate a path --- and cannot be scaled or rotated (it can be translated). --- --- \*\* WARNING \*\* - the types of Shapes and Coordinate are not --- ideal and are pending revision. +-- A Coordinate is operationally like a shape but it can only be +-- drawn as a dot or a cross and it only supports @CenterAnchor@. -- +-- Coordinates support affine transformations, however +-- transfomations only displace a coordinate\'s origin they do +-- not change how it is drawn (one cannot elongate the drawing of +-- a coordinate with a scale). This is why coordinates are not +-- Shapes, though one major use of coordinates is to illustrate +-- anchor points on Shapes. +-- -------------------------------------------------------------------------------- module Wumpus.Basic.Shapes.Coordinate @@ -27,26 +31,31 @@ , DCoordinate , coordinate - , coordinateMark + , coordinateDot + , coordinateX ) where -import Wumpus.Basic.Anchors import Wumpus.Basic.Graphic +import Wumpus.Basic.Shapes.Base import Wumpus.Core -- package: wumpus-core - +import Control.Monad +-- Note - a CoordinateAnchor should _NOT_ have affine instances. +-- +-- However, a coordinate supports affine transformations. This +-- follows the logic where Shapes transform but representations +-- of their anchors (i.e. the concrete types Rectangle, Circle...) +-- do not transform. +-- -------------------------------------------------------------------------------- -- | Coordinate -data CoordinateAnchor u = CoordinateAnchor - { coord_x :: !u - , coord_y :: !u - } +newtype CoordinateAnchor u = CoordinateAnchor { getCoordAnchor :: ShapeCTM u } deriving (Eq,Ord,Show) type DCoordinateAnchor = CoordinateAnchor Double @@ -60,29 +69,68 @@ 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 (CoordinateAnchor x y) = P2 x y + 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 = Coordinate . fn . getCoordinate - where - fn (CoordinateAnchor x y) = CoordinateAnchor (x+dx) (y+dy) + translate dx dy = cMap (translate dx dy) --- Need a differentiation at the type level between a coord --- that can be translated (moved) and a coord that anchors... -coordinate :: Num u => Point2 u -> Coordinate u -coordinate (P2 x y) = Coordinate $ CoordinateAnchor { coord_x = x, coord_y = y } --- Note - should @coordinate@ take a point, Shapes don\'t. +coordinate :: Num u => LocCoordinate u +coordinate = Coordinate . CoordinateAnchor . makeShapeCTM -coordinateMark :: (Real u, Floating u) - => Coordinate u -> Image u (CoordinateAnchor u) -coordinateMark x = intoImage (return $ getCoordinate x) (drawCoord x) +coordinateDot :: (Real u, Floating u, FromPtSize u) + => Coordinate u -> Image u (CoordinateAnchor u) +coordinateDot x = intoImage (return $ getCoordinate x) (drawDot x) -drawCoord :: (Real u, Floating u) => Coordinate u -> Graphic u -drawCoord coord = - localize bothStrokeColour $ filledEllipse 2 2 (center $ getCoordinate coord) + + +-- | Note - the @x@ is drawn /regardless/ of any scaling or rotation. +-- +coordinateX :: (Real u, Floating u, FromPtSize u) + => Coordinate u -> Image u (CoordinateAnchor u) +coordinateX x = intoImage (return $ getCoordinate x) (drawX x) + + + +quarterMarkHeight :: (Fractional u, FromPtSize u) => CF u +quarterMarkHeight = liftM (0.25*) markHeight + +drawDot :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u +drawDot coord = quarterMarkHeight >>= \qh -> + localize bothStrokeColour (filledEllipse qh qh `at` ctr) + where + ctr = center $ getCoordinate coord + +drawX :: (Real u, Floating u, FromPtSize u) => Coordinate u -> Graphic u +drawX coord = quarterMarkHeight >>= \qh -> line1 qh `oplus` line2 qh + where + P2 x y = center $ getCoordinate coord + line1 h = straightLineBetween (P2 (x-h) (y-h)) (P2 (x+h) (y+h)) + line2 h = straightLineBetween (P2 (x+h) (y-h)) (P2 (x-h) (y+h)) diff --git a/src/Wumpus/Basic/Shapes/Derived.hs b/src/Wumpus/Basic/Shapes/Derived.hs --- a/src/Wumpus/Basic/Shapes/Derived.hs +++ b/src/Wumpus/Basic/Shapes/Derived.hs @@ -15,9 +15,6 @@ -- -- Simple shapes - rectangle, circle diamond, ellipse. -- --- \*\* WARNING \*\* - the types of Shapes and Plaintext are not --- ideal and are pending revision. --- -------------------------------------------------------------------------------- module Wumpus.Basic.Shapes.Derived @@ -45,7 +42,7 @@ ) where -import Wumpus.Basic.Anchors +import Wumpus.Basic.Graphic import Wumpus.Basic.Paths import Wumpus.Basic.Paths.RoundCorners import Wumpus.Basic.Shapes.Base @@ -85,7 +82,7 @@ runRectangle :: (u -> u -> ShapeGeom u a) -> Rectangle u -> a -runRectangle mf (Rectangle { rect_ctm =ctm, rect_hw = hw, rect_hh = hh }) = +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 diff --git a/src/Wumpus/Basic/Shapes/Plaintext.hs b/src/Wumpus/Basic/Shapes/Plaintext.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Shapes/Plaintext.hs +++ /dev/null @@ -1,149 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Shapes.Plaintext --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Plaintext is a bit like a shape but does not generate a path --- and cannot be scaled (it can be rotated or translated). --- --- \*\* WARNING \*\* - the types of Shapes and Plaintext are not --- ideal and are pending revision. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Shapes.Plaintext - ( - - PlaintextAnchor - , DPlaintextAnchor - , Plaintext - , DPlaintext - - , plaintext - , drawText - - ) where - -import Wumpus.Basic.Anchors -import Wumpus.Basic.Graphic -import Wumpus.Basic.Shapes.Base -import Wumpus.Basic.Shapes.Derived - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - -import Control.Applicative - - - - --------------------------------------------------------------------------------- --- Free label - --- Free label is a rectangle that /is not drawn/, the --- constructor should always create some text. - -newtype PlaintextAnchor u = PlaintextAnchor { getPlaintext :: Rectangle u } - - -type DPlaintextAnchor = PlaintextAnchor Double - -type instance DUnit (PlaintextAnchor u) = u - - -data Plaintext u = Plaintext - { text_text :: String -- Note - generalize this for multi-line... - , text_x :: !u - , text_y :: !u - , text_ang :: !Radian - } - deriving (Eq,Ord,Show) - -type DPlaintext = Plaintext Double - -type instance DUnit (Plaintext u) = u - - -instance (Real u, Floating u) => CenterAnchor (PlaintextAnchor u) where - center = center . getPlaintext - - -instance (Real u, Floating u) => CardinalAnchor (PlaintextAnchor u) where - north = north . getPlaintext - south = south . getPlaintext - east = east . getPlaintext - west = west . getPlaintext - -instance (Real u, Floating u) => CardinalAnchor2 (PlaintextAnchor u) where - northeast = northeast . getPlaintext - southeast = southeast . getPlaintext - southwest = southwest . getPlaintext - northwest = northwest . getPlaintext - -instance (Real u, Floating u) => RadialAnchor (PlaintextAnchor u) where - radialAnchor theta = radialAnchor theta . getPlaintext - - - -instance Rotate (Plaintext u) where - rotate dr = (\s i -> s { text_ang = i+dr }) <*> text_ang - --- Note - cannot scale Plaintext - - -instance Num u => Translate (Plaintext u) where - translate dx dy = (\s x y -> s { text_x = x+dx, text_y = y+dy }) - <*> text_x <*> text_y - - - -plaintext :: Num u => String -> Plaintext u -plaintext ss = Plaintext { text_text = ss - , text_x = 0 - , text_y = 0 - , text_ang = 0 } - - - - -drawText :: (Real u, Floating u, FromPtSize u) - => Plaintext u -> Image u (PlaintextAnchor u) -drawText x = intoImage (oneLineRect x) (drawOneLine x) - - - -textCTM :: Num u => u -> u -> Radian -> ShapeCTM u -textCTM x y theta = rotate theta $ makeShapeCTM (P2 x y) - -oneLineRect :: (Fractional u, Ord u, FromPtSize u) - => Plaintext u -> DrawingR (PlaintextAnchor u) -oneLineRect ptext = - monoTextDimensions (text_text ptext) >>= \(w,h) -> - return (PlaintextAnchor $ mkRectangle (0.5*w) (0.5*h) ctm) - where - ctm = textCTM (text_x ptext) (text_y ptext) (text_ang ptext) - - -drawOneLine :: (Real u, Floating u, FromPtSize u) - => Plaintext u -> Graphic u -drawOneLine (Plaintext { text_text = ss, text_x=dx, text_y=dy - , text_ang = ang }) = - monoVecToCenter ss >>= \v -> - let ctr = P2 dx dy; bl = ctr .-^ v in - rotTextline ang ss (rotateAbout ang ctr bl) - - - -rotTextline :: (Real u, Floating u) => Radian -> String -> LocGraphic u -rotTextline theta ss baseline_left = - withTextAttr $ \rgb attr -> - wrapPrim $ rtextlabel rgb attr ss theta baseline_left diff --git a/src/Wumpus/Basic/Text/LRSymbol.hs b/src/Wumpus/Basic/Text/LRSymbol.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Text/LRSymbol.hs +++ /dev/null @@ -1,746 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Text.LRSymbol --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Named literals from Symbol font, drawn with the LRText monad. --- --- Note - Symbol font handling and precise letter placing in SVG --- viewers is mixed. Chrome works well good, Firefox (3.6.3) and --- Safari (5.0.1) are unsatisfactory. --- --- --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Text.LRSymbol - ( - - - -- * Upper case letters and upper case Greek letters - uAlpha - , uBeta - , uChi - , uDelta - , uEpsilon - , uEta - , uEuro - , uGamma - , uIfraktur - , uIota - , uKappa - , uLambda - , uMu - , uNu - , uOmega - , uOmicron - , uPhi - , uPi - , uPsi - , uRfraktur - , uRho - , uSigma - , uTau - , uTheta - , uUpsilon - , uUpsilon1 - , uXi - , uZeta - - - - -- * Lower case Greek letters - - , alpha - , beta - , gamma - , delta - , epsilon - , zeta - , eta - , theta - , iota - , kappa - , lambda - , mu - , nu - , xi - , pi - , rho - , sigma - , tau - , upsilon - , phi - , chi - , psi - , omega - - -- * Miscellaneous chars - , aleph - , ampersand - , angle - , angleleft - , angleright - , approxequal - , arrowboth - , arrowdblboth - , arrowdbldown - , arrowdblleft - , arrowdblright - , arrowdblup - , arrowdown - , arrowleft - , arrowright - , arrowup - , asteriskmath - , bar - , braceleft - , braceright - , bracketleft - , bracketright - , bullet - , carriagereturn - , circlemultiply - , circleplus - , club - , colon - , comma - , congruent - , copyrightsans - , copyrightserif - , degree - , diamond - , divide - , dotmath - , eight - , element - , ellipsis - , emptyset - , equal - , equivalence - , exclam - , existential - , five - , florin - , four - , fraction - , gradient - , greater - , greaterequal - , heart - , infinity - , integral - , intersection - , less - , lessequal - , logicaland - , logicalnot - , logicalor - , lozenge - , minus - , minute - , multiply - , nine - , notelement - , notequal - , notsubset - , numbersign - , omega1 - , omicron - , one - , parenleft - , parenright - , partialdiff - , percent - , period - , perpendicular - , phi1 - , plus - , plusminus - , product - , propersubset - , propersuperset - , proportional - , question - , radical - , radicalex - , reflexsubset - , reflexsuperset - , registersans - , registerserif - , second - , semicolon - , seven - , sigma1 - , similar - , six - , slash - , space - , spade - , suchthat - , summation - , therefore - , theta1 - , three - , trademarksans - , trademarkserif - , two - , underscore - , union - , universal - , weierstrass - , zero - - ) where - - -import Wumpus.Basic.Text.LRText - - -import Prelude hiding ( pi, product ) - - - --------------------------------------------------------------------------------- --- upper case - --- | Note - prints as \'A\'. --- -uAlpha :: Num u => LRText u () -uAlpha = symb 'A' - --- | Note - prints as \'B\'. --- -uBeta :: Num u => LRText u () -uBeta = symb 'B' - --- | Note - prints as \'X\'. --- -uChi :: Num u => LRText u () -uChi = symb 'C' - -uDelta :: Num u => LRText u () -uDelta = symb 'D' - --- | Note - prints as \'E\'. --- -uEpsilon :: Num u => LRText u () -uEpsilon = symb 'E' - --- | Note - prints as \'H\'. --- -uEta :: Num u => LRText u () -uEta = symb 'H' - - --- | Note - does not appear to print in Chrome. --- -uEuro :: Num u => LRText u () -uEuro = symbEscInt 0o240 - -uGamma :: Num u => LRText u () -uGamma = symb 'G' - -uIfraktur :: Num u => LRText u () -uIfraktur = symbEscInt 0o301 - --- | Note - prints as \'I\'. --- -uIota :: Num u => LRText u () -uIota = symb 'I' - --- | Note - prints as \'K\'. --- -uKappa :: Num u => LRText u () -uKappa = symb 'K' - -uLambda :: Num u => LRText u () -uLambda = symb 'L' - --- | Note - prints as \'M\'. --- -uMu :: Num u => LRText u () -uMu = symb 'M' - --- | Note - prints as \'N\'. --- -uNu :: Num u => LRText u () -uNu = symb 'N' - -uOmega :: Num u => LRText u () -uOmega = symbEscInt 0o127 - -uOmicron :: Num u => LRText u () -uOmicron = symbEscInt 0o117 - -uPhi :: Num u => LRText u () -uPhi = symbEscInt 0o106 - -uPi :: Num u => LRText u () -uPi = symb 'P' - -uPsi :: Num u => LRText u () -uPsi = symbEscInt 0o131 - -uRfraktur :: Num u => LRText u () -uRfraktur = symbEscInt 0o302 - -uRho :: Num u => LRText u () -uRho = symbEscInt 0o122 - -uSigma :: Num u => LRText u () -uSigma = symb 'S' - -uTau :: Num u => LRText u () -uTau = symb 'T' - - -uTheta :: Num u => LRText u () -uTheta = symb 'Q' - --- | Note - prints as \'Y\'. --- -uUpsilon :: Num u => LRText u () -uUpsilon = symbEscInt 0o125 - --- | Note - this is the /pretty/ Upsilon. --- -uUpsilon1 :: Num u => LRText u () -uUpsilon1 = symbEscInt 0o241 - -uXi :: Num u => LRText u () -uXi = symb 'X' - -uZeta :: Num u => LRText u () -uZeta = symb 'Z' - - --------------------------------------------------------------------------------- --- lower case Greek letters - - -alpha :: Num u => LRText u () -alpha = symb 'a' - -beta :: Num u => LRText u () -beta = symb 'b' - -gamma :: Num u => LRText u () -gamma = symb 'g' - -delta :: Num u => LRText u () -delta = symb 'd' - -epsilon :: Num u => LRText u () -epsilon = symb 'e' - -zeta :: Num u => LRText u () -zeta = symb 'z' - -eta :: Num u => LRText u () -eta = symb 'h' - -theta :: Num u => LRText u () -theta = symb 'q' - -iota :: Num u => LRText u () -iota = symb 'i' - -kappa :: Num u => LRText u () -kappa = symb 'k' - -lambda :: Num u => LRText u () -lambda = symb 'l' - -mu :: Num u => LRText u () -mu = symb 'm' - -nu :: Num u => LRText u () -nu = symb 'n' - -xi :: Num u => LRText u () -xi = symb 'x' - -pi :: Num u => LRText u () -pi = symb 'p' - -rho :: Num u => LRText u () -rho = symb 'r' - -sigma :: Num u => LRText u () -sigma = symb 's' - -tau :: Num u => LRText u () -tau = symb 't' - -upsilon :: Num u => LRText u () -upsilon = symb 'u' - -phi :: Num u => LRText u () -phi = symb 'j' - -chi :: Num u => LRText u () -chi = symb 'c' - -psi :: Num u => LRText u () -psi = symb 'y' - -omega :: Num u => LRText u () -omega = symb 'w' - - - --------------------------------------------------------------------------------- --- Miscellaneous chars - -aleph :: Num u => LRText u () -aleph = symbEscInt 0o300 - -ampersand :: Num u => LRText u () -ampersand = symbEscInt 0o046 - -angle :: Num u => LRText u () -angle = symbEscInt 0o320 - -angleleft :: Num u => LRText u () -angleleft = symbEscInt 0o341 - -angleright :: Num u => LRText u () -angleright = symbEscInt 0o361 - -approxequal :: Num u => LRText u () -approxequal = symbEscInt 0o273 - -arrowboth :: Num u => LRText u () -arrowboth = symbEscInt 0o253 - -arrowdblboth :: Num u => LRText u () -arrowdblboth = symbEscInt 0o333 - -arrowdbldown :: Num u => LRText u () -arrowdbldown = symbEscInt 0o337 - -arrowdblleft :: Num u => LRText u () -arrowdblleft = symbEscInt 0o334 - -arrowdblright :: Num u => LRText u () -arrowdblright = symbEscInt 0o336 - -arrowdblup :: Num u => LRText u () -arrowdblup = symbEscInt 0o335 - -arrowdown :: Num u => LRText u () -arrowdown = symbEscInt 0o257 - -arrowleft :: Num u => LRText u () -arrowleft = symbEscInt 0o254 - -arrowright :: Num u => LRText u () -arrowright = symbEscInt 0o256 - -arrowup :: Num u => LRText u () -arrowup = symbEscInt 0o255 - -asteriskmath :: Num u => LRText u () -asteriskmath = symbEscInt 0o052 - -bar :: Num u => LRText u () -bar = symbEscInt 0o174 - -braceleft :: Num u => LRText u () -braceleft = symbEscInt 0o173 - -braceright :: Num u => LRText u () -braceright = symbEscInt 0o175 - -bracketleft :: Num u => LRText u () -bracketleft = symbEscInt 0o133 - -bracketright :: Num u => LRText u () -bracketright = symbEscInt 0o135 - -bullet :: Num u => LRText u () -bullet = symbEscInt 0o267 - -carriagereturn :: Num u => LRText u () -carriagereturn = symbEscInt 0o277 - - -circlemultiply :: Num u => LRText u () -circlemultiply = symbEscInt 0o304 - -circleplus :: Num u => LRText u () -circleplus = symbEscInt 0o305 - -club :: Num u => LRText u () -club = symbEscInt 0o247 - -colon :: Num u => LRText u () -colon = symbEscInt 0o072 - -comma :: Num u => LRText u () -comma = symbEscInt 0o054 - -congruent :: Num u => LRText u () -congruent = symbEscInt 0o100 - -copyrightsans :: Num u => LRText u () -copyrightsans = symbEscInt 0o343 - -copyrightserif :: Num u => LRText u () -copyrightserif = symbEscInt 0o323 - -degree :: Num u => LRText u () -degree = symbEscInt 0o260 - -diamond :: Num u => LRText u () -diamond = symbEscInt 0o250 - -divide :: Num u => LRText u () -divide = symbEscInt 0o270 - -dotmath :: Num u => LRText u () -dotmath = symbEscInt 0o327 - -eight :: Num u => LRText u () -eight = symbEscInt 0o070 - -element :: Num u => LRText u () -element = symbEscInt 0o316 - -ellipsis :: Num u => LRText u () -ellipsis = symbEscInt 0o274 - -emptyset :: Num u => LRText u () -emptyset = symbEscInt 0o306 - -equal :: Num u => LRText u () -equal = symbEscInt 0o075 - -equivalence :: Num u => LRText u () -equivalence = symbEscInt 0o272 - -exclam :: Num u => LRText u () -exclam = symbEscInt 0o041 - -existential :: Num u => LRText u () -existential = symbEscInt 0o044 - -five :: Num u => LRText u () -five = symbEscInt 0o065 - -florin :: Num u => LRText u () -florin = symbEscInt 0o246 - -four :: Num u => LRText u () -four = symbEscInt 0o064 - -fraction :: Num u => LRText u () -fraction = symbEscInt 0o244 - -gradient :: Num u => LRText u () -gradient = symbEscInt 0o321 - -greater :: Num u => LRText u () -greater = symbEscInt 0o076 - -greaterequal :: Num u => LRText u () -greaterequal = symbEscInt 0o263 - -heart :: Num u => LRText u () -heart = symbEscInt 0o251 - -infinity :: Num u => LRText u () -infinity = symbEscInt 0o245 - -integral :: Num u => LRText u () -integral = symbEscInt 0o362 - -intersection :: Num u => LRText u () -intersection = symbEscInt 0o307 - -less :: Num u => LRText u () -less = symbEscInt 0o074 - -lessequal :: Num u => LRText u () -lessequal = symbEscInt 0o243 - -logicaland :: Num u => LRText u () -logicaland = symbEscInt 0o331 - -logicalnot :: Num u => LRText u () -logicalnot = symbEscInt 0o330 - -logicalor :: Num u => LRText u () -logicalor = symbEscInt 0o332 - -lozenge :: Num u => LRText u () -lozenge = symbEscInt 0o340 - -minus :: Num u => LRText u () -minus = symbEscInt 0o055 - -minute :: Num u => LRText u () -minute = symbEscInt 0o242 - -multiply :: Num u => LRText u () -multiply = symbEscInt 0o264 - -nine :: Num u => LRText u () -nine = symbEscInt 0o071 - -notelement :: Num u => LRText u () -notelement = symbEscInt 0o317 - -notequal :: Num u => LRText u () -notequal = symbEscInt 0o271 - -notsubset :: Num u => LRText u () -notsubset = symbEscInt 0o313 - -numbersign :: Num u => LRText u () -numbersign = symbEscInt 0o043 - -omega1 :: Num u => LRText u () -omega1 = symbEscInt 0o166 - -omicron :: Num u => LRText u () -omicron = symbEscInt 0o157 - -one :: Num u => LRText u () -one = symbEscInt 0o061 - -parenleft :: Num u => LRText u () -parenleft = symbEscInt 0o050 - -parenright :: Num u => LRText u () -parenright = symbEscInt 0o051 - -partialdiff :: Num u => LRText u () -partialdiff = symbEscInt 0o266 - -percent :: Num u => LRText u () -percent = symbEscInt 0o045 - -period :: Num u => LRText u () -period = symbEscInt 0o056 - -perpendicular :: Num u => LRText u () -perpendicular = symbEscInt 0o136 - -phi1 :: Num u => LRText u () -phi1 = symbEscInt 0o152 - -plus :: Num u => LRText u () -plus = symbEscInt 0o053 - -plusminus :: Num u => LRText u () -plusminus = symbEscInt 0o261 - -product :: Num u => LRText u () -product = symbEscInt 0o325 - -propersubset :: Num u => LRText u () -propersubset = symbEscInt 0o314 - -propersuperset :: Num u => LRText u () -propersuperset = symbEscInt 0o311 - -proportional :: Num u => LRText u () -proportional = symbEscInt 0o265 - -question :: Num u => LRText u () -question = symbEscInt 0o077 - -radical :: Num u => LRText u () -radical = symbEscInt 0o326 - -radicalex :: Num u => LRText u () -radicalex = symbEscInt 0o140 - -reflexsubset :: Num u => LRText u () -reflexsubset = symbEscInt 0o315 - -reflexsuperset :: Num u => LRText u () -reflexsuperset = symbEscInt 0o312 - -registersans :: Num u => LRText u () -registersans = symbEscInt 0o342 - -registerserif :: Num u => LRText u () -registerserif = symbEscInt 0o322 - -second :: Num u => LRText u () -second = symbEscInt 0o262 - -semicolon :: Num u => LRText u () -semicolon = symbEscInt 0o073 - -seven :: Num u => LRText u () -seven = symbEscInt 0o067 - -sigma1 :: Num u => LRText u () -sigma1 = symbEscInt 0o126 - -similar :: Num u => LRText u () -similar = symbEscInt 0o176 - -six :: Num u => LRText u () -six = symbEscInt 0o066 - -slash :: Num u => LRText u () -slash = symbEscInt 0o057 - -space :: Num u => LRText u () -space = symbEscInt 0o040 - -spade :: Num u => LRText u () -spade = symbEscInt 0o252 - -suchthat :: Num u => LRText u () -suchthat = symbEscInt 0o047 - -summation :: Num u => LRText u () -summation = symbEscInt 0o345 - -therefore :: Num u => LRText u () -therefore = symbEscInt 0o134 - -theta1 :: Num u => LRText u () -theta1 = symbEscInt 0o112 - -three :: Num u => LRText u () -three = symbEscInt 0o063 - -trademarksans :: Num u => LRText u () -trademarksans = symbEscInt 0o344 - -trademarkserif :: Num u => LRText u () -trademarkserif = symbEscInt 0o324 - -two :: Num u => LRText u () -two = symbEscInt 0o062 - -underscore :: Num u => LRText u () -underscore = symbEscInt 0o137 - -union :: Num u => LRText u () -union = symbEscInt 0o310 - -universal :: Num u => LRText u () -universal = symbEscInt 0o042 - -weierstrass :: Num u => LRText u () -weierstrass = symbEscInt 0o303 - -zero :: Num u => LRText u () -zero = symbEscInt 0o060 - - diff --git a/src/Wumpus/Basic/Text/LRText.hs b/src/Wumpus/Basic/Text/LRText.hs --- a/src/Wumpus/Basic/Text/LRText.hs +++ b/src/Wumpus/Basic/Text/LRText.hs @@ -7,191 +7,233 @@ -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- --- Maintainer : Stephen Tetley --- Stability : highly unstable +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable -- Portability : GHC -- --- LRText monad - left-to-right text, with kerning. --- --- Note - because Wumpus has no access to the metrics data inside --- a font file, the default spacing is not good and it is --- expected that kerning will need to be added per-letter for --- variable width fonts. --- --- This module makes precise horizontal text spacing \*possible\*, --- it does not make it \*easy\*. +-- Left-to-right measured text. The text uses glyph metrics so it +-- can be positioned accurately. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Text.LRText ( + + singleLineBL + , singleLineCC - LRText + , multiAlignLeft + , multiAlignCenter + , multiAlignRight - , runLRText - , execLRText - , kern - , char - , escInt - , escName - , symb - , symbEscInt - , symbEscName - ) where + import Wumpus.Basic.Graphic -import Wumpus.Basic.SafeFonts -import Wumpus.Basic.Utils.HList import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices -import Control.Applicative -import Control.Monad +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace +import Data.Char +import Data.Foldable ( foldrM ) +import qualified Data.Map as Map +import Data.Maybe +-- One line of multiline text +-- +data InterimText1 u = InterimText1 + { text1_escaped :: EscapedText + , text1_advance :: (AdvanceVec u) + } + deriving (Eq,Show) --- Need a note in wumpus-core and here about space:preserve --- Note - if we have font change (e.g. to symbol font) then we --- have to generate more than one hkernline. --- --- Apropos /optimization/ we have two two simultaneous and --- overlayed lines - one in the regular font, and one in Symbol. +singleLineBL :: (Ord u, FromPtSize u) + => String -> BoundedLocGraphic u +singleLineBL ss = interimText1 ss >>= singleLRText id + +singleLineCC :: (Fractional u, Ord u, FromPtSize u) + => String -> BoundedLocGraphic u +singleLineCC ss = glyphCapHeight >>= \cap_h -> + interimText1 ss >>= \interim -> + let hw = 0.5 * advanceH (text1_advance interim) + in singleLRText (.-^ vec hw (0.5 * cap_h)) interim + +-- | Draw multi-line text, aligned to the left. -- --- Result should be a LocGraphic (so cannot do a trace as we go). +-- The input string is split on newline with the Prelude function +-- @lines@. The supplied point is the center of the text. -- +multiAlignLeft :: (Fractional u, Ord u, FromPtSize u) + => String -> BoundedLocGraphic u +multiAlignLeft = + multiAligned drawLeftAligned1 (\wv pt -> pt .-^ hvec (0.5 * advanceH wv)) --- Note - the the state tracks two kernlines: one for symbols, -data St u = St - { delta_chr :: !u - , delta_sym :: !u - , acc_chr :: H (KerningChar u) - , acc_sym :: H (KerningChar u) - } +-- | Draw multi-line text, aligned on the horizontal center. +-- +-- The input string is split on newline with the Prelude function +-- @lines@. The supplied point is the center of the text. +-- +multiAlignCenter :: (Fractional u, Ord u, FromPtSize u) + => String -> BoundedLocGraphic u +multiAlignCenter = + multiAligned drawCenterAligned1 (\_ pt -> pt) +-- | Draw multi-line text, aligned to the right. +-- +-- The input string is split on newline with the Prelude function +-- @lines@. The supplied point is the center of the text. +-- +multiAlignRight :: (Fractional u, Ord u, FromPtSize u) + => String -> BoundedLocGraphic u +multiAlignRight = + multiAligned drawRightAligned1 (\wv pt -> pt .+^ hvec (0.5 * advanceH wv)) -data Env u = Env - { char_width :: !u - , spacer_width :: !u - } --- Note - unlike Turtle for example, Text is a monad not a --- transformer. +-- Build multi-line aligned text. -- --- The rationale for this is to avoid complications percolating --- from the Drawing monad. It Text were built over the Drawing --- monad what would it do on a font change, a colour change... --- --- That say Text must still be run /within/ the Drawing so it --- can take the initial font size, stroke colour etc. +-- The drawF functions regard the supplied point differently, for +-- instance @drawRightAligned1@ regards the point as +-- baseline-right. -- +-- The dispF are applied to a point which is initially in the +-- center of the drawing - for right aligned text it is displaced +-- to the right (half the max width vectoer), for left aligned +-- text it is displaced to the left. Center aligned text is not +-- displaced. +-- +multiAligned :: (Fractional u, Ord u, FromPtSize u) + => (InterimText1 u -> Point2 u -> BoundedGraphic u) + -> (AdvanceVec u -> Point2 u -> Point2 u) + -> String -> BoundedLocGraphic u +multiAligned drawF dispF ss = + linesToInterims ss >>= \(wv,xs) -> + glyphCapHeight >>= \cap_h -> + baselineSpacing >>= \base_span -> + promote1 $ \p0 -> let p1 = dispF wv p0 + axs = annotateStartPoints cap_h base_span p1 xs + in mergeLines drawF p1 axs -newtype LRText u a = LRText { getLRText :: Env u -> St u -> (a, St u) } +-- This needs sorting out so as not to throw an error +-- +mergeLines :: (Num u, Ord u) + => (InterimText1 u -> Point2 u -> BoundedGraphic u) + -> Point2 u + -> [(InterimText1 u, Point2 u)] -> BoundedGraphic u +mergeLines fn fallback_pt = step + where + step [(x,pt)] = fn x pt + step ((x,pt):ys) = fn x pt `oplus` step ys + step _ = fn empty_fallback fallback_pt -type instance MonUnit (LRText u) = u + empty_fallback = InterimText1 (escapeString "") (hvec 0) -instance Functor (LRText u) where - fmap f mf = LRText $ \r s -> let (a,s') = getLRText mf r s in (f a,s') -instance Applicative (LRText u) where - pure a = LRText $ \_ s -> (a,s) - mf <*> ma = LRText $ \r s -> let (f,s') = getLRText mf r s - (a,s'') = getLRText ma r s' - in (f a,s'') -instance Monad (LRText u) where - return a = LRText $ \_ s -> (a,s) - m >>= k = LRText $ \r s -> let (a,s') = getLRText m r s - in (getLRText . k) a r s' +singleLRText :: (Ord u, FromPtSize u) + => (Point2 u -> Point2 u) -> InterimText1 u + -> BoundedLocGraphic u +singleLRText dispF (InterimText1 esc av) = + glyphHeightRange >>= \(ymin, ymax) -> + promote1 $ \p0 -> let pt = dispF p0 + w = advanceH av + ll = pt .+^ vvec ymin + ur = pt .+^ vec w ymax + bb = boundingBox ll ur + in (escapedline esc `at` pt) >>= \prim -> + return (bb, prim) +-- Point is baseline-left +-- +drawLeftAligned1 :: (Ord u, FromPtSize u) + => InterimText1 u -> Point2 u -> BoundedGraphic u +drawLeftAligned1 itext pt = singleLRText id itext `at` pt -runLRText :: (Num u, FromPtSize u) => LRText u a -> LocImage u a -runLRText ma = \pt -> envZero >>= \e1 -> - let (a,st) = getLRText ma e1 st_zero - in mkline pt (acc_chr st) >>= \g1 -> - localize (fontface symbol) (mkline pt (acc_sym st)) >>= \g2 -> - return (a, g1 `oplus` g2) - where - mkline pt h = hkernline (toListH h) pt +-- Point is baseline-center +-- +drawCenterAligned1 :: (Fractional u, Ord u, FromPtSize u) + => InterimText1 u -> Point2 u -> BoundedGraphic u +drawCenterAligned1 itext pt = + let hw = 0.5 * advanceH (text1_advance itext) + in singleLRText (.-^ hvec hw) itext `at` pt +-- Point is baseline-right +-- +drawRightAligned1 :: (Fractional u, Ord u, FromPtSize u) + => InterimText1 u -> Point2 u -> BoundedGraphic u +drawRightAligned1 itext pt = + let w = advanceH (text1_advance itext) + in singleLRText (.-^ hvec w) itext `at` pt -execLRText :: (Num u, FromPtSize u) => LRText u a -> LocGraphic u -execLRText ma = \pt -> liftM snd (runLRText ma pt) -st_zero :: Num u => St u -st_zero = St { delta_chr = 0 - , delta_sym = 0 - , acc_chr = emptyH - , acc_sym = emptyH } - -envZero :: FromPtSize u => DrawingR (Env u) -envZero = (\sz -> Env { char_width = fromPtSize $ charWidth sz - , spacer_width = fromPtSize $ spacerWidth sz }) - <$> fontSize - -gets :: (St u -> a) -> LRText u a -gets fn = LRText $ \_ s -> (fn s, s) +-- This isn't worth the complexity to get to one traversal... -charMove :: Num u => LRText u () -charMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s -> - let step_width = cw + sw - d_sym = (delta_sym s) + step_width - in ((), s { delta_chr = step_width, delta_sym = d_sym }) +linesToInterims :: (FromPtSize u, Ord u) + => String -> DrawingInfo (AdvanceVec u, [InterimText1 u]) +linesToInterims = fmap post . mapM interimText1 . lines + where + post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs) + fn a vmax = avMaxWidth (text1_advance a) vmax -symbMove :: Num u => LRText u () -symbMove = LRText $ \(Env {char_width=cw, spacer_width=sw}) s -> - let step_width = cw + sw - d_chr = (delta_chr s) + step_width - in ((), s { delta_chr = d_chr, delta_sym = step_width }) +avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u +avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a -snocSymb :: KerningChar u -> LRText u () -snocSymb kc = LRText $ \_ s -> ((), upd s) +interimText1 :: FromPtSize u => String -> DrawingInfo (InterimText1 u) +interimText1 ss = let esc = escapeString ss in + postpro (mk esc) $ textVector esc where - upd = (\s a -> s { acc_sym = a `snocH` kc}) <*> acc_sym + mk a b = InterimText1 { text1_escaped = a + , text1_advance = b } -snocChar :: KerningChar u -> LRText u () -snocChar kc = LRText $ \_ s -> ((), upd s) - where - upd = (\s a -> s { acc_chr = a `snocH` kc}) <*> acc_chr -kern :: Num u => u -> LRText u () -kern dx = LRText $ \_ s -> ((), upd s) - where - upd = (\s a b -> s { delta_chr = a+dx, delta_sym = b+dx}) - <*> delta_chr <*> delta_sym +textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u) +textVector esc = let cs = getEscapedText esc in + foldrM (\c v -> charVector c >>= \cv -> return (v ^+^ cv)) (vec 0 0) cs -char :: Num u => Char -> LRText u () -char ch = gets delta_chr >>= \u -> - snocChar (kernchar u ch) >> charMove -escInt :: Num u => Int -> LRText u () -escInt i = gets delta_chr >>= \u -> - snocChar (kernEscInt u i) >> charMove +charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u) +charVector (CharLiteral c) = unCF1 (ord c) avLookupTable +charVector (CharEscInt i) = unCF1 i avLookupTable +charVector (CharEscName s) = unCF1 ix avLookupTable + where + ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices -escName :: Num u => String -> LRText u () -escName s = gets delta_chr >>= \u -> - snocChar (kernEscName u s) >> charMove -symb :: Num u => Char -> LRText u () -symb sy = gets delta_sym >>= \u -> - snocSymb (kernchar u sy) >> symbMove +-- baseline_span is the vertical distance from one baseline to +-- the next it is not /gap_height/. +-- +annotateStartPoints :: Fractional u + => u -> u -> Point2 u -> [InterimText1 u] + -> [(InterimText1 u, Point2 u)] +annotateStartPoints _ _ _ [] = [] +annotateStartPoints cap_height baseline_span (P2 x y) (z:rest) = + let y0 = if odd list_len then odd_start_y else even_start_y + p0 = P2 x y0 + in (z,p0) : step (moveDown1 p0) rest + where + list_len = 1 + length rest + halfn = fromIntegral $ list_len `div` 2 + center_to_bl = 0.5 * cap_height + half_gap_height = 0.5 * (baseline_span - cap_height) + odd_start_y = y - center_to_bl + halfn * baseline_span + even_start_y = y - half_gap_height - cap_height + halfn * baseline_span -symbEscInt :: Num u => Int -> LRText u () -symbEscInt i = gets delta_sym >>= \u -> - snocSymb (kernEscInt u i) >> symbMove + moveDown1 = \pt -> pt .-^ vvec baseline_span -symbEscName :: Num u => String -> LRText u () -symbEscName s = gets delta_sym >>= \u -> - snocSymb (kernEscName u s) >> symbMove + step _ [] = [] + step pt (a:as) = (a,pt) : step (moveDown1 pt) as + diff --git a/src/Wumpus/Basic/Utils/Combinators.hs b/src/Wumpus/Basic/Utils/Combinators.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Utils/Combinators.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Utils.Combinators --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Combiantors - pairing, /static argument/ functions, ... --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Utils.Combinators - ( - - -- * Combinators - fork - , prod - , forkA - - , bindR - , bindAsk - , bindInto - , rlift1 - - , bindR2 - , bindAskR2 - , rlift2 - - - ) where - -import Control.Applicative - -fork :: (a -> b) -> (a -> c) -> a -> (b,c) -fork f g a = (f a, g a) - -prod :: (a -> c) -> (b -> d) -> (a,b) -> (c,d) -prod f g (a,b) = (f a, g b) - - -forkA :: Applicative f => f a -> f b -> f (a,b) -forkA af ab = (,) <$> af <*> ab - - - -infixl 1 `bindR`, `bindR2` - --- Monadic bind with 1 static argument. --- -bindR :: Monad m => (r -> m a) -> (a -> r -> m b) -> r -> m b -bindR cxma cxmf = \x -> cxma x >>= \a -> cxmf a x - --- 'bindAsk' takes a monadic function oblivious to R1 upto bindR. --- (lift and bind). --- -bindAsk :: Monad m => m a -> (a -> r1 -> m b) -> r1 -> m b -bindAsk ma cxmf r1 = ma >>= \a -> cxmf a r1 - - --- 'bindInto' takes a monadic action dependent on R1 and binds --- it into a mondic function oblivious to R1. --- -bindInto :: Monad m => (r1 -> m a) -> (a -> m b) -> r1 -> m b -bindInto cxma mf r1 = cxma r1 >>= \a -> mf a - -rlift1 :: Monad m => m a -> (r -> m a) -rlift1 ma = \_ -> ma - - - --- Monadic bind with 2 static arguments. --- -bindR2 :: Monad m - => (r1 -> r2 -> m a) -> (a -> r1 -> r2 -> m b) -> r1 -> r2 -> m b -bindR2 cxma cxmf = \x y -> cxma x y >>= \a -> cxmf a x y - - --- 'bindAskR2' takes a monadic function oblivious to R1 and R2 upto bindR2. --- (lift and bind). --- -bindAskR2 :: Monad m => m a -> (a -> r1 -> r2 -> m b) -> r1 -> r2 -> m b -bindAskR2 ma cxmf r1 r2 = ma >>= \a -> cxmf a r1 r2 - - -rlift2 :: Monad m => m a -> (r1 -> r2 -> m a) -rlift2 ma = \_ _ -> ma - diff --git a/src/Wumpus/Basic/Utils/FormatCombinators.hs b/src/Wumpus/Basic/Utils/FormatCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Utils/FormatCombinators.hs @@ -0,0 +1,430 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Utils.FormatCombinators +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Formatting combinators - pretty printers without the fitting. +-- +-- Note - indentation support is very limited. Generally one +-- should use a proper pretty printing library. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Utils.FormatCombinators + ( + Doc + , DocS + , Format(..) + , empty + , showsDoc + , (<>) + , (<+>) + , vconcat + , separate + , hcat + , hsep + , vcat + + , text + , char + , int + , integer + , integral + , float + , double + , hex4 + + , space + , comma + , semicolon + , line + + , fill + , fillStringR + , fillStringL + + , punctuate + , enclose + , squotes + , dquotes + , parens + , brackets + , braces + , angles + + , lparen + , rparen + , lbracket + , rbracket + , lbrace + , rbrace + , langle + , rangle + + , list + , tupled + , semiBraces + + , indent + + , writeDoc + + ) where + +import Data.Monoid +import Numeric + +-- | Doc is a Join List ... +-- +data Doc = Doc1 ShowS + | Join Doc Doc + | Line + | Indent !Int Doc + + +type DocS = Doc -> Doc + + +-- Join could be improved... +-- +unDoc :: Doc -> ShowS +unDoc = step 0 id + where + step _ acc (Doc1 sf) = acc . sf + step n acc (Join a b) = let acc' = step n acc a in step n acc' b + step n acc Line = acc . showChar '\n' . indentS n + step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d + + +indentS :: Int -> ShowS +indentS i | i < 1 = id + | otherwise = showString $ replicate i ' ' + +runDoc :: Doc -> String +runDoc = ($ "") . unDoc + + +instance Show Doc where + show = runDoc + +instance Monoid Doc where + mempty = empty + mappend = (<>) + + +class Format a where format :: a -> Doc + +-------------------------------------------------------------------------------- + +infixr 6 <>, <+> + + + +-- | Create an empty, zero length document. +-- +empty :: Doc +empty = Doc1 id + +-- | Create a document from a ShowS function. +-- +showsDoc :: ShowS -> Doc +showsDoc = Doc1 + + +-- | Horizontally concatenate two documents with no space +-- between them. +-- +(<>) :: Doc -> Doc -> Doc +a <> b = Join a b + + +-- | Horizontally concatenate two documents with a single space +-- between them. +-- +(<+>) :: Doc -> Doc -> Doc +a <+> b = Join a (Join space b) + +-- | Vertical concatenate two documents with a line break. +-- +vconcat :: Doc -> Doc -> Doc +vconcat a b = a <> Line <> b + + + +separate :: Doc -> [Doc] -> Doc +separate _ [] = empty +separate sep (a:as) = step a as + where + step acc [] = acc + step acc (x:xs) = step (acc <> sep <> x) xs + +-- | Horizontally concatenate a list of documents with @(\<\>)@. +-- +hcat :: [Doc] -> Doc +hcat = foldr (<>) empty + +-- | Horizontally concatenate a list of documents with @(\<+\>)@. +-- +hsep :: [Doc] -> Doc +hsep = separate space + +-- | Vertically concatenate a list of documents, with a line +-- break between each doc. +-- +vcat :: [Doc] -> Doc +vcat [] = empty +vcat (x:xs) = step x xs + where + step acc (z:zs) = step (acc `vconcat` z) zs + step acc [] = acc + +-- | Create a document from a literal string. +-- +-- The string should not contain newlines (though this is not +-- enforced). +-- +text :: String -> Doc +text = Doc1 . showString + + +-- | Create a document from a literal character. +-- +-- The char should not be a tab or newline. +-- +char :: Char -> Doc +char = Doc1 . showChar + +-- | Show the Int as a Doc. +-- +-- > int = text . show +-- +int :: Int -> Doc +int = Doc1 . showInt + +-- | Show the Integer as a Doc. +-- +integer :: Integer -> Doc +integer = Doc1 . showInt + +-- | Show an \"integral value\" as a Doc via 'fromIntegral'. +-- +integral :: Integral a => a -> Doc +integral = Doc1 . showInt + +-- | Show the Float as a Doc. +-- +float :: Double -> Doc +float = Doc1 . showFloat + +-- | Show the Double as a Doc. +-- +double :: Double -> Doc +double = Doc1 . showFloat + +-- | Show the Int as hexadecimal, padding up to 4 digits if +-- necessary. +-- +-- No trucation occurs if the value has more than 4 digits. +-- +hex4 :: Int -> Doc +hex4 n | n < 0x0010 = text "000" <> showsDoc (showHex n) + | n < 0x0100 = text "00" <> showsDoc (showHex n) + | n < 0x1000 = text "0" <> showsDoc (showHex n) + | otherwise = showsDoc (showHex n) + +-- | Create a Doc containing a single space character. +-- +space :: Doc +space = char ' ' + +-- | Create a Doc containing a comma, \",\". +-- +comma :: Doc +comma = char ',' + +-- | Create a Doc containing a semi colon, \";\". +-- +semicolon :: Doc +semicolon = char ';' + +-- | Create a Doc containing newline, \"\\n\". +-- +line :: Doc +line = char '\n' + + +-------------------------------------------------------------------------------- + +-- | Fill a doc to the supplied length, padding the right-hand +-- side with spaces. +-- +-- Note - this function is expensive - it unrolls the functional +-- representation of the String. +-- +-- Also it should only be used for single line Doc\'s. +-- +fill :: Int -> Doc -> Doc +fill i d = Doc1 (padr i ' ' $ unDoc d) + +padr :: Int -> Char -> ShowS -> ShowS +padr i c df = step (length $ df []) + where + step len | len >= i = df + | otherwise = df . showString (replicate (i-len) c) + +-- | String version of 'fill'. +-- +-- This is more efficient than 'fill' as the input is a string +-- so its length is more accesible. +-- +-- Padding is the space character appended to the right. +-- +fillStringR :: Int -> String -> Doc +fillStringR i s = step (length s) + where + step n | n >= i = text s + step n = text s <> text (replicate (i-n) ' ') + +-- | Left-padding version of 'fillStringR'. +-- +fillStringL :: Int -> String -> Doc +fillStringL i s = step (length s) + where + step n | n >= i = text s + step n = text (replicate (i-n) ' ') <> text s + +-------------------------------------------------------------------------------- + +-- | Punctuate the Doc list with the separator, producing a Doc. +-- +punctuate :: Doc -> [Doc] -> Doc +punctuate _ [] = empty +punctuate _ [x] = x +punctuate s (x:xs) = x <> s <> punctuate s xs + + +-- | Enclose the final Doc within the first two. +-- +-- There are no spaces between the documents: +-- +-- > enclose l r d = l <> d <> r +-- +enclose :: Doc -> Doc -> Doc -> Doc +enclose l r d = l <> d <> r + + + +-- | Enclose the Doc within single quotes. +-- +squotes :: Doc -> Doc +squotes = enclose (char '\'') (char '\'') + +-- | Enclose the Doc within double quotes. +-- +dquotes :: Doc -> Doc +dquotes = enclose (char '"') (char '"') + +-- | Enclose the Doc within parens @()@. +-- +parens :: Doc -> Doc +parens = enclose lparen rparen + +-- | Enclose the Doc within square brackets @[]@. +-- +brackets :: Doc -> Doc +brackets = enclose lbracket rbracket + +-- | Enclose the Doc within curly braces @{}@. +-- +braces :: Doc -> Doc +braces = enclose lbrace rbrace + +-- | Enclose the Doc within angle brackets @\<\>@. +-- +angles :: Doc -> Doc +angles = enclose langle rangle + + + +-- | Create a Doc containing a left paren, \'(\'. +-- +lparen :: Doc +lparen = char '(' + +-- | Create a Doc containing a right paren, \')\'. +-- +rparen :: Doc +rparen = char ')' + +-- | Create a Doc containing a left square bracket, \'[\'. +-- +lbracket :: Doc +lbracket = char '[' + +-- | Create a Doc containing a right square bracket, \']\'. +-- +rbracket :: Doc +rbracket = char ']' + +-- | Create a Doc containing a left curly brace, \'{\'. +-- +lbrace :: Doc +lbrace = char '{' + +-- | Create a Doc containing a right curly brace, \'}\'. +-- +rbrace :: Doc +rbrace = char '}' + +-- | Create a Doc containing a left angle bracket, \'\<\'. +-- +langle :: Doc +langle = char '<' + +-- | Create a Doc containing a right angle bracket, \'\>\'. +-- +rangle :: Doc +rangle = char '>' + +-- | Comma separate the list of documents and enclose in square +-- brackets. +-- +list :: [Doc] -> Doc +list = brackets . punctuate comma + +-- | Comma separate the list of documents and enclose in parens. +-- +tupled :: [Doc] -> Doc +tupled = parens . punctuate comma + +-- | Separate the list with a semicolon and enclose in curly +-- braces. +-- +semiBraces :: [Doc] -> Doc +semiBraces = braces . punctuate semicolon + + +-- | Horizontally indent a Doc. +-- +-- Note - this space-prefixes the Doc on /the current line/. It +-- does not indent subsequent lines if the Doc spans multiple +-- lines. +-- +indent :: Int -> Doc -> Doc +indent i d | i < 1 = d + | otherwise = Indent i d + +-------------------------------------------------------------------------------- + + +-- | Write a Doc to file. +-- +writeDoc :: FilePath -> Doc -> IO () +writeDoc filepath d = writeFile filepath $ show d diff --git a/src/Wumpus/Basic/Utils/ParserCombinators.hs b/src/Wumpus/Basic/Utils/ParserCombinators.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Utils/ParserCombinators.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Utils.ParserCombinators +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Two continuation parser combinators. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Utils.ParserCombinators + ( + Parser + , Result(..) + , CharParser + , CharResult + , ParseError + + , runParser + , runParserEither + , apply + , failure + , throwError + , () + , lookahead + , peek + , eof + , equals + , satisfy + , oneOf + , noneOf + + , chainl1 + , chainr1 + , chainl + , chainr + , choice + , count + , between + , option + , optionMaybe + , optionUnit + , skipOne + , skipMany + , skipMany1 + , many1 + , sepBy + , sepBy1 + , sepEndBy + , sepEndBy1 + , manyTill + , manyTill1 + + -- * Char parsers + , char + , string + , anyChar + , upper + , lower + , letter + , alphaNum + , digit + , hexDigit + , octDigit + , newline + , tab + , space + + + + ) where + +import Control.Applicative +import Control.Monad +import Data.Char + + +data Result s ans = Fail String [s] | Okay ans [s] + deriving (Eq,Ord,Show) + + +type SK s r ans = r -> FK s ans -> [s] -> Result s ans +type FK s ans = Result s ans + + +newtype Parser s r = Parser { + getParser :: forall ans. SK s r ans -> FK s ans -> [s] -> Result s ans } + + +type CharParser a = Parser Char a +type CharResult a = Result Char a +type ParseError = String + +runParser :: Parser s a -> [s] -> Result s a +runParser p = getParser p skZero fkZero + where + skZero = \ans _ ss -> Okay ans ss + fkZero = Fail "" [] + + +runParserEither :: Show s => Parser s a -> [s] -> Either ParseError a +runParserEither p = post . runParser p + where + post (Okay a _) = Right a + post (Fail err []) = Left $ err ++ "\nUnexpected EOF" + post (Fail err ss) = Left $ err ++ "\n" ++ (take 20 $ show ss) + + +-- @return@ of Monad, @pure@ of Applicative +-- +yield :: a -> Parser s a +yield a = Parser $ \sk fk ss -> sk a fk ss + +-- mplus of MonadPlus, (<|>) of Applicative. +-- +alt :: Parser s a -> Parser s a -> Parser s a +alt p1 p2 = Parser $ \sk fk ss -> getParser p1 sk (getParser p2 sk fk ss) ss + +infixl 5 `apply` + +apply :: Functor f => f a -> (a -> b) -> f b +apply = flip fmap + + +failure :: Parser s a +failure = Parser $ \_ fk _ -> fk + + +-- eager-many / zero-or-more (many of Applicative) +-- +eagerMany :: Parser s a -> Parser s [a] +eagerMany p = (p >>= \r -> eagerMany p `apply` \rs -> (r:rs)) <|> return [] + +-- eager-some / one-or-more (some of Applicative) +-- +eagerSome :: Parser s a -> Parser s [a] +eagerSome p = p >>= \r -> eagerMany p `apply` \rs -> (r:rs) + + +instance Functor (Parser s) where + fmap f mf = Parser $ \sk -> getParser mf $ \a -> (sk . f) a + + + +instance Applicative (Parser s) where + pure = yield + (<*>) = ap + +instance Alternative (Parser s) where + empty = failure + (<|>) = alt + many = eagerMany + some = eagerSome + +instance Monad (Parser s) where + return = yield + m >>= k = Parser $ \sk -> getParser m $ \a -> getParser (k a) sk + +instance MonadPlus (Parser s) where + mzero = failure + mplus = alt + + + +-------------------------------------------------------------------------------- +-- Combinators + + +throwError :: String -> Parser s a +throwError err_msg = Parser $ \_ _ ss -> Fail err_msg ss + + +infixr 0 + +() :: Parser s a -> String -> Parser s a +p err_msg = Parser $ \sk fk ss -> getParser p sk (swapMsg fk) ss + where + swapMsg (Fail _ ss) = Fail err_msg ss + swapMsg okay = okay + +-- | This one is from Chris Okasaki\'s \"Even Higher-Order +-- Functions for Parsing\". +-- +lookahead :: Parser s a -> (a -> Parser s b) -> Parser s b +lookahead p mf = Parser $ \sk fk -> + getParser p (\a fk2 -> getParser (mf a) sk fk2) fk + + +-- | Peek tries the supplied parse, but does not consume input +-- \*\* even when the parse succeeds \*\*. +-- +peek :: Parser s a -> Parser s a +peek p = Parser $ \sk fk ss -> + getParser p (\a fk2 _ -> sk a fk2 ss) fk ss + + +eof :: Parser s () +eof = Parser go + where + go sk fk [] = sk () fk [] + go _ fk _ = fk + +equals :: Eq s => s -> Parser s s +equals sym = Parser go + where + go sk fk (s:ss) | s == sym = sk s fk ss + go _ fk _ = fk + + +satisfy :: (s -> Bool) -> Parser s s +satisfy test = Parser go + where + go sk fk (s:ss) | test s = sk s fk ss + go _ fk _ = fk + + +oneOf :: Eq s => [s] -> Parser s s +oneOf cs = satisfy (`elem` cs) + +noneOf :: Eq s => [s] -> Parser s s +noneOf cs = satisfy (`notElem` cs) + + + +-- Note - the type sigs of the chain parsers can be generalized +-- to any MonadPlus. +-- + +chainl1 :: MonadPlus m => m a -> m (a -> a -> a) -> m a +chainl1 p op = p >>= rest + where + rest x = mplus (op >>= \f -> p >>= \a -> rest (f x a)) (return x) + + +chainr1 :: MonadPlus m => m a -> m (a -> a -> a) -> m a +chainr1 p op = scan + where + scan = p >>= rest + rest x = mplus (op >>= \f -> scan >>= \a -> rest (f x a)) (return x) + +chainl :: MonadPlus m => m a -> m (a -> a -> a) -> a -> m a +chainl p op v = mplus (chainl1 p op) (return v) + +chainr :: MonadPlus m => m a -> m (a -> a -> a) -> a -> m a +chainr p op v = mplus (chainr1 p op) (return v) + + +infixr 5 <:> + +-- | Applicative cons. +-- +(<:>) :: Applicative f => f a -> f [a] -> f [a] +(<:>) p1 p2 = (:) <$> p1 <*> p2 + + +choice :: Alternative f => [f a] -> f a +choice = foldr (<|>) empty + +count :: Applicative f => Int -> f a -> f [a] +count i p | i <= 0 = pure [] + | otherwise = p <:> count (i-1) p + +between :: Applicative f => f open -> f close -> f a -> f a +between o c a = o *> a <* c + + +option :: Alternative f => a -> f a -> f a +option x p = p <|> pure x + +optionMaybe :: Alternative f => f a -> f (Maybe a) +optionMaybe = optional + +-- aka Parsecs /optional/ +optionUnit :: Alternative f => f a -> f () +optionUnit p = () <$ p <|> pure () + +skipOne :: Applicative f => f a -> f () +skipOne p = p *> pure () + +skipMany :: Alternative f => f a -> f () +skipMany p = many_p + where + many_p = some_p <|> pure () + some_p = p *> many_p + +skipMany1 :: Alternative f => f a -> f () +skipMany1 p = p *> skipMany p + +-- | 'many1' an alias for Control.Applicative 'some'. +-- +many1 :: Alternative f => f a -> f [a] +many1 = some + +sepBy :: Alternative f => f a -> f b -> f [a] +sepBy p sep = sepBy1 p sep <|> pure [] + +sepBy1 :: Alternative f => f a -> f b -> f [a] +sepBy1 p sep = p <:> step + where + step = (sep *> p) <:> step <|> pure [] + +sepEndBy :: Alternative f => f a -> f b -> f [a] +sepEndBy p sep = sepEndBy1 p sep <|> pure [] + +sepEndBy1 :: Alternative f => f a -> f b -> f [a] +sepEndBy1 p sep = (p <* sep) <:> step + where + step = (p <* sep) <:> step <|> pure [] + +manyTill :: Alternative f => f a -> f b -> f [a] +manyTill p end = step <|> pure [] + where + step = p <:> (final <|> step) + final = [] <$ end + +manyTill1 :: Alternative f => f a -> f b -> f [a] +manyTill1 p end = p <:> step + where + step = final <|> (p <:> step) + final = [] <$ end + + +-------------------------------------------------------------------------------- +-- Char parsers + + +char :: Char -> CharParser Char +char ch = satisfy (==ch) + +string :: String -> CharParser String +string ss = mapM char ss + +anyChar :: CharParser Char +anyChar = Parser go + where + go sk fk (s:ss) = sk s fk ss + go _ fk _ = fk + + +upper :: CharParser Char +upper = satisfy isUpper + +lower :: CharParser Char +lower = satisfy isLower + +letter :: CharParser Char +letter = satisfy isAlpha + +alphaNum :: CharParser Char +alphaNum = satisfy isAlphaNum + +digit :: CharParser Char +digit = satisfy isDigit + +hexDigit :: CharParser Char +hexDigit = satisfy isHexDigit + +octDigit :: CharParser Char +octDigit = satisfy isOctDigit + +newline :: CharParser Char +newline = equals '\n' + +tab :: CharParser Char +tab = equals '\t' + +space :: CharParser Char +space = satisfy isSpace + diff --git a/src/Wumpus/Basic/Utils/TokenParsers.hs b/src/Wumpus/Basic/Utils/TokenParsers.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Utils/TokenParsers.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Utils.TokenParsers +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Generally you should expect to import this module qualified +-- and define versions to consume trailing white-space. +-- +-- > lexDef :: P.LexemeParser +-- > lexDef = P.commentLineLexemeParser "Comment" [' ', '\t'] +-- > +-- > lexeme :: CharParser a -> CharParser a +-- > lexeme = P.lexeme lexDef +-- > +-- > integer :: CharParser Int +-- > integer = lexeme P.integer +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Utils.TokenParsers + ( + + LexemeParser + , spaceLexemeParser + , spaceCharLexemeParser + , commentLexemeParser + , commentLineLexemeParser + , commentMultiLexemeParser + + , lexeme + , whiteSpace + + , octBase + , octHask + + , hexBase + + , natural + , integer + , double + + ) where + +import Wumpus.Basic.Utils.ParserCombinators + +import Control.Applicative + +-- | Opaque type representing a parser that consumes arbitrary +-- space. +-- +-- Unlike Parsec\'s lexeme parser, this can be customized so that +-- e.g. newlines are not consumed as white space. +-- +newtype LexemeParser = LexemeParser { getLexemeParser :: CharParser () } + +-- | Build a lexeme parser that handles /space/. +-- +-- /Space/ is zero or more elements matching the @isSpace@ +-- predicate from @Data.Char@. +-- +spaceLexemeParser :: LexemeParser +spaceLexemeParser = LexemeParser go + where + go = () <$ many space + + +-- | Build a lexeme parser that handles arbitrary /space/. +-- +-- /space/ is parametric, for instance this can manufacture a +-- lexeme parser that consumes space and tab chars but not +-- newline. +-- +spaceCharLexemeParser :: [Char] -> LexemeParser +spaceCharLexemeParser cs = LexemeParser go + where + go = skipMany (oneOf cs) + + +-- | Build a lexeme parser that handles start-and-end delimited +-- comments and arbitrary /space/. +-- +commentLexemeParser :: String -> (String,String) -> [Char] -> LexemeParser +commentLexemeParser line (start,end) cs = LexemeParser go + where + go = skipMany (whiteChar <|> lineComment line + <|> spanComment start end) + whiteChar = skipOne (oneOf cs) + + +-- | Build a lexeme parser that handles line spanning comments +-- an arbitrary /space/. +-- +commentLineLexemeParser :: String -> [Char] -> LexemeParser +commentLineLexemeParser start cs = LexemeParser go + where + go = skipMany (whiteChar <|> lineComment start) + whiteChar = skipOne (oneOf cs) + + +-- | Build a lexeme parser that handles start-and-end delimited +-- comments, line comments and arbitrary /space/. +-- +commentMultiLexemeParser :: String -> String -> [Char] -> LexemeParser +commentMultiLexemeParser start end cs = LexemeParser go + where + go = skipMany (whiteChar <|> spanComment start end) + whiteChar = skipOne (oneOf cs) + +lineComment :: String -> CharParser () +lineComment start = + skipOne (string start *> manyTill anyChar endLine) + +spanComment :: String -> String -> CharParser () +spanComment start end = + string start *> manyTill anyChar (string end) *> return () + + +endLine :: CharParser () +endLine = skipOne (char '\n') <|> eof + + +-- | Wrap a CharParser with a lexeme parser, the CharParser will +-- consume trailing space according to the strategy of the +-- LexemeParser. +-- +lexeme :: LexemeParser -> CharParser a -> CharParser a +lexeme trail p = p <* getLexemeParser trail + +whiteSpace :: LexemeParser -> CharParser () +whiteSpace = getLexemeParser + +-------------------------------------------------------------------------------- + + + + +octBase :: CharParser Int +octBase = (\cs -> read $ '0':'o':cs) <$> many1 octDigit + +octHask :: CharParser Int +octHask = (string "0o" <|> string "0O") *> octBase + + +hexBase :: CharParser Int +hexBase = (\xs -> read $ '0':'x':xs) <$> many1 hexDigit + + + +-------------------------------------------------------------------------------- + +natural :: CharParser Integer +natural = liftA read (many1 digit) + + +integer :: CharParser Integer +integer = ($) <$> psign <*> natural + where + psign = option id (negate <$ char '-') + + +double :: CharParser Double +double = (\signf intpart fracpart -> signf $ intpart + fracpart) + <$> psign <*> onatural <*> ofrac + where + psign = option id (negate <$ char '-') + onatural = option 0 (fromIntegral <$> natural) + ofrac = option 0 ((\xs -> read $ '.':xs) <$> (char '.' *> (many1 digit))) 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,12,0) +-- > (0,13,0) -- wumpus_basic_version :: (Int,Int,Int) -wumpus_basic_version = (0,12,0) +wumpus_basic_version = (0,13,0) diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal --- a/wumpus-basic.cabal +++ b/wumpus-basic.cabal @@ -1,5 +1,5 @@ name: wumpus-basic -version: 0.12.0 +version: 0.13.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -9,87 +9,63 @@ synopsis: Common drawing utilities built on wumpus-core. description: . - \*\* WARNING \*\* - this package is sub-alpha. It was released - to Hackage prematurely - designing a higher-level drawing - library turns out to be much more demanding than designing a - low-level one (Wumpus-Core). - . - Some of the modules (SafeFonts, SVGColours, X11Colours) are - relatively stable. The core modules of @Basic.Graphic@ (@Base@, - @PrimGraphic@, @DrawingContext@) seem to support a good set - primitive functions, but the exact types of drawing objects do - not feel right at the moment. Other modules (Paths, Chains, - Shapes) are still being worked out and may be substantially - revised in subsequent updates. - . - Version 0.12.0 extends the sets of arrowheads and connectors. - Unfortunately Shapes are still undercooked. - . - Changelog: - . - 0.11.0 to 0.12.0: - . - * Changes Base types in @Basic.Graphic@. The @Graphic@ and - @Image@ types now produce (wrapped) @Primitives@, rather than - Hughes lists of @Primitives@. This means they can now be - transformed with the affine transformations. Removed the - function @ati@, it is replaced by @at@. - . - * Added @Basic.Utils.Combinators@. + \*\* 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...). . - * Arrowheads and Connectors reworked - Arrowheads are now a - functional type, Connectors use new Image combining - operations from @Basic.Graphic.Base@. + Version 0.13.0 significantly differs form the previous release + as font metrics support has been added and the core graphic + types have been redesigned. With these re-workings some modules + that were previously fairly stable have changed substantially or + are likely to change soon (@Basic.PictureLanguage@ has become + @Basic.DrawingComposition@; @Basic.SafeFonts@ no longer seems + very /SVG safe/ so it is marked as pending change). . - * Path connectors re-worked and renamed. + 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. . - * Dot hierarchy changed - @Basic.Dots@ becomes - @Basic.Dots.AnchorDots@; @Basic.Dots.Primitive@ becomes - @Basic.Dots.Marks@. + Adobe Font techinal notes: + . - * @Basic.Shapes@ - internals reworked. + Core 14 AFM metrics: + . - 0.10.0 to 0.11.0: - . - * Reworked arrowheads and connectors - connectors are now - configurable: there are functions to make connectors with - a left arrowhead, right arrowhead, none or both. + WARNING - the font metrics parsing in version 0.13.0 is + essentially a proof-of-concept and is not very robust. + Generally, if a font cannot be parsed, fallback metrics will be + used. At the moment there no error logging, so there is little + indication of whether Wumpus has used the correct metrics or the + fallback for a requested font. . - * Reworked shapes - internally shapes now create a @Path@ rather - than a @Graphic@ this means the path can be manipulated (e.g. - round cornered rectangles, diamonds... can be constructed). - @Coordinate@ is no longer a @Shape@ - it is now similar object - but of a different type. Likewise, @FreeLabel@ has been - replaced by @Plaintext@ which is not a @Shape@, but has some - similar properties. Unfortunately, the Shape types are still - difficult to work with and a larger reworking is still - necessary. + Changelog: . - * @Basic.Paths.Base@ - @Path@ type changed, @PathEmpty@ - constructor removed so empty paths cannot be created. This - allows a better API for taking points on a path. It also - means @Path@ is no longer an instance of Monoid. Type changes - to various functions (e.g. @tipR@, @tipL@) reflecting that as - paths cannot now be empty, functions on them can generally be - total. @toPrimPathU@ removed as converting to a PrimPath as - now always /safe/. @tracePoints@ renamed @traceLinePoints@, - @tracePointsCurve@ renamed @traceCurvePoints@, @midpoint@ - renamed @midway@. + 0.12.0 to 0.13.0: . - * @Basic.Graphic@ - the types @ConnDrawingR@, @ConnGraphic@ etc. - have had their names expanded to @ConnectorDrawingR@, - @ConnectorGraphic@... + * 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@. . - * @Basic.SafeFont@ - font names changed to use underscore - separators rather than camelCase. Wumpus generally uses - underscored names for /constants/. + * Rudimentary font loading added, only AFM files are supported. . - * Removed @conn@ from @Basic.Graphic.Drawing@. Connectors should - be used instead. + * @Basic.Shapes.Coordinate@ re-worked. The Coordinate type is + now more like the Shapes types (excepting the intentional + difference in drawing style). . - * The class @DrawingCtxM@ now has @Applicative@ as a superclass. + * @Basic.Shapes.Plaintext@ removed. . - * @lineSpacing@ renamed @baselineSpacing@. + * @Basic.Text.LRText@ completely redesigned. . . build-type: Simple @@ -103,24 +79,28 @@ demo/Arrowheads.hs, demo/ClipPic.hs, demo/ColourCharts.hs, - demo/ColourDefns.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/Picture.hs, demo/Symbols.hs library hs-source-dirs: src build-depends: base < 5, - containers >= 0.3 && <= 0.4, - vector-space >= 0.6, - wumpus-core == 0.36.0 + containers >= 0.3 && <= 0.4, + directory >= 1.0 && < 2.0, + filepath >= 1.1 && < 2.0, + vector-space >= 0.6 && < 1.0, + wumpus-core == 0.40.0 exposed-modules: - Wumpus.Basic.Anchors, Wumpus.Basic.Arrows, Wumpus.Basic.Arrows.Connectors, Wumpus.Basic.Arrows.Tips, @@ -131,13 +111,26 @@ Wumpus.Basic.Colour.X11Colours, Wumpus.Basic.Dots.AnchorDots, Wumpus.Basic.Dots.Marks, + Wumpus.Basic.DrawingComposition, + Wumpus.Basic.FontLoader.AfmLoader, + Wumpus.Basic.FontLoader.AfmParserBase, + Wumpus.Basic.FontLoader.AfmV2Parser, + Wumpus.Basic.FontLoader.AfmV4Dot1Parser, + Wumpus.Basic.FontLoader.Base, + Wumpus.Basic.FontLoader.GSFontMap, + Wumpus.Basic.FontLoader.GSLoader, Wumpus.Basic.Graphic, + Wumpus.Basic.Graphic.Anchors, Wumpus.Basic.Graphic.Base, + Wumpus.Basic.Graphic.ContextFunction, Wumpus.Basic.Graphic.Drawing, Wumpus.Basic.Graphic.DrawingContext, - Wumpus.Basic.Graphic.PrimGraphic, + Wumpus.Basic.Graphic.GlyphMetrics + Wumpus.Basic.Graphic.GraphicOperations, + Wumpus.Basic.Graphic.GraphicTypes, Wumpus.Basic.Graphic.Query, Wumpus.Basic.Graphic.ScalingContext, + Wumpus.Basic.Graphic.TraceDrawing, Wumpus.Basic.Monads.TurtleClass, Wumpus.Basic.Monads.TurtleMonad, Wumpus.Basic.Paths, @@ -151,14 +144,13 @@ Wumpus.Basic.Shapes.Base, Wumpus.Basic.Shapes.Coordinate, Wumpus.Basic.Shapes.Derived, - Wumpus.Basic.Shapes.Plaintext, - Wumpus.Basic.Text.LRSymbol, Wumpus.Basic.Text.LRText, - Wumpus.Basic.Utils.Combinators, Wumpus.Basic.Utils.HList, + Wumpus.Basic.Utils.FormatCombinators, Wumpus.Basic.Utils.Intersection, - Wumpus.Basic.VersionNumber, - Wumpus.Basic.PictureLanguage + Wumpus.Basic.Utils.ParserCombinators, + Wumpus.Basic.Utils.TokenParsers, + Wumpus.Basic.VersionNumber other-modules: