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
startAuf meinem Core 2 Quad Q6600 Desktop kommt es zu folgenden Ergebnissen.
Der komplette Code.
