17x17: Deterministic algorithm for singlecoloring a grid
I finally got some time to code up a messy script to test out a few variations of an algorithm to generate rectanglefree 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 codedump. The algorithm is essentially:

color cell,

turn to the right,

stop on first nonrectangle 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 rectanglefree 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 newlycolored 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,y1)
move E (x,y) = (x+1,y)
move N (x,y) = (x,y+1)
move W (x,y) = (x1,y)