184 lines
5.6 KiB
Haskell
184 lines
5.6 KiB
Haskell
-- 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)
|