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

注意：因为我们可以很容易地取一个填充了从 1 到n的数字的拉丁方格，并用我们想要的任何东西重新标记它，我们可以编写使用整数符号的代码而不泄露任何东西，所以让我们坚持下去。

无论如何，有状态的回溯/非确定性单子：

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在状态中。它永远不会被修改，所以它实际上应该在 a 中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],...]

或 576 个大小为 4 的拉丁方格：

λ> length $ runM 4 latin
576

使用编译-O2，它的速度足以在几秒钟内枚举所有 161280 个大小为 5 的正方形：

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

上面基于列表的 urn 表示不是很有效。另一方面，由于列表的长度非常小，因此通过找到更有效的表示并没有太多好处。

尽管如此，这里有完整的代码，它使用了针对 thers和csurn 的使用方式量身定制的高效 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

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

问题描述

解决方案

推荐阅读