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# 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".