Shapes.lhs

"Embedded Domain-Specific Languages"
Jeremy Gibbons, University of Oxford <jeremy.gibbons@cs.ox.ac.uk>
Formosan Summer School on Logic, Languages and Computation, Taipei, July 2014

Skeleton code 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
>   |  Triangle Double

Style settings

> data Col = Red | Blue | Bisque 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

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

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

Simple transformations

> 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

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

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

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

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

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

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

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, 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" 
>       (("points", polyPoints (map (transformPos t) [ (-s/2):+(-h), (s/2):+(-h), 0:+h ])) : 
>        applyStyleSheet u)
>     where  polyPoints = concat . map (\ (x:+y) -> show x ++ "," ++ show y ++ " ")
>            h = s * sqrt 3 / 4

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

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

Here are the tile markings for Escher's "Square Limit".

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

This is the definition you'll need to draw markings.

> tile :: [[Pos]] -> [HTML]
> tile = map (concat . map (\ (x :+ y) -> show x ++ "," ++ show y ++ " "))

The remainder is commented out, because it depends on features that
get introduced during the exercises.

 > fishP, fishQ, fishR, fishS :: Picture
 > fishP = Place [StrokeWidth 0.1] (Tile 16 markingsP)
 > fishQ = Place [StrokeWidth 0.1] (Tile 16 markingsQ)
 > fishR = Place [StrokeWidth 0.1] (Tile 16 markingsR)
 > fishS = Place [StrokeWidth 0.1] (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

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

For testing purposes

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