Snake game in Elm

snake.elm

import Color
import Debug
import Effects exposing (..)
import Graphics.Collage exposing (..)
import Graphics.Element exposing (..)
import Html exposing (div, Html)
import Keyboard exposing (..)
import Random
import StartApp
import Text
import Time

type alias Input = { x : Int, y : Int }

type Action =
    Tick |
    DirectionInput Input

type alias Coordinate = { x : Int, y : Int }

type Direction = Left | Right | Up | Down

type alias Dimensions = { rows : Int, cols : Int}

type alias Model =
    {
        snakeIsAlive : Bool,
        dimensions : Dimensions,
        direction : Direction,
        foods : List Coordinate,
        inputBuffer : List Direction,
        points : Int,
        randomSeed : Random.Seed,
        snakeLength : Int,
        snakePieces : List Coordinate
    }

initialModel =
    {
        dimensions = { cols = 30, rows = 30 },
        direction = Left,
        foods = [{ x = 1, y = 1}],
        inputBuffer = [],
        points = 0,
        randomSeed = Random.initialSeed 0,
        snakeIsAlive = True,
        snakeLength = 1,
        snakePieces = [{ x = 15, y = 15}]
    }

init = (initialModel, Effects.none)

makeForm : Color.Color -> Float -> Coordinate -> Form
makeForm c size position =
    let halfSide = sideSize / 2
    in filled c (rect size size)
        |> move (toFloat position.x * sideSize - 150 + halfSide, toFloat position.y * sideSize - 150 + halfSide)

sideSize = 10
bgColor = Color.rgb 182 194 0
fgColor = Color.rgb 114 107 0

textLineStyle =
    {
        color = Color.black,
        width = 0.5,
        cap = Flat,
        join = Smooth,
        dashing = [],
        dashOffset = 0
    }

filledOutlinedText : String -> Float -> Form
filledOutlinedText s size =
    let basicText = Text.fromString s |> Text.height size |> Text.color fgColor
        filledT = text basicText
        outlinedT = outlinedText textLineStyle basicText
    in group [filledT, outlinedT]

snakeScreen : Model -> Element
snakeScreen m =
    let background = filled bgColor (rect (toFloat m.dimensions.rows * sideSize) (toFloat m.dimensions.cols * sideSize))
        snakePieces = List.map (\p -> makeForm fgColor sideSize p) m.snakePieces
        fruits = List.map (\p -> makeForm Color.red sideSize p) m.foods
        gameOverText = filledOutlinedText "Game Over" 50
            |> move (0, 45)
        scoreText = filledOutlinedText ("Score: " ++ toString m.points) 30
        playAgainText = filledOutlinedText "Press a key to play again" 20
            |> move (0, -35)
        gameOver = if m.snakeIsAlive then toForm empty else group [gameOverText, scoreText, playAgainText]
    in collage 300 300 (background :: fruits ++ snakePieces ++ [gameOver])

view : Signal.Address Action -> Model -> Html
view _ m =
    div [] [Html.fromElement (snakeScreen m)]

getSnakeHead : Model -> Coordinate
getSnakeHead m =
    case List.head m.snakePieces of
        Just c -> c
        Nothing -> Debug.crash "No snake head found"

getSnakeTail : Model -> List Coordinate
getSnakeTail m =
    case List.tail m.snakePieces of
        Just t -> t
        Nothing -> Debug.crash "No snake tail found"

moveSnake : Model -> Model
moveSnake m =
    let snakeHead = getSnakeHead m
        newSnakeHead =
            case m.direction of
                Left -> { snakeHead | x = snakeHead.x - 1 }
                Right -> { snakeHead | x = snakeHead.x + 1 }
                Down -> { snakeHead | y = snakeHead.y - 1 }
                Up -> { snakeHead | y = snakeHead.y + 1 }
    in { m | snakePieces = List.take m.snakeLength (newSnakeHead :: m.snakePieces) }

snakeHasDied : Model -> Bool
snakeHasDied m =
    let snakeHead = getSnakeHead m
    in snakeHasMovedOutside snakeHead m.dimensions || snakeBitItself snakeHead (getSnakeTail m)

snakeBitItself : Coordinate -> List Coordinate -> Bool
snakeBitItself head tail = List.any (\b -> b == head) tail

snakeHasMovedOutside : Coordinate -> Dimensions -> Bool
snakeHasMovedOutside head dimensions =
    head.x < 0 || head.x >= dimensions.rows || head.y < 0 || head.y >= dimensions.cols

find : List a -> (a -> Bool) -> Maybe a
find l p =
    case l of
        [] -> Nothing
        e :: es -> if p e then Just e else find es p

snakeEatsFood : Coordinate -> List Coordinate -> Maybe Coordinate
snakeEatsFood head foods = find foods (\f -> f == head)

coordinateGenerator : Random.Generator Coordinate
coordinateGenerator = Random.map2 (\x y -> { x = x, y = y }) (Random.int 0 29) (Random.int 0 29)

range : Int -> Int -> List Int
range l h =
    let go l h current =
        if l > h then current
        else l :: range (l + 1) h
    in go l h []

allPositions : Dimensions -> List Coordinate
allPositions d =
    let rows = range 0 (d.rows - 1)
        cols = range 0 (d.cols - 1)
    in List.concat <| List.map (\ri -> List.map (\ci -> { y = ri, x = ci }) cols) rows

listGet : Int -> List a -> Maybe a
listGet i l = List.drop i l |> List.head

pickFromList : List a -> Random.Seed -> (a, Random.Seed)
pickFromList l seed =
    let indexGenerator = Random.int 0 (List.length l)
        (randomIndex, newSeed) = Random.generate indexGenerator seed
    in case listGet randomIndex l of
        Just e -> (e, newSeed)
        Nothing -> Debug.crash "Called pick with list on empty list"

{- TODO Full Screen not handled -}
generateNewFood : Model -> (Coordinate, Random.Seed)
generateNewFood m =
    let freePositions = List.filter (\pos -> not (List.member pos m.snakePieces)) (allPositions m.dimensions)
    in pickFromList freePositions m.randomSeed

advanceState : Model -> Model
advanceState m =
    if m.snakeIsAlive then
        let withMovedSnake = moveSnake m
        in
            if snakeHasDied withMovedSnake then
                {m | snakeIsAlive = False }
            else
                case snakeEatsFood (getSnakeHead m) m.foods of
                    Just _ ->
                        let (newFood, newRandomSeed) = generateNewFood m
                        in { withMovedSnake |
                            snakeLength = withMovedSnake.snakeLength + 2,
                            foods = [newFood],
                            points = withMovedSnake.points,
                            randomSeed = newRandomSeed
                        }
                    Nothing ->
                        withMovedSnake
    else m

directionFromArrows : { x : Int, y : Int } -> Maybe Direction
directionFromArrows { x, y } =
    if x == -1 then Just Left
    else if x == 1 then Just Right
    else if y == -1 then Just Down
    else if y == 1 then Just Up
    else Nothing

opposite : Direction -> Direction -> Bool
opposite d1 d2 =
    case (d1, d2) of
        (Left, Right) -> True
        (Right, Left) -> True
        (Up, Down) -> True
        (Down, Up) -> True
        otherwise -> False

updateDirection : Model -> Model
updateDirection m =
    case m.inputBuffer of
        newDirection :: rest ->
            let updatedDirection = if (m.direction `opposite` newDirection) then m.direction else newDirection
            in { m | direction = updatedDirection, inputBuffer = rest }
        [] -> m

updateInputBuffer : List Direction -> Direction -> List Direction
updateInputBuffer current next =
    case current of
        [] -> [next]
        buffer ->
            case 
            let updatedBuffer = if next == d then d :: ds else next :: d :: ds
                in List.take 2 (updatedDirection

update : Action -> Model -> (Model, Effects Action)
update a m =
    case a of
        Tick -> (updateDirection m |> advanceState, Effects.none)
        DirectionInput arrows ->
            if m.snakeIsAlive then
                case directionFromArrows arrows of
                    Nothing -> (m, Effects.none)
                    Just newDirection ->
                        let newInputBuffer = Debug.log "inputBuffer" <| List.take 2 (m.inputBuffer ++ [newDirection])
                        in ({ m | inputBuffer = newInputBuffer }, Effects.none)
            else
                (initialModel, Effects.none)

ticks = Signal.map (always Tick) (Time.fps 8)
arrowSignal = Signal.map DirectionInput arrows

app = StartApp.start {init = init, update = update, view = view, inputs = [arrowSignal, ticks]}

main = app.html