{-# 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.Drawing.Colour.SVGColours
import Wumpus.Drawing.Extras.Clip
import Wumpus.Drawing.Paths.Relative
import Wumpus.Drawing.Text.StandardFontDefs
import Wumpus.Basic.Kernel -- package: wumpus-basic
import Wumpus.Core -- package: wumpus-core
import Data.AffineSpace -- package: vector-space
import Data.Monoid
import System.Directory
main :: IO ()
main = do
createDirectoryIfMissing True "./out/"
let pic1 = runCtxPictureU std_ctx clip_pic
writeEPS "./out/clip_pic.eps" pic1
writeSVG "./out/clip_pic.svg" pic1
std_ctx :: DrawingContext
std_ctx = standardContext 14
clip_pic :: CtxPicture
clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do
drawl (P2 0 320) $ closedRelPath FILL path01
drawl (P2 112 320) $ localize (fill_colour powder_blue) $ closedRelPath FILL path02
drawl (P2 384 416) $ closedRelPath FILL path03
drawl (P2 328 512) $ closedRelPath FILL path04
drawl (P2 0 0) $ clip1
drawl (P2 112 0) $ clip2
drawl (P2 384 96) $ clip3
drawl (P2 328 192) $ clip4
background :: RGBi -> LocGraphic Double
background rgb = promoteLoc $ \_ ->
ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288
where
ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell)
clip1 :: LocGraphic Double
clip1 = locClip path01 $ background black
clip2 :: LocGraphic Double
clip2 = locClip path02 $ background medium_violet_red
clip3 :: LocGraphic Double
clip3 = locClip path03 $ background black
clip4 :: LocGraphic Double
clip4 = locClip path04 $ background black
iheartHaskell :: LocGraphic Double
iheartHaskell = promoteLoc $ \pt ->
let body = dcTextlabel "I Haskell" `at` pt
heart = localize (set_font symbol) $
dcTextlabel "&heart;" `at` (pt .+^ hvec 7)
in body `mappend` heart
-- zeroPt
path01 :: RelPath Double
path01 = evalPathSpec $ hline 80
>> line (vec 112 160)
>> line (vec (-112) 160)
>> hline (-80)
>> line (vec 112 (-160))
>> line (vec (-112) (-160))
-- (P2 112 0)
path02 :: RelPath Double
path02 = evalPathSpec $ hline 80
>> line (vec 72 112)
>> line (vec 72 (-112))
>> hline 80
>> line (vec (-224) 320)
>> hline (-80)
>> line (vec 112 (-160))
>> line (vec (-112) (-160))
-- (P2 384 96)
path03 :: RelPath Double
path03 = evalPathSpec $ hline 96 >> vline 56 >> hline (-136)
-- (P2 328 192)
path04 :: RelPath Double
path04 = evalPathSpec $ hline 152 >> vline 56 >> hline (-192)