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) ())

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

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.

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.

Purity - A CLR-Hosted Total Functional Programming Langauge.

Purity - A CLR-Hosted Total Functional Programming Langauge.

F#. A* (a-star) Pathfinding Algorithm with Priority Queue and Finger Tree.

Update A* Star Pathfinding with Jump Point Search.

// Astar.fs
//from Haskell version http://www.haskell.org/haskellwiki/Haskell_Quiz/Astar/Solution_Dolio
namespace Astar

module AstarTypes =
    type Point = int * int
    type Map = char list list

    let inline flip f b a = f a b

[<RequireQualifiedAccess>]
module PriorityQueue =
  exception Empty

  type t<'k,'a> =
    | E
    | T of 'k * 'a * t<'k, 'a> * Lazy<t<'k,'a>>

  let empty = E

  let isEmpty = function E -> true | _ -> false

  let inline singleton prio x = T(prio, x, E, lazy E)

  let rec merge t1 t2 =
    match t1, t2 with
    | E, h -> h
    | h, E -> h
    | T(xprio, _, _, _), T(yprio, _, _, _) ->
        if xprio <= yprio then link t1 t2 else link t2 t1

  and link t1 t2 =
    match t1, t2 with
    | T(prio, a, E, m), r -> T(prio, a, r, m)
    | T(prio, a, t, m), r -> T(prio, a, E, lazy merge (merge r t) (m.Force()))
    | _ -> failwith "should not get there"

  let inline insert prio x q = merge (singleton prio x) q

  let rec contains prio = function
    | E -> false
    | T (sndPrio, _, a, b) ->
        prio = sndPrio || contains prio a || contains prio (b.Force())

  let deleteFindMin = function
    | E -> raise Empty
    | T(prio, a, t, m) ->(prio, a), merge t (m.Force())
  
  let inline findMin q = fst (deleteFindMin q)

  let inline deleteMin q = snd (deleteFindMin q)


  let rec remove x = function
    | E -> E
    | T(prio, y, a, b) as t ->
        if a = x
        then merge a (b.Force())
        else T(prio, y, remove x a, lazy remove x (b.Force()))

  let inline ofSeq s = Seq.fold (fun q (prio, a) -> merge (singleton prio a) q) empty s

module AstarImpl = 
  //Point -> (Point -> Set<Point>) -> (Point -> bool) -> (Point -> int) -> (Point -> int) -> Point list
  let astar start succ finish cost heur =
      let rec inner seen q =
           match PriorityQueue.isEmpty q with
           | true -> failwith "No Solution."
           | false ->
               let ((c, next), dq) = PriorityQueue.deleteFindMin q
               let n = List.head next

               match finish n with
               | true -> next
               | otherwise -> 
                   let succs = succ n

                   let costs item = c + (cost item) + (heur item) - (heur n) 
                   
                   let q' = 
                       Set.difference succs seen |> Seq.map (fun x ->costs x, x :: next) 
                       |> PriorityQueue.ofSeq |> PriorityQueue.merge dq

                   inner (Set.union seen succs) q'
      inner (Set.singleton start) (PriorityQueue.singleton (heur start) [start])

Version mit FingerTree aus dem Beitrag.

//Astar.fs
...
module AstarFtree =
  open FingerTree
  
  type PrioMonoid () =
        interface IMonoid<int> with
            member inline this.Zero = System.Int32.MaxValue
            member inline this.Plus a b = min a b
  
  type PrioElement =
    {Prio : int; Val : AstarTypes.Point list} with
    static member inline ofPair (p, v) = {Prio = p;Val = v}
    interface IMeasured<int> with
        member inline this.Value = this.Prio

  type FingerAstar = 
      {Tree : FingerTree<PrioElement, int, PrioMonoid>;
       Seen : Set<AstarTypes.Point>} with
          member inline this.deleteFindPrio =
                match this.Tree with
                | FingerTree.Empty -> failwith "tree is empty."
                | FingerTree.Single b -> b, FingerTree.Empty
                | FingerTree.Deep (v, _,_,_) ->                    
                    match FingerTree.findAndSplit (fun x -> x = v) this.Tree with
                    | Some (Split(l, x, r)) -> x, FingerTree.concat l r

          static member inline ofSeq s =
              {Tree = Seq.fold (AstarTypes.flip FingerTree.push_front) FingerTree.Empty s
               Seen = Set.empty}
  
  //Point -> (Point -> Set<Point>) -> (Point -> bool) -> (Point -> int) -> (Point -> int) -> Point list
  let astar start succ finish cost heur =
      let rec inner q  =
           match FingerTree.isEmpty q.Tree with
           | true -> failwith "No Solution."
           | false ->
               let (element, dq) = q.deleteFindPrio
               let n = List.head element.Val

               match finish n with
               | true -> element.Val
               | otherwise -> 
                   let succs = succ n

                   let costs item = element.Prio + (cost item) + (heur item) - (heur n) 
                   
                   let q' = 
                       Set.difference succs q.Seen 
                       |> Seq.map (fun x ->costs x, x :: element.Val)
                       |> Seq.map PrioElement.ofPair 
                       |> FingerAstar.ofSeq 
                       
                   inner {Tree = FingerTree.concat dq q'.Tree
                          Seen = Set.union q.Seen succs}
      inner {Seen = Set.singleton start; 
             Tree = FingerTree.Single {Prio = heur start; Val = [start]} }

//Programm.fs 
open Astar
open System

 //Point -> Point -> int
let inline heuristic (x, y) (u, v) = max (abs (x - u))  (abs (y - v))

// Map -> Point -> Set<Point> 
let inline successor m (x,y) = 
    set[for u in  [x + 1; x; x - 1] do
        for v in  [y + 1; y; y - 1] do
        if (0 <= u && u < List.length m 
            && 0 <= v && v < List.length (List.head m)) 
            && (u <> x || y <> v) 
            && (List.nth (List.nth m u) v <> '~') then
            yield set [u, v]
        ]
    |> Set.unionMany

//char -> Map -> Point
let inline find c =
      let rec inner x m = 
          match m with
          | [] ->  failwith "Can't find tile."
          | h :: t -> 
              match List.tryFindIndex (fun item -> item = c) h with
              | Some y -> x, y
              | otherwise -> inner (x+1) t
      inner 0
// char list list -> Point list -> char list list
let inline path m l = 
       List.mapi (fun idx ht ->
           List.mapi (fun idy c->
               if List.exists (fun (n', m') -> (n', m') = (idx, idy)) l then '#' else c) ht) m

let inline run s fAstar =
      let m = List.map (fun (str : string) ->List.ofSeq str) s
      let start = find 'S' m
      let finish = find 'F' m
      let succ = successor m
      let h     = heuristic finish
      let cost (x, y) = 
          let costs = Map.ofList [('S',1);('F',1);('.',1);('*',2);('^',7)]
          List.nth m x 
          |> AstarTypes.flip List.nth y
          |> AstarTypes.flip Map.find costs

      path m (fAstar start succ ((=) finish) cost h)

let input =
    [ "..*..S";
     "*^*^~.";
     "*~*^.~";
     "^^^.~^";
     "^~^~.~";
     "~~^~~.";
     "F*~*~~";]
printfn "Input Map :" 
List.iter (fun x -> printfn "%A" (List.ofSeq x))  input
let res = run input AstarImpl.astar
printfn " Path "
List.iter (fun x -> printfn "%A" x)  res

let resFtree = run input AstarFtree.astar
printfn " Path Finger Tree"
List.iter (fun x -> printfn "%A" x)  resFtree

Input Map :
['.'; '.'; '*'; '.'; '.'; 'S']
['*'; '^'; '*'; '^'; '~'; '.']
['*'; '~'; '*'; '^'; '.'; '~']
['^'; '^'; '^'; '.'; '~'; '^']
['^'; '~'; '^'; '~'; '.'; '~']
['~'; '~'; '^'; '~'; '~'; '.']
['F'; '*'; '~'; '*'; '~'; '~']
 Path
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']
 Path Finger Tree
['.'; '.'; '*'; '.'; '.'; '#']
['*'; '^'; '*'; '^'; '~'; '#']
['*'; '~'; '*'; '^'; '#'; '~']
['^'; '^'; '^'; '#'; '~'; '^']
['^'; '~'; '#'; '~'; '.'; '~']
['~'; '~'; '#'; '~'; '~'; '.']
['#'; '#'; '~'; '*'; '~'; '~']

Hier habe ich den A Star Algorithmus verwendet, um eine Labyrinth Lösung zu finden.

F#. Net Regex vs. DFA Table.

Um den im letzten Beitrag erstellten DFA sinnvoll einsetzen zu können, sollten wir die Liste von Transitions in einer Tabelle (2D Array) umwandeln. Dann können wir zu jedem Symbol des Alphabets und dem aktuellen Zustand den nächsten Zustand ermitteln, wobei das Symbol als Array-Index verwendet wird.

let nextState = table.[int 'a'].[currentState]

//Program.fs
open System
open System.Text.RegularExpressions
open System.Text
open Graph
open RegExParsing
open RegExCompiling
open RegExProcessor
open ConvertNfaToDfaTable
open Microsoft.FSharp.Collections 

type DfaTableContext = { table : int[][];
                         accept : Set<Node>; //DFA accept states
                         start : Node;
                         numberofState : int;
                         fstLetter : int
                         }

let inline tabulate f size = Array.init size (fun i-> f i)

let inline createDFATable (context : ConvertContext)  =
    let fstLetter = int (List.head context.alphabet)
    let fillArr arr key transitions  = 
        Seq.fold (fun (acc : int[][]) (Transition (fromNode, toNode, _)) -> 
                 match Set.contains fromNode context.accept with
                 | false -> 
                     acc.[int key - fstLetter].[fromNode] <- toNode
                     acc
                 | true -> 
                     acc.[int key - fstLetter].[fromNode] <- fromNode
                     acc) arr transitions
    let tbl = 
        let initTable = 
            tabulate (fun _ -> Array.create context.nextNode context.start)
                (List.length context.alphabet)
        
        Seq.groupBy (fun (Transition (_, _, (Simple c))) -> c) context.trans
        |> ;Seq.fold (fun (acc : int[][]) (key, transitions) ->
                fillArr acc key transitions
                ) initTable

    {table = tbl; accept = context.accept; start = context.start;
     numberofState = context.nextNode; fstLetter = fstLetter}

Letztendlich geht es um die Anwendung vom regulären Ausdruck in dem Fall von der String-Verkettung. Die .Net Regex muss nach jede Verkettung die gesamte neu entstandene Zeichenfolge komplett durchgehen. Im Gegensatz dazu können die resultierende Zustand-Arrays in dem Fall vom DFA ganz einfach zusammengesetzt werden.

Jetzt können wir die Match-Funktion schreiben.

let inline foldUntil dfa (input:string) length = 
      let rec inner acc pos  =
          match pos = length with
          | true -> acc, false
          | _ ->
              let idx = int (input.Chars pos)
              //compose state arrays.
              let res = Array.map (fun node-> dfa.table.[idx - dfa.fstLetter].[node]) acc
              //checking if initial state 0 maps the to the one accepted final state
              match Set.contains res.[0] dfa.accept with
              | true -> res, true
              | false -> inner res (pos+1) 
      inner    
  
let inline matchInput dfa input =   
      foldUntil dfa input input.Length (tabulate id dfa.numberofState) 0 

//Simulate a stream.
let inline streamInput size =
      let str = String.Concat( Array.create size " Match Me " )
      seq{
          yield str+"("
          yield! seq{for i in 1..20 -> str}
          yield str+"007"
          yield str+"bb"
          yield str+")"
          }

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

let inline testRegexWithStream nfa regex size letters =
    let dfaContext = convert letters nfa |> createDFATable
    let regex = new Regex (regex)
    let builder = StringBuilder()

    printfn "Array Size %A" size
    let matchStream stream=  
        Seq.fold (fun (acc : int []) x-> 
            let tbl, isMatch = matchInput dfaContext x
            if isMatch then
                printfn "match: true, %A" tbl
                tbl
            else
                let res = Array.map (fun node -> tbl.[node]) acc
                printfn "match: %A, table: %A" (Set.contains res.[0] dfaContext.accept) res
                res) (tabulate id dfaContext.numberofState) stream
    test (fun ()-> 
        printfn "Stream with DFA Table." 
        (streamInput  size |> matchStream ) |> ignore)
    
    let matchStreamRegex stream = 
        stream |> Seq.iter (fun (item: string) ->
            try
                let input = builder.Append(item).ToString() 
                printfn "Input Size: %A; match: %A" builder.Length (regex.Match(input).Success)
            with
                | :? System.ArgumentOutOfRangeException -> printfn "input to big for StringBuilder!"
                | :? System.OutOfMemoryException ->  printfn "input to big for StringBuilder!") 

let run () = 
    let regex = "aa|bb"
    let letters =[' '..'z']
    let nfa = 
        regex |> RegExParsing.parseRegExp |> RegExCompiling.compile FullMatch
        
    testRegexWithStream nfa regex 2000 letters
    testRegexWithStream nfa regex 700000 letters

run()

Array Size 2000
Test Start
Stream with DFA Table.
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
match: true, [|4; 4; 4; 3; 4|]
match: true, table: [|4; 4; 4; 3; 4|]
Time Duration : 127L
Test Start
Stream with .Net Regex
Input Size: 20001; match: false
Input Size: 40001; match: false
Input Size: 60001; match: false
Input Size: 80001; match: false
Input Size: 100001; match: false
Input Size: 120001; match: false
Input Size: 140001; match: false
Input Size: 160001; match: false
Input Size: 180001; match: false
Input Size: 200001; match: false
Input Size: 220001; match: false
Input Size: 240001; match: false
Input Size: 260001; match: false
Input Size: 280001; match: false
Input Size: 300001; match: false
Input Size: 320001; match: false
Input Size: 340001; match: false
Input Size: 360001; match: false
Input Size: 380001; match: false
Input Size: 400001; match: false
Input Size: 420001; match: false
Input Size: 440004; match: false
Input Size: 460006; match: true
Input Size: 480007; match: true
Time Duration : 395L

Array Size 700000
Test Start
Stream with DFA Table.
match: false, table: [|0; 0; 0; 3; 4|]
match: false, table: [|0; 0; 0; 3; 4|]
...
match: false, table: [|0; 0; 0; 3; 4|]
match: true, [|4; 4; 4; 3; 4|]
match: true, table: [|4; 4; 4; 3; 4|]
Time Duration : 21480L
Test Start
Stream with .Net Regex
Input Size: 7000001; match: false
Input Size: 14000001; match: false
...
Input Size: 154000004; match: false
input to big for StringBuilder!
input to big for StringBuilder!
Time Duration : 106610L

Aber wie schneidet die DFA-Tabelle gegen .Net Regex bei großen Texten. Da ist .Net Regex viel schneller. Zum Glück können wir das Matching parallelisieren.

let inline matchParallel dfaContext (s : seq<int * string>) =
    PSeq.map (fun (i, s) -> i, matchInput dfaContext s) s
    |> Seq.sortBy (fun (i, _) -> i)
    |> Seq.reduce (fun (accIdx, accPair) (idx, resultPair)->
         match (snd accPair),(snd resultPair) with
         | true, _  -> accIdx, accPair
         | _, true  -> idx, resultPair
         | other    ->
             let res = Array.map (fun node -> (fst resultPair).[node]) (fst accPair)
             idx, (res, Set.contains res.[0] dfaContext.accept)) 

let inline testRegex nfa regex size letters  =
    let dfaContext = convert letters nfa |> createDFATable
    let regex = new Regex (regex)
    
    let builder = StringBuilder()
    streamInput size |> Seq.iter (fun (item: string) ->
                builder.Append(item).ToString()|>ignore)
    let input = builder.ToString()
    builder.Clear() |>ignore
    let offs = input.Length / Environment.ProcessorCount

    printfn "Regex - %A;Input Length %A" regex input.Length
    let splitSeq = Seq.map (fun i ->
        i, if i + 1 < Environment.ProcessorCount then 
               input.Substring(i * offs, offs) 
           else 
               input.Substring(i * offs)) [0..Environment.ProcessorCount - 1]   
    test (fun () -> printfn "DFA Table Parallel: match - %A" (matchParallel dfaContext splitSeq) )
    test (fun () -> printfn "DFA Table :  match - %A" (matchInput dfaContext input))
    test (fun () -> printfn ".NET Regex : match - %A" (regex.Match(input).Success))

let run () = 
    let regexList = ["aa|bb";".*\(.*007.*\).*"]
    let letters =[' '..'z']

    regexList |> List.iter (fun regex ->
        let nfa = 
            regex |> RegExParsing.parseRegExp |> RegExCompiling.compile FullMatch
        testRegex nfa regex 200 letters 
        testRegex nfa regex 20000 letters
        testRegex nfa regex 200000 letters)
    Console.ReadLine()|>ignore 

Regex - aa|bb;  Input Length 48007
DFA Table Parallel: match - ([|4; 3; 4; 3; 4|], true)
Time Duration : 48L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|4; 4; 4; 3; 4|], true)
Time Duration : 7L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 4L


Regex - aa|bb;  Input Length 4800007

DFA Table Parallel: match - ([|4; 3; 4; 3; 4|], true)
Time Duration : 111L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|4; 4; 4; 3; 4|], true)
Time Duration : 283L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 256L

Regex - aa|bb;  Input Length 48000007

DFA Table Parallel: match - ([|4; 3; 4; 3; 4|], true)
Time Duration : 1052L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|4; 4; 4; 3; 4|], true)
Time Duration : 2814L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 2555L
-----------------------------------------------
Regex - .*\(.*007.*\).*;  Input Length 48007

DFA Table Parallel: match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 7L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 8L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 3L

Regex - .*\(.*007.*\).*;  Input Length 4800007

DFA Table Parallel: match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 278L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 564L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 258L

Regex - .*\(.*007.*\).*;  Input
Post veröffentlichen Length 48000007

DFA Table Parallel: match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 2050L
++++++++++++++++++++++++++++++++++++
DFA Table :  match - ([|8; 8; 8; 8; 8; 8; 8; 8; 8; 8; 10; 11; 8; 13|], true)
Time Duration : 5443L
++++++++++++++++++++++++++++++++++++
.NET Regex : match - true
Time Duration : 2618L
-----------------------------------------------

Das gesamte Visual Studio Project kann man hier herunterladen.

F# Subset Construction Algorithm. Converting NFA to DFA.

In Zusammenhang mit dem alten Regex-Posting habe ich überlegt, wenn einen regulären Ausdruck zu einer DFA Übergangstabelle konvertiert werden kann, dann können wir einen solchen Ausdruck auf eine unendliche Eingabefolge anzuwenden ohne überhaupt die Gesamt- oder Teilfolge zu speichern. Wir brauchen nur die aktuelle Werte von der Übergangstabelle zu wissen um festzustellen, ob ein Regex die gesamte Eingabe "matcht".

Dazu muss erst ein Regex in einen DFA umgewandelt werden. Der Algorithmus ist hier in Details beschrieben und es gibt bereits eine F#-Implementierung zur Kompilierung eines regulären Ausdrucks in einen nicht-deterministischen endlichen Automaten (NFA). Was fehlt, ist der Übergang zum DFA und darum geht es hier.

Subset Construction Algorithm (aka Powerset Construction)


Ich hoffe ich verletze keine Copyright-Bestimmungen, wenn ich oben genannte Implementierung nutze ( hier kann man das Projekt herunterladen). 

Wie bei mir schon üblich ist, diente der Haskell-Code als Vorbild.

// Required RegExProcessor from  
// http://stevehorsfield.wordpress.com/2009/08/05/download-the-regular-expression-processor/
open RegExCompiling
open RegExParsing.RegExProcessor

  type Node = int
  //Transition: fromNode * toNode * Label 
  type Transition = Transition of Node * Node * NdfaEdge
  type ConvertContext = { nfa : RegExCompiling.NdfaGraph;
                          trans :  Transition list;   //DFA Transition list.
                          //mapping NFA sets of nodes  to a single node in the DFA.
                          setMap : Map<Set<Node>, int>;
                          setStack : Set<Node> list;
                          finalNfa : Set<Node>;  // set of NFA final states
                          accept : Set<Node>;   //  DFA accept states
                          nextNode : Node;
                          start : Node
                          alphabet : char list}
  // Search the table of transitions to find all nodes you can reach given an initial set of nodes.
  // Auto - epsilon transition.
  let inline findToNodes startNode trans value fromNodes = 
      let matchNodes  (from, _to, edge) nodes =
          match from with 
          | from' when (from' = fromNodes) ->
              match edge, value with
              | AnyChar, Simple _ -> Set.add _to nodes
              | Auto,    Auto     -> Set.add _to nodes
              | CharacterTest criteria, Simple c when (testCharacter criteria c)     -> 
                  Set.add _to nodes  
              | CharacterTest criteria, Simple c when not (testCharacter criteria c) -> 
                  Set.add startNode nodes 
              | Simple v, Simple c when  v = c  -> Set.add _to nodes 
              | Simple v, Simple c when  v <> c -> Set.add startNode nodes 
              | other -> nodes
          | other -> nodes
      List.foldBack matchNodes trans Set.empty  
  
  // Check if we already added this transition if not add it
  let inline checkTransition ts context = 
    match List.exists (fun x -> x = ts) context.trans with
    | true  -> context
    | false -> {context with trans = ts :: context.trans }

  // Check if a given node set contains a accept state
  // if so add it to the dfa accept states
  let inline updateAcceptStates nfaAccepts dfaAccepts nSet nSetIndex = 
    match Set.intersect nSet nfaAccepts |> Set.isEmpty with
    | true  -> dfaAccepts
    | false -> Set.add nSetIndex dfaAccepts
          
  let inline addNodeSet nSet context = 
    let newNodesStack   = context.setStack @ [nSet]
    let newNode         = context.nextNode
    let newNodesMap     = Map.add nSet newNode context.setMap
    let newAccepts      = updateAcceptStates context.finalNfa context.accept nSet newNode
    
    newNode, {context with setMap = newNodesMap; 
                           nextNode = newNode + 1; 
                           setStack = newNodesStack; 
                           accept = newAccepts}

  // Checks a NodeSet to see if it has a node number value
  // If it doesnt we assign it one and add it to the nodeSet stack
  let inline checkNodeSet nSet context = 
    match Map.containsKey nSet context.setMap with
    | true  -> context.setMap.[nSet], context
    | false -> addNodeSet nSet context   
  
  // Given a node and a set of nodes, union orginal set with the set of nodes you can 
  // traverse to from node on the value
  let inline closure startNode trans value oldSet nodes = 
      Set.union (findToNodes startNode trans value nodes) oldSet
  
  // Given an initial set of nodes, find the set of all nodes you can reach by taking 
  // transitions on epsilon only
  let inline epsilonClosure start trans = 
      let generator = Set.fold (closure start trans Auto) Set.empty
      Set.unionMany 
      << Seq.unfold (fun state -> 
              match Set.isEmpty state with
              | true  -> None
              | false -> Some(state, generator state)) 
  //Move takes a set of nodes and input character and returns all nodes you can reach by taking transitions on given input character. 
  let inline moveClosure start trans character =
      epsilonClosure start trans << Set.fold (closure start trans character) Set.empty
  

  let inline buildTransition oldTrans context value= 
      let nodes = List.head context.setStack
      let newSet = moveClosure context.start oldTrans value nodes
      match Set.isEmpty newSet with
      | false ->
          let fromNode, c1 = checkNodeSet nodes context
          let toNode, c2 = checkNodeSet newSet c1
          checkTransition (Transition (fromNode, toNode, value)) c2
      | true -> context
        
  let inline runConversion machine nodes finalNfa letters =
      let context = { nfa = machine;
                      trans = [];
                      setMap = Map.empty;
                      setStack = [];
                      finalNfa = finalNfa;
                      accept = Set.empty;
                      nextNode = 0;
                      start = 0;
                      alphabet = letters}
      let popSetStack context   = {context with setStack = List.tail context.setStack}
      let trans                 = Graph.toTable context.nfa
      let edges                 = context.alphabet |> List.map Simple
      let startSet              = epsilonClosure context.start trans nodes

      checkNodeSet startSet context
      |> snd
      |> Seq.unfold (fun ctx -> 
          match List.isEmpty ctx.setStack with
          | true  -> None
          | false -> 
              let newCtx = List.fold (buildTransition trans) ctx edges |> popSetStack
              Some(newCtx, newCtx))
      |> Seq.tryFind (fun ctx -> List.isEmpty ctx.setStack)
  
  let inline convert letters nfa =
    let fstLetter = List.head letters
    let final = 
      getClosureMap nfa
      |>Array.mapi (fun node isFinal -> 
          match isFinal with
          | true  -> Some(node)
          | false -> None)
      |>Array.choose id 
      |>Set.ofArray 

    let initialStates = 
      getStartStates nfa

    let startNodes = (List.map (fun (i,_,_,_,_) -> i) initialStates)
    
    let context = 
        match runConversion nfa (startNodes |> Set.ofList) final letters with
        | Some v -> v
        | None   -> failwith "Conversion is not possible."
    context 

open RegExParsing
> let test () =
    let regex = "aa|bb"
    let letters =['a'..'c']
    let context = 
        "aa|bb" |> RegExParsing.parseRegExp |> RegExCompiling.compile FullMatch
        |> convert letters 
    printfn "Context: %A" context;;

> test();;
Context: {nfa =
    ((7, 6),
    [((6, (Closure, null)), []); ((5, (Normal, null)), [(4, 1, 4, Simple 'b')]);
     ((4, (Normal, null)), [(5, 0, 6, Simple 'b')]); ((3, (Closure, null)), []);
     ((2, (Normal, null)), [(1, 0, 1, Simple 'a')]);
     ((1, (Normal, null)), [(2, 0, 3, Simple 'a')]);
     ((0, (Start, null)), [(3, 1, 5, Auto); (0, 0, 2, Auto)])]);
trans =
    [Transition (4,0,Simple 'c'); Transition (4,4,Simple 'b');
     Transition (4,1,Simple 'a'); Transition (3,0,Simple 'c');
     Transition (3,2,Simple 'b'); Transition (3,3,Simple 'a');
     Transition (2,0,Simple 'c'); Transition (2,4,Simple 'b');
     Transition (2,1,Simple 'a'); Transition (1,0,Simple 'c');
     Transition (1,2,Simple 'b'); Transition (1,3,Simple 'a');
     Transition (0,0,Simple 'c'); Transition (0,2,Simple 'b');
     Transition (0,1,Simple 'a')];
setMap =
  map
    [(set [0; 1; 2; 3; 5], 3); (set [0; 1; 2; 5], 1); (set [0; 2; 4; 5], 2);
     (set [0; 2; 4; 5; 6], 4); (set [0; 2; 5], 0)];
setStack = [];
finalNfa = set [3; 6];
accept = set [3; 4];
nextNode = 5;
start = 0;
alphabet = ['a'; 'b'; 'c'];}
val it : unit = ()

Fortsetzung folgt.

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@>)