Bloxorz for Fable REPL (fable.io/repl)

bloxorz.fs

namespace Bloxorz

module BFS = 
    open System.Collections.Generic

    type Queue<'a>(values: 'a seq) =
        let values = ResizeArray(values)
        member x.Count = values.Count
        member x.Enqueue value = values.Add(value)
        member x.Dequeue () = let result = values.[0] in values.RemoveAt(0); result

    let bfs idof fanout node =
        let queue = Queue([node])
        let visited = HashSet()

        // DSL
        let enqueue = queue.Enqueue
        let dequeue = queue.Dequeue
        let empty () = queue.Count = 0
        let mark = idof >> visited.Add >> ignore
        let test = idof >> visited.Contains >> not

        // algorithm
        seq {
            while not (empty ()) do
                let current = dequeue ()
                mark current
                yield current
                current |> fanout |> Seq.filter test |> Seq.iter enqueue
        }

    let trace traverse idof fanout node =
        let node' = (node, [])
        let idof' (node, _) = idof node
        let fanout' (node, actions) =
            node |> fanout |> Seq.map (fun (n, a) -> (n, a :: actions))
        traverse idof' fanout' node'

module Domain = 
    open BFS

    type Position = int * int
    type Bloxor = Position * Position
    type Move = | North | East | South | West
    type Path = Bloxor * Move list
    type World = { A: Position; B: Position; IsValid: Position -> bool }

    let infiniteWorld a b = { A = a; B = b; IsValid = fun _ -> true }
    let makeBloxor (position: Position): Bloxor = (position, position)
    let (|IsStanding|IsHorizontal|IsVertical|) (bloxor: Bloxor) =
        let ((ax, ay), (bx, by)) = bloxor
        match bx - ax, by - ay with
        | 0, 0 -> IsStanding
        | 1, 0 -> IsHorizontal
        | 0, 1 -> IsVertical
        | _ -> failwithf "Invalid bloxor (%d,%d) (%d,%d)" ax ay bx by

    let moveBloxor (bloxor: Bloxor) (direction: Move): Bloxor =
        let shiftX x1 x2 ((ax, ay), (bx, by)) = (ax + x1, ay), (bx + x2, by)
        let shiftY y1 y2 ((ax, ay), (bx, by)) = (ax, ay + y1), (bx, by + y2)
        let move =
            match bloxor, direction with
            | IsStanding, North -> shiftY -2 -1
            | IsStanding, East -> shiftX 1 2
            | IsStanding, South -> shiftY 1 2
            | IsStanding, West -> shiftX -2 -1
            | IsHorizontal, North -> shiftY -1 -1
            | IsHorizontal, East -> shiftX 2 1
            | IsHorizontal, South -> shiftY 1 1
            | IsHorizontal, West -> shiftX -1 -2
            | IsVertical, North -> shiftY -1 -2
            | IsVertical, East -> shiftX 1 1
            | IsVertical, South -> shiftY 2 1
            | IsVertical, West -> shiftX -1 -1
        move bloxor

    let solveWorld (world: World): Move list option =
        // DSL
        let isValid (a, b) = world.IsValid a && world.IsValid b
        let isFinal (a, b) = a = world.B && b = world.B
        let validMoves bloxor =
            [North; South; East; West]
            |> Seq.map (fun direction -> (moveBloxor bloxor direction, direction))
            |> Seq.filter (fun (bloxor, _) -> isValid bloxor)

        // action!
        let node = makeBloxor world.A
        let idof ((ax, ay), (bx, by)) = sprintf "%d.%d.%d.%d" ax ay bx by
        let fanout = validMoves
        trace bfs idof fanout node |> Seq.tryFind (fst >> isFinal) |> Option.map (snd >> List.rev)

    let parseWorld lines =
        let map =
            lines
            |> Seq.mapi (fun y l -> l |> Seq.mapi (fun x c -> (x, y), c))
            |> Seq.collect id
            |> Map.ofSeq
        let a = map |> Map.findKey (fun _ c -> c = 'A')
        let b = map |> Map.findKey (fun _ c -> c = 'B')
        let valid k = map |> Map.tryFind k |> Option.filter (fun c -> c <> ' ') |> Option.isSome
        { A = a; B = b; IsValid = valid }

module Main =
    open Fable.Import
    open Fable.Core.JsInterop
    open Domain
    open Fable

    let window = Browser.window
    let element name = Browser.document.getElementById(name)
    let canvas = element("canvas") :?> Browser.HTMLCanvasElement
    let start = element("start") :?> Browser.HTMLButtonElement
    let load1 = element("load1") :?> Browser.HTMLButtonElement
    let load2 = element("load2") :?> Browser.HTMLButtonElement
    let context = canvas.getContext_2d()

    let resize () =
        canvas.width <- window.innerWidth
        canvas.height <- window.innerHeight

    let drawBloxor (x, y) (color: string) =
        context.fillStyle <- !^ color
        context.fillRect (float (x * 22 + 8), float (y * 22 + 8), 21., 21.)

    let drawWorld (world: World) =
        for x = 0 to 100 do
            for y = 0 to 100 do
                let p = (x, y)
                let color = 
                    if not (world.IsValid p) then "black" 
                    elif p = world.A then "green" 
                    elif p = world.B then "red" 
                    else "grey"
                drawBloxor (x, y) color

    let animate paint (states: 'state seq) =
        let enumerator = states.GetEnumerator ()
        let rec action () =
            if enumerator.MoveNext () then
                paint enumerator.Current
                window.setTimeout (action, 1000) |> ignore
        action ()

    let paint world bloxor =
        printfn "%A" bloxor
        drawWorld world
        let a, b = bloxor
        drawBloxor a "blue"
        drawBloxor b "blue"

    let world1 =
        [
            "      xxxxxxx"
            "xxxx  xxx  xx"
            "xxxxxxxxx  xxxx"
            "xAxx       xxBx"
            "xxxx       xxxx"
            "            xxx"
        ] |> Domain.parseWorld

    let world2 =
        [
            "xxx"
            "xAxxxx"
            "xxxxxxxxx"
            " xxxxxxxxx"
            "     xxBxx"
            "      xxx"
        ] |> Domain.parseWorld
    
    let mutable world = world1

    let solve world = 
        world
        |> Domain.solveWorld
        |> Option.defaultValue []
        |> List.scan (Domain.moveBloxor) (Domain.makeBloxor world.A)

    window.addEventListener_load (fun _ -> printf "Loaded"; resize (); drawWorld world; null)
    window.addEventListener_resize (fun _ -> printf "Resized"; resize (); drawWorld world; null)
    load1.addEventListener_click (fun _ -> printf "World 1"; world <- world1; resize (); drawWorld world; null)
    load2.addEventListener_click (fun _ -> printf "World 2"; world <- world2; resize (); drawWorld world; null)
    start.addEventListener_click (fun _ -> printf "Clicked"; world |> solve |> animate (paint world); null)

    resize ()
    drawWorld world

index.html

<html>
<head>
  <meta http-equiv='Content-Type' content='text/html; charset=utf-8'>
  <style>
    body { margin: 0; width: 100%; position: relative; }
    #canvas { background-color: black; height: 100vh; width: 100%; display: block; }
    #buttons { position: fixed; bottom: 8px; right: 8px; }
    #buttons button { padding: 8px; }
  </style>
</head>
<body>
  <canvas id="canvas"></canvas>
  <div id="buttons">
    <button id="load1">World 1</button>
    <button id="load2">World 2</button>
    <button id="start">Start</button>
  </div>
</body>
</html>

• go to fable.io/repl
• paste bloxorz.fs into F# box
• paste index.html into HTML box
• press Compile