Browse Source

Add solutions for HW4.

master
Danila Fedorin 2 years ago
parent
commit
cf99539856
  1. 183
      HW4.fedorind.hs
  2. 63
      MiniMiniLogo.hs
  3. 82
      Render.hs

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

63
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

82
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 ++ "'/>"
Loading…
Cancel
Save