Work for CS-381, Programming Language Fundamentals
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

183 lines
5.6 KiB

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