F# Monad Transformers Library.

FML.

F# Spell Checker mit BK-Tree. Teil 2. Parallel Tasks.

Teil 1.
Hier ist die F# Implementierung einer anderen Distanz-Funktion - Damerau-Levenshtein Distanz.

Ich glaube einen F#-Bug entdeckt zu haben. Auf jedem Fall wenn ich die levenshteinDistance-Funktion aus dem letzten Posting ändere, dauert die Erstellung von Spell Corrector statt eine halbe Minute nur noch ca. 11-13 Sekunden, sodass man auf das Serialisieren vom BK-Baum verzichten kann.

let levenshteinDistance s1 s2 =
    let sa,sb : char [] * char [] = Array.ofSeq s1, Array.ofSeq s2
    let n = Array.length sa
    let transform (narr : int []) c =
        let zip3wrapper xs =
            let m = (min n (Array.length xs)) - 1
            Array.zip3 sa.[..m] narr.[..m] xs.[..m]
        let compute z (c', x, y) =
            // List.min oder die Listenerstellung ist viel zu langsam.
            // List.min [y+1; z+1; x + abs (compare c' c)]
            min (y + 1) (z + 1)|> min (x + abs (compare c' c))
        Array.scan compute (narr.[0] + 1) (zip3wrapper narr.[1..])
    let res = Array.fold transform [|0..n|] sb
    res.[res.Length - 1] 

Der Code kann noch schneller werden, wenn wir ihm parallelisieren. Dazu brauchen wir die neue .Net 4 Tasks-Bibliothek.

module Utils =
    open System.Threading.Tasks
    ...
      // returns all the elements in tree which are 
      // at a distance less than or equal to n from the element a.
      let inline elemsDistance distance =
        let rec inner n word tree =
            match tree with
            | Empty          -> []
            | Node (other, imap) ->
                let d = distance word other
                let folder acc key v =
                    if (key > d - n - 1 && key < d + n + 1) then
                        (inner n word v) :: acc
                    else
                        acc
                if d <= n then
                    other :: (Map.fold folder [] imap|>List.concat )
                else
                   Map.fold folder [] imap|>List.concat
        inner
    //Parallel Tasks version.
    let inline elemsDistanceTask distance =
        let rec inner n word other map =
                let d = distance word other
                let folder acc key v =
                    if (key > d - n - 1 && key < d + n + 1) then
                        match v with
                        | Node (b, imap) -> (inner n word b imap) :: acc
                    else
                        acc
                if d <= n then
                    other :: (Map.fold folder [] map|>List.concat )
                else
                   Map.fold folder [] map|>List.concat
        let start n word tree =
            match tree with
            | Empty          -> []
            | Node (other, imap) -> 
                let tasks = Map.fold (fun acc key v->
                    match v with
                    | Node(_, map) -> Task.Factory.StartNew(fun () -> inner n word other map) :: acc) [] imap|>List.toArray
                let result = Task.Factory.ContinueWhenAll(tasks, (fun ts -> Array.map (fun (t : Task<string list>) -> t.Result) ts|>List.concat))
                result.Result
        start 
    //Constructs a tree from a list
    let inline fromList distance =
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | w :: ws -> 
                let mkDist other =
                    (distance w other, other)
                let recurse pairlist =
                    match pairlist with
                    | (key,_) :: _ ->(key, constructTree (List.map snd pairlist))
                //goupBy surrogate.
                let folder (acc, l) (key ,word) =
                    if acc = key then
                        match l with
                        | x :: xs -> key, ((key, word) :: x) :: xs
                        | _ -> key, [[(key, word)]]
                    else
                        key, [(key, word)] :: l
                List.map mkDist ws
                |>List.sortBy fst
                |>List.fold folder (0, List.empty)|>snd
                |>List.map recurse
                |>Map.ofList
                |>node w
        constructTree 
    
    //Parallel Tasks version.
    let inline fromListTask distance =
        let mkDist word other =
                    (distance word other, other)
        //goupBy surrogate.
        let folder (acc, l) (key ,word) =
            if acc = key then
                match l with
                | x :: xs -> key, ((key, word) :: x) :: xs
                | _ -> key, [[(key,word)]]
            else
                key, [(key, word)] :: l
        let constructKeyValuePairs word ws =
            List.map (mkDist word) ws
            |>List.sortBy fst
            |>List.fold folder (0,List.empty)|>snd
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | w :: ws ->
                constructKeyValuePairs w ws 
                |>List.map recurse
                |>Map.ofList
                |>node w
        and recurse pairlist =
                match pairlist with
                | (key, _) :: _ ->(key, constructTree (List.map snd pairlist))
        let start xs =
            match xs with
            | [] -> Empty
            | w :: ws -> 
                let pairs  = constructKeyValuePairs w ws 
                let tasks  = List.map (fun pairlist -> Task.Factory.StartNew(fun () -> recurse pairlist)) pairs|>List.toArray
                let result = Task.Factory.ContinueWhenAll(tasks, (fun ts -> Array.fold (fun acc (t : Task<int * BKTree<_>>) -> t.Result :: acc) [] ts))
                Map.ofList result.Result
                |>node w
        start

Auf meinem Core 2 Quad Q6600 Desktop kommt es zu folgenden Ergebnissen.


Der komplette Code.

F# Spelling Checker mit BK-Tree und Levenshtein-Distanz. Teil 1.

Hier habe ich vor kurzem gelesen, wie leicht man auf Basis von einen Burkhard-Keller Baum einen Spelling Checker aufbauen kann.
Wie man aus dem Artikel erfährt, braucht man zuerst die Levenshtein Distanz oder irgendeine andere Distanz-Funktion. Hier gibt es Implementierungen in verschiedenen Programmierungssprachen. Ich habe mich an der Haskell-Variante orientiert.

let levenshteinDistance s1 s2 = 
    let sa, sb:char [] * char [] = Array.ofSeq s1, Array.ofSeq s2
    let n = Array.length sa
    let transform (narr:int []) c = 
        let zip3wrapper xs =
            let m = (min n (Array.length xs))-1
            Array.zip3 sa.[..m] narr.[..m] xs.[..m]
        let compute z (c', x, y) = List.min [y+1; z+1; x + abs (compare c' c)]
        Array.scan compute (narr.[0]+1) (zip3wrapper narr.[1..])
    let res = Array.fold transform [|0..n|] sb 
    res.[res.Length-1]

Ich weiß nicht, ob es ein Fehler von F# ist, aber wenn man Typenangaben in der Zeile

let sa, sb = Array.ofSeq s1, Array.ofSeq s2

weglässt, errechnet die compare-Funktion später den falschen Wert.

Als zweites braucht man eine Type-Definition von BK-Baum, was in F# dank den rekursiven Typen schnell gemacht ist.

type BKTree<'a> = 
        | Node of 'a *  Map<int, BKTree<'a>>
        | Empty

Schon wieder habe ich eine Haskell-Implementierung als Vorlage genommen.

module SpellChecker
open System.IO

module BKTreeType =
    open System.Runtime.Serialization.Formatters.Binary
    type BKTree<'a> = 
        | Node of 'a *  Map<int, BKTree<'a>>
        | Empty
    with
        member this.toFile(filename) =
            let bf = new BinaryFormatter()
            using (File.Open(filename, FileMode.Create))
                (fun treeFile -> bf.Serialize(treeFile, this))
        static member fromFile(filename) =
            let bf = new BinaryFormatter()
            using (File.Open(filename, FileMode.Open))
                (fun treeFile -> bf.Deserialize(treeFile) :?> BKTree<'a>)

module Utils =
    open System.Collections.Generic
    open BKTreeType
    
    let inline singleton a = Node (a, Map.empty)
    
    let inline node a map = Node (a, map)
    // Inserts an element into the tree.
    let inline insert distance =
        let rec inner a t=
            match t with
            | Empty        -> singleton a
            | Node (b,map) ->
                let d = distance a b
                match Map.tryFind d map with
                | None      -> Node (b, Map.add d (singleton a) map)
                | Some tree -> Node (b, Map.add d (inner a tree) map)
        inner
    // returns all the elements in tree which are 
    // at a distance less than or equal to n from the element a.
    let inline elemsDistance distance =
        let rec inner n a tree =
            match tree with
            | Empty          -> []
            | Node (b, imap) ->
                let d = distance a b
                let folder acc k v =
                    if (k > d-n-1 && k < d+n+1) then
                        (inner n a v)::acc
                    else
                        acc
                if d<=n then
                    b::(Map.fold folder [] imap|>List.concat )
                else
                   Map.fold folder [] imap|>List.concat
        inner
    // is element  in the tree.
    let inline isMember distance =
        let rec inner a tree = 
            match tree with
            | Empty         -> false
            | Node (b, map) ->
                match a = b with
                | true  -> true
                | false -> 
                    match Map.tryFind (distance a b) map with
                    | None      -> false
                    | Some tree -> inner a tree
        inner
    // return true if there is an element in tree
    // which has a distance less than or equal to n
    // from a.
    let inline memberDistance distance =
        let rec inner n a tree =
            match tree with
            | Empty         -> false
            | Node (b, map) ->
                match distance a b with
                | d when d <= n -> true
                | d             ->
                    let folder acc k v =
                        if (k > d-n-1 && k < d+n+1) then
                            v::acc
                        else
                            acc
                    Map.fold folder [] map
                    |>List.exists (inner n a)
        inner

    //Constructs a tree from a list
    let inline fromList distance =
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | x::xss -> 
                let mkDist m =
                    (distance x m, m)
                let recurse bs =
                    match bs with
                    | (k, _)::_ ->(k, constructTree (List.map snd bs))
                let folder (acc, t) (k, w) =
                    if acc = k then
                        match t with
                        | x::xs -> k,((k, w)::x)::xs
                        | _ -> k,[[(k, w)]]
                    else
                        k,[(k,w)]::t
                List.map mkDist xss
                |>List.sortBy fst
                |>List.fold folder (0, List.empty)|>snd
                |>List.map recurse
                |>Map.ofList
                |>node x
        constructTree 

    let inline reader file =
        seq {
          use reader = new StreamReader(File.OpenRead(file))
          while not reader.EndOfStream do
            yield reader.ReadLine()
        }

    let inline read dir =
        [for file in Directory.GetFiles(dir) do
              if Path.GetFileName(file.ToLower()) <> "readme" then
                for line in reader file ->
                  line.ToLower()
        ]
module Implementer =
    open Utils
    type SpellChecker(d:string->string->int)  =
      let distance = d
      member x.fromIspellFile   = x.fromList<<read
      member x.Insert           = insert distance
      member x.elemsDistance    = elemsDistance distance
      member x.isMember         = isMember distance
      member x.memberDistance   = memberDistance distance
      member x.fromList         = fromList distance 
      member x.Check n word tree  = 
          if x.isMember word tree then
              []
          else 
              x.elemsDistance n word tree

Das Wörterbuch für den Spelling Checker kann man von Ispell English Word Lists runterladen.
Jetzt können wir testen.

#load @"spell.fsx"
open SpellChecker.BKTreeType
open SpellChecker.Implementer

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

let dir = @"C:\ispell-enwl-3.1.20"

let spellBuilder =new SpellChecker(levenshteinDistance)
let tree = spellBuilder.fromIspellFile dir

Wie man sieht, dauert es ca. 20 sec. einen Spelling Cheker mit Daten zu füllen ( auf meinem alten Laptop sogar mehr als eine Minute). Dafür sind die einzelne Check-Abfragen relativ schnell.

Wir können die Daten nur ein einziges Mal laden, serialisieren und dann immer mit der serialisierten Datei arbeiten. Leider kann ich nicht die fromList-Methode dafür verwenden, da dabei ein F#-Fehler auftrat, und musste die langsame Insert-Methode nehmen.

 let testList =["watergate";"dance";"frippery";"disestablishment";"bit";"uncharacteristically";]

let treeFromList = spellBuilder.fromList testList
let treeInsert = List.fold (fun acc word ->spellBuilder.Insert word acc) Empty testList

open SpellChecker.Utils
let treeToSerialize = List.fold (fun acc word ->spellBuilder.Insert word acc) Empty (read dir)
treeToSerialize.toFile "spellDictionary"

Das Laden ist vierfach schneller geworden.

F# Boids (Swarm). Schwarm Simulation.

Update Part 2.

Boids stellen eine Simulation von Schwarmverhalten dar.
Als Grundlage diente mir der folgende Pseudocode. Einige Implementierungsdetails habe ich von hier übernommen.
Die Regeln sind schnell implementiert.

let inline sq x = x * x

type BoidVel = { velX:float; velY :float }

type BoidNeighbour = {relX:float; relY : float; Vel : BoidVel }

//three vector operators.
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

//boids neighbours. 
let inline within neighbours distance = 
    List.filter (fun n -> (sq n.relX) + (sq n.relY) < (sq distance) ) neighbours

//Boids try to match velocity with near boids.
let inline meanVelocityAcc curVel neighbours =
    match neighbours with
    |[]->curVel.velX,curVel.velY
    |_->
        (List.average (List.map (fun n -> n.Vel.velX) neighbours)) - curVel.velX,
        (List.average (List.map (fun n -> n.Vel.velY) neighbours)) - curVel.velY

//An acceleration to stop us hitting nearby boids.
let inline repulsionAcc sight neighbours =
    within neighbours sight 
    |>List.map (fun n->negate n.relX, negate n.relY)
    |>List.fold (<+>) (0.0, 0.0) 

//An acceleration to keep us quite close to nearby boids. 
let inline keepCloseAcc neighbours = 
    match neighbours with
    |[]->0.0,0.0
    |_->
        List.average (List.map (fun n->n.relX) neighbours),
        List.average (List.map (fun n->n.relY) neighbours)

//Limit maximum speed.
let inline limit boidVel speedLimit =
    match boidVel with
    |vel when sq vel.velX + sq vel.velY > sq speedLimit ->
        let slowdown = (sq speedLimit) / (sq vel.velX + sq vel.velY)
        {velX = slowdown * vel.velX; velY = slowdown * vel.velY}
    |_ -> boidVel

//Bounding the position
let inline boundPosition (boundMin,boundMax) boid =
    let bound coor =
        match coor > boundMax, coor<boundMin with
        |true, _ -> -1.0
        |_, true -> 1.0
        |_ -> 0.0
    bound boid.relX, bound boid.relY

//apply rules for current boid.
let inline boidRules sight (cur,input)= 
    let neighbours = within input 2.0 * sight
    (meanVelocityAcc cur.Vel neighbours) </> 8.0
    <+> (repulsionAcc sight neighbours </> 4.0)
    <+> (keepCloseAcc neighbours </> 30.0)

Die Schwarm-Daten hält man üblicherweise (z.B wegen Effizienz) in einem Array, ich wollte aber in Rahmen der reinen funktionalen Programmierung bleiben und entscheide mich die Daten in einer Liste zu halten. Daraus ergab sich eine interessante Funktion zur Berechnung der neuen Position einzelner Schwarm-Elemente.

type Environment = 
    {sight: float;
     space float;
     speedLimit: float; 
     bound: float * float;
     target: BoidNeighbour -> float * float; //goal seeking function
     avoidObstacle: BoidNeighbour -> float * float //obstacle avoidance function
    }

let inline moveAll env input =
    input|> List.fold 
        (fun (pred,succ) _ -> 
            match succ with
            |x::xs->
                withEnv env (x, near env.space x (pred@xs))::pred, xs
            |[]->
                pred,[]) ([], input)
    |> fst

Wir gehen unsere Liste von Boids durch und erstellen eine neue Liste.

input|>List.fold ...

Als Akkumulator wird ein Tupel von Listen verwendet.

input|>List.fold (fun (pred,succ) _ -> ...) ([], input)

Wie man sieht, wird input noch mal als Anfangszustand an der Fold-Funktion übergeben. In der Funktion wird den neuen Wert des Elements berechnet. Dabei wird mit den relativen Positionen gearbeitet, für deren Berechnung eine Liste alle Boids außer aktuellen - pred@xs - gebraucht wird.

...near env.space x (pred@xs)
...
let inline near distance cur boids =
    let absDiff a b = abs (a - b)
    List.fold 
        (fun acc other -> 
            if (absDiff cur.relX other.relX <= distance) && (absDiff cur.relY other.relY <= distance) then
                {Vel=other.Vel;
                 relX = other.relX- cur.relX;
                 relY = other.relY- cur.relY}::acc
            else
                acc ) [] boids

In der pred-Teilliste stehen neu berechnete Werte aller Vorgänger eines aktuellen Elementes,

withEnv env (x, near env.space x (pred@xs))::pred

so dass diese am Ende des Folding-Prozesses alle neuen Werte enthält.

Zwei weitere Regeln können interaktiv vom Benutzer hinzugefügt werden: das Ausweichen von Hindernissen und eine Zielsuche.

//awoid obstacle.
let inline avoid sight radius obstacle boid =
    let diffAngle vel distance =
        let rec inner a f r=
            match (f a) with
            | true-> inner (r a) f r
            | false -> a
        let t = inner (vel - distance) (fun x-> x > Math.PI) (fun x-> x - 2.0*Math.PI)
        inner t (fun x-> x<(-Math.PI)) (fun x->x+ 2.0*Math.PI)
    let (dx,dy) = obstacle <-> (boid.relX, boid.relY)
    let distance = sqrt (sq dx+sq dy)
    match distance with 
    | d when d <= sight -> 
        (-dx*rnd.NextDouble(),-dy*rnd.NextDouble())
    | d when d < (2.0 *sight + radius) ->
        let velAngle=atan2 boid.Vel.velY boid.Vel.velX
        let distanceAngle = atan2 dy dx
        let diff = diffAngle velAngle distanceAngle
        let newVel sinOrCos m = ((distance - radius)*(sinOrCos (distanceAngle - m * Math.PI)) +
                                (radius + sight - distance * rnd.NextDouble()) * 
                                (sinOrCos (distanceAngle - Math.PI)))/sight
        match (abs diff) < Math.PI/2.0 with
        | true ->
            if diff>0.0 then
                (newVel cos 1.5, newVel sin 1.5)
            else
                (newVel cos 0.5, newVel sin 0.5)
        | false -> (0.0, 0.0)
    | d->
        (0.0, 0.0)

let inline tendToPlace bound place boid =
    (place <-> (boid.relX, boid.relY)) </> (bound * 1.5)

Alle Regeln zusammen.

let inline withEnv env (cur,input) =
    let (idealAccX, idealAccY) = 
        (boidRules env.sight (cur, input))
        <+> (env.target cur)  3.0
        <+> (env.avoidObstacle cur)
        <+> (boundPosition env.bound cur) 
    let newvel = limit {velX = cur.Vel.velX + (idealAccX/6.0);
                        velY = cur.Vel.velY + (idealAccY/6.0)} env.speedLimit
    {Vel = newvel; relX = cur.relX + newvel.velX; relY = cur.relY + newvel.velY}

Dank First Class Events in F# kann die Benutzerinteraktion ganz einfach, schnell und in funktionaler Manier realisiert werden.
Linke Maustaste - Hindernis auf das Formular platzieren.
Rechte Maustaste - Ziel für den Schwarm setzen.

type AnimationForm() as x =
    inherit Form()
    let img = createImage Brushes.Red

    do 
        x.SetStyle(ControlStyles.AllPaintingInWmPaint ||| ControlStyles.OptimizedDoubleBuffer, true)
        x.FormBorderStyle <- FormBorderStyle.FixedToolWindow
        x.StartPosition <- FormStartPosition.CenterScreen
        
        let tmr = new Timers.Timer(Interval = 20.0)
        tmr.Elapsed.Add(fun _ -> x.Invalidate() )
        tmr.Start()

    member x.guiRefresh (e:Graphics) envDrawing swarm =
        e.FillRectangle(Brushes.White, Rectangle(Point(0,0), x.ClientSize))
        let envCompose = compose envDrawing.drawingObstacle envDrawing.drawingTarget
        let drawing = swarm|>List.fold (fun acc n->compose acc (drawBoid img n) ) emptyDrawing
        envCompose.Draw(e)
        drawing.Draw(e)

let test =
    let boundMin,boundMax=0.0,650.0
    let radius =10.0
    //Start Enviroment.
    let envStart = {sight = 18.0; space = 250.0;
                    speedLimi t= 1.2;
                    bound = (boundMin,boundMax);
                    targe t= (fun _-> 0.0, 0.0);
                    avoidObstacle = (fun _-> 0.0, 0.0)}
    let envDrawingStart = {drawingTarget = emptyDrawing; drawingObstacle = emptyDrawing}
    let af = new AnimationForm(ClientSize = Size(int boundMax, int boundMax), Visible = true)
    let swarmInit = List.map (fun i ->makeboid i rnd) [0..150]
    //Start swarm after 500 steps.
    let swarmStart = List.fold (fun acc _->moveAll envStart acc) swarmInit [0..500]
    let evtMouseClick =
        af.MouseClick 
        |>Event.scan (fun (accEnv,accEnvDrawing) arg->
                 match (arg.Button) with
                 | MouseButtons.Left->
                     let f = avoid accEnv.sight radius (float arg.X,float arg.Y)
                     {accEnv with avoidObstacle = f}, {accEnvDrawing with drawingObstacle = 
                                                           circle Brushes.Black (float32 radius) (float32 arg.X, float32 arg.Y)}
                 | MouseButtons.Right->
                     let f = tendToPlace boundMax (float arg.X,float arg.Y)
                     {accEnv with target = f}, {accEnvDrawing with drawingTarget = 
                                                    circle Brushes.Red (float32 radius) (float32 arg.X,float32 arg.Y)}
                 | _-> 
                     accEnv, accEnvDrawing) 
            (envStart, envDrawingStart)

    let rec waiting (env:Environment) (envDrawing:EnvDrawing) swarm= async {
        let! evnt = Async.AwaitObservable (af.Paint, evtMouseClick)
        match evnt with
        | Choice1Of2(evntArg1)->
            let newSwarm = moveAll env swarm
            af.guiRefresh evntArg1.Graphics envDrawing newSwarm
            do! waiting env envDrawing newSwarm 
        | Choice2Of2(evntArg2) ->
            let newEnv,newEnvDrawing = evntArg2
            do! waiting newEnv newEnvDrawing swarm }
    waiting envStart envDrawingStart swarmStart|> Async.StartImmediate
#if COMPILED
  af

System.Windows.Forms.Application.Run(test)
#else
let main() =
    test |> ignore
[<STAThread>]
    do main()
#endif

Die Exe-Datei zum Ausprobieren und der komplette F#-Code.

F# Skip List.

Ausnahmsweise keine funktionale Datenstruktur. Mein bescheidener Versuch eine Skip List zu implementieren.

open System

type Key<'k> =
    |Key of 'k
    |Root

type NodeRecord<'k> = {key:Key<'k>; down:Node<'k>; mutable succ:Node<'k>}
and Node<'k> = 
    |Node of NodeRecord<'k>
    |Nil
    |DownNil

let inline createTower k maxLvl = 
    let rec createNode node lvl=
        match lvl with
        |l when l < maxLvl ->
            let r = {key= k;down = node; succ= Nil}
            createNode (Node r) (lvl+1)
        |_->node
    createNode DownNil 0

let inline downNode node=
    match node with
    |Node record-> record.down
    |_-> Nil


let inline setSucc succNode node=
    match succNode with
    |Node record-> record.succ<-node
    |_->()

let inline setNewNode predecessor newNode node=
    match predecessor,newNode with
    |Node predrecord, Node newrecord-> 
        newrecord.succ<-node
        predrecord.succ<-newNode
    |_->()

type SkipList<'k when 'k:comparison> (p:float, maxLvl:int) =
    let maxLevel = maxLvl
    let probability = p
    let mutable curLevel = 0
    let rnd =new Random()
    //skip list data
    let tskip = createTower Root maxLvl
    member x.Data 
     with get()  = tskip
    member x.MaxLevel 
     with get()  = maxLevel
    member x.Probability 
     with get()  = probability
    member private x.Start 
     with get()  = 
        let rec startNode node n = 
            match n with 
            |l when l > 0 -> startNode (downNode node) (n-1)
            |_-> node
        startNode tskip (maxLevel - (curLevel+1))
    member inline private x.chooseLevel (rndm:Random)= 
        let rs = Seq.initInfinite (fun _-> rndm.NextDouble())
        let samples = Seq.take (maxLevel - 1) rs
        Seq.length (Seq.takeWhile ((<) probability ) samples)
    member inline x.Insert (k:'k) = 
        let rec insertAcc lvl node newNode predecessor=
            match node with
            |DownNil->()
            |Nil -> 
                match (lvl > 0) with
                |false->
                    setSucc predecessor newNode
                    insertAcc lvl (downNode predecessor) (downNode newNode) Nil
                |true->
                    insertAcc (lvl-1) (downNode predecessor) newNode Nil
            |Node record -> 
                match record.key with
                |Root -> 
                    insertAcc lvl record.succ newNode node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        insertAcc lvl record.succ newNode node
                    |LT when LT < 0->
                        match (lvl > 0) with
                        |false->
                            setNewNode predecessor newNode node
                            insertAcc lvl (downNode predecessor) (downNode newNode) Nil
                        |true->
                            insertAcc (lvl-1) (downNode predecessor) newNode Nil
                    |EQ -> ()
        let newLvl = x.chooseLevel rnd
        let newNodes = createTower (Key k) (newLvl+1)
        if (curLevel < newLvl) then 
            curLevel <- newLvl
        insertAcc (curLevel - newLvl) x.Start newNodes Nil
    member inline x.Lookup (k:'k) =
        let rec lookupAcc node predecessor=
            match node with
            |DownNil->None
            |Nil -> lookupAcc (downNode predecessor) Nil
            |Node record -> 
                match record.key with
                |Root -> 
                    lookupAcc record.succ node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        lookupAcc record.succ node
                    |LT when LT < 0->
                        lookupAcc (downNode predecessor) Nil
                    |EQ -> Some k
        lookupAcc x.Start Nil
    member inline x.Delete k = 
        let rec deleteAcc node predecessor = 
            match node with
            |DownNil-> ()
            |Nil -> deleteAcc (downNode predecessor) Nil
            |Node record ->
                match record.key with
                |Root -> 
                    deleteAcc record.succ node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        deleteAcc record.succ node
                    |LT when LT < 0->
                        deleteAcc (downNode predecessor) Nil
                    |EQ ->
                        setSucc predecessor record.succ
                        deleteAcc (downNode predecessor) Nil
        deleteAcc x.Start Nil

Die einzige interessante Detail ist die chooseLevel -Methode.

//Choosing a Random Level
member inline private x.chooseLevel (rndm:Random)= 
        let rs = Seq.initInfinite (fun _-> rndm.NextDouble())
        let samples = Seq.take (maxLevel - 1) rs
        Seq.length (Seq.takeWhile ((<) probability ) samples)

F# Suffix Tree. Update.

Die Funktion zur Erstellung eines Suffix-Dictionary ist angepasst.

//old version.
let suffixMap<'a when 'a : comparison> : ('a list list -> list<'a * 'a list list>) =
   let alter k v (m:Map<_,_>) : Map<_,_> =
       match Map.tryFind k m with
       | None -> Map.add k [v] m
       | Some x ->
           Map.add k (v::x) m
   let step m (l:'a list)=
       match l with
       |x::xs ->
           alter x xs m
       |_-> m
   List.map id<<Map.toList<<List.fold step Map.empty

//new version.
let suffixMap l =
   Seq.groupBy List.head l
   |>Seq.map (fun (x,ls)->
         x,
         Seq.map List.tail ls
         |>Seq.toList)
   |>Seq.toList)

Hier nochmals der aktualisierte Code.

F# Finger Tree und RegEx. Teil 3.

Teil 1.
Teil 2.

Zurück zum eigentlichen Problem. Hier übrigens Online RegEx to Finite State Machine Tool.

#load @"..\fingertree.fsx"

open FData.FingerTree

let inline flip f b a= f a b

//Finite State Machine for Regex ".*(.*007.*).*"
let inline fsm i c =
    match i, c with
    |0, '(' -> 1
    |0, _ -> 0
    |1, '0' -> 2
    |1, _ -> 1
    |2, '0' -> 3
    |2, _ -> 1
    |3, '7' -> 4
    |3, '0' -> 3
    |3, _ -> 1
    |4, ')' -> 5
    |4, _ -> 4
    |5, _ -> 5

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

//Table with tabulated function for each letter in our alphabet.
let letters =
    [|' '..'z'|]
    |>Array.map (fun i->i,tabulate (flip fsm i))
    |>Map.ofArray

type Table= int []

type Size =
    |Size of int

//product monoid.
type Monoid() =
        interface IMonoid<Size * Table> with
            member inline this.Zero = Size 0,tabulate id
            member inline this.Plus a b = 
                match a,b with
                |(Size a, ta), (Size b, tb) -> Size (a + b), tabulate (fun st -> tb.[ta.[st]] )


type Element =
    |Elem of char
    interface IMeasured<Size * Table> with
        member inline this.Value = 
            match this with
            |Elem a -> 
                 Size 1, Map.find a letters

type FingerString =FingerTree<Element,Size * Table, Monoid>

let inline matches007 (s:FingerString) = (snd (measured s)).[0]=5

let inline fromList s=(s,Empty)||> List.foldBack (push_front<<Elem)

let inline insert i c tree = 
    let (l,r) = split (fun (Size n,_) -> n>i) tree
    concat l (push_front (Elem c) r)

let inline replace i c tree = 
    update (fun (Size n,_) -> n>i) (Elem c) tree

let treeString : seq<char>->FingerString = fromList<<List.ofSeq

//Simulate an interactive loop
let loop l f tree=
    let res = List.fold (fun acc (i,c)->
        let result= f i c acc
        result) tree l
    printfn "with Loop. Result %A" (matches007 res) 
    res

//Tests
open System
open System.Text.RegularExpressions

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

//Regex for test.
let regex = new Regex (".*\(.*007.*\).*")

//String with 100 000 chars.
let str = String.Concat( Array.create 10000 " Match Me " )

//List of strings for test.
let listString=[str; str + "(007)"; "(007" + str + ")"; "(007)" + str]

//List of finger trees for test.
let listFingerString = List.map treeString listString

let runTest ()= 
    List.fold (fun acc str->
        test (fun ()->printfn "with Regex %A. Result %A " acc (regex.Match(str).Success))
        acc+1) 0 listString|>ignore
    List.fold (fun acc str->
        test (fun ()->printfn "with Finger Tree %A. Result %A " acc (matches007 str))
        acc+1) 0 listFingerString|>ignore

runTest ()

test (fun ()->loop [(3,'(');(4000,'u');(20005,'0');(20006,'0');(20007,'7');(20008,'r');(40009,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop  [(3,'(');(4,'0');(5,'0');(6,'7');(8,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop [(40004,'(');(40005,'0');(40006,'0');(40007,'7');(40008,'r');(40009,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop [(3,'(');(4000,'u');(20005,'0');(20006,'0');(20007,'7');(20008,'r');(40009,')');(40010,' ');(11,'I')] replace stringTree|>ignore)

F# Finger Tree und RegEx. Teil 2. Polymorphic Recursion.

Teil 1.
Die push_front-Funktion ist rekursiv und ruft sich selbst mit verschiedenen Typ-Parameter. In diesem Fall spricht man von "Polymorphic Recursion".

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> 

Wenn beim Funktionsparameter a der Typ-Parameter weggelassen wird, bekommen wir folgende Fehlermeldung.

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> a (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> 

Um besser zu sehen, mit welchem Parameter die Funktion aufgerufen wird, loggen wir die einzelne Funktionsaufrufe.

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> =
        printfn "Argument a = %A" a
...

let tree:RandomAccess<char> = List.foldBack (push_front<<Element) ['a'..'i'] Empty

Teil 3.

F# Finger Tree und RegEx. Teil 1.

Finger Tree ist eine Datenstruktur aus der Welt der funktionalen Programmierung. Die verständliche und ausführliche Erklärung findet man hier 1, 2.

Hier ist ein sehr interessantes Problem beschrieben, das mittels der Finger Tree-Datenstruktur elegant gelöst wird.

Kurz gefasst: Sei einen regulären Ausdruck R gegeben, der auf einen String S der Länge N angewendet wird und angenommen der String S wird durch Einfügen, Ersetzen oder Löschen einzelner Zeichen geändert. Wie schnell kann die geänderte Zeichenfolge mit dem Ausdruck R erneut verglichen werden. Erstmal scheint es, dass die gesamte Zeichenfolge neu überprüft werden soll. Der Artikel jedoch zeigt, dass man nur O (log n) Zeit für die Neuberechnung benötigt.

Zuerst aber F# Finger Tree Version.
Grundlegende Ansätze zur F#-Implementierung habe ich bei diesen Postings - 1 und 2 - abgeschaut. Für weitere Funktionalitäten - split, concat und find Funktionen - ist die Haskell-Version herangezogen worden.

//Types
type IMeasured<'V>  =
    abstract inline Value : 'V

let inline measured (v : #IMeasured<_>) = v.Value

type IMonoid<'V> =
    abstract inline Zero : 'V
    abstract inline Plus : 'V -> 'V -> 'V

type Singleton<'T when 'T : (new : unit -> 'T)> private () =
    static let instance = new 'T()
    static member Instance = instance


type Node<'T,'V when 'T :> IMeasured<'V>> = 
    | Node2 of 'V * 'T * 'T
    | Node3 of 'V * 'T * 'T * 'T
    interface IMeasured<'V> with
        member x.Value =
            match x with
            |Node2 (v,_,_) ->v
            |Node3 (v,_,_,_) ->v

type Digit<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> =
    |One of 'T
    |Two of 'T * 'T
    |Three of 'T * 'T * 'T
    |Four of 'T * 'T * 'T * 'T
    interface IMeasured<'V> with
        member x.Value = 
            let monoid = Singleton<'M>.Instance
            match x with
            |One x-> measured x
            |Two(a,b)->  monoid.Plus (measured a) (measured b)
            |Three(a,b,c)->  monoid.Plus ((measured a, measured b)||>monoid.Plus) (measured c)
            |Four(a,b,c,d)->  monoid.Plus ((measured a, measured b)||>monoid.Plus) ((measured c,measured d)||>monoid.Plus)

type FingerTree<'T, 'V, 'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> = 
    | Empty
    | Single of 'T
    | Deep of 'V * Digit<'T,'V,'M> * FingerTree<Node<'T,'V>,'V,'M> * Digit<'T,'V,'M>
    interface IMeasured<'V> with
        member x.Value =
            let monoid = Singleton<'M>.Instance
            match x with
            | Empty -> monoid.Zero
            | Single s -> measured s
            | Deep (v,_,_,_)->v

//Tree Construction.
let inline node2<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (b:'T)= 
    let monoid = Singleton<'M>.Instance
    Node2 (monoid.Plus (measured a) (measured b),a,b)

let inline node3<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (b:'T) (c:'T)=
    let monoid = Singleton<'M>.Instance
    Node3 (monoid.Plus ((measured a, measured b)||>monoid.Plus) (measured c),a,b,c)

let inline consDigit a dig=
    match dig with
    |One b->Two(a,b)
    |Two(b,c)->Three(a,b,c)
    |Three(b,c,d)-> Four(a,b,c,d)
    |_->raise FTreeException

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> =
        match t with 
        |Empty-> Single a
        |Single b->deep (One a) Empty (One b)
        |Deep (v, left, mid, right)->
            let monoid = Singleton<'M>.Instance
            match left with
            |Four(e,f,g,h) ->
                Deep(monoid.Plus (measured a) v,Two(a,e),push_front (node3<'T,'V,'M> f g h) mid,right)
            |_-> 
                Deep (monoid.Plus (measured a) v, consDigit a left, mid, right)

Der vollständige Quellcode - fingertree.fsx.
Wie wir sehen können ist die Baumstruktur mit einem Monoid parametrisiert. Dadurch kann eine und dieselbe Baumstruktur für verschiedene Zwecke verwendet werden. Wir können z.B. eine Random Access Datenstruktur definieren.

open FData.FingerTree

//Random Access
type Monoid() =
        interface IMonoid<int> with
            member this.Zero = 0
            member this.Plus a b = a + b

type Element<'T>  =
    |Element of 'T
    interface IMeasured<int> with
        member this.Value = 1

type RandomAccess<'T> = FingerTree<Element<'T>, int, Monoid>

//Index-Zugriff.
let nth index tree =
    match (find ((<) index) tree) with
    |Some value-> value
    |None-> failwith "invalid index" 

oder Max-Priority Queue

open FData.FingerTree

//Max-Priority Queue
type Monoid() =
        interface IMonoid<int> with
            member this.Zero = System.Int32.MinValue
            member this.Plus a b = max a b

type Element<'V> =
        { Prio : int
          Element : 'V }
          interface IMeasured<int> with
            member this.Value = this.Prio

type Priority<'T> =FingerTree<Element<'T>,int,Monoid>

//Das Element mit der höchsten Priorität finden
let findPrio tree = 
    match tree with
    |Empty->failwith "tree is empty"
    |Single b->Some b
    |Deep (v, _,_,_)->
        find (fun x->x = v) tree

Teil 2.

Suffix Tree. longest repeated substring und longest common substring.

Suffix Tree. Hier ist die Haskell-Implementierung. Ich versuchte die Datenstruktur mit der Aufmerksamkeit auf den oben genannten Punkte in F# nachzubilden.

//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

Das Herzstück ist die Fold-Funktion, mit derer Hilfe beide Aufgaben relativ einfach gelöst werden können.

// fold : (a -> a)                -- ^ downwards state transformer
//     -> (a -> a)                -- ^ upwards state transformer
//     -> (Prefix b -> a -> a -> a) -- ^ edge state transformer
//     -> (a -> a)                -- ^ leaf state transformer
//     -> a                       -- ^ initial state
//     -> STree b                 -- ^ tree
//     -> a
// Folds the edges in a tree
let fold fdown fup fprefix fleaf  =
let rec go v t =
    match t with
    |Leaf->fleaf v
    |Node es-> fup (List.foldBack edge es v)
and edge (p, subtree) v = fprefix p (go (fdown v) subtree) v
go

longest repeated substring(lrs).
Man bestimme die längste Teilzeichenkette, die an mindestens zwei verschiedenen Positionen auftritt. Man konstruiert einen Suffix-Baum. Dann muss man nur den internen Knoten finden, der die längste Zeichenkette repräsentiert.

let lrs tree=
fold (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
     tree
 |>snd
 |>List.concat

longest common substring(lcs).
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.

Mit dem Code bin ich nicht so ganz glücklich, aber habe leider keine bessere Idee.

let lcs s1 s2 =
let endFst = '#'
let endSnd = '$'
let tree = construct ((s1|>List.ofSeq)@[endFst]@(s2|>List.ofSeq)@[endSnd])
let folderPrefixes (fstFounded,sndFounded) subtree=
    let counter = List.fold (fun acc item->
            match ( item = endFst),( item =endSnd) with
            |true,_-> acc+1
            |_,true-> acc+1
            |_->acc) 0 subtree
    match fstFounded,sndFounded with
    |true,true->fstFounded,sndFounded
    |_->
        match counter with
        |1->true,sndFounded
        |2->fstFounded,true
        |_->fstFounded,sndFounded
let fprefix p (downl,downt,downFounded) (accl,acct,accFounded) =
        let found =
            match downl with
                |[]->(prefix p)::accl,acct,true
                |_->
                    let comb=List.map (fun x->(prefix p)@x) downl
                    comb@accl,acct,true
        match p with
        |Prefix(t,Exactly _)->
            match downFounded with
            |true-> found
            |false->
                match (List.fold folderPrefixes (false,false) downt) with
                |true,true -> found
                |_ -> accl,t::acct,accFounded
        |Prefix(t,_)->accl,t::acct,accFounded
let (l,_,_)=
    fold (fun _ ->(List.empty,List.empty,false))    //fdown
         id                                         //fup
         fprefix
         id                                         //fleaf
         (List.empty,List.empty,false)              //accumulator
         tree                                       //Suffix tree
match l with
|[]->List.empty
|_->l|>List.reduce
        (fun x r->
            match (List.length x)>(List.length r) with
            |true->x
            |false->r
        )

Der vollständige Code ist hier.

Update 1

Update 2
Update 3