F#. A* (a-star) Pathfinding Algorithm with Priority Queue and Finger Tree.

Update A* Star Pathfinding with Jump Point Search.

// Astar.fs
//from Haskell version http://www.haskell.org/haskellwiki/Haskell_Quiz/Astar/Solution_Dolio
namespace Astar

module AstarTypes =
    type Point = int * int
    type Map = char list list

    let inline flip f b a = f a b

[<RequireQualifiedAccess>]
module PriorityQueue =
  exception Empty

  type t<'k,'a> =
    | E
    | T of 'k * 'a * t<'k, 'a> * Lazy<t<'k,'a>>

  let empty = E

  let isEmpty = function E -> true | _ -> false

  let inline singleton prio x = T(prio, x, E, lazy E)

  let rec merge t1 t2 =
    match t1, t2 with
    | E, h -> h
    | h, E -> h
    | T(xprio, _, _, _), T(yprio, _, _, _) ->
        if xprio <= yprio then link t1 t2 else link t2 t1

  and link t1 t2 =
    match t1, t2 with
    | T(prio, a, E, m), r -> T(prio, a, r, m)
    | T(prio, a, t, m), r -> T(prio, a, E, lazy merge (merge r t) (m.Force()))
    | _ -> failwith "should not get there"

  let inline insert prio x q = merge (singleton prio x) q

  let rec contains prio = function
    | E -> false
    | T (sndPrio, _, a, b) ->
        prio = sndPrio || contains prio a || contains prio (b.Force())

  let deleteFindMin = function
    | E -> raise Empty
    | T(prio, a, t, m) ->(prio, a), merge t (m.Force())
  
  let inline findMin q = fst (deleteFindMin q)

  let inline deleteMin q = snd (deleteFindMin q)


  let rec remove x = function
    | E -> E
    | T(prio, y, a, b) as t ->
        if a = x
        then merge a (b.Force())
        else T(prio, y, remove x a, lazy remove x (b.Force()))

  let inline ofSeq s = Seq.fold (fun q (prio, a) -> merge (singleton prio a) q) empty s

module AstarImpl = 
  //Point -> (Point -> Set<Point>) -> (Point -> bool) -> (Point -> int) -> (Point -> int) -> Point list
  let astar start succ finish cost heur =
      let rec inner seen q =
           match PriorityQueue.isEmpty q with
           | true -> failwith "No Solution."
           | false ->
               let ((c, next), dq) = PriorityQueue.deleteFindMin q
               let n = List.head next

               match finish n with
               | true -> next
               | otherwise -> 
                   let succs = succ n

                   let costs item = c + (cost item) + (heur item) - (heur n) 
                   
                   let q' = 
                       Set.difference succs seen |> Seq.map (fun x ->costs x, x :: next) 
                       |> PriorityQueue.ofSeq |> PriorityQueue.merge dq

                   inner (Set.union seen succs) q'
      inner (Set.singleton start) (PriorityQueue.singleton (heur start) [start])

Version mit FingerTree aus dem Beitrag.

//Astar.fs
...
module AstarFtree =
  open FingerTree
  
  type PrioMonoid () =
        interface IMonoid<int> with
            member inline this.Zero = System.Int32.MaxValue
            member inline this.Plus a b = min a b
  
  type PrioElement =
    {Prio : int; Val : AstarTypes.Point list} with
    static member inline ofPair (p, v) = {Prio = p;Val = v}
    interface IMeasured<int> with
        member inline this.Value = this.Prio

  type FingerAstar = 
      {Tree : FingerTree<PrioElement, int, PrioMonoid>;
       Seen : Set<AstarTypes.Point>} with
          member inline this.deleteFindPrio =
                match this.Tree with
                | FingerTree.Empty -> failwith "tree is empty."
                | FingerTree.Single b -> b, FingerTree.Empty
                | FingerTree.Deep (v, _,_,_) ->                    
                    match FingerTree.findAndSplit (fun x -> x = v) this.Tree with
                    | Some (Split(l, x, r)) -> x, FingerTree.concat l r

          static member inline ofSeq s =
              {Tree = Seq.fold (AstarTypes.flip FingerTree.push_front) FingerTree.Empty s
               Seen = Set.empty}
  
  //Point -> (Point -> Set<Point>) -> (Point -> bool) -> (Point -> int) -> (Point -> int) -> Point list
  let astar start succ finish cost heur =
      let rec inner q  =
           match FingerTree.isEmpty q.Tree with
           | true -> failwith "No Solution."
           | false ->
               let (element, dq) = q.deleteFindPrio
               let n = List.head element.Val

               match finish n with
               | true -> element.Val
               | otherwise -> 
                   let succs = succ n

                   let costs item = element.Prio + (cost item) + (heur item) - (heur n) 
                   
                   let q' = 
                       Set.difference succs q.Seen 
                       |> Seq.map (fun x ->costs x, x :: element.Val)
                       |> Seq.map PrioElement.ofPair 
                       |> FingerAstar.ofSeq 
                       
                   inner {Tree = FingerTree.concat dq q'.Tree
                          Seen = Set.union q.Seen succs}
      inner {Seen = Set.singleton start; 
             Tree = FingerTree.Single {Prio = heur start; Val = [start]} }

//Programm.fs 
open Astar
open System

 //Point -> Point -> int
let inline heuristic (x, y) (u, v) = max (abs (x - u))  (abs (y - v))

// Map -> Point -> Set<Point> 
let inline successor m (x,y) = 
    set[for u in  [x + 1; x; x - 1] do
        for v in  [y + 1; y; y - 1] do
        if (0 <= u && u < List.length m 
            && 0 <= v && v < List.length (List.head m)) 
            && (u <> x || y <> v) 
            && (List.nth (List.nth m u) v <> '~') then
            yield set [u, v]
        ]
    |> Set.unionMany

//char -> Map -> Point
let inline find c =
      let rec inner x m = 
          match m with
          | [] ->  failwith "Can't find tile."
          | h :: t -> 
              match List.tryFindIndex (fun item -> item = c) h with
              | Some y -> x, y
              | otherwise -> inner (x+1) t
      inner 0
// char list list -> Point list -> char list list
let inline path m l = 
       List.mapi (fun idx ht ->
           List.mapi (fun idy c->
               if List.exists (fun (n', m') -> (n', m') = (idx, idy)) l then '#' else c) ht) m

let inline run s fAstar =
      let m = List.map (fun (str : string) ->List.ofSeq str) s
      let start = find 'S' m
      let finish = find 'F' m
      let succ = successor m
      let h     = heuristic finish
      let cost (x, y) = 
          let costs = Map.ofList [('S',1);('F',1);('.',1);('*',2);('^',7)]
          List.nth m x 
          |> AstarTypes.flip List.nth y
          |> AstarTypes.flip Map.find costs

      path m (fAstar start succ ((=) finish) cost h)

let input =
    [ "..*..S";
     "*^*^~.";
     "*~*^.~";
     "^^^.~^";
     "^~^~.~";
     "~~^~~.";
     "F*~*~~";]
printfn "Input Map :" 
List.iter (fun x -> printfn "%A" (List.ofSeq x))  input
let res = run input AstarImpl.astar
printfn " Path "
List.iter (fun x -> printfn "%A" x)  res

let resFtree = run input AstarFtree.astar
printfn " Path Finger Tree"
List.iter (fun x -> printfn "%A" x)  resFtree

Input Map :
['.'; '.'; '*'; '.'; '.'; 'S']
['*'; '^'; '*'; '^'; '~'; '.']
['*'; '~'; '*'; '^'; '.'; '~']
['^'; '^'; '^'; '.'; '~'; '^']
['^'; '~'; '^'; '~'; '.'; '~']
['~'; '~'; '^'; '~'; '~'; '.']
['F'; '*'; '~'; '*'; '~'; '~']
 Path
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']
 Path Finger Tree
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']

Hier habe ich den A Star Algorithmus verwendet, um eine Labyrinth Lösung zu finden.