F# Subset Construction Algorithm. Converting NFA to DFA.

In Zusammenhang mit dem alten Regex-Posting habe ich überlegt, wenn einen regulären Ausdruck zu einer DFA Übergangstabelle konvertiert werden kann, dann können wir einen solchen Ausdruck auf eine unendliche Eingabefolge anzuwenden ohne überhaupt die Gesamt- oder Teilfolge zu speichern. Wir brauchen nur die aktuelle Werte von der Übergangstabelle zu wissen um festzustellen, ob ein Regex die gesamte Eingabe "matcht".

Dazu muss erst ein Regex in einen DFA umgewandelt werden. Der Algorithmus ist hier in Details beschrieben und es gibt bereits eine F#-Implementierung zur Kompilierung eines regulären Ausdrucks in einen nicht-deterministischen endlichen Automaten (NFA). Was fehlt, ist der Übergang zum DFA und darum geht es hier.

Subset Construction Algorithm (aka Powerset Construction)


Ich hoffe ich verletze keine Copyright-Bestimmungen, wenn ich oben genannte Implementierung nutze ( hier kann man das Projekt herunterladen). 

Wie bei mir schon üblich ist, diente der Haskell-Code als Vorbild.

// Required RegExProcessor from  
// http://stevehorsfield.wordpress.com/2009/08/05/download-the-regular-expression-processor/
open RegExCompiling
open RegExParsing.RegExProcessor

  type Node = int
  //Transition: fromNode * toNode * Label 
  type Transition = Transition of Node * Node * NdfaEdge
  type ConvertContext = { nfa : RegExCompiling.NdfaGraph;
                          trans :  Transition list;   //DFA Transition list.
                          //mapping NFA sets of nodes  to a single node in the DFA.
                          setMap : Map<Set<Node>, int>;
                          setStack : Set<Node> list;
                          finalNfa : Set<Node>;  // set of NFA final states
                          accept : Set<Node>;   //  DFA accept states
                          nextNode : Node;
                          start : Node
                          alphabet : char list}
  // Search the table of transitions to find all nodes you can reach given an initial set of nodes.
  // Auto - epsilon transition.
  let inline findToNodes startNode trans value fromNodes = 
      let matchNodes  (from, _to, edge) nodes =
          match from with 
          | from' when (from' = fromNodes) ->
              match edge, value with
              | AnyChar, Simple _ -> Set.add _to nodes
              | Auto,    Auto     -> Set.add _to nodes
              | CharacterTest criteria, Simple c when (testCharacter criteria c)     -> 
                  Set.add _to nodes  
              | CharacterTest criteria, Simple c when not (testCharacter criteria c) -> 
                  Set.add startNode nodes 
              | Simple v, Simple c when  v = c  -> Set.add _to nodes 
              | Simple v, Simple c when  v <> c -> Set.add startNode nodes 
              | other -> nodes
          | other -> nodes
      List.foldBack matchNodes trans Set.empty  
  
  // Check if we already added this transition if not add it
  let inline checkTransition ts context = 
    match List.exists (fun x -> x = ts) context.trans with
    | true  -> context
    | false -> {context with trans = ts :: context.trans }

  // Check if a given node set contains a accept state
  // if so add it to the dfa accept states
  let inline updateAcceptStates nfaAccepts dfaAccepts nSet nSetIndex = 
    match Set.intersect nSet nfaAccepts |> Set.isEmpty with
    | true  -> dfaAccepts
    | false -> Set.add nSetIndex dfaAccepts
          
  let inline addNodeSet nSet context = 
    let newNodesStack   = context.setStack @ [nSet]
    let newNode         = context.nextNode
    let newNodesMap     = Map.add nSet newNode context.setMap
    let newAccepts      = updateAcceptStates context.finalNfa context.accept nSet newNode
    
    newNode, {context with setMap = newNodesMap; 
                           nextNode = newNode + 1; 
                           setStack = newNodesStack; 
                           accept = newAccepts}

  // Checks a NodeSet to see if it has a node number value
  // If it doesnt we assign it one and add it to the nodeSet stack
  let inline checkNodeSet nSet context = 
    match Map.containsKey nSet context.setMap with
    | true  -> context.setMap.[nSet], context
    | false -> addNodeSet nSet context   
  
  // Given a node and a set of nodes, union orginal set with the set of nodes you can 
  // traverse to from node on the value
  let inline closure startNode trans value oldSet nodes = 
      Set.union (findToNodes startNode trans value nodes) oldSet
  
  // Given an initial set of nodes, find the set of all nodes you can reach by taking 
  // transitions on epsilon only
  let inline epsilonClosure start trans = 
      let generator = Set.fold (closure start trans Auto) Set.empty
      Set.unionMany 
      << Seq.unfold (fun state -> 
              match Set.isEmpty state with
              | true  -> None
              | false -> Some(state, generator state)) 
  //Move takes a set of nodes and input character and returns all nodes you can reach by taking transitions on given input character. 
  let inline moveClosure start trans character =
      epsilonClosure start trans << Set.fold (closure start trans character) Set.empty
  

  let inline buildTransition oldTrans context value= 
      let nodes = List.head context.setStack
      let newSet = moveClosure context.start oldTrans value nodes
      match Set.isEmpty newSet with
      | false ->
          let fromNode, c1 = checkNodeSet nodes context
          let toNode, c2 = checkNodeSet newSet c1
          checkTransition (Transition (fromNode, toNode, value)) c2
      | true -> context
        
  let inline runConversion machine nodes finalNfa letters =
      let context = { nfa = machine;
                      trans = [];
                      setMap = Map.empty;
                      setStack = [];
                      finalNfa = finalNfa;
                      accept = Set.empty;
                      nextNode = 0;
                      start = 0;
                      alphabet = letters}
      let popSetStack context   = {context with setStack = List.tail context.setStack}
      let trans                 = Graph.toTable context.nfa
      let edges                 = context.alphabet |> List.map Simple
      let startSet              = epsilonClosure context.start trans nodes

      checkNodeSet startSet context
      |> snd
      |> Seq.unfold (fun ctx -> 
          match List.isEmpty ctx.setStack with
          | true  -> None
          | false -> 
              let newCtx = List.fold (buildTransition trans) ctx edges |> popSetStack
              Some(newCtx, newCtx))
      |> Seq.tryFind (fun ctx -> List.isEmpty ctx.setStack)
  
  let inline convert letters nfa =
    let fstLetter = List.head letters
    let final = 
      getClosureMap nfa
      |>Array.mapi (fun node isFinal -> 
          match isFinal with
          | true  -> Some(node)
          | false -> None)
      |>Array.choose id 
      |>Set.ofArray 

    let initialStates = 
      getStartStates nfa

    let startNodes = (List.map (fun (i,_,_,_,_) -> i) initialStates)
    
    let context = 
        match runConversion nfa (startNodes |> Set.ofList) final letters with
        | Some v -> v
        | None   -> failwith "Conversion is not possible."
    context 

open RegExParsing
> let test () =
    let regex = "aa|bb"
    let letters =['a'..'c']
    let context = 
        "aa|bb" |> RegExParsing.parseRegExp |> RegExCompiling.compile FullMatch
        |> convert letters 
    printfn "Context: %A" context;;

> test();;
Context: {nfa =
    ((7, 6),
    [((6, (Closure, null)), []); ((5, (Normal, null)), [(4, 1, 4, Simple 'b')]);
     ((4, (Normal, null)), [(5, 0, 6, Simple 'b')]); ((3, (Closure, null)), []);
     ((2, (Normal, null)), [(1, 0, 1, Simple 'a')]);
     ((1, (Normal, null)), [(2, 0, 3, Simple 'a')]);
     ((0, (Start, null)), [(3, 1, 5, Auto); (0, 0, 2, Auto)])]);
trans =
    [Transition (4,0,Simple 'c'); Transition (4,4,Simple 'b');
     Transition (4,1,Simple 'a'); Transition (3,0,Simple 'c');
     Transition (3,2,Simple 'b'); Transition (3,3,Simple 'a');
     Transition (2,0,Simple 'c'); Transition (2,4,Simple 'b');
     Transition (2,1,Simple 'a'); Transition (1,0,Simple 'c');
     Transition (1,2,Simple 'b'); Transition (1,3,Simple 'a');
     Transition (0,0,Simple 'c'); Transition (0,2,Simple 'b');
     Transition (0,1,Simple 'a')];
setMap =
  map
    [(set [0; 1; 2; 3; 5], 3); (set [0; 1; 2; 5], 1); (set [0; 2; 4; 5], 2);
     (set [0; 2; 4; 5; 6], 4); (set [0; 2; 5], 0)];
setStack = [];
finalNfa = set [3; 6];
accept = set [3; 4];
nextNode = 5;
start = 0;
alphabet = ['a'; 'b'; 'c'];}
val it : unit = ()

Fortsetzung folgt.

Wpf INotifyPropertyChanged mit F# Quotations.

Man implementiert die INotifyPropertyChanged-Schnittstelle um die Änderungen an einer Eigenschaft den Clients mitzuteilen. Standardmäßig verwendet man den Namen der Eigenschaft als einer String-Konstante, die an das PropertyChanged-Erreignis übergeben wird. Ungefähr so.

//standard version. pass property name as a string to the PropertyChanged event.
open System.ComponentModel
type ViewModelBase() =
    let propertyChangedEvent = new Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member x.PropertyChanged = propertyChangedEvent.Publish
    member x.RaisePropertyChangedEvent (propertyName) = 
        if not(propertyName = null) then
            propertyChangedEvent.Trigger(x, new PropertyChangedEventArgs(propertyName))

type ResultViewModel (d:DateTime, name) =
    inherit ViewModelBase ()
    let mutable birthday = d
    let mutable name = name

    new () = new ResultViewModel(DateTime.Today, "")      

    member r.Birthday with get() = birthday
                       and set newValue =
                            birthday <- newValue
                            base.RaisePropertyChangedEvent("Birthday")

    member r.Name with get() = name
                       and set newValue =
                            name <- newValue
                            base.RaisePropertyChangedEvent("Name")

Alternativ kann man F#-Quotations an den RaisePropertyChangedEvent-Aufruf übergeben. Der Vorteil ist das wir  weg von den String-Konstanten sind, bei denen man schnell vertippen kann und der Compiler zur Kompilierzeit dies nicht merkt.

//version with F#-quotations
open System.ComponentModel
open Microsoft.FSharp.Quotations
open Microsoft.FSharp.Quotations.Patterns

type ViewModelBase() =
    let propertyChangedEvent = new Event<PropertyChangedEventHandler, PropertyChangedEventArgs>()
    interface INotifyPropertyChanged with
        [<CLIEvent>]
        member x.PropertyChanged = propertyChangedEvent.Publish
    member x.RaisePropertyChangedEvent (expr: Expr) = 
        match expr with
        | PropertyGet(_, methodInfo, _) ->
            let propertyName = methodInfo.Name
            propertyChangedEvent.Trigger(x, new PropertyChangedEventArgs(propertyName))
        | other -> failwith "not implemented" 

type ResultViewModel (d:DateTime, name) =
    inherit ViewModelBase ()
    let mutable birthday = d
    let mutable name = name

    new () = new ResultViewModel(DateTime.Today, "")      

    member r.Birthday with get() = birthday
                       and set newValue =
                            birthday <- newValue
                            base.RaisePropertyChangedEvent(<@r.Birthday@>)

    member r.Name with get() = name
                       and set newValue =
                            name <- newValue
                            base.RaisePropertyChangedEvent(<@r.Name@>)

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

F# Monad Transformers Library.

FML.

F# Spell Checker mit BK-Tree. Teil 2. Parallel Tasks.

Teil 1.
Hier ist die F# Implementierung einer anderen Distanz-Funktion - Damerau-Levenshtein Distanz.

Ich glaube einen F#-Bug entdeckt zu haben. Auf jedem Fall wenn ich die levenshteinDistance-Funktion aus dem letzten Posting ändere, dauert die Erstellung von Spell Corrector statt eine halbe Minute nur noch ca. 11-13 Sekunden, sodass man auf das Serialisieren vom BK-Baum verzichten kann.

let levenshteinDistance s1 s2 =
    let sa,sb : char [] * char [] = Array.ofSeq s1, Array.ofSeq s2
    let n = Array.length sa
    let transform (narr : int []) c =
        let zip3wrapper xs =
            let m = (min n (Array.length xs)) - 1
            Array.zip3 sa.[..m] narr.[..m] xs.[..m]
        let compute z (c', x, y) =
            // List.min oder die Listenerstellung ist viel zu langsam.
            // List.min [y+1; z+1; x + abs (compare c' c)]
            min (y + 1) (z + 1)|> min (x + abs (compare c' c))
        Array.scan compute (narr.[0] + 1) (zip3wrapper narr.[1..])
    let res = Array.fold transform [|0..n|] sb
    res.[res.Length - 1] 

Der Code kann noch schneller werden, wenn wir ihm parallelisieren. Dazu brauchen wir die neue .Net 4 Tasks-Bibliothek.

module Utils =
    open System.Threading.Tasks
    ...
      // returns all the elements in tree which are 
      // at a distance less than or equal to n from the element a.
      let inline elemsDistance distance =
        let rec inner n word tree =
            match tree with
            | Empty          -> []
            | Node (other, imap) ->
                let d = distance word other
                let folder acc key v =
                    if (key > d - n - 1 && key < d + n + 1) then
                        (inner n word v) :: acc
                    else
                        acc
                if d <= n then
                    other :: (Map.fold folder [] imap|>List.concat )
                else
                   Map.fold folder [] imap|>List.concat
        inner
    //Parallel Tasks version.
    let inline elemsDistanceTask distance =
        let rec inner n word other map =
                let d = distance word other
                let folder acc key v =
                    if (key > d - n - 1 && key < d + n + 1) then
                        match v with
                        | Node (b, imap) -> (inner n word b imap) :: acc
                    else
                        acc
                if d <= n then
                    other :: (Map.fold folder [] map|>List.concat )
                else
                   Map.fold folder [] map|>List.concat
        let start n word tree =
            match tree with
            | Empty          -> []
            | Node (other, imap) -> 
                let tasks = Map.fold (fun acc key v->
                    match v with
                    | Node(_, map) -> Task.Factory.StartNew(fun () -> inner n word other map) :: acc) [] imap|>List.toArray
                let result = Task.Factory.ContinueWhenAll(tasks, (fun ts -> Array.map (fun (t : Task<string list>) -> t.Result) ts|>List.concat))
                result.Result
        start 
    //Constructs a tree from a list
    let inline fromList distance =
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | w :: ws -> 
                let mkDist other =
                    (distance w other, other)
                let recurse pairlist =
                    match pairlist with
                    | (key,_) :: _ ->(key, constructTree (List.map snd pairlist))
                //goupBy surrogate.
                let folder (acc, l) (key ,word) =
                    if acc = key then
                        match l with
                        | x :: xs -> key, ((key, word) :: x) :: xs
                        | _ -> key, [[(key, word)]]
                    else
                        key, [(key, word)] :: l
                List.map mkDist ws
                |>List.sortBy fst
                |>List.fold folder (0, List.empty)|>snd
                |>List.map recurse
                |>Map.ofList
                |>node w
        constructTree 
    
    //Parallel Tasks version.
    let inline fromListTask distance =
        let mkDist word other =
                    (distance word other, other)
        //goupBy surrogate.
        let folder (acc, l) (key ,word) =
            if acc = key then
                match l with
                | x :: xs -> key, ((key, word) :: x) :: xs
                | _ -> key, [[(key,word)]]
            else
                key, [(key, word)] :: l
        let constructKeyValuePairs word ws =
            List.map (mkDist word) ws
            |>List.sortBy fst
            |>List.fold folder (0,List.empty)|>snd
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | w :: ws ->
                constructKeyValuePairs w ws 
                |>List.map recurse
                |>Map.ofList
                |>node w
        and recurse pairlist =
                match pairlist with
                | (key, _) :: _ ->(key, constructTree (List.map snd pairlist))
        let start xs =
            match xs with
            | [] -> Empty
            | w :: ws -> 
                let pairs  = constructKeyValuePairs w ws 
                let tasks  = List.map (fun pairlist -> Task.Factory.StartNew(fun () -> recurse pairlist)) pairs|>List.toArray
                let result = Task.Factory.ContinueWhenAll(tasks, (fun ts -> Array.fold (fun acc (t : Task<int * BKTree<_>>) -> t.Result :: acc) [] ts))
                Map.ofList result.Result
                |>node w
        start

Auf meinem Core 2 Quad Q6600 Desktop kommt es zu folgenden Ergebnissen.


Der komplette Code.

F# Spelling Checker mit BK-Tree und Levenshtein-Distanz. Teil 1.

Hier habe ich vor kurzem gelesen, wie leicht man auf Basis von einen Burkhard-Keller Baum einen Spelling Checker aufbauen kann.
Wie man aus dem Artikel erfährt, braucht man zuerst die Levenshtein Distanz oder irgendeine andere Distanz-Funktion. Hier gibt es Implementierungen in verschiedenen Programmierungssprachen. Ich habe mich an der Haskell-Variante orientiert.

let levenshteinDistance s1 s2 = 
    let sa, sb:char [] * char [] = Array.ofSeq s1, Array.ofSeq s2
    let n = Array.length sa
    let transform (narr:int []) c = 
        let zip3wrapper xs =
            let m = (min n (Array.length xs))-1
            Array.zip3 sa.[..m] narr.[..m] xs.[..m]
        let compute z (c', x, y) = List.min [y+1; z+1; x + abs (compare c' c)]
        Array.scan compute (narr.[0]+1) (zip3wrapper narr.[1..])
    let res = Array.fold transform [|0..n|] sb 
    res.[res.Length-1]

Ich weiß nicht, ob es ein Fehler von F# ist, aber wenn man Typenangaben in der Zeile

let sa, sb = Array.ofSeq s1, Array.ofSeq s2

weglässt, errechnet die compare-Funktion später den falschen Wert.

Als zweites braucht man eine Type-Definition von BK-Baum, was in F# dank den rekursiven Typen schnell gemacht ist.

type BKTree<'a> = 
        | Node of 'a *  Map<int, BKTree<'a>>
        | Empty

Schon wieder habe ich eine Haskell-Implementierung als Vorlage genommen.

module SpellChecker
open System.IO

module BKTreeType =
    open System.Runtime.Serialization.Formatters.Binary
    type BKTree<'a> = 
        | Node of 'a *  Map<int, BKTree<'a>>
        | Empty
    with
        member this.toFile(filename) =
            let bf = new BinaryFormatter()
            using (File.Open(filename, FileMode.Create))
                (fun treeFile -> bf.Serialize(treeFile, this))
        static member fromFile(filename) =
            let bf = new BinaryFormatter()
            using (File.Open(filename, FileMode.Open))
                (fun treeFile -> bf.Deserialize(treeFile) :?> BKTree<'a>)

module Utils =
    open System.Collections.Generic
    open BKTreeType
    
    let inline singleton a = Node (a, Map.empty)
    
    let inline node a map = Node (a, map)
    // Inserts an element into the tree.
    let inline insert distance =
        let rec inner a t=
            match t with
            | Empty        -> singleton a
            | Node (b,map) ->
                let d = distance a b
                match Map.tryFind d map with
                | None      -> Node (b, Map.add d (singleton a) map)
                | Some tree -> Node (b, Map.add d (inner a tree) map)
        inner
    // returns all the elements in tree which are 
    // at a distance less than or equal to n from the element a.
    let inline elemsDistance distance =
        let rec inner n a tree =
            match tree with
            | Empty          -> []
            | Node (b, imap) ->
                let d = distance a b
                let folder acc k v =
                    if (k > d-n-1 && k < d+n+1) then
                        (inner n a v)::acc
                    else
                        acc
                if d<=n then
                    b::(Map.fold folder [] imap|>List.concat )
                else
                   Map.fold folder [] imap|>List.concat
        inner
    // is element  in the tree.
    let inline isMember distance =
        let rec inner a tree = 
            match tree with
            | Empty         -> false
            | Node (b, map) ->
                match a = b with
                | true  -> true
                | false -> 
                    match Map.tryFind (distance a b) map with
                    | None      -> false
                    | Some tree -> inner a tree
        inner
    // return true if there is an element in tree
    // which has a distance less than or equal to n
    // from a.
    let inline memberDistance distance =
        let rec inner n a tree =
            match tree with
            | Empty         -> false
            | Node (b, map) ->
                match distance a b with
                | d when d <= n -> true
                | d             ->
                    let folder acc k v =
                        if (k > d-n-1 && k < d+n+1) then
                            v::acc
                        else
                            acc
                    Map.fold folder [] map
                    |>List.exists (inner n a)
        inner

    //Constructs a tree from a list
    let inline fromList distance =
        let rec constructTree xs =
            match xs with
            | [] -> Empty
            | x::xss -> 
                let mkDist m =
                    (distance x m, m)
                let recurse bs =
                    match bs with
                    | (k, _)::_ ->(k, constructTree (List.map snd bs))
                let folder (acc, t) (k, w) =
                    if acc = k then
                        match t with
                        | x::xs -> k,((k, w)::x)::xs
                        | _ -> k,[[(k, w)]]
                    else
                        k,[(k,w)]::t
                List.map mkDist xss
                |>List.sortBy fst
                |>List.fold folder (0, List.empty)|>snd
                |>List.map recurse
                |>Map.ofList
                |>node x
        constructTree 

    let inline reader file =
        seq {
          use reader = new StreamReader(File.OpenRead(file))
          while not reader.EndOfStream do
            yield reader.ReadLine()
        }

    let inline read dir =
        [for file in Directory.GetFiles(dir) do
              if Path.GetFileName(file.ToLower()) <> "readme" then
                for line in reader file ->
                  line.ToLower()
        ]
module Implementer =
    open Utils
    type SpellChecker(d:string->string->int)  =
      let distance = d
      member x.fromIspellFile   = x.fromList<<read
      member x.Insert           = insert distance
      member x.elemsDistance    = elemsDistance distance
      member x.isMember         = isMember distance
      member x.memberDistance   = memberDistance distance
      member x.fromList         = fromList distance 
      member x.Check n word tree  = 
          if x.isMember word tree then
              []
          else 
              x.elemsDistance n word tree

Das Wörterbuch für den Spelling Checker kann man von Ispell English Word Lists runterladen.
Jetzt können wir testen.

#load @"spell.fsx"
open SpellChecker.BKTreeType
open SpellChecker.Implementer

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

let dir = @"C:\ispell-enwl-3.1.20"

let spellBuilder =new SpellChecker(levenshteinDistance)
let tree = spellBuilder.fromIspellFile dir

Wie man sieht, dauert es ca. 20 sec. einen Spelling Cheker mit Daten zu füllen ( auf meinem alten Laptop sogar mehr als eine Minute). Dafür sind die einzelne Check-Abfragen relativ schnell.

Wir können die Daten nur ein einziges Mal laden, serialisieren und dann immer mit der serialisierten Datei arbeiten. Leider kann ich nicht die fromList-Methode dafür verwenden, da dabei ein F#-Fehler auftrat, und musste die langsame Insert-Methode nehmen.

 let testList =["watergate";"dance";"frippery";"disestablishment";"bit";"uncharacteristically";]

let treeFromList = spellBuilder.fromList testList
let treeInsert = List.fold (fun acc word ->spellBuilder.Insert word acc) Empty testList

open SpellChecker.Utils
let treeToSerialize = List.fold (fun acc word ->spellBuilder.Insert word acc) Empty (read dir)
treeToSerialize.toFile "spellDictionary"

Das Laden ist vierfach schneller geworden.

F# Boids (Swarm). Schwarm Simulation.

Update Part 2.

Boids stellen eine Simulation von Schwarmverhalten dar.
Als Grundlage diente mir der folgende Pseudocode. Einige Implementierungsdetails habe ich von hier übernommen.
Die Regeln sind schnell implementiert.

let inline sq x = x * x

type BoidVel = { velX:float; velY :float }

type BoidNeighbour = {relX:float; relY : float; Vel : BoidVel }

//three vector operators.
let inline (<+>) (a,b) (a',b') = a+a',b+b'

let inline (<->) (a,b) (a',b') = a-a',b-b'

let inline (</>) (a,b) c= a/c, b/c

//boids neighbours. 
let inline within neighbours distance = 
    List.filter (fun n -> (sq n.relX) + (sq n.relY) < (sq distance) ) neighbours

//Boids try to match velocity with near boids.
let inline meanVelocityAcc curVel neighbours =
    match neighbours with
    |[]->curVel.velX,curVel.velY
    |_->
        (List.average (List.map (fun n -> n.Vel.velX) neighbours)) - curVel.velX,
        (List.average (List.map (fun n -> n.Vel.velY) neighbours)) - curVel.velY

//An acceleration to stop us hitting nearby boids.
let inline repulsionAcc sight neighbours =
    within neighbours sight 
    |>List.map (fun n->negate n.relX, negate n.relY)
    |>List.fold (<+>) (0.0, 0.0) 

//An acceleration to keep us quite close to nearby boids. 
let inline keepCloseAcc neighbours = 
    match neighbours with
    |[]->0.0,0.0
    |_->
        List.average (List.map (fun n->n.relX) neighbours),
        List.average (List.map (fun n->n.relY) neighbours)

//Limit maximum speed.
let inline limit boidVel speedLimit =
    match boidVel with
    |vel when sq vel.velX + sq vel.velY > sq speedLimit ->
        let slowdown = (sq speedLimit) / (sq vel.velX + sq vel.velY)
        {velX = slowdown * vel.velX; velY = slowdown * vel.velY}
    |_ -> boidVel

//Bounding the position
let inline boundPosition (boundMin,boundMax) boid =
    let bound coor =
        match coor > boundMax, coor<boundMin with
        |true, _ -> -1.0
        |_, true -> 1.0
        |_ -> 0.0
    bound boid.relX, bound boid.relY

//apply rules for current boid.
let inline boidRules sight (cur,input)= 
    let neighbours = within input 2.0 * sight
    (meanVelocityAcc cur.Vel neighbours) </> 8.0
    <+> (repulsionAcc sight neighbours </> 4.0)
    <+> (keepCloseAcc neighbours </> 30.0)

Die Schwarm-Daten hält man üblicherweise (z.B wegen Effizienz) in einem Array, ich wollte aber in Rahmen der reinen funktionalen Programmierung bleiben und entscheide mich die Daten in einer Liste zu halten. Daraus ergab sich eine interessante Funktion zur Berechnung der neuen Position einzelner Schwarm-Elemente.

type Environment = 
    {sight: float;
     space float;
     speedLimit: float; 
     bound: float * float;
     target: BoidNeighbour -> float * float; //goal seeking function
     avoidObstacle: BoidNeighbour -> float * float //obstacle avoidance function
    }

let inline moveAll env input =
    input|> List.fold 
        (fun (pred,succ) _ -> 
            match succ with
            |x::xs->
                withEnv env (x, near env.space x (pred@xs))::pred, xs
            |[]->
                pred,[]) ([], input)
    |> fst

Wir gehen unsere Liste von Boids durch und erstellen eine neue Liste.

input|>List.fold ...

Als Akkumulator wird ein Tupel von Listen verwendet.

input|>List.fold (fun (pred,succ) _ -> ...) ([], input)

Wie man sieht, wird input noch mal als Anfangszustand an der Fold-Funktion übergeben. In der Funktion wird den neuen Wert des Elements berechnet. Dabei wird mit den relativen Positionen gearbeitet, für deren Berechnung eine Liste alle Boids außer aktuellen - pred@xs - gebraucht wird.

...near env.space x (pred@xs)
...
let inline near distance cur boids =
    let absDiff a b = abs (a - b)
    List.fold 
        (fun acc other -> 
            if (absDiff cur.relX other.relX <= distance) && (absDiff cur.relY other.relY <= distance) then
                {Vel=other.Vel;
                 relX = other.relX- cur.relX;
                 relY = other.relY- cur.relY}::acc
            else
                acc ) [] boids

In der pred-Teilliste stehen neu berechnete Werte aller Vorgänger eines aktuellen Elementes,

withEnv env (x, near env.space x (pred@xs))::pred

so dass diese am Ende des Folding-Prozesses alle neuen Werte enthält.

Zwei weitere Regeln können interaktiv vom Benutzer hinzugefügt werden: das Ausweichen von Hindernissen und eine Zielsuche.

//awoid obstacle.
let inline avoid sight radius obstacle boid =
    let diffAngle vel distance =
        let rec inner a f r=
            match (f a) with
            | true-> inner (r a) f r
            | false -> a
        let t = inner (vel - distance) (fun x-> x > Math.PI) (fun x-> x - 2.0*Math.PI)
        inner t (fun x-> x<(-Math.PI)) (fun x->x+ 2.0*Math.PI)
    let (dx,dy) = obstacle <-> (boid.relX, boid.relY)
    let distance = sqrt (sq dx+sq dy)
    match distance with 
    | d when d <= sight -> 
        (-dx*rnd.NextDouble(),-dy*rnd.NextDouble())
    | d when d < (2.0 *sight + radius) ->
        let velAngle=atan2 boid.Vel.velY boid.Vel.velX
        let distanceAngle = atan2 dy dx
        let diff = diffAngle velAngle distanceAngle
        let newVel sinOrCos m = ((distance - radius)*(sinOrCos (distanceAngle - m * Math.PI)) +
                                (radius + sight - distance * rnd.NextDouble()) * 
                                (sinOrCos (distanceAngle - Math.PI)))/sight
        match (abs diff) < Math.PI/2.0 with
        | true ->
            if diff>0.0 then
                (newVel cos 1.5, newVel sin 1.5)
            else
                (newVel cos 0.5, newVel sin 0.5)
        | false -> (0.0, 0.0)
    | d->
        (0.0, 0.0)

let inline tendToPlace bound place boid =
    (place <-> (boid.relX, boid.relY)) </> (bound * 1.5)

Alle Regeln zusammen.

let inline withEnv env (cur,input) =
    let (idealAccX, idealAccY) = 
        (boidRules env.sight (cur, input))
        <+> (env.target cur)  3.0
        <+> (env.avoidObstacle cur)
        <+> (boundPosition env.bound cur) 
    let newvel = limit {velX = cur.Vel.velX + (idealAccX/6.0);
                        velY = cur.Vel.velY + (idealAccY/6.0)} env.speedLimit
    {Vel = newvel; relX = cur.relX + newvel.velX; relY = cur.relY + newvel.velY}

Dank First Class Events in F# kann die Benutzerinteraktion ganz einfach, schnell und in funktionaler Manier realisiert werden.
Linke Maustaste - Hindernis auf das Formular platzieren.
Rechte Maustaste - Ziel für den Schwarm setzen.

type AnimationForm() as x =
    inherit Form()
    let img = createImage Brushes.Red

    do 
        x.SetStyle(ControlStyles.AllPaintingInWmPaint ||| ControlStyles.OptimizedDoubleBuffer, true)
        x.FormBorderStyle <- FormBorderStyle.FixedToolWindow
        x.StartPosition <- FormStartPosition.CenterScreen
        
        let tmr = new Timers.Timer(Interval = 20.0)
        tmr.Elapsed.Add(fun _ -> x.Invalidate() )
        tmr.Start()

    member x.guiRefresh (e:Graphics) envDrawing swarm =
        e.FillRectangle(Brushes.White, Rectangle(Point(0,0), x.ClientSize))
        let envCompose = compose envDrawing.drawingObstacle envDrawing.drawingTarget
        let drawing = swarm|>List.fold (fun acc n->compose acc (drawBoid img n) ) emptyDrawing
        envCompose.Draw(e)
        drawing.Draw(e)

let test =
    let boundMin,boundMax=0.0,650.0
    let radius =10.0
    //Start Enviroment.
    let envStart = {sight = 18.0; space = 250.0;
                    speedLimi t= 1.2;
                    bound = (boundMin,boundMax);
                    targe t= (fun _-> 0.0, 0.0);
                    avoidObstacle = (fun _-> 0.0, 0.0)}
    let envDrawingStart = {drawingTarget = emptyDrawing; drawingObstacle = emptyDrawing}
    let af = new AnimationForm(ClientSize = Size(int boundMax, int boundMax), Visible = true)
    let swarmInit = List.map (fun i ->makeboid i rnd) [0..150]
    //Start swarm after 500 steps.
    let swarmStart = List.fold (fun acc _->moveAll envStart acc) swarmInit [0..500]
    let evtMouseClick =
        af.MouseClick 
        |>Event.scan (fun (accEnv,accEnvDrawing) arg->
                 match (arg.Button) with
                 | MouseButtons.Left->
                     let f = avoid accEnv.sight radius (float arg.X,float arg.Y)
                     {accEnv with avoidObstacle = f}, {accEnvDrawing with drawingObstacle = 
                                                           circle Brushes.Black (float32 radius) (float32 arg.X, float32 arg.Y)}
                 | MouseButtons.Right->
                     let f = tendToPlace boundMax (float arg.X,float arg.Y)
                     {accEnv with target = f}, {accEnvDrawing with drawingTarget = 
                                                    circle Brushes.Red (float32 radius) (float32 arg.X,float32 arg.Y)}
                 | _-> 
                     accEnv, accEnvDrawing) 
            (envStart, envDrawingStart)

    let rec waiting (env:Environment) (envDrawing:EnvDrawing) swarm= async {
        let! evnt = Async.AwaitObservable (af.Paint, evtMouseClick)
        match evnt with
        | Choice1Of2(evntArg1)->
            let newSwarm = moveAll env swarm
            af.guiRefresh evntArg1.Graphics envDrawing newSwarm
            do! waiting env envDrawing newSwarm 
        | Choice2Of2(evntArg2) ->
            let newEnv,newEnvDrawing = evntArg2
            do! waiting newEnv newEnvDrawing swarm }
    waiting envStart envDrawingStart swarmStart|> Async.StartImmediate
#if COMPILED
  af

System.Windows.Forms.Application.Run(test)
#else
let main() =
    test |> ignore
[<STAThread>]
    do main()
#endif

Die Exe-Datei zum Ausprobieren und der komplette F#-Code.

F# Skip List.

Ausnahmsweise keine funktionale Datenstruktur. Mein bescheidener Versuch eine Skip List zu implementieren.

open System

type Key<'k> =
    |Key of 'k
    |Root

type NodeRecord<'k> = {key:Key<'k>; down:Node<'k>; mutable succ:Node<'k>}
and Node<'k> = 
    |Node of NodeRecord<'k>
    |Nil
    |DownNil

let inline createTower k maxLvl = 
    let rec createNode node lvl=
        match lvl with
        |l when l < maxLvl ->
            let r = {key= k;down = node; succ= Nil}
            createNode (Node r) (lvl+1)
        |_->node
    createNode DownNil 0

let inline downNode node=
    match node with
    |Node record-> record.down
    |_-> Nil


let inline setSucc succNode node=
    match succNode with
    |Node record-> record.succ<-node
    |_->()

let inline setNewNode predecessor newNode node=
    match predecessor,newNode with
    |Node predrecord, Node newrecord-> 
        newrecord.succ<-node
        predrecord.succ<-newNode
    |_->()

type SkipList<'k when 'k:comparison> (p:float, maxLvl:int) =
    let maxLevel = maxLvl
    let probability = p
    let mutable curLevel = 0
    let rnd =new Random()
    //skip list data
    let tskip = createTower Root maxLvl
    member x.Data 
     with get()  = tskip
    member x.MaxLevel 
     with get()  = maxLevel
    member x.Probability 
     with get()  = probability
    member private x.Start 
     with get()  = 
        let rec startNode node n = 
            match n with 
            |l when l > 0 -> startNode (downNode node) (n-1)
            |_-> node
        startNode tskip (maxLevel - (curLevel+1))
    member inline private x.chooseLevel (rndm:Random)= 
        let rs = Seq.initInfinite (fun _-> rndm.NextDouble())
        let samples = Seq.take (maxLevel - 1) rs
        Seq.length (Seq.takeWhile ((<) probability ) samples)
    member inline x.Insert (k:'k) = 
        let rec insertAcc lvl node newNode predecessor=
            match node with
            |DownNil->()
            |Nil -> 
                match (lvl > 0) with
                |false->
                    setSucc predecessor newNode
                    insertAcc lvl (downNode predecessor) (downNode newNode) Nil
                |true->
                    insertAcc (lvl-1) (downNode predecessor) newNode Nil
            |Node record -> 
                match record.key with
                |Root -> 
                    insertAcc lvl record.succ newNode node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        insertAcc lvl record.succ newNode node
                    |LT when LT < 0->
                        match (lvl > 0) with
                        |false->
                            setNewNode predecessor newNode node
                            insertAcc lvl (downNode predecessor) (downNode newNode) Nil
                        |true->
                            insertAcc (lvl-1) (downNode predecessor) newNode Nil
                    |EQ -> ()
        let newLvl = x.chooseLevel rnd
        let newNodes = createTower (Key k) (newLvl+1)
        if (curLevel < newLvl) then 
            curLevel <- newLvl
        insertAcc (curLevel - newLvl) x.Start newNodes Nil
    member inline x.Lookup (k:'k) =
        let rec lookupAcc node predecessor=
            match node with
            |DownNil->None
            |Nil -> lookupAcc (downNode predecessor) Nil
            |Node record -> 
                match record.key with
                |Root -> 
                    lookupAcc record.succ node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        lookupAcc record.succ node
                    |LT when LT < 0->
                        lookupAcc (downNode predecessor) Nil
                    |EQ -> Some k
        lookupAcc x.Start Nil
    member inline x.Delete k = 
        let rec deleteAcc node predecessor = 
            match node with
            |DownNil-> ()
            |Nil -> deleteAcc (downNode predecessor) Nil
            |Node record ->
                match record.key with
                |Root -> 
                    deleteAcc record.succ node
                |Key rkey->
                    match compare k rkey with
                    |GT when GT > 0 -> 
                        deleteAcc record.succ node
                    |LT when LT < 0->
                        deleteAcc (downNode predecessor) Nil
                    |EQ ->
                        setSucc predecessor record.succ
                        deleteAcc (downNode predecessor) Nil
        deleteAcc x.Start Nil

Die einzige interessante Detail ist die chooseLevel -Methode.

//Choosing a Random Level
member inline private x.chooseLevel (rndm:Random)= 
        let rs = Seq.initInfinite (fun _-> rndm.NextDouble())
        let samples = Seq.take (maxLevel - 1) rs
        Seq.length (Seq.takeWhile ((<) probability ) samples)