F# Wpf. Maze/Labyrinth Generation with Union-Find and Maze Solver with A* Star.

Ich habe vor kurzem auf eine F# Implementierung von der Union Find Datenstruktur (disjoint-set data) aufmerksam geworden. "Randomized Kruskal's algorithm" verwendet die Datenstruktur um ein Labyrinth zu generieren. Ich versuche den beschriebenen Algorithmus nachzuimplementieren.
Spaßeshalber habe ich noch "Maze Solver" mithilfe des A* Star Algoritmus programmiert.

//Maze.fs
//from Haskell Version http://cdsmith.wordpress.com/2011/06/06/mazes-in-haskell-my-version/
namespace Maze

open System

module MazeType = 
    
    type Cell = int * int

    type Wall = 
        | H of Cell
        | V of Cell

module MazeUtils =
    
    let KnuthShuffle (lst : array<'a>) =
        let Swap i j =                                                
            let item = lst.[i]
            lst.[i] <- lst.[j]
            lst.[j] <- item
        let rnd = new System.Random()
        let ln = lst.Length
        [0..(ln - 2)]                                                  
        |> Seq.iter (fun i -> Swap i (rnd.Next(i, ln)))  
        lst

    let inline getA a (x, y)    = Array2D.get a x y

    let inline updateA a (x, y) = Array2D.set a x y

    let inline addPoint (x,y) (dx,dy) = (x + dx, y + dy)

module UnionFind =
    open MazeUtils

    type UnionFind2D  = 
        {Parents : (int * int)[,]; Ranks : int [,]}    

    let empty = {Parents = Array2D.zeroCreate 0 0; Ranks = Array2D.zeroCreate 0 0}

    let inline root uf i =
        let rec inner fget fupdate i =
            match i = fget i with
            | false -> 
                fupdate i (i|>(fget<<fget))
                inner fget fupdate (fget i)
            | true -> i
        inner (getA uf.Parents) (updateA uf.Parents) i

    let inline find uf (p, q) =
        root uf p = root uf q

    let inline union uf (p, q) =
            let updateParent, updateRank, getRank = 
                updateA uf.Parents<<root uf, updateA uf.Ranks<<root uf, getA uf.Ranks<<root uf
            let unite a b =
                updateParent a b
                updateRank b (getRank b + getRank a)
            match getRank p > getRank q with
            | true  -> unite p q
            | false -> unite q p

module MazeGenerator =
    open MazeType
    open MazeUtils
    open UnionFind

    //processMaze :: UnionFind2D -> Wall list -> Wall list
    let inline processMaze rooms  walls =
        let temp w p q acc =
            match find rooms (p, q) with
            | true -> w :: acc
            | false -> 
                union rooms (p, q)
                acc
        let rec inner w acc =
            match w with
            | [] -> acc
            | H (x,y) :: ws-> inner ws (temp (H(x, y)) (x, y) (x,       y + 1)  acc)
            | V (x,y) :: ws-> inner ws (temp (V(x, y)) (x, y) (x + 1,   y)      acc)
        
        inner walls []
    
    //genMaze :: int -> int -> Wall list
    let inline genMaze w h =
        let parents xmax ymax = Array2D.init xmax ymax (fun x y -> x, y)

        let ranks xmax ymax = Array2D.create xmax ymax 1
        
        let allWalls = 
            Array.append
                [| for x in 0..w-1 do
                   for y in 0..h-2 do
                   yield H(x,y)
                |]
                [| for x in 0..w-2 do
                   for y in 0..h-1 do
                   yield V(x,y)
                |]
        let startRooms = { Parents = parents w h; Ranks = ranks w h}

        KnuthShuffle allWalls 
        |> List.ofArray
        |> processMaze startRooms

module MazeSolver =
    open MazeType
    open MazeUtils
    open Microsoft.FSharp.Collections

    let inline heuristic (x, y) (u, v) = max (abs (x - u))  (abs (y - v))

    // Map<int *int, (int * int) list> -> int ->int -> Point -> Set<Point> 
    let inline successor rooms w h p = 
        let neighbours xs = List.map (addPoint p)  xs
        set[for (u, v) in Map.find p rooms |> neighbours  do
            if (0 <= u && u < w 
                && 0 <= v && v < h) then
                yield u,v
            ]

    let inline run rooms (start, finish) w h solver=

          let succ      = successor rooms w h
          
          solver start succ ((=) finish) (fun _ -> 0) (heuristic finish)

Als weiteres habe ich den hier beschriebenen Diffusion Algorithm als einen Art Anti-Object Pacman eingebaut.

//AntiObject.fs
namespace Maze
open System

module CustomStack =
    exception Empty

    type CustomStack<'a> =
        | Nil
        | Cons of ('a * CustomStack<'a>)
    
    let empty = Nil
    
    let isEmpty = function Nil -> true | _ -> false

    let cons x cs = Cons(x, cs)

    let singleton x = cons x empty

    let head = function
        | Nil -> raise Empty
        | Cons (hd, tl) -> hd

    let tail = function
        | Nil -> raise Empty
        | Cons (hd, tl) -> tl
    
    let rec append x y =
        match x with
        | Nil -> y
        | Cons (hd, tl) -> Cons (hd, append tl y)

    let rec set xs i x =
        match xs, i with
        | Nil, _ -> raise Empty
        | Cons (hd, tl), 0 -> Cons(x, tl)
        | Cons(hd, tl), n -> Cons(hd, set tl (i-1) x)



module AntiObject =
    open CustomStack
    open MazeType
    open MazeUtils
    open UnionFind
    open Microsoft.FSharp.Collections

    let inline flip f a b = f b a

    let rec removeOne value list = 
        match list with
        | head::tail when head = value -> tail
        | head::tail -> head::(removeOne value tail)
        | _ -> []
    
    type Either<'a,'b> =
        | Left of 'a
        | Right of 'b

    type Point = int * int

    type Agent = 
        | Goal of Double
        | Pursuer
        | Path of Double
        | Obstacle

    type Environment = {board : Map<Point, CustomStack<Agent>>; w : int; h : int; pursuers : Point list; goal : Point; 
                        rooms: Map<(int * int),(int * int) list> ; rate : double}

    let emptyEnvironment = {board = Map.empty; w = 0; h = 0; pursuers = []; goal= (0, 0); rooms = Map.empty; rate = 0.0 }


    let inline scent agent =
        match agent with
        | Path s    -> s
        | Goal s    -> s
        | _         -> 0.0

    let inline zeroScent agent =
        match agent with
        | Path s -> Path 0.0
        | x      -> x

    let inline zeroScents agents =
        match agents with
        | Cons(x, xs) -> cons (zeroScent x)  xs
        | x           -> x

    let inline topScent agents =
        match agents with
        | Cons(x, _) -> scent x
        | _          -> 0.0

    //Builds a basic environment
    //createEnvironment :: int -> -> int -> Map<(int * int),(int * int) list [,] -> (float * int * int) -> int * int -> int * int -> float- > Environment
    let inline createEnvironment w h rooms (goal, xgoal, ygoal) (xpursuer1, ypursuer1) (xpursuer2,ypursuer2) rate = 
        let mkAgent x y =
            let path = singleton (Path 0.0)
            match x, y with
            | x, y when x = -1 || y = -1 || x = w || y = h  -> singleton Obstacle
            | x, y when x = xgoal && y = ygoal              -> cons (Goal goal)  path
            | x, y when x = xpursuer1 && y = ypursuer1      -> cons Pursuer       path
            | x, y when x = xpursuer2 && y = ypursuer2      -> cons Pursuer       path
            | otherwise                                     -> path
        let b = Map.ofList [for y in -1..h do
                            for x in -1..w do
                            yield ((x, y), mkAgent x y)]
        {board = b; w = w; h = h; pursuers = [(xpursuer1, ypursuer1); (xpursuer2,ypursuer2)]; goal =(xgoal, ygoal); rooms = rooms; rate = rate}

    //canMove :: CustomStack<Agent> option -> bool
    let inline canMove someAgents =
        match someAgents with
        | Some (Cons(Path _, _))    -> true
        | _                         -> false

    //move :: Map<Point, CustomStack<Agent>> -> Point -> Point -> Map<Point, CustomStack<Agent>>
    let inline move (e : Map<Point, CustomStack<Agent>>) src tgt =
        let (Cons(h, tl)) = e.[src]   
        e
        |> Map.add tgt (cons h e.[tgt])
        |> Map.add src (zeroScents tl)
    
    //moveGoal :: Point -> Environment -> Environment * bool
    let inline moveGoal dest e =
        let targetSuitable = canMove (Map.tryFind dest e.board)
        match targetSuitable with
        | true -> {e with board = move e.board e.goal dest
                                        ; goal = dest }, true
        | false -> e, false

    let inline checkPoint p e board =
        let mapper p (dx,dy)  =
            Map.tryFind (addPoint p (dx, dy)) board

        match p with
        | x, y when x < 0 || y < 0  -> List.empty
        | _                         -> e.rooms.[p] |> List.map (mapper p)
             
    // Ensure we only move if there is a better scent available
    //updatePursuer :: Environment -> Point -> Environment
    let inline updatePursuer e p =
        let top = topScent << flip Map.find e.board
        let neighbours = 
            e.rooms.[p] 
            |> List.map (addPoint p)
            |> List.filter (canMove<<flip Map.tryFind e.board)
            |> List.filter (flip (>=) (top p) << top) 
        match neighbours with
        | []  -> e
        | _   -> 
            let tgt = List.maxBy (scent<<head<<flip Map.find e.board) neighbours
            {e with board = move e.board p tgt;
                    pursuers = tgt :: removeOne p e.pursuers }

    //diffusePoint :: float -> CustomStack<Agent> -> Agent list -> CustomStack<Agent>
    let inline diffusePoint rate agents check = 
        let diffusedScent s ys = s + rate * List.sum (List.map (fun x -> (scent x) - s) ys)
    
        let diffuse agents n  =
            match agents with
            | Cons (Path d, r) -> cons (Path  (diffusedScent d n )) r
            | other            -> other   
         
        let neighbours =                 
            match check with
            | _ :: _ ->   List.map head (check |> List.choose id )
            | [] ->  List.empty
    
        diffuse agents neighbours  


    //updatePursuers :: Environment -> Environment
    let inline updatePursuers env = Seq.fold updatePursuer env (env.pursuers)

    // update :: Point seq -> Environment -> Environment
    let inline update boardPoints e = 
        let updateBoard = 
            PSeq.fold (fun acc p ->
                        let dp = diffusePoint e.rate e.board.[p] (checkPoint p e acc)
                        Map.add p dp acc) e.board
        updatePursuers {e with board = updateBoard boardPoints}    

Für eine einfache GUI Darstellung der resultierenden Labyrinth wird WPF mit Canvas und Path Markup Syntax verwendet.

//MazeModel.fs
namespace FSharpWpfMvvmTemplate.Model

open System
open System.Windows.Input
open System.Text
open Maze.MazeType
open Maze.MazeGenerator
open Maze.UnionFind
open Astar
open Maze
open Microsoft.FSharp.Collections

module MazeModel =
    type Point = AntiObject.Point
    type MazeEnvironment = 
        { environment : AntiObject.Environment; maze : Wall list; rooms : Map<int *int, (int * int) list>; 
            w : int; h : int; wallSize : float; coinX : float; coinY : float; update : AntiObject.Environment -> AntiObject.Environment}
        member x.IsEmpty = List.isEmpty <| x.maze

    let inline flip f a b = f b a


    let empty = { environment = AntiObject.emptyEnvironment; maze = []; rooms = Map.empty;
                 w = 100; h = 100; wallSize = 20.0; coinX = 0.0; coinY = 0.0; update = id }

    let inline mapRooms mazeEnv =
        let mkWall (x, y) =
            (x,y),(List.zip [(-1,0); (0,-1); (1,0); (0, 1)] [V(x-1,y); H(x,y-1); V(x,y); H(x,y)]) 
            |>List.filter (not << flip List.exists mazeEnv.maze << (=) <<snd)
            |>List.map fst
        PSeq.map mkWall [for x in [0..mazeEnv.w] do
                         for y in [0..mazeEnv.h] do
                         yield x,y] |> PSeq.toList |> Map.ofList 
    
    let createSolver mazeEnv = 
        let startx, starty = (int mazeEnv.coinX) / int mazeEnv.wallSize, (int mazeEnv.coinY) / int mazeEnv.wallSize
        match mazeEnv.w > 0 && mazeEnv.h > 0, Map.isEmpty mazeEnv.rooms with 
        | false, _      -> [] 
        | true, true    -> MazeSolver.run (mapRooms mazeEnv) ((startx, starty), (mazeEnv.w - 1, mazeEnv.h - 1)) mazeEnv.w mazeEnv.h AstarImpl.astar
        | true, false   -> MazeSolver.run mazeEnv.rooms ((startx, starty), (mazeEnv.w - 1, mazeEnv.h - 1)) mazeEnv.w mazeEnv.h AstarImpl.astar

    let inline fupdate w h =
        [for x in [-1..w] do
                    for y in [-1..h] do
                    yield (x,y)]
        |> AntiObject.update

    let moveCoin mazeEnv move =
        let moveX, moveY =
            let cx,cy = (int mazeEnv.coinX) / int mazeEnv.wallSize , (int mazeEnv.coinY) / int mazeEnv.wallSize
            match move, mazeEnv.IsEmpty with
            | _, true -> mazeEnv.coinX, mazeEnv.coinY
            | Key.Down, false ->             
                if cy >= mazeEnv.h - 1 || (List.exists ( fun w -> w = H(cx,cy)) mazeEnv.maze ) then
                    mazeEnv.coinX, mazeEnv.coinY
                else
                    mazeEnv.coinX, mazeEnv.coinY + mazeEnv.wallSize
            | Key.Up, false -> 
                if cy = 0 || (List.exists ( fun w -> w = H(cx, cy - 1)) mazeEnv.maze) then
                    mazeEnv.coinX, mazeEnv.coinY
                else
                    mazeEnv.coinX, mazeEnv.coinY - mazeEnv.wallSize
            | Key.Right, false -> 
                if cx >= mazeEnv.w-1 || (List.exists ( fun w -> w = V(cx, cy)) mazeEnv.maze) then
                    mazeEnv.coinX, mazeEnv.coinY
                else
                    mazeEnv.coinX + mazeEnv.wallSize, mazeEnv.coinY
            | Key.Left, false -> 
                if cx = 0 || (List.exists ( fun w -> w = V(cx-1, cy)) mazeEnv.maze) then
                    mazeEnv.coinX, mazeEnv.coinY
                else
                    mazeEnv.coinX - mazeEnv.wallSize, mazeEnv.coinY

        if (moveX, moveY) <> (mazeEnv.coinX, mazeEnv.coinY) then
            let goalX, goalY = (int moveX) / int mazeEnv.wallSize, (int moveY) / int mazeEnv.wallSize
            match AntiObject.moveGoal (goalX, goalY) mazeEnv.environment with
            | e, true -> 
                {mazeEnv with environment = mazeEnv.update e; coinX = moveX; coinY = moveY}
            | e, false -> {mazeEnv with environment = mazeEnv.update e}
        else
            {mazeEnv with environment = mazeEnv.update mazeEnv.environment}

    let mazeToPath w h mazeEnv =
        let builder = StringBuilder()
        
        let folder (acc : StringBuilder) wall  =
            match wall with
            | H(x, y) ->
                let xf, yf = (float x) * mazeEnv.wallSize, (float y) * mazeEnv.wallSize
                acc.Append(sprintf "M%f,%fH%f" xf (yf + mazeEnv.wallSize)  (xf + mazeEnv.wallSize))
            | V(x, y) ->
                let xf, yf =(float x) * mazeEnv.wallSize, (float y) * mazeEnv.wallSize
                acc.Append(sprintf "M%f,%fV%f" (xf + mazeEnv.wallSize) yf (yf + mazeEnv.wallSize))

        
        builder.Append(sprintf "M%f,%f" 0.0 0.0)|>ignore
        builder.Append(sprintf "L%f,%f %f,%f" 0.0   0.0     0.0     (h * mazeEnv.wallSize)) |> ignore
        builder.Append(sprintf " %f,%f %f,%f" 0.0   (h * mazeEnv.wallSize)  (w * mazeEnv.wallSize)  (h * mazeEnv.wallSize)) |>ignore
        builder.Append(sprintf " %f,%f %f,%f" (w * mazeEnv.wallSize)  (h * mazeEnv.wallSize)    (w * mazeEnv.wallSize)    0.0) |>ignore
        builder.Append(sprintf " %f,%f %f,%f" (w * mazeEnv.wallSize)  0.0   0.0     0.0)|>ignore
        
        (mazeEnv.maze |> PSeq.fold folder builder).ToString()

    let inline solverToPath wallSize solver =
        match Seq.isEmpty solver with
        | false ->
            let builder = StringBuilder()
            let (xstart, ystart) = Seq.head solver

            builder.Append(sprintf "M%f,%f" ((float xstart) * wallSize + wallSize / 2.0) ((float ystart) * wallSize + wallSize / 2.0))|>ignore

            let folder (acc : StringBuilder) ((x, y), (x',y')) =
                let xf, yf =    (float x) * wallSize, (float y) * wallSize
                let xf', yf' =  (float x') * wallSize, (float y') * wallSize 
                acc.Append(sprintf "L%f,%f %f,%f" (xf + wallSize / 2.0) (yf + wallSize / 2.0)  (xf' + wallSize / 2.0)  (yf' + wallSize / 2.0))

            (solver
            |> Seq.pairwise
            |> PSeq.fold folder builder).ToString()
        | true -> String.Empty
    
    let createMaze w h l = 
        {environment = AntiObject.emptyEnvironment; w = w; h = h; wallSize = l; maze = MazeGenerator.genMaze w h; 
            rooms = Map.empty; coinX = 0.0; coinY = 0.0; update = fupdate w h}
    
    let isBoardEmpty mazeEnv = 
        Map.isEmpty mazeEnv.environment.board 

    let createEnvironment mazeEnv desirability rate =
        let sx, sy = (int mazeEnv.coinX) / int mazeEnv.wallSize, (int mazeEnv.coinY) / int mazeEnv.wallSize
        let fcreate rooms = 
            AntiObject.createEnvironment mazeEnv.w mazeEnv.h rooms (desirability, sx, sy) (0, mazeEnv.h - 1) ((mazeEnv.w - 1) / 2, (mazeEnv.h-1) / 2) rate
            
        match Map.isEmpty mazeEnv.rooms with
        | true ->
            let rooms = (mapRooms mazeEnv)
            {mazeEnv with rooms = rooms; coinX = (mazeEnv.wallSize / 4.0); coinY = (mazeEnv.wallSize / 4.0); environment = fcreate rooms}
        | false ->
            {mazeEnv with coinX = (mazeEnv.wallSize / 4.0); coinY = (mazeEnv.wallSize / 4.0); environment = fcreate mazeEnv.rooms}


    let enemiesPos mazeEnv = 
        mazeEnv.environment.pursuers 
        |> List.map (fun (x, y) ->  
                float x * mazeEnv.wallSize + (mazeEnv.wallSize / 4.0), float y * mazeEnv.wallSize + (mazeEnv.wallSize / 4.0))
    
    let setW mazeEnv w = {mazeEnv with w = w}

    let setH mazeEnv h = {mazeEnv with h = h}
    
    let setCoinX mazeEnv x = 
        if x < float (mazeEnv.w * int mazeEnv.wallSize) && List.isEmpty mazeEnv.maze |> not then
                {mazeEnv with coinX = x}
        else
            mazeEnv
    
    let setCoinY mazeEnv y = 
        if y < float (mazeEnv.h * int mazeEnv.wallSize) && List.isEmpty mazeEnv.maze |> not then
            {mazeEnv with coinY = y}
        else
            mazeEnv

    let setWallSize mazeEnv l = {mazeEnv with wallSize = l}

Das gesamte Programm auf GitHub.