// 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) resFtreeInput Map :
['.'; '.'; '*'; '.'; '.'; 'S']
['*'; '^'; '*'; '^'; '~'; '.']
['*'; '~'; '*'; '^'; '.'; '~']
['^'; '^'; '^'; '.'; '~'; '^']
['^'; '~'; '^'; '~'; '.'; '~']
['~'; '~'; '^'; '~'; '~'; '.']
['F'; '*'; '~'; '*'; '~'; '~']
Path
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']
Path Finger Tree
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']Hier habe ich den A Star Algorithmus verwendet, um eine Labyrinth Lösung zu finden.
