-----------------------------------------------------------------------
--
--  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 (Int -> Picture -> ShowS
[Picture] -> ShowS
Picture -> String
(Int -> Picture -> ShowS)
-> (Picture -> String) -> ([Picture] -> ShowS) -> Show Picture
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Picture -> ShowS
showsPrec :: Int -> Picture -> ShowS
$cshow :: Picture -> String
show :: Picture -> String
$cshowList :: [Picture] -> ShowS
showList :: [Picture] -> ShowS
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 (Int -> Image -> ShowS
[Image] -> ShowS
Image -> String
(Int -> Image -> ShowS)
-> (Image -> String) -> ([Image] -> ShowS) -> Show Image
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Image -> ShowS
showsPrec :: Int -> Image -> ShowS
$cshow :: Image -> String
show :: Image -> String
$cshowList :: [Image] -> ShowS
showList :: [Image] -> ShowS
Show)

data Name  = Name String
             deriving (Int -> Name -> ShowS
[Name] -> ShowS
Name -> String
(Int -> Name -> ShowS)
-> (Name -> String) -> ([Name] -> ShowS) -> Show Name
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Name -> ShowS
showsPrec :: Int -> Name -> ShowS
$cshow :: Name -> String
show :: Name -> String
$cshowList :: [Name] -> ShowS
showList :: [Name] -> ShowS
Show)

--
-- The functions over Pictures
--

above, beside, over :: Picture -> Picture -> Picture 

above :: Picture -> Picture -> Picture
above  = Picture -> Picture -> Picture
Above
beside :: Picture -> Picture -> Picture
beside = Picture -> Picture -> Picture
Beside
over :: Picture -> Picture -> Picture
over   = Picture -> Picture -> Picture
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 :: Picture -> Picture
flipH (Above Picture
pic1 Picture
pic2)  = (Picture -> Picture
flipH Picture
pic2) Picture -> Picture -> Picture
`Above` (Picture -> Picture
flipH Picture
pic1)
flipH (Beside Picture
pic1 Picture
pic2) = (Picture -> Picture
flipH Picture
pic1) Picture -> Picture -> Picture
`Beside` (Picture -> Picture
flipH Picture
pic2)
flipH (Over Picture
pic1 Picture
pic2)   = (Picture -> Picture
flipH Picture
pic1) Picture -> Picture -> Picture
`Over` (Picture -> Picture
flipH Picture
pic2)
flipH Picture
pic                = Picture -> Picture
FlipH Picture
pic

flipV :: Picture -> Picture
flipV (Above Picture
pic1 Picture
pic2)  = (Picture -> Picture
flipV Picture
pic1) Picture -> Picture -> Picture
`Above` (Picture -> Picture
flipV Picture
pic2)
flipV (Beside Picture
pic1 Picture
pic2) = (Picture -> Picture
flipV Picture
pic2) Picture -> Picture -> Picture
`Beside` (Picture -> Picture
flipV Picture
pic1)
flipV (Over Picture
pic1 Picture
pic2)   = (Picture -> Picture
flipV Picture
pic1) Picture -> Picture -> Picture
`Over` (Picture -> Picture
flipV Picture
pic2)
flipV Picture
pic                = Picture -> Picture
FlipV Picture
pic

negative :: Picture -> Picture
negative = Picture -> Picture
Negative

invertColour :: Picture -> Picture
invertColour = Picture -> Picture
Negative

-- Convert an Image to a Picture

img :: Image -> Picture 

img :: Image -> Picture
img = Image -> Picture
Img

--
-- Library functions
--

-- Dimensions of pictures

width,height :: Picture -> Int

width :: Picture -> Int
width (Img (Image Name
_ (Int
x,Int
_))) = Int
x 
width (Above Picture
pic1 Picture
pic2)     = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Picture -> Int
width Picture
pic1) (Picture -> Int
width Picture
pic2)
width (Beside Picture
pic1 Picture
pic2)    = (Picture -> Int
width Picture
pic1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Picture -> Int
width Picture
pic2)
width (Over Picture
pic1 Picture
pic2)      = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Picture -> Int
width Picture
pic1) (Picture -> Int
width Picture
pic2)
width (FlipH Picture
pic)           = Picture -> Int
width Picture
pic
width (FlipV Picture
pic)           = Picture -> Int
width Picture
pic
width (Negative Picture
pic)        = Picture -> Int
width Picture
pic

height :: Picture -> Int
height (Img (Image Name
_ (Int
x,Int
y))) = Int
y 
height (Above Picture
pic1 Picture
pic2)     = (Picture -> Int
height Picture
pic1) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Picture -> Int
height Picture
pic2)
height (Beside Picture
pic1 Picture
pic2)    = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Picture -> Int
height Picture
pic1) (Picture -> Int
height Picture
pic2)
height (Over Picture
pic1 Picture
pic2)      = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Picture -> Int
height Picture
pic1) (Picture -> Int
height Picture
pic2)
height (FlipH Picture
pic)           = Picture -> Int
height Picture
pic
height (FlipV Picture
pic)           = Picture -> Int
height Picture
pic
height (Negative Picture
pic)        = Picture -> Int
height Picture
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 {Filter -> Bool
fH, Filter -> Bool
fV, Filter -> Bool
neg :: Bool}
              deriving (Int -> Filter -> ShowS
[Filter] -> ShowS
Filter -> String
(Int -> Filter -> ShowS)
-> (Filter -> String) -> ([Filter] -> ShowS) -> Show Filter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Filter -> ShowS
showsPrec :: Int -> Filter -> ShowS
$cshow :: Filter -> String
show :: Filter -> String
$cshowList :: [Filter] -> ShowS
showList :: [Filter] -> ShowS
Show)

newFilter :: Filter
newFilter = Bool -> Bool -> Bool -> Filter
Filter Bool
False Bool
False Bool
False

data Basic = Basic Image Point Filter
             deriving (Int -> Basic -> ShowS
[Basic] -> ShowS
Basic -> String
(Int -> Basic -> ShowS)
-> (Basic -> String) -> ([Basic] -> ShowS) -> Show Basic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Basic -> ShowS
showsPrec :: Int -> Basic -> ShowS
$cshow :: Basic -> String
show :: Basic -> String
$cshowList :: [Basic] -> ShowS
showList :: [Basic] -> ShowS
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 :: Point -> Picture -> [Basic]
flatten (Int
x,Int
y) (Img Image
image)        = [Image -> Point -> Filter -> Basic
Basic Image
image (Int
x,Int
y) Filter
newFilter] 
flatten (Int
x,Int
y) (Above Picture
pic1 Picture
pic2)  = Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic1 [Basic] -> [Basic] -> [Basic]
forall a. [a] -> [a] -> [a]
++ Point -> Picture -> [Basic]
flatten (Int
x, Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Picture -> Int
height Picture
pic1) Picture
pic2
flatten (Int
x,Int
y) (Beside Picture
pic1 Picture
pic2) = Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic1 [Basic] -> [Basic] -> [Basic]
forall a. [a] -> [a] -> [a]
++ Point -> Picture -> [Basic]
flatten (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Picture -> Int
width Picture
pic1 , Int
y) Picture
pic2
flatten (Int
x,Int
y) (Over Picture
pic1 Picture
pic2)   = Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic1 [Basic] -> [Basic] -> [Basic]
forall a. [a] -> [a] -> [a]
++ Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic2
flatten (Int
x,Int
y) (FlipH Picture
pic)        = (Basic -> Basic) -> [Basic] -> [Basic]
forall a b. (a -> b) -> [a] -> [b]
map Basic -> Basic
flipFH ([Basic] -> [Basic]) -> [Basic] -> [Basic]
forall a b. (a -> b) -> a -> b
$ Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic
flatten (Int
x,Int
y) (FlipV Picture
pic)        = (Basic -> Basic) -> [Basic] -> [Basic]
forall a b. (a -> b) -> [a] -> [b]
map Basic -> Basic
flipFV ([Basic] -> [Basic]) -> [Basic] -> [Basic]
forall a b. (a -> b) -> a -> b
$ Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic
flatten (Int
x,Int
y) (Negative Picture
pic)     = (Basic -> Basic) -> [Basic] -> [Basic]
forall a b. (a -> b) -> [a] -> [b]
map Basic -> Basic
flipNeg ([Basic] -> [Basic]) -> [Basic] -> [Basic]
forall a b. (a -> b) -> a -> b
$ Point -> Picture -> [Basic]
flatten (Int
x,Int
y) Picture
pic

-- flip one of the flags for transforms / filter

flipFH :: Basic -> Basic
flipFH (Basic Image
img (Int
x,Int
y) f :: Filter
f@(Filter {fH :: Filter -> Bool
fH=Bool
boo}))   = Image -> Point -> Filter -> Basic
Basic Image
img (Int
x,Int
y) Filter
f{fH = not boo}
flipFV :: Basic -> Basic
flipFV (Basic Image
img (Int
x,Int
y) f :: Filter
f@(Filter {fV :: Filter -> Bool
fV=Bool
boo}))   = Image -> Point -> Filter -> Basic
Basic Image
img (Int
x,Int
y) Filter
f{fV = not boo}
flipNeg :: Basic -> Basic
flipNeg (Basic Image
img (Int
x,Int
y) f :: Filter
f@(Filter {neg :: Filter -> Bool
neg=Bool
boo})) = Image -> Point -> Filter -> Basic
Basic Image
img (Int
x,Int
y) Filter
f{neg = not boo}

--
-- Convert a Basic picture to an SVG image, represented by a String.
--

convert :: Basic -> String

convert :: Basic -> String
convert (Basic (Image (Name String
name) (Int
width, Int
height)) (Int
x,Int
y) (Filter Bool
fH Bool
fV Bool
neg))
  = String
"\n  <image x=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" y=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" width=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
width String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" height=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++
    Int -> String
forall a. Show a => a -> String
show Int
height String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\" xlink:href=\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
flipPart String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
negPart String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/>\n"
        where
          flipPart :: String
flipPart 
              = if      Bool
fH Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fV 
                then String
" transform=\"translate(0," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
height) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") scale(1,-1)\" " 
                else if Bool
fV Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
fH 
                then String
" transform=\"translate(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",0) scale(-1,1)\" " 
                else if Bool
fV Bool -> Bool -> Bool
&& Bool
fH 
                then String
" transform=\"translate(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
width) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"," String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
y Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
height) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") scale(-1,-1)\" " 
                else String
""
          negPart :: String
negPart 
              = if Bool
neg 
                then String
" filter=\"url(#negative)\"" 
                else String
"" 

-- 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 :: Picture -> IO ()
render Picture
pic 
 = 
   let
       picList :: [Basic]
picList = Point -> Picture -> [Basic]
flatten (Int
0,Int
0) Picture
pic
       svgString :: String
svgString = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ((Basic -> String) -> [Basic] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Basic -> String
convert [Basic]
picList)
       newFile :: String
newFile = String
preamble String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
svgString String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
postamble
   in
     do
       Handle
outh <- String -> IOMode -> IO Handle
openFile String
"svgOut.xml" IOMode
WriteMode
       Handle -> String -> IO ()
hPutStrLn Handle
outh String
newFile
       Handle -> IO ()
hClose Handle
outh

-- Preamble and postamble: boilerplate XML code. 

preamble :: String
preamble
 = String
"<svg width=\"100%\" height=\"100%\" version=\"1.1\"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"xmlns=\"http://www.w3.org/2000/svg\" xmlns:xlink=\"http://www.w3.org/1999/xlink\">\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"<filter id=\"negative\">\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"<feColorMatrix type=\"matrix\"\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"values=\"-1 0  0  0  0  0 -1  0  0  0  0  0 -1  0  0  1  1  1  0  0\" />\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
   String
"</filter>\n"

postamble :: String
postamble
 = String
"\n</svg>\n"

--
-- Examples
--

white :: Picture
white = Image -> Picture
Img (Image -> Picture) -> Image -> Picture
forall a b. (a -> b) -> a -> b
$ Name -> Point -> Image
Image (String -> Name
Name String
"white.jpg") (Int
50, Int
50)

black :: Picture
black = Image -> Picture
Img (Image -> Picture) -> Image -> Picture
forall a b. (a -> b) -> a -> b
$ Name -> Point -> Image
Image (String -> Name
Name String
"black.jpg") (Int
50, Int
50)

red :: Picture
red = Image -> Picture
Img (Image -> Picture) -> Image -> Picture
forall a b. (a -> b) -> a -> b
$ Name -> Point -> Image
Image (String -> Name
Name String
"red.jpg") (Int
50, Int
50)

blue :: Picture
blue = Image -> Picture
Img (Image -> Picture) -> Image -> Picture
forall a b. (a -> b) -> a -> b
$ Name -> Point -> Image
Image (String -> Name
Name String
"blue.jpg") (Int
50, Int
50)

horse :: Picture
horse = Image -> Picture
Img (Image -> Picture) -> Image -> Picture
forall a b. (a -> b) -> a -> b
$ Name -> Point -> Image
Image (String -> Name
Name String
"blk_horse_head.jpg") (Int
150, Int
200)

test :: Picture
test = (Picture
horse Picture -> Picture -> Picture
`beside` (Picture -> Picture
negative (Picture -> Picture
flipV Picture
horse))) 
                      Picture -> Picture -> Picture
`above` 
       ((Picture -> Picture
negative Picture
horse) Picture -> Picture -> Picture
`beside` (Picture -> Picture
flipV Picture
horse))

test2 :: Picture
test2 = Picture
test Picture -> Picture -> Picture
`beside` Picture -> Picture
flipV Picture
test