patrick/mystery-hunt-2023-reactivation
1
0
Fork 0
mirror of https://github.com/Smaug123/mystery-hunt-2023-reactivation synced 2025-10-05 04:38:40 +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> <TargetFramework>net7.0</TargetFramework>
<IsPackable>false</IsPackable> <IsPackable>false</IsPackable>
<GenerateProgramFile>false</GenerateProgramFile> <RootNamespace>Reactivation.Test</RootNamespace>
</PropertyGroup> </PropertyGroup>
<ItemGroup> <ItemGroup>
<Compile Include="UnitTest1.fs" /> <Compile Include="TestSeq.fs" />
<Compile Include="Program.fs" />
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
@@ -23,7 +22,7 @@
</ItemGroup> </ItemGroup>
<ItemGroup> <ItemGroup>
<ProjectReference Include="..\ConsoleApp2\ConsoleApp2.fsproj" /> <ProjectReference Include="..\Reactivation\Reactivation.fsproj" />
</ItemGroup> </ItemGroup>
</Project> </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 FsUnitTyped
open NUnit.Framework open NUnit.Framework
open Solve open Reactivation
open FsCheck open FsCheck
[<TestFixture>] [<TestFixture>]
@@ -10,11 +10,11 @@ module TestSeq =
[<Test>] [<Test>]
let ``Seq.range works`` () : unit = 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 prop (i : int) (s : int list) =
let s = i :: s let s = i :: s
Seq.range s Seq.rangeOrZero s
|> (=) (Seq.max s - Seq.min s) |> (=) (Seq.max s - Seq.min s)
prop prop

4
ConsoleApp2.sln → Reactivation.sln
View File

@@ -1,8 +1,8 @@
 
Microsoft Visual Studio Solution File, Format Version 12.00 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 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 EndProject
Global Global
GlobalSection(SolutionConfigurationPlatforms) = preSolution 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 = type BondSet =
private private
| BondSet of ((int * int) * (int * int)) Set | BondSet of ((int * int) * (int * int)) ImmutableHashSet
[<RequireQualifiedAccess>] [<RequireQualifiedAccess>]
module BondSet = module BondSet =
@@ -16,46 +18,41 @@ module BondSet =
if bonds.Contains (sort (sourceX + 1, sourceY) (sourceX, sourceY + 1)) then if bonds.Contains (sort (sourceX + 1, sourceY) (sourceX, sourceY + 1)) then
None None
else else
bonds bonds.Add (sort source dest)
|> Set.add (sort source dest)
|> BondSet |> BondSet
|> Some |> Some
elif sourceX > destX && sourceY > destY then elif sourceX > destX && sourceY > destY then
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY - 1)) then if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY - 1)) then
None None
else else
bonds bonds.Add (sort source dest)
|> Set.add (sort source dest)
|> BondSet |> BondSet
|> Some |> Some
elif sourceX < destX then elif sourceX < destX then
if bonds.Contains (sort (sourceX, sourceY - 1) (sourceX + 1, sourceY)) then if bonds.Contains (sort (sourceX, sourceY - 1) (sourceX + 1, sourceY)) then
None None
else else
bonds bonds.Add (sort source dest)
|> Set.add (sort source dest)
|> BondSet |> BondSet
|> Some |> Some
else else
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then
None None
else else
bonds bonds.Add (sort source dest)
|> Set.add (sort source dest)
|> BondSet |> BondSet
|> Some |> Some
else else
if distance <> 1 then failwith "bad assumption" if distance <> 1 then failwith "bad assumption"
bonds bonds.Add (sort source dest)
|> Set.add (sort source dest)
|> BondSet |> BondSet
|> Some |> Some
let empty = BondSet Set.empty let empty = BondSet ImmutableHashSet.Empty
let directionList (BondSet s) = 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 if s.IsEmpty then List.rev (start :: acc) else
let next, toRem = let next, toRem =
s s
@@ -65,8 +62,6 @@ module BondSet =
else None else None
) )
|> Seq.exactlyOne |> Seq.exactlyOne
go (start :: acc) next (Set.remove toRem s) go (start :: acc) next (s.Remove toRem)
go [] (0, 0) s 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 = module Program =
@@ -40,20 +49,21 @@ module Program =
start.[i - 1] <> next.[i - 1] start.[i - 1] <> next.[i - 1]
) )
|> List.exactlyOne |> List.exactlyOne
|> enum<Instruction>
start, instruction start, instruction
) )
let restrict (board : Map<int * int, string>) = let restrict (board : IReadOnlyDictionary<int * int, string>) =
if Seq.range (board.Keys |> Seq.map snd) > 5 then false if Seq.rangeOrZero (board.Keys |> Seq.map snd) > 5 then false
elif Seq.range (board.Keys |> Seq.map fst) > 7 then false elif Seq.rangeOrZero (board.Keys |> Seq.map fst) > 7 then false
else true else true
let rec go let rec go
(currX : int) (currX : int)
(currY : int) (currY : int)
(bonds : BondSet) (bonds : BondSet)
(board : Map<int * int, string>) (board : ImmutableDictionary<int * int, string>)
(instructions : (string * int) list) (instructions : (string * Instruction) list)
: _ list : _ list
= =
if not (restrict board) then [] else if not (restrict board) then [] else
@@ -62,81 +72,63 @@ module Program =
| (word, i) :: rest -> | (word, i) :: rest ->
// Place this word. // Place this word.
let newBoard = let newBoard =
board board.Add ((currX, currY), word)
|> Map.add (currX, currY) word
match i with match i with
| 1 -> | Instruction.Horizontal ->
// horizontal, i.e. change X // horizontal, i.e. change X
[ [
match Map.tryFind (currX + 1, currY) newBoard with if not (newBoard.ContainsKey (currX + 1, currY)) then
| None ->
match bonds |> BondSet.addIfOk (currX + 1, currY) (currX, currY) with match bonds |> BondSet.addIfOk (currX + 1, currY) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX + 1) currY bonds newBoard rest yield! go (currX + 1) currY bonds newBoard rest
| Some _ -> ()
match Map.tryFind (currX - 1, currY) newBoard with if not (newBoard.ContainsKey (currX - 1, currY)) then
| None ->
match bonds |> BondSet.addIfOk (currX - 1, currY) (currX, currY) with match bonds |> BondSet.addIfOk (currX - 1, currY) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX - 1) currY bonds newBoard rest yield! go (currX - 1) currY bonds newBoard rest
| Some _ -> ()
] ]
| 2 -> | Instruction.Vertical ->
// vertical, i.e. change Y // vertical, i.e. change Y
[ [
match Map.tryFind (currX, currY + 1) newBoard with if not (newBoard.ContainsKey (currX, currY + 1)) then
| None ->
match bonds |> BondSet.addIfOk (currX, currY + 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX, currY + 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go currX (currY + 1) bonds newBoard rest yield! go currX (currY + 1) bonds newBoard rest
| Some _ -> () if not (newBoard.ContainsKey (currX, currY - 1)) then
match Map.tryFind (currX, currY - 1) newBoard with
| None ->
match bonds |> BondSet.addIfOk (currX, currY - 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX, currY - 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go currX (currY - 1) bonds newBoard rest yield! go currX (currY - 1) bonds newBoard rest
| Some _ -> ()
] ]
| 3 -> | Instruction.UpAndRight ->
// Bottom left to top right
[ [
match Map.tryFind (currX + 1, currY + 1) newBoard with if not (newBoard.ContainsKey (currX + 1, currY + 1)) then
| None ->
match bonds |> BondSet.addIfOk (currX + 1, currY + 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX + 1, currY + 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX + 1) (currY + 1) bonds newBoard rest yield! go (currX + 1) (currY + 1) bonds newBoard rest
| Some _ -> () if not (newBoard.ContainsKey (currX - 1, currY - 1)) then
match Map.tryFind (currX - 1, currY - 1) newBoard with
| None ->
match bonds |> BondSet.addIfOk (currX - 1, currY - 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX - 1, currY - 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX - 1) (currY - 1) bonds newBoard rest yield! go (currX - 1) (currY - 1) bonds newBoard rest
| Some _ -> ()
] ]
| 4 -> | Instruction.DownAndRight ->
// Top left to bottom right
[ [
match Map.tryFind (currX - 1, currY + 1) newBoard with if not (newBoard.ContainsKey (currX - 1, currY + 1)) then
| None ->
match bonds |> BondSet.addIfOk (currX - 1, currY + 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX - 1, currY + 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX - 1) (currY + 1) bonds newBoard rest yield! go (currX - 1) (currY + 1) bonds newBoard rest
| Some _ -> () if not (newBoard.ContainsKey (currX + 1, currY - 1)) then
match Map.tryFind (currX + 1, currY - 1) newBoard with
| None ->
match bonds |> BondSet.addIfOk (currX + 1, currY - 1) (currX, currY) with match bonds |> BondSet.addIfOk (currX + 1, currY - 1) (currX, currY) with
| None -> () | None -> ()
| Some bonds -> | Some bonds ->
yield! go (currX + 1) (currY - 1) bonds newBoard rest yield! go (currX + 1) (currY - 1) bonds newBoard rest
| Some _ -> ()
] ]
| _ -> failwith "bad direction" | _ -> failwith "bad direction"
@@ -145,54 +137,48 @@ module Program =
[<EntryPoint>] [<EntryPoint>]
let main _ = let main _ =
let sw = System.Diagnostics.Stopwatch.StartNew ()
let after = let after =
instructions instructions
|> go 0 0 BondSet.empty Map.empty |> go 0 0 BondSet.empty ImmutableDictionary.Empty
|> List.map (fun (examplePlacement, exampleBonds) -> |> List.map (fun (examplePlacement, exampleBonds) ->
let munged = let munged =
exampleBonds exampleBonds
|> List.choose (fun (srcX, srcY) -> |> List.choose (fun (srcX, srcY) ->
match examplePlacement.TryFind (srcX, srcY) with match examplePlacement.TryGetValue ((srcX, srcY)) with
| Some w -> | true, w ->
Some ((srcX, srcY), w) Some ((srcX, srcY), w)
| None -> | false, _ ->
None None
) )
munged munged
) )
|> List.distinct
printfn "Before filtering, %i options" after.Length
let after = let positions =
after after
|> List.sortBy (fun l -> |> List.minBy (fun l ->
let (x, y), _ = List.last l let (x, y), _ = List.last l
abs x + abs y 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 struct (minX, maxX) = positions |> Seq.map fst |> Seq.minMax |> ValueOption.get
let positions = l |> List.map fst let struct (minY, maxY) = positions |> Seq.map snd |> Seq.minMax |> ValueOption.get
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 arr = Array2D.zeroCreate (maxY - minY + 1) (maxX - minX + 1) let arr = Array2D.zeroCreate (maxY - minY + 1) (maxX - minX + 1)
let mutable i = 0 let mutable i = 0
for x, y in positions do for x, y in positions do
if i >= instructions.Length then arr.[y - minY, x - minX] <- words.[i].[int (snd instructions.[i]) - 1]
arr.[y - minY, x - minX] <- ValueSome 'M'
else
arr.[y - minY, x - minX] <- ValueSome words.[i].[snd instructions.[i] - 1]
i <- i + 1 i <- i + 1
for row in maxY .. -1 .. minY do for row in maxY .. -1 .. minY do
for col in minX..maxX do for col in minX..maxX do
match arr.[row - minY, col - minX] with match arr.[row - minY, col - minX] with
| ValueNone -> printf "." | '\000' -> printf "."
| ValueSome c -> printf "O" | _ -> printf "O"
printfn "" printfn ""
0 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