Add solutions for HW4.
This commit is contained in:
parent
2f5fc49117
commit
cf99539856
183
HW4.fedorind.hs
Normal file
183
HW4.fedorind.hs
Normal file
@ -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)
|
||||
63
MiniMiniLogo.hs
Normal file
63
MiniMiniLogo.hs
Normal file
@ -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
|
||||
82
Render.hs
Normal file
82
Render.hs
Normal file
@ -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 ++ "'/>"
|
||||
Loading…
Reference in New Issue
Block a user