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.