字符串矩阵，具有唯一的行和列，拉丁方

Question

我正在尝试编写一个函数，为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”，...]，...]这样的列表？

Answer 1

注：因为我们可以轻松地获取一个从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中仅出现一次，因此我们可以使用第二个：

my_cs_urn = [(c,s) | c <- [1..n], s <- [1..n]]
创建拉丁方块是通过删除匹配的球(r,c)和s在每个位置(r,s)用符号(c,s)填充（即，从每个中删除两个球），以便每个球仅使用了一次。我们的状态将是骨灰盒的内容。

我们需要回溯，因为我们可能会到达一个特定位置(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是不确定性的，因此它将尝试从every中拾取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
这可以生成大小为3的所有12个拉丁方格：

λ> 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编译，它的速度足以在几秒钟内枚举大小为5的所有161280平方：

main :: IO ()
main = print $ length $ runM 5 latin
上面的基于列表的ur表示不是很有效。另一方面，由于列表的长度很小，因此通过找到更有效的表示形式并不会获得太多。

尽管如此，这是完整的代码，它使用有效的Map / Set表示形式，这些表示形式是根据rs和cs骨灰盒的使用方式定制的。用-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
这足够快，可以在几分钟内枚举所有大小为7的16,942,080个缩小的拉丁方格：
$ 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