Foxtran Solver (v1)

Icfpc2023.Tests/Tests.fs

@@ -11,3 +11,9 @@ let ``Test problem reader`` () =
     let problemDef = Path.Combine(solDir, "problems", "1.json")
     let p = JsonDefs.ReadProblemFromFile problemDef
     Assert.NotNull p
+
+[<Fact>]
+let ``FoxtranV1 solver test``(): unit =
+    let problem = JsonDefs.ReadProblemFromFile(Path.Combine(Program.problemsDir, "22.json"))
+    let solution = FoxtranSolver.FoxtranSolveV1 problem
+    Assert.NotNull solution

Icfpc2023.sln.DotSettings

@@ -1,3 +1,6 @@
-<wpf:ResourceDictionary xml:space="preserve" xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml" xmlns:s="clr-namespace:System;assembly=mscorlib" xmlns:ss="urn:shemas-jetbrains-com:settings-storage-xaml" xmlns:wpf="http://schemas.microsoft.com/winfx/2006/xaml/presentation">
-
-	<s:Boolean x:Key="/Default/UserDictionary/Words/=icfpcontest/@EntryIndexedValue">True</s:Boolean></wpf:ResourceDictionary>
+<wpf:ResourceDictionary xml:space="preserve" xmlns:x="http://schemas.microsoft.com/winfx/2006/xaml"
+                        xmlns:s="clr-namespace:System;assembly=mscorlib"
+                        xmlns:wpf="http://schemas.microsoft.com/winfx/2006/xaml/presentation">
+	<s:Boolean x:Key="/Default/UserDictionary/Words/=Foxtran/@EntryIndexedValue">True</s:Boolean>
+
+	<s:Boolean x:Key="/Default/UserDictionary/Words/=icfpcontest/@EntryIndexedValue">True</s:Boolean></wpf:ResourceDictionary>

Icfpc2023/Domain.fs

@@ -16,9 +16,15 @@ type Problem = {
     Attendees: Attendee[]
 }
 
-type Solution = {
-    Placements: PointD[]
-}
+type IPartialSolution =
+    abstract member GetPlacedMusicians: allMusicians: int[] -> seq<PointD * int>
+
+type Solution =
+    { Placements: PointD[] }
+    interface IPartialSolution with
+        member this.GetPlacedMusicians allMusicians =
+            allMusicians
+            |> Seq.zip this.Placements
 
 type Score = double
 type SolverName = string

Icfpc2023/Icfpc2023.fsproj

@@ -10,6 +10,7 @@
     <Compile Include="Domain.fs" />
     <Compile Include="Scoring.fs" />
     <Compile Include="Solvers\DummySolver.fs" />
+    <Compile Include="Solvers\FoxtranSolver.fs" />
     <Compile Include="JsonDefs.fs" />
     <Compile Include="HttpApi.fs" />
     <Compile Include="LambdaScoring.fs" />

Icfpc2023/Scoring.fs

@@ -46,10 +46,9 @@ let CalculateScore(problem: Problem) (solution: Solution): Score =
         |> Seq.toArray
     problem.Attendees |> Array.sumBy(CalculateAttendeeScore musicians)
 
-let CalculateNoBlockingScore(problem: Problem) (solution: Solution): Score =
+let CalculateNoBlockingScore(problem: Problem) (solution: IPartialSolution): Score =
     let musicians =
-        problem.Musicians
-        |> Seq.zip solution.Placements
+        solution.GetPlacedMusicians problem.Musicians
         |> Seq.map(fun(p, i) -> { Instrument = i; Location = p })
         |> Seq.toArray
     problem.Attendees |> Array.sumBy(CalculateAttendeeNoBlockingScore musicians)

Icfpc2023/Solvers/FoxtranSolver.fs

@@ -0,0 +1,105 @@
+module Icfpc2023.FoxtranSolver
+
+open System
+open System.Collections.Generic
+
+let private MusicianDeadZoneRadius = 10.0
+let private GridCellSize = MusicianDeadZoneRadius
+
+type private PartialSolution(position: PointD, instrument: int) =
+    interface IPartialSolution with
+        member _.GetPlacedMusicians _ =
+            [| position, instrument |]
+
+let private MakeSolutionWithSingleMusician index point =
+    PartialSolution(point, index)
+
+let private GetMusicianIndicesPerInstrument problem: Dictionary<int, list<int>> =
+    let result = Dictionary<int, list<int>>()
+    for m in 0 .. problem.Musicians.Length - 1 do
+        let instrument = problem.Musicians[m]
+        match result.TryGetValue instrument with
+        | false, _ -> result[instrument] <- [m]
+        | true, existing ->
+            result[instrument] <- m :: existing
+
+    result
+
+let FindMaxValue grid =
+    let mutable max = Double.MinValue
+    let mutable maxPos = struct(-1, -1)
+    for x in 0 .. Array2D.length1 grid - 1 do
+        for y in 0 .. Array2D.length2 grid - 1 do
+            if grid[x, y] > max then
+                 max <- grid[x, y]
+                 maxPos <- x, y
+    struct(maxPos, max)
+
+let private ChooseBestInstrument availableInstruments (gridsPerInstrument: Score[,][]) =
+    availableInstruments
+    |> Seq.maxBy(fun i ->
+        let struct(_, v) = FindMaxValue gridsPerInstrument[i]
+        v
+    )
+
+let private ChooseBestPosition grid =
+    let struct(pos, _) = FindMaxValue grid
+    pos
+
+let private GridCoordToPhysicalCoord (problem: Problem) (struct(x, y)) =
+    let (PointD(originX, originY)) = problem.StageBottomLeft
+    PointD(10.0 + originX + double x * GridCellSize, 10.0 + originY + double y * GridCellSize)
+
+#nowarn "25"
+let private PlaceMusicianAndDestroyPosition problem
+                                            position
+                                            instrument
+                                            (placements: PointD array)
+                                            (musicianIndicesPerInstrument: Dictionary<int, list<int>>)
+                                            (gridsPerInstrument: Score[,][]) =
+    let musician :: rest = musicianIndicesPerInstrument[instrument]
+
+    // Set to target array:
+    if placements[musician] <> PointD(0.0, 0.0) then failwith "Second time placement in same musician slot!"
+    placements[musician] <- GridCoordToPhysicalCoord problem position
+
+    // Clean up existing data on musician:
+    match rest with
+    | [] -> musicianIndicesPerInstrument.Remove instrument |> ignore
+    | _ -> musicianIndicesPerInstrument[instrument] <- rest
+
+    // Clean up existing data on grid cell:
+    let struct(x, y) = position
+    for grid in gridsPerInstrument do
+        grid[x, y] <- Double.MinValue
+
+let FoxtranSolveV1(problem: Problem): Solution =
+    let instrumentCount = problem.Attendees[0].Tastes.Length
+    let gridWidth, gridHeight =
+        1 + (int <| floor ((problem.StageWidth - 20.0) / GridCellSize)),
+        1 + (int <| floor ((problem.StageHeight - 20.0) / GridCellSize))
+    let createGrid() = Array2D.zeroCreate gridWidth gridHeight
+
+    let gridsPerInstrument = Array.init instrumentCount (fun _ -> createGrid())
+
+    for cellX in 0 .. gridWidth - 1 do
+      for cellY in 0 .. gridHeight - 1  do
+        for instrument in 0 .. instrumentCount-1 do
+          let cellPosition = GridCoordToPhysicalCoord problem (cellX, cellY)
+          let solution = MakeSolutionWithSingleMusician instrument cellPosition
+          let score = Scoring.CalculateNoBlockingScore problem solution
+          gridsPerInstrument[instrument][cellX, cellY] <- score
+
+    let musicianIndicesPerInstrument = GetMusicianIndicesPerInstrument problem
+    let placements = Array.zeroCreate problem.Musicians.Length
+    while musicianIndicesPerInstrument.Count > 0 do
+        let instrument = ChooseBestInstrument musicianIndicesPerInstrument.Keys gridsPerInstrument
+        let position = ChooseBestPosition gridsPerInstrument[instrument]
+        PlaceMusicianAndDestroyPosition problem
+                                        position
+                                        instrument
+                                        placements
+                                        musicianIndicesPerInstrument
+                                        gridsPerInstrument
+
+    { Placements = placements }