Примечание: , поскольку мы можем легко взять латинский квадрат, заполненный числами от 1 до n , и пометить его как угодно, мы можем написать код, который использует целочисленные символы, ничего не отдавая, поэтому давайте придерживаться этого.
В любом случае, отслеживание состояния / недетерминированность c монада:
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)
Теперь действие monadi c для генерации латинских квадратов будет выглядеть так:
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 })
С соответствующим драйвером для нашей монады:
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 на основе списка не очень эффективно. С другой стороны, поскольку длины списков довольно малы, не так уж много, чтобы получить , находя более эффективные представления.
Тем не менее, вот полный код, который использует эффективные Map / Установите представления с учетом способа использования урн rs и cs. Скомпилированный с -O2, он работает в постоянном пространстве. При n = 6 он может обрабатывать около 100000 латинских квадратов в секунду, но это все равно означает, что ему потребуется несколько часов, чтобы перечислить все 800 миллионов из них.
{-# 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