字符串矩阵，具有唯一的列和行，拉丁方
Matrix of string, with unique columns and rows, latin square
我正在尝试编写一个函数，为 n 提供具有唯一行和列（拉丁方）的矩阵 n*n。
我得到的函数给出了我的字符串列表 "1" .. "2" .. "n"
numSymbol:: Int -> [String]
我试图生成它的所有排列，它们都是排列的 n 长元组，并且它们检查它在行/列中是否唯一。但是复杂性 (n!)^2 对于 2 和 3 来说是完美的，但是当 n > 3 时，它需要永远。可以直接从排列构建拉丁方，例如从
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
获得
[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]
没有生成像 [["1",...],["1",...],...] 这样的列表，当我们知道第一个元素取消它的资格时？
注意： 因为我们可以很容易地取一个填有从 1 到 n 的数字的拉丁方，然后用任何我们想要的，我们都可以编写使用整数符号的代码而不会泄露任何东西，所以让我们坚持下去。
无论如何，有状态的 backtracking/nondeterministic 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) 来用符号 s 填充每个位置 (r,c) 的问题（即删除两个球, 每个骨灰盒一个) 这样每个球都只使用一次。我们的状态将是骨灰盒中的内容。
我们需要回溯，因为我们可能会到达某个点，对于特定位置 (r,c)，没有 s 这样 (r,s) 和 (c,s) 仍然可用在他们各自的骨灰盒中。此外，基于列表的 backtracking/nondeterminism 的一个令人愉快的副作用是它会生成所有可能的拉丁方，而不仅仅是它找到的第一个。
鉴于此，我们的状态将如下所示：
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 瓮中可用，如果是则将其删除：
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],...]
或大小为 4 的 576 个拉丁方块：
λ> length $ runM 4 latin
576
使用 -O2 编译，它的速度足以在几秒钟内枚举所有 161280 个大小为 5 的方块：
main :: IO ()
main = print $ length $ runM 5 latin
上面基于列表的骨灰盒表示不是很有效。另一方面，由于列表的长度非常小，因此 通过找到更有效的表示形式并没有太大的收获。
尽管如此，这里的完整代码使用了针对 rs 和 cs 瓮的使用方式量身定制的高效 Map/Set 表示。用 -O2 编译，它 运行 在常量 space 中。对于 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
我正在尝试编写一个函数，为 n 提供具有唯一行和列（拉丁方）的矩阵 n*n。 我得到的函数给出了我的字符串列表 "1" .. "2" .. "n"
numSymbol:: Int -> [String]
我试图生成它的所有排列，它们都是排列的 n 长元组，并且它们检查它在行/列中是否唯一。但是复杂性 (n!)^2 对于 2 和 3 来说是完美的，但是当 n > 3 时，它需要永远。可以直接从排列构建拉丁方，例如从
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
获得
[[["1","2","3",],["2","1","3"],["3","1","2"]] , ....]
没有生成像 [["1",...],["1",...],...] 这样的列表，当我们知道第一个元素取消它的资格时？
注意： 因为我们可以很容易地取一个填有从 1 到 n 的数字的拉丁方，然后用任何我们想要的，我们都可以编写使用整数符号的代码而不会泄露任何东西，所以让我们坚持下去。
无论如何，有状态的 backtracking/nondeterministic 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) 来用符号 s 填充每个位置 (r,c) 的问题（即删除两个球, 每个骨灰盒一个) 这样每个球都只使用一次。我们的状态将是骨灰盒中的内容。
我们需要回溯，因为我们可能会到达某个点，对于特定位置 (r,c)，没有 s 这样 (r,s) 和 (c,s) 仍然可用在他们各自的骨灰盒中。此外，基于列表的 backtracking/nondeterminism 的一个令人愉快的副作用是它会生成所有可能的拉丁方，而不仅仅是它找到的第一个。
鉴于此，我们的状态将如下所示：
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 瓮中可用，如果是则将其删除：
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],...]
或大小为 4 的 576 个拉丁方块：
λ> length $ runM 4 latin
576
使用 -O2 编译，它的速度足以在几秒钟内枚举所有 161280 个大小为 5 的方块：
main :: IO ()
main = print $ length $ runM 5 latin
上面基于列表的骨灰盒表示不是很有效。另一方面，由于列表的长度非常小，因此 通过找到更有效的表示形式并没有太大的收获。
尽管如此，这里的完整代码使用了针对 rs 和 cs 瓮的使用方式量身定制的高效 Map/Set 表示。用 -O2 编译，它 运行 在常量 space 中。对于 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