Haskell 字符串矩阵，具有唯一的列和行，拉丁方
我试着写一个函数，对于n，它给出了矩阵n*n和唯一的行和列（拉丁方）。 我得到了一个函数，它给出了我的字符串列表“1”。。"2" .. “n” 我试图生成所有的排列，它们都是n长度的排列元组，它们检查它在行/列中是否唯一。但是复杂度（n！）^2对于2和3来说是完美的，但是当n>3时，它需要永远。可以直接从排列构建拉丁方，例如从Haskell 字符串矩阵，具有唯一的列和行，拉丁方,haskell,math,functional-programming,permutation,complexity-theory,Haskell,Math,Functional Programming,Permutation,Complexity Theory,我试着写一个函数，对于n，它给出了矩阵n*n和唯一的行和列（拉丁方）。 我得到了一个函数，它给出了我的字符串列表“1”。。"2" .. “n” 我试图生成所有的排列，它们都是n长度的排列元组，它们检查它在行/列中是否唯一。但是复杂度（n！）^2对于2和3来说是完美的，但是当n>3时，它需要永远。可以直接从排列构建拉丁方，例如从 permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"]
permutation ( numSymbol 3) = [["1","2","3"],["1","3","2"],["2","1","3"],["2","3","1"],["3","1","2"],["3","2","1"]]
type StateList s = StateT s []
sr（r，s）（r，s）（c，s）s（r，c）s（r，s）（c，s）type Urn = [(Int,Int)]
data S = S
{ size :: Int
, rs :: Urn
, cs :: Urn }
尺寸读取器中，但这更简单
我们将通过按行主要顺序排列的单元格内容列表（即位置[（1,1），（1,2），…，（1,n），（2,1），…，（n，n）]
中的符号）来表示正方形：
现在，生成拉丁方的一元操作如下所示：
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]
大部分工作由助手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
第二个，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 })
这可以生成大小为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
上面基于列表的urn表示不是很有效。另一方面，由于列表的长度非常小，因此通过寻找更高效的表示法并不能获得多少好处
尽管如此，这里还是有一个完整的代码，它使用了高效的地图/集合表示法，这些表示法是根据rs
和cs
urn的使用方式定制的。使用-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 2 3 fill in question marks 1 2 3
2 ? ? =====================> 2 3 1
3 ? ? in row-major order 3 1 2
这足够快，可以在几分钟内枚举所有大小为7的16942080个缩减拉丁方：
$ 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
您使用的是什么permutations
实现？“从permutations构建拉丁方”-我不会尝试。相反，你应该只生成那些你首先可以用于拉丁方的排列。预期的结果是什么？你能找到的第一个拉丁方？全部的或者只是所有的拉丁方？我建议不要在拉丁方中使用字符串作为符号。可以尝试单个char
s，也可以只尝试Int
s，如果您想要自定义符号，那么在最后执行map
ping。@Bergi我使用自己的排列排列：：（Eq a）=>[a]->[a]]。寻找所有的同位素拉丁方。我想做“1”…“N”拉丁方，一个“…”第N个字母“拉丁方，如果可能的话，把它合并成希腊拉丁语
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 })
runM :: Int -> M a -> [a]
runM n act = evalStateT act (S n p p)
where p = pairs n
λ> 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],...]
λ> length $ runM 4 latin
576
main :: IO ()
main = print $ length $ runM 5 latin
{-# 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)
-- 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]
λ> 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
$ 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