Snake implementation in F#

Snake.fsx

module Elmish.Snake

(**
 Timer as a source of events with an SVG clock, by Zaid Ajaj.
 You can find more info about Emish architecture and samples at https://elmish.github.io/
*)

open System
open Fable.Import
open Fable.Helpers.React
open Fable.Helpers.React.Props
open Elmish
open Elmish.React
open Fable.Import.Browser

type SVG = SVGAttr

let screenWidth = 20
let screenHeight = 20

[<Struct>]
type Position = {
    X:int
    Y:int
}

[<Struct>]
type Direction =
    | Up
    | Down
    | Left
    | Right
    
type InGameModel = {
    snakeParts: Position list
    food: Position
    direction: Direction
    oldDirection: Direction
}
    
type GameState =
    | GameOver
    | GameIsRunning of InGameModel

[<Struct>]
type UserInteraction =
    | KeyUp
    | KeyDown
    | KeyLeft
    | KeyRight

type Msg = 
    | Input of UserInteraction
    | TimeElapsed

type Collision =
    | Wall
    | Food of newFoodPosition:Position
    | Tail of remainingSnakeParts:Position list

let getTranslationFromDirection direction =
    match direction with
    | Up -> 0, -1
    | Down -> 0, 1
    | Left -> -1, 0
    | Right -> 1, 0

let getInvertedDirection direction =
    match direction with
    | Up -> Down
    | Left -> Right
    | Down -> Up
    | Right -> Left

let random = new System.Random()

let tryGetCollision model =
    let head = model.snakeParts |> List.head
    // Yummy food!
    if head.X = model.food.X &&
        head.Y = model.food.Y then
        { X = random.Next(screenWidth)
          Y = random.Next(screenHeight)}
        |> Collision.Food
        |> Some
    // We're biting us!
    else
        let possibleBitingPoint =
            model.snakeParts
            |> List.tail
            |> List.tryFindIndex(fun e -> e.X = head.X && e.Y = head.Y)
        match possibleBitingPoint with
        | Some index ->
            model.snakeParts
            |> List.take index
            |> Collision.Tail
            |> Some
        | None ->
            if head.X <= 0 ||
                head.Y <= 0 ||
                head.Y >= screenHeight ||
                head.X >= screenWidth then
                Collision.Wall
                |> Some
            else
                None
            
let initialModel =
    { snakeParts = [for i in 0..5 -> {X = 5; Y = 5 + i}]
      direction = Up
      food = {X = 10; Y = 10}
      oldDirection = Up }
    |> GameIsRunning

let update msg gameState =
    match gameState with
    | GameIsRunning(model) ->
        match msg with
        | Input userInteraction ->
            let isValidNewDirection oldDirection newDirection =
                match oldDirection, newDirection with
                | Up, Down
                | Down, Up
                | Right, Left
                | Left, Right -> false
                | _ -> true
            let newDirection =
                match userInteraction with
                | KeyUp -> Up
                | KeyDown -> Down
                | KeyLeft -> Left
                | KeyRight -> Right
            if isValidNewDirection model.oldDirection newDirection then
                { model with direction = newDirection }
            else
                model
            |> GameIsRunning
        | TimeElapsed ->
            let currentDirection = model.direction
            let oldDirection = model.direction
            let newSnakePartsPositions =
                let remainingParts =
                    model.snakeParts
                    |> List.rev
                    |> List.tail
                    |> List.rev
                let xPlus, yPlus =
                    currentDirection
                    |> getTranslationFromDirection
                let oldHead =
                    model.snakeParts
                    |> List.head
                let newHead = 
                    { X = oldHead.X + xPlus
                      Y = oldHead.Y + yPlus }
                newHead :: remainingParts
            // Collision detection
            let preCollisionModel =
                { model with
                    snakeParts = newSnakePartsPositions
                    direction = currentDirection
                    oldDirection = currentDirection }
            match tryGetCollision preCollisionModel with
            | Some collision ->
                match collision with
                | Wall -> GameOver
                | Food newFoodPosition ->
                    let lastElement =
                        let defaultLastElement () =
                            let newHead =
                                preCollisionModel.snakeParts
                                |> List.head
                            let xPlus, yPlus =
                                currentDirection
                                |> getInvertedDirection 
                                |> getTranslationFromDirection
                            { X = newHead.X + xPlus 
                              Y = newHead.Y + yPlus }
                        model.snakeParts
                        |> List.rev
                        |> List.tryHead
                        |> (function | Some a -> a | None -> defaultLastElement ())
                    { preCollisionModel with
                        snakeParts = [lastElement] |> List.append preCollisionModel.snakeParts
                        food = newFoodPosition }
                    |> GameIsRunning
                | Tail remainingSnakeParts ->
                    { preCollisionModel with 
                        snakeParts = remainingSnakeParts }
                    |> GameIsRunning
            | None ->
                preCollisionModel
                |> GameIsRunning
    | GameOver -> GameOver

let timerTick dispatch =
    Browser.window.setInterval(fun _ ->
        dispatch TimeElapsed
    , 500) |> ignore

let inputs dispatch =
    let update (e : KeyboardEvent, pressed) =
        match e.key with
        | "w" -> KeyUp |> Input |> dispatch
        | "a" -> KeyLeft |> Input |> dispatch
        | "s" -> KeyDown |> Input |> dispatch
        | "d" -> KeyRight |> Input |> dispatch
        | _ -> ()
    document.addEventListener("keydown", fun e -> update(e :?> _, true))

let view gameState dispatch =
    let offset = 3
    let realScreenWidth, realScreenHeight =
        screenWidth * offset, screenHeight * offset
    let color = "#000000"
    let width = 1.0
    match gameState with
    | GameIsRunning model ->
        svg
            [ ViewBox (sprintf "0 0 %d %d" realScreenHeight realScreenWidth)
              SVG.Width "500px" ]
            [   
                // circle [
                //     Cx "50"
                //     Cy "50"
                //     R "45"
                //     SVG.Fill "#0B79CE" ] []
                // circle in the center
                yield
                        line [ 
                            X1 "0"
                            Y1 "0"
                            X2 realScreenWidth
                            Y2 "0"
                            // Qualify these props to avoid name collision with CSSProp
                            SVG.Stroke color
                            SVG.StrokeWidth width ] []
                yield
                        line [
                            X1 "0"
                            Y1 "0"
                            X2 "0"
                            Y2 realScreenHeight
                            // Qualify these props to avoid name collision with CSSProp
                            SVG.Stroke color
                            SVG.StrokeWidth width ] []
                yield
                        line [ 
                            X1 realScreenWidth
                            Y1 "0"
                            X2 realScreenWidth
                            Y2 realScreenHeight
                            // Qualify these props to avoid name collision with CSSProp
                            SVG.Stroke color
                            SVG.StrokeWidth width ] []
                yield
                        line [
                            X1 "0"
                            Y1 realScreenHeight
                            X2 realScreenWidth
                            Y2 realScreenHeight
                            // Qualify these props to avoid name collision with CSSProp
                            SVG.Stroke color
                            SVG.StrokeWidth width ] []
                yield
                    circle [
                        Cx (model.food.X * offset)
                        Cy (model.food.Y * offset)
                        R "1"
                        SVG.Fill "#FF0000"
                        SVG.Stroke "#023963"
                        SVG.StrokeWidth 0.5 ] []
                yield
                    circle [
                        (model.snakeParts |> List.head |> fun s -> s.X * offset |> box |> Cx)
                        (model.snakeParts |> List.head |> fun s -> s.Y * offset |> box |> Cy)
                        R "2"
                        SVG.Fill "#0B79CE"
                    ] []
                for part in (model.snakeParts.Tail) do
                    yield
                        circle [
                            (part.X * offset |> box |> Cx)
                            (part.Y * offset |> box |> Cy)
                            R "2"
                            SVG.Fill "#0000FF"
                        ] []
            ]
    | GameOver ->
        div []
            [
                str "GAME OVER :("
            ]

// App
Program.mkProgram (fun _ -> initialModel, Cmd.none) (fun msg model -> update msg model, Cmd.none) view
|> Program.withSubscription (fun _ -> [ Cmd.ofSub timerTick; Cmd.ofSub inputs ] |> Cmd.batch)
|> Program.withReactSynchronous "elmish-app"
|> Program.run