Matrix of string, with unique columns and rows, latin square

Question

i'm trying to write a function that for n gives matrix n*n with unique rows and columns (latin square). I got function that gives my list of strings "1" .. "2" .. "n"

numSymbol:: Int -> [String]

I tried to generate all permutations of this, and them all n-length tuples of permutations, and them check if it is unique in row / columns. But complexity (n!)^2 works perfect for 2 and 3, but with n > 3 it takes forever. It is possible to build latin square from permutations directly, for example from

permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]] 

get

[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]

without generating list like [["1",...],["1",...],...], when we know first element disqualify it ?

Answer 1

Note: since we can easily take a Latin square that's been filled with numbers from 1 to n and re-label it with anything we want, we can write code that uses integer symbols without giving anything away, so let's stick with that.

Anyway, the stateful backtracking/nondeterministic monad:

type StateList s = StateT s []

is helpful for this sort of problem.

Here's the idea. We know that every symbol s is going to appear exactly once in each row r, so we can represent this with an urn of all possible ordered pairs (r,s):

my_rs_urn = [(r,s) | r <- [1..n], s <- [1..n]]

Similarly, as every symbol s appears exactly once in each column c, we can use a second urn:

my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]

Creating a Latin square is matter of filling in each position (r,c) with a symbol s by removing matching balls (r,s) and (c,s) (i.e., removing two balls, one from each urn) so that every ball is used exactly once. Our state will be the content of the urns.

We need backtracking because we might reach a point where for a particular position (r,c), there is no s such that (r,s) and (c,s) are both still available in their respective urns. Also, a pleasant side-effect of list-based backtracking/nondeterminism is that it'll generate all possible Latin squares, not just the first one it finds.

Given this, our state will look like:

type Urn = [(Int,Int)]

data S = S
  { size :: Int
  , rs :: Urn
  , cs :: Urn }

I've included the size in the state for convenience. It won't ever be modified, so it actually ought to be in a Reader instead, but this is simpler.

We'll represent a square by a list of cell contents in row-major order (i.e., the symbols in positions [(1,1),(1,2),...,(1,n),(2,1),...,(n,n)]):

data Square = Square
  Int   -- square size
  [Int] -- symbols in row-major order
  deriving (Show)

Now, the monadic action to generate latin squares will look like this:

type M = StateT S []

latin :: M Square
latin = do
  n <- gets size
  -- for each position (r,c), get a valid symbol `s`
  cells <- forM (pairs n) (\(r,c) -> getS r c)
  return $ Square n cells

pairs :: Int -> [(Int,Int)]
pairs n = -- same as [(x,y) | x <- [1..n], y <- [1..n]]
          (,) <$> [1..n] <*> [1..n]

The worker function getS picks an s so that (r,s) and (c,s) are available in the respective urns, removing those pairs from the urns as a side effect. Note that getS is written non-deterministically, so it'll try every possible way of picking an s and associated balls from the urns:

getS :: Int -> Int -> M Int
getS r c = do
  -- try each possible `s` in the row
  s <- pickSFromRow r
  -- can we put `s` in this column?
  pickCS c s
  -- if so, `s` is good
  return s

Most of the work is done by the helpers pickSFromRow and pickCS. The first, pickSFromRow picks an s from the given row:

pickSFromRow :: Int -> M Int
pickSFromRow r = do
  balls <- gets rs
  -- "lift" here non-determinstically picks balls
  ((r',s), rest) <- lift $ choices balls
  -- only consider balls in matching row
  guard $ r == r'
  -- remove the ball
  modify (\st -> st { rs = rest })
  -- return the candidate "s"
  return s

It uses a choices helper which generates every possible way of pulling one element out of a list:

choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
  where f a (x:b) = (x, a++b)
        f _ _ = error "choices: internal error"

The second, pickCS checks if (c,s) is available in the cs urn, and removes it if it is:

pickCS :: Int -> Int -> M ()
pickCS c s = do
  balls <- gets cs
  -- only continue if the required ball is available
  guard $ (c,s) `elem` balls
  -- remove the ball
  modify (\st -> st { cs = delete (c,s) balls })

With an appropriate driver for our monad:

runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
  where p = pairs n

this can generate all 12 Latin square of size 3:

λ> runM 3 latin
[Square 3 [1,2,3,2,3,1,3,1,2],Square 3 [1,2,3,3,1,2,2,3,1],...]

or the 576 Latin squares of size 4:

λ> length $ runM 4 latin
576

Compiled with -O2, it's fast enough to enumerate all 161280 squares of size 5 in a couple seconds:

main :: IO ()
main = print $ length $ runM 5 latin

The list-based urn representation above isn't very efficient. On the other hand, because the lengths of the lists are pretty small, there's not that much to be gained by finding more efficient representations.

Nonetheless, here's complete code that uses efficient Map/Set representations tailored to the way the rs and cs urns are used. Compiled with -O2, it runs in constant space. For n=6, it can process about 100000 Latin squares per second, but that still means it'll need to run for a few hours to enumerate all 800 million of them.

{-# OPTIONS_GHC -Wall #-}

module LatinAll where

import Control.Monad.State
import Data.List
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!))
import qualified Data.Map as Map

data S = S
  { size :: Int
  , rs :: Map Int [Int]
  , cs :: Set (Int, Int) }

data Square = Square
  Int   -- square size
  [Int] -- symbols in row-major order
  deriving (Show)

type M = StateT S []

-- Get Latin squares
latin :: M Square
latin = do
  n <- gets size
  cells <- forM (pairs n) (\(r,c) -> getS r c)
  return $ Square n cells

-- All locations in row-major order [(1,1),(1,2)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [1..n] <*> [1..n]

-- Get a valid `s` for position `(r,c)`.
getS :: Int -> Int -> M Int
getS r c = do
  s <- pickSFromRow r
  pickCS c s
  return s

-- Get an available `s` in row `r` from the `rs` urn.
pickSFromRow :: Int -> M Int
pickSFromRow r = do
  urn <- gets rs
  (s, rest) <- lift $ choices (urn ! r)
  modify (\st -> st { rs = Map.insert r rest urn })
  return s

-- Remove `(c,s)` from the `cs` urn.
pickCS :: Int -> Int -> M ()
pickCS c s = do
  balls <- gets cs
  guard $ (c,s) `Set.member` balls
  modify (\st -> st { cs = Set.delete (c,s) balls })

-- Return all ways of removing one element from list.
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
  where f a (x:b) = (x, a++b)
        f _ _ = error "choices: internal error"

-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
  where rs0 = Map.fromAscList $ zip [1..n] (repeat [1..n])
        cs0 = Set.fromAscList $ pairs n

main :: IO ()
main = do
  print $ runM 3 latin
  print $ length (runM 4 latin)
  print $ length (runM 5 latin)

Somewhat remarkably, modifying the program to produce only reduced Latin squares (i.e., with symbols [1..n] in order in both the first row and the first column) requires changing only two functions:

-- All locations in row-major order, skipping first row and column
-- i.e., [(2,2),(2,3)..(n,n)]
pairs :: Int -> [(Int,Int)]
pairs n = (,) <$> [2..n] <*> [2..n]

-- Run an action in the M monad.
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n rs0 cs0)
  where -- skip balls [(1,1)..(n,n)] for first row
        rs0 = Map.fromAscList $ map (\r -> (r, skip r)) [2..n]
        -- skip balls [(1,1)..(n,n)] for first column
        cs0 = Set.fromAscList $ [(c,s) | c <- [2..n], s <- skip c]
        skip i = [1..(i-1)]++[(i+1)..n]

With these modifications, the resulting Square will include symbols in row-major order but skipping the first row and column. For example:

λ> runM 3 latin
[Square 3 [3,1,1,2]]

means:

1 2 3  fill in question marks  1 2 3
2 ? ?  =====================>  2 3 1
3 ? ?    in row-major order    3 1 2

This is fast enough to enumerate all 16,942,080 reduced Latin squares of size 7 in a few minutes:

$ stack ghc -- -O2  -main-is LatinReduced LatinReduced.hs && time ./LatinReduced
[1 of 1] Compiling LatinReduced     ( LatinReduced.hs, LatinReduced.o )
Linking LatinReduced ...
16942080

real    3m9.342s
user    3m8.494s
sys     0m0.848s