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.

F# Sudoku Solver. Exact Cover In Solving Sudokus.

Ich möchte endlich begreifen, wie die Sudoku - Lösungstechnik  funktioniert und fand einen Artikel über das Exact Cover Problem in Zusammenhang mit Sudoku, eine Sudoku Solver Version in F# und eine Haskell-Version.

//Program.fs
open FData.ExactCover
open System
//In the standard 9×9 Sudoku variant, there are four kinds of constraints
type Constraint = 
    | Row of int * int  //Row-Number: Each row must contain each number exactly once.
    | Col of int * int  //Column-Number: Each column must contain each number exactly once.
    | Box of int * int  //Box-Number: Each box must contain each number exactly once.
    | Pos of int * int  //Row-Column: Each intersection of a row and column, i.e, each cell, must contain exactly one number.
    | Given of int      

type Move
    = { mRow : int; mCol : int; mVal : int }

let inline box r c = ((r-1) / 3) * 3 + ((c-1) / 3) + 1

//Since there are 9 rows, 9 columns, 9 boxes and 9 numbers, there are 9×9=81 row-column constraint sets, 
//9×9=81 row-number constraint sets, 9×9=81 column-number constraint sets,
// and 9×9=81 box-number constraint sets: 81+81+81+81=324 constraint sets in all.
let inline constraintsFor rest m =
    (m, Pos(m.mRow, m.mCol)) :: (m, Row(m.mRow, m.mVal)) :: 
    (m, Col(m.mCol, m.mVal)) :: (m, Box(box m.mRow m.mCol, m.mVal)) :: rest

let inline constraints givenMarks =
    //In the standard 9×9 Sudoku variant, in which each of 9×9 cells is assigned one of 9 numbers,
    // there are 9×9×9=729 possibilities.
    let l = 
        seq {for r in 1..9 do
             for c in 1..9 do
             for v in 1..9 do
             yield { mRow = r; mCol = c; mVal = v }}
    let input = 
        Seq.append
            (Seq.mapi (fun i (r,c,v) ->
                { mRow = r; mCol = c; mVal = v }, Given (i + 1)) givenMarks)
            (Seq.fold constraintsFor [] l)
    addCover input

let inline zipCoords s =
    let coords  = 
        seq {for r in 1..9 do
             for c in 1..9 do
             yield (r,c)}
    Seq.zip coords s

let inline board input = 
    seq{for (r,c),v in zipCoords input do if v>0 then yield (r,c,v)}

let inline problem s= 
    List.concat s
    |>board
    |>constraints

let test f=
    printfn "Test Start."
    let sw = new System.Diagnostics.Stopwatch()
    sw.Start()
    let res=f ()
    sw.Stop()
    printfn "Time Duration : %A" sw.ElapsedMilliseconds
    //printfn "Result : %A" res

//simple Sudoku
let s2 =
    [[0; 0; 8;  3; 0; 0;  6; 0; 0]
     [0; 0; 4;  0; 0; 0;  0; 1; 0]
     [6; 7; 0;  0; 8; 0;  0; 0; 0]
     [0; 1; 6;  4; 3; 0;  0; 0; 0]
     [0; 0; 0;  7; 9; 0;  0; 2; 0]
     [0; 9; 0;  0; 0; 0;  4; 0; 1]
     [0; 0; 0;  9; 1; 0;  0; 0; 5]
     [0; 0; 3;  0; 5; 0;  0; 0; 2]
     [0; 5; 0;  0; 0; 0;  0; 7; 4]]
//middle
let s3 =
    [[1;0;0;0;0;7;0;9;0];
     [0;3;0;0;2;0;0;0;8];
     [0;0;9;6;0;0;5;0;0];
     [0;0;5;3;0;0;9;0;0];
     [0;1;0;0;8;0;0;0;2];
     [6;0;0;0;0;4;0;0;0];
     [3;0;0;0;0;0;0;1;0];
     [0;4;0;0;0;0;0;0;7];
     [0;0;7;0;0;0;3;0;0]]
//hard
let s4 = 
    [[0;0;0;  0;0;0;  0;0;8];
     [0;0;3;  0;0;0;  4;0;0];
     [0;9;0;  0;2;0;  0;6;0];
     [0;0;0;  0;7;9;  0;0;0];
     [0;0;0;  0;6;1;  2;0;0];
     [0;6;0;  5;0;2;  0;7;0];
     [0;0;8;  0;0;0;  5;0;0];
     [0;1;0;  0;0;0;  0;2;0];
     [4;0;5;  0;0;0;  0;0;3]]
test (fun()-> problem s2|>solveExactCover)
test (fun()-> problem s3|>solveExactCover)
test (fun()-> problem s4|>solveExactCover)

//ExactCover.fs
namespace FData
open System

[<RequireQualifiedAccess>]
module PrioSeq =
  type PSQ<'k, 'p> =
      | Void
      | Winner of 'k * 'p * LTree<'k, 'p> * 'k
  and LTree<'k, 'p> =
      | Start
      | LLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
      | RLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
  
  let inline play t1 t2 =
      match t1, t2 with
      | Void, t -> t
      | t, Void -> t
      | Winner (k, p, t, m), Winner (k', p', t', m') -> 
          match p <= p' with
          | true     -> Winner(k, p, RLoser(k', p', t, m, t'), m')
          | false    -> Winner(k', p', LLoser(k, p, t, m, t'), m')

  type TourView<'k, 'p> =  
      | Null
      | Single of 'k * 'p 
      | Play of PSQ<'k, 'p> * PSQ<'k, 'p>

  let inline tourView psq = 
      match psq with
      | Void -> Null
      | Winner(k, p, Start, _) -> Single(k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') -> Play(Winner(k, p, tl, m), Winner(k', p', tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') -> Play(Winner(k', p', tl, m), Winner(k, p, tr, m'))

  let empty =  Void
  
  let inline single (k, p) =  Winner(k, p, Start, k)
  
  let inline key (k,_) = k

  let inline prio (_, p) = p

  let inline maxKey (Winner (_, _, _, m)) =  m

  let rec insert b q =
      match tourView q with
      | Null                                  -> single b
      | Single(k,p) when key b < k            -> play (single b) (single(k, p))
      | Single(k,p) when key b = k            -> single b
      | Single(k,p)                           -> play (single(k, p)) (single b)
      | Play(tl, tr) when key b <= maxKey tl  -> play (insert b tl) tr
      | Play(tl, tr)                          -> play tl (insert b tr)

  let inline foldm f e x =
      let rec inner n xs =
          match n, xs with
          | 1, y::ys -> (y, ys)
          | n, ys    -> 
              let m = n / 2
              let (y1, ys1) = inner (n-m) ys
              let (y2, ys2) = inner m ys1
              f y1 y2, ys2
      match x with
      | [] -> e
      | _  -> fst (inner (List.length x) x)
  
  let inline fromOrdList l =
      foldm play empty l

  let rec toOrdLists q=
      match tourView q with
      | Null          -> List.empty
      | Single(k, p)  -> [single (k, p)]
      | Play(tl, tr)  -> (toOrdLists tl) @ (toOrdLists tr)

  let inline rebalance<'k,'p when 'p : comparison> : (PSQ<'k, 'p> ->PSQ<'k, 'p>)= fromOrdList<<toordlists 
  
  let lookup k p =
      match tourView q with
      | Null                             -> None
      | Single(k', p) when k = k'        -> Some p
      | Single(k', p)                    -> None
      | Play(tl, tr) when k <= maxKey tl -> lookup k tl
      | Play(tl, tr)                     -> lookup k tr

  let rec delete k q =
      match tourView q with
      | Null                             -> empty
      | Single(k', p) when k = k'        -> empty
      | Single(k', p)                    -> single (k', p)
      | Play(tl, tr) when k <= maxKey tl -> play (delete k tl) tr
      | Play(tl, tr)                     -> play tl (delete k tr)

  type MinView<'k, 'p> =  
      | Empty 
      | Min of ('k * 'p)

  let inline minView q =
      match q with
      | Void               -> Empty
      | Winner(k, p, t, m) -> Min (k, p)

  let rec adjust f key q = 
      match q with
      | Void                                                       -> Void
      | Winner(k, p, Start, _) when key = k                        -> single (k, (f p))
      | Winner(k, p, Start, _)                                     -> single (k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') when key <= m  -> 
          play (adjust f key (Winner(k, p, tl, m))) (Winner(k', p', tr, m'))
      | Winner(k, p, RLoser(k', p', tl, m, tr), m')                 ->
          play (Winner(k, p, tl, m)) (adjust f key (Winner(k', p', tr, m')))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') when key <= m   ->
          play (adjust f key (Winner( k', p', tl, m))) (Winner(k, p, tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m')                 ->
          let w2 = Winner(k, p, tr, m')
          play (Winner(k', p', tl, m)) (adjust f key w2)


module ExactCover =
  open System.Collections.Generic
  open Microsoft.FSharp.Collections

  type ECValue<'r when 'r : comparison> = { ecvSize : int; ecvRows : Set<'r>  }

  type ExactCover<'r, 'c when 'r : comparison and 'c : comparison> =
      { ecCol : PrioSeq.PSQ<'c, ECValue<'r>>; ecRow : Map<'r, Set<'c>> }

  let inline emptyCover<'c, 'r when 'c : comparison and 'r : comparison> = 
      {ecCol = PrioSeq.empty; ecRow = Map.empty}

  let inline addCover rcs  =
      let createMap f g = 
          rcs
          |>Seq.groupBy f
          |>Seq.map (fun (x, ys) -> x, Seq.map g ys|>Set.ofSeq)
      let col = 
          createMap snd fst
          |>Seq.fold (fun acc (c, m) -> 
                        PrioSeq.insert (c, {ecvSize = Set.count m ; ecvRows = m}) acc
                        ) PrioSeq.empty
      let row = 
          createMap fst snd
          |>Map.ofSeq
      { ecCol = PrioSeq.rebalance col; ecRow = row }
  
  let inline flip f a b = f b a
  
  let rec solve soFar ec  =
      match PrioSeq.minView ec.ecCol with
      | PrioSeq.Empty -> soFar
      | PrioSeq.Min(_, rs) -> 
          let setDifference ys ecv =
              let zs = ecv.ecvRows - ys 
              { ecvSize = Set.count zs; ecvRows = zs }
          Seq.map (fun move ->
              //Get all constraints of current move
              let constraints = Map.find move ec.ecRow
              //Get all moves of selected constraints
              let moves = Set.unionMany (Seq.map (fun k -> 
                  match PrioSeq.lookup k ec.ecCol with
                  | Some ecv -> ecv.ecvRows
                  | None -> failwith ("Nothing" + k.ToString())) constraints)
              //all posible constraints for selected moves
              let posibleConstraints = Seq.concat (Seq.map (flip Map.find ec.ecRow) moves)

              let newCol = 
                  //delete all constraints of current move
                  let acc = Seq.fold (flip PrioSeq.delete) ec.ecCol constraints
                  //update posible constraints for selected moves
                  Seq.fold (flip (PrioSeq.adjust (setDifference moves))) acc posibleConstraints

              let newRow = Seq.fold (flip Map.remove) ec.ecRow moves

              solve (Set.add move soFar) {ecCol = newCol; ecRow = newRow}) rs.ecvRows
          |>Set.unionMany
  
  let inline solveExactCover ec = solve Set.empty ec|>Set.toList

Test Start.
Time Duration : 342L
Test Start.
Time Duration : 545L
Test Start.
Time Duration : 3713L