F# Sudoku Solver. Exact Cover In Solving Sudokus.

Ich möchte endlich begreifen, wie die Sudoku - Lösungstechnik  funktioniert und fand einen Artikel über das Exact Cover Problem in Zusammenhang mit Sudoku, eine Sudoku Solver Version in F# und eine Haskell-Version.

//Program.fs
open FData.ExactCover
open System
//In the standard 9×9 Sudoku variant, there are four kinds of constraints
type Constraint = 
    | Row of int * int  //Row-Number: Each row must contain each number exactly once.
    | Col of int * int  //Column-Number: Each column must contain each number exactly once.
    | Box of int * int  //Box-Number: Each box must contain each number exactly once.
    | Pos of int * int  //Row-Column: Each intersection of a row and column, i.e, each cell, must contain exactly one number.
    | Given of int      

type Move
    = { mRow : int; mCol : int; mVal : int }

let inline box r c = ((r-1) / 3) * 3 + ((c-1) / 3) + 1

//Since there are 9 rows, 9 columns, 9 boxes and 9 numbers, there are 9×9=81 row-column constraint sets, 
//9×9=81 row-number constraint sets, 9×9=81 column-number constraint sets,
// and 9×9=81 box-number constraint sets: 81+81+81+81=324 constraint sets in all.
let inline constraintsFor rest m =
    (m, Pos(m.mRow, m.mCol)) :: (m, Row(m.mRow, m.mVal)) :: 
    (m, Col(m.mCol, m.mVal)) :: (m, Box(box m.mRow m.mCol, m.mVal)) :: rest

let inline constraints givenMarks =
    //In the standard 9×9 Sudoku variant, in which each of 9×9 cells is assigned one of 9 numbers,
    // there are 9×9×9=729 possibilities.
    let l = 
        seq {for r in 1..9 do
             for c in 1..9 do
             for v in 1..9 do
             yield { mRow = r; mCol = c; mVal = v }}
    let input = 
        Seq.append
            (Seq.mapi (fun i (r,c,v) ->
                { mRow = r; mCol = c; mVal = v }, Given (i + 1)) givenMarks)
            (Seq.fold constraintsFor [] l)
    addCover input

let inline zipCoords s =
    let coords  = 
        seq {for r in 1..9 do
             for c in 1..9 do
             yield (r,c)}
    Seq.zip coords s

let inline board input = 
    seq{for (r,c),v in zipCoords input do if v>0 then yield (r,c,v)}

let inline problem s= 
    List.concat s
    |>board
    |>constraints

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
    //printfn "Result : %A" res

//simple Sudoku
let s2 =
    [[0; 0; 8;  3; 0; 0;  6; 0; 0]
     [0; 0; 4;  0; 0; 0;  0; 1; 0]
     [6; 7; 0;  0; 8; 0;  0; 0; 0]
     [0; 1; 6;  4; 3; 0;  0; 0; 0]
     [0; 0; 0;  7; 9; 0;  0; 2; 0]
     [0; 9; 0;  0; 0; 0;  4; 0; 1]
     [0; 0; 0;  9; 1; 0;  0; 0; 5]
     [0; 0; 3;  0; 5; 0;  0; 0; 2]
     [0; 5; 0;  0; 0; 0;  0; 7; 4]]
//middle
let s3 =
    [[1;0;0;0;0;7;0;9;0];
     [0;3;0;0;2;0;0;0;8];
     [0;0;9;6;0;0;5;0;0];
     [0;0;5;3;0;0;9;0;0];
     [0;1;0;0;8;0;0;0;2];
     [6;0;0;0;0;4;0;0;0];
     [3;0;0;0;0;0;0;1;0];
     [0;4;0;0;0;0;0;0;7];
     [0;0;7;0;0;0;3;0;0]]
//hard
let s4 = 
    [[0;0;0;  0;0;0;  0;0;8];
     [0;0;3;  0;0;0;  4;0;0];
     [0;9;0;  0;2;0;  0;6;0];
     [0;0;0;  0;7;9;  0;0;0];
     [0;0;0;  0;6;1;  2;0;0];
     [0;6;0;  5;0;2;  0;7;0];
     [0;0;8;  0;0;0;  5;0;0];
     [0;1;0;  0;0;0;  0;2;0];
     [4;0;5;  0;0;0;  0;0;3]]
test (fun()-> problem s2|>solveExactCover)
test (fun()-> problem s3|>solveExactCover)
test (fun()-> problem s4|>solveExactCover)

//ExactCover.fs
namespace FData
open System

[<RequireQualifiedAccess>]
module PrioSeq =
  type PSQ<'k, 'p> =
      | Void
      | Winner of 'k * 'p * LTree<'k, 'p> * 'k
  and LTree<'k, 'p> =
      | Start
      | LLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
      | RLoser of 'k * 'p * (LTree<'k, 'p>) * 'k * LTree<'k, 'p>
  
  let inline play t1 t2 =
      match t1, t2 with
      | Void, t -> t
      | t, Void -> t
      | Winner (k, p, t, m), Winner (k', p', t', m') -> 
          match p <= p' with
          | true     -> Winner(k, p, RLoser(k', p', t, m, t'), m')
          | false    -> Winner(k', p', LLoser(k, p, t, m, t'), m')

  type TourView<'k, 'p> =  
      | Null
      | Single of 'k * 'p 
      | Play of PSQ<'k, 'p> * PSQ<'k, 'p>

  let inline tourView psq = 
      match psq with
      | Void -> Null
      | Winner(k, p, Start, _) -> Single(k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') -> Play(Winner(k, p, tl, m), Winner(k', p', tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') -> Play(Winner(k', p', tl, m), Winner(k, p, tr, m'))

  let empty =  Void
  
  let inline single (k, p) =  Winner(k, p, Start, k)
  
  let inline key (k,_) = k

  let inline prio (_, p) = p

  let inline maxKey (Winner (_, _, _, m)) =  m

  let rec insert b q =
      match tourView q with
      | Null                                  -> single b
      | Single(k,p) when key b < k            -> play (single b) (single(k, p))
      | Single(k,p) when key b = k            -> single b
      | Single(k,p)                           -> play (single(k, p)) (single b)
      | Play(tl, tr) when key b <= maxKey tl  -> play (insert b tl) tr
      | Play(tl, tr)                          -> play tl (insert b tr)

  let inline foldm f e x =
      let rec inner n xs =
          match n, xs with
          | 1, y::ys -> (y, ys)
          | n, ys    -> 
              let m = n / 2
              let (y1, ys1) = inner (n-m) ys
              let (y2, ys2) = inner m ys1
              f y1 y2, ys2
      match x with
      | [] -> e
      | _  -> fst (inner (List.length x) x)
  
  let inline fromOrdList l =
      foldm play empty l

  let rec toOrdLists q=
      match tourView q with
      | Null          -> List.empty
      | Single(k, p)  -> [single (k, p)]
      | Play(tl, tr)  -> (toOrdLists tl) @ (toOrdLists tr)

  let inline rebalance<'k,'p when 'p : comparison> : (PSQ<'k, 'p> ->PSQ<'k, 'p>)= fromOrdList<<toordlists 
  
  let lookup k p =
      match tourView q with
      | Null                             -> None
      | Single(k', p) when k = k'        -> Some p
      | Single(k', p)                    -> None
      | Play(tl, tr) when k <= maxKey tl -> lookup k tl
      | Play(tl, tr)                     -> lookup k tr

  let rec delete k q =
      match tourView q with
      | Null                             -> empty
      | Single(k', p) when k = k'        -> empty
      | Single(k', p)                    -> single (k', p)
      | Play(tl, tr) when k <= maxKey tl -> play (delete k tl) tr
      | Play(tl, tr)                     -> play tl (delete k tr)

  type MinView<'k, 'p> =  
      | Empty 
      | Min of ('k * 'p)

  let inline minView q =
      match q with
      | Void               -> Empty
      | Winner(k, p, t, m) -> Min (k, p)

  let rec adjust f key q = 
      match q with
      | Void                                                       -> Void
      | Winner(k, p, Start, _) when key = k                        -> single (k, (f p))
      | Winner(k, p, Start, _)                                     -> single (k, p)
      | Winner(k, p, RLoser(k', p', tl, m, tr), m') when key <= m  -> 
          play (adjust f key (Winner(k, p, tl, m))) (Winner(k', p', tr, m'))
      | Winner(k, p, RLoser(k', p', tl, m, tr), m')                 ->
          play (Winner(k, p, tl, m)) (adjust f key (Winner(k', p', tr, m')))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m') when key <= m   ->
          play (adjust f key (Winner( k', p', tl, m))) (Winner(k, p, tr, m'))
      | Winner(k, p, LLoser(k', p', tl, m, tr), m')                 ->
          let w2 = Winner(k, p, tr, m')
          play (Winner(k', p', tl, m)) (adjust f key w2)


module ExactCover =
  open System.Collections.Generic
  open Microsoft.FSharp.Collections

  type ECValue<'r when 'r : comparison> = { ecvSize : int; ecvRows : Set<'r>  }

  type ExactCover<'r, 'c when 'r : comparison and 'c : comparison> =
      { ecCol : PrioSeq.PSQ<'c, ECValue<'r>>; ecRow : Map<'r, Set<'c>> }

  let inline emptyCover<'c, 'r when 'c : comparison and 'r : comparison> = 
      {ecCol = PrioSeq.empty; ecRow = Map.empty}

  let inline addCover rcs  =
      let createMap f g = 
          rcs
          |>Seq.groupBy f
          |>Seq.map (fun (x, ys) -> x, Seq.map g ys|>Set.ofSeq)
      let col = 
          createMap snd fst
          |>Seq.fold (fun acc (c, m) -> 
                        PrioSeq.insert (c, {ecvSize = Set.count m ; ecvRows = m}) acc
                        ) PrioSeq.empty
      let row = 
          createMap fst snd
          |>Map.ofSeq
      { ecCol = PrioSeq.rebalance col; ecRow = row }
  
  let inline flip f a b = f b a
  
  let rec solve soFar ec  =
      match PrioSeq.minView ec.ecCol with
      | PrioSeq.Empty -> soFar
      | PrioSeq.Min(_, rs) -> 
          let setDifference ys ecv =
              let zs = ecv.ecvRows - ys 
              { ecvSize = Set.count zs; ecvRows = zs }
          Seq.map (fun move ->
              //Get all constraints of current move
              let constraints = Map.find move ec.ecRow
              //Get all moves of selected constraints
              let moves = Set.unionMany (Seq.map (fun k -> 
                  match PrioSeq.lookup k ec.ecCol with
                  | Some ecv -> ecv.ecvRows
                  | None -> failwith ("Nothing" + k.ToString())) constraints)
              //all posible constraints for selected moves
              let posibleConstraints = Seq.concat (Seq.map (flip Map.find ec.ecRow) moves)

              let newCol = 
                  //delete all constraints of current move
                  let acc = Seq.fold (flip PrioSeq.delete) ec.ecCol constraints
                  //update posible constraints for selected moves
                  Seq.fold (flip (PrioSeq.adjust (setDifference moves))) acc posibleConstraints

              let newRow = Seq.fold (flip Map.remove) ec.ecRow moves

              solve (Set.add move soFar) {ecCol = newCol; ecRow = newRow}) rs.ecvRows
          |>Set.unionMany
  
  let inline solveExactCover ec = solve Set.empty ec|>Set.toList

Test Start.
Time Duration : 342L
Test Start.
Time Duration : 545L
Test Start.
Time Duration : 3713L

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