Forth Solution to Grecian Computer Puzzle

I got this puzzle a while ago as a present. It is a wooden puzzle made up of rotating discs of numbers. The goal is to line up the discs so that all the numbers add up to 42. What makes this especially complicated is that most of the discs have gaps in them, and therefore propagate numbers up from below depending on their position.

As an exercise, I wanted to see if I could write a memory-space efficient Forth program which would solve this puzzle.

In principle, this seemed like a simple idea, as I only need to represent the discs in memory and rotate them methodically, checking along the way for the solution. The trickiest part, however, was figuring out how to represent these discs in memory, while preserving their holes, and figuring out how to overlay them properly.

In the approach I took, there is one 48 byte memory space representing the board as a composite of the discs:

decimal
create board 48 allot

The first disc, the bottom one, is easy because it has no holes. This is represented by another 48 byte array.

create disc0
 2 c,  5 c, 10 c,  7 c, 16 c,  8 c,  7 c,  8 c,  8 c,  3 c,  4 c, 12 c,
 3 c,  3 c, 14 c, 14 c, 21 c, 21 c,  9 c,  9 c,  4 c,  4 c,  6 c,  6 c,
 8 c,  9 c, 10 c, 11 c, 12 c, 13 c, 14 c, 15 c,  4 c,  5 c,  6 c,  7 c,
14 c, 11 c, 14 c, 14 c, 11 c, 14 c, 11 c, 14 c, 11 c, 11 c, 14 c, 11 c,

For the other discs, I will also use byte arrays. However, I have to represent the holes some how. The most practical choice is to use the number zero, which is not used anywhere on the actual board, and conveniently maps to the boolean false value in Forth. So, I create disc1, disc2, and so on. You see that my number of rows shrinks with each disc.

create disc1
 1 c,  0 c,  9 c,  0 c, 12 c,  0 c,  6 c,  0 c, 10 c,  0 c, 10 c,  0 c,
 3 c, 26 c,  6 c,  0 c,  2 c, 13 c,  9 c,  0 c, 17 c, 19 c,  3 c, 12 c,
 9 c, 20 c, 12 c,  3 c,  6 c,  0 c, 14 c, 12 c,  3 c,  8 c,  9 c,  0 c,
 7 c,  0 c,  9 c,  0 c,  7 c, 14 c, 11 c,  0 c,  8 c,  0 c, 16 c,  2 c,

create disc2
 5 c,  0 c, 10 c,  0 c,  8 c,  0 c, 22 c,  0 c, 16 c,  0 c,  9 c,  0 c,
21 c,  6 c, 15 c,  4 c,  9 c, 18 c, 11 c, 26 c, 14 c,  1 c, 12 c,  0 c,
 9 c, 13 c,  9 c,  7 c, 13 c, 21 c, 17 c,  4 c,  5 c,  0 c,  7 c,  8 c, 

create disc3
14 c,  0 c,  9 c,  0 c, 12 c,  0 c,  4 c,  0 c,  7 c, 15 c,  0 c,  0 c,
11 c,  6 c, 11 c,  0 c,  6 c, 17 c,  7 c,  3 c,  0 c,  6 c,  0 c, 11 c,

create disc4
 3 c,  0 c,  6 c,  0 c, 10 c,  0 c,  7 c,  0 c, 15 c,  0 c,  8 c,  0 c,

Now, how to manipulate the board? The computationally simple and space-efficient approach is to simple rotate the bytes in place. So, here is my row rotation function, followed by one that rotates a whole disc. (Please forgive some of my inconsistent parameter descriptions…)

: rot-row ( addr -- )
    dup 11 + c@ swap ( c a )
    11 0 u+do
        dup 10 + i - c@ swap ( c c a )
        dup 11 + i - ( c c a a )
        rot ( c a a c )
        swap c! ( c a )
    loop
    c!
;

: rot-disc ( addr n )
    0 u+do
        dup 12 i * +
        rot-row loop
    drop
;

Having all the discs, and a way to rotate each of them, eventually I would need a procedure to stack them onto the board:

: overlay ( a a u -- )
    12 * 0 u+do ( a1 a2 )
        dup i + c@ ( a1 a2 c )
        dup 0<> if
            2 pick ( a1 a2 c a1 )
            i + c! ( a1 a2 )
        else drop
        endif
    loop
    drop drop
;

: overlay-all
    board disc0 4 overlay
    board disc1 4 overlay
    board 12 + disc2 3 overlay
    board 24 + disc3 2 overlay
    board 36 + disc4 1 overlay
;

We are pretty close now. I need a function to check for a solution, which is simple addition of the columns on the board:

: solved? ( -- bool )
    true
    12 0 u+do
        board i + c@
        board 12 i + + c@
        board 24 i + + c@
        board 36 i + + c@
        + + +
        42 <> if drop false leave then
    loop
;

Now, I’ve got to walk through rotating all the discs, checking for a solution in each case. I chose to do this with five nested procedures, which each handle their disc with the appropriate minor variations. (A nested loop would have worked also.)

: solve4 ( -- bool )
    false
    12 0 u+do
        overlay-all
        solved? if drop true leave else disc4 1 rot-disc then
    loop
;

: solve3 ( -- bool )
    false
    12 0 u+do
        solve4 if drop true leave else disc3 2 rot-disc then
    loop
;

: solve2 ( -- bool )
    false
    12 0 u+do
        solve3 if drop true leave else disc2 3 rot-disc then
    loop
;

: solve1 ( -- bool )
    false
    12 0 u+do
        solve2 if drop true leave else disc1 4 rot-disc then
    loop
;
    
: solve ( -- bool )
    false
    12 0 u+do
        solve1 if drop true leave else disc0 4 rot-disc then
    loop
;

Now, I just need to run the solve procedure. It should return -1 (true) and then I can print the board with the command board 48 dump, which prints the board memory.

Unfortunately, I did this, and after a few seconds, the program instead return 0 (false) meaning there is no solution. Naturally, I expected there was some fault in my coding, and I dived into debugging. After an hour of carefully checking code, and inserting debugging code here and there, I was still getting the same result, and getting discouraged.

At one point, I inserted some code that would, at least, allow me to see the closest solution. I found one solution that had all columns adding up to 42, and one column adding up to 47. I did a quick Internet search, and found this revelation on the Project Genius website!

Yes, indeed, I happened to own one of the defective early models, which had a misprint. I edited my disc0 array to read 3 instead of 8 in that location (already corrected above). The edited program found the solution quickly.

christopher@nightshade ~/Repos/grecian-computer$ gforth grecian-computer.fs
Gforth 0.7.3, Copyright (C) 1995-2008 Free Software Foundation, Inc.
Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'
Type `bye' to exit
solve . board 48 dump -1 
7F1CC5748238: 01 05 09 07  0C 08 06 08 - 0A 03 0A 0C  16 1A 10 0E  ................
7F1CC5748248: 09 0D 05 09  0A 13 08 0C - 0B 04 0E 07  0F 0D 15 0E  ................
7F1CC5748258: 0F 09 09 0C  08 07 03 0E - 06 08 0A 0B  07 0B 0F 06  ................
 ok

One must translate between hexidecimal to decimal, and then map the four arrays of twelve bytes onto the board, which gives you the solution (SPOILER WARNING!)

The Forth code above is provided under the GPLv3+ license:

    Copyright 2020 Christopher Howard

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <https://www.gnu.org/licenses/>.