Modified from Jeremy Gibbons' lecture, Functional Programming for Domain-Specific Language, FLOLAC 2014.

Shapes.hs

{-

Revision of Jeremy Gibbons' lecture material, Functional Programming for Domain-Specific Language, FLOLAC 2014.
  http://www.cs.ox.ac.uk/publications/publication7583-abstract.html
  http://flolac.iis.sinica.edu.tw/flolac14/doku.php?id=zh-tw:spl

  (Removed the dependency on `diagrams`.

Note: You'll have to install blaze-svg and colour:P

  cabal install blaze-svg
  cabal install colour

An example:
  writeSVG "ex.svg" (assemble (drawPicture figure))

-}

{-# LANGUAGE OverloadedStrings, NoMonomorphismRestriction, StandaloneDeriving #-}

import Prelude hiding (cycle)
import Data.List (intercalate)
import Data.Complex
import Data.Colour (Colour())
import Data.Colour.SRGB (sRGB24show)
import Data.Colour.Names
import Numeric (showFFloat)
import Data.String (fromString)

import Text.Blaze.Svg11 ((!), mkPath, Svg())
import qualified Text.Blaze.Svg11 as S
import qualified Text.Blaze.Svg11.Attributes as A
import Text.Blaze.Svg.Renderer.Utf8 (renderSvg)
import Data.ByteString.Lazy (writeFile)

data Shape 
  =  Rectangle Double Double
  |  Ellipse Double Double
  |  Triangle Double

type Col = Colour Double
type StyleSheet = [Styling]
data Styling
  =  FillColour Col
  |  NoFill
  |  StrokeColour Col
  |  StrokeWidth Double

data Picture 
  =  Place StyleSheet Shape
  |  Above Picture Picture
  |  Beside Picture Picture

figure :: Picture
figure =  Place [StrokeWidth 0.1, FillColour bisque] (Ellipse 3 3) `Above`
          Place [FillColour red, StrokeWidth 0] (Rectangle 10 1) `Above`
          Place [FillColour red, StrokeWidth 0] (Triangle 10) `Above`
          ( Place [FillColour blue, StrokeWidth 0] (Rectangle 1 5) `Beside`
            Place [StrokeWidth 0] (Rectangle 2 5) `Beside`
            Place [FillColour blue, StrokeWidth 0] (Rectangle 1 5) ) `Above`
          ( Place [FillColour blue, StrokeWidth 0] (Rectangle 2 1) `Beside`
            Place [StrokeWidth 0] (Rectangle 2 1) `Beside`
            Place [FillColour blue, StrokeWidth 0] (Rectangle 2 1) ) 



type Pos = Complex Double
data Transform
  =  Identity
  |  Translate Pos
  |  Compose Transform Transform

transformPos :: Transform -> Pos -> Pos
transformPos Identity       = id
transformPos (Translate p)  = (p+)
transformPos (Compose t u)  = transformPos t . transformPos u

type Extent = (Pos,Pos) -- (lower left, upper right)
unionExtent :: Extent -> Extent -> Extent
unionExtent (llx1 :+ lly1, urx1 :+ ury1) (llx2 :+ lly2, urx2 :+ ury2) 
  = (min llx1 llx2 :+ min lly1 lly2, max urx1 urx2 :+ max ury1 ury2) 

drawingExtent :: Drawing -> Extent
drawingExtent = foldr1 unionExtent . map getExtent where
  getExtent (t,_,s) =  let (ll,ur) = shapeExtent s
                       in (transformPos t ll, transformPos t ur)

shapeExtent :: Shape -> Extent
shapeExtent (Ellipse xr yr)  = (-(xr :+ yr), xr :+ yr)
shapeExtent (Rectangle w h)  = ( -(w/2 :+ h/2), w/2 :+ h/2)
shapeExtent (Triangle s)     = ( -(s/2 :+ sqrt 3 * s/4), s/2 :+ sqrt 3 * s/4)



drawPicture :: Picture -> Drawing
drawPicture (Place u s)      = drawShape u s
drawPicture (Above p q)      = drawPicture p `aboveD` drawPicture q
drawPicture (Beside p q)     = drawPicture p `besideD` drawPicture q

drawShape :: StyleSheet -> Shape -> Drawing
drawShape u s = [(Identity,u,s)]

aboveD :: Drawing -> Drawing -> Drawing
pd `aboveD` qd =   transformDrawing (Translate (0 :+ qury)) pd ++ 
                   transformDrawing (Translate (0 :+ plly)) qd where
  (pllx :+ plly, pur)  = drawingExtent pd
  (qll, qurx :+ qury)  = drawingExtent qd

besideD :: Drawing -> Drawing -> Drawing
pd `besideD` qd =  transformDrawing (Translate (qllx :+ 0)) pd ++ 
                   transformDrawing (Translate (purx :+ 0)) qd where
  (pll, purx :+ pury)  = drawingExtent pd
  (qllx :+ qlly, qur)  = drawingExtent qd

transformDrawing :: Transform -> Drawing -> Drawing
transformDrawing t = map (\ (t',u,s) -> (Compose t t',u,s))

type Drawing = [ (Transform, StyleSheet, Shape) ] -- non-empty, will be centred

showFloat :: Double -> String
showFloat f = showFFloat Nothing f []

showFAttr :: Double -> S.AttributeValue
showFAttr = fromString . showFloat

shapeSVG :: Shape -> Svg
shapeSVG (Rectangle width height) = S.rect ! (A.x x') ! (A.y y') ! (A.width width') ! (A.height height') where
  x' = showFAttr (-width/2)
  y' = showFAttr (-height/2)
  width' = showFAttr width
  height' = showFAttr height
shapeSVG (Ellipse xrad yrad) = S.ellipse ! (A.rx (showFAttr xrad)) ! (A.ry (showFAttr yrad))
shapeSVG (Triangle size) = S.polygon ! A.points pts where
  pts = fromString . intercalate " " . map (\(x,y) -> showFloat x ++ "," ++ showFloat y) $ pts'
  pts' = [(-size/2,-s'),(size/2,-s'),(0,s')]
  s' = size  * sqrt 3 / 4

stylingSVG :: Styling -> Svg -> Svg
stylingSVG NoFill           = (! A.fill "none")
stylingSVG (FillColour col) = (! A.fill (fromString $ sRGB24show col))
stylingSVG (StrokeColour col) = (! A.stroke (fromString $ sRGB24show col))
stylingSVG (StrokeWidth width) = (! A.strokeWidth (showFAttr width))

isFill :: Styling -> Bool
isFill (FillColour _) = True
isFill _              = False

styleSVG :: StyleSheet -> Svg -> Svg
styleSVG = foldr1 (.) . map stylingSVG

transform2Translate :: Transform -> Complex Double
transform2Translate Identity = 0 :+ 0
transform2Translate (Translate p) = p
transform2Translate (Compose t u) = transform2Translate t + transform2Translate u

transformSVG :: Transform -> Svg -> Svg
transformSVG t = (! (A.transform $ fromString $ "translate(" ++ showFloat dx ++ " " ++ showFloat dy ++ ")")) where
  dx :+ dy = transform2Translate t -- FIXME

assemble :: Drawing -> Svg
assemble drawing = S.docTypeSvg . (S.g ! (A.transform $ fromString $ "translate(" ++ showFloat picX ++ " " ++ showFloat picY ++ ")")) . (S.g ! A.transform "scale(5 -5)") . mapM_ makeSVG $ drawing where
  (left :+ bottom, right :+ top) = drawingExtent drawing
  picX = -left*5
  picY = -bottom*5
  makeSVG (trans, styl, shap) = transSVG . stylSVG $ shapSVG where
    transSVG = transformSVG trans
    stylSVG = styleSVG styl'
    shapSVG = shapeSVG shap
    styl' = if all (not . isFill) styl then NoFill:styl else styl

writeSVG :: FilePath -> Svg -> IO ()
writeSVG f = Data.ByteString.Lazy.writeFile f . renderSvg

markingsP = [
  [ (4:+4), (6:+0) ],
  [ (0:+3), (3:+4), (0:+8), (0:+3) ],
  [ (4:+5), (7:+6), (4:+10), (4:+5) ], 
  [ (11:+0), (10:+4), (8:+8), (4:+13), (0:+16) ], 
  [ (11:+0), (14:+2), (16:+2) ], 
  [ (10:+4), (13:+5), (16:+4) ], 
  [ (9:+6), (12:+7), (16:+6) ], 
  [ (8:+8), (12:+9), (16:+8) ], 
  [ (8:+12), (16:+10) ], 
  [ (0:+16), (6:+15), (8:+16), (12:+12), (16:+12) ], 
  [ (10:+16), (12:+14), (16:+13) ], 
  [ (12:+16), (13:+15), (16:+14) ], 
  [ (14:+16), (16:+15) ]
  ]

markingsQ = [
  [ (2:+0), (4:+5), (4:+7) ],
  [ (4:+0), (6:+5), (6:+7) ],
  [ (6:+0), (8:+5), (8:+8) ],
  [ (8:+0), (10:+6), (10:+9) ],
  [ (10:+0), (14:+11) ],
  [ (12:+0), (13:+4), (16:+8), (15:+10), (16:+16), (12:+10), (6:+7), (4:+7), (0:+8) ],
  [ (13:+0), (16:+6) ],
  [ (14:+0), (16:+4) ],
  [ (15:+0), (16:+2) ],
  [ (0:+10), (7:+11) ],
  [ (9:+12), (10:+10), (12:+12), (9:+12) ],
  [ (8:+15), (9:+13), (11:+15), (8:+15) ],
  [ (0:+12), (3:+13), (7:+15), (8:+16) ],
  [ (2:+16), (3:+13) ],
  [ (4:+16), (5:+14) ],
  [ (6:+16), (7:+15) ]
  ]

markingsR = [
  [ (0:+12), (1:+14) ],
  [ (0:+8), (2:+12) ],
  [ (0:+4), (5:+10) ],
  [ (0:+0), (8:+8) ],
  [ (1:+1), (4:+0) ],
  [ (2:+2), (8:+0) ],
  [ (3:+3), (8:+2), (12:+0) ],
  [ (5:+5), (12:+3), (16:+0) ],
  [ (0:+16), (2:+12), (8:+8), (14:+6), (16:+4) ],
  [ (6:+16), (11:+10), (16:+6) ],
  [ (11:+16), (12:+12), (16:+8) ],
  [ (12:+12), (16:+16) ],
  [ (13:+13), (16:+10) ],
  [ (14:+14), (16:+12) ],
  [ (15:+15), (16:+14) ]
  ]

markingsS = [
  [ (0:+0), (4:+2), (8:+2), (16:+0) ],
  [ (0:+4), (2:+1) ],
  [ (0:+6), (7:+4) ],
  [ (0:+8), (8:+6) ],
  [ (0:+10), (7:+8) ],
  [ (0:+12), (7:+10) ],
  [ (0:+14), (7:+13) ],
  [ (8:+16), (7:+13), (7:+8), (8:+6), (10:+4), (16:+0) ],
  [ (10:+16), (11:+10) ],
  [ (10:+6), (12:+4), (12:+7), (10:+6) ],
  [ (13:+7), (15:+5), (15:+8), (13:+7) ],
  [ (12:+16), (13:+13), (15:+9), (16:+8) ],
  [ (13:+13), (16:+14) ],
  [ (14:+11), (16:+12) ],
  [ (15:+9), (16:+10) ]
  ]

deriving instance Show Shape
deriving instance Show Styling
deriving instance Show Picture
deriving instance Show Transform