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

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