Seiten

Mittwoch, 23. November 2011

F# Smart Constructors for Union Type.

Neulich über Hakell Smart Constructors gelesen.
Das funktioniert teilweise auch mit F# Union Type.

Die Signaturdatei mit verdeckten Resistor Konstruktoren.
//Resistor.fsi 
namespace SmartConstructors
module Resistor =
    type Bands = int

    // Union Type with hiding constructors
    type Resistor = private Metal of Bands | Ceramic of Bands
    //smart constructor.
    val metalResistor : Bands -> Resistor
    val (|Metal|Ceramic|) : Resistor -> Choice<Bands,Bands> 
Implementierung.
//Resistor.fs
namespace SmartConstructors
open System
module Resistor  =
    type Bands = int
    
    type  Resistor = Metal of Bands | Ceramic of Bands with
        override x.ToString()= 
            match x with
            | (Metal v) -> "Metal " + v.ToString() 
            | (Ceramic v) -> "Ceramic " + v.ToString()
    //smart constructor.
    let metalResistor (b:Bands) =
        assert ( b >= 4 && b <= 8)
        Metal b
    let (|Metal|Ceramic|) n =
        match n with
        | (Metal v) -> Metal v
        | (Ceramic v) -> Ceramic v
Aufrufen.
// other F# Console Project
// with reference to SmartConstructors.dll
// Program.fs
open SmartConstructors.Resistor

//don't compile
//let failResistor = Metal 5

//only way to build a metal resistor
let resistor6 = metalResistor 6

let getBands r = 
    match r with
    | Metal v -> v
    | Ceramic v -> v
printfn "%A" (resistor6.ToString())
printfn "%A" (getBands resistor6)

//Assertion failed
let resistor10 = metalResistor 10
printfn "%A" (resistor10.ToString())

Freitag, 18. November 2011

F# Wpf MVVM. Mouse Tracking with AttachedProperty.

Seit letztem Beitrag habe ich überlegt, wie man die Hindernisse einfach per Maus ziehen (bei gedrückter linker Maustaste) erstellen kann.
Die zweite Herausforderung bestand in der Mausklick-Verarbeitung im Zusammenhang mit der Positionsbestimmung des Mauszeigers. Man sollte per Mausklick entweder ein Chip auswählen können oder ein Hindernis an der entsprechenden Position zu zeichnen oder zu löschen.
Nicht zu vergessen wir sind im MVVM-Land und Code-Behind ist nicht erwünscht. In diesem Fall kann die AttachedProperty eine mögliche Option sein.
...
<Canvas Name="canvas" Grid.Column="0"
 AttachedProperty:TrackMouseBehavior.TrackPosition="{Binding TrackMouseMove}">
...
</ Canvas> 
<Canvas.InputBindings> <MouseBinding MouseAction="RightClick" Command="{Binding RightClickCommand}" /> <MouseBinding MouseAction="LeftClick" Command="{Binding LeftClickCommand}" /> </Canvas.InputBindings> Mouse Tracking mittels AttachedProperty.
//MouseTrack.fs 
//NO GUARANTEE. I'm not sure that using of the Event class at this point is allowed.
namespace FSharpWpfMvvmTemplate.AttachedProperty

open System.Windows
open System.Windows.Input

// The type represents just the action that should be executed 
// upon the occurrence of PreviewMouseMove event.
type TrackMouse  = {action : Point -> unit}

type TrackMouseBehavior() =
    let mutable startTrack = false
    let mutable endTrack = true
    static let mutable TrackPositionProperty : DependencyProperty = 
        DependencyProperty.RegisterAttached
            ("TrackPosition", typeof<TrackMouse>, typeof<TrackMouseBehavior>,
                                            new PropertyMetadata(null, new PropertyChangedCallback(TrackMouseBehavior.OnPropertyChanged)))

    static member OnPropertyChanged (d:DependencyObject) (e:DependencyPropertyChangedEventArgs) =
        let element = d :?> UIElement
        if e.NewValue <> null then
            let trackMouse = e.NewValue :?> TrackMouse
            let trackFunc = TrackMouseBehavior.MouseTrack trackMouse element
            // First when the left mouse button is already pressed and the mouse is moved,
            // until the left mouse button is released.
            element.PreviewMouseLeftButtonDown
               |> Event.map (fun args -> args :> MouseEventArgs)
               |> Event.merge element.PreviewMouseMove
               |> Event.filter (fun args -> args.LeftButton =  MouseButtonState.Pressed)
               |> Event.add (fun args -> func(args))

    static member GetTrackPosition(d:DependencyObject) =
        d.GetValue(TrackPositionProperty) :?> TrackMouse
    static member SetTrackPosition(d:DependencyObject, value : TrackMouse) =
        d.SetValue(TrackPositionProperty, value)
    
    static member MouseTrack(trackPos : TrackMouse) (element:UIElement) (mouseEventArgs : MouseEventArgs ) =   
            let point = mouseEventArgs.GetPosition(element)
            trackPos.action point
Im ViewModel wird die AddPoint-Methode definiert, die im TrackMouse-Type gekapsellt an der TrackMouseMove-AttachedProperty übergeben wird.
// JumpSearchViewModel.fs
type JumpSearchViewModel() as x=   
    class
...
        let mutable mazePath = String.Empty
        let mutable obstacles = set[]
        let mutable env : MazeEnvironment = empty
...
        let AddPointToPath (x, y) wallSize =
            let xf, yf = (float x) * wallSize, (float y) * wallSize
            let v = sprintf "M%f,%fV%f" xf yf  (yf + wallSize)
            let h= sprintf " H%fV%fH%f" (xf + wallSize) yf xf
            sprintf "%s%s%s" mazePath v h

        member x.AddPoint (point : Point) =
            if not env.IsEmpty && not timer.IsEnabled && x.VerifyX() = null && x.VerifyY() = null then
                let cellPos (posx, posy) = (posx / 20.0 |> int), (posy / 20.0 |> int)
                let pointX, pointY = cellPos (point.X, point.Y)
                if pointX <= x.MazeX - 1 && pointY <= x.MazeY - 1 then
                    //check if the mouse click hit the start or the finish coin position.
                    match (pointX, pointY) = cellPos (env.coinX, env.coinY),  (pointX, pointY) = cellPos (env.targetX, env.targetY) with
                    | true, _ -> selectedCoin <- Start (env.coinX, env.coinY)
                    |_, true -> selectedCoin <- Finish (env.targetX, env.targetY)
                    | _ ->
                        obstacles <- Set.add (pointX, pointY) obstacles
                        mazePath <- AddPointToPath (pointX, pointY) x.WallSize
                        x.MazeData <- Geometry.Parse(mazePath)

        //maze path geometry.   
        member x.MazeData  
            with get () =  mazeGeometry
            and set value = 
                mazeGeometry <- value
                base.RaisePropertyChangedEvent(<@x.MazeData@>) 
        
        // Get the TrackMouse action that should be executed. 
        member x.TrackMouseMove
            with get () =  {action = x.AddPoint}
...
Der Code.

Freitag, 11. November 2011

A* Star Pathfinding with Jump Point Search. F#, Wpf and Visualisation.

Im letzten Beitrag habe ich meiner Implementierung vom Jump Point Search Algorithmus gezeigt. Hier geht es in erster Linie um F# und Wpf.
Da es in Visual Studio bereits eine Projekt-Vorlage für F# Wpf gibt, habe ich sie auch genommen. Und zwar handelt es sich dabei um eine MVVM-Vorlage. Daher veruschte ich im Rahmen vom MVVM-Pattern zu bleiben.

Typen für das Model und
//JumpSearchModel.fs
//MVVM Model Types.
module JumpMazeModelType =
    open Maze.JumpPointSearchType
    type SelectedCoin =
        | Start of float * float
        | Finish of float * float

    type MazeEnvironment = 
        { maze : JumpPointEnvironment; obstacles : Set<(int * int)>; 
          wallSize : float; coinX : float; coinY : float; targetX : float; targetY : float}
        member this.IsEmpty = Map.isEmpty <| this.maze.grid

    let empty = { maze = empty; obstacles = Set.empty;
                  wallSize = 20.0; coinX = 0.0; coinY = 0.0;targetX = 0.0; targetY = 0.0 }
das ViewModel.
//JumpSearchViewModel.fs
//MVVM ViewModel Class Type
type JumpSearchViewModel() as x =   
    class
        inherit ViewModelBase()
        let mutable env : MazeEnvironment  = JumpMazeModel.empty
        let mutable selectedCoin : SelectedCoin = Start (0.0, 0.0)
        ...
    end
DataContext vom View.
<Window.DataContext>
        <ViewModel:JumpSearchViewModel></ViewModel:JumpSearchViewModel>
</Window.DataContext>
Ich habe nichts besseres gefunden, als das Canvas-Element im CommandParameter-Binding vom Button-Element anzugeben, um es später im ViewModel für den Aufruf von Mouse.GetPosition und für den Zugriff auf die Children-Auflistung des Canvas-Elementes zu verwenden.
...
<Button Command="{Binding CreateMazeCommand}"  CommandParameter="{Binding ElementName=canvas}" >Init Maze</Button>
...
//JumpSearchViewModel.fs
type JumpSearchViewModel() as x=   
    class
        ...
        let mutable canvas : Canvas = null
        
        member x.CreateMazeCommand = 
            new RelayCommand ((fun canExecute ->  x.VerifyX() = null &&  x.VerifyY() = null), (fun element -> x.CreateMaze(element)))

        member x.CreateMaze(element) =
            canvas <- element :?> Canvas
...
Die erste Herausforderung war die Start- und Ziel-Spielmarke mit der Tastatur auf dem Labyrinthbrett zu bewegen. Genauer gesagt wird einen von beiden Chips per Mausklick ausgewählt und dann mit einer Pfeiltaste auf die nächste Zelle bewegt, wenn es da gerade kein Hindernis gibt.
...
<!--coins moving with keys-->
<Window.InputBindings>
        <KeyBinding Command="{Binding CoinMoveCommand}" Key="Down" >
            <KeyBinding.CommandParameter>
                <i:Key>Down</i:Key>
            </KeyBinding.CommandParameter>
        </KeyBinding>
        <KeyBinding Command="{Binding CoinMoveCommand}" Key="Up">
            <KeyBinding.CommandParameter>
                <i:Key>Up</i:Key>
            </KeyBinding.CommandParameter>
        </KeyBinding>
        <KeyBinding Command="{Binding CoinMoveCommand}" Key="Left">
            <KeyBinding.CommandParameter>
                <i:Key>Left</i:Key>
            </KeyBinding.CommandParameter>
        </KeyBinding>
        <KeyBinding Command="{Binding CoinMoveCommand}" Key="Right">
            <KeyBinding.CommandParameter>
                <i:Key>Right</i:Key>
            </KeyBinding.CommandParameter>
        </KeyBinding>
</Window.InputBindings>
...
<!--start and finish coin-->
<Canvas>
    ...
    <Ellipse Name="coin" Fill="Blue"                     
     Canvas.Left="{Binding Path=CoinX }"  
                     Canvas.Top="{Binding Path=CoinY }" />
    <Ellipse Name="target" Canvas.Left="{Binding Path=TargetX}"  
                     Canvas.Top="{Binding Path=TargetY}" />
...
</Canvas>
//JumpSearchViewModel.fs
type JumpSearchViewModel() as x =   
    class
        ...
        member x.CoinX 
            with get () =  
                env.coinX   
            and set value = 
                env <- JumpMazeModel.setCoinX env value coin
                base.RaisePropertyChangedEvent(<@x.CoinX@>) 
    
        member x.CoinY 
            ...
        member x.TargetX 
            with get () =  
                env.targetX   
            and set value = 
                env <- JumpMazeModel.setCoinX env value coin
                base.RaisePropertyChangedEvent(<@x.TargetX@>) 
    
        member x.TargetY 
            ...
        member x.CoinMoveCommand =
            new RelayCommand ((fun _ -> not env.IsEmpty && not timer.IsEnabled && x.Verify "MazeX" = null && x.Verify "MazeY" = null), 
                                (fun key -> x.CoinMove(key)))
        member x.CoinMove(k)= 
            env <- JumpMazeModel.moveCoin {env with obstacles=obstacles} (k :?> Key) selectedCoin 
            match selectedCoin with
            | Start _ ->
                selectedCoin <- Start (env.coinX, env.coinY)
                base.RaisePropertyChangedEvent(<@x.CoinX@>)
                base.RaisePropertyChangedEvent(<@x.CoinY@>)
            | Finish _ ->
                selectedCoin <- Finish (env.targetX, env.targetY)
                base.RaisePropertyChangedEvent(<@x.TargetX@>)
                base.RaisePropertyChangedEvent(<@x.TargetY@>)
...
//JumpSearchModel.fs
...
    let moveCoin (mazeEnv : MazeEnvironment) key selectedCoin =
        let move (coinX, coinY) =
            let cx, cy = (int coinX) / int mazeEnv.wallSize , (int coinY) / int mazeEnv.wallSize
            match key, mazeEnv.IsEmpty with
            | _, true -> coinX, coinY
            | Key.Down, false ->             
                if cy >= mazeEnv.maze.h - 1 || (Set.exists ( fun w -> w = (cx, cy + 1)) mazeEnv.obstacles ) then
                    coinX, coinY
                else
                    coinX, coinY + mazeEnv.wallSize
            | Key.Up, false -> 
                if cy = 0 || (Set.exists ( fun w -> w = (cx, cy - 1)) mazeEnv.obstacles) then
                    coinX, coinY
                else
                    coinX, coinY - mazeEnv.wallSize
            | Key.Right, false -> 
                if cx >= mazeEnv.maze.w - 1 || (Set.exists ( fun w -> w = (cx + 1, cy)) mazeEnv.obstacles) then
                    coinX, coinY
                else
                    coinX + mazeEnv.wallSize, coinY
            | Key.Left, false -> 
                if cx = 0 || (Set.exists ( fun w -> w = (cx - 1, cy)) mazeEnv.obstacles) then
                    coinX, coinY
                else
                    coinX - mazeEnv.wallSize, coinY
            | _, false -> coinX, coinY
        match selectedCoin with
        | Start (dx, dy) -> 
            let moveX, moveY = move (dx, dy)
            {mazeEnv with coinX = moveX; coinY = moveY}
        | Finish (dx, dy) -> 
            let moveX, moveY = move (dx, dy)
            {mazeEnv with targetX = moveX; targetY = moveY}

    let setCoinX (mazeEnv : MazeEnvironment) x selectedCoin = 
        if mazeEnv.IsEmpty |> not && x < float (mazeEnv.maze.w * int mazeEnv.wallSize)  then
               match selectedCoin with
               | Start _ -> {mazeEnv with coinX = x}
               | Finish _ -> {mazeEnv with targetX = x}
        else
            mazeEnv
    
    let setCoinY (mazeEnv : MazeEnvironment) y selectedCoin = 
        ...
Die zweite Herausforderung bestand in der Mausklick-Verarbeitung im Zusammenhang mit der Positionsbestimmung des Mauszeigers. Man sollte per Mausklick entweder ein Chip auswählen können oder ein Hindernis an der entsprechenden Position zu zeichnen oder zu löschen.
...
<Canvas.InputBindings>
                <MouseBinding MouseAction="LeftClick" Command="{Binding LeftClickCommand}" />
                <MouseBinding MouseAction="RightClick"  Command="{Binding RightClickCommand}" />
</Canvas.InputBindings>
...
Wie oben schon erwähnt, wird die Position über den Aufruf von Mouse.GetPosition ermittelt. Die Hindernis-Positionen werden in einer Liste gespeichert und mit der Hilfe von Path-Geometry auf dem Canvas-Element abgebildet.
//JumpSearchViewModel.fs
type JumpSearchViewModel() as x =  
...
        let mutable obstacles = set[]
        let mutable mazeGeometry = Geometry.Parse("")
...
        //maze path geometry.   
        member x.MazeData  
            with get () =  mazeGeometry
            and set value = 
                mazeGeometry <- value
                base.RaisePropertyChangedEvent(<@x.MazeData@>) 

        member x.LeftClickCommand  = 
            // if the mouse position hit the start or the finish coin position,
            // then select a coin. Otherwise add obstacle at mouse position.
            new RelayCommand ((fun canExecute -> not env.IsEmpty && not timer.IsEnabled && x.Verify "MazeX" = null && x.Verify "MazeY" = null), 
                                (fun element -> 
                                    let pos = Mouse.GetPosition(element :?> UIElement)
                                    let cellPos (posx, posy) = (posx / 20.0 |> int), (posy / 20.0 |> int)
                                    //check if the mouse click hit the start or the finish coin position.
                                    match cellPos (pos.X, pos.Y) = cellPos (env.coinX, env.coinY),  cellPos (pos.X, pos.Y) = cellPos (env.targetX, env.targetY) with
                                    | true, _ -> selectedCoin <- Start (env.coinX, env.coinY)
                                    |_, true -> selectedCoin <- Finish (env.targetX, env.targetY)
                                    | _ ->
                                        obstacles <- Set.add (cellPos (pos.X, pos.Y)) obstacles
                                        x.MazeData <- Geometry.Parse(JumpSearchViewModel.CreateMazePath (x.MazeX |> float)  (x.MazeY |> float) x.WallSize obstacles)))
        member x.RightClickCommand  =
            //Remove obstacle at mouse position.
            new RelayCommand ((fun canExecute -> not env.IsEmpty && not timer.IsEnabled && x.Verify "MazeX" = null && x.Verify "MazeY" = null), 
                                (fun element -> 
                                    let pos = Mouse.GetPosition(element :?> UIElement)
                                    let posx, posy = (pos.X/20.0 |> int), (pos.Y / 20.0 |> int)
                                    obstacles <- Set.remove (posx, posy) obstacles
                                    x.MazeData <- Geometry.Parse(JumpSearchViewModel.CreateMazePath (x.MazeX |> float)  (x.MazeY |> float) x.WallSize obstacles)))
...
Das Labyrinth und der Ergebnispfad.
<!--Labirynth and solver result path-->
<Path Name="mazePath" Stroke="Black" Data="{Binding Path=MazeData}" StrokeThickness="4" ></Path>
<Path Name="solverPath" Stroke="Purple"  Data="{Binding Path=SolverData}"  StrokeDashArray="4 2"  StrokeThickness="3" ></Path>
...
<Button Command="{Binding CreateMazeCommand}"  CommandParameter="{Binding ElementName=canvas}"   >Init Maze</Button>
<Button Name="AStar" Command="{Binding CreateAStarCommand}">A* Jump Points Search</Button>
Die komplexe Pfade lassen sich leicht mit der Hilfe von der Markup-Syntax beschreiben.
//JumpSearchViewModel.fs
type JumpSearchViewModel() as x =  
...
        let mutable mazeGeometry = Geometry.Parse("")
        let mutable solverPath = Geometry.Parse("")
...
        static member CreateMazePath w h wallSize points =
        
            let builder = StringBuilder()
        
            let folder (acc : StringBuilder) wall  =
                match wall with
                | (x, y) ->
                    let xf, yf = (float x) * wallSize, (float y) * wallSize
                    acc.Append(sprintf "M%f,%fV%f" xf yf  (yf + wallSize))|>ignore
                    acc.Append(sprintf " H%fV%fH%f" (xf + wallSize) yf xf) 
        
            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 * wallSize)) |> ignore
            builder.Append(sprintf " %f,%f %f,%f" 0.0   (h * wallSize)  (w * wallSize)  (h * wallSize)) |>ignore
            builder.Append(sprintf " %f,%f %f,%f" (w * wallSize)  (h * wallSize)    (w * wallSize)    0.0) |>ignore
            builder.Append(sprintf " %f,%f %f,%f" (w * wallSize)  0.0   0.0     0.0)|>ignore
            (points |> PSeq.fold folder builder).ToString()
        member x.SolverData  
            with get () =  solverPath
            and set value = 
                solverPath <- value
                base.RaisePropertyChangedEvent(<@x.SolverData@>)

        member x.CreateMazeCommand = 
            new RelayCommand ((fun canExecute -> x.VerifyX = null && x.VerifyY = null), (fun element -> x.CreateMaze(element)))

        member x.CreateMaze(element) =
            ...
            x.MazeData <- Geometry.Parse("")
            x.SolverData <- Geometry.Parse("")
            env <- JumpMazeModel.createMaze x.MazeX x.MazeY x.WallSize
            selectedCoin <- Finish (env.targetX, env.targetY)
            x.TargetX <- env.targetX
            x.TargetY <- env.targetY
            obstacles <- env.obstacles
            x.MazeData <- Geometry.Parse(JumpSearchViewModel.CreateMazePath (x.MazeX |> float)  (x.MazeY |> float) x.WallSize obstacles)

        member x.CreateAStarCommand =
            new RelayCommand (
                                (fun canExecute -> true),
                                 (fun _ -> 
                                     if x.VerifyX = null && x.VerifyY = null then x.CreateAStar()))
        //create solver path.
        member x.CreateAStar() =
            ...
            let jumpPoints = JumpMazeModel.run {env with obstacles = obstacles}
            x.SolverData <- Geometry.Parse(jumpPoints |> JumpMazeModel.resultPath |> JumpMazeModel.solverToPath x.WallSize )
Das Schwierigste war für mich die Visualisierung. Es geht bestimmt irgendwie besser und anders. Meine Lösung ist die Verwendung von der DispatcherTimer-Klasse. Die Positionen von den besuchten Zellen mitsamt Positionen von Vater-Zellen werden in einer Liste - animatePoints - gespeichert. Bei jedem Tick-Ereignis wird ein Listenelement aus der Liste genommen und als ein Ellipse-Element in der Children-Eigenschaft von Canvas gespeichert. Zusätzlich wird der Weg von der Vater-Zelle zu der aktuellen Zelle gezeichnet.
<Canvas Name="canvas">
    ...
    <Path Stroke="BurlyWood" Data="{Binding Path=AnimateData}" StrokeThickness="2"></Path>
    ...
</Canvas>
...
<Button Command="{Binding AnimateCommand}" >Animate</Button>
...
//JumpSearchViewModel.fs
type JumpSearchViewModel() as x=   
    class
...
        let mutable animateData = String.Empty
        let mutable animateResult = String.Empty
        let mutable timer = new DispatcherTimer(DispatcherPriority.Normal)
         //( (int * int) * ((int * int) * Direction) ) list. 
         //( jumpPoint   * (parent      * direction)) list 
        let mutable animatePoints = []
        let mutable undo = []
        let mutable canvas : Canvas = null
        do 
            timer.Interval <- new TimeSpan(0, 0, 0, 0, 400)
            
            timer.Tick.Add(fun _  -> x.AnimateOneStep () )   
...
        member x.AnimateData  
            with get () =  Geometry.Parse(animateData)
            and set value = 
                solverPath <-  Geometry.Parse(value)
                base.RaisePropertyChangedEvent(<@x.AnimateData@>)  
        
        member x.AnimateCommand =
            new RelayCommand ((fun _ -> true), 
                                        (fun _ ->  
                                            match not env.IsEmpty && x.Verify "MazeX" = null && x.Verify "MazeY" = null with
                                            | false -> ()
                                            | true -> 
                                                x.SolverData <- Geometry.Parse("")
                                                x.ResetAnimateData() 
                                                selectedCoin <- Start (env.coinX, env.coinY)
                                                let animateRun =  JumpMazeModel.run {env with obstacles = obstacles}
                                                animateResult <- animateRun |> JumpMazeModel.resultPath |> JumpMazeModel.solverToPath x.WallSize
                                                animatePoints <- animateRun |> JumpMazeModel.animatePoints |> Seq.toList
                                                timer.Start()))

        member x.AnimateOneStep () =
            match animatePoints with
            | [] -> timer.Stop()
            | [((currx, curry),(x',y'), d)] ->
                let x2, y2, x1, y1 = (currx |> float) * env.wallSize + env.wallSize / 2.0, (curry |> float) * env.wallSize + env.wallSize / 2.0, (x' |> float) * env.wallSize + env.wallSize / 2.0, (y' |> float) * env.wallSize + env.wallSize / 2.0
                animateData <- sprintf "%sM%f,%fL%f,%f %f,%f%s" animateData x1 y1 x1 y1 x2 y2 (x.DrawArrow (x2, y2, d))
                x.AnimateData <- animateData
                x.SolverData <-  Geometry.Parse(animateResult)
                timer.Stop()
            | ((currx, curry),(x',y'), d) :: ts->
                let x2, y2, x1, y1 = (currx |> float) * env.wallSize + env.wallSize / 2.0, (curry |> float) * env.wallSize + env.wallSize / 2.0, (x' |> float) * env.wallSize + env.wallSize / 2.0, (y' |> float) * env.wallSize + env.wallSize / 2.0
                // add new Point to Path and draw a line with arrows
                // from the last point to the new point.
                animateData <- sprintf "%sM%f,%fL%f,%f %f,%f%s" animateData x1 y1 x1 y1 x2 y2 (x.DrawArrow (x2, y2, d))
                x.AnimateData <- animateData
                // move the start coin.
                x.CoinX <- x2
                x.CoinY <- y2
                // add new jump point to canvas children collection.
                if canvas <> null then
                    let e = new Ellipse(Width = 6.0, Height= 6.0, Fill = Brushes.Blue)
                    canvas.Children.Add(e)|>ignore
                    Canvas.SetLeft(e, x2 )
                    Canvas.SetTop(e, y2 )
                    //add remove function to undo functon list.
                    undo <- [(fun _ -> canvas.Children.Remove e;)] @ undo

                animatePoints <- ts

        member x.CreateAStar() =
            x.ResetAnimateData()
            ...
        member x.CreateMaze(element) =
            x.ResetAnimateData()
            ...
        member private x.ResetAnimateData() =
            if timer.IsEnabled then
                timer.Stop()
            // Remove all added ellipses.
            List.map (fun f -> f ()) undo|>ignore
            animateData <- String.Empty
            x.AnimateData <- animateData
            ...
Der Code.

Mittwoch, 9. November 2011

F#. A* Star Pathfinding with Jump Point Search.



Das gesamte Projekt ist auf dem GitHub unter "Maze-Generator-and-Maze-Solver".

"Jump Point Search" Algorithmus ist ein sehr interessanter, einfacher und effizienter Algorithmus, der die A * Suche dadurch beschleunigt, dass letztendlich weniger Nodes besucht wird. Ich kann nur empfehlen den Blog-Eintrag und die ausführliche Beschreibung zu lesen, da die ganze Deatils zur Implementierung der Algorithmus dort ganz gut erklärt sind.
Es gibt bereits eine C++ Implementierung.

Die angepasste A* Suche Funktion.
//JumpPointsSearch.fs
...
   // return all jump points with parents and costs.  seq<jumpPoint   * (parent      * cost)> 
  //astarJump : int * int -> JumpPointEnvironment -> seq<(int * int) * ((int * int) * float)>
  let inline astarJump start env = 
      let inner (seen, q)  =
           match PriorityQueue.isEmpty q with
           | true -> failwith "No Solution."
           | false ->
               let ((currentCosts, next), dq) = PriorityQueue.deleteFindMin q
               let expanded, parent = next
               if currentCosts = 0.0 then None
               else 
                   match env.isGoal expanded with
                   | true -> Some ((expanded, (parent, currentCosts)),(seen, PriorityQueue.singleton 0.0 (expanded, expanded)))
                   | otherwise -> 
                       let succs = successors env.rooms expanded
                       let dir = directionToParent parent expanded
                       let jumpPoints= findJumpPoints env expanded dir succs  |> Set.ofSeq
 
                       let costs target = currentCosts + (env.stepCosts expanded target)  
                                            + (env.heuristic target) - (env.heuristic expanded) 

                       let q' = 
                           Set.difference jumpPoints seen |> Seq.map (fun a -> costs a, (a, expanded)) 
                           |> PriorityQueue.ofSeq |> PriorityQueue.merge dq
                       Some ((expanded, (parent, currentCosts)), ((Set.union seen jumpPoints), q'))
                   
      Seq.unfold inner ((Set.singleton start), (PriorityQueue.singleton (env.heuristic start) (start,start))) 
Typen und Hilfsfunktionen für das Jump Point Search Verfahren.
//
module JumpPointSearchType =
  open MazeType

  type StraightDirection = N  | S | E  | W  
  type DiagonalDirection = NE | NW | SE | SW
   
  type Direction =
    | Straight of StraightDirection * Cell
    | Diagonal of DiagonalDirection * Cell
    | NONE

  type JumpPointEnvironment = 
    { grid: Map<int * int, Direction list>;  //cells with avialiable Directions.
      w : int; h : int;     // Weight and Height
      isGoal : int * int -> bool;
      heuristic : int * int -> float;
      stepCosts : int * int -> int * int -> float}
        member x.successors point = 
          set[for direction in Map.find point x.grid  do
                  yield direction
              ]

  let empty = { grid = Map.empty; w = 20; h = 20; isGoal = (fun _ -> true);
                heuristic = (fun _ -> 0.0)
                stepCosts = (fun _ _-> 0.0)
               }

  let inline straightPosition direction =
    match direction with
    | N -> (0, -1)
    | S -> (0, 1)
    | E -> (1, 0)
    | W -> (-1, 0)
  
  let diagonalPosition direction =
    match direction with
    | NE -> (1,  -1)
    | SE -> (1,   1)
    | SW -> (-1,  1)
    | NW -> (-1, -1)
  
  let inline straight  direction = Straight (direction, straightPosition direction)
  let inline diagonal  direction = Diagonal (direction, diagonalPosition direction)

  type NotRule = Not of Direction

  let inline notRule direction = Not (straight direction)
  
  type PruningRule = 
      | StraightRule of (NotRule * Direction) 
      | DiagonalRule of Direction
  
  let inline straightRule notrule direction  = StraightRule (notrule, diagonal direction) 
  let inline diagonalRule direction  = DiagonalRule (straight direction)

  let inline flip f a b = f b a

  let inline inGrid w h cell =
            match cell with
            | x, y when (0 <= x && x <= w - 1 && 0 <= y && y <= h - 1) -> true
            | _  -> false
Jump Point Search Algorithm.
//  findJumpPoints : JumpPointEnvironment -> int * int -> Direction -> Set<Direction> -> (int * int) list
  let inline findJumpPoints env (x, y) direction neighbours  =
      let find naturalNeighbours forcedNeighboursRules =
          naturalNeighbours @ 
              (forcedNeighboursRules
               |> List.filter (not << flip Set.contains neighbours << fst)
               |> List.map snd)
          |> List.choose (jump env x y)
      //Neighbour Pruning Rules
      match direction with
      | Straight(N, _) -> 
          // add S neighbour to the pruned set of neighbours.
          // add SE neighbour only if E neighbour is obstacle.
          // add SW neighbour only if W neighbour is obstacle.
          find [straight S]
                    (List.zip   [straight E;     straight W] 
                                [diagonal SE;    diagonal SW])

      | Diagonal(NE, _) -> 
          find [diagonal SW; straight S; straight W]
                    (List.zip   [straight N;     straight E] 
                                [diagonal NW;    diagonal SE])

      | Straight(E, _) ->
          find [straight W]
                    (List.zip   [straight N;     straight S] 
                                [diagonal NW;    diagonal SW])
      | Straight(S, _) -> 
          find [straight N] 
                    (List.zip   [straight E;     straight W] 
                                [diagonal NE;    diagonal NW])
      | Diagonal(SE, _) -> 
          find [diagonal NW; straight N; straight W]   
                    (List.zip   [straight S;     straight E] 
                                [diagonal SW;    diagonal NE])
      | Straight(W, _) -> 
         find [straight E]           
                    (List.zip   [straight N;     straight S] 
                                [diagonal NE;    diagonal SE])
      | Diagonal(SW, _) -> 
          find [diagonal NE; straight N; straight E]   
                    (List.zip   [straight S;     straight W] 
                                [diagonal SE;    diagonal NW])
      | Diagonal(NW, _) -> 
          find [diagonal SE; straight S; straight E]
                   (List.zip   [straight N;     straight W] 
                               [diagonal NE;    diagonal SW])
      // return all neighbours as the pruned set of neighbours.
      | NONE -> directionsToPoints neighbours (x, y) |> Set.toList
Details
module JumpPointsSearch =
  open Microsoft.FSharp.Collections
  open Astar
  open JumpPointSearchType
  
  let sqrtTWO = 1.414213562
  
  let inline diagHeuristic (x1, y1) (x2, y2) =
    let diagonal = min (abs(x1 - x2)) (abs (y1 - y2)) |> float
    let straight = (abs (x1 - x2)) + (abs (y1 - y2)) |> float
    sqrtTWO * diagonal + (straight - 2.0 * diagonal)


  let inline stepCosts (x1,y1) (x2,y2) = 
        let xa, ya = abs(x1-x2), (abs(y1-y2))
        (sqrtTWO - 1.0) * (min xa ya |> float) + (max xa ya |> float) 

  // move with turning points rules in direction jumpDirection.
  // recursively apply the straight pruning rule or
  // the diagonal pruning rule.
  // jump : JumpPointEnvironment -> int -> int -> Direction -> (int * int) option
  let rec jump env x y jumpDirection =
          let generateSteps dx dy notObstacle =
                (x, y)
                |> Seq.unfold (fun cell -> 
                                    let nextCell = MazeUtils.addPoint cell (dx, dy)
                                    if inGrid env.w env.h nextCell && notObstacle cell then 
                                        Some(nextCell, nextCell) 
                                    else None) 
          let directionSteps direction = 
                match direction with
                | NONE -> Seq.empty
                | Straight(_,(dx, dy)) -> generateSteps dx dy (Set.contains direction << env.successors )
                | Diagonal(_,(dx, dy)) -> generateSteps dx dy (Set.contains direction << env.successors )          
          
          let move direction directionRules =
              //apply the pruning rules.
              let applayRules rules func (px, py) = 
                    Seq.map (fun rule -> 
                                    match rule with
                                    | StraightRule(Not a, b) -> (not <| func a) && func b 
                                    | DiagonalRule dir -> jump env px py dir |> Option.isSome) rules |> Seq.reduce (||)
              //all available steps in current direction.
              let steps = directionSteps direction 
              //try to find jump point p. 
              steps
              |> Seq.tryFind (fun p ->
                    env.isGoal p || applayRules directionRules (flip Set.contains (env.successors p)) p)
                        
          match jumpDirection with
          | NONE -> None
          
          | Straight(N, _) as dir -> 
            //(x, y) is a jump point if a NW neighbour exists which cannot be                                  
            // reached by a shorter path than one involving (x, y) or with other words W is obstacle or
            // if NE and not E
                                     move dir [straightRule (notRule W) NW; straightRule (notRule E) NE]

          | Straight(S, _) as dir -> move dir [straightRule (notRule W) SW; straightRule (notRule E) SE] 

          | Straight(E, _) as dir -> move dir [straightRule (notRule S) SE; straightRule (notRule N) NE]

          | Straight(W, _) as dir -> move dir [straightRule (notRule S) SW; straightRule (notRule N) NW]
          
          | Diagonal(NE, _) as dir -> 
            //(x, y) is a jump point if a SE neighbour exists which cannot be                                  
            // reached by a shorter path than one involving (x, y) or with other words S is obstacle or
            // if NW and not W or 
            // if we can reach other jump points by 
            // travelling vertically or horizontally.  
                                      move dir [straightRule (notRule S) SE; straightRule (notRule W) NW;
                                                diagonalRule N; diagonalRule E] 

          | Diagonal(SE, _) as dir -> move dir [straightRule (notRule W) SW; straightRule (notRule N) NE;
                                                diagonalRule S; diagonalRule E]
          | Diagonal(SW, _) as dir -> move dir [straightRule (notRule N) NW; straightRule (notRule E) SE;
                                                diagonalRule S; diagonalRule W]
          | Diagonal(NW, _) as dir -> move dir [straightRule (notRule E) NE; straightRule (notRule S) SW;
                                                diagonalRule N; diagonalRule W]
  
  // directionsToPoints : Set<Direction> -> int * int -> Set<int * int>
  let inline directionsToPoints directions (x, y)=
      let inner d = 
              match d with
              | Straight(_, (dx, dy)) ->    x + dx, y + dy
              | Diagonal(_, (dx, dy)) ->    x + dx, y + dy
              | NONE -> failwith "failed to determine direction."
      Set.map inner directions
Ausführen.
...
    open Maze.JumpPointSearchType
    open Maze.JumpPointsSearch

    type MazeEnvironment = 
        { maze : JumpPointEnvironment; obstacles : Set<(int * int)>; 
          wallSize : float; coinX : float; coinY : float; targetX : float; targetY : float}
        member this.IsEmpty = Map.isEmpty <| this.maze.grid

    let empty = { maze = empty; obstacles = Set.empty;
                  wallSize = 20.0; coinX = 0.0; coinY = 0.0;targetX = 0.0; targetY = 0.0 }
    // Create the grid from the obstacles set.
    // mapObstaclesToGrid : JumpPointEnvironment -> Set<int * int> -> JumpPointEnvironment
    let inline mapObstaclesToGrid mazeEnv obstacles =
        
        let notObstacleDiagonal straight pos =
            let isInGrid = List.forall (inGrid mazeEnv.w mazeEnv.h)  (pos :: straight)
            match isInGrid with
            | true -> not <| Set.contains pos obstacles && Set.intersect (Set.ofList straight) obstacles |> Set.count < 2
            | _  ->   false

        let notObstacle cell = 
            match inGrid  mazeEnv.w mazeEnv.h cell with
            | true -> not <| Set.contains cell obstacles 
            | false -> false

        let mkWall (x, y) =
            let add =  addPoint (x, y)
            (x,y), [straight W,   straightPosition W |> add |> notObstacle;
                    straight N,   straightPosition N |> add |> notObstacle;
                    straight E,   straightPosition E |> add |> notObstacle; 
                    straight S,   straightPosition S |> add |> notObstacle; 
                    diagonal NW,  diagonalPosition NW |> add |> notObstacleDiagonal [straightPosition N |> add; 
                                                                                     straightPosition W |> add ]; 
                    diagonal NE,  diagonalPosition NE |> add |> notObstacleDiagonal [straightPosition N |> add;
                                                                                     straightPosition E |> add ]; 
                    diagonal SW,  diagonalPosition SW |> add |> notObstacleDiagonal [straightPosition S |> add;
                                                                                     straightPosition W |> add ]; 
                    diagonal SE,  diagonalPosition SE |> add |> notObstacleDiagonal [straightPosition S |> add;
                                                                                     straightPosition E |> add ]]
            |> List.filter (id << snd)
            |> List.map fst
        {mazeEnv with 
            grid = Seq.map mkWall 
                        [ for x in [0..mazeEnv.w-1] do
                            for y in [0..mazeEnv.h-1] do
                            yield x, y] |> Seq.toList |> Map.ofList }
    
    // run : MazeEnvironment -> seq<(int * int) * ((int * int) * float)>    
    let run env = 
        let jumpPointEnv = mapObstaclesToGrid env.maze env.obstacles
        let start = env.coinX / env.wallSize |> int, env.coinY / env.wallSize |>int
        let finish = env.targetX / env.wallSize |> int, env.targetY / env.wallSize |> int
        astarJump start { jumpPointEnv with isGoal = ((=) finish); stepCosts = stepCosts;  heuristic = (diagHeuristic finish) }

    // jump points  seq<jumpPoint   * (parent      * cost)>  to path of points list.
    // resultPath : seq<(int * int) * ((int * int) * float)> -> (int * int) list
    let inline resultPath jumpPoints =
        jumpPoints
        |> Seq.groupBy (fst)
        |> Seq.map (fun (key, s)-> key, Seq.minBy (snd << snd) s |> snd |> fst) 
        |> Seq.toList |> List.rev
        |> List.fold (fun acc (curr, parent) -> 
                        match acc with
                        | [] -> [parent;curr;]
                        | x :: _ when x = curr-> parent :: acc
                        | _ -> acc) []
    
    let inline animatePath jumpPoints = jumpPoints |> Seq.map (fun (curr, (parent, _)) -> curr, parent, directionToParent curr parent)
Ehrlich gesagt habe ich die meiste Zeit mit WPF verbracht, um die halbwegs brauchbare Algorithmus-Animation zu erstellen.