patrick/mystery-hunt-2023-reactivation
1
0
Fork 0
mirror of https://github.com/Smaug123/mystery-hunt-2023-reactivation synced 2025-10-05 12:48:39 +00:00
Code Issues Packages Projects Releases Wiki Activity

A bit of productionising

Browse Source
This commit is contained in:
Smaug123
2023-01-16 13:43:16 +00:00
parent b3c3978afa
commit 9697bb5311
9 changed files with 86 additions and 106 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
ConsoleApp2/Seq.fs
View File

@@ -1,16 +0,0 @@
namespace Solve
[<RequireQualifiedAccess>]
module Seq =
let range (s : int seq) : int =
use e = s.GetEnumerator ()
if not (e.MoveNext ()) then 0 else
let mutable min = e.Current
let mutable max = e.Current
while e.MoveNext () do
if e.Current < min then min <- e.Current
if e.Current > max then max <- e.Current
max - min

7
Solve.Test/Solve.Test.fsproj → Reactivation.Test/Reactivation.Test.fsproj
View File

@@ -4,12 +4,11 @@
<TargetFramework>net7.0</TargetFramework>
<IsPackable>false</IsPackable>
<GenerateProgramFile>false</GenerateProgramFile>
<RootNamespace>Reactivation.Test</RootNamespace>
</PropertyGroup>
<ItemGroup>
<Compile Include="UnitTest1.fs" />
<Compile Include="Program.fs" />
<Compile Include="TestSeq.fs" />
</ItemGroup>
<ItemGroup>
@@ -23,7 +22,7 @@
</ItemGroup>
<ItemGroup>
<ProjectReference Include="..\ConsoleApp2\ConsoleApp2.fsproj" />
<ProjectReference Include="..\Reactivation\Reactivation.fsproj" />
</ItemGroup>
</Project>

8
Solve.Test/UnitTest1.fs → Reactivation.Test/TestSeq.fs
View File

@@ -1,8 +1,8 @@
namespace Solve.Test
namespace Reactivation.Test
open FsUnitTyped
open NUnit.Framework
open Solve
open Reactivation
open FsCheck
[<TestFixture>]
@@ -10,11 +10,11 @@ module TestSeq =
[<Test>]
let ``Seq.range works`` () : unit =
Seq.range Seq.empty |> shouldEqual 0
Seq.rangeOrZero Seq.empty |> shouldEqual 0
let prop (i : int) (s : int list) =
let s = i :: s
Seq.range s
Seq.rangeOrZero s
|> (=) (Seq.max s - Seq.min s)
prop

4
ConsoleApp2.sln → Reactivation.sln
View File

@@ -1,8 +1,8 @@

Microsoft Visual Studio Solution File, Format Version 12.00
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "ConsoleApp2", "ConsoleApp2\ConsoleApp2.fsproj", "{D18D6A10-3AAB-4F2A-8CE6-C0D598A8E144}"
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Reactivation", "Reactivation\Reactivation.fsproj", "{D18D6A10-3AAB-4F2A-8CE6-C0D598A8E144}"
EndProject
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Solve.Test", "Solve.Test\Solve.Test.fsproj", "{A4D67E0D-4DE2-4F6F-A443-6BE3B735C173}"
Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Reactivation.Test", "Reactivation.Test\Reactivation.Test.fsproj", "{A4D67E0D-4DE2-4F6F-A443-6BE3B735C173}"
EndProject
Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution

29
ConsoleApp2/BondSet.fs → Reactivation/BondSet.fs
View File

@@ -1,8 +1,10 @@
namespace Solve
namespace Reactivation
open System.Collections.Immutable
type BondSet =
private
| BondSet of ((int * int) * (int * int)) Set
| BondSet of ((int * int) * (int * int)) ImmutableHashSet
[<RequireQualifiedAccess>]
module BondSet =
@@ -16,46 +18,41 @@ module BondSet =
if bonds.Contains (sort (sourceX + 1, sourceY) (sourceX, sourceY + 1)) then
None
else
bonds
|> Set.add (sort source dest)
bonds.Add (sort source dest)
|> BondSet
|> Some
elif sourceX > destX && sourceY > destY then
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY - 1)) then
None
else
bonds
|> Set.add (sort source dest)
bonds.Add (sort source dest)
|> BondSet
|> Some
elif sourceX < destX then
if bonds.Contains (sort (sourceX, sourceY - 1) (sourceX + 1, sourceY)) then
None
else
bonds
|> Set.add (sort source dest)
bonds.Add (sort source dest)
|> BondSet
|> Some
else
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then
None
else
bonds
|> Set.add (sort source dest)
bonds.Add (sort source dest)
|> BondSet
|> Some
else
if distance <> 1 then failwith "bad assumption"
bonds
|> Set.add (sort source dest)
bonds.Add (sort source dest)
|> BondSet
|> Some
let empty = BondSet Set.empty
let empty = BondSet ImmutableHashSet.Empty
let directionList (BondSet s) =
let rec go (acc : _ list) (start : int * int) (s : Set<_>) =
let rec go (acc : _ list) (start : int * int) (s : ImmutableHashSet<_>) =
if s.IsEmpty then List.rev (start :: acc) else
let next, toRem =
s
@@ -65,8 +62,6 @@ module BondSet =
else None
)
|> Seq.exactlyOne
go (start :: acc) next (Set.remove toRem s)
go (start :: acc) next (s.Remove toRem)
go [] (0, 0) s

104
ConsoleApp2/Program.fs → Reactivation/Program.fs
View File

@@ -1,4 +1,13 @@
namespace Solve
namespace Reactivation
open System.Collections.Generic
open System.Collections.Immutable
type Instruction =
| Horizontal = 1
| Vertical = 2
| UpAndRight = 3
| DownAndRight = 4
module Program =
@@ -40,20 +49,21 @@ module Program =
start.[i - 1] <> next.[i - 1]
)
|> List.exactlyOne
|> enum<Instruction>
start, instruction
)
let restrict (board : Map<int * int, string>) =
if Seq.range (board.Keys |> Seq.map snd) > 5 then false
elif Seq.range (board.Keys |> Seq.map fst) > 7 then false
let restrict (board : IReadOnlyDictionary<int * int, string>) =
if Seq.rangeOrZero (board.Keys |> Seq.map snd) > 5 then false
elif Seq.rangeOrZero (board.Keys |> Seq.map fst) > 7 then false
else true
let rec go
(currX : int)
(currY : int)
(bonds : BondSet)
(board : Map<int * int, string>)
(instructions : (string * int) list)
(board : ImmutableDictionary<int * int, string>)
(instructions : (string * Instruction) list)
: _ list
=
if not (restrict board) then [] else
@@ -62,81 +72,63 @@ module Program =
| (word, i) :: rest ->
// Place this word.
let newBoard =
board
|> Map.add (currX, currY) word
board.Add ((currX, currY), word)
match i with
| 1 ->
| Instruction.Horizontal ->
// horizontal, i.e. change X
[
match Map.tryFind (currX + 1, currY) newBoard with
| None ->
if not (newBoard.ContainsKey (currX + 1, currY)) then
match bonds |> BondSet.addIfOk (currX + 1, currY) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX + 1) currY bonds newBoard rest
| Some _ -> ()
match Map.tryFind (currX - 1, currY) newBoard with
| None ->
if not (newBoard.ContainsKey (currX - 1, currY)) then
match bonds |> BondSet.addIfOk (currX - 1, currY) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX - 1) currY bonds newBoard rest
| Some _ -> ()
]
| 2 ->
| Instruction.Vertical ->
// vertical, i.e. change Y
[
match Map.tryFind (currX, currY + 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX, currY + 1)) then
match bonds |> BondSet.addIfOk (currX, currY + 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go currX (currY + 1) bonds newBoard rest
| Some _ -> ()
match Map.tryFind (currX, currY - 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX, currY - 1)) then
match bonds |> BondSet.addIfOk (currX, currY - 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go currX (currY - 1) bonds newBoard rest
| Some _ -> ()
]
| 3 ->
// Bottom left to top right
| Instruction.UpAndRight ->
[
match Map.tryFind (currX + 1, currY + 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX + 1, currY + 1)) then
match bonds |> BondSet.addIfOk (currX + 1, currY + 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX + 1) (currY + 1) bonds newBoard rest
| Some _ -> ()
match Map.tryFind (currX - 1, currY - 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX - 1, currY - 1)) then
match bonds |> BondSet.addIfOk (currX - 1, currY - 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX - 1) (currY - 1) bonds newBoard rest
| Some _ -> ()
]
| 4 ->
// Top left to bottom right
| Instruction.DownAndRight ->
[
match Map.tryFind (currX - 1, currY + 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX - 1, currY + 1)) then
match bonds |> BondSet.addIfOk (currX - 1, currY + 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX - 1) (currY + 1) bonds newBoard rest
| Some _ -> ()
match Map.tryFind (currX + 1, currY - 1) newBoard with
| None ->
if not (newBoard.ContainsKey (currX + 1, currY - 1)) then
match bonds |> BondSet.addIfOk (currX + 1, currY - 1) (currX, currY) with
| None -> ()
| Some bonds ->
yield! go (currX + 1) (currY - 1) bonds newBoard rest
| Some _ -> ()
]
| _ -> failwith "bad direction"
@@ -145,54 +137,48 @@ module Program =
[<EntryPoint>]
let main _ =
let sw = System.Diagnostics.Stopwatch.StartNew ()
let after =
instructions
|> go 0 0 BondSet.empty Map.empty
|> go 0 0 BondSet.empty ImmutableDictionary.Empty
|> List.map (fun (examplePlacement, exampleBonds) ->
let munged =
exampleBonds
|> List.choose (fun (srcX, srcY) ->
match examplePlacement.TryFind (srcX, srcY) with
| Some w ->
match examplePlacement.TryGetValue ((srcX, srcY)) with
| true, w ->
Some ((srcX, srcY), w)
| None ->
| false, _ ->
None
)
munged
)
|> List.distinct
printfn "Before filtering, %i options" after.Length
let after =
let positions =
after
|> List.sortBy (fun l ->
|> List.minBy (fun l ->
let (x, y), _ = List.last l
abs x + abs y
)
|> List.map fst
if after.Length = 0 then 1 else
sw.Stop ()
printfn "%i" sw.ElapsedMilliseconds
let l = after.[1]
let positions = l |> List.map fst
let minX = positions |> List.map fst |> List.min
let maxX = positions |> List.map fst |> List.max
let minY = positions |> List.map snd |> List.min
let maxY = positions |> List.map snd |> List.max
let struct (minX, maxX) = positions |> Seq.map fst |> Seq.minMax |> ValueOption.get
let struct (minY, maxY) = positions |> Seq.map snd |> Seq.minMax |> ValueOption.get
let arr = Array2D.zeroCreate (maxY - minY + 1) (maxX - minX + 1)
let mutable i = 0
for x, y in positions do
if i >= instructions.Length then
arr.[y - minY, x - minX] <- ValueSome 'M'
else
arr.[y - minY, x - minX] <- ValueSome words.[i].[snd instructions.[i] - 1]
arr.[y - minY, x - minX] <- words.[i].[int (snd instructions.[i]) - 1]
i <- i + 1
for row in maxY .. -1 .. minY do
for col in minX..maxX do
match arr.[row - minY, col - minX] with
| ValueNone -> printf "."
| ValueSome c -> printf "O"
| '\000' -> printf "."
| _ -> printf "O"
printfn ""
0

0
ConsoleApp2/ConsoleApp2.fsproj → Reactivation/Reactivation.fsproj
View File

20
Reactivation/Seq.fs Normal file
View File

@@ -0,0 +1,20 @@
namespace Reactivation
[<RequireQualifiedAccess>]
module Seq =
let minMax (s : int seq) : struct (int * int) voption =
use e = s.GetEnumerator ()
if not (e.MoveNext ()) then ValueNone else
let mutable min = e.Current
let mutable max = e.Current
while e.MoveNext () do
if e.Current < min then min <- e.Current
if e.Current > max then max <- e.Current
ValueSome (struct (min, max))
let rangeOrZero (s : int seq) : int =
match minMax s with
| ValueNone -> 0
| ValueSome (min, max) -> max - min

4
Solve.Test/Program.fs
View File

@@ -1,4 +0,0 @@
module Program =
[<EntryPoint>]
let main _ = 0