Seiten

Posts mit dem Label wpf werden angezeigt. Alle Posts anzeigen
Posts mit dem Label wpf werden angezeigt. Alle Posts anzeigen

Samstag, 5. Mai 2012

Lazy Levenshtein Visualisation. F# WPF MVVM.

Hier habe ich eine F# WPF(MVVM) Anwendung geschrieben um den Lazy Levenshtein Algorithmus zu visualisieren.



Code on GitHub

Ein paar Sätze, wie man das "Spielfeld" mit dem WPF-MVVM implementieren kann. Ich habe dazu ein empfehlenswertes F# MVVM Template genommen.
Als erstes die ViewModelBase-Klasse auf die Implementierung mit F# Quotations umgestellt.
//ViewModelBase.fs
namespace LazyLevenshteinMVVM.ViewModel

open System

open System.ComponentModel
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns
// implement the INotifyPropertyChanged interface with F# quotations.
type ViewModelBase() =
    let propertyChangedEvent = new Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member x.PropertyChanged = propertyChangedEvent.Publish
    member x.OnPropertyChanged (expr: Expr) = 
        match expr with
        | PropertyGet(_, methodInfo, _) ->
            let propertyName = methodInfo.Name
            propertyChangedEvent.Trigger(x, new PropertyChangedEventArgs(propertyName))
        | other -> failwith "not implemented" 
Als nächstes brauchen wir zwei View Model Klassen: eine für eine Zelle des Spielfeldes und eine für das Spielfeld selbst.
//BoardViewModel.fs
namespace LazyLevenshteinMVVM.ViewModel

open System
open System.Windows
open System.Windows.Threading
open System.Windows.Input
open System.ComponentModel
open System.Collections.ObjectModel
open LazyLevenshteinMVVM.Model

//View Model for a board cell.
type BoardCell() =
    inherit ViewModelBase()
    let mutable cellValue = ""
    let mutable isEvaluated = false
    let mutable isEvaluatedFrom =false
    let mutable isEvaluate = false
    let mutable isThunk = false
    let mutable isDiagStep = false
    let mutable evaluateText = String.Empty
    let mutable evaluatedFrom = String.Empty

    member x.FromPoint (point : LazyLevenshteinMVVM.Model.Point) =
        match x.IsEvaluated with
        | true -> 
            match point.isDiagonalStep, point.isEvaluatedFrom with 
            | true, true ->
                x.IsDiagStep <- true
                x.IsEvaluatedFrom <- true
            | true, false ->  x.IsDiagStep <- true
            | false, true ->  x.IsEvaluatedFrom <- true
            | _ -> ()
        | false ->
            x.IsEvaluate <- point.isEvaluate
            x.IsDiagStep <- point.isDiagonalStep
            x.IsThunk <- point.isThunk
            match point.value with
            | Some v -> 
                match point.isEvaluate, point.isEvaluated, point.isEvaluatedFrom, point.isThunk with
                | true, _, _, _ ->   x.EvaluateText <- v
                | _, true, _, _ -> 
                    x.IsEvaluated <- point.isEvaluated
                    x.EvaluatedFrom <- point.evaluatedFrom
                    x.CellValue <- v
                |_, _, true, _ ->    
                    x.IsEvaluatedFrom <- point.isEvaluatedFrom
                | _, _, _, true -> 
                    x.IsThunk <- point.isThunk
                    x.CellValue <- v
                |_->()
            | None -> ()
    member x.IsEvaluated 
        with get() = isEvaluated
        and set value = 
            isEvaluated <- value
            x.OnPropertyChanged(<@x.IsEvaluated@>)
    member x.IsEvaluate 
        with get() = isEvaluate
        and set value = 
            isEvaluate <- value
            x.OnPropertyChanged(<@x.IsEvaluate@>)
    member x.IsThunk 
        with get() = isThunk
        and set value = 
            isThunk <- value
            x.OnPropertyChanged(<@x.IsThunk@>)
    member x.IsDiagStep 
        with get() = isDiagStep
        and set value = 
            isDiagStep <- value
            x.OnPropertyChanged(<@x.IsDiagStep@>)
    //computed edit distance for given letters from string A and B.
    member x.CellValue
        with get() = cellValue
        and set value = 
            cellValue <- value
            x.OnPropertyChanged(<@x.CellValue@>)
    //shows the letters for which a calculation should evaluate.
    member x.EvaluateText
        ...
    //describes how the value was computed. 
    //An element depends only on the elements to the west, north-west and north
    member.EvaluatedFrom
        ....    
    member x.IsEvaluatedFrom
        ...
Das Spielfeld.
Wenn man den Text in Eingabefelder ändert, wird das Bord sofort über den Aufruf von der BuildBoard-Methode neu erstellt und die Animation mit der Hilfe von DispatcherTimer neu gestartet. Über die GridRows-Eigenschaft werden die Änderungen an das View weitergeleitet.
// View Model for a board.
type Board() as x =
    inherit ViewModelBase()
        
    let mutable rows = new ObservableCollection<ObservableCollection<BoardCell>>()
    let mutable sizex = 0
    let mutable sizey = 0
    let mutable textA = String.Empty
    let mutable textB = String.Empty

    let model = LevenshteinModel.Empty
    let mutable timer = new DispatcherTimer(DispatcherPriority.Normal)
    let mutable distance = 0
    let pointToCell (point : LazyLevenshteinMVVM.Model.Point)  =
                let col = rows.[snd point.xy + 2] 
                let cell = col.[fst point.xy + 2]
                cell.FromPoint point
                cell.IsEvaluatedFrom <- false
                cell.IsDiagStep <- false
                col.[fst point.xy + 2] <- cell
                rows.[snd point.xy + 2] <- col       
    do
        timer.Interval <- new TimeSpan(0, 0, 0, 0, 1500)
        timer.Tick.Add(fun _  -> x.AnimateOneStep () )    
    
    member x.AnimateOneStep () = 
        match rows.Count, model.OneStep () with 
        | _, [] -> timer.Stop()
        | 0, _ -> timer.Stop()
        | _, points ->
            points |> List.iter pointToCell 
            x.OnPropertyChanged(<@x.GridRows@>)
    //build the board.
    member private x.BuildBoard  =
        [for i in 0..sizex-2 do
                rows.[0].[i+2].CellValue <- textA.[i].ToString()
                rows.[1].[i+2].CellValue <- (i+1).ToString() 
                rows.[1].[i+2].IsEvaluated<-true
        ] |> ignore

        rows.[1].[1].CellValue <- "0" 
        [for j in 2..sizey do  
              let c = rows.[j].[0]
              let n = rows.[j].[1]
              c.CellValue <- textB.[j-2].ToString()
              n.CellValue <- (j - 1).ToString()
              n.IsEvaluated<-true
        ] |> ignore
        timer.Stop()

        model.Run(textA, textB)
        match model.distance with
        | None -> x.Distance <- 0
        | Some v -> x.Distance <- v
        x.OnPropertyChanged(<@x.GridRows@>)
        timer.Start()

    member x.TextA
        with get() = textA
        and set value = 
            textA <- value
            x.SizeX <- (if textA.Length > 0 then textA.Length + 1 else 0)
            x.BuildBoard
            x.OnPropertyChanged(<@x.TextA@>)
            
    member x.TextB
        with get() = textB
        and set value = 
            textB <- value
            x.SizeY <- (if textB.Length > 0 then textB.Length + 1 else 0)
            x.BuildBoard
            x.OnPropertyChanged(<@x.TextB@>)
    member x.Distance 
        with get() = distance
        and set value = 
            distance <- value
            x.OnPropertyChanged(<@x.Distance@>)

    member x.GridRows = rows

    member private x.Size =
        sizex <- (if sizex > 0 then sizex else (if sizey > 0 then 1 else 0))
        sizey <- (if sizey > 0 then sizey else (if sizex > 0 then 1 else 0))
        [   for i in 0..sizey do
                let col = new ObservableCollection<BoardCell>()
                for j in 0..sizex do
                    let c = new BoardCell()
                    c.CellValue <-""
                    col.Add(c)

                rows.Add(col) ] |> ignore  
    member x.SizeY
        with get() = sizey
        and set value = 
            sizey <- value
            rows <- new ObservableCollection<ObservableCollection<BoardCell>>()
            x.Size
            x.OnPropertyChanged(<@x.SizeY@>)
    member x.SizeX
        with get() = sizex
        and set value = 
            sizex <- value
            rows <- new ObservableCollection<ObservableCollection<BoardCell>>()
            x.Size
            x.OnPropertyChanged(<@x.SizeX@>)
Das View.
<!--Board.xaml--> 
<UserControl 
    xmlns="http://schemas.microsoft.com/winfx/2006/xaml/presentation"
    xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
    xmlns:ViewModel="clr-namespace:LazyLevenshteinMVVM.ViewModel;assembly=App"
 HorizontalAlignment ="Stretch"
 HorizontalContentAlignment ="Stretch"
 VerticalAlignment ="Stretch"
 VerticalContentAlignment ="Stretch"
 Foreground="White">
    <UserControl.DataContext>
        <ViewModel:Board> </ViewModel:Board>
    </UserControl.DataContext>
    <UserControl.Resources>
        <Storyboard x:Key="selectedStory">
            <DoubleAnimation Storyboard.TargetName="TextBlock"
                                  Storyboard.TargetProperty="Opacity"
                                  From="0"
                                  To="0.8"
                                  Duration="0:0:0.8"/>
        </Storyboard>
        <LinearGradientBrush x:Key="BoardBackground" StartPoint="0,0" EndPoint="1,0">
            ...
        </LinearGradientBrush>
        <DataTemplate x:Key ="CellTemplate" >
                <Border x:Name ="Border" BorderBrush ="DimGray" BorderThickness ="1">
                    <Border.Background>
                       ...
                    </Border.Background>
                <StackPanel Orientation="Vertical" >
                    <TextBlock x:Name="evaluateText" Text="{Binding Path=EvaluateText}"/>
                    <TextBox x:Name ="TextBlock" Margin="3"
                     FontWeight ="Bold" FontSize ="12"  Text ="{Binding Path=CellValue}" 
                     HorizontalAlignment ="{Binding ElementName=Border, Path=HorizontalAlignment}" 
                     VerticalAlignment ="Center"
                             Focusable ="False" Opacity="0.8" Background="White">
                        <TextBox.BitmapEffect>
                            <DropShadowBitmapEffect/>
                        </TextBox.BitmapEffect>
                    </TextBox>
                    <TextBlock x:Name="evaluateFrom" Text="{Binding Path=EvaluatedFrom}" 
                                  FontSize="11" />
                </StackPanel>
            </Border>             
            <DataTemplate.Triggers>        
                <DataTrigger Binding ="{Binding IsEvaluated}" Value ="True">
                    <Setter TargetName ="TextBlock" Property ="Foreground" Value="Red"/>
                    <Setter TargetName ="TextBlock" Property ="Background" Value="Blue"/>
                    <DataTrigger.EnterActions>
                        <BeginStoryboard Storyboard="{StaticResource selectedStory}">
                        </BeginStoryboard>
                        <BeginStoryboard x:Name="evaluatedStory">
                            <Storyboard>
                                <DoubleAnimation Storyboard.TargetName="TextBlock"
                                  Storyboard.TargetProperty="FontSize"
                                  From="12"
                                  To="22"
                                  Duration="0:0:0.8" AutoReverse="True" />
                            </Storyboard>
                        </BeginStoryboard>
                    </DataTrigger.EnterActions>
                </DataTrigger>
                
                <DataTrigger Binding ="{Binding IsThunk}" Value ="True">
                    <Setter TargetName ="TextBlock" Property ="Background" Value="LightGreen"/>
                </DataTrigger>
                
                <DataTrigger Binding="{Binding IsEvaluatedFrom}" Value="True">
                    ...
                </DataTrigger>
                
                <DataTrigger Binding="{Binding IsEvaluate}" Value="True">
                    ...
                </DataTrigger>
                
                <DataTrigger Binding="{Binding IsDiagStep}" Value="True">
                    ...
                </DataTrigger>
            </DataTemplate.Triggers>
        </DataTemplate>
        <DataTemplate x:Key ="BoardTemplate">
            <ItemsControl ItemTemplate ="{StaticResource CellTemplate}" ItemsSource ="{Binding}">
                <ItemsControl.ItemsPanel>
                    <ItemsPanelTemplate>
                        <UniformGrid Rows ="1"/>
                    </ItemsPanelTemplate>
                </ItemsControl.ItemsPanel>
            </ItemsControl>
        </DataTemplate>        
    </UserControl.Resources>
    <Grid>
        <Grid.ColumnDefinitions>
            <ColumnDefinition Width="6*" />
            <ColumnDefinition Width="1*" />
        </Grid.ColumnDefinitions>
        <ItemsControl Grid.Column="0" ItemTemplate ="{StaticResource BoardTemplate}" 
                         ItemsSource ="{Binding Path=GridRows}" x:Name ="MainList">
            <ItemsControl.ItemsPanel>
                <ItemsPanelTemplate>
                    <UniformGrid Columns ="1" Background="{StaticResource BoardBackground}"/>
                </ItemsPanelTemplate>
            </ItemsControl.ItemsPanel>
        </ItemsControl>
        <StackPanel Grid.Column="1" Orientation="Vertical" Margin="5">
            <Label Content="Text 1" />
            <TextBox MinWidth="10" MaxHeight="25" MaxLength="12" MaxWidth="200" 
                        Text="{Binding Path=TextA,UpdateSourceTrigger=PropertyChanged}"></TextBox>
            <Label Content="Text 2" />
            <TextBox MinWidth="10" MaxHeight="25" MaxLength="12" MaxWidth="200" 
                        Text="{Binding Path=TextB,UpdateSourceTrigger=PropertyChanged}"></TextBox>
            <Label  Content="N - North" />
            <Label Content="W - West" />
            <Label Content="NW - North West" />
            <Label Content="Distance"  Margin="5" />
            <TextBox  Margin="5" Text="{Binding Path=Distance}" />
        </StackPanel>
    </Grid>
</UserControl>

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.

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, 21. Januar 2011

Wpf INotifyPropertyChanged mit F# Quotations.

Man implementiert die INotifyPropertyChanged-Schnittstelle um die Änderungen an einer Eigenschaft den Clients mitzuteilen. Standardmäßig verwendet man den Namen der Eigenschaft als einer String-Konstante, die an das PropertyChanged-Erreignis übergeben wird. Ungefähr so.
//standard version. pass property name as a string to the PropertyChanged event.
open System.ComponentModel
type ViewModelBase() =
    let propertyChangedEvent = new Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member x.PropertyChanged = propertyChangedEvent.Publish
    member x.RaisePropertyChangedEvent (propertyName) = 
        if not(propertyName = null) then
            propertyChangedEvent.Trigger(x, new PropertyChangedEventArgs(propertyName))

type ResultViewModel (d:DateTime, name) =
    inherit ViewModelBase ()
    let mutable birthday = d
    let mutable name = name

    new () = new ResultViewModel(DateTime.Today, "")      

    member r.Birthday with get() = birthday
                       and set newValue =
                            birthday <- newValue
                            base.RaisePropertyChangedEvent("Birthday")

    member r.Name with get() = name
                       and set newValue =
                            name <- newValue
                            base.RaisePropertyChangedEvent("Name")
Alternativ kann man F#-Quotations an den RaisePropertyChangedEvent-Aufruf übergeben. Der Vorteil ist das wir  weg von den String-Konstanten sind, bei denen man schnell vertippen kann und der Compiler zur Kompilierzeit dies nicht merkt.
//version with F#-quotations
open System.ComponentModel
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns

type ViewModelBase() =
    let propertyChangedEvent = new Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member x.PropertyChanged = propertyChangedEvent.Publish
    member x.RaisePropertyChangedEvent (expr: Expr) = 
        match expr with
        | PropertyGet(_, methodInfo, _) ->
            let propertyName = methodInfo.Name
            propertyChangedEvent.Trigger(x, new PropertyChangedEventArgs(propertyName))
        | other -> failwith "not implemented" 

type ResultViewModel (d:DateTime, name) =
    inherit ViewModelBase ()
    let mutable birthday = d
    let mutable name = name

    new () = new ResultViewModel(DateTime.Today, "")      

    member r.Birthday with get() = birthday
                       and set newValue =
                            birthday <- newValue
                            base.RaisePropertyChangedEvent(<@r.Birthday@>)

    member r.Name with get() = name
                       and set newValue =
                            name <- newValue
                            base.RaisePropertyChangedEvent(<@r.Name@>)