Homework/HW4.fedorind.hs

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