注意： 因为我们可以很容易地取一个填充了从 1 到 n 的数字的拉丁方格，然后用我们想要的任何东西重新标记它，我们可以编写代码它使用整数符号而不泄露任何东西，所以让我们坚持下去。
无论如何，有状态的回溯/非确定性 monad：
type StateList s = StateT s []
对这类问题很有帮助。
这就是想法。我们知道每个符号 s 在每一行 r 中都会出现一次，所以我们可以用一个包含所有可能的有序对 (r,s) 的瓮来表示：
my_rs_urn = [(r,s) | r <- [1..n], s <- [1..n]]
同样，每个符号 s 在每一列 c 中只出现一次，我们可以使用第二个 urn：
my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]
创建一个拉丁方格是通过删除匹配的球 (r,s) 和 (c,s) 用符号 (r,c) 填充每个位置 (r,c)（即，从每个瓮中删除两个球），以便每个球只使用一次。我们的状态将是骨灰盒的内容。
我们需要回溯，因为我们可能会到达一个点，即对于特定位置 (r,c)，没有 s，因此 (r,s) 和 (c,s) 在各自的骨灰盒中仍然可用。此外，基于列表的回溯/不确定性的一个令人愉快的副作用是它会生成所有可能的拉丁方格，而不仅仅是它找到的第一个方格。
鉴于此，我们的状态将如下所示：
type Urn = [(Int,Int)]
data S = S
{ size :: Int
, rs :: Urn
, cs :: Urn }
为方便起见，我已将size 包含在状态中。它永远不会被修改，所以它实际上应该在 Reader 中，但这更简单。
我们将通过按行优先顺序排列的单元格内容列表来表示一个正方形（即，[(1,1),(1,2),...,(1,n),(2,1),...,(n,n)] 位置上的符号）：
data Square = Square
Int -- square size
[Int] -- symbols in row-major order
deriving (Show)
现在，生成拉丁方格的单子动作将如下所示：
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]
工作函数getS 选择一个s，以便(r,s) 和(c,s) 在各自的骨灰盒中可用，从骨灰盒中删除这些对作为副作用。请注意，getS 是非确定性写入的，因此它会尝试所有可能的方式从骨灰盒中挑选 s 和相关球：
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
大部分工作由助手pickSFromRow 和pickCS 完成。第一个，pickSFromRow 从给定的行中选择一个 s：
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
它使用choices 帮助器生成从列表中拉出一个元素的所有可能方式：
choices :: [a] -> [(a,[a])]
choices = init . (zipWith f <$> inits <*> tails)
where f a (x:b) = (x, a++b)
f _ _ = error "choices: internal error"
第二个，pickCS 检查(c,s) 在cs urn 中是否可用，如果存在则将其删除：
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 })
为我们的 monad 使用适当的驱动程序：
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
where p = pairs n
这可以生成所有 12 个大小为 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],...]
或 576 个大小为 4 的拉丁方格：
λ> length $ runM 4 latin
576
使用-O2 编译，速度足以在几秒钟内枚举所有 161280 个大小为 5 的方格：
main :: IO ()
main = print $ length $ runM 5 latin
上面基于列表的 urn 表示不是很有效。另一方面，由于列表的长度非常小，因此通过找到更有效的表示并没有那么多。
尽管如此，这里有完整的代码，它使用了针对 rs 和 cs urns 的使用方式量身定制的高效 Map/Set 表示。使用-O2 编译，它在恒定空间中运行。对于 n=6，它每秒可以处理大约 100000 个拉丁方格，但这仍然意味着它需要运行几个小时才能枚举全部 8 亿个方格。
{-# 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)
值得注意的是，修改程序以仅生成缩减的拉丁方格（即，符号 [1..n] 在第一行和第一列中都按顺序排列）只需要更改两个函数：
-- 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]
通过这些修改，生成的Square 将包含按行优先顺序排列的符号，但会跳过第一行和第一列。例如：
λ> runM 3 latin
[Square 3 [3,1,1,2]]
意思是：
1 2 3 fill in question marks 1 2 3
2 ? ? =====================> 2 3 1
3 ? ? in row-major order 3 1 2
这足以在几分钟内枚举所有 16,942,080 个大小为 7 的缩减拉丁方格：
$ 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