Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
"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
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.