add day 23HEADmaster

1 files changed, 209 insertions, 0 deletions

diff --git a/day23/both.fth b/day23/both.fth
new file mode 100644
index 0000000..d4108b8
--- /dev/null
+++ b/day23/both.fth
@@ -0,0 +1,209 @@
+\ Advent of Code 2022: Day 23, both parts (comment selected)
+\ Written for gForth. TODO improve
+
+46 CONSTANT MEMPTY
+35 CONSTANT MELF
+13 CONSTANT MCR
+10 CONSTANT MLF
+
+0 CONSTANT NOMOVE
+1 CONSTANT NORTH
+2 CONSTANT SOUTH
+3 CONSTANT WEST
+4 CONSTANT EAST
+CREATE DIRECTIONS NORTH , SOUTH , WEST , EAST ,
+
+5000 CONSTANT MAXELVES
+VARIABLE ELVES MAXELVES 2 * CELLS ALLOT
+VARIABLE NEWELVES MAXELVES 2 * CELLS ALLOT
+VARIABLE ELFCOUNT
+
+: RESET ( -- )
+   0 ELFCOUNT ! ;
+
+: NEXTDIR ( dir -- dir )
+  3 AND CELLS DIRECTIONS + @ ;
+
+: ELF ( i -- c-addr )
+   2 * CELLS ELVES + ;
+
+: GETELF ( i -- y x )
+   ELF DUP @ SWAP CELL+ @ ;
+
+: GETNEWELF ( i -- y x )
+   2 * CELLS NEWELVES + DUP @ SWAP CELL+ @ ;
+
+: SETELF ( i y x -- )
+   SWAP ROT ELF TUCK ! CELL+ ! ;
+
+: SETNEWELF ( i y x -- )
+   SWAP ROT 2 * CELLS NEWELVES + TUCK ! CELL+ ! ;
+
+: ADDELF ( y x -- )
+   ELFCOUNT @ -ROT SETELF
+   1 ELFCOUNT +! ;
+
+: SAMEELF? ( i y x -- b )
+   ROT GETELF ROT = -ROT = AND ;
+
+: SAMENEWELF? ( i y x -- b )
+   ROT GETNEWELF ROT = -ROT = AND ;
+
+: ELFAT? ( y x -- b )
+   ELFCOUNT @ 0 DO
+      2DUP I -ROT SAMEELF?
+      IF 2DROP TRUE UNLOOP EXIT THEN
+   LOOP 2DROP FALSE ;
+
+: NEIGHBOR? ( y x -- b )
+   1- SWAP 1- SWAP 0 -ROT
+   3 0 DO
+      3 0 DO
+         2DUP ELFAT? IF
+            ROT 1+ DUP 1 > IF
+               DROP 2DROP TRUE UNLOOP UNLOOP EXIT ELSE
+               -ROT THEN THEN
+         1+
+      LOOP
+      3 - SWAP 1+ SWAP
+   LOOP 2DROP 1 > ;
+
+: NNEIGHBOR? ( y x -- b )
+   1- SWAP 1- SWAP \ y x
+   3 0 DO
+      2DUP ELFAT? IF 2DROP TRUE UNLOOP EXIT THEN
+      1+
+   LOOP 2DROP FALSE ;
+
+: SNEIGHBOR? ( y x -- b )
+   1- SWAP 1+ SWAP
+   3 0 DO
+      2DUP ELFAT? IF 2DROP TRUE UNLOOP EXIT THEN
+      1+
+   LOOP 2DROP FALSE ;
+
+: WNEIGHBOR? ( y x -- b )
+   1- SWAP 1- SWAP
+   3 0 DO
+      2DUP ELFAT? IF 2DROP TRUE UNLOOP EXIT THEN
+      SWAP 1+ SWAP
+   LOOP 2DROP FALSE ;
+
+: ENEIGHBOR? ( y x -- b )
+   1+ SWAP 1- SWAP
+   3 0 DO
+      2DUP ELFAT? IF 2DROP TRUE UNLOOP EXIT THEN
+      SWAP 1+ SWAP
+   LOOP 2DROP FALSE ;
+
+: CANMOVE? ( y x dir -- b )
+   CASE
+   NORTH OF NNEIGHBOR? 0= ENDOF
+   SOUTH OF SNEIGHBOR? 0= ENDOF
+   WEST OF WNEIGHBOR? 0= ENDOF
+   EAST OF ENEIGHBOR? 0= ENDOF
+   ENDCASE ;
+
+: READELVES ( -- )
+   0 0 \ Initial Y and X
+   BEGIN
+      KEY CASE
+      MELF OF 2DUP ADDELF 1+ ENDOF
+      MEMPTY OF 1+ ENDOF
+      MCR OF DROP 1+ 0 ENDOF
+      MLF OF DROP 1+ 0 ENDOF
+      DROP 2DROP EXIT
+      ENDCASE
+   AGAIN ;
+
+: PROPOSE ( i dir -- dir )
+   SWAP GETELF
+   2DUP NEIGHBOR? 0= IF 2DROP DROP NOMOVE EXIT THEN
+   4 0 DO
+      2DUP 4 PICK CANMOVE? IF 2DROP UNLOOP EXIT THEN
+      ROT NEXTDIR -ROT
+   LOOP 2DROP DROP NOMOVE ;
+
+: PROPOSED ( i dir -- y x )
+   SWAP GETELF ROT CASE
+   NORTH OF SWAP 1- SWAP ENDOF
+   SOUTH OF SWAP 1+ SWAP ENDOF
+   WEST OF 1- ENDOF
+   EAST OF 1+ ENDOF
+   ENDCASE ;
+
+: MAKEPROPOSALS ( dir -- )
+   ELFCOUNT @ 0 DO
+      I OVER PROPOSE
+      I SWAP PROPOSED
+      I -ROT SETNEWELF
+   LOOP DROP ;
+
+: UNDOELF ( i -- )
+   DUP GETNEWELF SETELF ;
+
+: COLLISION? ( i -- b )
+   DUP GETNEWELF
+   ELFCOUNT @ 0 DO
+      2DUP I -ROT SAMENEWELF? 3 PICK I <> AND
+      IF 2DROP DROP TRUE UNLOOP EXIT THEN
+   LOOP 2DROP DROP FALSE ;
+
+: COMMITELVES ( -- )
+   ELFCOUNT @ 0 DO
+      I DUP COLLISION? 0= IF DUP GETNEWELF SETELF ELSE DROP THEN
+   LOOP ;
+
+: STILL? ( -- )
+   ELFCOUNT @ 0 DO
+      I DUP GETNEWELF SAMEELF? 0= IF FALSE UNLOOP EXIT THEN
+   LOOP TRUE ;
+
+: DISPELVES ( -- )
+   ELFCOUNT @ 0 DO
+      I GETELF SWAP . . ." , "
+   LOOP CR ;
+
+: DISPNEWELVES ( -- )
+   ELFCOUNT @ 0 DO
+      I GETNEWELF SWAP . . ." , "
+   LOOP CR ;
+
+: SCATTER ( init-dir n -- n )
+   0 -ROT
+   0 DO
+      DUP MAKEPROPOSALS
+      SWAP 1+ SWAP
+      STILL? IF DROP UNLOOP EXIT THEN
+      COMMITELVES
+      NEXTDIR
+   LOOP DROP ;
+
+: XMINMAX ( -- min max )
+   10000 -10000
+   ELFCOUNT @ 0 DO
+      I GETELF NIP \ mi ma x
+      2DUP < IF NIP DUP THEN \ mi ma x
+      DUP 3 PICK < IF ROT DROP SWAP ELSE DROP THEN
+   LOOP ;
+
+: YMINMAX ( -- min max )
+   10000 -10000
+   ELFCOUNT @ 0 DO
+      I GETELF DROP \ mi ma y
+      2DUP < IF NIP DUP THEN
+      DUP 3 PICK < IF ROT DROP SWAP ELSE DROP THEN
+   LOOP ;
+
+: PROGRESS ( -- n )
+   XMINMAX SWAP - 1+
+   YMINMAX SWAP - 1+ *
+   ELFCOUNT @ - ;
+
+RESET
+READELVES
+ELFCOUNT @ . ." elves" CR
+\ NORTH 10 SCATTER PROGRESS . CR \ part 1
+NORTH 0 SCATTER . ." rounds" CR \ part 2 (exec time: 9m31)
+BYE
+