ScottsSnake.elm

--- module ScottsSnake where

import Keyboard
import Random
import String
import Set

type Position = {x: Int, y: Int }
type Board = {w: Int, h: Int, wall: [Position]}
type Apple = Position
type Snake = { cells: [Position], direction:Direction}
type Score = Int

data Direction = Up | Down | Left | Right
data GameState = GameOn Snake Apple | GameOver Score

board = makeBoard 20 20
startApple = {x = 4, y = 6}
startDirection=Up
startSnake = { cells = [{x = 4, y = 3}], direction=startDirection}
difficulty = 7
renderInterval = 550 - 50*difficulty -- in ms

makeBoard w h =
  {w = w, h = h, 
   wall = concat [ map (\s -> {x=0,y=s}) [0..h-1],
                   map (\s -> {x=w-1,y=s}) [0..h-1],
                   map (\s -> {x=s,y=0}) [0..w-1],
                   map (\s -> {x=s,y=h-1}) [0..w-1]]}

---------- GEOMETRY HELPERS

sameCell: Position -> Position -> Bool
sameCell c d = c.x == d.x && c.y == d.y

cartesianProduct: [a] -> [b] -> [(a,b)]
cartesianProduct l1 l2 = 
  let allXs = concat (map (repeat (length l2)) l1)
      allYs = concat (repeat (length l1) l2)
  in zip allXs allYs

freeCells:Board -> Snake -> [Position]
freeCells board snake = 
  let boardCells = Set.fromList (cartesianProduct [1..(board.w-2)] [1..(board.h-2)])
      snakeCells = Set.fromList (map (\c -> (c.x, c.y)) (snake.cells))
  in map (\(cx,cy) -> {x=cx,y=cy}) (Set.toList (Set.diff boardCells snakeCells))

pickCell : Int -> [Position]  -> Position
pickCell i l =  head (drop (mod i (length l)) l)

containsCell : Position -> [Position] -> Bool
containsCell c cells = length (filter (\cell -> sameCell c cell) cells) >= 1
                 
adjacentCell : Position -> Direction -> Position
adjacentCell cell direction =
  case direction of 
    Left  -> { x = cell.x-1, y = cell.y }
    Right -> { x = cell.x+1, y = cell.y }
    Down  -> { x = cell.x, y = cell.y-1 }
    Up    -> { x = cell.x, y = cell.y+1 }

cutTheLast : [Position] -> [Position]
cutTheLast l = take ((length l)-1) l

---------- GAME LOGIC

nextState:Board -> (Direction, Int) -> GameState -> GameState
nextState board (direction,rand) gameState =
    case gameState of
      GameOver score -> gameState
      GameOn snake apple ->
        let nextHead = adjacentCell (head snake.cells) direction
        in 
          if | containsCell nextHead board.wall -> GameOver (length snake.cells)
             | containsCell nextHead (tail snake.cells) -> GameOver (length snake.cells)
             | not (sameCell nextHead apple) 
               -> GameOn { snake | cells <- nextHead :: cutTheLast snake.cells } apple
             | otherwise 
               -> GameOn { snake | cells <- nextHead :: snake.cells } (pickCell rand (freeCells board snake))

------------ SIGNAL HELPERS

directionFromArrows:{x:Int, y:Int} -> Direction -> Direction
directionFromArrows arrows direction =
  if  | arrows.x < 0 -> Left
      | arrows.x > 0 -> Right
      | arrows.y > 0 -> Up
      | arrows.y < 0 -> Down
      | otherwise -> direction

flipDirection : Direction -> Direction
flipDirection direction = 
  case direction of
    Up -> Down
    Down -> Up
    Left -> Right
    Right -> Left

noBackwards : Direction -> Direction -> Direction
noBackwards new old = if new == flipDirection old then old else new

------------- SIGNALS

main = lift render gameStateSignal

gameStateSignal : Signal GameState
gameStateSignal = foldp (nextState board) (GameOn startSnake startApple) wrappedSignal

wrappedSignal : Signal (Direction, Int)
wrappedSignal = lift2 (\dir rand -> (dir, rand)) timedDirectionSignal randomSignal

randomSignal : Signal Int
randomSignal = Random.range 0 (board.w*board.h) timedDirectionSignal

timedDirectionSignal : Signal Direction
timedDirectionSignal = foldp noBackwards startDirection (sampleOn (every renderInterval) requestedDirectionSignal)

requestedDirectionSignal : Signal Direction
requestedDirectionSignal = foldp directionFromArrows startDirection (Keyboard.arrows)

--port log : Signal String
--port log = lift show gameStateSignal

--- RENDERING BELOW

drawCell: Color -> Position -> Form
drawCell color cell = rect 10 10 |> filled color
                                 |> move (toFloat cell.x*10, toFloat cell.y*10)
                                 |> move (-92,0)

drawCells snakeCells apple =
  collage 400 400 (concat [ map (drawCell red) [apple],
                            map (drawCell green) snakeCells,
                            map (drawCell black) board.wall ])

render:GameState -> Element
render state = case state of
            GameOn snake apple -> drawCells snake.cells apple
            GameOver score   -> asText ("GameOver. Snake Length: " ++ (show score))