-----------------------------------------------------------------------
--
-- Haskell: The Craft of Functional Programming, 3e
-- Simon Thompson
-- (c) Addison-Wesley, 1996-2011.
--
-- PicturesSVG
--
-- The Pictures functionality implemented by translation
-- SVG (Scalable Vector Graphics)
--
-- These Pictures could be rendered by conversion to ASCII art,
-- but instead are rendered into SVG, which can then be viewed in
-- a browser: google chrome does a good job.
--
-----------------------------------------------------------------------
module PicturesSVG where
import System.IO
-- Pictures represened by a type of trees, so this is a deep
-- embedding.
data Picture
= Img Image
| Above Picture Picture
| Beside Picture Picture
| Over Picture Picture
| FlipH Picture
| FlipV Picture
| Negative Picture
deriving (Show)
-- Coordinates are pairs (x,y) of integers
--
-- o------> x axis
-- |
-- |
-- V
-- y axis
type Point = (Int,Int)
-- The Point in an Image gives the dimensions of the image in pixels.
data Image = Image Name Point
deriving (Show)
data Name = Name String
deriving (Show)
--
-- The functions over Pictures
--
above, beside, over :: Picture -> Picture -> Picture
above = Above
beside = Beside
over = Over
-- flipH is flip in a horizontal axis
-- flipV is flip in a vertical axis
-- negative negates each pixel
-- The definitions of flipH, flipV, negative push the
-- constructors through the binary operations to the images
-- at the leaves.
-- Original implementation incorrect: it pushed the
-- flipH and flipV through all constructors ...
-- Now it distributes appropriately over Above, Beside and Over.
flipH, flipV, negative :: Picture -> Picture
flipH (Above pic1 pic2) = (flipH pic2) `Above` (flipH pic1)
flipH (Beside pic1 pic2) = (flipH pic1) `Beside` (flipH pic2)
flipH (Over pic1 pic2) = (flipH pic1) `Over` (flipH pic2)
flipH pic = FlipH pic
flipV (Above pic1 pic2) = (flipV pic1) `Above` (flipV pic2)
flipV (Beside pic1 pic2) = (flipV pic2) `Beside` (flipV pic1)
flipV (Over pic1 pic2) = (flipV pic1) `Over` (flipV pic2)
flipV pic = FlipV pic
negative = Negative
invertColour = Negative
-- Convert an Image to a Picture
img :: Image -> Picture
img = Img
--
-- Library functions
--
-- Dimensions of pictures
width,height :: Picture -> Int
width (Img (Image _ (x,_))) = x
width (Above pic1 pic2) = max (width pic1) (width pic2)
width (Beside pic1 pic2) = (width pic1) + (width pic2)
width (Over pic1 pic2) = max (width pic1) (width pic2)
width (FlipH pic) = width pic
width (FlipV pic) = width pic
width (Negative pic) = width pic
height (Img (Image _ (x,y))) = y
height (Above pic1 pic2) = (height pic1) + (height pic2)
height (Beside pic1 pic2) = max (height pic1) (height pic2)
height (Over pic1 pic2) = max (height pic1) (height pic2)
height (FlipH pic) = height pic
height (FlipV pic) = height pic
height (Negative pic) = height pic
--
-- Converting pictures to a list of basic images.
--
-- A Filter represents which of the actions of flipH, flipV
-- and negative is to be applied to an image in forming a
-- Basic picture.
data Filter = Filter {fH, fV, neg :: Bool}
deriving (Show)
newFilter = Filter False False False
data Basic = Basic Image Point Filter
deriving (Show)
-- Flatten a picture into a list of Basic pictures.
-- The Point argument gives the origin for the coversion of the
-- argument.
flatten :: Point -> Picture -> [Basic]
flatten (x,y) (Img image) = [Basic image (x,y) newFilter]
flatten (x,y) (Above pic1 pic2) = flatten (x,y) pic1 ++ flatten (x, y + height pic1) pic2
flatten (x,y) (Beside pic1 pic2) = flatten (x,y) pic1 ++ flatten (x + width pic1 , y) pic2
flatten (x,y) (Over pic1 pic2) = flatten (x,y) pic1 ++ flatten (x,y) pic2
flatten (x,y) (FlipH pic) = map flipFH $ flatten (x,y) pic
flatten (x,y) (FlipV pic) = map flipFV $ flatten (x,y) pic
flatten (x,y) (Negative pic) = map flipNeg $ flatten (x,y) pic
-- flip one of the flags for transforms / filter
flipFH (Basic img (x,y) f@(Filter {fH=boo})) = Basic img (x,y) f{fH = not boo}
flipFV (Basic img (x,y) f@(Filter {fV=boo})) = Basic img (x,y) f{fV = not boo}
flipNeg (Basic img (x,y) f@(Filter {neg=boo})) = Basic img (x,y) f{neg = not boo}
--
-- Convert a Basic picture to an SVG image, represented by a String.
--
convert :: Basic -> String
convert (Basic (Image (Name name) (width, height)) (x,y) (Filter fH fV neg))
= "\n \n"
where
flipPart
= if fH && not fV
then " transform=\"translate(0," ++ show (2*y + height) ++ ") scale(1,-1)\" "
else if fV && not fH
then " transform=\"translate(" ++ show (2*x + width) ++ ",0) scale(-1,1)\" "
else if fV && fH
then " transform=\"translate(" ++ show (2*x + width) ++ "," ++ show (2*y + height) ++ ") scale(-1,-1)\" "
else ""
negPart
= if neg
then " filter=\"url(#negative)\""
else ""
-- Outputting a picture.
-- The effect of this is to write the SVG code into a file
-- whose path is hardwired into the code. Could easily modify so
-- that it is an argument of the call, and indeed could also call
-- the browser to update on output.
render :: Picture -> IO ()
render pic
=
let
picList = flatten (0,0) pic
svgString = concat (map convert picList)
newFile = preamble ++ svgString ++ postamble
in
do
outh <- openFile "svgOut.xml" WriteMode
hPutStrLn outh newFile
hClose outh
-- Preamble and postamble: boilerplate XML code.
preamble
= "\n"
--
-- Examples
--
white = Img $ Image (Name "white.jpg") (50, 50)
black = Img $ Image (Name "black.jpg") (50, 50)
red = Img $ Image (Name "red.jpg") (50, 50)
blue = Img $ Image (Name "blue.jpg") (50, 50)
horse = Img $ Image (Name "blk_horse_head.jpg") (150, 200)
test = (horse `beside` (negative (flipV horse)))
`above`
((negative horse) `beside` (flipV horse))
test2 = test `beside` flipV test