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.
module SpellChecker
open System.IO
module BKTreeType =
open System.Runtime.Serialization.Formatters.Binary
type BKTree<'a> =
| Node of 'a * Map<int, BKTree<'a>>
| Empty
module Utils =
open System.Threading.Tasks
open System.Collections.Generic
open BKTreeType
let empty = Empty
let inline singleton a = Node (a, Map.empty)
let inline node a map = Node (a, map)
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
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
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
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
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
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
let inline fromListTask distance =
let mkDist word other =
(distance word other, other)
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
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.fromIspellFileTask = x.fromListTask<<read
member x.Insert = insert distance
member x.elemsDistance = elemsDistance distance
member x.elemsDistanceTask = elemsDistanceTask distance
member x.isMember = isMember distance
member x.memberDistance = memberDistance distance
member x.fromList = fromList distance
member x.fromListTask = fromListTask distance
member x.Check n word tree =
if x.isMember word tree then
[]
else
x.elemsDistance n word tree
member x.CheckTask n word tree =
if x.isMember word tree then
[]
else
x.elemsDistanceTask n word tree
Keine Kommentare:
Kommentar veröffentlichen