--
-- !!! OBSOLETE !!! OBSOLETE !!!
-- use sudoku_equiv.cc instead!
--
-- Quick and dirty hack for more symmetry elimination for the Sudoku counting
-- problem. The code is inefficient but gets the job done in a reasonable
-- amount of time.
--
-- This turned out to be inadequate.
--
-- This is a Haskell program (see haskell.org)
--
-- Author: Bertram Felgenhauer
-- History:
-- 2005-05-23: Initial version.
--
-- It's based on a hint by A F Jarvis in a personal email.
--
-- result: divides the 36288 possible configurations of boxes 2, 3 into
-- 1089 equivalence classes
-- after implementing some more of afj's ideas, 306 equivalence classes remain
import List
-- I was lazy: permutations code is from
-- http://www.haskell.org/pipermail/haskell-cafe/2002-June/003122.html
-- with a small bug fix.
selections :: [a] -> [(a,[a])]
selections [] = []
selections (x:xs) = (x, xs) : [ (y, x:ys) | (y, ys) <- selections xs ]
permutations :: [a] -> [[a]]
permutations [] = [[]]
permutations xs = [ y:zs | (y, ys) <- selections xs, zs <- permutations ys ]
overlap :: Eq a => [a] -> [a] -> Bool
overlap a b = or [ any (x==) b | x <- a ]
-- generate a list of box 2 and 3 configurations, normalized
-- by the first column.
box23 :: [[[Int]]]
box23 = [ [p1, p2, p3] |
p1 <- permutations [4, 5, 6, 7, 8, 9],
p1!!0 < p1!!1, p1!!1 < p1!!2,
p1!!3 < p1!!4, p1!!4 < p1!!5,
p1!!0 < p1!!3,
p2 <- permutations [1, 2, 3, 7, 8, 9],
not $ overlap (take 3 p1) (take 3 p2),
not $ overlap (drop 3 p1) (drop 3 p2),
p3 <- permutations [1, 2, 3, 4, 5, 6],
not $ overlap (take 3 p1) (take 3 p3),
not $ overlap (drop 3 p1) (drop 3 p3),
not $ overlap (take 3 p2) (take 3 p3),
not $ overlap (drop 3 p2) (drop 3 p3) ]
-- transpose :: [[a]] -> [[a]]
-- transpose = foldr (zipWith (:)) (repeat [])
{-
> Hmm, I guess you're exploiting the 6!^2 possible renamings of the
> digits 1-9 that leave the first box unchanged up to a permutation
> of rows and a permutation of columns here. I wonder if there's a
> good way to incorporate that into my program directly. Food for
> thought...
-}
-- normalize a given configuration of boxes 2 and 3:
-- new: also consider choosing a different block as the first block and
-- rename accordingly
-- if boxes contain a rectangle ab, also consider ba as equivalent
-- ba ab
-- first, adjoin box 1, then apply all the possible renamings mentioned above,
-- then reorder the rows according to box 1, then order box 2 columns and
-- box 3 columns and then the two boxes; finally take the smallest of those
-- according to lexicographic order.
{-
normalize :: [[Int]] -> [[Int]]
normalize pi = (sort $ map norm_ $
[ [ [ maybe (-1) id $ lookup x ren | x <- p ] |
p <- zipWith (++) [[1, 2, 3], [4, 5, 6], [7, 8, 9]] pi ] |
ren <- renamings ] ) !! 0 where
renamings :: [[(Int, Int)]]
renamings = [ zip [1..9] $ concat x |
x <- concat $ map (permutations.transpose) $
permutations [[1, 4, 7], [2, 5, 8], [3, 6, 9]] ]
norm_ :: [[Int]] -> [[Int]]
norm_ pi = let q = transpose $ map (drop 3) $ sort pi in
transpose $ concat $ sort [sort $ take 3 q, sort $ drop 3 q]
-}
ren0 :: [[Int]] -> [[[Int]]]
ren0 p = let pp = [[[1, 2, 3], [4, 5, 6], [7, 8, 9]],
map (take 3) p, map (drop 3) p] in
[ [ [ maybe (-1) id $ lookup x (zip (concat a) [1..9]) | x <- l ] |
l <- zipWith (++) b c ] | (a, [b, c]) <- selections pp ]
ren1 :: [[Int]] -> [[[Int]]]
ren1 pp = ren1_ pp 0 0 1 1 where
ren1_ pp 5 _ _ _ = [pp]
ren1_ pp x1 2 _ _ = ren1_ pp (x1+1) 0 (x1+2) 1
ren1_ pp x1 y1 6 _ = ren1_ pp x1 (y1+1) (x1+1) (y1+1)
ren1_ pp x1 y1 x2 3 = ren1_ pp x1 y1 (x2+1) (y1+1)
ren1_ pp x1 y1 x2 y2 = if pp!!y1!!x1 == pp!!y2!!x2 &&
pp!!y2!!x1 == pp!!y1!!x2 then
ren1_ pp x1 y1 x2 (y2+1) ++
ren1_ (replace pp) x1 y1 x2 (y2+1)
else
ren1_ pp x1 y1 x2 (y2+1) where
replace pp = take y1 pp ++
[ take x1 (pp!!y1) ++
[pp!!y2!!x1] ++
(take (x2-x1-1) $ drop (x1+1) (pp!!y1)) ++
[pp!!y1!!x1] ++
(take (6-1-x2) $ drop (x2+1) (pp!!y1)) ] ++
(take (y2-y1-1) $ drop (y1+1) pp) ++
[ take x1 (pp!!y2) ++
[pp!!y1!!x1] ++
(take (x2-x1-1) $ drop (x1+1) (pp!!y2)) ++
[pp!!y2!!x1] ++
(take (6-1-x2) $ drop (x2+1) (pp!!y2)) ] ++
(take (3-1-y2) $ drop (y2+1) pp)
normalize :: [[Int]] -> [[Int]]
normalize pi = (sort $ equiv pi) !! 0
equiv pi = map norm_ $
[ [ [ maybe (-1) id $ lookup x ren | x <- p ] |
p <- zipWith (++) [[1, 2, 3], [4, 5, 6], [7, 8, 9]] pii ] |
ren <- renamings,
pi' <- ren0 pi,
pii <- ren1 pi' ] where
renamings :: [[(Int, Int)]]
renamings = [ zip [1..9] $ concat x |
x <- concat $ map (permutations.transpose) $
permutations [[1, 4, 7], [2, 5, 8], [3, 6, 9]] ]
norm_ :: [[Int]] -> [[Int]]
norm_ pi = let q = transpose $ map (drop 3) $ sort pi in
transpose $ concat $ sort [sort $ take 3 q, sort $ drop 3 q]
-- generate raw list: (1.3s)
-- main = sequence $ map print $ box23
-- generate corresponding normalized list:
main = sequence $ map print $ map normalize $ box23