mirror of
https://github.com/Smaug123/mystery-hunt-2023-reactivation
synced 2025-10-05 04:38:40 +00:00
A bit of productionising
This commit is contained in:
Smaug123
67
Reactivation/BondSet.fs
Normal file
67
Reactivation/BondSet.fs
Normal file
@@ -0,0 +1,67 @@
|
||||
namespace Reactivation
|
||||
|
||||
open System.Collections.Immutable
|
||||
|
||||
type BondSet =
|
||||
private
|
||||
| BondSet of ((int * int) * (int * int)) ImmutableHashSet
|
||||
|
||||
[<RequireQualifiedAccess>]
|
||||
module BondSet =
|
||||
let sort a b = if a < b then (a, b) else (b, a)
|
||||
|
||||
let addIfOk ((sourceX, sourceY) as source) ((destX, destY) as dest) (BondSet bonds) : BondSet option =
|
||||
let distance = abs (sourceX - destX) + abs (sourceY - destY)
|
||||
if distance = 2 then
|
||||
// Check the other
|
||||
if sourceX < destX && sourceY < destY then
|
||||
if bonds.Contains (sort (sourceX + 1, sourceY) (sourceX, sourceY + 1)) then
|
||||
None
|
||||
else
|
||||
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.Add (sort source dest)
|
||||
|> BondSet
|
||||
|> Some
|
||||
elif sourceX < destX then
|
||||
if bonds.Contains (sort (sourceX, sourceY - 1) (sourceX + 1, sourceY)) then
|
||||
None
|
||||
else
|
||||
bonds.Add (sort source dest)
|
||||
|> BondSet
|
||||
|> Some
|
||||
else
|
||||
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then
|
||||
None
|
||||
else
|
||||
bonds.Add (sort source dest)
|
||||
|> BondSet
|
||||
|> Some
|
||||
|
||||
else
|
||||
if distance <> 1 then failwith "bad assumption"
|
||||
bonds.Add (sort source dest)
|
||||
|> BondSet
|
||||
|> Some
|
||||
|
||||
let empty = BondSet ImmutableHashSet.Empty
|
||||
|
||||
let directionList (BondSet s) =
|
||||
let rec go (acc : _ list) (start : int * int) (s : ImmutableHashSet<_>) =
|
||||
if s.IsEmpty then List.rev (start :: acc) else
|
||||
let next, toRem =
|
||||
s
|
||||
|> Seq.choose (fun (p1, p2) ->
|
||||
if p1 = start then Some (p2, (p1, p2))
|
||||
elif p2 = start then Some (p1, (p1, p2))
|
||||
else None
|
||||
)
|
||||
|> Seq.exactlyOne
|
||||
go (start :: acc) next (s.Remove toRem)
|
||||
|
||||
go [] (0, 0) s
|
||||
184
Reactivation/Program.fs
Normal file
184
Reactivation/Program.fs
Normal file
@@ -0,0 +1,184 @@
|
||||
namespace Reactivation
|
||||
|
||||
open System.Collections.Generic
|
||||
open System.Collections.Immutable
|
||||
|
||||
type Instruction =
|
||||
| Horizontal = 1
|
||||
| Vertical = 2
|
||||
| UpAndRight = 3
|
||||
| DownAndRight = 4
|
||||
|
||||
module Program =
|
||||
|
||||
let words =
|
||||
[
|
||||
"LEAD"
|
||||
"READ"
|
||||
"BEAD"
|
||||
"BEAR"
|
||||
"BEAT"
|
||||
"BOAT"
|
||||
"BOOT"
|
||||
"BOLT"
|
||||
"COLT"
|
||||
"CULT"
|
||||
"CURT"
|
||||
"CART"
|
||||
"CARE"
|
||||
"DARE"
|
||||
"DANE"
|
||||
"DONE"
|
||||
"DONG"
|
||||
"DING"
|
||||
"MING"
|
||||
"MINX"
|
||||
"MIND"
|
||||
"MEND"
|
||||
"MELD"
|
||||
"MEAD"
|
||||
]
|
||||
|
||||
let instructions =
|
||||
words @ [ List.head words ]
|
||||
|> List.pairwise
|
||||
|> List.map (fun (start, next) ->
|
||||
let instruction =
|
||||
[1..4]
|
||||
|> List.filter (fun i ->
|
||||
start.[i - 1] <> next.[i - 1]
|
||||
)
|
||||
|> List.exactlyOne
|
||||
|> enum<Instruction>
|
||||
start, instruction
|
||||
)
|
||||
|
||||
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 : ImmutableDictionary<int * int, string>)
|
||||
(instructions : (string * Instruction) list)
|
||||
: _ list
|
||||
=
|
||||
if not (restrict board) then [] else
|
||||
match instructions with
|
||||
| [] -> [board, BondSet.directionList bonds]
|
||||
| (word, i) :: rest ->
|
||||
// Place this word.
|
||||
let newBoard =
|
||||
board.Add ((currX, currY), word)
|
||||
|
||||
match i with
|
||||
| Instruction.Horizontal ->
|
||||
// horizontal, i.e. change X
|
||||
[
|
||||
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
|
||||
|
||||
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
|
||||
]
|
||||
| Instruction.Vertical ->
|
||||
// vertical, i.e. change Y
|
||||
[
|
||||
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
|
||||
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
|
||||
]
|
||||
| Instruction.UpAndRight ->
|
||||
[
|
||||
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
|
||||
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
|
||||
]
|
||||
| Instruction.DownAndRight ->
|
||||
[
|
||||
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
|
||||
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
|
||||
]
|
||||
| _ -> failwith "bad direction"
|
||||
|
||||
let print ((x, y), s) =
|
||||
printfn "%i, %i: %s" x y s
|
||||
|
||||
[<EntryPoint>]
|
||||
let main _ =
|
||||
let sw = System.Diagnostics.Stopwatch.StartNew ()
|
||||
let after =
|
||||
instructions
|
||||
|> go 0 0 BondSet.empty ImmutableDictionary.Empty
|
||||
|> List.map (fun (examplePlacement, exampleBonds) ->
|
||||
let munged =
|
||||
exampleBonds
|
||||
|> List.choose (fun (srcX, srcY) ->
|
||||
match examplePlacement.TryGetValue ((srcX, srcY)) with
|
||||
| true, w ->
|
||||
Some ((srcX, srcY), w)
|
||||
| false, _ ->
|
||||
None
|
||||
)
|
||||
munged
|
||||
)
|
||||
|
||||
let positions =
|
||||
after
|
||||
|> List.minBy (fun l ->
|
||||
let (x, y), _ = List.last l
|
||||
abs x + abs y
|
||||
)
|
||||
|> List.map fst
|
||||
|
||||
sw.Stop ()
|
||||
printfn "%i" sw.ElapsedMilliseconds
|
||||
|
||||
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
|
||||
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
|
||||
| '\000' -> printf "."
|
||||
| _ -> printf "O"
|
||||
printfn ""
|
||||
|
||||
0
|
||||
14
Reactivation/Reactivation.fsproj
Normal file
14
Reactivation/Reactivation.fsproj
Normal file
@@ -0,0 +1,14 @@
|
||||
<Project Sdk="Microsoft.NET.Sdk">
|
||||
|
||||
<PropertyGroup>
|
||||
<OutputType>Exe</OutputType>
|
||||
<TargetFramework>net7.0</TargetFramework>
|
||||
</PropertyGroup>
|
||||
|
||||
<ItemGroup>
|
||||
<Compile Include="Seq.fs" />
|
||||
<Compile Include="BondSet.fs" />
|
||||
<Compile Include="Program.fs" />
|
||||
</ItemGroup>
|
||||
|
||||
</Project>
|
||||
20
Reactivation/Seq.fs
Normal file
20
Reactivation/Seq.fs
Normal 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
|
||||
Reference in New Issue
Block a user