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

F# Sudoku Solver. Exact Cover In Solving Sudokus.

Ich möchte endlich begreifen, wie die Sudoku - Lösungstechnik  funktioniert und fand einen Artikel über das Exact Cover Problem in Zusammenhang mit Sudoku, eine Sudoku Solver Version in F# und eine Haskell-Version.

//Program.fs
open FData.ExactCover
open System
//In the standard 9×9 Sudoku variant, there are four kinds of constraints
type Constraint = 
    | Row of int * int  //Row-Number: Each row must contain each number exactly once.
    | Col of int * int  //Column-Number: Each column must contain each number exactly once.
    | Box of int * int  //Box-Number: Each box must contain each number exactly once.
    | Pos of int * int  //Row-Column: Each intersection of a row and column, i.e, each cell, must contain exactly one number.
    | Given of int      

type Move
    = { mRow : int; mCol : int; mVal : int }

let inline box r c = ((r-1) / 3) * 3 + ((c-1) / 3) + 1

//Since there are 9 rows, 9 columns, 9 boxes and 9 numbers, there are 9×9=81 row-column constraint sets, 
//9×9=81 row-number constraint sets, 9×9=81 column-number constraint sets,
// and 9×9=81 box-number constraint sets: 81+81+81+81=324 constraint sets in all.
let inline constraintsFor rest m =
    (m, Pos(m.mRow, m.mCol)) :: (m, Row(m.mRow, m.mVal)) :: 
    (m, Col(m.mCol, m.mVal)) :: (m, Box(box m.mRow m.mCol, m.mVal)) :: rest

let inline constraints givenMarks =
    //In the standard 9×9 Sudoku variant, in which each of 9×9 cells is assigned one of 9 numbers,
    // there are 9×9×9=729 possibilities.
    let l = 
        seq {for r in 1..9 do
             for c in 1..9 do
             for v in 1..9 do
             yield { mRow = r; mCol = c; mVal = v }}
    let input = 
        Seq.append
            (Seq.mapi (fun i (r,c,v) ->
                { mRow = r; mCol = c; mVal = v }, Given (i + 1)) givenMarks)
            (Seq.fold constraintsFor [] l)
    addCover input

let inline zipCoords s =
    let coords  = 
        seq {for r in 1..9 do
             for c in 1..9 do
             yield (r,c)}
    Seq.zip coords s

let inline board input = 
    seq{for (r,c),v in zipCoords input do if v>0 then yield (r,c,v)}

let inline problem s= 
    List.concat s
    |>board
    |>constraints

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

//simple Sudoku
let s2 =
    [[0; 0; 8;  3; 0; 0;  6; 0; 0]
     [0; 0; 4;  0; 0; 0;  0; 1; 0]
     [6; 7; 0;  0; 8; 0;  0; 0; 0]
     [0; 1; 6;  4; 3; 0;  0; 0; 0]
     [0; 0; 0;  7; 9; 0;  0; 2; 0]
     [0; 9; 0;  0; 0; 0;  4; 0; 1]
     [0; 0; 0;  9; 1; 0;  0; 0; 5]
     [0; 0; 3;  0; 5; 0;  0; 0; 2]
     [0; 5; 0;  0; 0; 0;  0; 7; 4]]
//middle
let s3 =
    [[1;0;0;0;0;7;0;9;0];
     [0;3;0;0;2;0;0;0;8];
     [0;0;9;6;0;0;5;0;0];
     [0;0;5;3;0;0;9;0;0];
     [0;1;0;0;8;0;0;0;2];
     [6;0;0;0;0;4;0;0;0];
     [3;0;0;0;0;0;0;1;0];
     [0;4;0;0;0;0;0;0;7];
     [0;0;7;0;0;0;3;0;0]]
//hard
let s4 = 
    [[0;0;0;  0;0;0;  0;0;8];
     [0;0;3;  0;0;0;  4;0;0];
     [0;9;0;  0;2;0;  0;6;0];
     [0;0;0;  0;7;9;  0;0;0];
     [0;0;0;  0;6;1;  2;0;0];
     [0;6;0;  5;0;2;  0;7;0];
     [0;0;8;  0;0;0;  5;0;0];
     [0;1;0;  0;0;0;  0;2;0];
     [4;0;5;  0;0;0;  0;0;3]]
test (fun()-> problem s2|>solveExactCover)
test (fun()-> problem s3|>solveExactCover)
test (fun()-> problem s4|>solveExactCover)

//ExactCover.fs
namespace FData
open System

[<RequireQualifiedAccess>]
module PrioSeq =
  type PSQ<'k, 'p> =
      | Void
      | Winner of 'k * 'p * LTree<'k, 'p> * 'k
  and LTree<'k, 'p> =
      | Start
      | LLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
      | RLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
  
  let inline play t1 t2 =
      match t1, t2 with
      | Void, t -> t
      | t, Void -> t
      | Winner (k, p, t, m), Winner (k', p', t', m') -> 
          match p <= p' with
          | true     -> Winner(k, p, RLoser(k', p', t, m, t'), m')
          | false    -> Winner(k', p', LLoser(k, p, t, m, t'), m')

  type TourView<'k, 'p> =  
      | Null
      | Single of 'k * 'p 
      | Play of PSQ<'k, 'p> * PSQ<'k, 'p>

  let inline tourView psq = 
      match psq with
      | Void -> Null
      | Winner(k, p, Start, _) -> Single(k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') -> Play(Winner(k, p, tl, m), Winner(k', p', tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') -> Play(Winner(k', p', tl, m), Winner(k, p, tr, m'))

  let empty =  Void
  
  let inline single (k, p) =  Winner(k, p, Start, k)
  
  let inline key (k,_) = k

  let inline prio (_, p) = p

  let inline maxKey (Winner (_, _, _, m)) =  m

  let rec insert b q =
      match tourView q with
      | Null                                  -> single b
      | Single(k,p) when key b < k            -> play (single b) (single(k, p))
      | Single(k,p) when key b = k            -> single b
      | Single(k,p)                           -> play (single(k, p)) (single b)
      | Play(tl, tr) when key b <= maxKey tl  -> play (insert b tl) tr
      | Play(tl, tr)                          -> play tl (insert b tr)

  let inline foldm f e x =
      let rec inner n xs =
          match n, xs with
          | 1, y::ys -> (y, ys)
          | n, ys    -> 
              let m = n / 2
              let (y1, ys1) = inner (n-m) ys
              let (y2, ys2) = inner m ys1
              f y1 y2, ys2
      match x with
      | [] -> e
      | _  -> fst (inner (List.length x) x)
  
  let inline fromOrdList l =
      foldm play empty l

  let rec toOrdLists q=
      match tourView q with
      | Null          -> List.empty
      | Single(k, p)  -> [single (k, p)]
      | Play(tl, tr)  -> (toOrdLists tl) @ (toOrdLists tr)

  let inline rebalance<'k,'p when 'p : comparison> : (PSQ<'k, 'p> ->PSQ<'k, 'p>)= fromOrdList<<toordlists 
  
  let lookup k p =
      match tourView q with
      | Null                             -> None
      | Single(k', p) when k = k'        -> Some p
      | Single(k', p)                    -> None
      | Play(tl, tr) when k <= maxKey tl -> lookup k tl
      | Play(tl, tr)                     -> lookup k tr

  let rec delete k q =
      match tourView q with
      | Null                             -> empty
      | Single(k', p) when k = k'        -> empty
      | Single(k', p)                    -> single (k', p)
      | Play(tl, tr) when k <= maxKey tl -> play (delete k tl) tr
      | Play(tl, tr)                     -> play tl (delete k tr)

  type MinView<'k, 'p> =  
      | Empty 
      | Min of ('k * 'p)

  let inline minView q =
      match q with
      | Void               -> Empty
      | Winner(k, p, t, m) -> Min (k, p)

  let rec adjust f key q = 
      match q with
      | Void                                                       -> Void
      | Winner(k, p, Start, _) when key = k                        -> single (k, (f p))
      | Winner(k, p, Start, _)                                     -> single (k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') when key <= m  -> 
          play (adjust f key (Winner(k, p, tl, m))) (Winner(k', p', tr, m'))
      | Winner(k, p, RLoser(k', p', tl, m, tr), m')                 ->
          play (Winner(k, p, tl, m)) (adjust f key (Winner(k', p', tr, m')))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') when key <= m   ->
          play (adjust f key (Winner( k', p', tl, m))) (Winner(k, p, tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m')                 ->
          let w2 = Winner(k, p, tr, m')
          play (Winner(k', p', tl, m)) (adjust f key w2)


module ExactCover =
  open System.Collections.Generic
  open Microsoft.FSharp.Collections

  type ECValue<'r when 'r : comparison> = { ecvSize : int; ecvRows : Set<'r>  }

  type ExactCover<'r, 'c when 'r : comparison and 'c : comparison> =
      { ecCol : PrioSeq.PSQ<'c, ECValue<'r>>; ecRow : Map<'r, Set<'c>> }

  let inline emptyCover<'c, 'r when 'c : comparison and 'r : comparison> = 
      {ecCol = PrioSeq.empty; ecRow = Map.empty}

  let inline addCover rcs  =
      let createMap f g = 
          rcs
          |>Seq.groupBy f
          |>Seq.map (fun (x, ys) -> x, Seq.map g ys|>Set.ofSeq)
      let col = 
          createMap snd fst
          |>Seq.fold (fun acc (c, m) -> 
                        PrioSeq.insert (c, {ecvSize = Set.count m ; ecvRows = m}) acc
                        ) PrioSeq.empty
      let row = 
          createMap fst snd
          |>Map.ofSeq
      { ecCol = PrioSeq.rebalance col; ecRow = row }
  
  let inline flip f a b = f b a
  
  let rec solve soFar ec  =
      match PrioSeq.minView ec.ecCol with
      | PrioSeq.Empty -> soFar
      | PrioSeq.Min(_, rs) -> 
          let setDifference ys ecv =
              let zs = ecv.ecvRows - ys 
              { ecvSize = Set.count zs; ecvRows = zs }
          Seq.map (fun move ->
              //Get all constraints of current move
              let constraints = Map.find move ec.ecRow
              //Get all moves of selected constraints
              let moves = Set.unionMany (Seq.map (fun k -> 
                  match PrioSeq.lookup k ec.ecCol with
                  | Some ecv -> ecv.ecvRows
                  | None -> failwith ("Nothing" + k.ToString())) constraints)
              //all posible constraints for selected moves
              let posibleConstraints = Seq.concat (Seq.map (flip Map.find ec.ecRow) moves)

              let newCol = 
                  //delete all constraints of current move
                  let acc = Seq.fold (flip PrioSeq.delete) ec.ecCol constraints
                  //update posible constraints for selected moves
                  Seq.fold (flip (PrioSeq.adjust (setDifference moves))) acc posibleConstraints

              let newRow = Seq.fold (flip Map.remove) ec.ecRow moves

              solve (Set.add move soFar) {ecCol = newCol; ecRow = newRow}) rs.ecvRows
          |>Set.unionMany
  
  let inline solveExactCover ec = solve Set.empty ec|>Set.toList

Test Start.
Time Duration : 342L
Test Start.
Time Duration : 545L
Test Start.
Time Duration : 3713L

F# Suffix Tree. longest common substring mit PSeq.

Teil 1 .

longest common substring (lcs).

Also noch mal die Algorithmusbeschreibung.
Gesucht ist die längste Zeichenkette, die in zwei gegebenen Zeichenketten x und y auftritt.
Konstruiere Suffix-Baum für x#y$, wobei # und $ nicht in x oder y auftreten.
Man sucht interne Knoten, die eine längste Zeichenkette repräsentieren und Blätter als Nachfolger besitzen, von denen mindestens eins zu einem Suffix gehört, das vor dem # beginnt und eines, das nach dem # beginnt - also kein #-Zeichen dafür aber ein $-Zeichen enthält.

Hier am Beispiel:
> lcs "abcab" "bca";;
 Node
  [(Prefix ('a'; 'b'; 'c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],Exactly 1),
    Node
      [(Prefix (['b'; 'c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],Exactly 1),
        Node
          [(Prefix (['c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf);
           (Prefix (['#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf)]);
       (Prefix (['$'],NoLength), Leaf)]);
   (Prefix (['b'; 'c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],Exactly 1),
    Node
      [(Prefix (['c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],Exactly 2),
        Node
          [(Prefix (['b'; '#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf);
           (Prefix (['$'],NoLength), Leaf)]);
       (Prefix (['#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf)]);
   (Prefix (['c'; 'a'; 'b'; '#'; 'b'; 'c'; 'a'; '$'],Exactly 2),
    Node
      [(Prefix (['b'; '#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf);
       (Prefix (['$'],NoLength), Leaf)]);
   (Prefix (['#'; 'b'; 'c'; 'a'; '$'],NoLength), Leaf);
   (Prefix (['$'],NoLength), Leaf)]

[['a']; ['b'; 'c'; 'a']; ['c'; 'a']]

val it : char list = ['b'; 'c'; 'a']

Ich habe den alten Code überarbeitet und für den Suchvorgang eigenen Type mit dem Plus-Operator definiert.


type SearchResult =
    | FoundFst
    | FoundSnd
    | FoundBoth
    | StartSearch

let inline reducer l =
    match l with
    | [] -> List.empty
    | _  -> 
        l
        |>List.reduce (fun x y -> 
            match (List.length x) > (List.length y) with
            | true  -> x
            | false -> y)

//plus operator for SearchResult.
let inline (>+<) (s1 : SearchResult) (s2 : SearchResult) =
    match s1, s2 with
    | x, y when x = y -> x
    | FoundBoth, _ -> FoundBoth
    | _, FoundBoth -> FoundBoth 
    | FoundFst, FoundSnd -> FoundBoth
    | FoundSnd, FoundFst -> FoundBoth
    | StartSearch, x -> x
    | x, StartSearch -> x

let inline lcsParallel s1 s2 = 
    let endFst = '#'
    let endSnd = '$'
    //Check a prefix if that begins before the endFst or after the endFst.
    let inline filterPrefix founded chars =
        let filtered = Seq.tryPick (fun character -> 
            match ( character = endFst), ( character = endSnd) with
            | true, _ -> Some FoundFst
            | _, true -> Some FoundSnd
            | _       -> None) chars
        match filtered with
        | Some f -> f >+< founded
        | None   -> founded
    let inline fprefix p (downl, downFounded) (accl, accFounded) =
            let found dl=
                    match dl with
                    | [] -> (prefix p) :: accl, downFounded
                    | _ ->
                        let comb = List.map (fun x -> (prefix p) @ x) dl
                        comb @ accl, downFounded
            match p, downFounded with
            | Prefix(_, Exactly _), FoundBoth -> 
                found downl
            | Prefix(chars, Exactly _), _ ->
                match (filterPrefix downFounded chars) with
                | FoundBoth -> found downl
                | other     -> accl, other >+< accFounded
            | Prefix(chars, _), _ -> 
                match accFounded with
                | FoundBoth -> accl, accFounded
                | other     -> accl, filterPrefix other chars
    let (result, _) = 
        constructParallel ((s1|>List.ofSeq) @ [endFst] @ (s2|>List.ofSeq) @ [endSnd])
        |>foldParallel (fun _ -> (List.empty, StartSearch))   //fdown
             id                                               //fup
             fprefix                                          //fprefix
             id                                               //fleaf
             (List.empty, StartSearch)                        //accumulator
    match result with
    | [] -> List.empty
    | _  -> reducer result 

Bei weiterem Herumprobieren habe ich dann herausgefunden, wie man die fold-Funktion noch ein Tick schneller laufen lässt. Der Suffix-Baum wird nicht komplett mit PSeq.fold rekursiv durchgegangen, wie es bei der foldParallel-Version erfolgt, sondern nur die oberste Einträge von der STree Node-Liste werden parallel gestartet. Alle weitere tief liegende Nodes werden weiter rekursiv mit der einfachen Seq.fold durchgegangen.

Der Funktionsname ist vielleicht nicht ganz richtig ausgewählt, mir fällt aber kein anderer Name ein.

let inline foldTask fdown fup fprefix fleaf ftask=
    let rec go state tree =
        match tree with
        | Leaf   -> fleaf state
        | Node es -> fup (Seq.fold edge state es)
    and edge state (p, subtree) = fprefix p (go (fdown state) subtree) state
    let start state t =
        match t with
        | Leaf    -> state
        | Node es -> ftask edge state es
    start 

Die eigentliche Parallelisierung geschieht in der ftask-Funktion, die an der foldTask als zusätzlicher Parameter übergeben wird.

let inline lrsTask s= 
    let endFst = '#'
    constructParallel ((s|>List.ofSeq) @ [endFst])
    |>foldTask (fun _ ->(0, List.empty))               //fdown
         id                                            //fup
         (fun p (count', res') (count, res) ->
            match p with
            | Prefix(_, Exactly v) ->
                match (v + count') > count with
                | true  -> (v + count'), (prefix p) :: res'
                | false -> count, res
            | _ -> count, res)                         //fprefix
         id                                            //fleaf
         (fun edge v->                              //   __
             PSeq.map (fun e ->                     //  |
                     edge v e)                      // <    ftask
             >>PSeq.toList                          //  |
             >>List.max )                            // |__
         (0, List.empty)                               //accumulator
     |>snd
     |>List.concat

let inline lcsTask s1 s2 = 
    let endFst = '#'
    let endSnd = '$'
    let filterPrefixes founded p =
        let filtered = Seq.tryPick (fun item -> 
            match ( item = endFst), ( item = endSnd) with
            | true, _ -> Some FoundFst
            | _, true -> Some FoundSnd
            | _ -> None) p
        match filtered with
        | Some f -> f >+< founded
        | None   -> founded
    let fprefix p (downl, downFounded) (accl, accFounded) =
            let found dl=
                    match dl with
                    | [] -> (prefix p) :: accl, downFounded
                    | _  ->
                        let comb = List.map (fun x -> (prefix p) @ x) dl
                        comb@accl, downFounded
            match p, downFounded with
            | Prefix(_, Exactly _), FoundBoth -> 
                found downl
            | Prefix(t, Exactly _), _ ->
                match (filterPrefixes downFounded t) with
                | FoundBoth -> found downl
                | other     -> accl, other >+< accFounded
            | Prefix(t, _), _ -> 
                match accFounded with
                | FoundBoth -> accl, accFounded
                | other     -> accl, filterPrefixes other t
    let ftask edge v es =
        es
        |>PSeq.map (fun e ->
                     match edge v e with
                     | res, FoundBoth -> res
                     | _ -> List.empty)
        |>PSeq.concat
        |>PSeq.toList, StartSearch
    let (l, _) = 
        constructParallel ((s1|>List.ofSeq) @ [endFst] @ (s2|>List.ofSeq) @ [endSnd])
        |>foldTask (fun _ -> (List.empty, StartSearch))    //fdown
             id                                            //fup
             fprefix                                    //fprefix
             id                                         //fleaf
             ftask                                    //ftask
             (List.empty, StartSearch)                  //accumulator
    reducer l

Hier mal der Testlauf.

#load @"SuffixTreeParallel.fsx"

open System

open FData.SuffixTree

let test f =

    printfn "Test Start"

    let sw = new System.Diagnostics.Stopwatch()

    sw.Start()

    let res=f ()

    sw.Stop()

    printfn "Time Duration : %A" sw.ElapsedMilliseconds

let s1 = "banghgnabnhhbanban"

let s2 = "navbanbanvna"

let stringlen=[200..300]

let testsPairs = [for i in stringlen->String.Concat (Array.create i s1),String.Concat (Array.create i s2)]

> test (fun()-> List.map (fun (word, _) -> lrs word) testsPairs)

test (fun()-> List.map (fun (word, _) -> lrsTask word) testsPairs)

test (fun()-> List.map (fun (word, _) -> lrsParallel word) testsPairs)

test (fun()-> List.map (fun (word1, word2) -> lcs word1 word2) testsPairs)

test (fun()-> List.map (fun (word1, word2) -> lcsTask word1 word2) testsPairs)

test (fun()-> List.map (fun (word1, word2) -> lcsParallel word1 word2) testsPairs);;

Test Start

Time Duration lrs : 274894L

Test Start

Time Duration lrsTask : 121913L

Test Start

Time Duration lrsParallel : 123758L

Test Start

Time Duration lcs : 433931L

Test Start

Time Duration lcsTask : 197091L

Test Start

Time Duration lcsParallel : 214340L

Der komplette Code ist hier.

F# Suffix Tree. longest repeated substring mit PSeq.

Vor einiger Zeit habe ich mich mit dem Suffix Tree und den dazugehörigen Algorithmen beschäftigt. Ich fragte mich, ob die Algorithmen auch parallel ausgeführt werden können.
Als erstes habe ich den Code ein bisschen optimiert, da der alte Code zu sehr an der Haskell-Version angelehnt war.

//The length of a prefix list
type Length<'a> =
    Exactly of int
    | NoLength

//The prefix string associated with an 'Edge'
type Prefix<'a> = Prefix of 'a list * 'a Length

// An edge in the suffix tree.
type Edge<'a>='a Prefix * 'a STree
// The suffix tree type
and STree<'a>= 
    Node of 'a Edge list
    |Leaf

//old version.  a bit too much similar to the Haskell version.
let rec cst (l:'a list list) =
    match l with
    | [s] -> (NoLength, [[]])
    | ((a :: w) :: xs) as awss when not (List.isEmpty xs)->
        let folder e acc =
            match e with
            | c :: _ when a <> c -> c :: acc
            | _ -> acc
        let cc = List.foldBack folder xs List.empty
        match (List.isEmpty cc) with
        |true ->
            let folder' e acc =
                match e with
                | _ :: tails ->  tails :: acc
                | _ -> acc
            let xss = List.foldBack folder' xs List.empty
            let cpl, rss = cst (w :: xss)
            inc cpl, rss
        |false -> (Exactly 0,awss)
    |_ -> (NoLength, [[]])

//new version. more F#.
//create a Prefix.
//val cst : 'a list list -> Length<'a0> * 'a list list when 'a : equality
let rec cst (l:'a list list) =
    match l with
    | [s] -> (NoLength, [[]])
    | ((character :: word) :: words) as awss when not (List.isEmpty words)->
        let filter word =
            match word with
            | hd :: _ when character <> hd -> true
            | _ -> false
        match (Seq.exists filter words) with
        | false ->
            let cpl, rss = cst (word :: (List.map (fun (_ :: tails) -> tails) words))
            inc cpl, rss
        | true -> (Exactly 0, awss)
    | _ -> (NoLength, [[]])

Unten ist der Prozess der Erstellung eines Suffix-Baumes veranschaulicht.

Für die parallele Ausführung benutze ich das PSeq-Modul aus F# PowerPack, das nichts anderes als die PLINQ-Integration ist. Die parallele Ausführung der treeParallel-Funktion bringt den meisten Performance-Gewinn.

let inline tree edge =
    let rec suf (l:'a list list) =
        match l with
        | [[]] -> Leaf
        | ss   ->
            let folder ((a,nsa) : 'a * 'a list list) acc =
                match nsa with
                | sa :: _ ->
                    let cpl, ssr = edge nsa
                    let prfx = Prefix (a :: sa, inc cpl)
                    ( prfx, suf ssr) :: acc
                | _ -> acc
            Node(List.foldBack folder (suffixMap ss) List.empty)
    suf<<suffixes

//val inline treeParallel :
//    ('a list list -> Length<'a> * 'a list list) -> ('a list -> STree<'a>)
//      when 'a : equality
let inline treeParallel edge =
    let rec suf (l:'a list list) =
        match l with
        | [[]] -> Leaf
        | xs ->
            let folder ((key, values) : 'a * 'a list list) acc=
                match values with
                |sa :: _ ->
                    let cpl, ssr = edge values
                    let prfx     = Prefix (key :: sa, inc cpl)
                    (prfx, suf ssr) :: acc
                | _ -> acc
            Node(List.foldBack folder (suffixMap xs) List.empty)
    let inner ((key, values):'a list * 'a list list)=
                    let cpl, ssr = edge values
                    let prfx     = Prefix (key, inc cpl)
                    prfx, suf ssr
    let start (l : 'a list list) =
        match l with
        | [[]] -> Leaf
        | xs -> 
            let edges = 
                PSeq.choose (fun (k, v)->
                    match v with
                    | sa :: _ -> Some (inner (k :: sa, v))
                    | _       -> None) (suffixMap xs)
            Node (PSeq.toList edges)
    start<<suffixes

// Constructs a suffix tree. parallel.
let inline constructParallel<'a when 'a : comparison> : ('a List -> 'a STree) = 
    treeParallel cst

Die Verwendung der PSeq.fold in  foldParallel lässt die Geschwindigkeit noch um ein paar Prozent steigen,  aber nicht so signifikant wie bei der treeParallel-Funktion.

// foldParallel : (a -> a)                -- ^ downwards state transformer (fdown) 
//     -> (a -> a)                -- ^ upwards state transformer  (fup)
//     -> (Prefix b -> a -> a -> a) -- ^ edge state transformer (fprefix)
//     -> (a -> a)                -- ^ leaf state transformer (fleaf)
//     -> a                       -- ^ initial state  (state)
//     -> STree b                 -- ^ tree
//     -> a
let inline foldParallel fdown fup fprefix fleaf =
    let rec go state tree =
        match tree with
        | Leaf    -> fleaf state
        | Node es -> fup (PSeq.fold edge state es)
    and edge state (p, subtree) = fprefix p (go (fdown state) subtree) state
    go 

Das liegt vermutlich daran, das die PSeq.fold letztendlich die fprefix-Funktion auf jedes Element einer Node-Liste anwendet und dies geschieht noch dazu rekursiv. In Fällen, wo das Präfix kurz ist, führt es wohl zu einem Overhead bei der parallelen Ausführung.

longest repeated substring (lrs).

let inline lrsParallel  s= 
    let endFst = '#'
    constructParallel ((s|>List.ofSeq) @ [endFst])
    |>foldParallel (fun _ -> (0, List.empty))               //fdown
        id                                                  //fup
        (fun p (count', res') (count, res) ->
            match p with
            | Prefix(_, Exactly v) ->
                match (v + count') > count with
                | true  -> (v + count'), (prefix p) :: res'
                | false -> count, res
            | _ -> count, res)                              //fprefix
        id                                                  //fleaf
        (0, List.empty)                                     //accumulator
    |>snd
    |>List.concat

Für heute reicht es. Weiter geht es mit der parallele Version von "longest common substring".
Der komplette Code ist hier.

Die Konstruktion eines Suffix-Baum am Beispiel des Wortes "banana".