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

Format

Browse Source
This commit is contained in:
Smaug123
2023-01-16 13:48:06 +00:00
parent 9697bb5311
commit 3973c5eaff
6 changed files with 171 additions and 121 deletions
Download Patch File Download Diff File Expand all files Collapse all files

57
Reactivation/BondSet.fs
View File

@@ -2,9 +2,7 @@ namespace Reactivation
open System.Collections.Immutable
type BondSet =
private
| BondSet of ((int * int) * (int * int)) ImmutableHashSet
type BondSet = private | BondSet of ((int * int) * (int * int)) ImmutableHashSet
[<RequireQualifiedAccess>]
module BondSet =
@@ -12,56 +10,51 @@ module BondSet =
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
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
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
bonds.Add (sort source dest) |> BondSet |> Some
else if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then
None
else
if bonds.Contains (sort (sourceX - 1, sourceY) (sourceX, sourceY + 1)) then
None
else
bonds.Add (sort source dest)
|> BondSet
|> Some
bonds.Add (sort source dest) |> BondSet |> Some
else
if distance <> 1 then failwith "bad assumption"
bonds.Add (sort source dest)
|> BondSet
|> Some
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)
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

150
Reactivation/Program.fs
View File

@@ -44,19 +44,21 @@ module Program =
|> List.pairwise
|> List.map (fun (start, next) ->
let instruction =
[1..4]
|> List.filter (fun i ->
start.[i - 1] <> next.[i - 1]
)
[ 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
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)
@@ -66,78 +68,71 @@ module Program =
(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)
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
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"
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
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
@@ -146,11 +141,10 @@ module Program =
exampleBonds
|> List.choose (fun (srcX, srcY) ->
match examplePlacement.TryGetValue ((srcX, srcY)) with
| true, w ->
Some ((srcX, srcY), w)
| false, _ ->
None
| true, w -> Some ((srcX, srcY), w)
| false, _ -> None
)
munged
)
@@ -170,6 +164,7 @@ module Program =
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
@@ -179,6 +174,7 @@ module Program =
match arr.[row - minY, col - minX] with
| '\000' -> printf "."
| _ -> printf "O"
printfn ""
0
0

24
Reactivation/Seq.fs
View File

@@ -5,16 +5,24 @@ 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))
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
| ValueSome (min, max) -> max - min