wip

Author: JaggerJo

src/Avalonia.FuncUI.Components/State/State.Adapters.fs

@@ -1,6 +1,7 @@
 namespace Avalonia.FuncUI
 
 open System
+open Avalonia.Controls.Primitives
 open Avalonia.FuncUI
 
 type internal UniqueValueReadOnly<'value>
@@ -31,13 +32,31 @@ type internal UniqueValue<'value>
         member this.Set (newValue: 'value) =
             src.Set newValue
 
-type internal ValueMap<'value, 'key when 'key : comparison>
-  ( src: IWritable<'value list>,
+type internal ValueMapped<'a, 'b>
+  ( src: IReadable<'a>,
+    mapFunc: 'a -> 'b ) =
+
+    let mutable current: 'b = mapFunc src.Current
+
+    interface IReadable<'b> with
+        member this.InstanceId with get () = src.InstanceId
+        member this.Current with get () = current
+        member this.Subscribe (handler: 'b -> unit) =
+            src.Subscribe (fun value ->
+                current <- mapFunc value
+                handler current
+            )
+
+        member this.Dispose () =
+            ()
+
+type internal ReadValueMap<'value, 'key when 'key : comparison>
+  ( src: IReadable<'value list>,
     keyPath: 'value -> 'key ) =
 
     let disposable = new DisposableBag ()
-    let value: IWritable<_> =
-        let value = new UniqueValue<_>(src)
+    let value: IReadable<_> =
+        let value = new UniqueValueReadOnly<_>(src)
         disposable.Add value
         value :> _
 
@@ -47,7 +66,7 @@ type internal ValueMap<'value, 'key when 'key : comparison>
         |> Map.ofSeq
     let mutable current: Map<'key, 'value> = makeMap value.Current
 
-    interface IWritable<Map<'key, 'value>> with
+    interface IReadable<Map<'key, 'value>> with
         member this.InstanceId with get () = value.InstanceId
         member this.Current with get () = current
         member this.Subscribe (handler: Map<'key, 'value> -> unit) =
@@ -57,22 +76,30 @@ type internal ValueMap<'value, 'key when 'key : comparison>
                 handler current'
             )
 
+        member this.Dispose () =
+            (disposable :> IDisposable).Dispose ()
+
+type internal ValueMap<'value, 'key when 'key : comparison>
+  ( src: IWritable<'value list>,
+    keyPath: 'value -> 'key ) =
+
+    inherit ReadValueMap<'value, 'key>(src, keyPath)
+
+    interface IWritable<Map<'key, 'value>> with
+
         member this.Set (signal: Map<'key, 'value>) : unit =
             src.Current
             |> Seq.choose (fun item -> Map.tryFind (keyPath item) signal)
             |> Seq.toList
             |> src.Set
 
-        member this.Dispose () =
-            (disposable :> IDisposable).Dispose ()
-
-type internal KeyFocusedValue<'value, 'key when 'key : comparison>
-  ( src: IWritable<Map<'key, 'value>>,
+type internal ReadKeyFocusedValue<'value, 'key when 'key : comparison>
+  ( src: IReadable<Map<'key, 'value>>,
     key: IReadable<'key> ) =
 
     let disposable = new DisposableBag ()
-    let value: IWritable<_> =
-        let value = new UniqueValue<_>(src)
+    let value: IReadable<_> =
+        let value = new UniqueValueReadOnly<_>(src)
         disposable.Add value
         value :> _
 
@@ -92,13 +119,23 @@ type internal KeyFocusedValue<'value, 'key when 'key : comparison>
     do disposable.Add (key.Subscribe (ignore >> onKeyOrValueChanged))
     do disposable.Add (value.Subscribe (ignore >> onKeyOrValueChanged))
 
-    interface IWritable<'value option> with
+    interface IReadable<'value option> with
         member this.InstanceId with get () = value.InstanceId
         member this.Current with get () = current
 
         member this.Subscribe (handler: 'value option -> unit) =
             onChange.Publish.Subscribe handler
 
+        member this.Dispose () =
+            (disposable :> IDisposable).Dispose()
+
+type internal KeyFocusedValue<'value, 'key when 'key : comparison>
+  ( src: IWritable<Map<'key, 'value>>,
+    key: IReadable<'key> ) =
+
+    inherit ReadKeyFocusedValue<'value, 'key>(src, key)
+
+    interface IWritable<'value option> with
         member this.Set (signal: 'value option) : unit =
             match signal with
             | Some signal ->
@@ -110,9 +147,6 @@ type internal KeyFocusedValue<'value, 'key when 'key : comparison>
                 |> Map.remove key.Current
                 |> src.Set
 
-        member this.Dispose () =
-            (disposable :> IDisposable).Dispose()
-
 type internal FilteringValueList<'value, 'filter>
   ( src: IWritable<'value list>,
     filter: IReadable<'filter>,

src/Avalonia.FuncUI.Components/State/State.Functions.fs

@@ -31,4 +31,18 @@ module State =
         uniqueWire :> _
 
     let subscribe (handler: 'value -> unit) (state: IWritable<'value>) : IDisposable =
-        state.Subscribe handler
+        state.Subscribe handler
+
+    (* read only functions prefixed with 'read' *)
+
+    let readUnique (state: IReadable<'value>) : IReadable<'value> =
+        let uniqueWire = new UniqueValueReadOnly<'value>(state)
+        uniqueWire :> _
+
+    let readMap (mapFunc: 'a -> 'b) (value: IReadable<'a>) : IReadable<'b> =
+        new ValueMapped<'a, 'b>(value, mapFunc) :> _
+
+    let readTryFindByKey (keyPath: 'signal -> 'key) (key: IReadable<'key>) (wire: IReadable<list<'signal>>) : IReadable<'signal option> =
+        let keyedWire: IReadable<Map<'key, 'signal>> = new ReadValueMap<'signal, 'key>(wire, keyPath) :> _
+        let keyFocusedWire: IReadable<'signal option> = new ReadKeyFocusedValue<'signal, 'key>(keyedWire, key) :> _
+        keyFocusedWire

src/Examples/Component Examples/Examples.GeneticAlgorithm/Examples.GeneticAlgorithm.fsproj

@@ -14,7 +14,17 @@
     </ItemGroup>
 
     <ItemGroup>
-        <Compile Include="Program.fs"/>
+        <Compile Include="Lib\WorldPos.fs" />
+        <Compile Include="Lib\Actors.fs" />
+        <Compile Include="Lib\World.fs" />
+        <Compile Include="Lib\WorldGeneration.fs" />
+        <Compile Include="Lib\States.fs" />
+        <Compile Include="Lib\Genetics.fs" />
+        <Compile Include="Lib\Fitness.fs" />
+        <Compile Include="Lib\Simulator.fs" />
+        <Compile Include="Lib\Population.fs" />
+        <Compile Include="Views.fs" />
+        <Compile Include="Program.fs" />
     </ItemGroup>
 
 </Project>

src/Examples/Component Examples/Examples.GeneticAlgorithm/Lib/Actors.fs

@@ -0,0 +1,13 @@
+namespace Examples.GeneticAlgorithm.Lib
+
+type ActorKind =
+  | Squirrel of hasAcorn: bool
+  | Tree
+  | Acorn
+  | Rabbit
+  | Doggo
+
+type Actor =
+  { Pos : WorldPos;
+    ActorKind : ActorKind;
+    IsActive : bool }

src/Examples/Component Examples/Examples.GeneticAlgorithm/Lib/Fitness.fs

@@ -0,0 +1,45 @@
+namespace Examples.GeneticAlgorithm.Lib
+
+module Fitness =
+
+  let evaluateFitness (gameStates: GameState[], fitnessFunction): float = fitnessFunction(gameStates)
+
+  let standardFitnessFunction (gameStates: GameState[]): float =
+    let lastState: GameState = Seq.last gameStates
+
+    let gameLength = float(gameStates.Length)
+
+    let gotAcornBonus =
+      match lastState.World.Acorn.IsActive with
+      | true  -> 100.0
+      | false -> 0.0
+
+    let finalStateBonus =
+      match lastState.SimState with
+      | SimulationState.Won  -> 1000.0 - (gameLength * 10.0) // Reward quick wins
+      | _ -> -50.0 + gameLength
+
+    gotAcornBonus + finalStateBonus
+
+  let killRabbitFitnessFunction (gameStates: GameState[]): float =
+    let lastState: GameState = Seq.last gameStates
+
+    let gameLength = float(gameStates.Length)
+
+    let gotAcornBonus =
+      match lastState.World.Acorn.IsActive with
+      | true  -> 100.0
+      | false -> 0.0
+
+    let isRabbitAlive = lastState.World.Rabbit.IsActive
+
+    let finalStateBonus =
+      match lastState.SimState with
+      | SimulationState.Won  -> match isRabbitAlive with
+                                | false -> 1000.0 // Heavily reward dead rabbits
+                                | true -> 250.0 - (gameLength * 10.0) // Reward quick wins
+      | _ -> match isRabbitAlive with
+             | true -> -50.0 + gameLength
+             | false -> gameLength
+
+    gotAcornBonus + finalStateBonus

src/Examples/Component Examples/Examples.GeneticAlgorithm/Lib/Genetics.fs

@@ -0,0 +1,109 @@
+namespace Examples.GeneticAlgorithm.Lib
+
+open System
+
+type ActorGeneIndex =
+  | Doggo = 0
+  | Acorn = 1
+  | Rabbit = 2
+  | Tree = 3
+  | Squirrel = 4
+  | NextToDoggo = 5
+  | NextToRabbit = 6
+
+type ActorChromosome =
+  {
+    genes: double list
+    age: int
+  }
+
+type IndividualWorldResult = {
+  score: float
+  states: GameState list
+}
+
+type SimulationResult = {
+  identity: Guid
+  totalScore: float
+  results: IndividualWorldResult list
+  brain: ActorChromosome
+}
+
+module Genes =
+
+    let getRandomGene (random: System.Random) = (random.NextDouble() * 2.0) - 1.0
+
+    let getRandomChromosome (random: System.Random) =
+      {
+        age = 0
+        genes = Seq.init 7 (fun _ -> getRandomGene random) |> Seq.toList
+      }
+
+    let mutate (random: System.Random, magnitude, value) =
+      (value + (random.NextDouble() * magnitude))
+      |> max -1.0 |> min 1.0
+
+    let mutateGenes (random: System.Random) mutationChance genes =
+      List.map (fun g -> if random.NextDouble() <= mutationChance then
+                            mutate(random, 0.5, g)
+                          else
+                            g
+                ) genes
+
+    let getChildGenes (random: System.Random) parent1 parent2 mutationChance =
+
+      // Map from one parent to another, choosing a point to switch from one parent as the source
+      // to the other. Being an identical copy to either parent is also possible
+      let crossoverIndex = random.Next(List.length parent1 + 1)
+
+      List.mapi2 (fun i m f -> if i <= crossoverIndex then
+                                  m
+                                else
+                                  f
+                  ) parent1 parent2
+      // Next allow each gene to be potentially mutated
+      |> mutateGenes random mutationChance
+
+    let createChild (random: System.Random, parent1: double list, parent2: double list, mutationChance: float) =
+
+      let genes = getChildGenes random parent1 parent2 mutationChance
+      {
+        age = 0
+        genes = Seq.toList genes
+      }
+
+    let evaluateProximity actor pos weight =
+      if actor.IsActive then
+        let maxDistance = 225.0
+        let distance = WorldPos.getDistance(actor.Pos, pos)
+        if distance < maxDistance then
+          ((maxDistance - distance)/maxDistance) * weight
+        else
+          0.0
+      else
+        0.0
+
+    let evaluateAdjacentTo actor pos weight =
+      if actor.IsActive && actor.Pos <> pos then
+        if WorldPos.getDistance(actor.Pos, pos) <= 1.5 then
+          0.05 * weight
+        else
+          0.0
+      else
+        0.0
+
+    let getGene (geneIndex: ActorGeneIndex) (genes: double list) =
+      genes.[int geneIndex]
+
+    let evaluateTile brain world pos =
+      let genes = brain.genes
+
+      let proxSquirrel = evaluateProximity world.Squirrel pos (getGene ActorGeneIndex.Squirrel genes)
+      let proxRabbit = evaluateProximity world.Rabbit pos (getGene ActorGeneIndex.Rabbit genes)
+      let proxDoggo = evaluateProximity world.Doggo pos (getGene ActorGeneIndex.Doggo genes)
+      let proxAcorn = evaluateProximity world.Acorn pos (getGene ActorGeneIndex.Acorn genes)
+      let proxTree = evaluateProximity world.Tree pos (getGene ActorGeneIndex.Tree genes)
+      let adjDoggo = evaluateAdjacentTo world.Doggo pos (getGene ActorGeneIndex.NextToDoggo genes)
+      let adjRabbit = evaluateAdjacentTo world.Rabbit pos (getGene ActorGeneIndex.NextToRabbit genes)
+
+      proxSquirrel + proxRabbit + proxDoggo + proxAcorn + proxTree + adjDoggo + adjRabbit

src/Examples/Component Examples/Examples.GeneticAlgorithm/Lib/Population.fs

@@ -0,0 +1,37 @@
+namespace Examples.GeneticAlgorithm.Lib
+
+module Population =
+
+    let simulateGeneration states actors =
+      actors
+      |> Seq.map (fun b -> Simulator.simulate b states)
+      |> Seq.sortByDescending (fun r -> r.totalScore)
+
+    let buildInitialPopulation random =
+      Seq.init<ActorChromosome> 20 (fun _ -> Genes.getRandomChromosome random)
+
+    let simulateFirstGeneration states random =
+      buildInitialPopulation random |> simulateGeneration states
+
+    let mutateBrains (random: System.Random, brains: ActorChromosome[]): ActorChromosome[] =
+      let numBrains = brains.Length
+      let survivors = [| brains.[0]; brains.[1]; |]
+      let randos = Seq.init (numBrains - 4) (fun _ -> Genes.getRandomChromosome random) |> Seq.toArray
+
+      let children = [|
+        Genes.createChild(random, survivors.[0].genes, survivors.[1].genes, 0.25);
+        Genes.createChild(random, survivors.[0].genes, survivors.[1].genes, 0.5);
+      |]
+
+      Array.append children randos |> Array.append survivors
+
+    let mutateAndSimulateGeneration (random: System.Random, worlds: World[], results: SimulationResult[]) =
+      let brains = Seq.map (fun b -> b.brain) results |> Seq.toArray
+      mutateBrains(random, brains) |> simulateGeneration worlds
+
+    let mutateAndSimulateMultiple (random: System.Random, worlds: World[], generations: int, results: SimulationResult[]) =
+      let mutable currentResults = results
+      for _ = 1 to generations do
+        let brains = Seq.map (fun b -> b.brain) currentResults |> Seq.toArray
+        currentResults <- mutateBrains(random, brains) |> simulateGeneration worlds |> Seq.toArray
+      currentResults