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.