wumpus-drawing (empty) → 0.1.0
raw patch · 47 files changed
+8879/−0 lines, 47 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, filepath, vector-space, wumpus-basic, wumpus-core
Files
- CHANGES +4/−0
- LICENSE +30/−0
- Setup.hs +29/−0
- demo/ArrowCircuit.hs +118/−0
- demo/Arrowheads.hs +83/−0
- demo/ClipPic.hs +104/−0
- demo/ColourChartUtils.hs +502/−0
- demo/ColourCharts.hs +57/−0
- demo/Connectors.hs +72/−0
- demo/DotPic.hs +123/−0
- demo/FeatureModel.hs +136/−0
- demo/FontLoaderUtils.hs +95/−0
- demo/FontPic.hs +116/−0
- demo/LeftRightText.hs +195/−0
- demo/PetriNet.hs +158/−0
- demo/PictureCompo.hs +151/−0
- demo/Symbols.hs +221/−0
- demo/TableChains.hs +44/−0
- src/Wumpus/Drawing/Arrows.hs +28/−0
- src/Wumpus/Drawing/Arrows/Connectors.hs +104/−0
- src/Wumpus/Drawing/Arrows/Tips.hs +515/−0
- src/Wumpus/Drawing/Chains.hs +29/−0
- src/Wumpus/Drawing/Chains/Base.hs +117/−0
- src/Wumpus/Drawing/Chains/Derived.hs +126/−0
- src/Wumpus/Drawing/Colour/SVGColours.hs +625/−0
- src/Wumpus/Drawing/Colour/X11Colours.hs +1282/−0
- src/Wumpus/Drawing/Dots/AnchorDots.hs +286/−0
- src/Wumpus/Drawing/Dots/Marks.hs +243/−0
- src/Wumpus/Drawing/Geometry/Intersection.hs +173/−0
- src/Wumpus/Drawing/Geometry/Paths.hs +138/−0
- src/Wumpus/Drawing/Paths.hs +31/−0
- src/Wumpus/Drawing/Paths/Base.hs +650/−0
- src/Wumpus/Drawing/Paths/Connectors.hs +247/−0
- src/Wumpus/Drawing/Paths/ControlPoints.hs +189/−0
- src/Wumpus/Drawing/Paths/MonadicConstruction.hs +160/−0
- src/Wumpus/Drawing/Shapes.hs +31/−0
- src/Wumpus/Drawing/Shapes/Base.hs +151/−0
- src/Wumpus/Drawing/Shapes/Circle.hs +127/−0
- src/Wumpus/Drawing/Shapes/Diamond.hs +152/−0
- src/Wumpus/Drawing/Shapes/Ellipse.hs +134/−0
- src/Wumpus/Drawing/Shapes/Rectangle.hs +136/−0
- src/Wumpus/Drawing/Text/LRText.hs +409/−0
- src/Wumpus/Drawing/Text/SafeFonts.hs +167/−0
- src/Wumpus/Drawing/Turtle/TurtleClass.hs +91/−0
- src/Wumpus/Drawing/Turtle/TurtleMonad.hs +139/−0
- src/Wumpus/Drawing/VersionNumber.hs +29/−0
- wumpus-drawing.cabal +132/−0
+ CHANGES view
@@ -0,0 +1,4 @@++0.1.0:++ * Initial split from Wumpus-Basic.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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
+ demo/ArrowCircuit.hs view
@@ -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)
+ demo/Arrowheads.hs view
@@ -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) +
+ demo/ClipPic.hs view
@@ -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) +
+ demo/ColourChartUtils.hs view
@@ -0,0 +1,502 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : ColourChartUtils+-- Copyright : (c) Stephen Tetley 2009+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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)+ ]++++
+ demo/ColourCharts.hs view
@@ -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)+ +
+ demo/Connectors.hs view
@@ -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+ +
+ demo/DotPic.hs view
@@ -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+
+ demo/FeatureModel.hs view
@@ -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 ()
+ demo/FontLoaderUtils.hs view
@@ -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+
+ demo/FontPic.hs view
@@ -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) ]
+ demo/LeftRightText.hs view
@@ -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."+ ]
+ demo/PetriNet.hs view
@@ -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)
+ demo/PictureCompo.hs view
@@ -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))+
+ demo/Symbols.hs view
@@ -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")+ ]+
+ demo/TableChains.hs view
@@ -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++
+ src/Wumpus/Drawing/Arrows.hs view
@@ -0,0 +1,28 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Arrows+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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++
+ src/Wumpus/Drawing/Arrows/Connectors.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Arrows.Connectors+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Arrows/Tips.hs view
@@ -0,0 +1,515 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Arrows.Tips+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Chains.hs view
@@ -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
+ src/Wumpus/Drawing/Chains/Base.hs view
@@ -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?).+--+
+ src/Wumpus/Drawing/Chains/Derived.hs view
@@ -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++
+ src/Wumpus/Drawing/Colour/SVGColours.hs view
@@ -0,0 +1,625 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Colour.SVGColours+-- Copyright : (c) Stephen Tetley 2009-2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+++++
+ src/Wumpus/Drawing/Colour/X11Colours.hs view
@@ -0,0 +1,1282 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Colour.X11Colours+-- Copyright : (c) Stephen Tetley 2009-2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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++++++
+ src/Wumpus/Drawing/Dots/AnchorDots.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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]
+ src/Wumpus/Drawing/Dots/Marks.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Dots.Marks+-- Copyright : (c) Stephen Tetley 2010-2011+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Geometry/Intersection.hs view
@@ -0,0 +1,173 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Geometry.Intersection+-- Copyright : (c) Stephen Tetley 2010-2011+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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
+ src/Wumpus/Drawing/Geometry/Paths.hs view
@@ -0,0 +1,138 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Geometry.Paths+-- Copyright : (c) Stephen Tetley 2010-2011+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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)+
+ src/Wumpus/Drawing/Paths.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Paths+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Paths/Base.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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)+
+ src/Wumpus/Drawing/Paths/Connectors.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Paths.Connectors+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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]+
+ src/Wumpus/Drawing/Paths/ControlPoints.hs view
@@ -0,0 +1,189 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Paths.ControlPoints+-- Copyright : (c) Stephen Tetley 2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Paths/MonadicConstruction.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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)+
+ src/Wumpus/Drawing/Shapes.hs view
@@ -0,0 +1,31 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Shapes+-- Copyright : (c) Stephen Tetley 2010-2011+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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
+ src/Wumpus/Drawing/Shapes/Base.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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)+
+ src/Wumpus/Drawing/Shapes/Circle.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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 ++++
+ src/Wumpus/Drawing/Shapes/Diamond.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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 ++
+ src/Wumpus/Drawing/Shapes/Ellipse.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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+
+ src/Wumpus/Drawing/Shapes/Rectangle.hs view
@@ -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 <stephen.tetley@gmail.com>+-- 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+ ++
+ src/Wumpus/Drawing/Text/LRText.hs view
@@ -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
+ src/Wumpus/Drawing/Text/SafeFonts.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS -Wall #-}++--------------------------------------------------------------------------------+-- |+-- Module : Wumpus.Drawing.Text.SafeFonts+-- Copyright : (c) Stephen Tetley 2009-2010+-- License : BSD3+--+-- Maintainer : Stephen Tetley <stephen.tetley@gmail.com>+-- 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+++++
+ src/Wumpus/Drawing/Turtle/TurtleClass.hs view
@@ -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)+
+ src/Wumpus/Drawing/Turtle/TurtleMonad.hs view
@@ -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)+
+ src/Wumpus/Drawing/VersionNumber.hs view
@@ -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)
+ wumpus-drawing.cabal view
@@ -0,0 +1,132 @@+name: wumpus-drawing+version: 0.1.0+license: BSD3+license-file: LICENSE+copyright: Stephen Tetley <stephen.tetley@gmail.com>+maintainer: Stephen Tetley <stephen.tetley@gmail.com>+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:+ <https://www.adobe.com/devnet/font.html>+ .+ Core 14 AFM metrics:+ <https://www.adobe.com/content/dam/Adobe/en/devnet/font/pdfs/Core14_AFMs.tar>+ .+ 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: + ++ +