Add solutions for HW4.

HW4.fedorind.hs

@@ -0,0 +1,183 @@
+-- Authors: Danila Fedorin, Ryan Alder, Matthew Sessions
+-- ONIDs: fedorind, alderr, sessionm
+module HW3 where
+
+import MiniMiniLogo
+import Render
+import System.Random
+import Data.Maybe
+import System.IO.Unsafe
+
+--
+-- * Semantics of MiniMiniLogo
+--
+
+-- NOTE:
+--  * MiniMiniLogo.hs defines the abstract syntax of MiniMiniLogo and some
+--    functions for generating MiniMiniLogo programs. It contains the type
+--    definitions for Mode, Cmd, and Prog.
+--  * Render.hs contains code for rendering the output of a MiniMiniLogo
+--    program in HTML5. It contains the types definitions for Point and Line.
+
+-- | A type to represent the current state of the pen.
+type State = (Mode,Point)
+
+-- | The initial state of the pen.
+start :: State
+start = (Up,(0,0))
+
+-- | A function that renders the image to HTML. Only works after you have
+--   implemented `prog`. Applying `draw` to a MiniMiniLogo program will
+--   produce an HTML file named MiniMiniLogo.html, which you can load in
+--   your browswer to view the rendered image.
+draw :: Prog -> IO ()
+draw p = let (_,ls) = prog p start in toHTML ls
+
+
+-- Semantic domains:
+--   * Cmd:  State -> (State, Maybe Line)
+--   * Prog: State -> (State, [Line])
+
+
+-- | Semantic function for Cmd.
+--   
+--   >>> cmd (Pen Down) (Up,(2,3))
+--   ((Down,(2,3)),Nothing)
+--
+--   >>> cmd (Pen Up) (Down,(2,3))
+--   ((Up,(2,3)),Nothing)
+--
+--   >>> cmd (Move 4 5) (Up,(2,3))
+--   ((Up,(4,5)),Nothing)
+--
+--   >>> cmd (Move 4 5) (Down,(2,3))
+--   ((Down,(4,5)),Just ((2,3),(4,5)))
+--
+cmd :: Cmd -> State -> (State, Maybe Line)
+cmd (Move l r) s = case fst s of
+    Up -> ((fst s, (l, r)), Nothing)
+    Down -> ((fst s, (l, r)), Just (snd s, (l, r)))
+cmd (Pen m) s    = ((m, snd s), Nothing)
+
+-- | Semantic function for Prog.
+--
+--   >>> prog (nix 10 10 5 7) start
+--   ((Down,(15,10)),[((10,10),(15,17)),((10,17),(15,10))])
+--
+--   >>> prog (steps 2 0 0) start
+--   ((Down,(2,2)),[((0,0),(0,1)),((0,1),(1,1)),((1,1),(1,2)),((1,2),(2,2))])
+prog :: Prog -> State -> (State, [Line])
+prog cs is = (fs, catMaybes ls)
+    where
+        step (s, xs) c = let (ns, ml) = cmd c s in (ns, xs ++ [ml])
+        (fs, ls) = foldl step (is, []) cs
+
+
+type Cell = (Bool, Bool, Bool, Bool, Bool)
+type Coord = (Int, Int)
+type Maze = [(Coord, Cell)]
+data Wall = WTop | WBottom | WLeft | WRight
+
+visited :: Cell -> Bool
+visited (b, _, _, _, _) = b
+
+neighbors :: Maze -> Coord -> [Coord]
+neighbors m (x, y) = [ c | c <- map fst m,
+                           abs (x - fst c) + abs (y - snd c) == 1,
+                           maybe False (not . visited) (lookup c m) ]
+
+pickNeighbor :: Maze -> StdGen -> Coord -> (Maybe Coord, StdGen)
+pickNeighbor m sg c = 
+    case ns of
+        [] -> (Nothing, sg)
+        _ -> (Just (ns !! v), g)
+    where
+        (v, g) = randomR (0, length ns - 1) sg
+        ns = neighbors m c
+
+breakCellWall :: Wall -> Cell -> Cell
+breakCellWall WTop (b1, b2, b3, b4, b5) = (b1, False, b3, b4, b5)
+breakCellWall WBottom (b1, b2, b3, b4, b5) = (b1, b2, False, b4, b5)
+breakCellWall WLeft (b1, b2, b3, b4, b5) = (b1, b2, b3, False, b5)
+breakCellWall WRight (b1, b2, b3, b4, b5) = (b1, b2, b3, b4, False)
+
+getWall :: Coord -> Coord -> Wall
+getWall (x, y) (x2, y2) = case (x - x2, y - y2) of
+    (0, 1)  -> WBottom
+    (0, -1) -> WTop
+    (1, 0)  -> WLeft
+    (-1, 0) -> WRight
+
+update :: Eq a => (b -> b) -> a -> [(a, b)] -> [(a, b)]
+update f a = map changeFunc
+    where
+        changeFunc (a', b) = if a == a' then (a', f b) else (a', b)
+
+breakWall :: Wall -> Coord -> Maze -> Maze
+breakWall w = update (breakCellWall w)
+
+visit :: Coord -> Maze -> Maze
+visit = update (\(b1, b2, b3, b4, b5) -> (True, b2, b3, b4, b5))
+
+generate :: Coord -> StdGen -> Maze -> (Maze, StdGen)
+generate c s m = maybe (nm, s) fixpointMove mc
+    where
+        nm = visit c m
+        (mc, g) = pickNeighbor nm s c
+        fixpointMove c2 = let (nm', g') = moveCell c2 in generate c g' nm'
+        moveCell c2 = generate c2 g $
+                         breakWall (getWall c c2) c $
+                         breakWall (getWall c2 c) c2 nm
+
+emptyMaze :: Int -> Int -> Maze 
+emptyMaze w h = [ ((x, y), (False, True, True, True, True)) | x <- [0..w - 1], y <- [0..h - 1] ]
+
+transform :: (Int -> Int) -> (Int -> Int) -> Coord -> Coord
+transform fx fy (x, y) = (fx x, fy y)
+
+offset :: Coord -> Coord -> Coord
+offset (ox, oy) = transform (+ox) (+oy)
+
+line :: Coord -> Coord -> Prog
+line (x1, y1) (x2, y2) = [ Pen Up, Move x1 y1, Pen Down, Move x2 y2 ]
+
+spotToLogo :: (Coord, Cell) -> Prog
+spotToLogo (c, (_, top, bottom, left, right)) = lineMovements
+    where
+        ls =
+            [ (offset (0, 1) c, offset (1, 1) c, top)
+            , (c, offset (1, 0) c, bottom)
+            , (c, offset (0, 1) c, left)
+            , (offset (1, 0) c, offset(1, 1) c, right)
+            ]
+        lineMovements = ls >>= (\(c1, c2, b) -> if b then line c1 c2 else [])
+
+mazeToLogo :: Maze -> Prog
+mazeToLogo m = m >>= spotToLogo
+
+drawFlower :: Int -> Coord -> Prog
+drawFlower n (xi, yi) = [ Pen Up, Move xi yi, Pen Down, Move xi (yi + n * 2) ] ++ linesFromCenter (xi, yi + n * 2)
+    where
+        pointsAround xs ys = [ (xs + x, ys + y) | x <- [-n..n], y <- [-n..n], abs x + abs y == n ]
+        linesFromCenter c@(x, y) = pointsAround x y >>= line c
+--
+-- * Extra credit
+--
+
+generateMaze :: Int -> Int -> Maze
+generateMaze w h = m
+    where
+        mi = emptyMaze w h
+        r = mkStdGen 5
+        (m, _) = generate (0, 0) r mi
+
+-- | This should be a MiniMiniLogo program that draws an amazing picture.
+--   Add as many helper functions as you want.
+amazing :: Prog
+amazing =
+    drawFlower 3 (5, 20) ++ 
+    drawFlower 3 (12, 20) ++ 
+    drawFlower 4 (27, 20) ++ 
+    drawFlower 6 (40, 20) ++
+    drawFlower 5 (65, 20) ++
+    (mazeToLogo $ generateMaze 80 20)

MiniMiniLogo.hs

@@ -0,0 +1,63 @@
+-- | This module defines the syntax of MiniMiniLogo. It also provides
+--   functions to generate programs that draw some basic shapes.
+--
+--   NOTE: You should not change the definitions in this file!
+--
+module MiniMiniLogo where
+
+--
+-- * Syntax
+--
+
+-- | A program is a sequence of commands.
+type Prog = [Cmd]
+
+-- | The mode of the pen.
+data Mode = Down | Up
+  deriving (Eq,Show)
+
+-- | Abstract syntax of commands.
+data Cmd = Pen Mode
+         | Move Int Int
+  deriving (Eq,Show)
+
+-- | Generate a MiniMiniLogo program that draws a 2x2 box starting from the
+--   specified point. Conceptually, this program looks like the following, but
+--   the additions are carried out in Haskell rather than in MiniMiniLogo.
+-- 
+--     pen up; move (x,y);
+--     pen down; move (x+2,y); move (x+2,y+2);
+--               move (x,y+2); move (x,y);
+--
+--   >>> box 7 3
+--   [Pen Up,Move 7 3,Pen Down,Move 9 3,Move 9 5,Move 7 5,Move 7 3]
+--
+box :: Int -> Int -> Prog
+box x y = [Pen Up, Move x y, Pen Down,
+           Move (x+2) y, Move (x+2) (y+2), Move x (y+2), Move x y]
+
+-- | Generate an 'X' from (x,y) to (x+w,y+h).
+--
+--   >>> nix 10 10 5 7
+--   [Pen Up,Move 10 10,Pen Down,Move 15 17,Pen Up,Move 10 17,Pen Down,Move 15 10]
+--
+nix :: Int -> Int -> Int -> Int -> Prog
+nix x y w h = [Pen Up, Move x y, Pen Down, Move (x+w) (y+h),
+               Pen Up, Move x (y+h), Pen Down, Move (x+w) y]
+
+-- | Generate a MiniMiniLogo program that draws n steps starting from
+--   point (x,y).
+--
+--   >>> steps 3 2 4
+--   [Pen Up,Move 2 4,Pen Down,Move 2 5,Move 3 5,Move 3 6,Move 4 6,Move 4 7,Move 5 7]
+-- 
+steps :: Int -> Int -> Int -> Prog
+steps n x y = [Pen Up, Move x y, Pen Down] ++ step n
+  where 
+    step 0 = []
+    step n = step (n-1) ++ [Move (x+n-1) (y+n), Move (x+n) (y+n)]
+
+-- | Draw an example picture. The expected output is given on the HW4
+--   description page.
+demo :: Prog
+demo = box 7 3 ++ nix 6 6 4 3 ++ steps 3 2 4

Render.hs

@@ -0,0 +1,82 @@
+-- | A module for rendering lines as an HTML5 file containing an SVG image.
+--   This can be used to visualize the denotational semantics of a MiniLogo
+--   program.
+--
+--   NOTE: You should not change the definitions in this file!
+--
+module Render (Point,Line,toHTML,toGridHTML) where
+
+import Data.List (intercalate)
+
+
+-- | A point is a cartesian pair (x,y).
+type Point = (Int,Int)
+
+-- | A line is defined by its endpoints.
+type Line = (Point,Point)
+
+-- | Output a list of lines as an HTML5 file containing an SVG image.
+toHTML :: [Line] -> IO ()
+toHTML ls = writeFile "MiniMiniLogo.html" (header ++ content ls ++ footer)
+
+-- | Alternate version of 'toHTML' that adds a grid to the background.
+toGridHTML :: [Line] -> IO ()
+toGridHTML ls = writeFile "MiniMiniLogo.html" (header ++ grid ++ content ls ++ footer)
+
+--
+-- Private definitions. All definitions below this point will not be visible
+-- from within a module that imports this module.
+--
+
+scale, margin, width, height :: Int
+scale  = 10
+margin = 10
+width  = 800
+height = 400
+
+gridStep = 5
+maxX = width `div` scale
+maxY = height `div` scale
+
+gridStyle = "fill:none;stroke:lightgrey;stroke-width:1"
+drawStyle = "fill:none;stroke:red;stroke-width:2"
+
+title  = "<head><title>MiniLogo Semantics Viewer</title></head>"
+view   = "<svg width='100%' viewBox='0 0 "
+         ++ show (width + 2*margin) ++ " "
+         ++ show (height + 2*margin) ++ "'>"
+border = "<rect x='" ++ show (margin-3) ++
+             "' y='" ++ show (margin-3) ++
+         "' width='" ++ show (width +6) ++
+        "' height='" ++ show (height+5) ++
+         "' style='fill:none;stroke:black;stroke-width:2'/>"
+
+header = unlines ["<!DOCTYPE html>", "<html>", title, "<body>", view, border]
+footer = unlines ["</svg>","</body>","</html>"]
+
+grid = unlines (map (poly gridStyle) lines)
+  where lines = [ [(x,0), (x,maxY)] | x <- [0,gridStep..maxX] ]
+             ++ [ [(0,y), (maxX,y)] | y <- [0,gridStep..maxY] ]
+
+content :: [Line] -> String
+content = unlines . map (poly drawStyle) . chunk
+
+-- | A canvas-adjusted point as a string.
+point :: Point -> String
+point (x,y) = show xp ++ "," ++ show yp
+  where xp = x*scale + margin
+        yp = height - y*scale + margin
+
+-- | Chunk a bunch of lines into sequences of connected points.
+chunk :: [Line] -> [[Point]]
+chunk []         = []
+chunk [(p,q)]    = [[p,q]]
+chunk ((p,q):ls) | q == head ps = (p:ps) : pss
+                 | otherwise    = [p,q] : ps : pss
+  where (ps:pss) = chunk ls
+
+-- | Draw a sequence of connected points.
+poly :: String -> [Point] -> String
+poly style ps = "<polyline points='"
+             ++ intercalate " " (map point ps)
+             ++ "' style='" ++ style ++ "'/>"