diff --git a/CHANGES b/CHANGES new file mode 100644 --- /dev/null +++ b/CHANGES @@ -0,0 +1,4 @@ + +0.1.0: + + * Initial split from Wumpus-Basic. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008 Stephen Peter Tetley + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,29 @@ +#!/usr/bin/env runhaskell + +import Distribution.Simple +import Distribution.Simple.Setup ( SDistFlags ) +import Distribution.PackageDescription ( HookedBuildInfo, emptyHookedBuildInfo ) + + +main = defaultMainWithHooks sdist_warning_hooks + +sdist_warning_hooks :: UserHooks +sdist_warning_hooks = simpleUserHooks { preSDist = sdistVersionWarning } + + +sdistVersionWarning :: Args -> SDistFlags -> IO HookedBuildInfo +sdistVersionWarning _ _ = + mapM_ putStrLn msg >> printVersionNumberFile >> return emptyHookedBuildInfo + where + msg = [ "-------------------------------------------------------" + , "-------------------------------------------------------" + , "" + , "WARNING - is Wumpus.Drawing.VersionNumber correct?" + , "" + , "-------------------------------------------------------" + , "-------------------------------------------------------" + ] + +printVersionNumberFile :: IO () +printVersionNumberFile = + readFile "src/Wumpus/Drawing/VersionNumber.hs" >>= putStrLn diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs new file mode 100644 --- /dev/null +++ b/demo/ArrowCircuit.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + + +-- Acknowledgment - the Arrow diagram is taken from Ross +-- Paterson\'s slides /Arrows and Computation/. + + +module ArrowCircuit where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts + +import Wumpus.Core -- package: wumpus-core + +import FontLoaderUtils + + +import Data.AffineSpace + +import System.Directory + + +main :: IO () +main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help + createDirectoryIfMissing True "./out/" + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." + +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (base_metrics, msgs) <- loadGSMetrics font_dir ["Times-Roman", "Times-Italic"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic + writeEPS "./out/arrow_circuit01.eps" pic1 + writeSVG "./out/arrow_circuit01.svg" pic1 + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Times-Roman", "Times-Italic"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) circuit_pic + writeEPS "./out/arrow_circuit02.eps" pic1 + writeSVG "./out/arrow_circuit02.svg" pic1 + + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace times_roman . metricsContext 11 + + + +-- Note - quite a bit of this diagram was produced /by eye/, +-- rather than using anchors directly - e.g. the placing of the +-- ptext labels and the anchors displaced by vectors. +-- + +-- Note `at` currently does not work for Shapes. + +circuit_pic :: CtxPicture Double +circuit_pic = drawTracing $ do + a1 <- drawi $ (strokedShape $ rrectangle 12 66 30) `at` P2 0 72 + atext a1 "CONST 0" + a2 <- drawi $ (strokedShape $ circle 16) `at` P2 120 60 + atext a2 "IF" + a3 <- drawi $ (strokedShape $ circle 16) `at` P2 240 28 + atext a3 "+1" + a4 <- drawi $ (strokedShape $ rectangle 66 30) `at` P2 120 0 + atext a4 "DELAY 0" + connWith connLine (east a1) (east a1 .+^ hvec 76) + connWith connLine (east a2) (east a2 .+^ hvec 180) + connWith connLine (north a2 .+^ vvec 40) (north a2) + connWith connLine (north a3 .+^ vvec 16) (north a3) + connWith connRightVH (south a3) (east a4) + connWith (connRightHVH (-30)) (west a4) (southwest a2) + ptext (P2 40 10) "next" + ptext (P2 152 100) "reset" + ptext (P2 252 72) "output" + return () + + + +connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m + , Real u, Floating u, FromPtSize u ) + => ConnectorPath u -> Point2 u -> Point2 u -> m () +connWith con p0 p1 = localize doublesize $ + drawi_ $ apply2R2 (rightArrow tri45 con) p0 p1 + + +atext :: ( CenterAnchor t, DUnit t ~ u + , Real u, Floating u, FromPtSize u + , TraceM m, DrawingCtxM m, u ~ MonUnit m ) + => t -> String -> m () +atext ancr ss = let pt = center ancr in + drawi_ $ ctrCenterLine ss `at` pt + + +ptext :: ( Real u, Floating u, FromPtSize u + , TraceM m, DrawingCtxM m, u ~ MonUnit m ) + => Point2 u -> String -> m () +ptext pt ss = localize (fontAttr times_italic 14) $ + drawi_ $ ctrCenterLine ss `at` pt + + +rrectangle :: (Real u, Floating u, FromPtSize u) + => u -> u -> u -> LocShape u (Rectangle u) +rrectangle r w h = localize (roundCornerFactor $ realToFrac r) (rectangle w h) diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs new file mode 100644 --- /dev/null +++ b/demo/Arrowheads.hs @@ -0,0 +1,83 @@ +{-# OPTIONS -Wall #-} + +module Arrowheads where + + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths hiding ( length ) + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_ctx arrow_drawing + writeEPS "./out/arrowheads01.eps" pic1 + writeSVG "./out/arrowheads01.svg" pic1 + +arrow_drawing :: CtxPicture Double +arrow_drawing = drawTracing $ localize (dashPattern unit_dash_pattern) + $ tableGraphic arrtable + +arrtable :: [(Arrowhead Double, Arrowhead Double)] +arrtable = + [ (tri90, tri90) + , (tri60, tri60) + , (tri45, tri45) + , (otri90, otri90) + , (otri60, otri60) + , (otri45, otri45) + , (revtri90, revtri90) + , (revtri60, revtri60) + , (revtri45, revtri45) + , (orevtri90, orevtri90) + , (orevtri60, orevtri60) + , (orevtri45, orevtri45) + , (barb90, barb90) + , (barb60, barb60) + , (barb45, barb45) + , (revbarb90, revbarb90) + , (revbarb60, revbarb60) + , (revbarb45, revbarb45) + , (perp, perp) + , (bracket, bracket) + , (diskTip, diskTip) + , (odiskTip, odiskTip) + , (squareTip, squareTip) + , (osquareTip, osquareTip) + , (diamondTip, diamondTip) + , (odiamondTip, odiamondTip) + , (curveTip, curveTip) + , (revcurveTip, revcurveTip) + ] + +tableGraphic :: (Real u, Floating u, FromPtSize u) + => [(Arrowhead u, Arrowhead u)] -> TraceDrawing u () +tableGraphic tips = zipchainWith makeArrowDrawing tips ps + where + ps = tableDown 20 (120,24) (P2 0 480) + + + +std_ctx :: DrawingContext +std_ctx = fillColour peru $ standardContext 18 + + + +makeArrowDrawing :: (Real u, Floating u, FromPtSize u) + => (Arrowhead u, Arrowhead u) -> LocGraphic u +makeArrowDrawing (arrl,arrr) = + promoteR1 $ \p0 -> forget $ + connect (leftRightArrow arrl arrr connLine) p0 (mkP1 p0) + where + mkP1 = (.+^ hvec 100) + -- forget needs a better name, then adding to Wumpus-Basic. + forget = fmap (replaceL uNil) + diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs new file mode 100644 --- /dev/null +++ b/demo/ClipPic.hs @@ -0,0 +1,104 @@ +{-# OPTIONS -Wall #-} + +-- Note - how the background is built in this example is very +-- expensive, i.e. it generates large PostScript and SVG files +-- because the text elements are drawn many more times than they +-- are actually seen. +-- +-- This example just illustrates that clipping-paths work and +-- uses a complicated background to make that point. +-- + + +module ClipPic where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Text.SafeFonts + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import System.Directory + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic = runCtxPictureU pic_drawing_ctx big_pic + writeEPS "./out/clip_pic.eps" pic + writeSVG "./out/clip_pic.svg" pic + + +pic_drawing_ctx :: DrawingContext +pic_drawing_ctx = standardContext 14 + + +big_pic :: DCtxPicture +big_pic = pic1 `nextToV` zconcat [cpic1, cpic2, cpic3, cpic4] + +fillPath :: Num u => Path u -> Graphic u +fillPath = filledPath . toPrimPath + +pic1 :: DCtxPicture +pic1 = drawTracing $ + localize (fillColour medium_slate_blue) $ do + draw $ fillPath path01 + localize (fillColour powder_blue) $ + draw $ fillPath path02 + draw $ fillPath path03 + draw $ fillPath path04 + + +background :: RGBi -> DCtxPicture +background rgb = drawTracing $ + localize (strokeColour rgb) $ + unchain 112 iheartHaskell $ tableDown 18 (86,16) (P2 0 288) + +cpic1 :: DCtxPicture +cpic1 = clipCtxPicture (toPrimPath path01) (background black) + +cpic2 :: DCtxPicture +cpic2 = clipCtxPicture (toPrimPath path02) (background medium_violet_red) + +cpic3 :: DCtxPicture +cpic3 = clipCtxPicture (toPrimPath path03) (background black) + +cpic4 :: DCtxPicture +cpic4 = clipCtxPicture (toPrimPath path04) (background black) + + +iheartHaskell :: Num u => FromPtSize u => LocGraphic u +iheartHaskell = promoteR1 $ \pt -> + let body = textline "I Haskell" `at` pt + heart = localize (fontFace symbol) $ + textline "&heart;" `at` (pt .+^ hvec 7) + in body `oplus` heart + + +path01 :: Floating u => Path u +path01 = execPath zeroPt $ hline 80 >> rlineto (vec 112 160) + >> rlineto (vec (-112) 160) + >> hline (-80) + >> rlineto (vec 112 (-160)) + >> rlineto (vec (-112) (-160)) + + +path02 :: Floating u => Path u +path02 = execPath (P2 112 0) $ hline 80 >> rlineto (vec 72 112) + >> rlineto (vec 72 (-112)) + >> hline 80 + >> rlineto (vec (-224) 320) + >> hline (-80) + >> rlineto (vec 112 (-160)) + >> rlineto (vec (-112) (-160)) + +path03 :: Floating u => Path u +path03 = execPath (P2 384 96) $ hline 96 >> vline 56 >> hline (-136) + +path04 :: Floating u => Path u +path04 = execPath (P2 328 192) $ hline 152 >> vline 56 >> hline (-192) + diff --git a/demo/ColourChartUtils.hs b/demo/ColourChartUtils.hs 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.Drawing.Colour.SVGColours as SVG +import qualified Wumpus.Drawing.Colour.X11Colours as X11 + +import Wumpus.Core.Colour ( RGBi ) + + +all_svg_colours :: [(String,RGBi)] +all_svg_colours = + [ ("alice_blue", SVG.alice_blue) + , ("antique_white", SVG.antique_white) + , ("aqua", SVG.aqua) + , ("aquamarine", SVG.aquamarine) + , ("azure", SVG.azure) + , ("beige", SVG.beige) + , ("bisque", SVG.bisque) + , ("black", SVG.black) + , ("blanched_almond", SVG.blanched_almond) + , ("blue", SVG.blue) + , ("blue_violet", SVG.blue_violet) + , ("brown", SVG.brown) + , ("burlywood", SVG.burlywood) + , ("cadet_blue", SVG.cadet_blue) + , ("chartreuse", SVG.chartreuse) + , ("chocolate", SVG.chocolate) + , ("coral", SVG.coral) + , ("cornflower_blue", SVG.cornflower_blue) + , ("cornsilk", SVG.cornsilk) + , ("crimson", SVG.crimson) + , ("cyan", SVG.cyan) + , ("dark_blue", SVG.dark_blue) + , ("dark_cyan", SVG.dark_cyan) + , ("dark_goldenrod", SVG.dark_goldenrod) + , ("dark_gray", SVG.dark_gray) + , ("dark_green", SVG.dark_green) + , ("dark_grey", SVG.dark_grey) + , ("dark_khaki", SVG.dark_khaki) + , ("dark_magenta", SVG.dark_magenta) + , ("dark_olive_green", SVG.dark_olive_green) + , ("dark_orange", SVG.dark_orange) + , ("dark_orchid", SVG.dark_orchid) + , ("dark_red", SVG.dark_red) + , ("dark_salmon", SVG.dark_salmon) + , ("dark_sea_green", SVG.dark_sea_green) + , ("dark_slate_blue", SVG.dark_slate_blue) + , ("dark_slate_gray", SVG.dark_slate_gray) + , ("dark_slate_grey", SVG.dark_slate_grey) + , ("dark_turquoise", SVG.dark_turquoise) + , ("dark_violet", SVG.dark_violet) + , ("deep_pink", SVG.deep_pink) + , ("deep_sky_blue", SVG.deep_sky_blue) + , ("dim_gray", SVG.dim_gray) + , ("dim_grey", SVG.dim_grey) + , ("dodger_blue", SVG.dodger_blue) + , ("firebrick", SVG.firebrick) + , ("floral_white", SVG.floral_white) + , ("forest_green", SVG.forest_green) + , ("fuchsia", SVG.fuchsia) + , ("gainsboro", SVG.gainsboro) + , ("ghost_white", SVG.ghost_white) + , ("gold", SVG.gold) + , ("goldenrod", SVG.goldenrod) + , ("gray", SVG.gray) + , ("grey", SVG.grey) + , ("green", SVG.green) + , ("green_yellow", SVG.green_yellow) + , ("honeydew", SVG.honeydew) + , ("hot_pink", SVG.hot_pink) + , ("indian_red", SVG.indian_red) + , ("indigo", SVG.indigo) + , ("ivory", SVG.ivory) + , ("khaki", SVG.khaki) + , ("lavender", SVG.lavender) + , ("lavender_blush", SVG.lavender_blush) + , ("lawn_green", SVG.lawn_green) + , ("lemon_chiffon", SVG.lemon_chiffon) + , ("light_blue", SVG.light_blue) + , ("light_coral", SVG.light_coral) + , ("light_cyan", SVG.light_cyan) + , ("light_goldenrod_yellow", SVG.light_goldenrod_yellow) + , ("light_gray", SVG.light_gray) + , ("light_green", SVG.light_green) + , ("light_grey", SVG.light_grey) + , ("light_pink", SVG.light_pink) + , ("light_salmon", SVG.light_salmon) + , ("light_sea_green", SVG.light_sea_green) + , ("light_sky_blue", SVG.light_sky_blue) + , ("light_slate_gray", SVG.light_slate_gray) + , ("light_slate_grey", SVG.light_slate_grey) + , ("light_steel_blue", SVG.light_steel_blue) + , ("light_yellow", SVG.light_yellow) + , ("lime", SVG.lime) + , ("lime_green", SVG.lime_green) + , ("linen", SVG.linen) + , ("magenta", SVG.magenta) + , ("maroon", SVG.maroon) + , ("medium_aquamarine", SVG.medium_aquamarine) + , ("medium_blue", SVG.medium_blue) + , ("medium_orchid", SVG.medium_orchid) + , ("medium_purple", SVG.medium_purple) + , ("medium_sea_green", SVG.medium_sea_green) + , ("medium_slate_blue", SVG.medium_slate_blue) + , ("medium_spring_green", SVG.medium_spring_green) + , ("medium_turquoise", SVG.medium_turquoise) + , ("medium_violet_red", SVG.medium_violet_red) + , ("midnight_blue", SVG.midnight_blue) + , ("mintcream", SVG.mintcream) + , ("mistyrose", SVG.mistyrose) + , ("moccasin", SVG.moccasin) + , ("navajo_white", SVG.navajo_white) + , ("navy", SVG.navy) + , ("old_lace", SVG.old_lace) + , ("olive", SVG.olive) + , ("olive_drab", SVG.olive_drab) + , ("orange", SVG.orange) + , ("orange_red", SVG.orange_red) + , ("orchid", SVG.orchid) + , ("pale_goldenrod", SVG.pale_goldenrod) + , ("pale_green", SVG.pale_green) + , ("pale_turquoise", SVG.pale_turquoise) + , ("pale_violet_red", SVG.pale_violet_red) + , ("papaya_whip", SVG.papaya_whip) + , ("peach_puff", SVG.peach_puff) + , ("peru", SVG.peru) + , ("pink", SVG.pink) + , ("plum", SVG.plum) + , ("powder_blue", SVG.powder_blue) + , ("purple", SVG.purple) + , ("red", SVG.red) + , ("rosy_brown", SVG.rosy_brown) + , ("royal_blue", SVG.royal_blue) + , ("saddle_brown", SVG.saddle_brown) + , ("salmon", SVG.salmon) + , ("sandy_brown", SVG.sandy_brown) + , ("sea_green", SVG.sea_green) + , ("seashell", SVG.seashell) + , ("sienna", SVG.sienna) + , ("silver", SVG.silver) + , ("sky_blue", SVG.sky_blue) + , ("slate_blue", SVG.slate_blue) + , ("slate_gray", SVG.slate_gray) + , ("slate_grey", SVG.slate_grey) + , ("snow", SVG.snow) + , ("spring_green", SVG.spring_green) + , ("steel_blue", SVG.steel_blue) + , ("tan", SVG.tan) + , ("teal", SVG.teal) + , ("thistle", SVG.thistle) + , ("tomato", SVG.tomato) + , ("turquoise", SVG.turquoise) + , ("violet", SVG.violet) + , ("wheat", SVG.wheat) + , ("white", SVG.white) + , ("whitesmoke", SVG.whitesmoke) + , ("yellow", SVG.yellow) + , ("yellow_green", SVG.yellow_green) + ] + + + +all_x11_colours :: [(String,RGBi)] +all_x11_colours = + [ ("antique_white1", X11.antique_white1) + , ("antique_white2", X11.antique_white2) + , ("antique_white3", X11.antique_white3) + , ("antique_white4", X11.antique_white4) + , ("aquamarine1", X11.aquamarine1) + , ("aquamarine2", X11.aquamarine2) + , ("aquamarine3", X11.aquamarine3) + , ("aquamarine4", X11.aquamarine4) + , ("azure1", X11.azure1) + , ("azure2", X11.azure2) + , ("azure3", X11.azure3) + , ("azure4", X11.azure4) + , ("bisque1", X11.bisque1) + , ("bisque2", X11.bisque2) + , ("bisque3", X11.bisque3) + , ("bisque4", X11.bisque4) + , ("blue1", X11.blue1) + , ("blue2", X11.blue2) + , ("blue3", X11.blue3) + , ("blue4", X11.blue4) + , ("brown1", X11.brown1) + , ("brown2", X11.brown2) + , ("brown3", X11.brown3) + , ("brown4", X11.brown4) + , ("burlywood1", X11.burlywood1) + , ("burlywood2", X11.burlywood2) + , ("burlywood3", X11.burlywood3) + , ("burlywood4", X11.burlywood4) + , ("cadet_blue1", X11.cadet_blue1) + , ("cadet_blue2", X11.cadet_blue2) + , ("cadet_blue3", X11.cadet_blue3) + , ("cadet_blue4", X11.cadet_blue4) + , ("chartreuse1", X11.chartreuse1) + , ("chartreuse2", X11.chartreuse2) + , ("chartreuse3", X11.chartreuse3) + , ("chartreuse4", X11.chartreuse4) + , ("chocolate1", X11.chocolate1) + , ("chocolate2", X11.chocolate2) + , ("chocolate3", X11.chocolate3) + , ("chocolate4", X11.chocolate4) + , ("coral1", X11.coral1) + , ("coral2", X11.coral2) + , ("coral3", X11.coral3) + , ("coral4", X11.coral4) + , ("cornsilk1", X11.cornsilk1) + , ("cornsilk2", X11.cornsilk2) + , ("cornsilk3", X11.cornsilk3) + , ("cornsilk4", X11.cornsilk4) + , ("cyan1", X11.cyan1) + , ("cyan2", X11.cyan2) + , ("cyan3", X11.cyan3) + , ("cyan4", X11.cyan4) + , ("dark_goldenrod1", X11.dark_goldenrod1) + , ("dark_goldenrod2", X11.dark_goldenrod2) + , ("dark_goldenrod3", X11.dark_goldenrod3) + , ("dark_goldenrod4", X11.dark_goldenrod4) + , ("dark_olive_green1", X11.dark_olive_green1) + , ("dark_olive_green2", X11.dark_olive_green2) + , ("dark_olive_green3", X11.dark_olive_green3) + , ("dark_olive_green4", X11.dark_olive_green4) + , ("dark_orange1", X11.dark_orange1) + , ("dark_orange2", X11.dark_orange2) + , ("dark_orange3", X11.dark_orange3) + , ("dark_orange4", X11.dark_orange4) + , ("dark_orchid1", X11.dark_orchid1) + , ("dark_orchid2", X11.dark_orchid2) + , ("dark_orchid3", X11.dark_orchid3) + , ("dark_orchid4", X11.dark_orchid4) + , ("dark_sea_green1", X11.dark_sea_green1) + , ("dark_sea_green2", X11.dark_sea_green2) + , ("dark_sea_green3", X11.dark_sea_green3) + , ("dark_sea_green4", X11.dark_sea_green4) + , ("dark_slate_gray1", X11.dark_slate_gray1) + , ("dark_slate_gray2", X11.dark_slate_gray2) + , ("dark_slate_gray3", X11.dark_slate_gray3) + , ("dark_slate_gray4", X11.dark_slate_gray4) + , ("deep_pink1", X11.deep_pink1) + , ("deep_pink2", X11.deep_pink2) + , ("deep_pink3", X11.deep_pink3) + , ("deep_pink4", X11.deep_pink4) + , ("deep_sky_blue1", X11.deep_sky_blue1) + , ("deep_sky_blue2", X11.deep_sky_blue2) + , ("deep_sky_blue3", X11.deep_sky_blue3) + , ("deep_sky_blue4", X11.deep_sky_blue4) + , ("dodger_blue1", X11.dodger_blue1) + , ("dodger_blue2", X11.dodger_blue2) + , ("dodger_blue3", X11.dodger_blue3) + , ("dodger_blue4", X11.dodger_blue4) + , ("firebrick1", X11.firebrick1) + , ("firebrick2", X11.firebrick2) + , ("firebrick3", X11.firebrick3) + , ("firebrick4", X11.firebrick4) + , ("gold1", X11.gold1) + , ("gold2", X11.gold2) + , ("gold3", X11.gold3) + , ("gold4", X11.gold4) + , ("goldenrod1", X11.goldenrod1) + , ("goldenrod2", X11.goldenrod2) + , ("goldenrod3", X11.goldenrod3) + , ("goldenrod4", X11.goldenrod4) + , ("green1", X11.green1) + , ("green2", X11.green2) + , ("green3", X11.green3) + , ("green4", X11.green4) + , ("honeydew1", X11.honeydew1) + , ("honeydew2", X11.honeydew2) + , ("honeydew3", X11.honeydew3) + , ("honeydew4", X11.honeydew4) + , ("hot_pink1", X11.hot_pink1) + , ("hot_pink2", X11.hot_pink2) + , ("hot_pink3", X11.hot_pink3) + , ("hot_pink4", X11.hot_pink4) + , ("indian_red1", X11.indian_red1) + , ("indian_red2", X11.indian_red2) + , ("indian_red3", X11.indian_red3) + , ("indian_red4", X11.indian_red4) + , ("ivory1", X11.ivory1) + , ("ivory2", X11.ivory2) + , ("ivory3", X11.ivory3) + , ("ivory4", X11.ivory4) + , ("khaki1", X11.khaki1) + , ("khaki2", X11.khaki2) + , ("khaki3", X11.khaki3) + , ("khaki4", X11.khaki4) + , ("lavender_blush1", X11.lavender_blush1) + , ("lavender_blush2", X11.lavender_blush2) + , ("lavender_blush3", X11.lavender_blush3) + , ("lavender_blush4", X11.lavender_blush4) + , ("lemon_chiffon1", X11.lemon_chiffon1) + , ("lemon_chiffon2", X11.lemon_chiffon2) + , ("lemon_chiffon3", X11.lemon_chiffon3) + , ("lemon_chiffon4", X11.lemon_chiffon4) + , ("light_blue1", X11.light_blue1) + , ("light_blue2", X11.light_blue2) + , ("light_blue3", X11.light_blue3) + , ("light_blue4", X11.light_blue4) + , ("light_cyan1", X11.light_cyan1) + , ("light_cyan2", X11.light_cyan2) + , ("light_cyan3", X11.light_cyan3) + , ("light_cyan4", X11.light_cyan4) + , ("light_goldenrod1", X11.light_goldenrod1) + , ("light_goldenrod2", X11.light_goldenrod2) + , ("light_goldenrod3", X11.light_goldenrod3) + , ("light_goldenrod4", X11.light_goldenrod4) + , ("light_pink1", X11.light_pink1) + , ("light_pink2", X11.light_pink2) + , ("light_pink3", X11.light_pink3) + , ("light_pink4", X11.light_pink4) + , ("light_salmon1", X11.light_salmon1) + , ("light_salmon2", X11.light_salmon2) + , ("light_salmon3", X11.light_salmon3) + , ("light_salmon4", X11.light_salmon4) + , ("light_sky_blue1", X11.light_sky_blue1) + , ("light_sky_blue2", X11.light_sky_blue2) + , ("light_sky_blue3", X11.light_sky_blue3) + , ("light_sky_blue4", X11.light_sky_blue4) + , ("light_steel_blue1", X11.light_steel_blue1) + , ("light_steel_blue2", X11.light_steel_blue2) + , ("light_steel_blue3", X11.light_steel_blue3) + , ("light_steel_blue4", X11.light_steel_blue4) + , ("light_yellow1", X11.light_yellow1) + , ("light_yellow2", X11.light_yellow2) + , ("light_yellow3", X11.light_yellow3) + , ("light_yellow4", X11.light_yellow4) + , ("magenta1", X11.magenta1) + , ("magenta2", X11.magenta2) + , ("magenta3", X11.magenta3) + , ("magenta4", X11.magenta4) + , ("maroon1", X11.maroon1) + , ("maroon2", X11.maroon2) + , ("maroon3", X11.maroon3) + , ("maroon4", X11.maroon4) + , ("medium_orchid1", X11.medium_orchid1) + , ("medium_orchid2", X11.medium_orchid2) + , ("medium_orchid3", X11.medium_orchid3) + , ("medium_orchid4", X11.medium_orchid4) + , ("medium_purple1", X11.medium_purple1) + , ("medium_purple2", X11.medium_purple2) + , ("medium_purple3", X11.medium_purple3) + , ("medium_purple4", X11.medium_purple4) + , ("misty_rose1", X11.misty_rose1) + , ("misty_rose2", X11.misty_rose2) + , ("misty_rose3", X11.misty_rose3) + , ("misty_rose4", X11.misty_rose4) + , ("navajo_white1", X11.navajo_white1) + , ("navajo_white2", X11.navajo_white2) + , ("navajo_white3", X11.navajo_white3) + , ("navajo_white4", X11.navajo_white4) + , ("olive_drab1", X11.olive_drab1) + , ("olive_drab2", X11.olive_drab2) + , ("olive_drab3", X11.olive_drab3) + , ("olive_drab4", X11.olive_drab4) + , ("orange1", X11.orange1) + , ("orange2", X11.orange2) + , ("orange3", X11.orange3) + , ("orange4", X11.orange4) + , ("orange_red1", X11.orange_red1) + , ("orange_red2", X11.orange_red2) + , ("orange_red3", X11.orange_red3) + , ("orange_red4", X11.orange_red4) + , ("orchid1", X11.orchid1) + , ("orchid2", X11.orchid2) + , ("orchid3", X11.orchid3) + , ("orchid4", X11.orchid4) + , ("pale_green1", X11.pale_green1) + , ("pale_green2", X11.pale_green2) + , ("pale_green3", X11.pale_green3) + , ("pale_green4", X11.pale_green4) + , ("pale_turquoise1", X11.pale_turquoise1) + , ("pale_turquoise2", X11.pale_turquoise2) + , ("pale_turquoise3", X11.pale_turquoise3) + , ("pale_turquoise4", X11.pale_turquoise4) + , ("pale_violet_red1", X11.pale_violet_red1) + , ("pale_violet_red2", X11.pale_violet_red2) + , ("pale_violet_red3", X11.pale_violet_red3) + , ("pale_Violet_red4", X11.pale_violet_red4) + , ("peach_puff1", X11.peach_puff1) + , ("peach_puff2", X11.peach_puff2) + , ("peach_puff3", X11.peach_puff3) + , ("peach_puff4", X11.peach_puff4) + , ("pink1", X11.pink1) + , ("pink2", X11.pink2) + , ("pink3", X11.pink3) + , ("pink4", X11.pink4) + , ("plum1", X11.plum1) + , ("plum2", X11.plum2) + , ("plum3", X11.plum3) + , ("plum4", X11.plum4) + , ("purple1", X11.purple1) + , ("purple2", X11.purple2) + , ("purple3", X11.purple3) + , ("purple4", X11.purple4) + , ("red1", X11.red1) + , ("red2", X11.red2) + , ("red3", X11.red3) + , ("red4", X11.red4) + , ("rosy_brown1", X11.rosy_brown1) + , ("rosy_brown2", X11.rosy_brown2) + , ("rosy_brown3", X11.rosy_brown3) + , ("rosy_brown4", X11.rosy_brown4) + , ("royal_blue1", X11.royal_blue1) + , ("royal_blue2", X11.royal_blue2) + , ("royal_blue3", X11.royal_blue3) + , ("royal_blue4", X11.royal_blue4) + , ("salmon1", X11.salmon1) + , ("salmon2", X11.salmon2) + , ("salmon3", X11.salmon3) + , ("salmon4", X11.salmon4) + , ("sea_green1", X11.sea_green1) + , ("sea_green2", X11.sea_green2) + , ("sea_green3", X11.sea_green3) + , ("sea_green4", X11.sea_green4) + , ("seashell1", X11.seashell1) + , ("seashell2", X11.seashell2) + , ("seashell3", X11.seashell3) + , ("seashell4", X11.seashell4) + , ("sienna1", X11.sienna1) + , ("sienna2", X11.sienna2) + , ("sienna3", X11.sienna3) + , ("sienna4", X11.sienna4) + , ("sky_blue1", X11.sky_blue1) + , ("sky_blue2", X11.sky_blue2) + , ("sky_blue3", X11.sky_blue3) + , ("sky_blue4", X11.sky_blue4) + , ("slate_blue1", X11.slate_blue1) + , ("slate_blue2", X11.slate_blue2) + , ("slate_blue3", X11.slate_blue3) + , ("slate_blue4", X11.slate_blue4) + , ("slate_gray1", X11.slate_gray1) + , ("slate_gray2", X11.slate_gray2) + , ("slate_gray3", X11.slate_gray3) + , ("slate_gray4", X11.slate_gray4) + , ("snow1", X11.snow1) + , ("snow2", X11.snow2) + , ("snow3", X11.snow3) + , ("snow4", X11.snow4) + , ("spring_green1", X11.spring_green1) + , ("spring_green2", X11.spring_green2) + , ("spring_green3", X11.spring_green3) + , ("spring_green4", X11.spring_green4) + , ("steel_blue1", X11.steel_blue1) + , ("steel_blue2", X11.steel_blue2) + , ("steel_blue3", X11.steel_blue3) + , ("steel_blue4", X11.steel_blue4) + , ("tan1", X11.tan1) + , ("tan2", X11.tan2) + , ("tan3", X11.tan3) + , ("tan4", X11.tan4) + , ("thistle1", X11.thistle1) + , ("thistle2", X11.thistle2) + , ("thistle3", X11.thistle3) + , ("thistle4", X11.thistle4) + , ("tomato1", X11.tomato1) + , ("tomato2", X11.tomato2) + , ("tomato3", X11.tomato3) + , ("tomato4", X11.tomato4) + , ("turquoise1", X11.turquoise1) + , ("turquoise2", X11.turquoise2) + , ("turquoise3", X11.turquoise3) + , ("turquoise4", X11.turquoise4) + , ("violet_red1", X11.violet_red1) + , ("violet_red2", X11.violet_red2) + , ("violet_red3", X11.violet_red3) + , ("violet_red4", X11.violet_red4) + , ("wheat1", X11.wheat1) + , ("wheat2", X11.wheat2) + , ("wheat3", X11.wheat3) + , ("wheat4", X11.wheat4) + , ("yellow1", X11.yellow1) + , ("yellow2", X11.yellow2) + , ("yellow3", X11.yellow3) + , ("yellow4", X11.yellow4) + ] + + + + diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs new file mode 100644 --- /dev/null +++ b/demo/ColourCharts.hs @@ -0,0 +1,57 @@ +{-# OPTIONS -Wall #-} + +module ColourCharts where + +import ColourChartUtils + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + -- + let svg_pic = runCtxPictureU draw_ctx svg + writeEPS "./out/SVGcolours.eps" svg_pic + writeSVG "./out/SVGcolours.svg" svg_pic + -- + let x11_p = runCtxPictureU draw_ctx x11_portrait + writeEPS "./out/X11colours.eps" $ uniformScale 0.75 x11_p + let x11_l = runCtxPictureU draw_ctx x11_landscape + writeSVG "./out/X11colours.svg" x11_l + +draw_ctx :: DrawingContext +draw_ctx = (standardContext 9) + +svg :: CtxPicture Double +svg = makeDrawing 52 all_svg_colours + +x11_landscape :: CtxPicture Double +x11_landscape = makeDrawing 52 all_x11_colours + +x11_portrait :: CtxPicture Double +x11_portrait = makeDrawing 72 all_x11_colours + +makeDrawing :: Int -> [(String,RGBi)] -> DCtxPicture +makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs + +tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () +tableGraphic row_count xs = + zipchainWith (\(name,rgb) -> colourSample name rgb) xs ps + where + ps = tableDown row_count (152,11) pt + pt = displaceV (fromIntegral $ 11 * row_count) zeroPt + + +colourSample :: String -> RGBi -> LocGraphic Double +colourSample name rgb = localize (fillColour rgb) $ + promoteR1 $ \pt -> + oplus (borderedRectangle 15 10 `at` pt) + (textline name `at` displace 20 2 pt) + + diff --git a/demo/Connectors.hs b/demo/Connectors.hs new file mode 100644 --- /dev/null +++ b/demo/Connectors.hs @@ -0,0 +1,72 @@ +{-# OPTIONS -Wall #-} + +module Connectors where + + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths hiding ( length ) + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_ctx conn_pic + writeEPS "./out/connectors01.eps" pic1 + writeSVG "./out/connectors01.svg" pic1 + + + +conn_pic :: CtxPicture Double +conn_pic = drawTracing $ tableGraphic $ conntable + +conntable :: [ConnectorPath Double] +conntable = + [ connLine + , connRightVH + , connRightHV + , connRightVHV 15 + , connRightHVH 15 + , connIsosceles 25 + , connIsosceles (-25) + , connIsosceles2 15 + , connIsosceles2 (-15) + , connLightningBolt 15 + , connLightningBolt (-15) + , connIsoscelesCurve 25 + , connIsoscelesCurve (-25) + , connSquareCurve + , connUSquareCurve + , connTrapezoidCurve 40 0.5 + , connTrapezoidCurve (-40) 0.5 + , connZSquareCurve + , connUZSquareCurve + ] + +tableGraphic :: (Real u, Floating u, FromPtSize u) + => [ConnectorPath u] -> TraceDrawing u () +tableGraphic conns = zipchainWith makeConnDrawing conns ps + where + ps = tableDown 10 (120,52) (displaceV 520 zeroPt) + + + +std_ctx :: DrawingContext +std_ctx = fillColour peru $ standardContext 18 + + + +makeConnDrawing :: (Real u, Floating u, FromPtSize u) + => ConnectorPath u -> LocGraphic u +makeConnDrawing conn = + promoteR1 $ \p0 -> fmap (replaceL uNil) $ + connect (uniformArrow curveTip conn) p0 (mkP1 p0) + where + mkP1 = displace 100 40 + + diff --git a/demo/DotPic.hs b/demo/DotPic.hs new file mode 100644 --- /dev/null +++ b/demo/DotPic.hs @@ -0,0 +1,123 @@ +{-# OPTIONS -Wall #-} + +module DotPic where + + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Dots.AnchorDots +import Wumpus.Drawing.Text.SafeFonts + +import FontLoaderUtils + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import System.Directory + + + +main :: IO () +main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help + createDirectoryIfMissing True "./out/" + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." + + +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic + writeEPS "./out/dot_pic01_gs.eps" pic1 + writeSVG "./out/dot_pic01_gs.svg" pic1 + + + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) dot_pic + writeEPS "./out/dot_pic01_afm.eps" pic1 + writeSVG "./out/dot_pic01_afm.svg" pic1 + + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fillColour peru . fontFace helvetica . metricsContext 24 + + +dot_pic :: CtxPicture Double +dot_pic = drawTracing $ tableGraphic $ + [ dotHLine + , dotVLine + , dotX + , dotPlus + , dotCross + , dotDiamond + , dotDisk + , dotSquare + , dotCircle + , dotPentagon + , dotStar + , dotAsterisk + , dotOPlus + , dotOCross + , dotFOCross + , dotFDiamond + , dotText "%" + , dotTriangle + ] + + +tableGraphic :: (Real u, Floating u, FromPtSize u) + => [DotLocImage u] -> TraceDrawing u () +tableGraphic imgs = zipchainWith makeDotDrawing imgs ps + where + row_count = length imgs + ps = tableDown row_count (1,36) pt + pt = displaceV (fromIntegral $ 36 * row_count) zeroPt + + + +-- This is a bit convoluted - maybe there should be chain-run +-- functions for TraceDrawings as well as LocGraphics? + +makeDotDrawing :: (Real u, Floating u, FromPtSize u) + => DotLocImage u -> LocGraphic u +makeDotDrawing dotF = + promoteR1 $ \pt -> + let all_points = map (pt .+^) displacements + in oconcat (dashline all_points) + (map (\p1 -> ignoreL $ dotF `at` p1) all_points) + where + dashline = \ps -> localize attrUpd (openStroke $ vertexPath ps) + + attrUpd :: DrawingContext -> DrawingContext + attrUpd = dashPattern (evenDashes 1) . strokeColour cadet_blue + + ignoreL = fmap (replaceL uNil) + +displacements :: Num u => [Vec2 u] +displacements = [V2 0 0, V2 64 20, V2 128 0, V2 192 20] + + +-- Should these produce a DashPattern or a StrokeAttr? + +evenDashes :: Int -> DashPattern +evenDashes n = Dash 0 [(n,n)] + +dashOffset :: Int -> DashPattern -> DashPattern +dashOffset _ Solid = Solid +dashOffset n (Dash _ xs) = Dash n xs + diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs new file mode 100644 --- /dev/null +++ b/demo/FeatureModel.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + + + +module FeatureModel where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts + +import Wumpus.Core -- package: wumpus-core + +import FontLoaderUtils + + +import System.Directory + + +main :: IO () +main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help + createDirectoryIfMissing True "./out/" + putStrLn "Note - text centering does not seem to be working well at present..." + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." + +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (base_metrics, msgs) <- loadGSMetrics font_dir ["Courier-Bold"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model + writeEPS "./out/feature_model01.eps" pic1 + writeSVG "./out/feature_model01.svg" pic1 + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Courier-Bold"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) feature_model + writeEPS "./out/feature_model02.eps" pic1 + writeSVG "./out/feature_model02.svg" pic1 + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace courier_bold . metricsContext 18 + + +-- Note - I haven't worked out how to do @alternative@, @or@ and +-- @repetitions@ yet. +-- + +feature_model :: CtxPicture 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 + + +-- Note - ctrCenterLine does not seem to be working well... + +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) `at` pt + drawi_ $ ctrCenterLine ss `at` center a + -- draw $ filledDisk 2 `at` center a + return a + +box :: (Real u, Floating u, FromPtSize u) + => String -> Point2 u -> TraceDrawing u (Box u) +box = makeBox 40 + +widebox :: (Real u, Floating u, FromPtSize u) + => String -> Point2 u -> TraceDrawing u (Box u) +widebox = makeBox 60 + + +connWith :: ( Real u, Floating u, FromPtSize u ) + => Arrowhead u -> Box u -> Box u -> TraceDrawing u (Path u) +connWith arrh b0 b1 = do + lw <- getLineWidth + let p0 = south b0 + let p1 = northwards (realToFrac lw) b1 + drawi $ apply2R2 (rightArrow arrh connLine) 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 new file mode 100644 --- /dev/null +++ b/demo/FontPic.hs @@ -0,0 +1,116 @@ +{-# OPTIONS -Wall #-} + +module FontPic where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours ( steel_blue ) +import Wumpus.Drawing.Colour.X11Colours ( indian_red1 ) +import Wumpus.Drawing.Text.SafeFonts + +import Wumpus.Core -- package: wumpus-core + + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + -- + let courier_pic = runCtxPictureU std_ctx courier_cxpic + writeEPS "./out/font_courier.eps" courier_pic + writeSVG "./out/font_courier.svg" courier_pic + -- + let times_pic = runCtxPictureU std_ctx times_cxpic + writeEPS "./out/font_times.eps" times_pic + writeSVG "./out/font_times.svg" times_pic + -- + let helvetica_pic = runCtxPictureU std_ctx helvetica_cxpic + writeEPS "./out/font_helvetica.eps" helvetica_pic + writeSVG "./out/font_helvetica.svg" helvetica_pic + -- + let symbol_pic = runCtxPictureU std_ctx symbol_cxpic + writeEPS "./out/font_symbol.eps" symbol_pic + writeSVG "./out/font_symbol.svg" symbol_pic + + +fontMsg :: FontFace -> Int -> String +fontMsg ff sz = msgF [] + where + msgF = showString (ps_font_name ff) . showChar ' ' . shows sz . showString "pt" + + +makeLabel :: RGBi -> FontFace -> Int -> DLocGraphic +makeLabel rgb ff sz = localize upd (textline $ fontMsg ff sz) + where + upd = fillColour rgb . fontAttr ff sz + +-- indian_red1 +-- steel_blue + +point_sizes :: [Int] +point_sizes = [10, 12, 18, 24, 36, 48] + +positions :: [Int] +positions = [0, 12, 27, 49, 78, 122] + + +pointChain :: LocChain Double +pointChain = verticals $ map (fromIntegral . (+2)) point_sizes + +fontGraphic :: RGBi -> FontFace -> DPoint2 -> TraceDrawing Double () +fontGraphic rgb ff pt = + let ps = pointChain pt in + zipchainWith (\sz -> makeLabel rgb ff sz) point_sizes ps + + +std_ctx :: DrawingContext +std_ctx = standardContext 10 + + +fontDrawing :: [(RGBi,FontFace)] -> DCtxPicture +fontDrawing xs = drawTracing $ + zipchainWithTD (\(rgb,ff) -> fontGraphic rgb ff) xs ps + where + ps = tableDown 4 (1,180) (P2 0 (4*180)) + + + +-------------------------------------------------------------------------------- +-- Times + +times_cxpic :: CtxPicture Double +times_cxpic = + fontDrawing [ (steel_blue, times_roman) + , (indian_red1, times_italic) + , (steel_blue, times_bold) + , (indian_red1, times_bold_italic) + ] + +helvetica_cxpic :: CtxPicture Double +helvetica_cxpic = + fontDrawing [ (steel_blue, helvetica) + , (indian_red1, helvetica_oblique) + , (steel_blue, helvetica_bold) + , (indian_red1, helvetica_bold_oblique) + ] + + + +-------------------------------------------------------------------------------- + +courier_cxpic :: CtxPicture Double +courier_cxpic = + fontDrawing [ (steel_blue, courier) + , (indian_red1, courier_oblique) + , (steel_blue, courier_bold) + , (indian_red1, courier_bold_oblique) + ] + + +-------------------------------------------------------------------------------- + + +symbol_cxpic :: CtxPicture Double +symbol_cxpic = + 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,195 @@ +{-# OPTIONS -Wall #-} + +-- Note - @main@ is more convoluted than would normally be +-- expected as it supports both sources of glyph metrics - the +-- GhostScript distribution or the Core 14 metrics from Adobe. +-- +-- \"Real\" applications would be expected to choose one source. +-- +-- I-am-not-a-lawyer, but it does look as though the Adobe font +-- metrics are redistributable, the GhostScript metrics are +-- seemingly redistributable under the same terms as the larger +-- GhostScript distribution. +-- + + +module LeftRightText where + + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Text.LRText +import Wumpus.Drawing.Text.SafeFonts + +import FontLoaderUtils + + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + + +main :: IO () +main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help + createDirectoryIfMissing True "./out/" + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." + + +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (gs_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx gs_metrics) text_pic + writeEPS "./out/lr_text01.eps" pic1 + writeSVG "./out/lr_text01.svg" pic1 + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (afm_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica"] + mapM_ putStrLn msgs + let pic2 = runCtxPictureU (makeCtx afm_metrics) text_pic + writeEPS "./out/lr_text02.eps" pic2 + writeSVG "./out/lr_text02.svg" pic2 + + + + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace helvetica . metricsContext 18 + + +text_pic :: CtxPicture Double +text_pic = drawTracing $ do + drawi_ $ (fn left_text) `at` P2 0 400 + drawi_ $ (fn center_text) `at` P2 200 400 + drawi_ $ (fn right_text) `at` P2 400 400 + drawi_ $ (fn blank_text) `at` P2 0 300 + drawi_ $ (fn bl_oneline) `at` P2 200 300 + drawi_ $ (fn cc_oneline) `at` P2 400 300 + drawi_ $ (fn newblr) `at` P2 0 200 + drawi_ $ (fn newblc) `at` P2 200 200 + drawi_ $ (fn newbll) `at` P2 400 200 + drawi_ $ (fn rnewblr) `at` P2 0 100 + drawi_ $ (fn rnewblc) `at` P2 200 100 + drawi_ $ (fn rnewbll) `at` P2 400 100 + drawi_ $ (fn rleft_text) `at` P2 0 (-75) + drawi_ $ (fn rcenter_text) `at` P2 200 (-75) + drawi_ $ (fn rright_text) `at` P2 400 (-75) + + + draw $ redPlus `at` P2 0 400 + draw $ redPlus `at` P2 200 400 + draw $ redPlus `at` P2 400 400 + draw $ redPlus `at` P2 0 300 + draw $ redPlus `at` P2 200 300 + draw $ redPlus `at` P2 400 300 + draw $ redPlus `at` P2 0 200 + draw $ redPlus `at` P2 200 200 + draw $ redPlus `at` P2 400 200 + draw $ redPlus `at` P2 0 100 + draw $ redPlus `at` P2 200 100 + draw $ redPlus `at` P2 400 100 + draw $ redPlus `at` P2 0 (-75) + draw $ redPlus `at` P2 200 (-75) + draw $ redPlus `at` P2 400 (-75) + + where + fn = illustrateBoundedLocGraphic + +redPlus :: (Fractional u, FromPtSize u) => LocGraphic u +redPlus = localize (strokeColour red) markPlus + + +newblc :: BoundedLocGraphic Double +newblc = + localize (strokeColour dark_slate_gray) $ + baseCenterLine "new baseline center" + +newbll :: BoundedLocGraphic Double +newbll = + localize (strokeColour dark_slate_gray) $ + baseLeftLine "new baseline left" + +newblr :: BoundedLocGraphic Double +newblr = + localize (strokeColour dark_slate_gray) $ + baseRightLine "new baseline right" + + +rnewblc :: BoundedLocGraphic Double +rnewblc = + localize (strokeColour dark_slate_gray) $ + rbaseCenterLine "baseline center" `rot` (0.25*pi) + +rnewbll :: BoundedLocGraphic Double +rnewbll = + localize (strokeColour dark_slate_gray) $ + rbaseLeftLine "baseline left" `rot` (0.25*pi) + +rnewblr :: BoundedLocGraphic Double +rnewblr = + localize (strokeColour dark_slate_gray) $ + rbaseRightLine "baseline right" `rot` (0.25 * pi) + + +bl_oneline :: BoundedLocGraphic Double +bl_oneline = + localize (strokeColour dark_slate_gray) $ baseLeftLine "Baseline-left..." + + +cc_oneline :: BoundedLocGraphic Double +cc_oneline = + localize (strokeColour dark_slate_gray) $ ctrCenterLine "Center-center..." + +blank_text :: BoundedLocGraphic Double +blank_text = + localize (strokeColour dark_slate_gray) $ multiAlignCenter "" + + +left_text :: BoundedLocGraphic Double +left_text = + localize (strokeColour dark_slate_gray) $ multiAlignLeft dummy_text + + +right_text :: BoundedLocGraphic Double +right_text = + localize (strokeColour dark_slate_gray) $ multiAlignRight dummy_text + +center_text :: BoundedLocGraphic Double +center_text = + localize (strokeColour dark_slate_gray) $ multiAlignCenter dummy_text + + +rleft_text :: BoundedLocGraphic Double +rleft_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignLeft dummy_text `rot` (0.25*pi) + + +rright_text :: BoundedLocGraphic Double +rright_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignRight dummy_text `rot` (0.25*pi) + +rcenter_text :: BoundedLocGraphic Double +rcenter_text = + localize (strokeColour dark_slate_gray) $ + rmultiAlignCenter dummy_text `rot` (0.25*pi) + + +dummy_text :: String +dummy_text = unlines $ [ "The quick brown" + , "fox jumps over" + , "the lazy dog." + ] diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs new file mode 100644 --- /dev/null +++ b/demo/PetriNet.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-- Acknowledgment - the petri net is taken from Claus Reinke\'s +-- paper /Haskell-Coloured Petri Nets/. + + +module PetriNet where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Afm +import Wumpus.Basic.System.FontLoader.GhostScript +import Wumpus.Drawing.Arrows +import Wumpus.Drawing.Colour.SVGColours +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes +import Wumpus.Drawing.Text.SafeFonts +import Wumpus.Drawing.Text.LRText + +import FontLoaderUtils + +import Wumpus.Core -- package: wumpus-core + + +import System.Directory + + + + +main :: IO () +main = do + (mb_gs, mb_afm) <- processCmdLine default_font_loader_help + createDirectoryIfMissing True "./out/" + maybe gs_failk makeGSPicture $ mb_gs + maybe afm_failk makeAfmPicture $ mb_afm + where + gs_failk = putStrLn "No GhostScript font path supplied..." + afm_failk = putStrLn "No AFM v4.1 font path supplied..." + +makeGSPicture :: FilePath -> IO () +makeGSPicture font_dir = do + putStrLn "Using GhostScript metrics..." + (base_metrics, msgs) <- loadGSMetrics font_dir ["Helvetica", "Helvetica-Bold"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net + writeEPS "./out/petri_net01.eps" pic1 + writeSVG "./out/petri_net01.svg" pic1 + +makeAfmPicture :: FilePath -> IO () +makeAfmPicture font_dir = do + putStrLn "Using AFM 4.1 metrics..." + (base_metrics, msgs) <- loadAfmMetrics font_dir ["Helvetica", "Helvetica-Bold"] + mapM_ putStrLn msgs + let pic1 = runCtxPictureU (makeCtx base_metrics) petri_net + writeEPS "./out/petri_net02.eps" pic1 + writeSVG "./out/petri_net02.svg" pic1 + + +makeCtx :: GlyphMetrics -> DrawingContext +makeCtx = fontFace helvetica . metricsContext 14 + + +petri_net :: DCtxPicture +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 + +transition :: ( Real u, Floating u, FromPtSize 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 + + + + +connector' :: ( TraceM m, DrawingCtxM m, u ~ MonUnit m + , Real u, Floating u, FromPtSize u ) + => Point2 u -> Point2 u -> m () +connector' p0 p1 = + drawi_ $ apply2R2 (rightArrow tri45 connLine) p0 p1 + + +connectorC :: ( Real u, Floating u, FromPtSize u + , DrawingCtxM m, TraceM m, u ~ MonUnit m ) + => u -> Point2 u -> Point2 u -> m () +connectorC v p0 p1 = + drawi_ $ apply2R2 (rightArrow tri45 (connRightVHV v)) p0 p1 + +connectorD :: ( Real u, Floating u, FromPtSize u + , DrawingCtxM m, TraceM m, u ~ MonUnit m ) + => u -> Point2 u -> Point2 u -> m () +connectorD u p0 p1 = + drawi_ $ apply2R2 (rightArrow tri45 (connIsosceles u)) p0 p1 + + +lblParensParens :: Num u => LocGraphic u +lblParensParens = localize (fontFace helvetica) $ textline "(),()" + +lblParensParensParens :: Num u => LocGraphic u +lblParensParensParens = localize (fontFace helvetica) $ textline "(),(),()" + + +lblBold' :: Num u => String -> LocGraphic u +lblBold' ss = localize (fontFace helvetica_bold) $ textline ss + + +lblBold :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u +lblBold ss = localize (fontFace helvetica_bold) $ post $ ctrCenterLine ss + where + post = fmap (replaceL uNil) diff --git a/demo/PictureCompo.hs b/demo/PictureCompo.hs new file mode 100644 --- /dev/null +++ b/demo/PictureCompo.hs @@ -0,0 +1,151 @@ +{-# OPTIONS -Wall #-} + +module PictureCompo where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Colour.SVGColours + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let out1 = runCtxPictureU pic_drawing_ctx pictures + writeEPS "./out/picture_composition.eps" out1 + writeSVG "./out/picture_composition.svg" out1 + + +pic_drawing_ctx :: DrawingContext +pic_drawing_ctx = standardContext 14 + + +pictures :: DCtxPicture +pictures = vsep 12 [ pic1, pic2, pic3, pic4 + , pic5, pic6, pic7, pic8 + , pic9, pic10, pic11, pic12 ] + + +drawBlueBounds :: (Real u, Floating u, FromPtSize u) + => CtxPicture u -> CtxPicture u +drawBlueBounds = mapCtxPicture (illustrateBounds blue) + +pic1 :: DCtxPicture +pic1 = picAnno pic "red `over` green `over` blue" + where + pic :: DCtxPicture + pic = drawBlueBounds $ rect_red `over` rect_green `over` rect_blue + +pic2 :: DCtxPicture +pic2 = picAnno pic "red `under` green `under` blue" + where + pic :: DCtxPicture + pic = drawBlueBounds $ rect_red `under` rect_green `under` rect_blue + + +pic3 :: DCtxPicture +pic3 = picAnno pic "red `centric` green `centric` blue" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + rect_red `centric` rect_green `centric` rect_blue + +-- Note - nextToH only moves pictures in the horizontal. +-- +pic4 :: DCtxPicture +pic4 = picAnno pic "red `nextToH` green `nextToH` blue" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + rect_red `nextToH` rect_green `nextToH` rect_blue + +-- Note - nextToV only moves pictures in the vertical. +-- +pic5 :: DCtxPicture +pic5 = picAnno pic "red `nextToV` green `nextToV` blue" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + rect_red `nextToV` rect_green `nextToV` rect_blue + + +pic6 :: DCtxPicture +pic6 = picAnno pic "zconcat [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + zconcat [rect_red, rect_green, rect_blue] + + +pic7 :: DCtxPicture +pic7 = picAnno pic "hcat [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + hcat [rect_red, rect_green, rect_blue] + +pic8 :: DCtxPicture +pic8 = picAnno pic "vcat [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + vcat [rect_red, rect_green, rect_blue] + +pic9 :: DCtxPicture +pic9 = picAnno pic "hsep 20 [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + hsep 20 [rect_red, rect_green, rect_blue] + +pic10 :: DCtxPicture +pic10 = picAnno pic "vsep 20 [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + vsep 20 [rect_red, rect_green, rect_blue] + + +pic11 :: DCtxPicture +pic11 = picAnno pic "hcatA HTop [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + hcatA HTop [rect_red, rect_green, rect_blue] + + +pic12 :: DCtxPicture +pic12 = picAnno pic "vcatA VCenter [red, green, blue]" + where + pic :: DCtxPicture + pic = drawBlueBounds $ + vcatA VCenter [rect_red, rect_green, rect_blue] + + +-------------------------------------------------------------------------------- + + +picAnno :: DCtxPicture -> String -> DCtxPicture +picAnno pic msg = alignHSep HCenter 30 pic lbl + where + lbl = drawTracing $ draw $ textline msg `at` zeroPt + + +rect_red :: DCtxPicture +rect_red = drawTracing $ + localize (fillColour indian_red) + (draw $ borderedRectangle 30 10 `at` (P2 0 10)) + +rect_green :: DCtxPicture +rect_green = drawTracing $ + localize (fillColour olive_drab) + (draw $ borderedRectangle 15 15 `at` (P2 10 10)) + + +rect_blue :: DCtxPicture +rect_blue = drawTracing $ + localize (fillColour powder_blue) + (draw $ borderedRectangle 20 30 `at` (P2 10 0)) + diff --git a/demo/Symbols.hs b/demo/Symbols.hs new file mode 100644 --- /dev/null +++ b/demo/Symbols.hs @@ -0,0 +1,221 @@ +{-# OPTIONS -Wall #-} + +module Symbols where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Text.SafeFonts + + +import Wumpus.Core -- package: wumpus-core + +import Prelude hiding ( pi, product ) + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_ctx symbols + writeEPS "./out/symbols.eps" pic1 + writeSVG "./out/symbols.svg" pic1 + + +std_ctx :: DrawingContext +std_ctx = fontFace times_roman $ standardContext 12 + + +-- Because the font changes, we draw the all the symbols in one +-- run and all the labels in a second run. This helps Wumpus-Core +-- generate better PostScript as there are less changes to the +-- /graphics state/. +-- +symbols :: DCtxPicture +symbols = drawTracing $ do + localize (fontFace symbol) $ zipchainWith sdraw all_letters ps + zipchainWith ldraw all_letters ps + where + ps = tableDown 30 (100,20) (P2 0 (30*20)) + sdraw (s,_) = textline s + ldraw (_,name) = moveStartPoint (displaceH 16) (textline name) + + +all_letters :: [(String, String)] +all_letters = + [ ("Α", "Alpha") + , ("Β", "Beta") + , ("Χ", "Chi") + , ("Δ", "Delta") + , ("Ε", "Epsilon") + , ("Η", "Eta") + , ("&Euro;", "Euro") + , ("Γ", "Gamma") + , ("&Ifraktur;", "Ifraktur") + , ("Ι", "Iota") + , ("Κ", "Kappa") + , ("Λ", "Lambda") + , ("Μ", "Mu") + , ("Ν", "Nu") + , ("Ω", "Omega") + , ("Ο", "Omicron") + , ("Φ", "Phi") + , ("Π", "Pi") + , ("Ψ", "Psi") + , ("&Rfraktur;", "Rfraktur") + , ("Ρ", "Rho") + , ("Σ", "Sigma") + , ("Τ", "Tau") + , ("Θ", "Theta") + , ("Υ", "Upsilon") + , ("&Upsilon1;", "Upsilon1") + , ("Ξ", "Xi") + , ("Ζ", "Zeta") + , ("ℵ", "aleph") + , ("α", "alpha") + , ("&ersand;", "ampersand") + , ("∠", "angle") + , ("&angleleft;", "angleleft") + , ("&angleright;", "angleright") + , ("&approxequal;", "approxequal") + + -- + , ("&arrowboth;", "arrowboth") + , ("&arrowdblboth;", "arrowdblboth") + , ("&arrowdbldown;", "arrowdbldown") + , ("&arrowdblleft;", "arrowdblleft") + , ("&arrowdblright;", "arrowdblright") + , ("&arrowdblup;", "arrowdblup") + , ("&arrowdown;", "arrowdown") + , ("&arrowleft;", "arrowleft") + , ("&arrowright;", "arrowright") + , ("&arrowup;", "arrowup") + , ("&asteriskmath;", "asteriskmath") + , ("&bar;", "bar") + , ("β", "beta") + , ("&braceleft;", "braceleft") + , ("&braceright;", "braceright") + , ("&bracketleft;", "bracketleft") + , ("&bracketright;", "bracketright") + , ("•", "bullet") + , ("&carriagereturn;", "carriagereturn") + , ("χ", "chi") + + -- + , ("&circlemultiply;", "circlemultiply") + , ("&circleplus;", "circleplus") + , ("&club;", "club") + , (":", "colon") + , (",", "comma") + , ("&congruent;", "congruent") + , ("©rightsans;", "copyrightsans") + , ("©rightserif;", "copyrightserif") + , ("°ree;", "degree") + , ("δ", "delta") + , ("⋄", "diamond") + , ("÷", "divide") + , ("&dotmath;", "dotmath") + , ("&eight;", "eight") + , ("&element;", "element") + , ("&ellipsis;", "ellipsis") + , ("∅", "emptyset") + , ("ε", "epsilon") + , ("&equal;", "equal") + , ("&equivalence;", "equivalence") + , ("η", "eta") + , ("&exclam;", "exclam") + , ("&existential;", "existential") + , ("&five;", "five") + , ("&florin;", "florin") + , ("&four;", "four") + , ("&fraction;", "fraction") + , ("γ", "gamma") + , ("&gradient;", "gradient") + , ("&greater;", "greater") + , ("&greaterequal;", "greaterequal") + , ("&heart;", "heart") + , ("&infinity;", "infinity") + , ("&integral;", "integral") + + -- + , ("&intersection;", "intersection") + , ("ι", "iota") + , ("κ", "kappa") + , ("λ", "lambda") + , ("&less;", "less") + , ("&lessequal;", "lessequal") + , ("&logicaland;", "logicaland") + , ("&logicalnot;", "logicalnot") + , ("&logicalor;", "logicalor") + , ("◊", "lozenge") + , ("−", "minus") + , ("&minute;", "minute") + , ("μ", "mu") + , ("&multiply;", "multiply") + , ("&nine;", "nine") + , ("¬element;", "notelement") + , ("¬equal;", "notequal") + , ("¬subset;", "notsubset") + , ("ν", "nu") + , ("&numbersign;", "numbersign") + , ("ω", "omega") + , ("&omega1;", "omega1") + , ("ο", "omicron") + , ("&one;", "one") + , ("&parenleft;", "parenleft") + , ("&parenright;", "parenright") + + -- + , ("&partialdiff;", "partialdiff") + , ("&percent;", "percent") + , (".", "period") + , ("&perpendicular;", "perpendicular") + , ("φ", "phi") + , ("&phi1;", "phi1") + , ("π", "pi") + , ("+", "plus") + , ("&plusminus;", "plusminus") + , ("&product;", "product") + , ("&propersubset;", "propersubset") + , ("&propersuperset;", "propersuperset") + , ("&proportional;", "proportional") + , ("ψ", "psi") + , ("&question;", "question") + , ("&radical;", "radical") + , ("&radicalex;", "radicalex") + , ("&reflexsubset;", "reflexsubset") + , ("&reflexsuperset;", "reflexsuperset") + , ("®istersans;", "registersans") + , ("®isterserif;", "registerserif") + , ("ρ", "rho") + + -- + , ("&second;", "second") + , ("&semicolon;", "semicolon") + , ("&seven;", "seven") + , ("σ", "sigma") + , ("&sigma1;", "sigma1") + , ("&similar;", "similar") + , ("&six;", "six") + , ("&slash;", "slash") + , ("&space;", "space") + , ("&spade;", "spade") + , ("&suchthat;", "suchthat") + , ("&summation;", "summation") + , ("τ", "tau") + , ("∴", "therefore") + , ("θ", "theta") + , ("&theta1;", "theta1") + , ("&three;", "three") + , ("&trademarksans;", "trademarksans") + , ("&trademarkserif;", "trademarkserif") + , ("&two;", "two") + , ("&underscore;", "underscore") + , ("&union;", "union") + , ("&universal;", "universal") + , ("υ", "upsilon") + , ("&weierstrass;", "weierstrass") + , ("ξ", "xi") + , ("&zero;", "zero") + , ("ζ", "zeta") + ] + diff --git a/demo/TableChains.hs b/demo/TableChains.hs new file mode 100644 --- /dev/null +++ b/demo/TableChains.hs @@ -0,0 +1,44 @@ +{-# OPTIONS -Wall #-} + +module TableChains where + + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Chains +import Wumpus.Drawing.Colour.SVGColours + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_ctx table_drawing + writeEPS "./out/table_chains01.eps" pic1 + writeSVG "./out/table_chains01.svg" pic1 + +table_drawing :: CtxPicture Double +table_drawing = drawTracing $ tableGraphic + + +tableGraphic :: (Real u, Floating u, FromPtSize u) + => TraceDrawing u () +tableGraphic = do + draw $ filledDisk 3 `at` dstart + draw $ filledDisk 3 `at` rstart + zipchainWith (textline . show) [1..20::Int] downs + zipchainWith (textline . show) [1..20::Int] rights + where + downs = tableDown 4 (36,24) dstart + rights = tableRight 5 (36,24) rstart + + dstart = P2 0 480 + rstart = P2 240 480 + + +std_ctx :: DrawingContext +std_ctx = fillColour peru $ standardContext 18 + + diff --git a/src/Wumpus/Drawing/Arrows.hs b/src/Wumpus/Drawing/Arrows.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows.hs @@ -0,0 +1,28 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim module for arrow connectors and arrowheads. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows + ( + + module Wumpus.Drawing.Arrows.Tips + , module Wumpus.Drawing.Arrows.Connectors + + ) where + +import Wumpus.Drawing.Arrows.Tips +import Wumpus.Drawing.Arrows.Connectors + + diff --git a/src/Wumpus/Drawing/Arrows/Connectors.hs b/src/Wumpus/Drawing/Arrows/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows/Connectors.hs @@ -0,0 +1,104 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows.Connectors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Draw arrows. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows.Connectors + ( + + ArrowConnector + , leftArrow + , rightArrow + , leftRightArrow + , uniformArrow + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Arrows.Tips +import Wumpus.Drawing.Paths + + + +-- An arrowhead always know how to draw itself (filled triangle, +-- stroked barb, etc.) +-- +-- A Path is currently always drawn with openStroke, +-- eventually there might be scope for drawing +-- e.g. parallel lines ==== +-- + + +-- | A connector with arrow tips. The connector is an /Image/, +-- drawing it returns the path - positions can be taken on the +-- path (e.g. @midpoint@) for further decoration. +-- +type ArrowConnector u = ConnectorImage u (Path u) + + +-- | Connector with an arrow tip at the start point \/ left. +-- +leftArrow :: (Real u, Floating u) + => Arrowhead u -> ConnectorPath u -> ArrowConnector u +leftArrow arrh conn = promoteR2 $ \p0 p1 -> + connect conn p0 p1 >>= \cpath -> + arrowhead_retract_dist arrh >>= \dl -> + let path1 = shortenL dl cpath + ang = directionL path1 + g1 = openStroke $ toPrimPath path1 + g2 = atRot (arrowhead_draw arrh) p0 ang + in fmap (replaceL cpath) $ g1 `oplus` g2 + +-- Note - returns original path + + +-- | Connector with an arrow tip at the end point \/ right. +-- +rightArrow :: (Real u, Floating u) + => Arrowhead u -> ConnectorPath u -> ArrowConnector u +rightArrow arrh conn = promoteR2 $ \p0 p1 -> + connect conn p0 p1 >>= \cpath -> + arrowhead_retract_dist arrh >>= \dr -> + let path1 = shortenR dr cpath + ang = directionR path1 + g1 = openStroke $ toPrimPath path1 + g2 = atRot (arrowhead_draw arrh) p1 ang + in fmap (replaceL cpath) $ g1 `oplus` g2 + + + +-- | Connector with two arrow tips, possibly different. +-- +leftRightArrow :: (Real u, Floating u) + => Arrowhead u -> Arrowhead u -> ConnectorPath u + -> ArrowConnector u +leftRightArrow arrL arrR conn = promoteR2 $ \p0 p1 -> + connect conn p0 p1 >>= \cpath -> + arrowhead_retract_dist arrL >>= \dL -> + arrowhead_retract_dist arrR >>= \dR -> + let path1 = shortenPath dL dR cpath + angL = directionL path1 + angR = directionR path1 + g1 = openStroke $ toPrimPath path1 + gL = atRot (arrowhead_draw arrL) p0 angL + gR = atRot (arrowhead_draw arrR) p1 angR + in fmap (replaceL cpath) $ g1 `oplus` gL `oplus` gR + + +-- | Connector with the same arrow tip at both ends. +-- +uniformArrow :: (Real u, Floating u) + => Arrowhead u -> ConnectorPath u -> ArrowConnector u +uniformArrow arrh cp = leftRightArrow arrh arrh cp + diff --git a/src/Wumpus/Drawing/Arrows/Tips.hs b/src/Wumpus/Drawing/Arrows/Tips.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Arrows/Tips.hs @@ -0,0 +1,515 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Arrows.Tips +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Anchor points on shapes. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Arrows.Tips + ( + + + Arrowhead(..) + + + , tri90 + , tri60 + , tri45 + , otri90 + , otri60 + , otri45 + + , revtri90 + , revtri60 + , revtri45 + , orevtri90 + , orevtri60 + , orevtri45 + + , barb90 + , barb60 + , barb45 + , revbarb90 + , revbarb60 + , revbarb45 + + , perp + + , bracket + + , diskTip + , odiskTip + , squareTip + , osquareTip + , diamondTip + , odiamondTip + + , curveTip + , revcurveTip + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Paths + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + + +-- | Encode an arrowhead as a Graphic and a retract distance - +-- lines should be shortened for certain drawings (e.g. open +-- triangles). +-- +-- The retract distance is context sensitive - usually just on +-- the markHeight (or halfMarkHeight) so it has to be calculated +-- w.r.t. the DrawingCtx. +-- +data Arrowhead u = Arrowhead + { arrowhead_retract_dist :: DrawingInfo u + , arrowhead_draw :: LocThetaGraphic u + } + + +-- Design note - this used to be a newtype wrapper over a +-- LocThetaImage that returned retract distance. But, considering +-- the dataflow / evaluation, in some respects Arrowhead is not an +-- ideal LocThetaImage as we want the retract distance to work out +-- how to draw the image. +-- +-- Images do not inherently encode objects that should be drawn +-- and evaluated at the same time (and lazy eval permits this) but +-- it seems to helpful to think that Images should be evaluated as +-- they are drawn. +-- + + +-- | Tiplen is length of the tip \*along the line it follows\*. +-- +-- > |\ +-- > | \ +-- > | / +-- > |/ +-- > +-- > | | -- tip len +-- + +-- | Tip width is the distance between upper and lower +-- arrow points. +-- +-- > __ +-- > |\ +-- > | \ tip +-- > | / width +-- > |/ __ +-- > + + + +-- | This one is for triangular tips defined by their tip angle +-- e.g. 90deg, 60deg, 45deg. +-- +-- The tip width will be variable (tip length should be the +-- markHeight). +-- +triVecsByAngle :: Floating u => u -> Radian -> Radian -> (Vec2 u, Vec2 u) +triVecsByAngle tiplen halfang theta = (vec_to_upper, vec_to_lower) + where + hypo_len = tiplen / (fromRadian $ cos halfang) + rtheta = pi + theta -- theta in the opposite direction + vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len + vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len + + + +-- | This one is for triangles when the tip height and tip width +-- are known. +-- +triVecsByDist :: (Real u, Floating u) + => u -> u -> Radian -> (Vec2 u, Vec2 u) +triVecsByDist tiplen half_tipwidth theta = (vec_to_upper, vec_to_lower) + where + hypo_len = sqrt $ (tiplen*tiplen) + (half_tipwidth*half_tipwidth) + halfang = toRadian $ atan (half_tipwidth / tiplen) + rtheta = pi + theta -- theta in the opposite direction + vec_to_upper = avec (circularModulo $ rtheta - halfang) hypo_len + vec_to_lower = avec (circularModulo $ rtheta + halfang) hypo_len + + + + +{- +markHeightPlusLineWidth :: (Fractional u, FromPtSize u) => DrawingR u +markHeightPlusLineWidth = + (\h lw -> h + realToFrac lw) <$> markHeight <*> lineWidth +-} + + +markHeightLessLineWidth :: (Fractional u, FromPtSize u) => CF u +markHeightLessLineWidth = + (\h lw -> h - realToFrac lw) <$> markHeight <*> getLineWidth + + +-- noRetract ignores both the angle and the point. +-- +-- Its common for the rectraction not to care about the angle or +-- the point and only care about the DrawingCtx. +-- +noRetract :: Num u => DrawingInfo u +noRetract = pure 0 + + +-- | Arrow tips are drawn with a sloid line even if the connector +-- line is dashed (tips also override round corners) + +solidArrTip :: DrawingCtxM m => m a -> m a +solidArrTip mf = localize (dashPattern Solid . roundCornerFactor 0) mf + + +solidOpenStroke :: Num u => PrimPath u -> Graphic u +solidOpenStroke = solidArrTip . openStroke + +solidClosedStroke :: Num u => PrimPath u -> Graphic u +solidClosedStroke = solidArrTip . closedStroke + +solidStrokedDisk :: Num u => u -> LocGraphic u +solidStrokedDisk = solidArrTip . strokedDisk + +-------------------------------------------------------------------------------- + +tipBody :: FromPtSize u => (Point2 u -> Radian -> u -> CF a) -> LocThetaCF u a +tipBody mf = promoteR2 $ \pt theta -> markHeight >>= \h -> mf pt theta h + +-- | Tripoints takes the \*tip length\* is the mark height. +-- +-- This means that the 90deg tip has a tip width greater-than the +-- mark height (but that is okay - seemingly this is how TikZ +-- does it). +-- +tripointsByAngle :: (Floating u, FromPtSize u) + => Radian -> LocThetaCF u (Point2 u, Point2 u) +tripointsByAngle triang = + tipBody $ \pt theta h -> + let (vup,vlo) = triVecsByAngle h (0.5*triang) theta + in pure (pt .+^ vup, pt .+^ vlo) + + +revtripointsByAngle :: (Floating u, FromPtSize u) + => Radian + -> LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByAngle triang = + tipBody $ \pt theta h -> + let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByAngle h (0.5*triang) theta' + back_tip = pt .-^ avec theta h + in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + + + +tripointsByDist :: (Real u, Floating u, FromPtSize u) + => LocThetaCF u (Point2 u, Point2 u) +tripointsByDist = + tipBody $ \pt theta h -> + let (vup,vlo) = triVecsByDist h (0.5*h) theta + in pure (pt .+^ vup, pt .+^ vlo) + + + +revtripointsByDist :: (Real u, Floating u, FromPtSize u) + => LocThetaCF u (Point2 u, Point2 u, Point2 u) +revtripointsByDist = + tipBody $ \pt theta h -> + let theta' = circularModulo $ pi+theta + (vup,vlo) = triVecsByDist h (0.5*h) theta' + back_tip = pt .-^ avec theta h + in pure (back_tip .+^ vup, back_tip, back_tip .+^ vlo) + + + + + +-- width = xchar_height +-- filled with stroke colour! + +triTLG :: (Floating u, Real u, FromPtSize u) + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +triTLG triang drawF = + promoteR2 $ \pt theta -> + localize bothStrokeColour $ + apply2R2 (tripointsByAngle triang) pt theta >>= \(u,v) -> + drawF $ vertexPath [pt,u,v] + + + +tri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri90 = Arrowhead markHeight (triTLG (pi/2) filledPath) + + +tri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri60 = Arrowhead markHeight (triTLG (pi/3) filledPath) + + +tri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +tri45 = Arrowhead markHeight (triTLG (pi/4) filledPath) + +otri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri90 = Arrowhead markHeight (triTLG (pi/2) solidClosedStroke) + +otri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri60 = Arrowhead markHeight (triTLG (pi/3) solidClosedStroke) + +otri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +otri45 = Arrowhead markHeight (triTLG (pi/4) solidClosedStroke) + + +-- width = xchar_height +-- filled with stroke colour! + +revtriTLG :: (Floating u, Real u, FromPtSize u) + => Radian -> (PrimPath u -> Graphic u) -> LocThetaGraphic u +revtriTLG triang drawF = + promoteR2 $ \pt theta -> + localize bothStrokeColour $ + apply2R2 (revtripointsByAngle triang) pt theta >>= \(u,pt',v) -> + drawF $ vertexPath [u,pt',v] + + + +revtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri90 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/2) filledPath) + +revtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri60 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/3) filledPath) + +revtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revtri45 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/4) filledPath) + + +orevtri90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri90 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/2) solidClosedStroke) + +orevtri60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri60 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/3) solidClosedStroke) + +orevtri45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +orevtri45 = Arrowhead markHeightLessLineWidth + (revtriTLG (pi/4) solidClosedStroke) + + + +barbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +barbTLG ang = + promoteR2 $ \pt theta -> + apply2R2 (tripointsByAngle ang) pt theta >>= \(u,v) -> + solidOpenStroke $ vertexPath [u,pt,v] + + + +barb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb90 = Arrowhead noRetract (barbTLG (pi/2)) + +barb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb60 = Arrowhead noRetract (barbTLG (pi/3)) + + +barb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +barb45 = Arrowhead noRetract (barbTLG (pi/4)) + + + +revbarbTLG :: (Floating u, Real u, FromPtSize u) => Radian -> LocThetaGraphic u +revbarbTLG ang = + promoteR2 $ \pt theta -> + apply2R2 (revtripointsByAngle ang) pt theta >>= \(u,pt',v) -> + solidOpenStroke $ vertexPath [u,pt',v] + +revbarb90 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb90 = Arrowhead markHeight (revbarbTLG (pi/2)) + + +revbarb60 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb60 = Arrowhead markHeight (revbarbTLG (pi/3)) + +revbarb45 :: (Floating u, Real u, FromPtSize u) => Arrowhead u +revbarb45 = Arrowhead markHeight (revbarbTLG (pi/4)) + + +perpTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +perpTLG = + tipBody $ \pt theta h -> + let hh = 0.5*h in solidOpenStroke $ rperpPath hh pt theta + + +rperpPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +rperpPath hh ctr theta = primPath p0 [lineTo p1] + where + p0 = displacePerpendicular hh theta ctr + p1 = displacePerpendicular (-hh) theta ctr + + + +perp :: (Floating u, FromPtSize u) => Arrowhead u +perp = Arrowhead noRetract perpTLG + + + +bracketTLG :: (Floating u, FromPtSize u) => LocThetaGraphic u +bracketTLG = + tipBody $ \pt theta h -> + let hh = 0.5*h in solidOpenStroke $ rbracketPath hh pt theta + + +rbracketPath :: Floating u => u -> Point2 u -> Radian -> PrimPath u +rbracketPath hh pt theta = vertexPath [p0,p1,p2,p3] + where + p1 = displacePerpendicular hh theta pt + p0 = displaceParallel (-hh) theta p1 + p2 = displacePerpendicular (-hh) theta pt + p3 = displaceParallel (-hh) theta p2 + + + + +bracket :: (Floating u, FromPtSize u) => Arrowhead u +bracket = Arrowhead noRetract bracketTLG + + +diskTLG :: (Floating u, FromPtSize u) + => (u -> Point2 u -> Graphic u) -> LocThetaGraphic u +diskTLG drawF = + tipBody $ \pt theta h -> let hh = 0.5*h + ctr = pt .-^ avec theta hh + in drawF hh ctr + + +diskTip :: (Floating u, FromPtSize u) => Arrowhead u +diskTip = Arrowhead markHeight (diskTLG drawF) + where + drawF r pt = localize bothStrokeColour $ filledDisk r `at` pt + + +odiskTip :: (Floating u, FromPtSize u) => Arrowhead u +odiskTip = Arrowhead markHeight (diskTLG drawF) + where + drawF r pt = solidStrokedDisk r `at` pt + + +squareTLG :: (Floating u, FromPtSize u) + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +squareTLG drawF = + tipBody $ \pt theta h -> drawF $ rsquarePath pt theta (0.5*h) + + +rsquarePath :: Floating u => Point2 u -> Radian -> u -> PrimPath u +rsquarePath pt theta hh = vertexPath [p0,p1,p2,p3] + where + p0 = displacePerpendicular hh theta pt + p3 = displacePerpendicular (-hh) theta pt + p1 = displaceParallel (-2*hh) theta p0 + p2 = displaceParallel (-2*hh) theta p3 + + +squareTip :: (Floating u, FromPtSize u) => Arrowhead u +squareTip = Arrowhead markHeight (squareTLG drawF) + where + drawF = localize bothStrokeColour . filledPath + + +osquareTip :: (Floating u, FromPtSize u) => Arrowhead u +osquareTip = Arrowhead markHeight (squareTLG solidClosedStroke) + + +diamondTLG :: (Floating u, FromPtSize u) + => (PrimPath u -> Graphic u) -> LocThetaGraphic u +diamondTLG drawF = + tipBody $ \pt theta h -> drawF $ rdiamondPath pt theta (0.5*h) + + +rdiamondPath :: Floating u => Point2 u -> Radian -> u -> PrimPath u +rdiamondPath pt theta hh = vertexPath [pt,p1,p2,p3] + where + ctr = displaceParallel (-2*hh) theta pt + p1 = displacePerpendicular hh theta ctr + p3 = displacePerpendicular (-hh) theta ctr + p2 = displaceParallel (-4*hh) theta pt + + + +diamondTip :: (Floating u, FromPtSize u) => Arrowhead u +diamondTip = Arrowhead (fmap (2*) markHeightLessLineWidth) + (diamondTLG drawF) + where + drawF = localize bothStrokeColour . filledPath + + +odiamondTip :: (Floating u, FromPtSize u) => Arrowhead u +odiamondTip = Arrowhead (fmap (2*) markHeight) (diamondTLG solidClosedStroke) + + + + +-- Note - points flipped to get the second trapezium to +-- draw /underneath/. +-- +curveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +curveTLG = + tipBody $ \pt theta h -> + cxCurvePath pt theta (0.5*h) >>= \path -> + localize (joinRound . capRound) (solidOpenStroke path) + + +cxCurvePath :: (Real u, Floating u, FromPtSize u) + => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) +cxCurvePath pt theta hh = + apply2R2 tripointsByDist pt theta >>= \(tup,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 pt tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo pt + in pure $ toPrimPath $ curve tup u2 u1 pt `append` curve pt l1 l2 tlo + + + + +curveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u +curveTip = Arrowhead (fmap realToFrac getLineWidth) curveTLG + + +-- Note - points flipped to get the second trapezium to +-- draw /underneath/. +-- +revcurveTLG :: (Real u, Floating u, FromPtSize u) => LocThetaGraphic u +revcurveTLG = + tipBody $ \pt theta h -> + cxRevcurvePath pt theta (0.5*h) >>= \path -> + localize (joinRound . capRound) (solidOpenStroke path) + +cxRevcurvePath :: (Real u, Floating u, FromPtSize u) + => Point2 u -> Radian -> u -> DrawingInfo (PrimPath u) +cxRevcurvePath pt theta hh = + apply2R2 revtripointsByDist pt theta >>= \(tup,p1,tlo) -> + let (u1,u2) = trapezoidFromBasePoints (0.25*hh) 0.5 p1 tup + (l2,l1) = trapezoidFromBasePoints (0.25*hh) 0.5 tlo p1 + in pure $ toPrimPath $ curve tup u2 u1 p1 `append` curve p1 l1 l2 tlo + + +revcurveTip :: (Real u, Floating u, FromPtSize u) => Arrowhead u +revcurveTip = Arrowhead markHeight revcurveTLG + diff --git a/src/Wumpus/Drawing/Chains.hs b/src/Wumpus/Drawing/Chains.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Shim module. +-- +-- WARNING - very unstable. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains + ( + module Wumpus.Drawing.Chains.Base + , module Wumpus.Drawing.Chains.Derived + + + ) where + + +import Wumpus.Drawing.Chains.Base +import Wumpus.Drawing.Chains.Derived diff --git a/src/Wumpus/Drawing/Chains/Base.hs b/src/Wumpus/Drawing/Chains/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains/Base.hs @@ -0,0 +1,117 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains.Base +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Generate points in an iterated chain. +-- +-- \*\* WARNING \*\* - unstable. Names are not so good, also +-- Wumpus-Basic has a @chain1@ operator... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains.Base + ( + + Chain + , LocChain + , unchain + , zipchain + , zipchainWith + + , unchainTD + , zipchainTD + , zipchainWithTD + + + + ) where + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + + +-- | A 'Chain' is a list of points. The list is often expected to +-- be inifinte, but if it was a Stream it would loose the ability +-- to use list comprehensions. +-- +type Chain u = [Point2 u] + + +-- | A LocChain is a function from a starting point to a 'Chain'. +-- +type LocChain u = Point2 u -> Chain u + + +-- | Note - commonly a 'Chain' may be infinite, so it is only +-- unrolled a finite number of times. +-- +unchain :: Int -> LocGraphic u -> Chain u -> TraceDrawing u () +unchain i op chn = go i chn + where + go n _ | n <= 0 = return () + go _ [] = return () + go n (x:xs) = draw (op `at` x) >> go (n-1) xs + + + + + + +zipchain :: [LocGraphic u] -> Chain u -> TraceDrawing u () +zipchain (g:gs) (p:ps) = draw (g `at` p) >> zipchain gs ps +zipchain _ _ = return () + + +zipchainWith :: (a -> LocGraphic u) -> [a] -> Chain u -> TraceDrawing u () +zipchainWith op xs chn = go xs chn + where + go (a:as) (p:ps) = draw (op a `at` p) >> go as ps + go _ _ = return () + + + +-- | Variant of 'unchain' where the drawing argument is a +-- @TraceDrawing@ not a @LocGraphic@. +-- +unchainTD :: Int -> (Point2 u -> TraceDrawing u ()) -> Chain u -> TraceDrawing u () +unchainTD i op chn = go i chn + where + go n _ | n <= 0 = return () + go _ [] = return () + go n (x:xs) = (op x) >> go (n-1) xs + + +zipchainTD :: [Point2 u -> TraceDrawing u ()] -> Chain u -> TraceDrawing u () +zipchainTD (g:gs) (p:ps) = g p >> zipchainTD gs ps +zipchainTD _ _ = return () + + + +zipchainWithTD :: (a -> Point2 u -> TraceDrawing u ()) -> [a] -> Chain u -> TraceDrawing u () +zipchainWithTD op xs chn = go xs chn + where + go (a:as) (p:ps) = op a p >> go as ps + go _ _ = return () + + + +-- Notes - something like TikZ\'s chains could possibly be +-- achieved with a Reader monad (@local@ initially seems better +-- for \"state change\" than @set@ as local models a stack). +-- +-- It\'s almost tempting to put point-supply directly in the +-- Trace monad so that TikZ style chaining is transparent. +-- (The argument against is: how compatible this would be with +-- the Turtle monad for example?). +-- + diff --git a/src/Wumpus/Drawing/Chains/Derived.hs b/src/Wumpus/Drawing/Chains/Derived.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Chains/Derived.hs @@ -0,0 +1,126 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Chains.Derived +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Generate points in an iterated chain. +-- +-- WARNING - very unstable. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Chains.Derived + ( + + tableDown + , tableRight + + , horizontal + , vertical + + , horizontals + , verticals + + ) where + +import Wumpus.Drawing.Chains.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +-------------------------------------------------------------------------------- +-- Tables + +-- Note - for the minor runtime cost, pairing the row_width and +-- row_height should make the API more /memorable/... + + +-- | 'tableDown' : @ num_rows * (row_width, row_height) -> LocChain @ +-- +-- The table grows down and right, the implicit initial point is +-- @top-left@. +-- +tableDown :: Num u => Int -> (u,u) -> LocChain u +tableDown n (rw,rh) pt = map fn ints + where + ints = iterate (+1) 0 + fn i = let (x,y) = i `divMod` n + in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt + + +-- | 'tableRight' : @ num_cols * row_width * row_height -> LocChain @ +-- +-- The table grows right and down, the implicit initial point is +-- @top-left@. +-- +-- This chain is infinite. +-- +tableRight :: Num u => Int -> (u,u) -> LocChain u +tableRight n (rw,rh) pt = map fn ints + where + ints = iterate (+1) 0 + fn i = let (y,x) = i `divMod` n + in displace (rw * fromIntegral x) (rh * fromIntegral (-y)) pt + + + + + +-- | 'horizontal' : @ horizontal_dist -> LocChain @ +-- +-- The chain grows right by the supplied increment. +-- +-- This chain is infinite. +-- +-- \*\* WARNING \*\* - name due to be changed. Current name is +-- too general for this function. +-- +horizontal :: Num u => u -> LocChain u +horizontal dx = iterate (displaceH dx) + + +-- | 'vertical' : @ vertical_dist -> LocChain @ +-- +-- The chain grows up by the supplied increment. +-- +-- This chain is infinite. +-- +-- \*\* WARNING \*\* - name due to be changed. Current name is +-- too general for this function. +-- +vertical :: Num u => u -> LocChain u +vertical dy = iterate (displaceV dy) + + +-- | 'horizontals' : @ [horizontal_dist] -> LocChain @ +-- +-- This is a @scanl@ successive displacing the start point. +-- +-- This chain is finite (for finite input list). +-- +-- \*\* WARNING \*\* - name due to be changed. Current name is +-- too general for this function. +-- +horizontals :: Num u => [u] -> LocChain u +horizontals xs = \pt -> scanl (flip displaceH) pt xs + + +-- | 'verticals' : @ [vertical_dist] -> LocChain @ +-- +-- This is a @scanl@ successive displacing the start point. +-- +-- This chain is finite (for finite input list). +-- +-- \*\* WARNING \*\* - name due to be changed. Current name is +-- too general for this function. +-- +verticals :: Num u => [u] -> LocChain u +verticals ys = \pt -> scanl (flip displaceV) pt ys + + diff --git a/src/Wumpus/Drawing/Colour/SVGColours.hs b/src/Wumpus/Drawing/Colour/SVGColours.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Colour/SVGColours.hs @@ -0,0 +1,625 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Colour.SVGColours +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : unstable +-- Portability : GHC +-- +-- The SVG \'named colours\', as rgb [0,1] values +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Colour.SVGColours + ( + + -- * Named colours + alice_blue + , antique_white + , aqua + , aquamarine + , azure + , beige + , bisque + , black + , blanched_almond + , blue + , blue_violet + , brown + , burlywood + , cadet_blue + , chartreuse + , chocolate + , coral + , cornflower_blue + , cornsilk + , crimson + , cyan + , dark_blue + , dark_cyan + , dark_goldenrod + , dark_gray + , dark_green + , dark_grey + , dark_khaki + , dark_magenta + , dark_olive_green + , dark_orange + , dark_orchid + , dark_red + , dark_salmon + , dark_sea_green + , dark_slate_blue + , dark_slate_gray + , dark_slate_grey + , dark_turquoise + , dark_violet + , deep_pink + , deep_sky_blue + , dim_gray + , dim_grey + , dodger_blue + , firebrick + , floral_white + , forest_green + , fuchsia + , gainsboro + , ghost_white + , gold + , goldenrod + , gray + , grey + , green + , green_yellow + , honeydew + , hot_pink + , indian_red + , indigo + , ivory + , khaki + , lavender + , lavender_blush + , lawn_green + , lemon_chiffon + , light_blue + , light_coral + , light_cyan + , light_goldenrod_yellow + , light_gray + , light_green + , light_grey + , light_pink + , light_salmon + , light_sea_green + , light_sky_blue + , light_slate_gray + , light_slate_grey + , light_steel_blue + , light_yellow + , lime + , lime_green + , linen + , magenta + , maroon + , medium_aquamarine + , medium_blue + , medium_orchid + , medium_purple + , medium_sea_green + , medium_slate_blue + , medium_spring_green + , medium_turquoise + , medium_violet_red + , midnight_blue + , mintcream + , mistyrose + , moccasin + , navajo_white + , navy + , old_lace + , olive + , olive_drab + , orange + , orange_red + , orchid + , pale_goldenrod + , pale_green + , pale_turquoise + , pale_violet_red + , papaya_whip + , peach_puff + , peru + , pink + , plum + , powder_blue + , purple + , red + , rosy_brown + , royal_blue + , saddle_brown + , salmon + , sandy_brown + , sea_green + , seashell + , sienna + , silver + , sky_blue + , slate_blue + , slate_gray + , slate_grey + , snow + , spring_green + , steel_blue + , tan + , teal + , thistle + , tomato + , turquoise + , violet + , wheat + , white + , whitesmoke + , yellow + , yellow_green + + ) where + + +import Wumpus.Core.Colour ( RGBi(..) ) + + +import Prelude ( ) + + + +-------------------------------------------------------------------------------- + +alice_blue :: RGBi +alice_blue = RGBi 0xf0 0xf8 0xff + +antique_white :: RGBi +antique_white = RGBi 0xfa 0xeb 0xd7 + +aqua :: RGBi +aqua = RGBi 0x00 0xff 0xff + +aquamarine :: RGBi +aquamarine = RGBi 0x7f 0xff 0xd4 + +azure :: RGBi +azure = RGBi 0xf0 0xff 0xff + +beige :: RGBi +beige = RGBi 0xf5 0xf5 0xdc + +bisque :: RGBi +bisque = RGBi 0xff 0xe4 0xc4 + +black :: RGBi +black = RGBi 0x00 0x00 0x00 + +blanched_almond :: RGBi +blanched_almond = RGBi 0xff 0xeb 0xcd + +blue :: RGBi +blue = RGBi 0x00 0x00 0xff + +blue_violet :: RGBi +blue_violet = RGBi 0x8a 0x2b 0xe2 + +brown :: RGBi +brown = RGBi 0xa5 0x2a 0x2a + +burlywood :: RGBi +burlywood = RGBi 0xde 0xb8 0x87 + +cadet_blue :: RGBi +cadet_blue = RGBi 0x5f 0x9e 0xa0 + +chartreuse :: RGBi +chartreuse = RGBi 0x7f 0xff 0x00 + +chocolate :: RGBi +chocolate = RGBi 0xd2 0x69 0x1e + +coral :: RGBi +coral = RGBi 0xff 0x7f 0x50 + +cornflower_blue :: RGBi +cornflower_blue = RGBi 0x64 0x95 0xed + +cornsilk :: RGBi +cornsilk = RGBi 0xff 0xf8 0xdc + +crimson :: RGBi +crimson = RGBi 0xdc 0x14 0x3c + +cyan :: RGBi +cyan = RGBi 0x00 0xff 0xff + +dark_blue :: RGBi +dark_blue = RGBi 0x00 0x00 0x8b + +dark_cyan :: RGBi +dark_cyan = RGBi 0x00 0x8b 0x8b + +dark_goldenrod :: RGBi +dark_goldenrod = RGBi 0xb8 0x86 0x0b + +dark_gray :: RGBi +dark_gray = RGBi 0xa9 0xa9 0xa9 + +dark_green :: RGBi +dark_green = RGBi 0x00 0x64 0x00 + +dark_grey :: RGBi +dark_grey = RGBi 0xa9 0xa9 0xa9 + +dark_khaki :: RGBi +dark_khaki = RGBi 0xbd 0xb7 0x6b + +dark_magenta :: RGBi +dark_magenta = RGBi 0x8b 0x00 0x8b + +dark_olive_green :: RGBi +dark_olive_green = RGBi 0x55 0x6b 0x2f + +dark_orange :: RGBi +dark_orange = RGBi 0xff 0x8c 0x00 + +dark_orchid :: RGBi +dark_orchid = RGBi 0x99 0x32 0xcc + +dark_red :: RGBi +dark_red = RGBi 0x8b 0x00 0x00 + +dark_salmon :: RGBi +dark_salmon = RGBi 0xe9 0x96 0x7a + +dark_sea_green :: RGBi +dark_sea_green = RGBi 0x8f 0xbc 0x8f + +dark_slate_blue :: RGBi +dark_slate_blue = RGBi 0x48 0x3d 0x8b + +dark_slate_gray :: RGBi +dark_slate_gray = RGBi 0x2f 0x4f 0x4f + +dark_slate_grey :: RGBi +dark_slate_grey = RGBi 0x2f 0x4f 0x4f + +dark_turquoise :: RGBi +dark_turquoise = RGBi 0x00 0xce 0xd1 + +dark_violet :: RGBi +dark_violet = RGBi 0x94 0x00 0xd3 + +deep_pink :: RGBi +deep_pink = RGBi 0xff 0x14 0x93 + +deep_sky_blue :: RGBi +deep_sky_blue = RGBi 0x00 0xbf 0xff + +dim_gray :: RGBi +dim_gray = RGBi 0x69 0x69 0x69 + +dim_grey :: RGBi +dim_grey = RGBi 0x69 0x69 0x69 + +dodger_blue :: RGBi +dodger_blue = RGBi 0x1e 0x90 0xff + +firebrick :: RGBi +firebrick = RGBi 0xb2 0x22 0x22 + +floral_white :: RGBi +floral_white = RGBi 0xff 0xfa 0xf0 + +forest_green :: RGBi +forest_green = RGBi 0x22 0x8b 0x22 + +fuchsia :: RGBi +fuchsia = RGBi 0xff 0x00 0xff + +gainsboro :: RGBi +gainsboro = RGBi 0xdc 0xdc 0xdc + +ghost_white :: RGBi +ghost_white = RGBi 0xf8 0xf8 0xff + +gold :: RGBi +gold = RGBi 0xff 0xd7 0x00 + +goldenrod :: RGBi +goldenrod = RGBi 0xda 0xa5 0x20 + +gray :: RGBi +gray = RGBi 0x80 0x80 0x80 + +green :: RGBi +green = RGBi 0x00 0x80 0x00 + +green_yellow :: RGBi +green_yellow = RGBi 0xad 0xff 0x2f + +grey :: RGBi +grey = RGBi 0x80 0x80 0x80 + +honeydew :: RGBi +honeydew = RGBi 0xf0 0xff 0xf0 + +hot_pink :: RGBi +hot_pink = RGBi 0xff 0x69 0xb4 + +indian_red :: RGBi +indian_red = RGBi 0xcd 0x5c 0x5c + +indigo :: RGBi +indigo = RGBi 0x4b 0x00 0x82 + +ivory :: RGBi +ivory = RGBi 0xff 0xff 0xf0 + +khaki :: RGBi +khaki = RGBi 0xf0 0xe6 0x8c + +lavender :: RGBi +lavender = RGBi 0xe6 0xe6 0xfa + +lavender_blush :: RGBi +lavender_blush = RGBi 0xff 0xf0 0xf5 + +lawn_green :: RGBi +lawn_green = RGBi 0x7c 0xfc 0x00 + +lemon_chiffon :: RGBi +lemon_chiffon = RGBi 0xff 0xfa 0xcd + +light_blue :: RGBi +light_blue = RGBi 0xad 0xd8 0xe6 + +light_coral :: RGBi +light_coral = RGBi 0xf0 0x80 0x80 + +light_cyan :: RGBi +light_cyan = RGBi 0xe0 0xff 0xff + +light_goldenrod_yellow :: RGBi +light_goldenrod_yellow = RGBi 0xfa 0xfa 0xd2 + +light_gray :: RGBi +light_gray = RGBi 0xd3 0xd3 0xd3 + +light_green :: RGBi +light_green = RGBi 0x90 0xee 0x90 + +light_grey :: RGBi +light_grey = RGBi 0xd3 0xd3 0xd3 + +light_pink :: RGBi +light_pink = RGBi 0xff 0xb6 0xc1 + +light_salmon :: RGBi +light_salmon = RGBi 0xff 0xa0 0x7a + +light_sea_green :: RGBi +light_sea_green = RGBi 0x20 0xb2 0xaa + +light_sky_blue :: RGBi +light_sky_blue = RGBi 0x87 0xce 0xfa + +light_slate_gray :: RGBi +light_slate_gray = RGBi 0x77 0x88 0x99 + +light_slate_grey :: RGBi +light_slate_grey = RGBi 0x77 0x88 0x99 + +light_steel_blue :: RGBi +light_steel_blue = RGBi 0xb0 0xc4 0xde + +light_yellow :: RGBi +light_yellow = RGBi 0xff 0xff 0xe0 + +lime :: RGBi +lime = RGBi 0x00 0xff 0x00 + +lime_green :: RGBi +lime_green = RGBi 0x32 0xcd 0x32 + +linen :: RGBi +linen = RGBi 0xfa 0xf0 0xe6 + +magenta :: RGBi +magenta = RGBi 0xff 0x00 0xff + +maroon :: RGBi +maroon = RGBi 0x80 0x00 0x00 + +medium_aquamarine :: RGBi +medium_aquamarine = RGBi 0x66 0xcd 0xaa + +medium_blue :: RGBi +medium_blue = RGBi 0x00 0x00 0xcd + +medium_orchid :: RGBi +medium_orchid = RGBi 0xba 0x55 0xd3 + +medium_purple :: RGBi +medium_purple = RGBi 0x93 0x70 0xdb + +medium_sea_green :: RGBi +medium_sea_green = RGBi 0x3c 0xb3 0x71 + +medium_slate_blue :: RGBi +medium_slate_blue = RGBi 0x7b 0x68 0xee + +medium_spring_green :: RGBi +medium_spring_green = RGBi 0x00 0xfa 0x9a + +medium_turquoise :: RGBi +medium_turquoise = RGBi 0x48 0xd1 0xcc + +medium_violet_red :: RGBi +medium_violet_red = RGBi 0xc7 0x15 0x85 + +midnight_blue :: RGBi +midnight_blue = RGBi 0x19 0x19 0x70 + +mintcream :: RGBi +mintcream = RGBi 0xf5 0xff 0xfa + +mistyrose :: RGBi +mistyrose = RGBi 0xff 0xe4 0xe1 + +moccasin :: RGBi +moccasin = RGBi 0xff 0xe4 0xb5 + +navajo_white :: RGBi +navajo_white = RGBi 0xff 0xde 0xad + +navy :: RGBi +navy = RGBi 0x00 0x00 0x80 + +old_lace :: RGBi +old_lace = RGBi 0xfd 0xf5 0xe6 + +olive :: RGBi +olive = RGBi 0x80 0x80 0x00 + +olive_drab :: RGBi +olive_drab = RGBi 0x6b 0x8e 0x23 + +orange :: RGBi +orange = RGBi 0xff 0xa5 0x00 + +orange_red :: RGBi +orange_red = RGBi 0xff 0x45 0x00 + +orchid :: RGBi +orchid = RGBi 0xda 0x70 0xd6 + +pale_goldenrod :: RGBi +pale_goldenrod = RGBi 0xee 0xe8 0xaa + +pale_green :: RGBi +pale_green = RGBi 0x98 0xfb 0x98 + +pale_turquoise :: RGBi +pale_turquoise = RGBi 0xaf 0xee 0xee + +pale_violet_red :: RGBi +pale_violet_red = RGBi 0xdb 0x70 0x93 + +papaya_whip :: RGBi +papaya_whip = RGBi 0xff 0xef 0xd5 + +peach_puff :: RGBi +peach_puff = RGBi 0xff 0xda 0xb9 + +peru :: RGBi +peru = RGBi 0xcd 0x85 0x3f + +pink :: RGBi +pink = RGBi 0xff 0xc0 0xcb + +plum :: RGBi +plum = RGBi 0xdd 0xa0 0xdd + +powder_blue :: RGBi +powder_blue = RGBi 0xb0 0xe0 0xe6 + +purple :: RGBi +purple = RGBi 0x80 0x00 0x80 + +red :: RGBi +red = RGBi 0xff 0x00 0x00 + +rosy_brown :: RGBi +rosy_brown = RGBi 0xbc 0x8f 0x8f + +royal_blue :: RGBi +royal_blue = RGBi 0x41 0x69 0xe1 + +saddle_brown :: RGBi +saddle_brown = RGBi 0x8b 0x45 0x13 + +salmon :: RGBi +salmon = RGBi 0xfa 0x80 0x72 + +sandy_brown :: RGBi +sandy_brown = RGBi 0xf4 0xa4 0x60 + +sea_green :: RGBi +sea_green = RGBi 0x2e 0x8b 0x57 + +seashell :: RGBi +seashell = RGBi 0xff 0xf5 0xee + +sienna :: RGBi +sienna = RGBi 0xa0 0x52 0x2d + +silver :: RGBi +silver = RGBi 0xc0 0xc0 0xc0 + +sky_blue :: RGBi +sky_blue = RGBi 0x87 0xce 0xeb + +slate_blue :: RGBi +slate_blue = RGBi 0x6a 0x5a 0xcd + +slate_gray :: RGBi +slate_gray = RGBi 0x70 0x80 0x90 + +slate_grey :: RGBi +slate_grey = RGBi 0x70 0x80 0x90 + +snow :: RGBi +snow = RGBi 0xff 0xfa 0xfa + +spring_green :: RGBi +spring_green = RGBi 0x00 0xff 0x7f + +steel_blue :: RGBi +steel_blue = RGBi 0x46 0x82 0xb4 + +tan :: RGBi +tan = RGBi 0xd2 0xb4 0x8c + +teal :: RGBi +teal = RGBi 0x00 0x80 0x80 + +thistle :: RGBi +thistle = RGBi 0xd8 0xbf 0xd8 + +tomato :: RGBi +tomato = RGBi 0xff 0x63 0x47 + +turquoise :: RGBi +turquoise = RGBi 0x40 0xe0 0xd0 + +violet :: RGBi +violet = RGBi 0xee 0x82 0xee + +wheat :: RGBi +wheat = RGBi 0xf5 0xde 0xb3 + +white :: RGBi +white = RGBi 0xff 0xff 0xff + +whitesmoke :: RGBi +whitesmoke = RGBi 0xf5 0xf5 0xf5 + +yellow :: RGBi +yellow = RGBi 0xff 0xff 0x00 + +yellow_green :: RGBi +yellow_green = RGBi 0x9a 0xcd 0x32 + + + + + diff --git a/src/Wumpus/Drawing/Colour/X11Colours.hs b/src/Wumpus/Drawing/Colour/X11Colours.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Colour/X11Colours.hs @@ -0,0 +1,1282 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Colour.X11Colours +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : unstable +-- Portability : GHC +-- +-- The X11 \'named colours\', as rgb [0,1] values +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Colour.X11Colours + ( + + -- * Named X11 colours + antique_white1 + , antique_white2 + , antique_white3 + , antique_white4 + , aquamarine1 + , aquamarine2 + , aquamarine3 + , aquamarine4 + , azure1 + , azure2 + , azure3 + , azure4 + , bisque1 + , bisque2 + , bisque3 + , bisque4 + , blue1 + , blue2 + , blue3 + , blue4 + , brown1 + , brown2 + , brown3 + , brown4 + , burlywood1 + , burlywood2 + , burlywood3 + , burlywood4 + , cadet_blue1 + , cadet_blue2 + , cadet_blue3 + , cadet_blue4 + , chartreuse1 + , chartreuse2 + , chartreuse3 + , chartreuse4 + , chocolate1 + , chocolate2 + , chocolate3 + , chocolate4 + , coral1 + , coral2 + , coral3 + , coral4 + , cornsilk1 + , cornsilk2 + , cornsilk3 + , cornsilk4 + , cyan1 + , cyan2 + , cyan3 + , cyan4 + , dark_goldenrod1 + , dark_goldenrod2 + , dark_goldenrod3 + , dark_goldenrod4 + , dark_olive_green1 + , dark_olive_green2 + , dark_olive_green3 + , dark_olive_green4 + , dark_orange1 + , dark_orange2 + , dark_orange3 + , dark_orange4 + , dark_orchid1 + , dark_orchid2 + , dark_orchid3 + , dark_orchid4 + , dark_sea_green1 + , dark_sea_green2 + , dark_sea_green3 + , dark_sea_green4 + , dark_slate_gray1 + , dark_slate_gray2 + , dark_slate_gray3 + , dark_slate_gray4 + , deep_pink1 + , deep_pink2 + , deep_pink3 + , deep_pink4 + , deep_sky_blue1 + , deep_sky_blue2 + , deep_sky_blue3 + , deep_sky_blue4 + , dodger_blue1 + , dodger_blue2 + , dodger_blue3 + , dodger_blue4 + , firebrick1 + , firebrick2 + , firebrick3 + , firebrick4 + , gold1 + , gold2 + , gold3 + , gold4 + , goldenrod1 + , goldenrod2 + , goldenrod3 + , goldenrod4 + , green1 + , green2 + , green3 + , green4 + , honeydew1 + , honeydew2 + , honeydew3 + , honeydew4 + , hot_pink1 + , hot_pink2 + , hot_pink3 + , hot_pink4 + , indian_red1 + , indian_red2 + , indian_red3 + , indian_red4 + , ivory1 + , ivory2 + , ivory3 + , ivory4 + , khaki1 + , khaki2 + , khaki3 + , khaki4 + , lavender_blush1 + , lavender_blush2 + , lavender_blush3 + , lavender_blush4 + , lemon_chiffon1 + , lemon_chiffon2 + , lemon_chiffon3 + , lemon_chiffon4 + , light_blue1 + , light_blue2 + , light_blue3 + , light_blue4 + , light_cyan1 + , light_cyan2 + , light_cyan3 + , light_cyan4 + , light_goldenrod1 + , light_goldenrod2 + , light_goldenrod3 + , light_goldenrod4 + , light_pink1 + , light_pink2 + , light_pink3 + , light_pink4 + , light_salmon1 + , light_salmon2 + , light_salmon3 + , light_salmon4 + , light_sky_blue1 + , light_sky_blue2 + , light_sky_blue3 + , light_sky_blue4 + , light_steel_blue1 + , light_steel_blue2 + , light_steel_blue3 + , light_steel_blue4 + , light_yellow1 + , light_yellow2 + , light_yellow3 + , light_yellow4 + , magenta1 + , magenta2 + , magenta3 + , magenta4 + , maroon1 + , maroon2 + , maroon3 + , maroon4 + , medium_orchid1 + , medium_orchid2 + , medium_orchid3 + , medium_orchid4 + , medium_purple1 + , medium_purple2 + , medium_purple3 + , medium_purple4 + , misty_rose1 + , misty_rose2 + , misty_rose3 + , misty_rose4 + , navajo_white1 + , navajo_white2 + , navajo_white3 + , navajo_white4 + , olive_drab1 + , olive_drab2 + , olive_drab3 + , olive_drab4 + , orange1 + , orange2 + , orange3 + , orange4 + , orange_red1 + , orange_red2 + , orange_red3 + , orange_red4 + , orchid1 + , orchid2 + , orchid3 + , orchid4 + , pale_green1 + , pale_green2 + , pale_green3 + , pale_green4 + , pale_turquoise1 + , pale_turquoise2 + , pale_turquoise3 + , pale_turquoise4 + , pale_violet_red1 + , pale_violet_red2 + , pale_violet_red3 + , pale_violet_red4 + , peach_puff1 + , peach_puff2 + , peach_puff3 + , peach_puff4 + , pink1 + , pink2 + , pink3 + , pink4 + , plum1 + , plum2 + , plum3 + , plum4 + , purple1 + , purple2 + , purple3 + , purple4 + , red1 + , red2 + , red3 + , red4 + , rosy_brown1 + , rosy_brown2 + , rosy_brown3 + , rosy_brown4 + , royal_blue1 + , royal_blue2 + , royal_blue3 + , royal_blue4 + , salmon1 + , salmon2 + , salmon3 + , salmon4 + , sea_green1 + , sea_green2 + , sea_green3 + , sea_green4 + , seashell1 + , seashell2 + , seashell3 + , seashell4 + , sienna1 + , sienna2 + , sienna3 + , sienna4 + , sky_blue1 + , sky_blue2 + , sky_blue3 + , sky_blue4 + , slate_blue1 + , slate_blue2 + , slate_blue3 + , slate_blue4 + , slate_gray1 + , slate_gray2 + , slate_gray3 + , slate_gray4 + , snow1 + , snow2 + , snow3 + , snow4 + , spring_green1 + , spring_green2 + , spring_green3 + , spring_green4 + , steel_blue1 + , steel_blue2 + , steel_blue3 + , steel_blue4 + , tan1 + , tan2 + , tan3 + , tan4 + , thistle1 + , thistle2 + , thistle3 + , thistle4 + , tomato1 + , tomato2 + , tomato3 + , tomato4 + , turquoise1 + , turquoise2 + , turquoise3 + , turquoise4 + , violet_red1 + , violet_red2 + , violet_red3 + , violet_red4 + , wheat1 + , wheat2 + , wheat3 + , wheat4 + , yellow1 + , yellow2 + , yellow3 + , yellow4 + + ) where + +import Wumpus.Core.Colour ( RGBi(..) ) + + +-------------------------------------------------------------------------------- + +antique_white1 :: RGBi +antique_white1 = RGBi 0xff 0xef 0xdb + +antique_white2 :: RGBi +antique_white2 = RGBi 0xee 0xdf 0xcc + +antique_white3 :: RGBi +antique_white3 = RGBi 0xcd 0xc0 0xb0 + +antique_white4 :: RGBi +antique_white4 = RGBi 0x8b 0x83 0x78 + +aquamarine1 :: RGBi +aquamarine1 = RGBi 0x7f 0xff 0xd4 + +aquamarine2 :: RGBi +aquamarine2 = RGBi 0x76 0xee 0xc6 + +aquamarine3 :: RGBi +aquamarine3 = RGBi 0x66 0xcd 0xaa + +aquamarine4 :: RGBi +aquamarine4 = RGBi 0x45 0x8b 0x74 + +azure1 :: RGBi +azure1 = RGBi 0xf0 0xff 0xff + +azure2 :: RGBi +azure2 = RGBi 0xe0 0xee 0xee + +azure3 :: RGBi +azure3 = RGBi 0xc1 0xcd 0xcd + +azure4 :: RGBi +azure4 = RGBi 0x83 0x8b 0x8b + +bisque1 :: RGBi +bisque1 = RGBi 0xff 0xe4 0xc4 + +bisque2 :: RGBi +bisque2 = RGBi 0xee 0xd5 0xb7 + +bisque3 :: RGBi +bisque3 = RGBi 0xcd 0xb7 0x9e + +bisque4 :: RGBi +bisque4 = RGBi 0x8b 0x7d 0x6b + +blue1 :: RGBi +blue1 = RGBi 0x00 0x00 0xff + +blue2 :: RGBi +blue2 = RGBi 0x00 0x00 0xee + +blue3 :: RGBi +blue3 = RGBi 0x00 0x00 0xcd + +blue4 :: RGBi +blue4 = RGBi 0x00 0x00 0x8b + +brown1 :: RGBi +brown1 = RGBi 0xff 0x40 0x40 + +brown2 :: RGBi +brown2 = RGBi 0xee 0x3b 0x3b + +brown3 :: RGBi +brown3 = RGBi 0xcd 0x33 0x33 + +brown4 :: RGBi +brown4 = RGBi 0x8b 0x23 0x23 + +burlywood1 :: RGBi +burlywood1 = RGBi 0xff 0xd3 0x9b + +burlywood2 :: RGBi +burlywood2 = RGBi 0xee 0xc5 0x91 + +burlywood3 :: RGBi +burlywood3 = RGBi 0xcd 0xaa 0x7d + +burlywood4 :: RGBi +burlywood4 = RGBi 0x8b 0x73 0x55 + +cadet_blue1 :: RGBi +cadet_blue1 = RGBi 0x98 0xf5 0xff + +cadet_blue2 :: RGBi +cadet_blue2 = RGBi 0x8e 0xe5 0xee + +cadet_blue3 :: RGBi +cadet_blue3 = RGBi 0x7a 0xc5 0xcd + +cadet_blue4 :: RGBi +cadet_blue4 = RGBi 0x53 0x86 0x8b + +chartreuse1 :: RGBi +chartreuse1 = RGBi 0x7f 0xff 0x00 + +chartreuse2 :: RGBi +chartreuse2 = RGBi 0x76 0xee 0x00 + +chartreuse3 :: RGBi +chartreuse3 = RGBi 0x66 0xcd 0x00 + +chartreuse4 :: RGBi +chartreuse4 = RGBi 0x45 0x8b 0x00 + +chocolate1 :: RGBi +chocolate1 = RGBi 0xff 0x7f 0x24 + +chocolate2 :: RGBi +chocolate2 = RGBi 0xee 0x76 0x21 + +chocolate3 :: RGBi +chocolate3 = RGBi 0xcd 0x66 0x1d + +chocolate4 :: RGBi +chocolate4 = RGBi 0x8b 0x45 0x13 + +coral1 :: RGBi +coral1 = RGBi 0xff 0x72 0x56 + +coral2 :: RGBi +coral2 = RGBi 0xee 0x6a 0x50 + +coral3 :: RGBi +coral3 = RGBi 0xcd 0x5b 0x45 + +coral4 :: RGBi +coral4 = RGBi 0x8b 0x3e 0x2f + +cornsilk1 :: RGBi +cornsilk1 = RGBi 0xff 0xf8 0xdc + +cornsilk2 :: RGBi +cornsilk2 = RGBi 0xee 0xe8 0xcd + +cornsilk3 :: RGBi +cornsilk3 = RGBi 0xcd 0xc8 0xb1 + +cornsilk4 :: RGBi +cornsilk4 = RGBi 0x8b 0x88 0x78 + +cyan1 :: RGBi +cyan1 = RGBi 0x00 0xff 0xff + +cyan2 :: RGBi +cyan2 = RGBi 0x00 0xee 0xee + +cyan3 :: RGBi +cyan3 = RGBi 0x00 0xcd 0xcd + +cyan4 :: RGBi +cyan4 = RGBi 0x00 0x8b 0x8b + +dark_goldenrod1 :: RGBi +dark_goldenrod1 = RGBi 0xff 0xb9 0x0f + +dark_goldenrod2 :: RGBi +dark_goldenrod2 = RGBi 0xee 0xad 0x0e + +dark_goldenrod3 :: RGBi +dark_goldenrod3 = RGBi 0xcd 0x95 0x0c + +dark_goldenrod4 :: RGBi +dark_goldenrod4 = RGBi 0x8b 0x65 0x08 + +dark_olive_green1 :: RGBi +dark_olive_green1 = RGBi 0xca 0xff 0x70 + +dark_olive_green2 :: RGBi +dark_olive_green2 = RGBi 0xbc 0xee 0x68 + +dark_olive_green3 :: RGBi +dark_olive_green3 = RGBi 0xa2 0xcd 0x5a + +dark_olive_green4 :: RGBi +dark_olive_green4 = RGBi 0x6e 0x8b 0x3d + +dark_orange1 :: RGBi +dark_orange1 = RGBi 0xff 0x7f 0x00 + +dark_orange2 :: RGBi +dark_orange2 = RGBi 0xee 0x76 0x00 + +dark_orange3 :: RGBi +dark_orange3 = RGBi 0xcd 0x66 0x00 + +dark_orange4 :: RGBi +dark_orange4 = RGBi 0x8b 0x45 0x00 + +dark_orchid1 :: RGBi +dark_orchid1 = RGBi 0xbf 0x3e 0xff + +dark_orchid2 :: RGBi +dark_orchid2 = RGBi 0xb2 0x3a 0xee + +dark_orchid3 :: RGBi +dark_orchid3 = RGBi 0x9a 0x32 0xcd + +dark_orchid4 :: RGBi +dark_orchid4 = RGBi 0x68 0x22 0x8b + +dark_sea_green1 :: RGBi +dark_sea_green1 = RGBi 0xc1 0xff 0xc1 + +dark_sea_green2 :: RGBi +dark_sea_green2 = RGBi 0xb4 0xee 0xb4 + +dark_sea_green3 :: RGBi +dark_sea_green3 = RGBi 0x9b 0xcd 0x9b + +dark_sea_green4 :: RGBi +dark_sea_green4 = RGBi 0x69 0x8b 0x69 + +dark_slate_gray1 :: RGBi +dark_slate_gray1 = RGBi 0x97 0xff 0xff + +dark_slate_gray2 :: RGBi +dark_slate_gray2 = RGBi 0x8d 0xee 0xee + +dark_slate_gray3 :: RGBi +dark_slate_gray3 = RGBi 0x79 0xcd 0xcd + +dark_slate_gray4 :: RGBi +dark_slate_gray4 = RGBi 0x52 0x8b 0x8b + +deep_pink1 :: RGBi +deep_pink1 = RGBi 0xff 0x14 0x93 + +deep_pink2 :: RGBi +deep_pink2 = RGBi 0xee 0x12 0x89 + +deep_pink3 :: RGBi +deep_pink3 = RGBi 0xcd 0x10 0x76 + +deep_pink4 :: RGBi +deep_pink4 = RGBi 0x8b 0x0a 0x50 + +deep_sky_blue1 :: RGBi +deep_sky_blue1 = RGBi 0x00 0xbf 0xff + +deep_sky_blue2 :: RGBi +deep_sky_blue2 = RGBi 0x00 0xb2 0xee + +deep_sky_blue3 :: RGBi +deep_sky_blue3 = RGBi 0x00 0x9a 0xcd + +deep_sky_blue4 :: RGBi +deep_sky_blue4 = RGBi 0x00 0x68 0x8b + +dodger_blue1 :: RGBi +dodger_blue1 = RGBi 0x1e 0x90 0xff + +dodger_blue2 :: RGBi +dodger_blue2 = RGBi 0x1c 0x86 0xee + +dodger_blue3 :: RGBi +dodger_blue3 = RGBi 0x18 0x74 0xcd + +dodger_blue4 :: RGBi +dodger_blue4 = RGBi 0x10 0x4e 0x8b + +firebrick1 :: RGBi +firebrick1 = RGBi 0xff 0x30 0x30 + +firebrick2 :: RGBi +firebrick2 = RGBi 0xee 0x2c 0x2c + +firebrick3 :: RGBi +firebrick3 = RGBi 0xcd 0x26 0x26 + +firebrick4 :: RGBi +firebrick4 = RGBi 0x8b 0x1a 0x1a + +gold1 :: RGBi +gold1 = RGBi 0xff 0xd7 0x00 + +gold2 :: RGBi +gold2 = RGBi 0xee 0xc9 0x00 + +gold3 :: RGBi +gold3 = RGBi 0xcd 0xad 0x00 + +gold4 :: RGBi +gold4 = RGBi 0x8b 0x75 0x00 + +goldenrod1 :: RGBi +goldenrod1 = RGBi 0xff 0xc1 0x25 + +goldenrod2 :: RGBi +goldenrod2 = RGBi 0xee 0xb4 0x22 + +goldenrod3 :: RGBi +goldenrod3 = RGBi 0xcd 0x9b 0x1d + +goldenrod4 :: RGBi +goldenrod4 = RGBi 0x8b 0x69 0x14 + +green1 :: RGBi +green1 = RGBi 0x00 0xff 0x00 + +green2 :: RGBi +green2 = RGBi 0x00 0xee 0x00 + +green3 :: RGBi +green3 = RGBi 0x00 0xcd 0x00 + +green4 :: RGBi +green4 = RGBi 0x00 0x8b 0x00 + +honeydew1 :: RGBi +honeydew1 = RGBi 0xf0 0xff 0xf0 + +honeydew2 :: RGBi +honeydew2 = RGBi 0xe0 0xee 0xe0 + +honeydew3 :: RGBi +honeydew3 = RGBi 0xc1 0xcd 0xc1 + +honeydew4 :: RGBi +honeydew4 = RGBi 0x83 0x8b 0x83 + +hot_pink1 :: RGBi +hot_pink1 = RGBi 0xff 0x6e 0xb4 + +hot_pink2 :: RGBi +hot_pink2 = RGBi 0xee 0x6a 0xa7 + +hot_pink3 :: RGBi +hot_pink3 = RGBi 0xcd 0x60 0x90 + +hot_pink4 :: RGBi +hot_pink4 = RGBi 0x8b 0x3a 0x62 + +indian_red1 :: RGBi +indian_red1 = RGBi 0xff 0x6a 0x6a + +indian_red2 :: RGBi +indian_red2 = RGBi 0xee 0x63 0x63 + +indian_red3 :: RGBi +indian_red3 = RGBi 0xcd 0x55 0x55 + +indian_red4 :: RGBi +indian_red4 = RGBi 0x8b 0x3a 0x3a + +ivory1 :: RGBi +ivory1 = RGBi 0xff 0xff 0xf0 + +ivory2 :: RGBi +ivory2 = RGBi 0xee 0xee 0xe0 + +ivory3 :: RGBi +ivory3 = RGBi 0xcd 0xcd 0xc1 + +ivory4 :: RGBi +ivory4 = RGBi 0x8b 0x8b 0x83 + +khaki1 :: RGBi +khaki1 = RGBi 0xff 0xf6 0x8f + +khaki2 :: RGBi +khaki2 = RGBi 0xee 0xe6 0x85 + +khaki3 :: RGBi +khaki3 = RGBi 0xcd 0xc6 0x73 + +khaki4 :: RGBi +khaki4 = RGBi 0x8b 0x86 0x4e + +lavender_blush1 :: RGBi +lavender_blush1 = RGBi 0xff 0xf0 0xf5 + +lavender_blush2 :: RGBi +lavender_blush2 = RGBi 0xee 0xe0 0xe5 + +lavender_blush3 :: RGBi +lavender_blush3 = RGBi 0xcd 0xc1 0xc5 + +lavender_blush4 :: RGBi +lavender_blush4 = RGBi 0x8b 0x83 0x86 + +lemon_chiffon1 :: RGBi +lemon_chiffon1 = RGBi 0xff 0xfa 0xcd + +lemon_chiffon2 :: RGBi +lemon_chiffon2 = RGBi 0xee 0xe9 0xbf + +lemon_chiffon3 :: RGBi +lemon_chiffon3 = RGBi 0xcd 0xc9 0xa5 + +lemon_chiffon4 :: RGBi +lemon_chiffon4 = RGBi 0x8b 0x89 0x70 + +light_blue1 :: RGBi +light_blue1 = RGBi 0xbf 0xef 0xff + +light_blue2 :: RGBi +light_blue2 = RGBi 0xb2 0xdf 0xee + +light_blue3 :: RGBi +light_blue3 = RGBi 0x9a 0xc0 0xcd + +light_blue4 :: RGBi +light_blue4 = RGBi 0x68 0x83 0x8b + +light_cyan1 :: RGBi +light_cyan1 = RGBi 0xe0 0xff 0xff + +light_cyan2 :: RGBi +light_cyan2 = RGBi 0xd1 0xee 0xee + +light_cyan3 :: RGBi +light_cyan3 = RGBi 0xb4 0xcd 0xcd + +light_cyan4 :: RGBi +light_cyan4 = RGBi 0x7a 0x8b 0x8b + +light_goldenrod1 :: RGBi +light_goldenrod1 = RGBi 0xff 0xec 0x8b + +light_goldenrod2 :: RGBi +light_goldenrod2 = RGBi 0xee 0xdc 0x82 + +light_goldenrod3 :: RGBi +light_goldenrod3 = RGBi 0xcd 0xbe 0x70 + +light_goldenrod4 :: RGBi +light_goldenrod4 = RGBi 0x8b 0x81 0x4c + +light_pink1 :: RGBi +light_pink1 = RGBi 0xff 0xae 0xb9 + +light_pink2 :: RGBi +light_pink2 = RGBi 0xee 0xa2 0xad + +light_pink3 :: RGBi +light_pink3 = RGBi 0xcd 0x8c 0x95 + +light_pink4 :: RGBi +light_pink4 = RGBi 0x8b 0x5f 0x65 + +light_salmon1 :: RGBi +light_salmon1 = RGBi 0xff 0xa0 0x7a + +light_salmon2 :: RGBi +light_salmon2 = RGBi 0xee 0x95 0x72 + +light_salmon3 :: RGBi +light_salmon3 = RGBi 0xcd 0x81 0x62 + +light_salmon4 :: RGBi +light_salmon4 = RGBi 0x8b 0x57 0x42 + +light_sky_blue1 :: RGBi +light_sky_blue1 = RGBi 0xb0 0xe2 0xff + +light_sky_blue2 :: RGBi +light_sky_blue2 = RGBi 0xa4 0xd3 0xee + +light_sky_blue3 :: RGBi +light_sky_blue3 = RGBi 0x8d 0xb6 0xcd + +light_sky_blue4 :: RGBi +light_sky_blue4 = RGBi 0x60 0x7b 0x8b + +light_steel_blue1 :: RGBi +light_steel_blue1 = RGBi 0xca 0xe1 0xff + +light_steel_blue2 :: RGBi +light_steel_blue2 = RGBi 0xbc 0xd2 0xee + +light_steel_blue3 :: RGBi +light_steel_blue3 = RGBi 0xa2 0xb5 0xcd + +light_steel_blue4 :: RGBi +light_steel_blue4 = RGBi 0x6e 0x7b 0x8b + +light_yellow1 :: RGBi +light_yellow1 = RGBi 0xff 0xff 0xe0 + +light_yellow2 :: RGBi +light_yellow2 = RGBi 0xee 0xee 0xd1 + +light_yellow3 :: RGBi +light_yellow3 = RGBi 0xcd 0xcd 0xb4 + +light_yellow4 :: RGBi +light_yellow4 = RGBi 0x8b 0x8b 0x7a + +magenta1 :: RGBi +magenta1 = RGBi 0xff 0x00 0xff + +magenta2 :: RGBi +magenta2 = RGBi 0xee 0x00 0xee + +magenta3 :: RGBi +magenta3 = RGBi 0xcd 0x00 0xcd + +magenta4 :: RGBi +magenta4 = RGBi 0x8b 0x00 0x8b + +maroon1 :: RGBi +maroon1 = RGBi 0xff 0x34 0xb3 + +maroon2 :: RGBi +maroon2 = RGBi 0xee 0x30 0xa7 + +maroon3 :: RGBi +maroon3 = RGBi 0xcd 0x29 0x90 + +maroon4 :: RGBi +maroon4 = RGBi 0x8b 0x1c 0x62 + +medium_orchid1 :: RGBi +medium_orchid1 = RGBi 0xe0 0x66 0xff + +medium_orchid2 :: RGBi +medium_orchid2 = RGBi 0xd1 0x5f 0xee + +medium_orchid3 :: RGBi +medium_orchid3 = RGBi 0xb4 0x52 0xcd + +medium_orchid4 :: RGBi +medium_orchid4 = RGBi 0x7a 0x37 0x8b + +medium_purple1 :: RGBi +medium_purple1 = RGBi 0xab 0x82 0xff + +medium_purple2 :: RGBi +medium_purple2 = RGBi 0x9f 0x79 0xee + +medium_purple3 :: RGBi +medium_purple3 = RGBi 0x89 0x68 0xcd + +medium_purple4 :: RGBi +medium_purple4 = RGBi 0x5d 0x47 0x8b + +misty_rose1 :: RGBi +misty_rose1 = RGBi 0xff 0xe4 0xe1 + +misty_rose2 :: RGBi +misty_rose2 = RGBi 0xee 0xd5 0xd2 + +misty_rose3 :: RGBi +misty_rose3 = RGBi 0xcd 0xb7 0xb5 + +misty_rose4 :: RGBi +misty_rose4 = RGBi 0x8b 0x7d 0x7b + +navajo_white1 :: RGBi +navajo_white1 = RGBi 0xff 0xde 0xad + +navajo_white2 :: RGBi +navajo_white2 = RGBi 0xee 0xcf 0xa1 + +navajo_white3 :: RGBi +navajo_white3 = RGBi 0xcd 0xb3 0x8b + +navajo_white4 :: RGBi +navajo_white4 = RGBi 0x8b 0x79 0x5e + +olive_drab1 :: RGBi +olive_drab1 = RGBi 0xc0 0xff 0x3e + +olive_drab2 :: RGBi +olive_drab2 = RGBi 0xb3 0xee 0x3a + +olive_drab3 :: RGBi +olive_drab3 = RGBi 0x9a 0xcd 0x32 + +olive_drab4 :: RGBi +olive_drab4 = RGBi 0x69 0x8b 0x22 + +orange1 :: RGBi +orange1 = RGBi 0xff 0xa5 0x00 + +orange2 :: RGBi +orange2 = RGBi 0xee 0x9a 0x00 + +orange3 :: RGBi +orange3 = RGBi 0xcd 0x85 0x00 + +orange4 :: RGBi +orange4 = RGBi 0x8b 0x5a 0x00 + +orange_red1 :: RGBi +orange_red1 = RGBi 0xff 0x45 0x00 + +orange_red2 :: RGBi +orange_red2 = RGBi 0xee 0x40 0x00 + +orange_red3 :: RGBi +orange_red3 = RGBi 0xcd 0x37 0x00 + +orange_red4 :: RGBi +orange_red4 = RGBi 0x8b 0x25 0x00 + +orchid1 :: RGBi +orchid1 = RGBi 0xff 0x83 0xfa + +orchid2 :: RGBi +orchid2 = RGBi 0xee 0x7a 0xe9 + +orchid3 :: RGBi +orchid3 = RGBi 0xcd 0x69 0xc9 + +orchid4 :: RGBi +orchid4 = RGBi 0x8b 0x47 0x89 + +pale_green1 :: RGBi +pale_green1 = RGBi 0x9a 0xff 0x9a + +pale_green2 :: RGBi +pale_green2 = RGBi 0x90 0xee 0x90 + +pale_green3 :: RGBi +pale_green3 = RGBi 0x7c 0xcd 0x7c + +pale_green4 :: RGBi +pale_green4 = RGBi 0x54 0x8b 0x54 + +pale_turquoise1 :: RGBi +pale_turquoise1 = RGBi 0xbb 0xff 0xff + +pale_turquoise2 :: RGBi +pale_turquoise2 = RGBi 0xae 0xee 0xee + +pale_turquoise3 :: RGBi +pale_turquoise3 = RGBi 0x96 0xcd 0xcd + +pale_turquoise4 :: RGBi +pale_turquoise4 = RGBi 0x66 0x8b 0x8b + +pale_violet_red1 :: RGBi +pale_violet_red1 = RGBi 0xff 0x82 0xab + +pale_violet_red2 :: RGBi +pale_violet_red2 = RGBi 0xee 0x79 0x9f + +pale_violet_red3 :: RGBi +pale_violet_red3 = RGBi 0xcd 0x68 0x89 + +pale_violet_red4 :: RGBi +pale_violet_red4 = RGBi 0x8b 0x47 0x5d + +peach_puff1 :: RGBi +peach_puff1 = RGBi 0xff 0xda 0xb9 + +peach_puff2 :: RGBi +peach_puff2 = RGBi 0xee 0xcb 0xad + +peach_puff3 :: RGBi +peach_puff3 = RGBi 0xcd 0xaf 0x95 + +peach_puff4 :: RGBi +peach_puff4 = RGBi 0x8b 0x77 0x65 + +pink1 :: RGBi +pink1 = RGBi 0xff 0xb5 0xc5 + +pink2 :: RGBi +pink2 = RGBi 0xee 0xa9 0xb8 + +pink3 :: RGBi +pink3 = RGBi 0xcd 0x91 0x9e + +pink4 :: RGBi +pink4 = RGBi 0x8b 0x63 0x6c + +plum1 :: RGBi +plum1 = RGBi 0xff 0xbb 0xff + +plum2 :: RGBi +plum2 = RGBi 0xee 0xae 0xee + +plum3 :: RGBi +plum3 = RGBi 0xcd 0x96 0xcd + +plum4 :: RGBi +plum4 = RGBi 0x8b 0x66 0x8b + +purple1 :: RGBi +purple1 = RGBi 0x9b 0x30 0xff + +purple2 :: RGBi +purple2 = RGBi 0x91 0x2c 0xee + +purple3 :: RGBi +purple3 = RGBi 0x7d 0x26 0xcd + +purple4 :: RGBi +purple4 = RGBi 0x55 0x1a 0x8b + +red1 :: RGBi +red1 = RGBi 0xff 0x00 0x00 + +red2 :: RGBi +red2 = RGBi 0xee 0x00 0x00 + +red3 :: RGBi +red3 = RGBi 0xcd 0x00 0x00 + +red4 :: RGBi +red4 = RGBi 0x8b 0x00 0x00 + +rosy_brown1 :: RGBi +rosy_brown1 = RGBi 0xff 0xc1 0xc1 + +rosy_brown2 :: RGBi +rosy_brown2 = RGBi 0xee 0xb4 0xb4 + +rosy_brown3 :: RGBi +rosy_brown3 = RGBi 0xcd 0x9b 0x9b + +rosy_brown4 :: RGBi +rosy_brown4 = RGBi 0x8b 0x69 0x69 + +royal_blue1 :: RGBi +royal_blue1 = RGBi 0x48 0x76 0xff + +royal_blue2 :: RGBi +royal_blue2 = RGBi 0x43 0x6e 0xee + +royal_blue3 :: RGBi +royal_blue3 = RGBi 0x3a 0x5f 0xcd + +royal_blue4 :: RGBi +royal_blue4 = RGBi 0x27 0x40 0x8b + + +salmon1 :: RGBi +salmon1 = RGBi 0xff 0x8c 0x69 + +salmon2 :: RGBi +salmon2 = RGBi 0xee 0x82 0x62 + +salmon3 :: RGBi +salmon3 = RGBi 0xcd 0x70 0x54 + +salmon4 :: RGBi +salmon4 = RGBi 0x8b 0x4c 0x39 + +sea_green1 :: RGBi +sea_green1 = RGBi 0x54 0xff 0x9f + +sea_green2 :: RGBi +sea_green2 = RGBi 0x4e 0xee 0x94 + +sea_green3 :: RGBi +sea_green3 = RGBi 0x43 0xcd 0x80 + +sea_green4 :: RGBi +sea_green4 = RGBi 0x2e 0x8b 0x57 + +seashell1 :: RGBi +seashell1 = RGBi 0xff 0xf5 0xee + +seashell2 :: RGBi +seashell2 = RGBi 0xee 0xe5 0xde + +seashell3 :: RGBi +seashell3 = RGBi 0xcd 0xc5 0xbf + +seashell4 :: RGBi +seashell4 = RGBi 0x8b 0x86 0x82 + +sienna1 :: RGBi +sienna1 = RGBi 0xff 0x82 0x47 + +sienna2 :: RGBi +sienna2 = RGBi 0xee 0x79 0x42 + +sienna3 :: RGBi +sienna3 = RGBi 0xcd 0x68 0x39 + +sienna4 :: RGBi +sienna4 = RGBi 0x8b 0x47 0x26 + +sky_blue1 :: RGBi +sky_blue1 = RGBi 0x87 0xce 0xff + +sky_blue2 :: RGBi +sky_blue2 = RGBi 0x7e 0xc0 0xee + +sky_blue3 :: RGBi +sky_blue3 = RGBi 0x6c 0xa6 0xcd + +sky_blue4 :: RGBi +sky_blue4 = RGBi 0x4a 0x70 0x8b + +slate_blue1 :: RGBi +slate_blue1 = RGBi 0x83 0x6f 0xff + +slate_blue2 :: RGBi +slate_blue2 = RGBi 0x7a 0x67 0xee + +slate_blue3 :: RGBi +slate_blue3 = RGBi 0x69 0x59 0xcd + +slate_blue4 :: RGBi +slate_blue4 = RGBi 0x47 0x3c 0x8b + +slate_gray1 :: RGBi +slate_gray1 = RGBi 0xc6 0xe2 0xff + +slate_gray2 :: RGBi +slate_gray2 = RGBi 0xb9 0xd3 0xee + +slate_gray3 :: RGBi +slate_gray3 = RGBi 0x9f 0xb6 0xcd + +slate_gray4 :: RGBi +slate_gray4 = RGBi 0x6c 0x7b 0x8b + +snow1 :: RGBi +snow1 = RGBi 0xff 0xfa 0xfa + +snow2 :: RGBi +snow2 = RGBi 0xee 0xe9 0xe9 + +snow3 :: RGBi +snow3 = RGBi 0xcd 0xc9 0xc9 + +snow4 :: RGBi +snow4 = RGBi 0x8b 0x89 0x89 + +spring_green1 :: RGBi +spring_green1 = RGBi 0x00 0xff 0x7f + +spring_green2 :: RGBi +spring_green2 = RGBi 0x00 0xee 0x76 + +spring_green3 :: RGBi +spring_green3 = RGBi 0x00 0xcd 0x66 + +spring_green4 :: RGBi +spring_green4 = RGBi 0x00 0x8b 0x45 + +steel_blue1 :: RGBi +steel_blue1 = RGBi 0x63 0xb8 0xff + +steel_blue2 :: RGBi +steel_blue2 = RGBi 0x5c 0xac 0xee + +steel_blue3 :: RGBi +steel_blue3 = RGBi 0x4f 0x94 0xcd + +steel_blue4 :: RGBi +steel_blue4 = RGBi 0x36 0x64 0x8b + +tan1 :: RGBi +tan1 = RGBi 0xff 0xa5 0x4f + +tan2 :: RGBi +tan2 = RGBi 0xee 0x9a 0x49 + +tan3 :: RGBi +tan3 = RGBi 0xcd 0x85 0x3f + +tan4 :: RGBi +tan4 = RGBi 0x8b 0x5a 0x2b + +thistle1 :: RGBi +thistle1 = RGBi 0xff 0xe1 0xff + +thistle2 :: RGBi +thistle2 = RGBi 0xee 0xd2 0xee + +thistle3 :: RGBi +thistle3 = RGBi 0xcd 0xb5 0xcd + +thistle4 :: RGBi +thistle4 = RGBi 0x8b 0x7b 0x8b + +tomato1 :: RGBi +tomato1 = RGBi 0xff 0x63 0x47 + +tomato2 :: RGBi +tomato2 = RGBi 0xee 0x5c 0x42 + +tomato3 :: RGBi +tomato3 = RGBi 0xcd 0x4f 0x39 + +tomato4 :: RGBi +tomato4 = RGBi 0x8b 0x36 0x26 + +turquoise1 :: RGBi +turquoise1 = RGBi 0x00 0xf5 0xff + +turquoise2 :: RGBi +turquoise2 = RGBi 0x00 0xe5 0xee + +turquoise3 :: RGBi +turquoise3 = RGBi 0x00 0xc5 0xcd + +turquoise4 :: RGBi +turquoise4 = RGBi 0x00 0x86 0x8b + +violet_red1 :: RGBi +violet_red1 = RGBi 0xff 0x3e 0x96 + +violet_red2 :: RGBi +violet_red2 = RGBi 0xee 0x3a 0x8c + +violet_red3 :: RGBi +violet_red3 = RGBi 0xcd 0x32 0x78 + +violet_red4 :: RGBi +violet_red4 = RGBi 0x8b 0x22 0x52 + +wheat1 :: RGBi +wheat1 = RGBi 0xff 0xe7 0xba + +wheat2 :: RGBi +wheat2 = RGBi 0xee 0xd8 0xae + +wheat3 :: RGBi +wheat3 = RGBi 0xcd 0xba 0x96 + +wheat4 :: RGBi +wheat4 = RGBi 0x8b 0x7e 0x66 + +yellow1 :: RGBi +yellow1 = RGBi 0xff 0xff 0x00 + +yellow2 :: RGBi +yellow2 = RGBi 0xee 0xee 0x00 + +yellow3 :: RGBi +yellow3 = RGBi 0xcd 0xcd 0x00 + +yellow4 :: RGBi +yellow4 = RGBi 0x8b 0x8b 0x00 + + + + + + diff --git a/src/Wumpus/Drawing/Dots/AnchorDots.hs b/src/Wumpus/Drawing/Dots/AnchorDots.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Dots/AnchorDots.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Dots.AnchorDots +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Dots with anchors. +-- +-- In many cases a surrounding circle is used to locate anchor +-- points - this could be improved to use the actual dot border +-- at some point. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Dots.AnchorDots + ( + + -- * Existential anchor type + DotAnchor + + , DotLocImage + , DDotLocImage + + -- * Dots with anchor points + , dotChar + , dotText + , dotHLine + , dotVLine + , dotX + , dotPlus + , dotCross + , dotDiamond + , dotFDiamond + + , dotDisk + , dotSquare + , dotCircle + , dotPentagon + , dotStar + + , dotAsterisk + , dotOPlus + , dotOCross + , dotFOCross + + , dotTriangle + + ) where + + +import Wumpus.Drawing.Geometry.Intersection +import Wumpus.Drawing.Geometry.Paths +import Wumpus.Drawing.Dots.Marks +import Wumpus.Drawing.Text.LRText + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +import Control.Applicative + +-- An existential thing that supports anchors. +-- This means any dot can retun the same (opaque) structure +-- +-- But it does mean that which anchor class are supported is +-- fixed - the datatype needs a field for each one. +-- Supporting north, southeast etc. will also be tedious... +-- +data DotAnchor u = forall s. + DotAnchor { center_anchor :: Point2 u + , radial_anchor :: Radian -> Point2 u + , cardinal_anchor :: Cardinal -> Point2 u } + +data Cardinal = NN | NE | EE | SE | SS | SW | WW | NW + deriving (Eq,Show) + +type instance DUnit (DotAnchor u) = u + +instance CenterAnchor (DotAnchor u) where + center (DotAnchor ca _ _) = ca + +instance RadialAnchor (DotAnchor u) where + radialAnchor theta (DotAnchor _ ra _) = ra theta + +instance CardinalAnchor (DotAnchor u) where + north (DotAnchor _ _ c1) = c1 NN + south (DotAnchor _ _ c1) = c1 SS + east (DotAnchor _ _ c1) = c1 EE + west (DotAnchor _ _ c1) = c1 WW + + + +instance CardinalAnchor2 (DotAnchor u) where + northeast (DotAnchor _ _ c1) = c1 NE + southeast (DotAnchor _ _ c1) = c1 SE + southwest (DotAnchor _ _ c1) = c1 SW + northwest (DotAnchor _ _ c1) = c1 NW + + +radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u +radialCardinal rad ctr NN = ctr .+^ (avec (pi/2) rad) +radialCardinal rad ctr NE = ctr .+^ (avec (pi/4) rad) +radialCardinal rad ctr EE = ctr .+^ (avec 0 rad) +radialCardinal rad ctr SE = ctr .+^ (avec (7/4 * pi) rad) +radialCardinal rad ctr SS = ctr .+^ (avec (6/4 * pi) rad) +radialCardinal rad ctr SW = ctr .+^ (avec (5/4 * pi) rad) +radialCardinal rad ctr WW = ctr .+^ (avec pi rad) +radialCardinal rad ctr NW = ctr .+^ (avec (3/4 * pi) rad) + + +-- Rectangle cardinal points are at \"middles and corners\". +-- + +rectCardinal :: Floating u => u -> u -> Point2 u -> Cardinal -> Point2 u +rectCardinal _ hh ctr NN = ctr .+^ (vvec hh) +rectCardinal hw hh ctr NE = ctr .+^ (vec hw hh) +rectCardinal hw _ ctr EE = ctr .+^ (hvec hw) +rectCardinal hw hh ctr SE = ctr .+^ (vec hw (-hh)) +rectCardinal _ hh ctr SS = ctr .+^ (vvec (-hh)) +rectCardinal hw hh ctr SW = ctr .+^ (vec (-hw) (-hh) ) +rectCardinal hw _ ctr WW = ctr .+^ (hvec (-hw)) +rectCardinal hw hh ctr NW = ctr .+^ (vec (-hw) hh) + +polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u +polyCardinal f NN = f (0.5 * pi) +polyCardinal f NE = f (0.25 * pi) +polyCardinal f EE = f 0 +polyCardinal f SE = f (1.75 * pi) +polyCardinal f SS = f (1.5 * pi) +polyCardinal f SW = f (1.25 * pi) +polyCardinal f WW = f pi +polyCardinal f NW = f (0.75 * pi) + + + +rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u +rectangleAnchor hw hh ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = fn + , cardinal_anchor = rectCardinal hw hh ctr } + where + fn theta = maybe ctr id $ findIntersect ctr theta + $ rectangleLines ctr hw hh + + +polygonAnchor :: (Real u, Floating u) => [Point2 u] -> Point2 u -> DotAnchor u +polygonAnchor ps ctr = + DotAnchor { center_anchor = ctr + , radial_anchor = fn + , cardinal_anchor = polyCardinal fn } + where + fn theta = maybe ctr id $ findIntersect ctr theta $ polygonLines ps + + + +bboxRectAnchor :: (Real u, Floating u) => BoundingBox u -> DotAnchor u +bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) = + let hw = 0.5 * (x2 - x1) + hh = 0.5 * (y2 - y1) + in rectangleAnchor hw hh (bl .+^ vec hw hh) + +rectangleLDO :: (Real u, Floating u) + => u -> u -> LocDrawingInfo u (DotAnchor u) +rectangleLDO w h = + promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt + + +circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u +circleAnchor rad ctr = DotAnchor ctr + (\theta -> ctr .+^ (avec theta rad)) + (radialCardinal rad ctr) + +circleLDO :: (Floating u, FromPtSize u) => LocDrawingInfo u (DotAnchor u) +circleLDO = + promoteR1 $ \pt -> + markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt + + +-- This might be better taking a function: ctr -> poly_points +-- ... +-- +polygonLDO :: (Real u, Floating u, FromPtSize u) + => (u -> Point2 u -> [Point2 u]) -> LocDrawingInfo u (DotAnchor u) +polygonLDO mk = + promoteR1 $ \ctr -> + markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr + + +-------------------------------------------------------------------------------- + + +type DotLocImage u = LocImage u (DotAnchor u) + +type DDotLocImage = DotLocImage Double + +dotChar :: (Floating u, Real u, FromPtSize u) => Char -> DotLocImage u +dotChar ch = dotText [ch] + + +-- Note - dotText now uses font metrics, the generated BBox is +-- fine for dots (if they are all the same text) but not good for +-- tree nodes (for example). Wumpus-Tree should really be using a +-- different graphic object for labelled trees. +-- + + +dotText :: (Floating u, Real u, FromPtSize u) => String -> DotLocImage u +dotText ss = fmap (bimapL bboxRectAnchor) (ctrCenterLine ss) + + +dotHLine :: (Floating u, FromPtSize u) => DotLocImage u +dotHLine = intoLocImage circleLDO markHLine + + +dotVLine :: (Floating u, FromPtSize u) => DotLocImage u +dotVLine = intoLocImage circleLDO markVLine + + +dotX :: (Floating u, FromPtSize u) => DotLocImage u +dotX = intoLocImage circleLDO markX + +dotPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotPlus = intoLocImage circleLDO markPlus + +dotCross :: (Floating u, FromPtSize u) => DotLocImage u +dotCross = intoLocImage circleLDO markCross + +dotDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotDiamond = intoLocImage circleLDO markDiamond + +dotFDiamond :: (Floating u, FromPtSize u) => DotLocImage u +dotFDiamond = intoLocImage circleLDO markFDiamond + + + +dotDisk :: (Floating u, FromPtSize u) => DotLocImage u +dotDisk = intoLocImage circleLDO markDisk + + +dotSquare :: (Floating u, Real u, FromPtSize u) => DotLocImage u +dotSquare = + lift0R1 markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare + + + + +dotCircle :: (Floating u, FromPtSize u) => DotLocImage u +dotCircle = intoLocImage circleLDO markCircle + + +dotPentagon :: (Floating u, FromPtSize u) => DotLocImage u +dotPentagon = intoLocImage circleLDO markPentagon + +dotStar :: (Floating u, FromPtSize u) => DotLocImage u +dotStar = intoLocImage circleLDO markStar + + +dotAsterisk :: (Floating u, FromPtSize u) => DotLocImage u +dotAsterisk = intoLocImage circleLDO markAsterisk + +dotOPlus :: (Floating u, FromPtSize u) => DotLocImage u +dotOPlus = intoLocImage circleLDO markOPlus + +dotOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotOCross = intoLocImage circleLDO markOCross + +dotFOCross :: (Floating u, FromPtSize u) => DotLocImage u +dotFOCross = intoLocImage circleLDO markFOCross + + +dotTriangle :: (Real u, Floating u, FromPtSize u) => DotLocImage u +dotTriangle = intoLocImage (polygonLDO fn) markTriangle + where + fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top] diff --git a/src/Wumpus/Drawing/Dots/Marks.hs b/src/Wumpus/Drawing/Dots/Marks.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Dots/Marks.hs @@ -0,0 +1,243 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Dots.Marks +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Marks - dots without anchor handles. +-- +-- The text and char marks need loaded glyph metrics for proper +-- centering. +-- +-- \*\* WARNING \*\* - names are expected to change - filled and +-- background-filled marks need a naming convention. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Dots.Marks + ( + + + -- * Marks + markChar + , markText + + , markHLine + , markVLine + , markX + , markPlus + , markCross + , markDiamond + , markFDiamond + , markBDiamond + , markDisk + , markSquare + , markCircle + , markPentagon + , markStar + , markAsterisk + , markOPlus + , markOCross + , markFOCross + , markTriangle + + ) where + + +import Wumpus.Drawing.Geometry.Paths +import Wumpus.Drawing.Text.LRText + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative + +-- Marks should be the height of a lower-case letter... + +-- NOTES +-- +-- TikZ has both stroked and bordered (filled and outline-stroked) +-- marks e.g. square and square* +-- + + + + +infixr 9 `renderPathWith` + +renderPathWith :: LocDrawingInfo u (PrimPath u) + -> (PrimPath u -> Graphic u) + -> LocGraphic u +renderPathWith m k = m >>= (lift0R1 . k) + + + +markChar :: (Real u, Floating u, FromPtSize u) => Char -> LocGraphic u +markChar ch = markText [ch] + + + + +markText :: (Real u, Floating u, FromPtSize u) => String -> LocGraphic u +markText ss = fmap (replaceL uNil) $ ctrCenterLine ss + + + + +-- | Supplied point is the center. +-- +axialLine :: Fractional u => Vec2 u -> LocGraphic u +axialLine v = moveStartPoint (\ctr -> ctr .-^ (0.5 *^ v)) (straightLine v) + + +markHLine :: (Fractional u, FromPtSize u) => LocGraphic u +markHLine = lift0R1 markHeight >>= \h -> axialLine (hvec h) + + +markVLine :: (Fractional u, FromPtSize u) => LocGraphic u +markVLine = lift0R1 markHeight >>= \h -> axialLine (vvec h) + + +markX :: (Fractional u, FromPtSize u) => LocGraphic u +markX = lift0R1 markHeight >>= mkX + where + mkX h = let w = 0.75 * h + in axialLine (vec w h) `oplus` axialLine (vec (-w) h) + + + +markPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markPlus = markVLine `oplus` markHLine + + +markCross :: (Floating u, FromPtSize u) => LocGraphic u +markCross = markHeight >>= mkCross + where + mkCross h = axialLine (avec ang h) `oplus` axialLine (avec (-ang) h) + ang = pi*0.25 + +-- Note - height is extended slightly to look good... + +pathDiamond :: (Fractional u, FromPtSize u) + => LocDrawingInfo u (PrimPath u) +pathDiamond = + promoteR1 $ \pt -> + markHeight >>= \h -> let cp = diamondCoordPath (0.5*h) (0.66*h) + in return $ coordinatePrimPath pt cp + + + +-- closedStroke :: (a -> ctx -> prim) +-- pathDiamond :: (ctx -> pt -> a) +-- ans :: (ctx -> pt -> prim) + +markDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markDiamond = pathDiamond `renderPathWith` closedStroke + +markFDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markFDiamond = pathDiamond `renderPathWith` filledPath + + +-- Note - the (const . fn) composition doesn\'t /tell/ much about +-- what is going on - though obviously it can be decoded - make +-- the function obvious to the second argument. +-- +-- A named combinator might be better. +-- + +markBDiamond :: (Fractional u, FromPtSize u) => LocGraphic u +markBDiamond = pathDiamond `renderPathWith` borderedPath + + +-- | Note disk is filled. +-- +markDisk :: (Fractional u, FromPtSize u) => LocGraphic u +markDisk = lift0R1 markHalfHeight >>= filledDisk + + + +markSquare :: (Fractional u, FromPtSize u) => LocGraphic u +markSquare = + lift0R1 markHeight >>= \h -> + let d = 0.5*(-h) in moveStartPoint (displace d d) $ strokedRectangle h h + + + +markCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markCircle = lift0R1 markHalfHeight >>= strokedDisk + + +markBCircle :: (Fractional u, FromPtSize u) => LocGraphic u +markBCircle = lift0R1 markHalfHeight >>= borderedDisk + + + +markPentagon :: (Floating u, FromPtSize u) => LocGraphic u +markPentagon = + promoteR1 $ \pt -> + markHeight >>= \h -> closedStroke $ pentagonPath pt (0.5*h) + where + pentagonPath pt hh = coordinatePrimPath pt $ polygonCoordPath 5 hh + + + + +markStar :: (Floating u, FromPtSize u) => LocGraphic u +markStar = lift0R1 markHeight >>= \h -> starLines (0.5*h) + +starLines :: Floating u => u -> LocGraphic u +starLines hh = + promoteR1 $ \ctr -> let cp = polygonCoordPath 5 hh + in step $ map (fn ctr) $ cp ctr + where + fn p0 p1 = openStroke $ primPath p0 [lineTo p1] + step (x:xs) = oconcat x xs + step _ = error "starLines - unreachable" + + +markAsterisk :: (Floating u, FromPtSize u) => LocGraphic u +markAsterisk = lift0R1 markHeight >>= asteriskLines + +asteriskLines :: Floating u => u -> LocGraphic u +asteriskLines h = lineF1 `oplus` lineF2 `oplus` lineF3 + where + ang = (pi*2) / 6 + lineF1 = axialLine (vvec h) + lineF2 = axialLine (avec ((pi*0.5) + ang) h) + lineF3 = axialLine (avec ((pi*0.5) + ang + ang) h) + + +markOPlus :: (Fractional u, FromPtSize u) => LocGraphic u +markOPlus = markCircle `oplus` markPlus + + +markOCross :: (Floating u, FromPtSize u) => LocGraphic u +markOCross = markCircle `oplus` markCross + + +markFOCross :: (Floating u, FromPtSize u) => LocGraphic u +markFOCross = markCross `oplus` markBCircle + + +-- bkCircle :: (Fractional u, FromPtSize u) => LocGraphic u +-- bkCircle = disk (fillAttr attr) (0.5*markHeight attr) + + + +markTriangle :: (Floating u, FromPtSize u) => LocGraphic u +markTriangle = tripath `renderPathWith` closedStroke + where + tripath = promoteR1 $ \pt -> + markHeight >>= \h -> let cp = equilateralTriangleCoordPath h + in pure $ coordinatePrimPath pt cp + diff --git a/src/Wumpus/Drawing/Geometry/Intersection.hs b/src/Wumpus/Drawing/Geometry/Intersection.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Geometry/Intersection.hs @@ -0,0 +1,173 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Geometry.Intersection +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Intersection of line to line and line to plane +-- +-- \*\* - WARNING \*\* - half baked. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Geometry.Intersection + ( + LineSegment(..) + , PointSlope + , pointSlope + , LineEqn + , lineEqn + , toLineEqn + , findIntersect + , intersection + + , rectangleLines + , polygonLines + , langle + + ) + where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + + +-- WARNING - This module is not very good (neither particularly +-- robust, nor efficient). +-- +-- I really need to find an algorithm that does this properly. +-- + +data LineSegment u = LS (Point2 u) (Point2 u) + deriving (Eq,Ord,Show) + + +data PointSlope u = PointSlope + { _point_slope_point :: Point2 u + , _point_slope_slope :: u + } + deriving (Eq,Show) + +pointSlope :: Fractional u => Point2 u -> Radian -> PointSlope u +pointSlope pt theta = PointSlope pt (fromRadian $ tan theta) + + +-- | Line in equational form, i.e. @Ax + By + C = 0@. +data LineEqn u = LineEqn + { _line_eqn_A :: !u + , _line_eqn_B :: !u + , _line_eqn_C :: !u + } + deriving (Eq,Show) + +lineEqn :: Num u => Point2 u -> Point2 u -> LineEqn u +lineEqn (P2 x1 y1) (P2 x2 y2) = LineEqn a b c + where + a = y1 - y2 + b = x2 - x1 + c = (x1*y2) - (x2*y1) + + +toLineEqn :: Num u => PointSlope u -> LineEqn u +toLineEqn (PointSlope (P2 x0 y0) m) = LineEqn m (-1) ((-m) * x0 + y0) + + + + +data IntersectionResult u = Intersects u u | Contained | NoIntersect + deriving (Eq,Show) + + +-- Note the uses a /plane/ so is susceptible to picking the +-- wrong quadrant... +-- +findIntersect :: (Floating u, Real u, Ord u) + => Point2 u -> Radian -> [LineSegment u] -> Maybe (Point2 u) +findIntersect ctr ang0 = step + where + theta = circularModulo ang0 + eqn = toLineEqn $ pointSlope ctr theta + step [] = Nothing + step (x:xs) = case intersection x eqn of + Just pt | quadrantCheck theta ctr pt -> Just pt + _ -> step xs + + +quadrantCheck :: (Real u, Floating u) + => Radian -> Point2 u -> Point2 u -> Bool +quadrantCheck theta ctr pt = theta == langle ctr pt + +intersection :: (Fractional u, Ord u) + => LineSegment u -> LineEqn u -> Maybe (Point2 u) +intersection ls@(LS p q) eqn = case intersect1 ls eqn of + Intersects fp fq -> let t = fp / (fp-fq) in Just $ affineComb p q t + Contained -> Just p + NoIntersect -> Nothing + + + +intersect1 :: (Num u, Ord u) + => LineSegment u -> LineEqn u -> IntersectionResult u +intersect1 (LS p q) eqn = + if inters fp fq then Intersects fp fq + else if contained fp fq then Contained else NoIntersect + where + inters a b = (a < 0 && b >= 0) || (a > 0 && b <= 0) + contained a b = a == 0 && b == 0 + fp = lineF p eqn + fq = lineF q eqn + +lineF :: Num u => Point2 u -> LineEqn u -> u +lineF (P2 x y) (LineEqn a b c) = a*x + b*y + c + +affineComb :: Num u => Point2 u -> Point2 u -> u -> Point2 u +affineComb p q t = p .+^ t *^ (q .-. p) + + + + +rectangleLines :: Num u => Point2 u -> u -> u -> [LineSegment u] +rectangleLines ctr hw hh = [LS br tr, LS tr tl, LS tl bl, LS bl br] + where + br = ctr .+^ (vec hw (-hh)) + tr = ctr .+^ (vec hw hh) + tl = ctr .+^ (vec (-hw) hh) + bl = ctr .+^ (vec (-hw) (-hh)) + + +polygonLines :: [Point2 u] -> [LineSegment u] +polygonLines [] = error "polygonLines - emptyList" +polygonLines (x:xs) = step x xs + where + step a [] = [LS a x] + step a (b:bs) = LS a b : step b bs + + + +-- | Calculate the counter-clockwise angle between two points +-- and the x-axis. +-- +langle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian +langle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1) + where + -- north-east quadrant + step x y | pve x && pve y = toRadian $ atan (y/x) + + -- north-west quadrant + step x y | pve y = pi - (toRadian $ atan (y / abs x)) + + -- south-east quadrant + step x y | pve x = (2*pi) - (toRadian $ atan (abs y / x)) + + -- otherwise... south-west quadrant + step x y = pi + (toRadian $ atan (y/x)) + + pve a = signum a >= 0 diff --git a/src/Wumpus/Drawing/Geometry/Paths.hs b/src/Wumpus/Drawing/Geometry/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Geometry/Paths.hs @@ -0,0 +1,138 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Geometry.Paths +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Paths for /elementary/ shapes - rectangles... +-- +-- \*\* - WARNING \*\* - half baked. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Geometry.Paths + ( + LocCoordPath + , coordinatePrimPath + + , rectangleCoordPath + , diamondCoordPath + , polygonCoordPath + , isoscelesTriangleCoordPath + , isoscelesTrianglePoints + , equilateralTriangleCoordPath + , equilateralTrianglePoints + ) + where + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +import Data.List ( unfoldr ) + + +-- | A functional type from /initial point/ to point list. +-- +type LocCoordPath u = Point2 u -> [Point2 u] + + +-- Note - extraction needs a naming scheme - extractFROM or +-- extractTO? - in either case this might be queuing up +-- name-clash problems. +-- +-- The Path data type will also need a similar function... +-- + +coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u +coordinatePrimPath pt fn = go (fn pt) + where + go ps@(_:_) = vertexPath ps + go [] = emptyPath pt -- fallback + + +-- NOTE - These functions need changing to generate LocCoordPaths... + +-- | Supplied point is /bottom-left/, subsequenct points are +-- counter-clockise so [ bl, br, tr, tl ] . +-- +rectangleCoordPath :: Num u => u -> u -> LocCoordPath u +rectangleCoordPath w h bl = [ bl, br, tr, tl ] + where + br = bl .+^ hvec w + tr = br .+^ vvec h + tl = bl .+^ vvec h + + + +-- | 'diamondPath' : @ half_width * half_height * center_point -> PrimPath @ +-- +diamondCoordPath :: Num u => u -> u -> LocCoordPath u +diamondCoordPath hw hh ctr = [ s,e,n,w ] + where + s = ctr .+^ vvec (-hh) + e = ctr .+^ hvec hw + n = ctr .+^ vvec hh + w = ctr .+^ hvec (-hw) + + +-- | 'polygonCoordPath' : @ num_points * radius * center -> [point] @ +-- +polygonCoordPath :: Floating u => Int -> u -> LocCoordPath u +polygonCoordPath n radius ctr = unfoldr phi (0,(pi*0.5)) + where + theta = (pi*2) / fromIntegral n + + phi (i,ang) | i < n = Just (ctr .+^ avec ang radius, (i+1,ang+theta)) + | otherwise = Nothing + + + +-- | @isocelesTriangle bw h pt@ +-- +-- Supplied point is the centriod of the triangle. This has a +-- nicer visual balance than using half-height. +-- +isoscelesTriangleCoordPath :: Floating u => u -> u -> LocCoordPath u +isoscelesTriangleCoordPath bw h ctr = [bl,br,top] + where + (bl,br,top) = isoscelesTrianglePoints bw h ctr + + +-- | @isocelesTriangle bw h pt@ +-- +-- Supplied point is the centriod of the triangle. This has a +-- nicer visual balance than using half-height. +-- +isoscelesTrianglePoints :: Floating u + => u -> u -> Point2 u -> (Point2 u, Point2 u, Point2 u) +isoscelesTrianglePoints bw h ctr = (bl, br, top) + where + hw = 0.5*bw + theta = atan $ h / hw + centroid_h = hw * tan (0.5*theta) + top = ctr .+^ vvec (h - centroid_h) + br = ctr .+^ V2 hw (-centroid_h) + bl = ctr .+^ V2 (-hw) (-centroid_h) + + +-- | @ side_length * ctr -> [Points] @ +-- +equilateralTriangleCoordPath :: Floating u => u -> LocCoordPath u +equilateralTriangleCoordPath sl ctr = [bl, br, top] + where + (bl,br,top) = equilateralTrianglePoints sl ctr + +equilateralTrianglePoints :: Floating u + => u -> Point2 u -> (Point2 u, Point2 u, Point2 u) +equilateralTrianglePoints sl = isoscelesTrianglePoints sl h + where + h = sl * sin (pi/3) + diff --git a/src/Wumpus/Drawing/Paths.hs b/src/Wumpus/Drawing/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim import module for Paths. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths + ( + + module Wumpus.Drawing.Paths.Base + , module Wumpus.Drawing.Paths.Connectors + , module Wumpus.Drawing.Paths.ControlPoints + , module Wumpus.Drawing.Paths.MonadicConstruction + + ) where + +import Wumpus.Drawing.Paths.Base +import Wumpus.Drawing.Paths.Connectors +import Wumpus.Drawing.Paths.ControlPoints +import Wumpus.Drawing.Paths.MonadicConstruction + diff --git a/src/Wumpus/Drawing/Paths/Base.hs b/src/Wumpus/Drawing/Paths/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Base.hs @@ -0,0 +1,650 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Base +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Extended path type - more amenable for complex drawings than +-- the type in Wumpus-Core. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Base + ( + + Path + , DPath + , length + , append + , pconcat + , line + , curve + , pivot + , traceLinePoints + , traceCurvePoints + , curveByAngles + + , toPrimPath + + , tipL + , tipR + + , shortenPath + , shortenL + , shortenR + , directionL + , directionR + + , midway + , midway_ + , atstart + , atstart_ + , atend + , atend_ + + , PathViewL(..) + , DPathViewL + , PathViewR(..) + , DPathViewR + , PathSegment(..) + , DPathSegment + , pathViewL + , pathViewR + + + , roundTrail + , roundInterior + + ) where + + +import Wumpus.Drawing.Geometry.Intersection ( langle ) + +-- package: wumpus-basic +import Wumpus.Basic.Utils.JoinList ( JoinList, ViewL(..), viewl + , ViewR(..), viewr, cons, snoc, join ) +import qualified Wumpus.Basic.Utils.JoinList as JL + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace +import Data.VectorSpace + +import Data.List ( foldl' ) + +import Prelude hiding ( length ) + +data Path u = Path { _path_length :: u + , _path_start :: Point2 u + , _path_elements :: JoinList (PathSeg u) + , _path_end :: Point2 u + } + deriving (Eq,Show) + +type DPath = Path Double + +-- Annotating each segment with length is \*\* good \*\*. +-- Makes it much more efficient to find the midway point. +-- +-- But what do we do about the start point: +-- +-- a) put it in the segment - too much info in the type, allows +-- consistency problems vis-a-vis gaps in the path. +-- +-- b) leave it out - too little info in the type, allows +-- consistency problems with length. +-- +-- Option (a) is probably most convenient espcially as the +-- constructors won\'t be exported. + +-- Annotation is length... +-- +data PathSeg u = LineSeg { _line_length :: u + , _line_start :: Point2 u + , _line_end :: Point2 u + } + | CurveSeg { _curve_length :: u + , _curve_start :: Point2 u + , _ctrl_pt_one :: Point2 u + , _ctrl_pt_two :: Point2 u + , _curve_end :: Point2 u + } + deriving (Eq,Show) + + +type instance DUnit (Path u) = u +type instance DUnit (PathSeg u) = u + + +infixr 1 `append` + +length :: Num u => Path u -> u +length (Path u _ _ _) = u + +append :: Floating u => Path u -> Path u -> Path u +append (Path len1 start1 se1 end1) (Path len2 start2 se2 end2) + | end1 == start2 = Path (len1+len2) start1 (se1 `join` se2) end2 + | otherwise = let joint = lineSegment end1 start2 + total_len = len1 + len2 + segmentLength joint + in Path total_len start1 (se1 `join` (cons joint se2)) end2 + +-- CAUTION - @append@ is using Floating Point equality to see if +-- points are equal... + + +pconcat :: Floating u => Path u -> [Path u] -> Path u +pconcat p0 ps = foldl' append p0 ps + +segmentLength :: PathSeg u -> u +segmentLength (LineSeg u _ _) = u +segmentLength (CurveSeg u _ _ _ _) = u + + +segmentStart :: PathSeg u -> Point2 u +segmentStart (LineSeg _ p0 _) = p0 +segmentStart (CurveSeg _ p0 _ _ _) = p0 + +segmentEnd :: PathSeg u -> Point2 u +segmentEnd (LineSeg _ _ p1) = p1 +segmentEnd (CurveSeg _ _ _ _ p3) = p3 + + + + +lineSegment :: Floating u => Point2 u -> Point2 u -> PathSeg u +lineSegment p0 p1 = let v = vlength $ pvec p0 p1 in LineSeg v p0 p1 + + +pathZero :: Floating u => Point2 u -> Path u +pathZero p0 = Path 0 p0 JL.empty p0 + + +line :: Floating u => Point2 u -> Point2 u -> Path u +line p0 p1 = let v = vlength $ pvec p0 p1 + in Path v p0 (JL.one $ LineSeg v p0 p1) p1 + + +curve :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Path u +curve p0 p1 p2 p3 = let v = curveLength p0 p1 p2 p3 + in Path v p0 (JL.one $ CurveSeg v p0 p1 p2 p3) p3 + +-- | A draw a /straight line/ of length 0 at the supplied point. +-- +-- This is /might/ be useful in concatenating curved paths +-- as it introduces and extra control point. +-- +pivot :: Floating u => Point2 u -> Path u +pivot p0 = Path 0 p0 (JL.one $ LineSeg 0 p0 p0) p0 + + +-- | 'traceLinePoints' throws a runtime error if the supplied list +-- is empty. +-- +traceLinePoints :: Floating u => [Point2 u] -> Path u +traceLinePoints [] = error "traceLinePoints - empty point list." +traceLinePoints [a] = line a a +traceLinePoints (a:b:xs) = step (line a b) b xs + where + step acc _ [] = acc + step acc e (y:ys) = step (acc `append` line e y) y ys + + +-- | 'traceCurvePoints' consumes 4 points from the list on the +-- intial step (start, control1, control2, end) then steps +-- through the list taking 3 points at a time thereafter +-- (control1,control2, end). Leftover points are discarded. +-- +-- 'traceCurvePoints' throws a runtime error if the supplied list +-- is has less than 4 elements (start, control1, control2, end). +-- +traceCurvePoints :: (Floating u, Ord u) => [Point2 u] -> Path u +traceCurvePoints (a:b:c:d:xs) = step (curve a b c d) d xs + where + step acc p0 (x:y:z:zs) = step (acc `append` curve p0 x y z) z zs + step acc _ _ = acc + +traceCurvePoints _ = error "tracePointsCurve - less than 4 elems." + + +curveByAngles :: (Floating u, Ord u) + => Point2 u -> Radian -> Radian -> Point2 u -> Path u +curveByAngles start cin cout end = curve start (start .+^ v1) (end .+^ v2) end + where + sz = 0.375 * (vlength $ pvec start end) + v1 = avec cin sz + v2 = avec cout sz + + + +-- | Turn a Path into an ordinary PrimPath. +-- +-- Assumes path is properly formed - i.e. end point of one +-- segment is the same point as the start point of the next +-- segment. +-- +toPrimPath :: Num u => Path u -> PrimPath u +toPrimPath (Path _ start segs _) = step1 $ viewl segs + where + step1 EmptyL = emptyPath start + step1 (e :< se) = let (p0,a) = seg1 e in + primPath p0 $ a : step2 (viewl se) + + step2 EmptyL = [] + step2 (e :< se) = seg2 e : step2 (viewl se) + + seg1 (LineSeg _ p0 p1) = (p0, lineTo p1) + seg1 (CurveSeg _ p0 p1 p2 p3) = (p0, curveTo p1 p2 p3) + + seg2 (LineSeg _ _ p1) = lineTo p1 + seg2 (CurveSeg _ _ p1 p2 p3) = curveTo p1 p2 p3 + + + +-------------------------------------------------------------------------------- +-- Curve length + +data StrictCurve u = Curve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u) + +curveLength :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> u +curveLength p0 p1 p2 p3 = gravesenLength 0.1 $ Curve p0 p1 p2 p3 + + +-- | Jens Gravesen\'s bezier arc-length approximation. +-- +-- Note this implementation is parametrized on error tolerance. +-- +gravesenLength :: (Floating u, Ord u) => u -> StrictCurve u -> u +gravesenLength err_tol crv = step crv where + step c = let l1 = ctrlPolyLength c + l0 = cordLength c + in if l1-l0 > err_tol + then let (a,b) = subdivide c in step a + step b + else 0.5*l0 + 0.5*l1 + + +ctrlPolyLength :: Floating u => StrictCurve u -> u +ctrlPolyLength (Curve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3 + where + len pa pb = vlength $ pvec pa pb + +cordLength :: Floating u => StrictCurve u -> u +cordLength (Curve p0 _ _ p3) = vlength $ pvec p0 p3 + + +-- | mid-point between two points +-- +pointMidpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u +pointMidpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0 + + +-- | Curve subdivision via de Casteljau\'s algorithm. +-- +subdivide :: Fractional u + => StrictCurve u -> (StrictCurve u, StrictCurve u) +subdivide (Curve p0 p1 p2 p3) = + (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) + where + p01 = pointMidpoint p0 p1 + p12 = pointMidpoint p1 p2 + p23 = pointMidpoint p2 p3 + p012 = pointMidpoint p01 p12 + p123 = pointMidpoint p12 p23 + p0123 = pointMidpoint p012 p123 + +-- | subdivide with an affine weight along the line... +-- +subdividet :: Real u + => u -> StrictCurve u -> (StrictCurve u, StrictCurve u) +subdividet t (Curve p0 p1 p2 p3) = + (Curve p0 p01 p012 p0123, Curve p0123 p123 p23 p3) + where + p01 = affineCombination t p0 p1 + p12 = affineCombination t p1 p2 + p23 = affineCombination t p2 p3 + p012 = affineCombination t p01 p12 + p123 = affineCombination t p12 p23 + p0123 = affineCombination t p012 p123 + +affineCombination :: Real u => u -> Point2 u -> Point2 u -> Point2 u +affineCombination a p1 p2 = p1 .+^ a *^ (p2 .-. p1) + +-------------------------------------------------------------------------------- +-- tips + +tipL :: Path u -> Point2 u +tipL (Path _ sp _ _) = sp + + +tipR :: Path u -> Point2 u +tipR (Path _ _ _ ep) = ep + + + + +-- | 'sortenPath' : @ left_dist * right_dist * path -> Path @ +-- +shortenPath :: (Real u , Floating u) => u -> u -> Path u -> Path u +shortenPath l r = shortenL l . shortenR r + + +-------------------------------------------------------------------------------- +-- shorten from the left... + +-- | Note - shortening a line from the left by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the end point. +-- +shortenL :: (Real u, Floating u) => u -> Path u -> Path u +shortenL n (Path u _ segs ep) + | n >= u = line ep ep + | otherwise = step n (viewl segs) + where + step _ EmptyL = line ep ep -- should be unreachable + step d (e :< se) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewl se) + EQ -> makeLeftPath (u-n) se ep + LT -> let e1 = shortenSegL d e + in Path (u-n) (segmentStart e1) (e1 `cons` se) ep + + +makeLeftPath :: Floating u => u -> JoinList (PathSeg u) -> Point2 u -> Path u +makeLeftPath u se ep = + case viewl se of + EmptyL -> line ep ep + (e :< _) -> Path u (segmentStart e) se ep + + +shortenSegL :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u +shortenSegL n (LineSeg u p0 p1) = + LineSeg (u-n) (shortenLineL n p0 p1) p1 + +shortenSegL n (CurveSeg u p0 p1 p2 p3) = + let (Curve p0' p1' p2' p3') = snd $ subdividet (n/u) (Curve p0 p1 p2 p3) + in CurveSeg (u-n) p0' p1' p2' p3' + + +shortenLineL :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineL n p0 p1 = p0 .+^ v + where + v0 = p1 .-. p0 + v = avec (vdirection v0) n + + + +-------------------------------------------------------------------------------- +-- shorten from the right ... + +-- | Note - shortening a line from the right by +-- greater-than-or-equal its length is operationally equivalent +-- to making a zero-length line at the start point. +-- +shortenR :: (Real u, Floating u) => u -> Path u -> Path u +shortenR n (Path u sp segs _) + | n >= u = line sp sp + | otherwise = step n (viewr segs) + where + step _ EmptyR = line sp sp -- should be unreachable + step d (se :> e) = let z = segmentLength e in + case compare d z of + GT -> step (d-z) (viewr se) + EQ -> makeRightPath n sp se + LT -> let e1 = shortenSegR d e + in Path (u-n) sp (se `snoc` e1) (segmentEnd e1) + + +makeRightPath :: Floating u => u -> Point2 u -> JoinList (PathSeg u) -> Path u +makeRightPath u sp se = + case viewr se of + EmptyR -> line sp sp + (_ :> e) -> Path u sp se (segmentEnd e) + + + +shortenSegR :: (Real u, Floating u) => u -> PathSeg u -> PathSeg u +shortenSegR n (LineSeg u p0 p1) = + LineSeg (u-n) p0 (shortenLineR n p0 p1) + +shortenSegR n (CurveSeg u p0 p1 p2 p3) = + let (Curve p0' p1' p2' p3') = fst $ subdividet ((u-n)/u) (Curve p0 p1 p2 p3) + in CurveSeg (u-n) p0' p1' p2' p3' + + +shortenLineR :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +shortenLineR n p0 p1 = p1 .+^ v + where + v0 = p0 .-. p1 + v = avec (vdirection v0) n + + + + +-------------------------------------------------------------------------------- +-- line direction + +-- | Direction of empty path is considered to be 0. +-- +directionL :: (Real u, Floating u) => Path u -> Radian +directionL (Path _ _ se _) = step $ viewl se + where + step (LineSeg _ p0 p1 :< _) = lineDirection p1 p0 -- 1-to-0 + step (CurveSeg _ p0 p1 _ _ :< _) = lineDirection p1 p0 + step _ = 0 -- should be unreachable + + +-- | Direction of empty path is considered to be 0. +-- +directionR :: (Real u, Floating u) => Path u -> Radian +directionR (Path _ _ se _) = step $ viewr se + where + step (_ :> LineSeg _ p0 p1) = lineDirection p0 p1 + step (_ :> CurveSeg _ _ _ p2 p3) = lineDirection p2 p3 + step _ = 0 -- should be unreachable + + + + +-------------------------------------------------------------------------------- + + +-- Return direction as well because the calculation is expensive... +-- +midway :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +midway pa@(Path u sp _ _) + | u == 0 = (sp,0) + | otherwise = let pa1 = shortenR (u/2) pa in (tipR pa1, directionR pa1) + +-- Just the midway point. +-- +midway_ :: (Real u, Floating u) => Path u -> Point2 u +midway_ = fst . midway + + +atstart :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +atstart pa@(Path _ sp _ _) = (sp, directionL pa) + +atstart_ :: Path u -> Point2 u +atstart_ (Path _ sp _ _) = sp + + +atend :: (Real u, Floating u) => Path u -> (Point2 u, Radian) +atend pa@(Path _ _ _ ep) = (ep, directionR pa) + + +atend_ :: Path u -> Point2 u +atend_ (Path _ _ _ ep) = ep + + +-- nearstart, nearend, verynear ... + + +-------------------------------------------------------------------------------- + +data PathViewL u = PathOneL (PathSegment u) + | PathSegment u :<< Path u + deriving (Eq,Show) + +type DPathViewL = PathViewL Double + +data PathViewR u = PathOneR (PathSegment u) + | Path u :>> PathSegment u + deriving (Eq,Show) + +type DPathViewR = PathViewR Double + + +data PathSegment u = Line1 (Point2 u) (Point2 u) + | Curve1 (Point2 u) (Point2 u) (Point2 u) (Point2 u) + deriving (Eq,Show) + +type DPathSegment = PathSegment Double + +type instance DUnit (PathViewL u) = u +type instance DUnit (PathViewR u) = u +type instance DUnit (PathSegment u) = u + +pathViewL :: Num u => Path u -> PathViewL u +pathViewL (Path u _ segs ep) = go (viewl segs) + where + go EmptyL = error "pathViewL - (not) unreachable." + + go (LineSeg v p0 p1 :< se) + | JL.null se = PathOneL (Line1 p0 p1) + | otherwise = Line1 p0 p1 :<< Path (u-v) p1 se ep + + go (CurveSeg v p0 p1 p2 p3 :< se) + | JL.null se = PathOneL (Curve1 p0 p1 p2 p3) + | otherwise = Curve1 p0 p1 p2 p3 :<< Path (u-v) p3 se ep + + +pathViewR :: Num u => Path u -> PathViewR u +pathViewR (Path u _ segs ep) = go (viewr segs) + where + go EmptyR = error "pathViewR - (not) unreachable." + + go (se :> LineSeg v p0 p1) + | JL.null se = PathOneR (Line1 p0 p1) + | otherwise = Path (u-v) p1 se ep :>> Line1 p0 p1 + + go (se :> CurveSeg v p0 p1 p2 p3) + | JL.null se = PathOneR (Curve1 p0 p1 p2 p3) + | otherwise = Path (u-v) p3 se ep :>> Curve1 p0 p1 p2 p3 + + + + +-------------------------------------------------------------------------------- +-- Round corners + +-- | The length of the control-point vector wants to be slighly +-- longer than half of /d/ (d - being the distance between the +-- /truncated/ points and the corner). +-- +cornerCurve :: (Real u, Floating u) + => Point2 u -> Point2 u -> Point2 u -> Path u +cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3 + where + len1 = 0.6 * (vlength $ pvec p1 p2) + len2 = 0.6 * (vlength $ pvec p3 p2) + cp1 = p1 .+^ (avec (langle p1 p2) len1) + cp2 = p3 .+^ (avec (langle p3 p2) len2) + + +-- | 'roundTrail' : @ rounding_distance * [point] -> Path @ +-- +-- Build a path from the list of vertices, all the interior +-- corners are rounded by the rounding distance \*and\* final +-- round corner is created \"incorporating\" the start point (as +-- the start point becomes a rounded corner the actual path will +-- not intersect it). +-- +-- It is expected that this function will be used to create round +-- cornered shapes. +-- +-- 'roundTrail' throws a runtime error if the input list is empty. +-- If the list has one element /the null path/ is built, if the +-- list has two elements a straight line is built. +-- +roundTrail :: (Real u, Floating u) + => u -> [Point2 u] -> Path u +roundTrail _ [] = error "roundTrail - empty list." +roundTrail _ [a] = pathZero a +roundTrail _ [a,b] = line a b +roundTrail u (start:b:c:xs) = step (lineCurveTrail u start b c) (b:c:xs) + where + step acc (m:n:o:ps) = step (acc `append` lineCurveTrail u m n o) (n:o:ps) + step acc [n,o] = acc `append` lineCurveTrail u n o start + `append` lineCurveTrail u o start b + step acc _ = acc + + + +-- | Two parts - line and corner curve... +-- +-- Note - the starting point is moved, this function is for +-- closed, rounded paths. +-- +lineCurveTrail :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u -> Path u +lineCurveTrail u a b c = line p1 p2 `append` cornerCurve p2 b p3 + where + p1 = a .+^ (avec (vdirection $ pvec a b) u) + p2 = b .+^ (avec (vdirection $ pvec b a) u) + p3 = b .+^ (avec (vdirection $ pvec b c) u) + + +-- | 'roundInterior' : @ rounding_distance * [point] -> Path @ +-- +-- Build a path from the list of vertices, all the interior +-- corners are rounded by the rounding distance. Unlike +-- 'roundTrail' there is no /loop around/ to the start point, +-- and start path will begin exactly on the start point and end +-- exactly on the end point. +-- +-- 'roundInterior' throws a runtime error if the input list is +-- empty. If the list has one element /the null path/ is built, +-- if the list has two elements a straight line is built. +-- +roundInterior :: (Real u, Floating u) + => u -> [Point2 u] -> Path u +roundInterior _ [] = error "roundEveryInterior - empty list." +roundInterior _ [a] = pathZero a +roundInterior _ [a,b] = line a b +roundInterior u (start:b:c:xs) = let (path1,p1) = lineCurveInter1 u start b c + in step path1 (p1:c:xs) + where + step acc (m:n:o:ps) = let (seg2,p1) = lineCurveInter1 u m n o + in step (acc `append` seg2) (p1:o:ps) + step acc [n,o] = acc `append` line n o + step acc _ = acc + + + +-- | Two parts - line and corner curve... +-- +-- Note - draws a straight line from the starting point - this is +-- the first step of an interior (non-closed) rounded path +-- +lineCurveInter1 :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u -> (Path u, Point2 u) +lineCurveInter1 u a b c = + (line a p2 `append` cornerCurve p2 b p3, p3) + where + p2 = b .+^ (avec (vdirection $ pvec b a) u) + p3 = b .+^ (avec (vdirection $ pvec b c) u) + diff --git a/src/Wumpus/Drawing/Paths/Connectors.hs b/src/Wumpus/Drawing/Paths/Connectors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/Connectors.hs @@ -0,0 +1,247 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.Connectors +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Library of connector paths... +-- +-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.Connectors + ( + + ConnectorPath + , DConnectorPath + , sconnect + + , connLine + + , connRightVH + , connRightHV + , connRightVHV + , connRightHVH + + , connIsosceles + , connIsosceles2 + , connLightningBolt + + , connIsoscelesCurve + , connSquareCurve + , connUSquareCurve + + , connTrapezoidCurve + , connZSquareCurve + , connUZSquareCurve + + ) where + +import Wumpus.Drawing.Paths.Base +import Wumpus.Drawing.Paths.ControlPoints + +import Wumpus.Basic.Kernel -- package: wumpus-basic +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative +import Prelude hiding ( length ) + + +-- | Note - a ConnectorPath is not drawn automatically, it is a +-- @ConnectorCF@ not a @ConnectorGraphic@ or @ConnectorImage@. +-- +type ConnectorPath u = ConnectorCF u (Path u) + +type DConnectorPath = ConnectorPath Double + + + +-- Maybe this should be ConnectorPath u -> ConnectorImage u (Path u) instead? +-- This would be closer to the new shapes... +-- +sconnect :: Num u + => ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u) +sconnect mf p0 p1 = + connect mf p0 p1 >>= \cpath -> + intoImage (pure cpath) (openStroke $ toPrimPath cpath) + + +-- | Build the path with interior round corners. +-- +roundCornerPath :: (Real u, Floating u, FromPtSize u) + => [Point2 u] -> CF (Path u) +roundCornerPath xs = getRoundCornerSize >>= \sz -> + if sz == 0 then return (traceLinePoints xs) + else return (roundInterior sz xs) + + + +-------------------------------------------------------------------------------- + +-- | Connect with a straight line. +-- +connLine :: Floating u => ConnectorPath u +connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1 + + + +-- | Right-angled connector - go vertical, then go horizontal. +-- +connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u +connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) -> + let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1] + + + +-- | Right-angled connector - go horizontal, then go vertical. +-- +connRightHV :: (Real u, Floating u, FromPtSize u) + => ConnectorPath u +connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> + let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1] + +-- | Right-angled connector - go vertical for the supplied +-- distance, go horizontal, go vertical again for the +-- remaining distance. +-- +connRightVHV :: (Real u, Floating u, FromPtSize u) + => u -> ConnectorPath u +connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) -> + let a0 = p0 .+^ vvec v + a1 = a0 .+^ hvec (x1 - x0) + in roundCornerPath [p0, a0, a1, p1] + + +-- | Right-angled connector - go horizontal for the supplied +-- distance, go verical, go horizontal again for the +-- remaining distance. +-- +connRightHVH :: (Real u, Floating u, FromPtSize u) + => u -> ConnectorPath u +connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) -> + let a0 = p0 .+^ hvec h + a1 = a0 .+^ vvec (y1 - y0) + in roundCornerPath [p0,a0,a1,p1] + + +-- | /Triangular/ joint. +-- +-- @u@ is the altitude of the triangle. +-- +connIsosceles :: (Real u, Floating u, FromPtSize u) + => u -> ConnectorPath u +connIsosceles dy = promoteR2 $ \ p0 p1 -> + let mid_pt = midpointIsosceles dy p0 p1 + in roundCornerPath [p0, mid_pt, p1] + + + + + +-- | Double /triangular/ joint. +-- +-- @u@ is the altitude of the triangle. +-- +connIsosceles2 :: (Real u, Floating u, FromPtSize u) + => u -> ConnectorPath u +connIsosceles2 u = promoteR2 $ \ p0 p1 -> + let (cp0,cp1) = dblpointIsosceles u p0 p1 + in roundCornerPath [ p0, cp0, cp1, p1 ] + + + +-- | /Lightning bolt/ joint - a two joint connector with an /axis/ +-- perpendicular to the connector direction. +-- +-- @u@ is the half length of the of the axis. +-- +connLightningBolt :: (Real u, Floating u, FromPtSize u) + => u -> ConnectorPath u +connLightningBolt u = promoteR2 $ \ p0 p1 -> + let cp0 = midpointIsosceles u p0 p1 + cp1 = midpointIsosceles (-u) p0 p1 + in roundCornerPath [ p0, cp0, cp1, p1 ] + +-------------------------------------------------------------------------------- + + + +-- | Form a curve inside an isosceles triangle. +-- +-- The two Bezier control points take the same point - the +-- altitude of the triangle. The curve tends to be quite shallow +-- relative to the altitude. +-- +-- @u@ is the altitude of the triangle. +-- +connIsoscelesCurve :: (Real u, Floating u) => u -> ConnectorPath u +connIsoscelesCurve u = promoteR2 $ \ p0 p1 -> + let control_pt = midpointIsosceles u p0 p1 + in pure $ traceCurvePoints [p0, control_pt, control_pt, p1] + + + +-- | Form a curve inside a square. +-- +-- The two Bezier control points take the /top/ corners. The +-- curve tends to be very deep. +-- +connSquareCurve :: (Real u, Floating u) => ConnectorPath u +connSquareCurve = promoteR2 $ \ p0 p1 -> + let (cp0,cp1) = squareFromBasePoints p0 p1 + in pure $ traceCurvePoints [p0, cp0, cp1, p1] + + + +-- | Form a curve inside a square. +-- +-- As per 'connSquareCurve' but the curve is drawn /underneath/ +-- the line formed between the start and end points. +-- +-- (Underneath is modulo the direction, of course). +-- +connUSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUSquareCurve = promoteR2 $ \ p0 p1 -> + let (cp0,cp1) = usquareFromBasePoints p0 p1 + in pure $ traceCurvePoints [p0, cp0, cp1, p1] + + +-- | altitude * ratio_to_base +-- +-- Form a curve inside a trapeziod. +-- +connTrapezoidCurve :: (Real u, Floating u) => u -> u -> ConnectorPath u +connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> + let (cp0,cp1) = trapezoidFromBasePoints u ratio_to_base p0 p1 + in pure $ traceCurvePoints [p0, cp0, cp1, p1] + + +-- | Make a curve within a square, following the corner points as +-- a Z. +-- +connZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connZSquareCurve = promoteR2 $ \p0 p1 -> + let (cp0,cp1) = squareFromCornerPoints p0 p1 + in pure $ traceCurvePoints [p0,cp0,cp1,p1] + +-- | Make a curve within a square, following the corner points as +-- a Z. +-- +-- The order of tracing flips the control points, so this is an +-- /underneath/ version of 'connZSquareCurve'. +-- +connUZSquareCurve :: (Real u, Floating u) => ConnectorPath u +connUZSquareCurve = promoteR2 $ \ p0 p1 -> + let (cp0,cp1) = squareFromCornerPoints p0 p1 + in pure $ traceCurvePoints [p0,cp1,cp0,p1] + diff --git a/src/Wumpus/Drawing/Paths/ControlPoints.hs b/src/Wumpus/Drawing/Paths/ControlPoints.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/ControlPoints.hs @@ -0,0 +1,189 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.ControlPoints +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Collection of point manufacturing functions. +-- +-- \*\* WARNING \*\* this module is experimental and may change +-- significantly in future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.ControlPoints + ( + + midpointIsosceles + , dblpointIsosceles + + , rectangleFromBasePoints + , squareFromBasePoints + , usquareFromBasePoints + + , trapezoidFromBasePoints + + , squareFromCornerPoints + + ) where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + + + +-- | 'midpointIsosceles' : +-- @ altitude * start_pt * end_pt -> mid_pt @ +-- +-- Triangular midpoint. +-- +-- @u@ is the altitude of the triangle - negative values of u +-- form the triangle below the line. +-- +midpointIsosceles :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> Point2 u +midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = + mid_pt .+^ avec perp_ang u + where + mid_pt = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1)) + perp_ang = (pi*0.5) + vdirection (pvec p1 p2) + + + +-- | 'dblpointIsosceles' : +-- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @ +-- +-- Double triangular joint - one joint at a third of the line +-- length, the other at two thirds. +-- +dblpointIsosceles :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) +dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = + (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u) + where + mid1 = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1)) + mid2 = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1)) + perp_ang = (pi*0.5) + vdirection (pvec p1 p2) + + +-------------------------------------------------------------------------------- + + + +-- | 'rectangleFromBasePoints' : +-- @ altitude * start_pt * end_pt * (top_left, top_right) @ +-- +-- Control points forming a rectangle. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +rectangleFromBasePoints :: (Real u, Floating u) + => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u) +rectangleFromBasePoints u p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + theta = vdirection base_vec + cp1 = displacePerpendicular u theta p1 + cp2 = displacePerpendicular u theta p2 + + +-- | 'squareFromBasePoints' : +-- @ start_pt -> end_pt -> (top_left, top_right) @ +-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +squareFromBasePoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 + where + side_len = vlength $ pvec p1 p2 + + +-- | 'usquareFromBasePoints' : +-- @ start_pt -> end_pt -> (bottom_left, bottom_right) @ +-- +-- Control points forming a square - side_len derived from the +-- distance between start and end points. +-- +-- As per 'squareFromBasePoints' but the square is drawn +-- /underneath/ the line formed between the start and end points. +-- (Underneath is modulo the direction, of course). +-- +-- The two manufactured control points form the /bottom/ corners, +-- so the supplied points map as @start_point == top_left@ and +-- @end_point == top_right@. +-- +usquareFromBasePoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2 + where + side_len = negate $ vlength $ pvec p1 p2 + + + + + +-- | 'trapezoidFromBasePoints' : +-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @ +-- +-- Control points form an isosceles trapezoid. +-- +-- The two manufactured control points form the top corners, +-- so the supplied points map as @start_point == bottom_left@ and +-- @end_point == bottom_right@. +-- +trapezoidFromBasePoints :: (Real u, Floating u) + => u -> u -> Point2 u -> Point2 u + -> (Point2 u, Point2 u) +trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + base_len = vlength base_vec + theta = vdirection base_vec + half_ulen = 0.5 * ratio_to_base * base_len + base_mid = displaceParallel (0.5 * base_len) theta p1 + ubase_mid = displacePerpendicular u theta base_mid + cp1 = displaceParallel (-half_ulen) theta ubase_mid + cp2 = displaceParallel half_ulen theta ubase_mid + + + + +-- | 'squareFromCornerPoints' : +-- @ altitude * start_pt * end_pt * (top_left, bottom_right) @ +-- +-- Control points forming a square bisected by the line from +-- start_pt to end_pt. +-- +-- The two manufactured control points form the top_left and +-- bottom_right corners, so the supplied points map as +-- @start_point == bottom_left@ and @end_point == top_right@. +-- +squareFromCornerPoints :: (Real u, Floating u) + => Point2 u -> Point2 u -> (Point2 u, Point2 u) +squareFromCornerPoints p1 p2 = (cp1, cp2) + where + base_vec = pvec p1 p2 + half_len = 0.5 * (vlength base_vec) + theta = vdirection base_vec + base_mid = displaceParallel half_len theta p1 + cp1 = displacePerpendicular half_len theta base_mid + cp2 = displacePerpendicular (-half_len) theta base_mid + diff --git a/src/Wumpus/Drawing/Paths/MonadicConstruction.hs b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Paths/MonadicConstruction.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Paths.MonadicConstruction +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Build paths monadically. +-- +-- \*\* WARNING \*\* this module is an experiment, and may +-- change significantly or even be dropped from future revisions. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Paths.MonadicConstruction + ( + + PathM + , runPath + , execPath + + , tip + + , lineto + , rlineto + , hline + , vline + + , bezierto + , curveto + + , verticalHorizontal + , horizontalVertical + + ) where + +import Wumpus.Basic.Utils.HList +import Wumpus.Drawing.Paths.Base + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative +import Data.List + + +-- Are connectors and paths quite different things? +-- +-- It looks like they are - connectors always know start and end +-- points. +-- + + +-- State monad version is quite good - it ameliorates the problem +-- of joining to the end point of an empty path... + +data St u = St + { current_point :: Point2 u + , path_acc :: H (Path u) + } + + +newtype PathM u a = PathM { getPathM :: St u -> (a,St u) } + + +instance Functor (PathM u) where + fmap f mf = PathM $ \s -> let (a,s1) = getPathM mf s in (f a,s1) + + +instance Applicative (PathM u) where + pure a = PathM $ \s -> (a,s) + mf <*> ma = PathM $ \s -> let (f,s1) = getPathM mf s + (a,s2) = getPathM ma s1 + in (f a,s2) + +instance Monad (PathM u) where + return a = PathM $ \s -> (a,s) + m >>= k = PathM $ \s -> let (a,s1) = getPathM m s in + (getPathM . k) a s1 + + + +-- Running the path is (probably) agnostic to the DrawingCtx. +-- +runPath :: Floating u => Point2 u -> PathM u a -> (a, Path u) +runPath start mf = + let (a,s') = getPathM mf s in (a, post $ toListH $ path_acc s') + where + s = St { current_point = start + , path_acc = emptyH + } + post [] = line start start + post (x:xs) = foldl' append x xs + +execPath :: Floating u => Point2 u -> PathM u a -> Path u +execPath start mf = snd $ runPath start mf + +snocline :: Floating u => Vec2 u -> PathM u () +snocline v = PathM $ \(St pt ac) -> let ep = pt .+^ v + in ((), St ep (ac `snocH` line pt ep)) + + +tip :: PathM u (Point2 u) +tip = PathM $ \s -> (current_point s,s) + + +lineto :: Floating u => Point2 u -> PathM u () +lineto pt = PathM $ \(St p0 ac) -> ((), St pt (ac `snocH` line p0 pt)) + +rlineto :: Floating u => Vec2 u -> PathM u () +rlineto (V2 dx dy) = tip >>= \(P2 x y) -> lineto (P2 (x+dx) (y+dy)) + + +hline :: Floating u => u -> PathM u () +hline len = snocline (hvec len) + +vline :: Floating u => u -> PathM u () +vline len = snocline (vvec len) + + + +bezierto :: (Floating u, Ord u) + => Point2 u -> Point2 u -> Point2 u -> PathM u () +bezierto c1 c2 ep = PathM $ \(St p0 ac) -> + ((), St ep (ac `snocH` curve p0 c1 c2 ep)) + + + + + +-- + + +curveto :: (Floating u, Ord u) + => Radian -> Radian -> Point2 u -> PathM u () +curveto cin cout end = PathM $ \(St p0 ac) -> + let seg = curveByAngles p0 cin cout end + ac1 = ac `snocH` seg + end1 = tipR seg + in ((), St end1 ac1) + + + + +verticalHorizontal :: Floating u => Point2 u -> PathM u () +verticalHorizontal (P2 x y) = + tip >>= \(P2 x0 _) -> lineto (P2 x0 y) >> lineto (P2 x y) + +horizontalVertical :: Floating u => Point2 u -> PathM u () +horizontalVertical (P2 x y) = + tip >>= \(P2 _ y0) -> lineto (P2 x y0) >> lineto (P2 x y) + diff --git a/src/Wumpus/Drawing/Shapes.hs b/src/Wumpus/Drawing/Shapes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Shim module for Shapes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes + ( + module Wumpus.Drawing.Shapes.Base + , module Wumpus.Drawing.Shapes.Circle + , module Wumpus.Drawing.Shapes.Diamond + , module Wumpus.Drawing.Shapes.Ellipse + , module Wumpus.Drawing.Shapes.Rectangle + + ) where + +import Wumpus.Drawing.Shapes.Base +import Wumpus.Drawing.Shapes.Circle +import Wumpus.Drawing.Shapes.Diamond +import Wumpus.Drawing.Shapes.Ellipse +import Wumpus.Drawing.Shapes.Rectangle diff --git a/src/Wumpus/Drawing/Shapes/Base.hs b/src/Wumpus/Drawing/Shapes/Base.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Base.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Base2 +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common core for shapes +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Base + ( + + + LocShape + , intoLocShape + , strokedShape + , filledShape + , borderedShape + + , roundCornerShapePath + + , ShapeCTM + , makeShapeCTM + , ctmCenter + , ctmAngle + , projectPoint + + + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Paths + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + + +type LocShape u a = LocCF u (a, Path u) + + +intoLocShape :: LocCF u a -> LocCF u (Path u) -> LocCF u (a,Path u) +intoLocShape = liftA2 (,) + +strokedShape :: Num u => LocShape u a -> LocImage u a +strokedShape mf = + promoteR1 $ \pt -> + (mf `at` pt) >>= \(a,spath) -> + intoImage (pure a) (closedStroke $ toPrimPath spath) + + +filledShape :: Num u => LocShape u a -> LocImage u a +filledShape mf = + promoteR1 $ \pt -> + (mf `at` pt) >>= \(a,spath) -> + intoImage (pure a) (filledPath $ toPrimPath spath) + + +borderedShape :: Num u => LocShape u a -> LocImage u a +borderedShape mf = + promoteR1 $ \pt -> + (mf `at` pt) >>= \(a,spath) -> + intoImage (pure a) (borderedPath $ toPrimPath spath) + +-- | Draw the shape path with round corners. +-- +roundCornerShapePath :: (Real u, Floating u, FromPtSize u) + => [Point2 u] -> CF (Path u) +roundCornerShapePath xs = getRoundCornerSize >>= \sz -> + if sz == 0 then return (traceLinePoints xs) + else return (roundTrail sz xs) + + + +-------------------------------------------------------------------------------- +-- CTM + +-- Note - all shapes need a location (usually/always the center) +-- so this needs to be stored in the CTM. +-- + +data ShapeCTM u = ShapeCTM + { ctm_center :: Point2 u + , ctm_scale_x :: !u + , ctm_scale_y :: !u + , ctm_rotation :: Radian + } + deriving (Eq,Ord,Show) + + +type instance DUnit (ShapeCTM u) = u + +makeShapeCTM :: Num u => Point2 u -> ShapeCTM u +makeShapeCTM pt = ShapeCTM { ctm_center = pt + , ctm_scale_x = 1 + , ctm_scale_y = 1 + , ctm_rotation = 0 } + + + + +instance Num u => Scale (ShapeCTM u) where + scale sx sy = (\s x y -> s { ctm_scale_x = x*sx, ctm_scale_y = y*sy }) + <*> ctm_scale_x <*> ctm_scale_y + + +instance Rotate (ShapeCTM u) where + rotate ang = (\s i -> s { ctm_rotation = circularModulo $ i+ang }) + <*> ctm_rotation + +instance (Real u, Floating u) => RotateAbout (ShapeCTM u) where + rotateAbout ang pt = + (\s ctr i -> s { ctm_rotation = circularModulo $ i+ang + , ctm_center = rotateAbout ang pt ctr }) + <*> ctm_center <*> ctm_rotation + + +instance Num u => Translate (ShapeCTM u) where + translate dx dy = (\s (P2 x y) -> s { ctm_center = P2 (x+dx) (y+dy) }) + <*> ctm_center + + + + +ctmCenter :: ShapeCTM u -> Point2 u +ctmCenter = ctm_center + +ctmAngle :: ShapeCTM u -> Radian +ctmAngle = ctm_rotation + + + +projectPoint :: (Real u, Floating u) => Point2 u -> ShapeCTM u -> Point2 u +projectPoint (P2 x y) (ShapeCTM { ctm_center = (P2 dx dy) + , ctm_scale_x = sx + , ctm_scale_y = sy + , ctm_rotation = theta }) = + translate dx dy $ rotate theta $ P2 (sx*x) (sy*y) + diff --git a/src/Wumpus/Drawing/Shapes/Circle.hs b/src/Wumpus/Drawing/Shapes/Circle.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Circle.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Circle +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Simple shapes - rectangle, circle diamond, ellipse. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Circle + ( + + Circle + , DCircle + , circle + + ) where + +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + + + +-------------------------------------------------------------------------------- +-- Circle + +data Circle u = Circle + { circ_ctm :: ShapeCTM u + , circ_radius :: !u + } + deriving (Eq,Show) + +type DCircle = Circle Double + +type instance DUnit (Circle u) = u + + + + +mapCircleCTM :: (ShapeCTM u -> ShapeCTM u) -> Circle u -> Circle u +mapCircleCTM f = (\s i -> s { circ_ctm = f i }) <*> circ_ctm + +instance Num u => Scale (Circle u) where + scale sx sy = mapCircleCTM (scale sx sy) + + +instance Rotate (Circle u) where + rotate ang = mapCircleCTM (rotate ang) + + +instance (Real u, Floating u) => RotateAbout (Circle u) where + rotateAbout ang pt = mapCircleCTM (rotateAbout ang pt) + + +instance Num u => Translate (Circle u) where + translate dx dy = mapCircleCTM (translate dx dy) + + + +runCircle :: (u -> ShapeCTM u -> a) -> Circle u -> a +runCircle fn (Circle { circ_ctm = ctm, circ_radius = radius }) = + fn radius ctm + + +instance (Real u, Floating u) => CenterAnchor (Circle u) where + center = runCircle (\_ -> ctmCenter) + + +instance (Real u, Floating u) => CardinalAnchor (Circle u) where + north = runCircle $ \r -> projectPoint $ P2 0 r + south = runCircle $ \r -> projectPoint $ P2 0 (-r) + east = runCircle $ \r -> projectPoint $ P2 r 0 + west = runCircle $ \r -> projectPoint $ P2 (-r) 0 + + +instance (Real u, Floating u) => CardinalAnchor2 (Circle u) where + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) + + +instance (Real u, Floating u) => RadialAnchor (Circle u) where + radialAnchor theta = runCircle $ \r -> projectPoint $ zeroPt .+^ avec theta r + + + + + + +-- | 'circle' : @ radius -> shape @ +-- +circle :: (Real u, Floating u) => u -> LocShape u (Circle u) +circle radius = intoLocShape (mkCircle radius) (mkCirclePath radius) + + + +mkCircle :: Num u => u -> LocCF u (Circle u) +mkCircle radius = promoteR1 $ \ctr -> + pure $ Circle { circ_ctm = makeShapeCTM ctr, circ_radius = radius } + + + +mkCirclePath :: (Floating u, Ord u) => u -> LocCF u (Path u) +mkCirclePath radius = promoteR1 $ \ctr -> + pure $ traceCurvePoints $ bezierCircle 2 radius ctr + + + + diff --git a/src/Wumpus/Drawing/Shapes/Diamond.hs b/src/Wumpus/Drawing/Shapes/Diamond.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Diamond.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Diamond +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Simple shapes - rectangle, circle diamond, ellipse. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Diamond + ( + + Diamond + , DDiamond + , diamond + + + ) where + +import Wumpus.Drawing.Geometry.Intersection +import Wumpus.Drawing.Geometry.Paths +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative + + + + +-------------------------------------------------------------------------------- +-- Diamond + + +data Diamond u = Diamond + { dia_ctm :: ShapeCTM u + , dia_hw :: !u + , dia_hh :: !u + } + +type DDiamond = Diamond Double + +type instance DUnit (Diamond u) = u + + +mapDiamondCTM :: (ShapeCTM u -> ShapeCTM u) -> Diamond u -> Diamond u +mapDiamondCTM f = (\s i -> s { dia_ctm = f i }) <*> dia_ctm + +instance Num u => Scale (Diamond u) where + scale sx sy = mapDiamondCTM (scale sx sy) + + +instance Rotate (Diamond u) where + rotate ang = mapDiamondCTM (rotate ang) + + +instance (Real u, Floating u) => RotateAbout (Diamond u) where + rotateAbout ang pt = mapDiamondCTM (rotateAbout ang pt) + + +instance Num u => Translate (Diamond u) where + translate dx dy = mapDiamondCTM (translate dx dy) + + + +runDiamond :: (u -> u -> ShapeCTM u -> a) -> Diamond u -> a +runDiamond fm (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = + fm hw hh ctm + + +instance (Real u, Floating u) => CenterAnchor (Diamond u) where + center = runDiamond (\_ _ -> ctmCenter) + +instance (Real u, Floating u) => CardinalAnchor (Diamond u) where + north = runDiamond $ \_ hh -> projectPoint $ P2 0 hh + south = runDiamond $ \_ hh -> projectPoint $ P2 0 (-hh) + east = runDiamond $ \hw _ -> projectPoint $ P2 hw 0 + west = runDiamond $ \hw _ -> projectPoint $ P2 (-hw) 0 + +instance (Real u, Floating u, Fractional u) => CardinalAnchor2 (Diamond u) where + northeast x = midpoint (north x) (east x) + southeast x = midpoint (south x) (east x) + southwest x = midpoint (south x) (west x) + northwest x = midpoint (north x) (west x) + + + +instance (Real u, Floating u) => RadialAnchor (Diamond u) where + radialAnchor = diamondIntersect + + +-- Utils.Intersection needs improving... + + +diamondIntersect :: (Real u, Floating u) + => Radian -> Diamond u -> Point2 u +diamondIntersect theta (Diamond { dia_ctm = ctm, dia_hw = hw, dia_hh = hh }) = + let ps = diamondPoints hw hh ctm + ctr = ctmCenter ctm + in maybe ctr id $ findIntersect ctr theta $ polygonLines ps + + + +midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u +midpoint p1 p2 = let v = 0.5 *^ pvec p1 p2 in p1 .+^ v + + + +-- | 'diamond' : @ half_width * half_height -> shape @ +-- +-- Note - args might change to tull_width and full_height... +-- +diamond :: (Real u, Floating u, FromPtSize u) + => u -> u -> LocShape u (Diamond u) +diamond hw hh = intoLocShape (mkDiamond hw hh) (mkDiamondPath hw hh) + + +mkDiamond :: Num u => u -> u -> LocCF u (Diamond u) +mkDiamond hw hh = promoteR1 $ \ctr -> + pure $ Diamond { dia_ctm = makeShapeCTM ctr, dia_hw = hw, dia_hh = hh } + + +mkDiamondPath :: (Real u, Floating u, FromPtSize u) + => u -> u -> LocCF u (Path u) +mkDiamondPath hw hh = promoteR1 $ \ctr -> + roundCornerShapePath $ diamondCoordPath hw hh ctr + + +diamondPoints :: (Real u, Floating u) => u -> u -> ShapeCTM u -> [Point2 u] +diamondPoints hw hh ctm = map (projectPoint `flip` ctm) [ s, e, n, w ] + where + s = P2 0 (-hh) + e = P2 hw 0 + n = P2 0 hh + w = P2 (-hw) 0 + + diff --git a/src/Wumpus/Drawing/Shapes/Ellipse.hs b/src/Wumpus/Drawing/Shapes/Ellipse.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Ellipse.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Ellipse +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Ellipse shape. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Ellipse + ( + + + -- * Ellipse + Ellipse + , DEllipse + , ellipse + + + ) where + +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + +import Control.Applicative + + + + + +-------------------------------------------------------------------------------- +-- Ellipse + + +data Ellipse u = Ellipse + { ell_ctm :: ShapeCTM u + , ell_rx :: !u + , ell_ry :: !u + } + +type DEllipse = Ellipse Double + +type instance DUnit (Ellipse u) = u + + + +mapEllipseCTM :: (ShapeCTM u -> ShapeCTM u) -> Ellipse u -> Ellipse u +mapEllipseCTM f = (\s i -> s { ell_ctm = f i }) <*> ell_ctm + +instance Num u => Scale (Ellipse u) where + scale sx sy = mapEllipseCTM (scale sx sy) + + +instance Rotate (Ellipse u) where + rotate ang = mapEllipseCTM (rotate ang) + + +instance (Real u, Floating u) => RotateAbout (Ellipse u) where + rotateAbout ang pt = mapEllipseCTM (rotateAbout ang pt) + + +instance Num u => Translate (Ellipse u) where + translate dx dy = mapEllipseCTM (translate dx dy) + + +runEllipse :: (u -> u -> ShapeCTM u -> a) -> Ellipse u -> a +runEllipse fn (Ellipse { ell_ctm = ctm, ell_rx = rx, ell_ry = ry }) = + fn rx ry ctm + + +-- | x_radius is the unit length. +-- +scaleEll :: (Scale t, Fractional u, u ~ DUnit t) => u -> u -> t -> t +scaleEll rx ry = scale 1 (ry/rx) + + +instance (Real u, Floating u) => CenterAnchor (Ellipse u) where + center = runEllipse $ \_ _ -> ctmCenter + + +instance (Real u, Floating u) => RadialAnchor (Ellipse u) where + radialAnchor theta = runEllipse $ \rx ry -> + projectPoint $ scaleEll rx ry $ zeroPt .+^ avec theta rx + + +instance (Real u, Floating u) => CardinalAnchor (Ellipse u) where + north = radialAnchor (0.5*pi) + south = radialAnchor (1.5*pi) + east = radialAnchor 0 + west = radialAnchor pi + + +instance (Real u, Floating u) => CardinalAnchor2 (Ellipse u) where + northeast = radialAnchor (0.25*pi) + southeast = radialAnchor (1.75*pi) + southwest = radialAnchor (1.25*pi) + northwest = radialAnchor (0.75*pi) + + + + +-- | 'ellipse' : @ x_radii * y_radii -> shape @ +-- +ellipse :: (Floating u, Ord u) => u -> u -> LocShape u (Ellipse u) +ellipse rx ry = + intoLocShape (mkEllipse rx ry) (mkEllipsePath rx ry) + + +mkEllipse :: Num u => u -> u -> LocCF u (Ellipse u) +mkEllipse rx ry = promoteR1 $ \ctr -> + pure $ Ellipse { ell_ctm = makeShapeCTM ctr, ell_rx = rx, ell_ry = ry } + +-- This is wrong... +-- +mkEllipsePath :: (Floating u, Ord u) => u -> u -> LocCF u (Path u) +mkEllipsePath rx ry = promoteR1 $ \(P2 x y) -> + pure $ traceCurvePoints $ map (translate x y . scaleEll rx ry) + $ bezierCircle 2 rx zeroPt + diff --git a/src/Wumpus/Drawing/Shapes/Rectangle.hs b/src/Wumpus/Drawing/Shapes/Rectangle.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Shapes/Rectangle.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Shapes.Rectangle +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Rectangle shape. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Shapes.Rectangle + ( + + Rectangle + , DRectangle + , rectangle + + ) where + +import Wumpus.Drawing.Geometry.Intersection +import Wumpus.Drawing.Geometry.Paths +import Wumpus.Drawing.Paths +import Wumpus.Drawing.Shapes.Base + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative + + + +-------------------------------------------------------------------------------- +-- Rectangle + +data Rectangle u = Rectangle + { rect_ctm :: ShapeCTM u + , rect_hw :: !u + , rect_hh :: !u + } + deriving (Eq,Ord,Show) + +type DRectangle = Rectangle Double + + +type instance DUnit (Rectangle u) = u + + +mapRectangleCTM :: (ShapeCTM u -> ShapeCTM u) -> Rectangle u -> Rectangle u +mapRectangleCTM f = (\s i -> s { rect_ctm = f i }) <*> rect_ctm + +instance Num u => Scale (Rectangle u) where + scale sx sy = mapRectangleCTM (scale sx sy) + + +instance Rotate (Rectangle u) where + rotate ang = mapRectangleCTM (rotate ang) + + +instance (Real u, Floating u) => RotateAbout (Rectangle u) where + rotateAbout ang pt = mapRectangleCTM (rotateAbout ang pt) + + +instance Num u => Translate (Rectangle u) where + translate dx dy = mapRectangleCTM (translate dx dy) + + + + +runRectangle :: (u -> u -> ShapeCTM u -> a) -> Rectangle u -> a +runRectangle fn (Rectangle { rect_ctm = ctm, rect_hw = hw, rect_hh = hh }) = + fn hw hh ctm + +instance (Real u, Floating u) => CenterAnchor (Rectangle u) where + center = runRectangle (\ _ _ -> ctmCenter) + +instance (Real u, Floating u) => CardinalAnchor (Rectangle u) where + north = runRectangle $ \_ hh -> projectPoint $ P2 0 hh + south = runRectangle $ \_ hh -> projectPoint $ P2 0 (-hh) + east = runRectangle $ \hw _ -> projectPoint $ P2 hw 0 + west = runRectangle $ \hw _ -> projectPoint $ P2 (-hw) 0 + +instance (Real u, Floating u) => CardinalAnchor2 (Rectangle u) where + northeast = runRectangle $ \hw hh -> projectPoint $ P2 hw hh + southeast = runRectangle $ \hw hh -> projectPoint $ P2 hw (-hh) + southwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) (-hh) + northwest = runRectangle $ \hw hh -> projectPoint $ P2 (-hw) hh + + +instance (Real u, Floating u) => RadialAnchor (Rectangle u) where + radialAnchor theta = runRectangle $ \hw hh -> + projectPoint $ rectangleIntersect hw hh theta + +-- Note - the answer needs projecting with the CTM... +-- +rectangleIntersect :: (Real u, Floating u) + => u -> u -> Radian -> Point2 u +rectangleIntersect hw hh theta = + maybe zeroPt id $ findIntersect zeroPt theta $ rectangleLines zeroPt hw hh + + + +-- | 'rectangle' : @ width * height -> shape @ +-- +rectangle :: (Real u, Floating u, FromPtSize u) + => u -> u -> LocShape u (Rectangle u) +rectangle w h = + intoLocShape (mkRectangle (0.5*w) (0.5*h)) + (mkRectPath (0.5*w) (0.5*h)) + + +mkRectangle :: Num u => u -> u -> LocCF u (Rectangle u) +mkRectangle hw hh = promoteR1 $ \ctr -> + pure $ Rectangle { rect_ctm = makeShapeCTM ctr + , rect_hw = hw + , rect_hh = hh + } + + +mkRectPath :: (Real u, Floating u, FromPtSize u) + => u -> u -> LocCF u (Path u) +mkRectPath hw hh = promoteR1 $ \ctr -> + let btm_left = displace (-hw) (-hh) ctr + in roundCornerShapePath $ rectangleCoordPath (2*hw) (2*hh) btm_left + + + diff --git a/src/Wumpus/Drawing/Text/LRText.hs b/src/Wumpus/Drawing/Text/LRText.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/LRText.hs @@ -0,0 +1,409 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.LRText +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Left-to-right measured text. The text uses glyph metrics so it +-- can be positioned accurately. +-- +-- \*\* WARNING \*\* - the API for this module needs work. The +-- current API is not satisfactory for drawing according to a +-- start position (there are other reasonable start positions than +-- the ones currently supported - adding them would explode the +-- number of definitions). +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.LRText + ( + + baseCenterLine + , baseLeftLine + , baseRightLine + + , rbaseCenterLine + , rbaseLeftLine + , rbaseRightLine + + , ctrCenterLine + , baseCenterEscChar + + , multiAlignLeft + , multiAlignCenter + , multiAlignRight + + , rmultiAlignLeft + , rmultiAlignCenter + , rmultiAlignRight + + + ) where + + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.Char +import qualified Data.Map as Map +import Data.Maybe + + +-- Note - BoundedLocThetaGraphic is probably an adequate type +-- even though the same text will have a different bounding box +-- if it is rotated (the sides of the BBox are always parallel to +-- the x and y axes even if the text is not parrale to the +-- x-axis). +-- +-- I cannot think of any compelling graphics that need a more +-- accurate type. The execption is text cannot have exact anchors +-- however this is a moot /if/ text is considered as a labelling +-- of an existing rectangle (which may or may not have been +-- rotated). +-- + + + +-- One line of multiline text +-- +data OnelineText u = OnelineText EscapedText (AdvanceVec u) + + +-- | max_width * oneline_text -> LocThetaGraphic +-- +type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u + + +-- | max_width * oneline_text -> LocThetaGraphic +-- +type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u + + +-- | Draw one line of left-aligned text, knowing the max_width +-- of all the lines of text. +-- +-- All left-aligned text is moved left by half the max_width. +-- +-- Note - implicit point is baseline-center, this is perhaps +-- unintituitive given the functions name but it is an +-- advantage for drawing multi-line text. +-- +drawLeftAligned :: Floating u => LocThetaDrawOneline u +drawLeftAligned max_width (OnelineText esc _) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel ((-0.5) * max_width) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + + +-- | Draw one line of center-aligned text. Center aligned text is +-- oblivious to the max_width of all the lines of text. +-- +-- Each line of center-aligned text is moved left by half its +-- advance vector. +-- +-- Implicit point is baseline-center. +-- +drawCenterAligned :: Floating u => LocThetaDrawOneline u +drawCenterAligned _ (OnelineText esc av) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel (negate $ 0.5 * advanceH av) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + +-- | Draw one line of right-aligned text, knowing the max_width +-- of all the lines of text. +-- +-- Each right-aligned text line is moved by the width component +-- of the advance vector minus half the max width. +-- +-- Note - implicit point is baseline-center, this is perhaps +-- unintituitive given the functions name but it is an +-- advantage for drawing multi-line text. +-- +drawRightAligned :: Floating u => LocThetaDrawOneline u +drawRightAligned max_width (OnelineText esc av) = + promoteR2 $ \baseline_ctr theta -> + let mv = displaceParallel ((0.5 * max_width) - advanceH av) theta + in apply2R2 (rescapedline esc) (mv baseline_ctr) theta + + + + +-- Impilict point is baseline-center. +-- +onelineBBox :: (Real u, Floating u, FromPtSize u) + => OnelineText u -> LocThetaDrawingInfo u (BoundingBox u) +onelineBBox (OnelineText _ av) = + promoteR2 $ \baseline_ctr theta -> + glyphHeightRange >>= \(ymin, ymax) -> + getTextMargin >>= \(xsep, ysep) -> + let hw = 0.5 * advanceH av + btm_left = baseline_ctr .+^ vec (-hw) ymin + top_right = baseline_ctr .+^ vec hw ymax + bbox = expandBB xsep ysep (BBox btm_left top_right) + in pure $ centerOrthoBBox theta bbox + where + expandBB xsep ysep (BBox (P2 x0 y0) (P2 x1 y1)) = + BBox (P2 (x0-xsep) (y0-ysep)) (P2 (x1+xsep) (y1+ysep)) + + + + + + + +-- This should have max_width as a param... +-- +makeMoveableLine :: (Real u, Floating u, FromPtSize u) + => LocThetaDrawOneline u + -> BoundedLocThetaOneline u +makeMoveableLine drawF max_width oline = + intoLocThetaImage (onelineBBox oline) (drawF max_width oline) + +onelineAlg :: (Real u, Floating u, FromPtSize u) + => DisplaceFun u + -> LocThetaDrawOneline u + -> EscapedText + -> BoundedLocThetaGraphic u +onelineAlg ptMoveF drawF esc = + promoteR2 $ \pt theta -> + onelineEscText esc >>= \ans@(OnelineText _ av) -> + let max_width = advanceH av + move = ptMoveF max_width ans theta + in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta + + + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-left. +-- + +baseLeftLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseLeftLine ss = rbaseLeftLine ss `rot` 0 + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-center. +-- +baseCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseCenterLine ss = rbaseCenterLine ss `rot` 0 + + + + +-- | Draw 1 line... +-- +-- Impilict point is baseline-right. +-- +baseRightLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +baseRightLine ss = rbaseRightLine ss `rot` 0 + + + +rbaseLeftLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseLeftLine ss = + onelineAlg leftToCenter drawLeftAligned (escapeString ss) + + +rbaseCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseCenterLine ss = + onelineAlg centerToCenter drawCenterAligned (escapeString ss) + + +rbaseRightLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocThetaGraphic u +rbaseRightLine ss = + onelineAlg rightToCenter drawRightAligned (escapeString ss) + + +-- Note - assumes the ymin of the font is 0 or less. +-- +ctrCenterLine :: (Real u, Floating u, FromPtSize u) + => String -> BoundedLocGraphic u +ctrCenterLine ss = + glyphHeightRange >>= \(ymin, ymax) -> + let hh = 0.5 * ymax - ymin in + moveStartPoint (displaceV $ negate $ hh - abs ymin) $ baseCenterLine ss + + + +baseCenterEscChar :: (Real u, Floating u, FromPtSize u) + => EscapedChar -> BoundedLocGraphic u +baseCenterEscChar esc = body `rot` 0 + where + body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc) + + + + + + +-- | max_width * interim_text * theta -> (Point -> Point) +-- +type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u + +centerToCenter :: DisplaceFun u +centerToCenter _ _ _ = id + +leftToCenter :: Floating u => DisplaceFun u +leftToCenter max_width _ theta = + displaceParallel (0.5 * max_width) theta + +rightToCenter :: Floating u => DisplaceFun u +rightToCenter max_width (OnelineText _ av) theta = + displaceParallel ((0.5 * max_width) - advanceH av) theta + + + + +multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignLeft ss = rmultiAlignLeft ss `rot` 0 + + +multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignCenter ss = rmultiAlignCenter ss `rot` 0 + + + + +multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocGraphic u +multiAlignRight ss = rmultiAlignRight ss `rot` 0 + + +rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned) + + +rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned) + + +rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u) + => String + -> BoundedLocThetaGraphic u +rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned) + + + +multilineTEXT :: (Floating u, Ord u, FromPtSize u) + => BoundedLocThetaOneline u + -> String + -> BoundedLocThetaGraphic u +multilineTEXT _ [] = lift1R2 emptyBoundedLocGraphic +multilineTEXT mf ss = + lift0R2 (linesToInterims ss) >>= \(max_av, itexts) -> + centralPoints (length itexts) >>= \pts -> + zipMultis (advanceH max_av) mf itexts pts + + + + +zipMultis :: (Ord u, FromPtSize u) + => u + -> BoundedLocThetaOneline u + -> [OnelineText u] -> [Point2 u] + -> BoundedLocThetaGraphic u +zipMultis _ _ [] _ = lift1R2 $ emptyBoundedLocGraphic +zipMultis _ _ _ [] = lift1R2 $ emptyBoundedLocGraphic +zipMultis max_w mf (a:as) (b:bs) = step a b as bs + where + mkGraphic itext pt = promoteR2 $ \_ theta -> + apply2R2 (mf max_w itext) pt theta + step r s (r2:rs) (s2:ss) = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss) + step r s _ _ = mkGraphic r s + + + + +-- | @ana@ is an /anacrusis/ factor - if there are even points +-- half the baseline_spacing is added to get the top point +-- +centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u] +centralPoints n | n < 2 = promoteR2 $ \ctr _ -> return [ctr] + | even n = body (n `div` 2) (0.5*) + | otherwise = body (n `div` 2) (0 *) + where + body halfn ana = promoteR2 $ \ctr theta -> + baselineSpacing >>= \h -> + let y0 = (h * fromIntegral halfn) + ana h + top = displacePerpendicular y0 theta ctr + in pure $ trailPoints n h theta top + + + +trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u] +trailPoints n height theta top = take n $ iterate fn top + where + fn pt = displacePerpendicular (-height) theta pt + + + +-------------------------------------------------------------------------------- + +-- This isn't worth the complexity to get down to one traversal... + +linesToInterims :: (FromPtSize u, Ord u) + => String -> DrawingInfo (AdvanceVec u, [OnelineText u]) +linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines + where + post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs) + fn (OnelineText _ av) vmax = avMaxWidth av vmax + +avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u +avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a + +onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u) +onelineEscText esc = fmap (OnelineText esc) $ textVector esc + + + +textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u) +textVector esc = + cwLookupTable >>= \table -> + let cs = destrEscapedText id esc + in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs + + + + +charWidth :: FromPtSize u + => CharWidthTable u -> EscapedChar -> AdvanceVec u +charWidth fn (CharLiteral c) = fn $ ord c +charWidth fn (CharEscInt i) = fn i +charWidth fn (CharEscName s) = fn ix + where + ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices diff --git a/src/Wumpus/Drawing/Text/SafeFonts.hs b/src/Wumpus/Drawing/Text/SafeFonts.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Text/SafeFonts.hs @@ -0,0 +1,167 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Text.SafeFonts +-- Copyright : (c) Stephen Tetley 2009-2010 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Safe to use \"Core 13\" fonts that are expected to be present +-- for any PostScript interpreter. +-- +-- Note - regrettably Symbol is not safe to use for SVG. +-- +-- \*\* WARNING \*\* - this module is in flux due to changes to +-- Text encoding in Wumpus-Core and adding font metrics to +-- Wumpus-Basic. The code here is likely to be revised. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Text.SafeFonts + ( + -- * Times Roman + times_roman + , times_italic + , times_bold + , times_bold_italic + + -- * Helvetica + , helvetica + , helvetica_oblique + , helvetica_bold + , helvetica_bold_oblique + + -- * Courier + , courier + , courier_oblique + , courier_bold + , courier_bold_oblique + + -- * Symbol + , symbol + + ) where + + + +import Wumpus.Core +import Wumpus.Core.Text.StandardEncoding +import Wumpus.Core.Text.Symbol + +-- Supported fonts are: +-- +-- Times-Roman Times-Italic Times-Bold Times-BoldItalic +-- Helvetica Helvetica-Oblique Helvetica-Bold Helvetica-Bold-Oblique +-- Courier Courier-Oblique Courier-Bold Courier-Bold-Oblique +-- Symbol + +-------------------------------------------------------------------------------- +-- + +-- | Times-Roman +-- +times_roman :: FontFace +times_roman = + FontFace "Times-Roman" "Times New Roman" SVG_REGULAR standard_encoding + +-- | Times Italic +-- +times_italic :: FontFace +times_italic = + FontFace "Times-Italic" "Times New Roman" SVG_ITALIC standard_encoding + +-- | Times Bold +-- +times_bold :: FontFace +times_bold = + FontFace "Times-Bold" "Times New Roman" SVG_BOLD standard_encoding + +-- | Times Bold Italic +-- +times_bold_italic :: FontFace +times_bold_italic = FontFace "Times-BoldItalic" + "Times New Roman" + SVG_BOLD_ITALIC + standard_encoding + + +-------------------------------------------------------------------------------- +-- Helvetica + +-- | Helvetica +-- +helvetica :: FontFace +helvetica = FontFace "Helvetica" "Helvetica" SVG_REGULAR standard_encoding + + +-- | Helvetica Oblique +-- +helvetica_oblique :: FontFace +helvetica_oblique = + FontFace "Helvetica-Oblique" "Helvetica" SVG_OBLIQUE standard_encoding + +-- | Helvetica Bold +-- +helvetica_bold :: FontFace +helvetica_bold = + FontFace "Helvetica-Bold" "Helvetica" SVG_BOLD standard_encoding + + +-- | Helvetica Bold Oblique +-- +helvetica_bold_oblique :: FontFace +helvetica_bold_oblique = FontFace "Helvetica-Bold-Oblique" + "Helvetica" + SVG_BOLD_OBLIQUE + standard_encoding + + + +-------------------------------------------------------------------------------- + +-- | Courier +-- +courier :: FontFace +courier = FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding + +-- | Courier Oblique +-- +courier_oblique :: FontFace +courier_oblique = + FontFace "Courier-Oblique" "Courier New" SVG_OBLIQUE standard_encoding + +-- | Courier Bold +-- +courier_bold :: FontFace +courier_bold = + FontFace "Courier-Bold" "Courier New" SVG_BOLD standard_encoding + + +-- | Courier Bold Oblique +-- +courier_bold_oblique :: FontFace +courier_bold_oblique = FontFace "Courier-Bold-Oblique" + "Courier New" + SVG_BOLD_OBLIQUE + standard_encoding + +-------------------------------------------------------------------------------- +-- Symbol + +-- | Symbol +-- +-- Note - Symbol is intentionally not supported for SVG by some +-- renderers (Firefox). Chrome is fine, but the use of symbol +-- should be still be avoided for web graphics. +-- +symbol :: FontFace +symbol = FontFace "Symbol" "Symbol" SVG_REGULAR symbol_encoding + + + + + diff --git a/src/Wumpus/Drawing/Turtle/TurtleClass.hs b/src/Wumpus/Drawing/Turtle/TurtleClass.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Turtle/TurtleClass.hs @@ -0,0 +1,91 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Turtle.TurtleClass +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Turtle monad and monad transformer. +-- +-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor. +-- +-- While Wumpus generally aims for a more compositional, +-- \"coordinate-free\" style of drawing, some types of diagram +-- are more easily expressed in the LOGO style. +-- +-- Note - as turtle drawing with Wumpus is a /local effect/, +-- there is only one instance of TurtleM. Potentially TurtleM +-- will be removed and the functions implemented directly. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Turtle.TurtleClass + ( + + Coord + + , TurtleM(..) + + , setsLoc + , setsLoc_ + + -- * movement + , resetLoc + , moveLeft + , moveRight + , moveUp + , moveDown + , nextLine + + + ) where + + + +type Coord = (Int,Int) + + +class Monad m => TurtleM m where + getLoc :: m (Int,Int) + setLoc :: (Int,Int) -> m () + getOrigin :: m (Int,Int) + setOrigin :: (Int,Int) -> m () + + + +setsLoc :: TurtleM m => (Coord -> (a,Coord)) -> m a +setsLoc f = getLoc >>= \coord -> + let (a,coord') = f coord in setLoc coord' >> return a + +setsLoc_ :: TurtleM m => (Coord -> Coord) -> m () +setsLoc_ f = getLoc >>= \coord -> setLoc (f coord) + + +resetLoc :: TurtleM m => m () +resetLoc = getOrigin >>= setLoc + + +moveRight :: TurtleM m => m () +moveRight = setsLoc_ $ \(x,y)-> (x+1, y) + + +moveLeft :: TurtleM m => m () +moveLeft = setsLoc_ $ \(x,y) -> (x-1,y) + +moveUp :: TurtleM m => m () +moveUp = setsLoc_ $ \(x,y) -> (x,y+1) + +moveDown :: TurtleM m => m () +moveDown = setsLoc_ $ \(x,y) -> (x ,y-1) + + +nextLine :: TurtleM m => m () +nextLine = getOrigin >>= \(ox,_) -> + setsLoc_ $ \(_,y) -> (ox,y-1) + diff --git a/src/Wumpus/Drawing/Turtle/TurtleMonad.hs b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/Turtle/TurtleMonad.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.Turtle.TurtleMonad +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Turtle monad transformer. +-- +-- The Turtle monad embodies the LOGO style of imperative +-- drawing - sending commands to update the a cursor. +-- +-- While Wumpus generally aims for a more compositional, +-- \"coordinate-free\" style of drawing, some types of +-- diagram are more easily expressed in the LOGO style. +-- +-- Turtle is only a transformer - it is intended to be run within +-- a 'Drawing'. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.Turtle.TurtleMonad + ( + -- * Re-exports + module Wumpus.Drawing.Turtle.TurtleClass + + -- * Turtle transformer + , TurtleT + , runTurtleT + + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Drawing.Turtle.TurtleClass + + + +import Control.Applicative +import Control.Monad + + +-- Note - if Turtle is now just a /local effect/ monad is the +-- Turtle class still needed? Afterall, there is (probably) +-- only ever going to be one instance. +-- + +-- Turtle is a Reader / State monad +-- +-- The env is the horizontal and vertical move distances. +-- +-- The state is the current coordinate and the origin. +-- + +data TurtleState = TurtleState + { _turtle_origin :: (Int,Int) + , _current_coord :: (Int,Int) + } + +newtype TurtleT u m a = TurtleT { + getTurtleT :: ScalingContext Int Int u + -> TurtleState + -> m (a, TurtleState) } + +type instance MonUnit (TurtleT u m) = u + + + +-- Functor + + + +instance Monad m => Functor (TurtleT u m) where + fmap f m = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') -> + return (f a, s') + + +-- Applicative + +instance Monad m => Applicative (TurtleT u m) where + pure a = TurtleT $ \_ s -> return (a,s) + mf <*> ma = TurtleT $ \r s -> getTurtleT mf r s >>= \(f,s') -> + getTurtleT ma r s' >>= \(a,s'') -> + return (f a,s'') + + +-- Monad + +instance Monad m => Monad (TurtleT u m) where + return a = TurtleT $ \_ s -> return (a,s) + m >>= k = TurtleT $ \r s -> getTurtleT m r s >>= \(a,s') -> + (getTurtleT . k) a r s' >>= \(b,s'') -> + return (b,s'') + + + + +instance Monad m => TurtleM (TurtleT u m) where + getLoc = TurtleT $ \_ s@(TurtleState _ c) -> return (c,s) + setLoc c = TurtleT $ \_ (TurtleState o _) -> return ((),TurtleState o c) + getOrigin = TurtleT $ \_ s@(TurtleState o _) -> return (o,s) + setOrigin o = TurtleT $ \_ (TurtleState _ c) -> return ((),TurtleState o c) + + +runTurtleT :: (Monad m, Num u) + => (Int,Int) -> ScalingContext Int Int u -> TurtleT u m a -> m a +runTurtleT ogin cfg mf = getTurtleT mf cfg st0 >>= \(a,_) -> return a + where + st0 = TurtleState ogin ogin + + + +---------------------------------------------------------------------------------- +-- Cross instances + +instance DrawingCtxM m => DrawingCtxM (TurtleT u m) where + askDC = TurtleT $ \_ s -> askDC >>= \ ctx -> return (ctx,s) + localize upd mf = TurtleT $ \r s -> localize upd (getTurtleT mf r s) + + +-- This needs undecidable instances... + +instance (Monad m, TraceM m, u ~ MonUnit m) => TraceM (TurtleT u m) where + trace a = TurtleT $ \_ s -> trace a >> return ((),s) + + +instance (Monad m, u ~ MonUnit m, Num u) => PointSupplyM (TurtleT u m) where + position = TurtleT $ \r s@(TurtleState _ (x,y)) -> return (scalePt r x y,s) + diff --git a/src/Wumpus/Drawing/VersionNumber.hs b/src/Wumpus/Drawing/VersionNumber.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Drawing/VersionNumber.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Drawing.VersionNumber +-- Copyright : (c) Stephen Tetley 2010 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : unstable +-- Portability : GHC +-- +-- Version number +-- +-------------------------------------------------------------------------------- + +module Wumpus.Drawing.VersionNumber + ( + wumpus_drawing_version + + ) where + + +-- | Version number +-- +-- > (0,1,0) +-- +wumpus_drawing_version :: (Int,Int,Int) +wumpus_drawing_version = (0,1,0) diff --git a/wumpus-drawing.cabal b/wumpus-drawing.cabal new file mode 100644 --- /dev/null +++ b/wumpus-drawing.cabal @@ -0,0 +1,132 @@ +name: wumpus-drawing +version: 0.1.0 +license: BSD3 +license-file: LICENSE +copyright: Stephen Tetley +maintainer: Stephen Tetley +homepage: http://code.google.com/p/copperbox/ +category: Graphics +synopsis: High-level drawing objects built on Wumpus-Basic. +description: + . + \*\* WARNING \*\* - this package is sub-alpha. Although many of + the drawing objects have been improved since the code was split + from Wumpus-Basic, the code is still prototypical. Essentially + this package is a /technology preview/ and not a re-usable + library. + . + NOTE - many of the demos use font metrics. Font metrics for + the \"Core 14\" PostScript fonts are distributed as @*.afm@ + files with GhostScript in the @fonts@ directory. Wumpus expects + the GhostScript font metrics to be AFM version 2.0 files (this + matches GhostScript 8.63). Alternatively, metrics for the Core + 14 fonts are available from Adode (AFM version 4.1), see the + links below. To run the demos properly you will need one of + these sets of metrics. + . + Adobe Font techinal notes: + + . + Core 14 AFM metrics: + + . + Also note that Wumpus uses fallback metrics (derived from the + monospaced Courier font) when font loading fails, rather than + throwing a terminal error. Applications should ideally check + the font loading log to ensure that fonts have loaded correctly + (the demos print this log to standard out). + . + Changelog: + . + v0.1.0: + . + * Initial release - this is a split from @Wumpus-Basic@ making + the (very prototypical - read sub-alpha, unstable...) modules + in the @Drawing@ hierarchy a separate package. + . + * Simplified Chains - chains are now regular lists (though often + infinite). Drawings are made with chains using new zip-like + functions. + . + * Re-worked Shapes. + . + * Re-worked Arrow and Arrow Tip types. + . + * Re-worked ConnectorPaths. + . +build-type: Simple +stability: highly unstable +cabal-version: >= 1.2 + +extra-source-files: + CHANGES, + LICENSE, + demo/ArrowCircuit.hs, + demo/Arrowheads.hs, + demo/ClipPic.hs, + demo/ColourCharts.hs, + demo/ColourChartUtils.hs, + demo/Connectors.hs + demo/DotPic.hs, + demo/FeatureModel.hs, + demo/FontLoaderUtils.hs, + demo/FontPic.hs, + demo/LeftRightText.hs, + demo/PetriNet.hs, + demo/PictureCompo.hs, + demo/Symbols.hs, + demo/TableChains.hs + +library + hs-source-dirs: src + build-depends: base < 5, + containers >= 0.3 && <= 0.6, + directory >= 1.0 && < 2.0, + filepath >= 1.1 && < 2.0, + vector-space >= 0.6 && < 1.0, + wumpus-core >= 0.42.0 && < 0.43.0, + wumpus-basic == 0.15.0 + + + exposed-modules: + Wumpus.Drawing.Arrows, + Wumpus.Drawing.Arrows.Connectors, + Wumpus.Drawing.Arrows.Tips, + Wumpus.Drawing.Chains, + Wumpus.Drawing.Chains.Base, + Wumpus.Drawing.Chains.Derived, + Wumpus.Drawing.Colour.SVGColours, + Wumpus.Drawing.Colour.X11Colours, + Wumpus.Drawing.Dots.AnchorDots, + Wumpus.Drawing.Dots.Marks, + Wumpus.Drawing.Geometry.Intersection, + Wumpus.Drawing.Geometry.Paths, + Wumpus.Drawing.Paths, + Wumpus.Drawing.Paths.Base, + Wumpus.Drawing.Paths.Connectors, + Wumpus.Drawing.Paths.MonadicConstruction, + Wumpus.Drawing.Paths.ControlPoints, + Wumpus.Drawing.Shapes, + Wumpus.Drawing.Shapes.Base, + Wumpus.Drawing.Shapes.Circle, + Wumpus.Drawing.Shapes.Diamond, + Wumpus.Drawing.Shapes.Ellipse, + Wumpus.Drawing.Shapes.Rectangle, + Wumpus.Drawing.Text.LRText, + Wumpus.Drawing.Text.SafeFonts, + Wumpus.Drawing.Turtle.TurtleClass, + Wumpus.Drawing.Turtle.TurtleMonad, + Wumpus.Drawing.VersionNumber + + other-modules: + + extensions: + + + ghc-options: + + includes: + + + +