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)

F# Suffix Tree. Update.

Die Funktion zur Erstellung eines Suffix-Dictionary ist angepasst.

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

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

Hier nochmals der aktualisierte Code.

F# Finger Tree und RegEx. Teil 3.

Teil 1.
Teil 2.

Zurück zum eigentlichen Problem. Hier übrigens Online RegEx to Finite State Machine Tool.

#load @"..\fingertree.fsx"

open FData.FingerTree

let inline flip f b a= f a b

//Finite State Machine for Regex ".*(.*007.*).*"
let inline fsm i c =
    match i, c with
    |0, '(' -> 1
    |0, _ -> 0
    |1, '0' -> 2
    |1, _ -> 1
    |2, '0' -> 3
    |2, _ -> 1
    |3, '7' -> 4
    |3, '0' -> 3
    |3, _ -> 1
    |4, ')' -> 5
    |4, _ -> 4
    |5, _ -> 5

let inline tabulate f = Array.init 6 (fun i-> f i)

//Table with tabulated function for each letter in our alphabet.
let letters =
    [|' '..'z'|]
    |>Array.map (fun i->i,tabulate (flip fsm i))
    |>Map.ofArray

type Table= int []

type Size =
    |Size of int

//product monoid.
type Monoid() =
        interface IMonoid<Size * Table> with
            member inline this.Zero = Size 0,tabulate id
            member inline this.Plus a b = 
                match a,b with
                |(Size a, ta), (Size b, tb) -> Size (a + b), tabulate (fun st -> tb.[ta.[st]] )


type Element =
    |Elem of char
    interface IMeasured<Size * Table> with
        member inline this.Value = 
            match this with
            |Elem a -> 
                 Size 1, Map.find a letters

type FingerString =FingerTree<Element,Size * Table, Monoid>

let inline matches007 (s:FingerString) = (snd (measured s)).[0]=5

let inline fromList s=(s,Empty)||> List.foldBack (push_front<<Elem)

let inline insert i c tree = 
    let (l,r) = split (fun (Size n,_) -> n>i) tree
    concat l (push_front (Elem c) r)

let inline replace i c tree = 
    update (fun (Size n,_) -> n>i) (Elem c) tree

let treeString : seq<char>->FingerString = fromList<<List.ofSeq

//Simulate an interactive loop
let loop l f tree=
    let res = List.fold (fun acc (i,c)->
        let result= f i c acc
        result) tree l
    printfn "with Loop. Result %A" (matches007 res) 
    res

//Tests
open System
open System.Text.RegularExpressions

let test f =
    printfn "Test Start"
    let sw = new System.Diagnostics.Stopwatch()
    sw.Start()
    f()
    sw.Stop()
    printfn "Time Duration : %A" sw.ElapsedMilliseconds

//Regex for test.
let regex = new Regex (".*\(.*007.*\).*")

//String with 100 000 chars.
let str = String.Concat( Array.create 10000 " Match Me " )

//List of strings for test.
let listString=[str; str + "(007)"; "(007" + str + ")"; "(007)" + str]

//List of finger trees for test.
let listFingerString = List.map treeString listString

let runTest ()= 
    List.fold (fun acc str->
        test (fun ()->printfn "with Regex %A. Result %A " acc (regex.Match(str).Success))
        acc+1) 0 listString|>ignore
    List.fold (fun acc str->
        test (fun ()->printfn "with Finger Tree %A. Result %A " acc (matches007 str))
        acc+1) 0 listFingerString|>ignore

runTest ()

test (fun ()->loop [(3,'(');(4000,'u');(20005,'0');(20006,'0');(20007,'7');(20008,'r');(40009,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop  [(3,'(');(4,'0');(5,'0');(6,'7');(8,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop [(40004,'(');(40005,'0');(40006,'0');(40007,'7');(40008,'r');(40009,')');(40010,' ');(11,'I')] insert stringTree|>ignore)

test (fun ()->loop [(3,'(');(4000,'u');(20005,'0');(20006,'0');(20007,'7');(20008,'r');(40009,')');(40010,' ');(11,'I')] replace stringTree|>ignore)

F# Finger Tree und RegEx. Teil 2. Polymorphic Recursion.

Teil 1.
Die push_front-Funktion ist rekursiv und ruft sich selbst mit verschiedenen Typ-Parameter. In diesem Fall spricht man von "Polymorphic Recursion".

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> 

Wenn beim Funktionsparameter a der Typ-Parameter weggelassen wird, bekommen wir folgende Fehlermeldung.

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> a (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> 

Um besser zu sehen, mit welchem Parameter die Funktion aufgerufen wird, loggen wir die einzelne Funktionsaufrufe.

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> =
        printfn "Argument a = %A" a
...

let tree:RandomAccess<char> = List.foldBack (push_front<<Element) ['a'..'i'] Empty

Teil 3.

F# Finger Tree und RegEx. Teil 1.

Finger Tree ist eine Datenstruktur aus der Welt der funktionalen Programmierung. Die verständliche und ausführliche Erklärung findet man hier 1, 2.

Hier ist ein sehr interessantes Problem beschrieben, das mittels der Finger Tree-Datenstruktur elegant gelöst wird.

Kurz gefasst: Sei einen regulären Ausdruck R gegeben, der auf einen String S der Länge N angewendet wird und angenommen der String S wird durch Einfügen, Ersetzen oder Löschen einzelner Zeichen geändert. Wie schnell kann die geänderte Zeichenfolge mit dem Ausdruck R erneut verglichen werden. Erstmal scheint es, dass die gesamte Zeichenfolge neu überprüft werden soll. Der Artikel jedoch zeigt, dass man nur O (log n) Zeit für die Neuberechnung benötigt.

Zuerst aber F# Finger Tree Version.
Grundlegende Ansätze zur F#-Implementierung habe ich bei diesen Postings - 1 und 2 - abgeschaut. Für weitere Funktionalitäten - split, concat und find Funktionen - ist die Haskell-Version herangezogen worden.

//Types
type IMeasured<'V>  =
    abstract inline Value : 'V

let inline measured (v : #IMeasured<_>) = v.Value

type IMonoid<'V> =
    abstract inline Zero : 'V
    abstract inline Plus : 'V -> 'V -> 'V

type Singleton<'T when 'T : (new : unit -> 'T)> private () =
    static let instance = new 'T()
    static member Instance = instance


type Node<'T,'V when 'T :> IMeasured<'V>> = 
    | Node2 of 'V * 'T * 'T
    | Node3 of 'V * 'T * 'T * 'T
    interface IMeasured<'V> with
        member x.Value =
            match x with
            |Node2 (v,_,_) ->v
            |Node3 (v,_,_,_) ->v

type Digit<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> =
    |One of 'T
    |Two of 'T * 'T
    |Three of 'T * 'T * 'T
    |Four of 'T * 'T * 'T * 'T
    interface IMeasured<'V> with
        member x.Value = 
            let monoid = Singleton<'M>.Instance
            match x with
            |One x-> measured x
            |Two(a,b)->  monoid.Plus (measured a) (measured b)
            |Three(a,b,c)->  monoid.Plus ((measured a, measured b)||>monoid.Plus) (measured c)
            |Four(a,b,c,d)->  monoid.Plus ((measured a, measured b)||>monoid.Plus) ((measured c,measured d)||>monoid.Plus)

type FingerTree<'T, 'V, 'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> = 
    | Empty
    | Single of 'T
    | Deep of 'V * Digit<'T,'V,'M> * FingerTree<Node<'T,'V>,'V,'M> * Digit<'T,'V,'M>
    interface IMeasured<'V> with
        member x.Value =
            let monoid = Singleton<'M>.Instance
            match x with
            | Empty -> monoid.Zero
            | Single s -> measured s
            | Deep (v,_,_,_)->v

//Tree Construction.
let inline node2<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (b:'T)= 
    let monoid = Singleton<'M>.Instance
    Node2 (monoid.Plus (measured a) (measured b),a,b)

let inline node3<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (b:'T) (c:'T)=
    let monoid = Singleton<'M>.Instance
    Node3 (monoid.Plus ((measured a, measured b)||>monoid.Plus) (measured c),a,b,c)

let inline consDigit a dig=
    match dig with
    |One b->Two(a,b)
    |Two(b,c)->Three(a,b,c)
    |Three(b,c,d)-> Four(a,b,c,d)
    |_->raise FTreeException

let rec push_front<'T,'V,'M when 'M :> IMonoid<'V> and 'M : (new  : unit -> 'M) and 'T :> IMeasured<'V>> (a:'T) (t:FingerTree<'T,'V,'M> ):FingerTree<'T,'V,'M> =
        match t with 
        |Empty-> Single a
        |Single b->deep (One a) Empty (One b)
        |Deep (v, left, mid, right)->
            let monoid = Singleton<'M>.Instance
            match left with
            |Four(e,f,g,h) ->
                Deep(monoid.Plus (measured a) v,Two(a,e),push_front (node3<'T,'V,'M> f g h) mid,right)
            |_-> 
                Deep (monoid.Plus (measured a) v, consDigit a left, mid, right)

Der vollständige Quellcode - fingertree.fsx.
Wie wir sehen können ist die Baumstruktur mit einem Monoid parametrisiert. Dadurch kann eine und dieselbe Baumstruktur für verschiedene Zwecke verwendet werden. Wir können z.B. eine Random Access Datenstruktur definieren.

open FData.FingerTree

//Random Access
type Monoid() =
        interface IMonoid<int> with
            member this.Zero = 0
            member this.Plus a b = a + b

type Element<'T>  =
    |Element of 'T
    interface IMeasured<int> with
        member this.Value = 1

type RandomAccess<'T> = FingerTree<Element<'T>, int, Monoid>

//Index-Zugriff.
let nth index tree =
    match (find ((<) index) tree) with
    |Some value-> value
    |None-> failwith "invalid index" 

oder Max-Priority Queue

open FData.FingerTree

//Max-Priority Queue
type Monoid() =
        interface IMonoid<int> with
            member this.Zero = System.Int32.MinValue
            member this.Plus a b = max a b

type Element<'V> =
        { Prio : int
          Element : 'V }
          interface IMeasured<int> with
            member this.Value = this.Prio

type Priority<'T> =FingerTree<Element<'T>,int,Monoid>

//Das Element mit der höchsten Priorität finden
let findPrio tree = 
    match tree with
    |Empty->failwith "tree is empty"
    |Single b->Some b
    |Deep (v, _,_,_)->
        find (fun x->x = v) tree

Teil 2.

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

F# Random Permutation. Split und Shuffle.

von Rosetta Code Knuth shuffle.

let KnuthShuffle (lst : array<'a>) =
    let Swap i j =                                                 
        let item = lst.[i]
        lst.[i] <- lst.[j]
        lst.[j] <- item
    let rnd = new System.Random()
    let ln = lst.Length
    [0..(ln - 2)]                                                   
    |> Seq.iter (fun i -> Swap i (rnd.Next(i, ln)))  // swap the item at the index with a random one following it (or itself)
    lst

let shuffle = KnuthShuffle [|0..1000|]

Wie man sieht verwendet dieser Code Wertzuweisungen ("side effect"), da die Array-Elemente geändert werden.
Ich fragte mich, wie implementiert man so eine Algorithmus in der funktionalen Programmierung und bin hier findig geworden. Da ist es ausführlich mit Beispiel in Haskell erklärt.
Hier ist mein Versuch in F#. Erstmal die Split-Funktion für die Listen.

let splitAt n=
    let rec splitAtRec acc n l =
        match n, l with
        |0, xs       -> (fst acc, xs)
        |_, []       -> ([], [])
        |n, x :: xs -> splitAtRec (x::fst acc, snd acc) (n-1) xs
    splitAtRec ([],[]) n

Was wichtig ist, dass die Funktion "tail recursive" ist.

let ran = new System.Random()
let mergeRandom l1 l2 =
    let lengthAndList l = (List.length l),l
    
    let rec merge acc (nx,xs) (ny, ys) =
        match (nx, xs), (ny, ys) with
        |(0 , []), (ny , ys)-> 
            match ys with
            |[h]-> h::acc
            |h::tl->
                ys@acc
            |_-> acc
        |(nx, xs), (0 , [])-> 
            match xs with
            |[h]->h::acc
            |h::tl->
                xs@acc
            |_-> acc
        |(_, x'::xs'), (_, y'::ys')-> 
            let random = ran.Next(1, nx + ny)
            if random <= nx then
                merge (x'::acc) (nx-1, xs') (ny, ys)
            else
                merge (y'::acc) (nx, xs) (ny-1, ys')
        |_->[]
    merge [] (lengthAndList l1) (lengthAndList l2)

let Shuffle =
    let rec mergeSort l =
        match l with
        |[] -> []
        |[x] -> [x]
        |l -> 
            let l1,l2 = splitAt (l.Length/2) l 
            mergeRandom (mergeSort l1) (mergeSort l2)
    mergeSort

Die Shuffle-Funktion ist nach meinem Verständnis nicht "tail recursive", also sollte es zu einem StackOverflow-Fehler kommen, aber bei mir hat der nicht aufgetreten.
Leider ist meine funktionale Version viel zu langsam.

Funktionale Animation. Teil 4.

Teil 1.
Teil 2.
Teil 3.


Es ist soweit. Ich kann endlich eine kleine animierte Statistik generieren.
Nehmen wir an, es gibt eine Firma, die die verschiedene Produkte über Amazon verkauft. Für diese Firma wird z.B eine Statistik über Gewinn, Kosten und Amazon-Rating von einzelnen Produkten im Verlauf der Zeit erstellt.

• Gewinn - Y-Achse
• Kosten - X-Achse
• Rating - Kreisdurchmesser

Die Daten werden einfach von der Random-Funktion generiert und danach weiter interpoliert so, dass letztendlich eine Sequenz folgendes Formates herauskommt.
data: (int * string * float * float * 'color) seq

(Zeitangabe, Produktname, Gewinn, Kosten, Farbe)
oder für die Rating-Werte
(Zeitangabe, Produktname, Rating, der Feld wird ignoriert , Farbe)

Einfachheitshalber werden als Zeitangabe ausschließlich Jahreswerte angegeben, die in fortlaufenden Nummern umgewandelt werden.

[(1,"Produkt A",70.50, 64.00, Brushes.Black );
(1,"Produkt B",80.50, 144.00, Brushes.Red );
(1,"Produkt C",187.50, 54.00, Brushes.Green);
(2,"Produkt A",70.55, 106.05, Brushes.Black );
(2,"Produkt B",80.55, 44.00, Brushes.Red );
(2,"Produkt C",45.50, 54.00, Brushes.Green)]

Der Code für die Datenerstellung befindet sich hier (Data.fsx).

//Behavior.fs
module BehaviorDrawing  =
   open System.Drawing
   open Demo.Drawing
   open Demo.DrawingFunctions
   open Demo.Data
   
   ...

    //Erstellt die Daten für XY-Achsen.
    let createDataXYAxis (data: (int * string * float * float * 'a) seq) =
        behavior{
            let! createdData = 
                 filterData data 
                            (fun (_,text,posx,posy,_)->
                                 let fposx,fposy = (float32 posx),(float32 posy)
                                 text,fposx,fposy
                            )
                            (fun (text,_,_)->text)
            return createdData
        }

    //Erstellt aus der Daten die Kreise.
    let createDataCircle (data: (int * string * float * float * 'a) seq) =
        behavior{
            let! createdData = 
                 filterData data 
                            (fun (_,text,diameter,_,color)->
                                 let fdiameter = float32 diameter
                                 text, circle color fdiameter fdiameter text
                            )
                            (fun (text,_)->text)
            return createdData|>Seq.map snd
        }

    //Alles zusammenfügen.
    let dataDrawing dataXY dataCircle=
        behavior{
            let! xy = dataXY
            let! c = dataCircle
            match Seq.isEmpty xy,Seq.isEmpty c with
            |false,false-> 
                return (
                    Seq.zip xy c
                    |>Seq.map (fun ((_,fposx,fposy),circle)->
                        let moveCircle = translate fposx fposy circle        
                        let textX = drawText (fposy.ToString()) (20.0f) -fposy
                        let lineX = textX
                                    |>compose (lineDraw 40.f -fposy fposx -fposy)
                        let textY = drawText (fposx.ToString()) fposx (-20.0f)
                        let lineY = textY
                                    |>compose (lineDraw fposx -40.f fposx -fposy) 
                        Seq.fold compose moveCircle (lineX::[lineY]))
                    |>Seq.fold compose emptyDrawing)
            |_-> return emptyDrawing
        }

    //Anzeige der Jahresüberschrift.
    let animationYearText duration init =
        let year timeStep = 
            //let td = t % duration
            //let o= (td*255/duration)%255
            let year = init + (timeStep  / duration)
            ("Jahr " + (year.ToString()))
        behavior{
            let! t = time
            return  (drawText (year t) 300.f (-570.f))
        }

    let animationPart4 duration init=
       //Initialisiere die Funktion mit der Dauer und dem Startwert.
       let fInterpolation = createInterpolation duration init
       //Erstelle die Daten im angegebenen Bereich 
       //für den Kreisdurchmesser. 
       let circles = fInterpolation  20 70
       //Erstelle die Daten im angegebenen Bereich 
       //für die X- Y-Achsen.
       let xyAxis = fInterpolation  40 500
       behavior{
           //Erstelle das komplette Bild.
           let! all = 
               dataDrawing  (createDataXYAxis xyAxis) (createDataCircle circles)
           return all
           }
    let singelton=
        let one duration init = behavior{
              let! a = animationPart4 duration init//animation
              let! animYear = animationYearText duration init 
              return (compose a animYear)
              }
        one

Dequeue.fs
Data.fsx
Drawing.fs
BehaviorPart4.fsx
AnimationPart4.fsx
mainPart4.fs

Funktionale Animation. Teil 3. Like a satellite.

Teil 1
Teil 2


Als Nächstes möchte ich eine Art von einfacher Planetenbewegung simulieren. Sagen wir, drei Kreise sollen sich mit unterschiedlicher Geschwindigkeit bewegen, und jeder Kreis besitzt noch einen eigenen Satellit.

Die rotate-Funktion wird erweitert.

let rotate speed radius = behavior {
   let fast = faster speed time
   let! posx = fast|>wiggle
   let! posy = fast|>wait 0.5f|>wiggle
   return posx * radius, posy * radius
   }

Dann brauche ich eine leere Behavior-Animation.

let forever a = Behavior(fun _->a)

let emptyBehavior = forever emptyDrawing 

Wie man sieht, egal zu welchem Zeitpunkt, gibt die forever-Funktion immer den gleichen Wert zurück.
Die Komposition zweier Drawing-Werte ist bereits in Drawing.fs definiert. Zur Erinnerung:

//Drawing.fs
...
let compose (img1:Drawing) (img2:Drawing) =
    drawing(fun g ->
      img1.Draw(g)
      img2.Draw(g) )

Das Gleiches implementiere ich für die Behavior-Werte und zwar als ein Operator. Der Vorteil dabei ist, dass in F# der Operator in der Infix- und Präfixnotation geschrieben werden kann. z.B

//let sum = 1 + 2
//let sum = (+) 1 2

let (--) a b =
    behavior {
        let! x = a
        let! y = b
        return compose x y
    } 

Die Verschiebefunktion.

let rotateAndTranslate speed radius drawingBehavior =
    behavior {
        let! x,y = rotate speed radius
        let! image = drawingBehavior
        return translate x y image
    } 

Und schließlich kann die Animation-Funktion geschrieben werden.

let animationPart3 =
    let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f
    let folder (acc,count) (color, speed) =
        let planet =
            rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count+1
    [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

Gehen wir den Code jetzt Schritt für Schritt durch.

 let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f

Am einfachsten liest man diesen Ausdruck der Funktionskomposition von rechts nach links. (<<) ist der Funktionskomposition-Operator.

1. circle Brushes.DimGray 20.0f 20.0f - Erstelle einen Kreis mit den übergebenen Parametern. Mit der Hilfe von Currying bekommen wir eine reduzierte Funktion, die noch das letzte Argument verlangt und Drawing zurückliefert. Die Typ-Signatur ist - (string->Drawing).
   
2. forever-Funktion wandelt Drawing in Behavior<Drawing>. Die Typ-Signatur - (string->Behavior<Drawing>).
   
3. Verschiebe den in Behavior "versteckten" Drawing-Wert mit der angegebenen Geschwindigkeit auf der Laufbahn vom angegebenen Halbmesser. Die Typ-Signatur - (string->Behavior<Drawing>)
   

Die folder-Funktion folgt später.

     [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

Hier wird die Liste von Paaren mit der Farbe und der Geschwindigkeit an der Seq.fold übergeben. (|>) ist der Pipe-Operator. Der Wert vom linken Ausdruck wird an das letzte Argument des rechten Ausdruckes übergeben. Das Resultat von fold ist ein Tupel, von dem wird mit der fst-Funktion (fst für "first") der erste Wert genommen.
Nun zur folder-Funktion. Das Prinzip ist hier und speziell für F# Seq.fold erklärt.

let folder (acc,count) (color, speed) =
        let planet = rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count+1

Wie beschrieben, folder wird auf jeden Element - (color, speed) - der oben genannten Liste angewendet. Der Akkumulator (ich kenne keinen besseren Namen) ist (acc, count), wobei acc - wie man beim Funktionsaufruf sieht - am Anfang emptyBehavior ist und count gleich 1 ist.

let planet = 
    rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f

Hier is das gleiche wie beim satellite-Ausdruck. Anders ist nur, dass vor dem Verschieben der Kreis vom Planet mit dem Satellit zusammengesetzt wird. Dann setzen wir den Planet mit dem Akkumulator zusammen, dadurch wird am Ende des Fold-Prozesses ein allen Elementen enthaltener, akkumulierter Behavior-Wert entstehen. Der Zähler count ist für die Durchnummerierung von Kreisen auf dem Formular da.
Alles zusammen.

//Behavior.fsx
...
let rotate speed radius= behavior{
  let fast = faster speed time
  let! posx = fast|>wiggle
  let! posy = fast|>wait 0.5f|>wiggle
  return posx * radius, posy * radius}

module BehaviorDrawing  =
open Demo.Drawing
open Demo.DrawingFunctions
let emptyBehavior = forever emptyDrawing
let (--) a b =
    behavior{
        let! x = a
        let! y = b
        return compose x y
    }
let rotateAndTranslate speed radius drawingBehavior =
    behavior{
        let! x,y = rotate speed radius
        let! image = drawingBehavior
        return translate x y image
    }

let animationPart3 =
    let satellite = rotateAndTranslate 0.8f 45.0f<<forever<<circle Brushes.DimGray 20.0f 20.0f
    let folder (acc,count) (color, speed) =
        let planet = rotateAndTranslate speed 70.0f<<(--) (satellite "moon")<<forever<<circle color 40.0f 40.0f
        let result = acc -- (count.ToString()|>planet)
        result,count + 1
    [(Brushes.Black,0.1f);(Brushes.OliveDrab,0.3f);(Brushes.SteelBlue,0.6f)]
    |>Seq.fold folder (emptyBehavior,1)
    |>fst

let singelton =
    let one =behavior{
          let! a = animationPart3
          return a
          }
    one

Drawing.fs
Behavior.fsx
Animation.fsx
main.fs