Seiten

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.

Donnerstag, 25. August 2011

F# Transaction Monad.

Nachdem ich sehr interessante Beiträge über die verschiedensten F# Monads begeistert gelesen habe, überlegte ich mir, ob man so was wie eine Transaction Monad implementieren kann.
Und tatsächlich gibt es bereits eine Haskell Version. Hundertprozentig ist die Funktionsweise von der Monad für mich noch nicht klar, aber soweit ich es beurteilen kann ist die Transaktion ein Hybrid aus der Continuation und der State Monad.

Erstmal ein paar Tests:
open TransactionM
// 5 ways you can leave the monad.
// handle : transaction handle.
let test0 handle = 
    transaction {
      let! s = get
      do! set 99
      match s with
        | 0 -> return id
        | 1 -> return! abort    handle (Some s)
        | 2 -> return! dirty    handle (Some s.)
        | 3 -> return! rollback handle  "rollback!"
        | _ -> return! commit   handle  "commit"
    }
// return TransactionState<int,string> * int. second item is result of transaction.
let runTest0  = 
    let run = runTransaction_ (beginT test0)
    List.map run [0..4]
val test0 :
  TransactionM.TransactionHandle<'a,int,
                                 TransactionM.TransactionState<int,string>> ->
    TransactionM.TransactionM<'a,int,('b -> 'b)>

val runTest0 : (TransactionM.TransactionState<int,string> * int) list =

  [ (Abort null, 0); 
    (Abort (Some 1), 1); 
    (Dirty (Some 2), 99);
    (Rollback "rollback!", 3);
    (Commit "commit", 99) ]

Einfache Listenmanipulation als eine Transaktion.
// Simple list manipulation as transaction.
// p : some condition
// l : init list
// handle : transaction handle.
let testList p l handle = transaction {
        do! set l
        do! modify (fun xs-> 6::xs)
        do! modify (fun xs-> 7::xs)       
        match p  with
        | false -> return! rollback handle  "rollback!" 
        | true -> return! commit   handle   "commit."
    }
// Only if both transactions are successful then concatenate the two lists and commit all transactions.
// rollback otherwise.
// m1, m2 - transactions.
// handle : transaction handle.
let merge m1 m2 handle = 
    transaction {
            let! state1 = m1
            match state1 with
            | Commit a ->  
                let! firstList = get
                printfn "    first list: %A" firstList 

                let! state2 = m2
                match state2 with
                | Commit b   ->  
                    let! secondList = get
                    printfn "    second list: %A" secondList
                    do! set (firstList @ secondList)
                    return! commit   handle  b

                | Rollback b ->  return! rollback   handle  b
                | _          ->  return! abort      handle (Some "abort")

            | Rollback a    ->   return! rollback   handle  a                        
            | _             ->   return! abort      handle (Some "abort")
        }
//return TransactionState<string,'b> * 'c list. second item is result of transaction.
let runMerge i m1 m2 = 
    printfn "Start runMerge %A." i
    let m = beginT (merge m1 m2)
    runTransaction_ m [] 
// ls : list of list.
// return TransactionState<string,string> * int list. second item is result of transaction.
let runList ls = 
    printfn "Start runList."
    let m = List.fold (fun acc (l, p) -> beginT (merge acc (beginT (testList p l)))) (alwaysCommit "commit") ls
    runTransaction_ m []

printfn "runMerge 1: %A " (runMerge 1 (beginT (testList true  [0..3] )) (beginT (testList true  [10..13])))
printfn "runMerge 2: %A " (runMerge 2 (beginT (testList false [0..3] )) (beginT (testList true  [10..13])))

printfn "%A" (runList  [([0..3], true); ([10..13], true); ([20..23], true)])
printfn "%A" (runList  [([0..3], true); ([10..13], true); ([20..23], false)])
val testList :
  bool ->
    int list ->
      TransactionM.TransactionHandle<'a,int list,
                                     TransactionM.TransactionState<'b,string>> ->
        TransactionM.TransactionM<'a,int list,('c -> 'c)>
val merge :
  TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'c,'d>> ->
    TransactionM.TransactionM<'a,'b list,TransactionM.TransactionState<'e,'d>> ->
      TransactionM.TransactionHandle<'a,'b list,
                                     TransactionM.TransactionState<string,'d>> ->
        TransactionM.TransactionM<'a,'b list,('f -> 'f)>
val runMerge :
  'a ->
    TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
                               'c list),'c list,
                              TransactionM.TransactionState<'d,'b>> ->
      TransactionM.TransactionM<(TransactionM.TransactionState<string,'b> *
                                 'c list),'c list,
                                TransactionM.TransactionState<'e,'b>> ->
        TransactionM.TransactionState<string,'b> * 'c list
val runList :
  (int list * bool) list ->
    TransactionM.TransactionState<string,string> * int list

Start runMerge 1.
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
runMerge 1: (Commit "commit.", [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]) 

Start runMerge 2.
runMerge 2: (Rollback "rollback!", []) 

Start runList.
    first list: []
    second list: [7; 6; 0; 1; 2; 3]
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
    first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
    second list: [7; 6; 20; 21; 22; 23]
(Commit "commit.",
 [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13; 7; 6; 20; 21; 22; 23])

Start runList.
    first list: []
    second list: [7; 6; 0; 1; 2; 3]
    first list: [7; 6; 0; 1; 2; 3]
    second list: [7; 6; 10; 11; 12; 13]
    first list: [7; 6; 0; 1; 2; 3; 7; 6; 10; 11; 12; 13]
(Rollback "rollback!", [])
Interessant ist ob die Transaktionen asynchron ausgeführt werden können. Ich habe es leider nicht hingekriegt.

Hier ist meine F# Implementierung von der Transaktion Monad.
// from http://hackage.haskell.org/packages/archive/monad-tx/0.0.1/doc/html/Control-Monad-Tx.html
module TransactionM 

open System

// 'e : error type
// 'a : transaction state type
type TransactionState<'e,'a> =
    | Begin
    | Abort of ('e option)
    | Dirty of ('e option)
    | Rollback of 'a
    | Commit of 'a

// 's : state
// 'a : TransactionState
// 'r : result 
// ('s -> 'a -> 'r) : continuation
type TransactionM<'r, 's, 'a> = TransactionM of ('s -> ('s -> 'a -> 'r) -> 'r)

type TransactionHandle<'r, 's, 'a> = TransactionHandle of (('a * TransactionHandle<'r, 's, 'a>) -> TransactionM<'r, 's, unit>)

let inline runTransaction (TransactionM g) s k = g s k

// result is of type (TransactionState * state)
let inline runTransaction_ (TransactionM g) s = g s (fun s' a ->  (a, s'))
// result is of type TransactionState
let inline runTransactionState (TransactionM g) s = g s (fun _ a ->  a)

let inline withCommit f = 
    TransactionM (fun s k -> 
                    let (TransactionM g) = f (fun a -> TransactionM (fun s' _ ->  k s' a)) 
                    g s k)

let inline withRollback f = 
    TransactionM (fun s k -> 
                    let (TransactionM g) = (f (fun a -> TransactionM (fun _ _ -> k s a))) 
                    g s k)

let inline bind (TransactionM g) f = 
    TransactionM(fun s k -> 
                    g s (fun s' a ->
                            let (TransactionM g') = f a
                            g' s' k))
//computation workflow builder.
type TransactionBuilder() =
    member this.Return(a)                               = TransactionM(fun s k -> k s a) 
    member this.Bind(m, k)                              = bind m k
    member this.Zero ()                                 = this.Return ()
    member this.Combine(r1, r2)                         = this.Bind(r1, fun _ -> r2) 
    member this.ReturnFrom(m : TransactionM<_,_,_>)     = m
    member this.Delay(f)                                = this.Bind(this.Return (), f)
    
    member this.TryFinally(computation, compensation) =
        TransactionM(fun s k -> 
            try
                runTransaction computation s k
            finally
                compensation())

    member this.Using(res: #IDisposable, body) =
        this.TryFinally(body res,
            (fun () -> match res with null -> () | disp -> disp.Dispose()))

    member this.TryWith(computation, handler) =
        TransactionM(fun s k ->
            try
                runTransaction computation s k
            with e -> runTransaction (handler e) s k)

let transaction = new TransactionBuilder()

let inline bindM builder m f = (^M: (member Bind: 'd -> ('e -> 'c) -> 'c) (builder, m, f))

let inline (>>.) m n = bindM transaction m (fun _ ->  n)

let inline isBegin t =
    match t with
    | Begin -> true
    | _ -> false

let inline fmap f (TransactionM g) = TransactionM (fun s k -> g s (fun s' a -> k s' (f a)))
//begin transaction.
let inline beginT f =
    let checkpoint  = 
        withCommit (fun fcommit ->
            withRollback (fun frollback ->
                transaction {
                    let go (transactionState, handle) =
                        match transactionState with
                        | Begin         -> failwith     "nested"
                        | Abort e       -> frollback    (Abort e,       handle)
                        | Dirty e       -> fcommit      (Dirty e,       handle)
                        | Rollback a    -> frollback    (Rollback a,    handle)
                        | Commit a      -> fcommit      (Commit a,      handle)
                    return (Begin, TransactionHandle go) 
                    } ))

    withRollback (fun fabort ->
        transaction {
                    let! (transactionState, handle)  = checkpoint
                    if isBegin transactionState then
                        return!  (f  handle >>. fabort (Abort None))
                    return transactionState
                 })

//a bunch of helpers, which allow to access and manipulate transaction.

let inline alwaysCommit a = TransactionM(fun s k -> k s (Commit a))

let inline jump (TransactionHandle k) stat = 
    (k (stat, TransactionHandle k)) >>. TransactionM(fun s k -> k s id)

let inline abort    handle e = jump handle (Abort e)

let inline dirty    handle e = jump handle (Dirty e)

let inline rollback handle a = jump handle (Rollback a)

let inline commit   handle a = jump handle (Commit a)

let get = TransactionM (fun s k -> k s s)

let inline gets f = TransactionM (fun s k -> k s (f s))

let inline set s = 
    TransactionM (fun _ k -> k s ())

let inline modify f = TransactionM(fun s k -> k (f s) ())

Montag, 15. August 2011

F#. Flocks with k-d tree. Swarm Simulation Part 2.


Ich habe weiter mit der Schwarm Simulation gespielt.
Eine geeignete Datenstruktur zur Schwarm Simulation ist K-d tree, wie ich aus dem Beitrag "Functional flocks" erfahren habe.
Für unserer Zweck genügt es eigentlich zwei Dimensionen im k-d tree abzubilden.

// from Haskell Version https://github.com/mjsottile/publicstuff/tree/master/boids
namespace Flocks
open System

open Microsoft.FSharp.Math
open Microsoft.FSharp.Collections

module KDTree =

    type KDTreeNode<'a> =
        | Empty
        | Node of KDTreeNode<'a> * (float * float) * 'a * KDTreeNode<'a>
        //        left tree         position         data   Right tree
    
    let inline flatten tree =
        let s = System.Collections.Generic.Stack[tree]
        
        let rec loop (stack : Collections.Generic.Stack<KDTreeNode<'a>>) acc =
            match stack.Count>0 with
            | false -> acc
            | true ->
                match stack.Pop() with
                | Empty -> loop stack acc
                | Node(left, _, a, right) ->
                    stack.Push left
                    stack.Push right
                    loop stack (a :: acc)
        loop s


    let newKDTree = Empty

    let inline vecLessThan (a, b) (x, y)  = a < x && b < y
    let inline vecGreaterThan (a, b) (x, y)  = a > x && b > y

    let inline vecDimSelect (x, y) n =
        match n with
        | 0 -> x
        | 1 -> y
        | other -> failwith "invalid argument"  

    let inline kdtInBounds p bMin bMax =  (vecLessThan p bMax) && (vecGreaterThan p bMin)

    let inline kdtRangeSearch t bMin bMax =
        let rec inner t (current, next) acc =
            let nextfuncs = (next, current)
            match t with 
            | Empty -> acc
            | Node (left, npos, ndata, right) -> 
                match current npos < current bMin, 
                        current npos > current bMax with
                | true, _       -> inner right nextfuncs acc
                | _, true       -> inner left nextfuncs acc
                | false, false  ->
                    match kdtInBounds npos bMin bMax with
                    | true      -> inner right nextfuncs (inner left nextfuncs ((npos, ndata) :: acc))
                    | false     -> inner right nextfuncs (inner left nextfuncs acc)
        inner t (fst, snd) []

module Boids =
    open KDTree

    type Boid = { identifier : int; position : float * float; velocity : float * float; bounded : bool}

    // create KD Tree from boids list.
    let inline fromListWithDepth l =
        let rec loop boidPoints d =
            match Array.isEmpty boidPoints with
            | true -> Empty
            | false  ->
                let axis = d % 2 
                Array.sortInPlaceBy (fun boid -> vecDimSelect boid.position axis) boidPoints
                let index = Array.length boidPoints / 2
                if index = 0 then
                    let dataBoid =  boidPoints.[0]
                    Node (Empty, dataBoid.position, dataBoid, Empty)
                else
                    let lf, r =     boidPoints.[0..index - 1], boidPoints.[index..]
                    let dataBoid =  r.[0]
                    Node(loop lf  (d + 1) , dataBoid.position, dataBoid, loop r.[1..] (d + 1))
        loop (l |> Array.ofSeq) 0 
Meine Tests haben gezeigt, dass die explizite Verwendung vom Stack die schnellste Methode für das "flatten" einer Baumstruktur in einer Liste ist. Der umgekehrte Weg von einer Liste zu einem Baum ist die Funktion fromListWithDepth und sie ist die abgewandelte Version vom folgenden F# Snippet.
Der Rest ist ziehmlich identisch mit dem alten F# Boids Code. Der Schwarm ist in zwei Teilen geteilt - rote und blaue Teilchen - die einen bewegen sich in einer toroidalen Topologie (rote Teilchen), was komplett vom Matt Sottile Code übernommen ist, und die anderen (blaue) sind an die Grenzen des Formulars gebunden.
type Params = {velocity : float; cohesionParam : float;  separationParam : float;
                    sScale : float; alignmentParam : float;
                    vLimit : float; epsilon : float;
                    maxx : float;   maxy : float;
                    minx : float;   miny : float}
    let parms = 
        let maxx = 390.0
        let maxy = 390.0
        let minx = -8.0
        let miny = -8.0
        {velocity = 1.02; cohesionParam = 0.06; separationParam = 12.0; sScale = 0.2; 
         alignmentParam = 0.16; vLimit = 0.0025 * (max (maxx-minx) (maxy-miny));
         epsilon = 25.0; maxx = maxx; maxy = maxy;
         minx = minx; miny = miny}
    
    let vecZero = 0.0, 0.0

    let inline (<+>) (a, b) (a', b') = a + a', b + b'

    let inline (<->) (a, b) (a', b') = a - a', b - b'

    let inline (</>) (a, b) c = a/c, b/c

    let inline vecScale (s : float) (a, b) = s * a, s * b

    let inline sq x = x * x

    let inline vecNorm (x, y) = sqrt (sq x + sq y)
    //  sometimes we want to control runaway of vector scales, so this can
    // be used to enforce an upper bound
    let inline limiter boidVel speedLimit =
        match boidVel with
        |velX, velY when sq velX + sq velY > sq speedLimit ->
            let slowdown = (sq speedLimit) / (sq velX + sq velY)
            slowdown * velX, slowdown * velY
        |_ -> boidVel

    let inline findCentroid boids =
        match boids with
        | []      -> failwith "Bad centroid"
        | _   -> 
            let average f l = List.averageBy (fun boid -> boid.position |> f) l
            average fst boids, 
                average snd boids
            

// cohesion : go towards centroid.  parameter dictates fraction of
// distance from boid to centroid that contributes to velocity
    let inline cohesion b boids a  = 
        (findCentroid boids) <-> b.position
        |> vecScale a 
    
    //An acceleration to stop us hitting nearby boids
    let inline separation b boids a sScale =
        match boids with
        | [] -> vecZero
        | _ -> 
            boids
            |> List.map (fun boid -> boid.position <-> b.position)
            |> List.filter (fun i -> (vecNorm i) < a)       
            |> List.fold (<->) (0.0,0.0)   
            |> vecScale sScale
    
    //Boids try to match velocity with near boids.
    let inline alignment b boids a  =
        match boids with
        | [] -> vecZero
        | _ ->
            let avrg = List.averageBy (fun boid-> fst boid.velocity ) boids, List.averageBy (fun boid-> snd boid.velocity) boids
            vecScale a (avrg <-> b.velocity) 

    let inline wraparound parms  (x, y)  = 
        let w,h = parms.maxx - parms.minx, parms.maxy - parms.miny        
        let x' = if (x > parms.maxx) then x - w else (if x < parms.minx then x+w else x)     
        let y' = if (y > parms.maxy) then y - h else (if y < parms.miny then y+h else y) 
        (x', y')

    let inline boundPosition (boundMin,boundMax) boid =
        let bound coor =
            match coor > boundMax, coor<boundMin with
            |true, _ -> -1.0
            |_, true -> 1.0
            |_       -> 0.0
        bound <| vecDimSelect boid.position 0, bound <| vecDimSelect boid.position 1

    let inline oneboid parms b boids =  
        let c = cohesion b boids parms.cohesionParam       
        let s = separation b boids parms.separationParam parms.sScale 
        let a = alignment b boids parms.alignmentParam    

        //apply rules for current boid.
        let v' =  b.velocity <+> (vecScale 0.3 (c <+> s <+> a))
        match b.bounded with
        | true ->
            let vbound = v' <+> (boundPosition (parms.minx + 8.0, parms.maxx) b)
            let v'' = limiter (vecScale parms.velocity vbound) parms.vLimit      
            { b with identifier = b.identifier;  position = b.position <+> v'' ; velocity = v''}
        | false ->            
            let v'' = limiter (vecScale parms.velocity v') parms.vLimit      
            let p' =  b.position <+> v''
            { b with identifier = b.identifier;  position = wraparound parms p' ; velocity = v''}

    
    let inline splitBoxHoriz parms (lo, hi, ax, ay) =  
        let (lx, ly), (hx, hy) = lo, hi
        let w = parms.maxx - parms.minx
        if (hx-lx > w)   then 
            [( (parms.minx, ly), (parms.maxx, hy), ax, ay)]  
        else
            if (lx < parms.minx) then 
                [( (parms.minx, ly),  (hx, hy), ax, ay);
                 ( (parms.maxx - (parms.minx - lx), ly), (parms.maxx, hy), (ax - w), ay)]       
            else
                if (hx > parms.maxx)  then 
                    [((lx, ly),  (parms.maxx, hy), ax, ay);
                     ( (parms.minx, ly), (parms.minx + (hx - parms.maxx), hy), ax+w, ay)]            
                else [(lo,hi,ax,ay)]  
    
    let inline splitBoxVert parms (lo, hi, ax, ay) =
        let (lx, ly), (hx, hy) = lo, hi
        let h = parms.maxy - parms.miny
        if (hy-ly > h) then
            [( (lx, parms.miny), (hx, parms.maxy), ax, ay)]
        else 
            if (ly < parms.miny) then
               [((lx, parms.miny),  (hx, hy), ax, ay);
                ((lx, parms.maxy - (parms.miny - ly)), (hx, parms.maxy), ax, ay-h)]
            else 
                if (hy > parms.maxy) then
                    [((lx, ly), (hx, parms.maxy), ax, ay);
                     ((lx, parms.miny), (hx, parms.miny + (hy - parms.maxy)), ax, ay+h)]
                else [(lo,hi,ax,ay)]

    let inline findNeighbors parms tree b =           
        let epsvec = (parms.epsilon, parms.epsilon)
        let vlo, vhi = b.position <-> epsvec,  b.position <+> epsvec            
        
        // adjuster for wraparound      
        let adj1 ax ay (pos, theboid) = 
            (pos <+> (ax,ay), {theboid with position = theboid.position <+> (ax,ay) }) 
        
        let adjuster lo hi ax ay = 
            let neighbors = kdtRangeSearch tree lo hi                             
            List.map (adj1 ax ay) neighbors        
        
        let neighbors =
            match b.bounded with
            | false ->
                //split the boxes      
                let splith = splitBoxHoriz parms (vlo, vhi, 0.0, 0.0)      
                let splitv = List.collect (splitBoxVert parms) splith                      
        
                // do the sequence of range searches 
                List.collect (fun (lo,hi,ax,ay) -> adjuster lo hi ax ay) splitv            
            | true ->
                kdtRangeSearch tree vlo vhi
        // compute the distances from boid b to members 
        let dists = List.map (fun (_, boid) -> (vecNorm (b.position <-> boid.position), boid)) neighbors  
        
        b :: (List.map snd (List.filter (fun (d, _) -> d <= parms.epsilon) dists))

    //Updating the whole set of boids.
    let inline iterationkd fdraw parms tree =  
        let ftemp f g l = f l, g l
        flatten tree []  
        |> PSeq.map (fun boid -> oneboid parms boid (findNeighbors parms tree boid)) 
        |> ftemp fromListWithDepth (fdraw (int parms.epsilon))              

    let rndm = new Random()

    let inline makeboid i = 
        let x=rndm.NextDouble()
        let y=rndm.NextDouble()
        let m= (float i)%400.0
        match i % 3 with
        | 0 -> 
            {identifier = i; velocity = x - 1.5, y - 1.5; 
             position =  (m * (x - 0.5) , m * (y - 0.5) ); bounded = m > 150.0}
        | 1 -> 
            {identifier = i; velocity = - x , - y; 
             position = m * (x - 0.5) , m * (y - 0.5) + m; bounded = m > 150.0}
        | _ ->
            {identifier = i; velocity = 1.5 - x, y - 1.5; 
             position = m * (x - 0.5) + m, m * (y - 0.5) ; bounded = m > 150.0}
Wie man sieht, die Schwarm-Daten werden im K-d tree gespeichert und mit jeder GUI-Aktualisierung neu berechnet. Dies geschiet in der iterationkd-Funktion. Zuerst erstellen wir mit der flatten - Funktion aus dem Baum eine Liste von einzelnen Schwarmelementen. Dann errechnen wir parallel für jedes Element die neue Position (oneboid). Schließlich wird der neue Baum aus der Liste kreiert (fromListWithDepth).

Zusätzlich sind die Teilchen mit dem Kreis ihren "epsilon" Regionen dargestellt (man kann es als ihre Sichtweite bezeichnen).
//BoidDrawing.fs
namespace BoidForm

open System.Drawing
open System.Drawing
open System.Drawing.Drawing2D

open Flocks.Boids

module BoidDrawing =

    type Drawing =
        abstract Draw : Graphics -> unit

    let drawing f =
      { new Drawing with 
          member x.Draw(gr) = f(gr) }
      
    let emptyDrawing =
      { new Drawing with 
          member x.Draw(gr) = () }

    let pen = new Pen(Color.Black)

    let inline drawBoid (brush1, brush2) epsilon boids =
        drawing(fun g ->   
          boids
          |>Seq.iter (fun boid ->
              let (x,y) = boid.position
              g.TranslateTransform(float32 x, float32 y)
              if boid.bounded then
                g.FillEllipse(brush1, 0, 0, 6, 6)
              else
                g.FillEllipse(brush2, 0, 0, 6, 6)
              g.DrawEllipse(pen, (-epsilon / 2) + 3 , (-epsilon / 2) + 3, epsilon, epsilon)
              g.TranslateTransform(-(float32 x), -(float32 y))))
//BoidForm.fs
namespace BoidForm

open System
open System.Drawing
open System.Windows.Forms
open Flocks.KDTree
open BoidForm.BoidDrawing
open System.Drawing.Drawing2D

type public BoidForm() as form =
    inherit Form()
  
    do
        form.SuspendLayout();
         
        form.SetStyle(ControlStyles.AllPaintingInWmPaint ||| ControlStyles.OptimizedDoubleBuffer, true)
        form.FormBorderStyle <- FormBorderStyle.FixedToolWindow
        form.StartPosition <- FormStartPosition.CenterScreen;
    
        let tmr = new Timers.Timer(Interval = 40.0)
        tmr.Elapsed.Add(fun _ -> form.Invalidate() )
        tmr.Start()

        form.Text <- "F# Flock"

        // render the form
        form.ResumeLayout(false)
        form.PerformLayout()

    member x.guiRefresh (e:Graphics)  (swarm : Drawing) = 
        e.FillRectangle(Brushes.White, Rectangle(Point(0,0), Size(x.ClientSize.Width, x.ClientSize.Height-40)))
        e.SmoothingMode <- SmoothingMode.AntiAlias
        swarm.Draw(e)
Um das Ganze nicht so langweilig erscheinen zu lassen, sind diverse Parameter auf dem Formular platziert worden, damit die Änderungen sofort zu sehen sind.
//Programm.fs
namespace BoidForm

open System
open System.Drawing
open System.Windows.Forms
open Microsoft.FSharp.Collections

open Flocks.KDTree
open Flocks.Boids
open BoidDrawing

module Main =
    let synchronize f = 
        let ctx = System.Threading.SynchronizationContext.Current 
        f (fun g arg ->
            let nctx = System.Threading.SynchronizationContext.Current 
            if ctx <> null && ctx <> nctx then ctx.Post((fun _ -> g(arg)), null)
            else g(arg) )

    type Microsoft.FSharp.Control.Async with 
      static member AwaitObservable(ev1:IObservable<'a>) =
        synchronize (fun f ->
          Async.FromContinuations((fun (cont,econt,ccont) -> 
            let rec callback = (fun value ->
              remover.Dispose()
              f cont value )
            and remover : IDisposable  = ev1.Subscribe(callback) 
            () )))
  
      static member AwaitObservable(ev1:IObservable<'a>, ev2:IObservable<'b>) = 
        synchronize (fun f ->
          Async.FromContinuations((fun (cont,econt,ccont) -> 
            let rec callback1 = (fun value ->
              remover1.Dispose()
              remover2.Dispose()
              f cont (Choice1Of2(value)) )
            and callback2 = (fun value ->
              remover1.Dispose()
              remover2.Dispose()
              f cont (Choice2Of2(value)) )
            and remover1 : IDisposable  = ev1.Subscribe(callback1) 
            and remover2 : IDisposable  = ev2.Subscribe(callback2) 
            () )))

    type InputParams = | Cohesion of float | Alignment of float | Scale of float | Separation of float | Velocity of float | Epsilon of float
    let inline createParams input p =
        match input with
        | Cohesion v when v <> 0.0 ->     {p with cohesionParam = v} 
        | Alignment v when v <> 0.0->    {p with alignmentParam = v} 
        | Scale v when v <> 0.0->        {p with sScale = v} 
        | Separation v->    {p with separationParam = v} 
        | Velocity v->          {p with velocity = v}
        | Epsilon v -> {p with epsilon = v}
        | _ -> p

    let iter  = iterationkd (drawBoid (Brushes.Blue, Brushes.Red)) 

    let test =
        let boundMin,boundMax = 0.0, 400.0

        let af = new BoidForm(ClientSize = Size((int boundMax), (int boundMax)+50), Visible = true)
        let cohesionLabel = new Label(Text ="cohesion",Left = 8, Top = 410, Width = 60, Height = 15 )
        let cohesionTextBox = new TextBox(Text = parms.cohesionParam.ToString(), Left = 8, Top = 430, Width = 60)
        let alignmentLabel = new Label(Text ="alignment",Left = 70, Top = 410, Width = 60, Height = 15 )
        let alignmentTextBox = new TextBox(Text = parms.alignmentParam.ToString(), Left = 70, Top = 430, Width = 60)

        let scaleLabel = new Label(Text ="separation scale",Left = 135, Top = 410, Width = 90, Height = 15 )
        let scaleTextBox = new TextBox(Text = parms.sScale.ToString(), Left = 135, Top = 430, Width = 60)
        
        let separationLabel = new Label(Text ="separation",Left = 230, Top = 410, Width = 60, Height = 15 )
        let separationTextBox = new TextBox(Text = parms.separationParam.ToString(), Left = 230, Top = 430, Width = 60)
        
        let veloLabel = new Label(Text ="velocity",Left = 295, Top = 410, Width = 60, Height = 15 )
        let veloTextBox = new TextBox(Text = parms.velocity.ToString(), Left = 295, Top = 430, Width = 60)

        let epsilonLabel = new Label(Text ="epsilon",Left = 360, Top = 410, Width = 60, Height = 15 )
        let epsilonTextBox = new TextBox(Text = parms.epsilon.ToString(), Left = 360, Top = 430, Width = 60)

        let evtParamsChanged = 
            let parse f text = 
                let (ok, v) = System.Double.TryParse(text)
                if ok then Some(createParams (f v)) else None
            Event.merge (Event.map (fun _ -> parse Cohesion cohesionTextBox.Text) cohesionTextBox.TextChanged) (Event.map (fun _-> parse Alignment alignmentTextBox.Text) alignmentTextBox.TextChanged)
            |> Event.merge (Event.map (fun _ -> parse Scale scaleTextBox.Text) scaleTextBox.TextChanged)
            |> Event.merge (Event.map (fun _ -> parse Separation separationTextBox.Text) separationTextBox.TextChanged)
            |> Event.merge (Event.map (fun _ -> parse Velocity veloTextBox.Text) veloTextBox.TextChanged)
            |> Event.merge (Event.map (fun _ -> parse Epsilon epsilonTextBox.Text) epsilonTextBox.TextChanged)
            |> Event.choose id
        af.Controls.AddRange([| (cohesionTextBox:>Control); (alignmentTextBox:>Control);(scaleTextBox:>Control); (separationTextBox:>Control); (veloTextBox:>Control); (epsilonTextBox:>Control);
                                (cohesionLabel:>Control); (alignmentLabel:>Control);(scaleLabel:>Control); (separationLabel:>Control); (veloLabel:>Control); (epsilonLabel:>Control)|])
        let swarmInit = 
            List.map (fun i ->makeboid i ) [0..250] |> fromListWithDepth

        //Start swarm after 10 steps.
        let swarmStart  = 
            List.fold (fun (facc,_) _-> 
                    (iter parms facc)) (iter parms swarmInit) [0..10]

        let rec waiting swarm p = async {
            let! evnt = Async.AwaitObservable (af.Paint, evtParamsChanged)
            match evnt with
            | Choice1Of2(evntArg1) -> 
                let newSwarm, drawing = swarm 
                af.guiRefresh evntArg1.Graphics drawing
                do! waiting (iter p newSwarm) p
            | Choice2Of2(f) ->
                do! waiting swarm (f p)
                }
        (waiting swarmStart parms) |> Async.StartImmediate
        af

    [<STAThread>]
    do
        Application.EnableVisualStyles()
        Application.Run(test)
git repo

Mittwoch, 22. Juni 2011

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.

Freitag, 27. Mai 2011

F# Type-directed memoization.

Ich bin gerade am lesen des interesanten Artikels Fun with type functions. Unter anderem ist da "Type-directed memoization" beschrieben. Die versuche ich in F# umzusetzen.
Ich muss aber zugeben - eine praktische Anwendung wird es wohl kaum geben. Ich betrachte es als meiner eigene Haskell Cargo-Kult
Hier so zu sagen Standart-F# Memoization Pattern und Monadic Memoization.

Da es in F# keine Typklasse gibt, könnte man mit einem abstrakten Interface kleine Abhilfe schaffen.
type ITable<'a,'w> =
    abstract inline Table : ITable<'a,'w>

type BoolTable<'w> = 
    | BTable of Lazy<'w> * Lazy<'w>
    interface ITable<bool,'w> with
        member inline x.Table = x :> ITable<_,_>

//(bool -> 'a) -> BoolTable<'a>
let boolToTable f = BTable (lazy(f true), lazy(f false))

//BoolTable<'a> -> bool -> 'a
let boolFromTable (BTable (x,y)) b = 
    if b then x.Force() else y.Force()

Weiter zitiere ich einfach aus dem Artikel (http://research.microsoft.com/en-us/um/people/simonpj/papers/assoc-types/fun-with-type-funs/typefun.pdf).
" To memoise a function f :: bool -> Int, we simply replace it by g:
g :: Bool -> Int
g = fromTable (toTable f)
The first time g is applied to True, the Haskell implementation computes
the first component of the lazy pair (by applying f in turn to True) and
remembers it for future reuse. Thus, if f is defined by
f True = factorial 100
f False = fibonacci 100
then evaluating (g True + g True) will take barely half as much time as
evaluating (f True + f True). "
let boolFunc b = 
    match b with
    | true -> 
        printfn "true. Value = 10" 
        10
    |false -> 
        printfn "false. Value = 5"
        5
val boolFunc : bool -> int

> let memoized= boolFromTable (boolToTable boolFunc)

val memoized : (bool -> int)

> let res = memoized(true) + memoized(true) + memoized(false) + memoized(false)

true. Value = 10
false. Value = 5

val res : int = 30
" Generalising the Memo instance for Bool above, we can memoise functions
from any sum type, such as the standard Haskell type Either:
data Either a b = Left a | Right b
We can memoise a function from Either a b by storing a lazy pair of a
memo table from a and a memo table from b. That is, we take advantage
of the isomorphism between the function type Either a b -> w and the
product type (a -> w, b -> w). "
type Either<'a,'b>= 
        |Left of 'a
        |Right of 'b

type SumTable<'t1,'t2,'a,'b,'w when 't1:> ITable<'a,'w> and 't2:> ITable<'b,'w>> = 
    | STable of 't1 * 't2
    interface ITable<Either<'a,'b>,'w> with
        member inline x.Table = x :> ITable<Either<'a,'b>,'w>
Leider unterstützt F# auch keine "type function". Also die entsprechende Funktionen müssen explizit übergeben werden.
// sumToTable : (('a -> 'b) -> 'c) -> (('f -> 'b) -> 'g) -> (Either<'a,'f> -> 'b) ->
//     SumTable<'c,'g,'d,'h,'e>
//    when 'c :> ITable<'d,'e> and 'g :> ITable<'h,'e> 
let sumToTable fa fb f=
    STable (fa (f<<Left), fb (f<<Right))

// sumFromTable : ('a -> 'd -> 'e) -> ('f -> 'h -> 'e) -> SumTable<'a,'f,'b,'g,'c> ->
//     Either<'d,'h> -> 'e 
// when 'a :> ITable<'b,'c> and 'f :> ITable<'g,'c>
let sumFromTable fa fb tbl e =
            match tbl, e with
            | STable (t, _), Left  v   -> fa t v
            | STable (_, t), Right v   -> fb t v

let eitherFunc e =
    match e with
    | Left a  -> 
        printfn "eitherFunc Left %A" a
        (boolFunc a) - 3
    | Right b ->  
        printfn "eitherFunc Right %A" b
        (boolFunc b) * 2
val eitherFunc : Either<bool,bool> -> int

> let memoized= sumFromTable boolFromTable boolFromTable (sumToTable boolToTable boolToTable eitherFunc);;

val memoized : (Either<bool,bool> -> int)

> let res = memoized(Left true) + memoized(Left true) + memoized(Right false) + memoized(Right false);;

eitherFunc Left true
true. Value = 10
eitherFunc Right false
false. Value = 5

val res : int = 34

" Dually, we can
memoise functions from the product type (a,b) by storing a memo table
from a whose entries are memo tables from b. That is, we take advantage
of the currying isomorphism between the function types (a,b) -> w and
a -> b -> w. "
type ProductTable<'t1,'t2,'a,'b,'w when 't1 :> ITable<'b,'w> and 't2 :> ITable<'a,'t1> > =
    | PTable of 't2
    interface ITable<'a * 'b,'w> with
        member inline x.Table = x :> ITable<('a * 'b),'w>

// productToTable : (('a -> 'b) -> 'c) -> (('d -> 'c) -> 'e) -> ('d * 'a -> 'b) ->
//     ProductTable<'g,'e,'f,'h,'i>
//    when 'e :> ITable<'f,'g> and 'g :> ITable<'h,'i>
let productToTable fa fb f= 
              let p = fb (fun a -> fa (fun b -> f (a, b)))
              PTable p

// productFromTable: ('a -> 'b -> 'c) -> ('d -> 'i -> 'a) -> ProductTable<'f,'d,'e,'g,'h> ->
//     'i * 'b -> 'c
// when 'd :> ITable<'e,'f> and 'f :> ITable<'g,'h> 
let productFromTable fa fb tbl p =
            match tbl,p with
            | PTable t,(a,b)-> fa (fb t a) b

let productFunc pair =
    let x=
        printfn "productFunc first"
        (boolFunc (fst pair))-3
    let y =
        printfn "productFunc second "
        (boolFunc (snd pair))*2
    x + y

let productEitherFunc (e, b) =
    let x =
        printfn "productEitherFunc first %A" e
        (eitherFunc e) - 3
    let y =
        printfn "productEitherFunc second %A" b
        (boolFunc b) * 2
    x + y
val productFunc : bool * bool -> int

val productEitherFunc : Either<bool,bool> * bool -> int

> let memoized =  productFromTable boolFromTable boolFromTable (productToTable boolToTable boolToTable productFunc);;

val memoized : (bool * bool -> int)

> let res = memoized (true, true) + memoized (true, true);;

productFunc first
true. Value = 10
productFunc second 
true. Value = 10

val res : int = 54

> let res = memoized (true, true) + memoized (false, false);;

productFunc first
false. Value = 5
productFunc second 
false. Value = 5

val res : int = 39

> let memoized = 
    productFromTable boolFromTable (sumFromTable boolFromTable boolFromTable) 
        (productToTable boolToTable (sumToTable boolToTable boolToTable) productEitherFunc);;

val memoized : (Either<bool,bool> * bool -> int)

> let res = memoized (Left true, true) + memoized (Left true, true);;

productEitherFunc first Left true
eitherFunc Left true
true. Value = 10
productEitherFunc second true
true. Value = 10

val res : int = 48

> let res = memoized (Left true, true) + memoized (Right false, false) + memoized (Left true, true);;

productEitherFunc first Right false
eitherFunc Right false
false. Value = 5
productEitherFunc second false
false. Value = 5

val res : int = 65

Leider ist mir nicht gelungen Memoization für rekursive Typen zu schreiben und ich vermute stark, dass dies in F# gar nicht möglich ist.