Shapes-complete.lhs

"Embedded Domain-Specific Languages"
Jeremy Gibbons, University of Oxford <[email protected]>
Formosan Summer School on Logic, Languages and Computation, Taipei, July 2014

Complete solutions for exercises.

----------------------------------------------------------------------

> {-# LANGUAGE StandaloneDeriving #-}
>
> import Prelude hiding (cycle)
> import Data.Complex
> import Data.Char (toLower)

----------------------------------------------------------------------

Primitive shapes

> data Shape 
>   =  Rectangle Double Double
>   |  Ellipse Double Double
>   |  Circle Double -- exercise
>   |  Triangle Double
>   |  Tile Double TileMarkings

> type TileMarkings = [[Pos]]

Style settings

> data Col = Red | Blue | Bisque | Black | Green | Yellow | Brown
>   deriving Show  -- and many more besides!

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

Pictures (arrangements of shapes)

> data Picture 
>   =  Place StyleSheet Shape
>   |  Above Picture Picture
>   |  Beside Picture Picture
>   |  InFrontOf Picture Picture -- exercise
>   |  FlipV Picture -- flip vertically, ie about horizontal axis (exercise)
>   |  Expand Double Picture -- scale (exercise)
>   |  Rot Picture -- quarter-turn anticlockwise (exercise)

For example...

> house :: Picture
> house = Place [FillColour Red] (Triangle 10) `InFrontOf` Place [StrokeColour Blue, StrokeWidth 0.5] (Rectangle 10 8)

> 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) ) 

> figur2 :: Picture
> figur2 =  Place [StrokeWidth 0.1, FillColour Bisque] (Ellipse 3 3) `Above`
>           ( Place [FillColour Red, StrokeWidth 0] (Triangle 10) `InFrontOf`
>             ( Place [FillColour Red, StrokeWidth 0] (Rectangle 10 1) `Above`
>               Place [StrokeWidth 0] (Rectangle 10 (5 * sqrt 3 - 1)) ) ) `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) ) 

> chicken :: Picture
> chicken = ((eye `Beside` blank `Beside` eye) `Above` blank `Above` nose) `InFrontOf` face where 
>   eye = Place [FillColour Black] (Ellipse 1 2.5) `InFrontOf`
>         Place [FillColour Green] (Ellipse 5 3)
>   blank = Place [StrokeWidth 0] (Rectangle 5 5) 
>   nose = FlipV (Place [FillColour Red] (Triangle 10))
>   face = Place [FillColour Yellow, StrokeColour Brown, StrokeWidth 0.5] (Circle 20)

----------------------------------------------------------------------

Simple transformations

> type Pos = Complex Double
> data Transform
>   =  Identity
>   |  ReflectY -- exercise
>   |  Translate Pos
>   |  Scale Double
>   |  Rotate -- quarter-turn anticlockwise
>   |  Compose Transform Transform

> transformPos :: Transform -> Pos -> Pos
> transformPos Identity       = id
> transformPos ReflectY       = conjugate
> transformPos (Translate p)  = (p+)
> transformPos (Scale s)      = ((s :+ 0)*)
> transformPos Rotate         = ((0 :+ 1)*)
> transformPos (Compose t u)  = transformPos t . transformPos u

----------------------------------------------------------------------

Simplified form for pictures:

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

In order to place drawings next to each other, we'll need to compute extents.

> 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 order (transformPos t ll, transformPos t ur)
>   order (x1 :+ y1, x2 :+ y2) = (min x1 x2 :+ min y1 y2, max x1 x2 :+ max y1 y2)

> shapeExtent :: Shape -> Extent
> shapeExtent (Ellipse xr yr)  = (-(xr :+ yr), xr :+ yr)
> shapeExtent (Circle r)       = (-(r :+ r), r :+ r)
> 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)
> shapeExtent (Tile s m)       = ( -(s/2 :+ s/2), s/2 :+ s/2)

----------------------------------------------------------------------

Now to simplify pictures into this form

> 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
> drawPicture (InFrontOf p q)  = drawPicture p `inFrontOfD` drawPicture q
> drawPicture (FlipV p)        = flipD (drawPicture p)
> drawPicture (Expand s p)     = expandD s (drawPicture p)
> drawPicture (Rot p)          = rotateD (drawPicture p)

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

> aboveD, besideD, inFrontOfD :: 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
> pd `besideD` qd =  transformDrawing (Translate (qllx :+ 0)) pd ++ 
>                    transformDrawing (Translate (purx :+ 0)) qd where
>   (pll, purx :+ pury)  = drawingExtent pd
>   (qllx :+ qlly, qur)  = drawingExtent qd
> pd `inFrontOfD` qd = pd ++ qd

> flipD :: Drawing -> Drawing
> flipD = transformDrawing ReflectY

> expandD :: Double -> Drawing -> Drawing
> expandD s = transformDrawing (Scale s)

> rotateD :: Drawing -> Drawing
> rotateD = transformDrawing Rotate

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

----------------------------------------------------------------------

Finally, we should assemble our Drawing into SVG

> type HTML = String

> entity :: String -> [Attr] -> HTML
> entity n as = "<" ++ n ++ attrs as ++ "/>"

> open :: String -> [Attr] -> HTML
> open n as = "<" ++ n ++ attrs as ++ ">"

> close :: String -> HTML
> close n = "</" ++ n ++ ">"

> attrs :: [Attr] -> String
> attrs as = concat [ " "++k++"="++ show v | (k,v)<-as ]

> type Attr = (String,String)

> point :: (String,String) -> Pos -> [Attr]
> point (sx,sy) (x :+ y) = [(sx, show x), (sy, show y)]

> assemble :: Drawing -> [HTML]
> assemble d = [header d, opengroup] ++ map diagramShape d ++ [closegroup,footer] where
>   s = 10
>   opengroup = open "g" [ ("transform","scale" ++ show (s,-s))]
>   closegroup = close "g"
>   header d 
>     = let  (llx :+ lly, urx :+ ury) = drawingExtent d 
>            (w,h) = (urx-llx, ury-lly) in
>       open "svg" ( point ("width","height") ((s*w):+(s*h)) ++
>                    [ ("viewBox",show (10*llx)++","++show (10*lly)++","++
>                       show (10*w)++","++ show (10*h)), 
>                    ("xmlns","http://www.w3.org/2000/svg"), 
>                    ("version","1.1") ])
>   footer = close "svg"

> diagramShape :: (Transform,StyleSheet,Shape) -> HTML
> diagramShape (t,u,Ellipse xr yr) 
>   = entity "ellipse" 
>       (point ("cx","cy") (transformPos t (0 :+ 0)) ++ 
>        point ("rx","ry") (xr:+yr) ++ applyStyleSheet u)
> diagramShape (t,u, Circle r) 
>   = entity "circle" 
>       (point ("cx","cy") (transformPos t (0 :+ 0)) ++ 
>        [("r", show r)] ++ applyStyleSheet u)
> diagramShape (t,u, Rectangle w h) 
>   = entity "rect" 
>       (point ("x","y") (transformPos t (-(w :+ h)/2)) ++ 
>        point ("width","height") (w:+h) ++ applyStyleSheet u)
> diagramShape (t,u, Triangle s) 
>   = entity "polygon" 
>       (polyPoints t [ (-s/2):+(-h), (s/2):+(-h), 0:+h ] : applyStyleSheet u)
>     where  h = s * sqrt 3 / 4
> diagramShape (t, u, Tile s m)
>   = unlines $ map (\ ps -> entity "polyline" (polyPoints t' ps : applyStyleSheet u)) m
>     where t' = Compose t (Translate (-(s/2 :+ s/2)))

> polyPoints :: Transform -> [Pos] -> Attr
> polyPoints t ps = ("points", concat (map ((\ (x:+y) -> show x ++ "," ++ show y ++ " ") . transformPos t) ps))

> applyStyleSheet :: StyleSheet -> [Attr]
> applyStyleSheet sh = map applyStyling sh
>   ++ if any isFillColour sh then [] else [("fill","none")]
>   where isFillColour s = case s of FillColour _ -> True ; _ -> False

> applyStyling :: Styling -> Attr
> applyStyling (FillColour c)    = ("fill", map toLower (show c))
> applyStyling (StrokeColour c)  = ("stroke", map toLower (show c))
> applyStyling (StrokeWidth w)   = ("stroke-width", show w)

 ...so we can render it to an SVG file

> writeSVG :: FilePath -> [HTML] -> IO ()
> writeSVG f ss = writeFile f (unlines ss)

----------------------------------------------------------------------

> 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) ]
>   ]

> fishP, fishQ, fishR, fishS :: Picture
> fishP = Place [StrokeWidth 0.1, StrokeColour Black] (Tile 16 markingsP)
> fishQ = Place [StrokeWidth 0.1, StrokeColour Black] (Tile 16 markingsQ)
> fishR = Place [StrokeWidth 0.1, StrokeColour Black] (Tile 16 markingsR)
> fishS = Place [StrokeWidth 0.1, StrokeColour Black] (Tile 16 markingsS)

> quartet p q r s = Expand 0.5 ((p `Beside` q) `Above` (r `Beside` s))
> cycle p = quartet p (Rot(Rot(Rot p))) (Rot p) (Rot(Rot p))
> fishT = quartet fishP fishQ fishR fishS
> fishU = cycle (Rot fishQ)
> blank = Place [StrokeWidth 0] (Rectangle 16 16)
> side1 = quartet blank blank (Rot fishT) fishT
> side2 = quartet side1 side1 (Rot fishT) fishT
> corner1 = quartet blank blank blank fishU
> corner2 = quartet corner1 side1 (Rot side1) fishU
> pseudocorner = quartet corner2 side2 (Rot side2) (Rot fishT)
> pseudolimit = cycle pseudocorner
> nonet p1 p2 p3 p4 p5 p6 p7 p8 p9 = Expand (1/3) (
>   (p1 `Beside` p2 `Beside` p3) `Above` 
>   (p4 `Beside` p5 `Beside` p6) `Above`
>   (p7 `Beside` p8 `Beside` p9))
> corner = nonet corner2 side2 side2 (Rot side2) fishU (Rot fishT) (Rot side2) (Rot fishT) (Rot fishQ)
> squarelimit = cycle corner

----------------------------------------------------------------------

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