17x17: Deterministic algorithm for single-coloring a grid

I finally got some time to code up a messy script to test out a few variations of an algorithm to generate rectangle-free single colorings of a grid, as part of a lazy humble effort to solve the 17 x 17 challenge.

This post is going to be a bit of a code-dump. The algorithm is essentially:

color cell,
turn to the right,
stop on first non-rectangle forming cell,
if the cell is uncolored, color it and turn to the right, else if the cell was already colored and has been entered from this direction already, then skip it, else turn to the right

I’m not sure if an algorithm exists yet to find rectangle free colorings. The authors of the challenge seem to know of no optimal deterministic algorithm.

The code below produces a rectangle-free subset of 68 colored cells on a 17x17 grid. Apparently the largest known subset is 73 74 (important because 4 subsets of length 73 or 72 one subset of size 73 and three of size 72 would fill a 17x17 grid if they could be made to fit together). So hopefully one of the variations of the algorithm above that I have in mind will be able to match or beat that.

We don’t yet have logic for stopping once a row or column is exhausted, so it will just hang:

module Main
    where

import Data.List
import qualified Data.Map as M
import Data.Maybe
  
-- we move clockwise:  
data Direction = W | N | E | S deriving (Show, Ord, Eq, Enum)

data Cell = FormsRectangle
          | Colored DirectionsEntered
          deriving Show

-- to avoid loops, keep track of which way we've entered a cell :  
type DirectionsEntered = [ Direction ]

type Grid = M.Map (Int,Int) Cell
  
singleColoring :: Int -> [(Int,Int)]
singleColoring n = colorCells M.empty dI turns posI where
    -- start as we enter lower left corner cell...  
    posI = (1,1)
    -- ...moving to the left:  
    (dI:turns) = cycle [W ..]
      
    -- we wrap when moving off the grid:  
    mv d = wrapped . move d
    wrapped (x,y) = (w x, w y) where
        w 0 = n
        w x = if x == (n+1) then 1 else x
  
    -- our coloring algorithm:  
    colorCells g d ts@(d':ds) xy =
        case M.lookup xy g of
              -- color this cell:  
              Nothing -> xy : turnUpdating (color xy d)
              -- NO LOGIC YET FOR STOPPING WHEN WE"VE EXHAUSTED A ROW:  
              Just FormsRectangle -> skip
              Just (Colored es) ->
                if d `elem` es
                    --then []  
                    then skip
                    -- cell colored and we haven't entered this way yet; turn:  
                    else turnUpdating (addEntered d es xy)
                  where skip = colorCells g d ts (mv d xy)
                        turnUpdating f = colorCells (f g) d' ds (mv d' xy)

  
-- insert colored cell, along with markers for the cells that would form  
-- a rectanlge with this newly-colored cell:  
color :: (Int,Int) -> Direction -> Grid -> Grid
color (x,y) d g = M.insert (x,y) (Colored [d]) rectsFormed
  where
    ccs = M.keys $ M.filter isColored g

    -- all x coords of colored cells in same row (i.e. with same y):  
    row = inRow y

    -- all y coords of colored cells in same column:  
    col = inCol x

    -- rectangles would be formed by these coordinates:  
    xyRects = [ (x', y') | x'<- row, y' <- col ]
    xxRects = [ (x, y') | x'<- row, y' <- delete y (inCol x') ]
    yyRects = [ (x', y) | y'<- col, x' <- delete x (inRow y') ]
    corners = xyRects ++ xxRects ++ yyRects
    rectsFormed = foldr (flip M.insert FormsRectangle) g corners
      
    -- some helpers for above:  
    inRow r = [ x' | (x',y') <- ccs, y' == r ]
    inCol c = [ y' | (x',y') <- ccs, x' == c ]
  

isColored (Colored _) = True
isColored _ = False

  
-- mark the cell as having been entered from the direction we're going:  
addEntered :: Direction -> [Direction] -> (Int,Int) -> Grid -> Grid
addEntered d es = M.adjust . const $ Colored (d:es)

  
move S (x,y) = (x,y-1)
move E (x,y) = (x+1,y)
move N (x,y) = (x,y+1)
move W (x,y) = (x-1,y)