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

F# Suffix Tree. Update.

Die Funktion zur Erstellung eines Suffix-Dictionary ist angepasst.

//old version.
let suffixMap<'a when 'a : comparison> : ('a list list -> list<'a * 'a list list>) =
   let alter k v (m:Map<_,_>) : Map<_,_> =
       match Map.tryFind k m with
       | None -> Map.add k [v] m
       | Some x ->
           Map.add k (v::x) m
   let step m (l:'a list)=
       match l with
       |x::xs ->
           alter x xs m
       |_-> m
   List.map id<<Map.toList<<List.fold step Map.empty

//new version.
let suffixMap l =
   Seq.groupBy List.head l
   |>Seq.map (fun (x,ls)->
         x,
         Seq.map List.tail ls
         |>Seq.toList)
   |>Seq.toList)

Hier nochmals der aktualisierte Code.

Suffix Tree. longest repeated substring und longest common substring.

Suffix Tree. Hier ist die Haskell-Implementierung. Ich versuchte die Datenstruktur mit der Aufmerksamkeit auf den oben genannten Punkte in F# nachzubilden.

//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

Das Herzstück ist die Fold-Funktion, mit derer Hilfe beide Aufgaben relativ einfach gelöst werden können.

// fold : (a -> a)                -- ^ downwards state transformer
//     -> (a -> a)                -- ^ upwards state transformer
//     -> (Prefix b -> a -> a -> a) -- ^ edge state transformer
//     -> (a -> a)                -- ^ leaf state transformer
//     -> a                       -- ^ initial state
//     -> STree b                 -- ^ tree
//     -> a
// Folds the edges in a tree
let fold fdown fup fprefix fleaf  =
let rec go v t =
    match t with
    |Leaf->fleaf v
    |Node es-> fup (List.foldBack edge es v)
and edge (p, subtree) v = fprefix p (go (fdown v) subtree) v
go

longest repeated substring(lrs).
Man bestimme die längste Teilzeichenkette, die an mindestens zwei verschiedenen Positionen auftritt. Man konstruiert einen Suffix-Baum. Dann muss man nur den internen Knoten finden, der die längste Zeichenkette repräsentiert.

let lrs tree=
fold (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
     tree
 |>snd
 |>List.concat

longest common substring(lcs).
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.

Mit dem Code bin ich nicht so ganz glücklich, aber habe leider keine bessere Idee.

let lcs s1 s2 =
let endFst = '#'
let endSnd = '$'
let tree = construct ((s1|>List.ofSeq)@[endFst]@(s2|>List.ofSeq)@[endSnd])
let folderPrefixes (fstFounded,sndFounded) subtree=
    let counter = List.fold (fun acc item->
            match ( item = endFst),( item =endSnd) with
            |true,_-> acc+1
            |_,true-> acc+1
            |_->acc) 0 subtree
    match fstFounded,sndFounded with
    |true,true->fstFounded,sndFounded
    |_->
        match counter with
        |1->true,sndFounded
        |2->fstFounded,true
        |_->fstFounded,sndFounded
let fprefix p (downl,downt,downFounded) (accl,acct,accFounded) =
        let found =
            match downl with
                |[]->(prefix p)::accl,acct,true
                |_->
                    let comb=List.map (fun x->(prefix p)@x) downl
                    comb@accl,acct,true
        match p with
        |Prefix(t,Exactly _)->
            match downFounded with
            |true-> found
            |false->
                match (List.fold folderPrefixes (false,false) downt) with
                |true,true -> found
                |_ -> accl,t::acct,accFounded
        |Prefix(t,_)->accl,t::acct,accFounded
let (l,_,_)=
    fold (fun _ ->(List.empty,List.empty,false))    //fdown
         id                                         //fup
         fprefix
         id                                         //fleaf
         (List.empty,List.empty,false)              //accumulator
         tree                                       //Suffix tree
match l with
|[]->List.empty
|_->l|>List.reduce
        (fun x r->
            match (List.length x)>(List.length r) with
            |true->x
            |false->r
        )

Der vollständige Code ist hier.

Update 1

Update 2
Update 3