Note: this is part of a series of posts is related to the “17×17 Challenge” posted by Bill Gasarch. The goal is to color cells of a 17 by 17 grid, using only four colors, such that no rectangle is formed from four cells of the same color.

In my last post I noticed that all of the smaller optimal single-colorings I generated showed diagonal symmetry, meaning that row 1 is the same as column 1, row 8 is the same as column 8, etc. It’s my hypothesis that all complete single-colorings are symmetrical in this way.

I decided to play with making the known 74-cell subset symmetrical by applying rotations and came up with this:

Figuring out an automorphism that would give me that diagonal symmetry was easier than inputting the original points into Google Spreadsheet. The colors show the hints that helped anchor the rotations. (I’m going to try to come up with an algorithm for permuting a grid into a symmetrical form).

It seems that symmetry is a very interesting quality in a graph, but when the Graph Theorists study symmetric graphs, they are looking at graphs with where (as I understand it)

any two linked vertices can be mapped onto any to other linked vertices, resulting in essentially the same graph

…which is much cooler. Another interesting thing to mention is that a valid coloring is essentially a hypergraph where the higher dimensional edges are the row/column relationship. It can be flattened into a graph in any number of ways, for example by connecting every colored cell with it’s four neighbors (possibly itself).

So up next for me is a brute force algorithm for single-colorings generated symmetrically.

This isn’t clear from the docs, and you might try to do this and wonder at the output you got:

*Main> groupBy (< =) [3,4,5,3,2,1,4,4,1,1,2,3,4,5,4,5,6,7]
[[3,4,5,3],[2],[1,4,4,1,1,2,3,4,5,4,5,6,7]]

We can redefine groupBy as follows, so that the supplied predicate function compares adjacent elements one-by-one and returns True if they should be grouped together:

> groupBy' :: (a -> a -> Bool) -> [a] -> [[a]]
> groupBy' c []     = []
> groupBy' c (a:as) = (a:ys) : groupBy' c zs
>     where (ys,zs) = spanC a as
>           spanC _  []    = ([], [])
>           spanC a' (x:xs)
>             | a' `c` x   = let (ps,qs) = spanC x xs 
>                            in (x:ps,qs)
>             | otherwise = ([], x:xs)

Now we can use the groupBy function to return a list of ascending lists, like we (probably) wanted:

*Main> groupBy' (< =) [3,4,5,3,2,1,4,4,1,1,2,3,4,5,4,5,6,7]
[[3,4,5],[3],[2],[1,4,4],[1,1,2,3,4,5],[4,5,6,7]]

The functionality is of course the same for groupBy (==).

A function like group is in this category. It’s conceptually very simple, but defining it actually requires a bit of indirection. Here I’ve translated the definition from Data.List to use explicit recursion:

66 > group :: (Eq a) => [a] -> [[a]]
67 > group []     = []
68 > group (a:as) = (a:ys) : group zs
69 >     where (ys,zs) = spanEq as
70 >           spanEq []     = ([], [])
71 >           spanEq (x:xs)
72 >             | a == x    = let (ps,qs) = spanEq xs 
73 >                            in (x:ps,qs)
74 >             | otherwise = ([], x:xs)
75

I think if I were asked to define this having never seen it, the first thing I would think of would be something using foldl1, which wouldn’t work.

EDIT: see also an alternative definition for Data.List.groupBy

import Data.List (sortBy)

-- takes an inversion list and converts it to the list of permuted
-- elements:
decode = dec [] . sortBy lowHi . zip [1..]  where
    dec as []         = as
    dec as ((a,_):is) = let is' = sortBy lowHi (decrementGT a is)
                         in dec (a:as) is'

-- decrement every inversion number by 1, for every tuple in which
-- the element is greater than `a`:
decrementGT a = map (\(a',i) -> (a', if a'>a then i-1 else i) )

-- we sort by the inversion number, low to high. For elements with
-- the same inversion number, we say that the greater element tuple
-- should go before a lesser element:
lowHi (a,i) (a',i') 
    | i == i'   = if a>a' then LT else GT
    | otherwise = compare i i'

It’s not the prettiest code I’ve written, but it’s pretty straight-forward and concise. Thanks for looking!

The idea behind the Move-to-Front algorithm is that we start with some known alphabet (like the list of ASCII characters), and encode our data elements as the index into that alphabet list of each element. The trick is that after each character is encoded, the alphabet list is modified by moving the element whose index we just looked up to the front of the alphabet.

Here are my implementations of encode and decode:

import Data.List


mtf :: (Eq a, Bounded a, Enum a)=> [a] -> Maybe [Int]
mtf = sequence . snd . mapAccumL enc [ minBound.. ]
    where enc l x = (x:delete x l, elemIndex x l)


mtfD :: (Eq a, Bounded a, Enum a)=> [Int] -> [a]
mtfD = snd . mapAccumL dec [ minBound.. ]
    where dec l i = let x = l !! i 
                     in (x:delete x l, x)

The mapAccumL function is perfect for passing the state of the dictionary list. Another point of interest to mention is the use of minBound to let the function be polymorphic over any type for which there is a defined order and lowest element.

For example, we can do this:

*Main> mtf “SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES” >>= return . mtfDec :: Maybe String
Just “SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES”

or we can decode to Word8 bytes, if we want to get back the ASCII character in that form, just by specifying a different return type:

*Main> :m + Data.Word
*Main Data.Word> mtf “SIX.MIXED.PIXIES.SIFT.SIXTY.PIXIE.DUST.BOXES” >>= return . mtfDec :: Maybe [Word8]
Just [83,73,88,46,77,73,88,69,68,46,80,73,88,73,69,83, 46,83,73,70,84,46,83,73,88,84,89,46,80,73,88,73,69,46, 68,85,83,84,46,66,79,88,69,83]

Let me know your thoughts!