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