[[ネタ記録庫/sudoku]]
yet another [#x8235231]
* yet another [#x8235231]
- 解説 http://d.hatena.ne.jp/Gemma/20070128
- 2次元配列仕様、16x16に対応。solve は複数解をリストで返します。ここではそのheadをとっているので、解がひとつ見つかりしだい終了します。 - げんま 06/11/25
import System
import List
import Array
import Char
import Monad
dim = 16
sqrtdim = 4
isSingle [x] = True
isSingle _ = False
slice n [] = []
slice n l = a:(slice n b) where (a,b) = splitAt n l
allCells = range ((0,0),(dim-1,dim-1))
rowCells idx =
let (row,col) = idx
in range ((row,0),(row,dim-1))
colCells idx =
let (row,col) = idx
in range ((0,col),(dim-1,col))
boxCells idx =
let (row,col) = idx
a = (row `div` sqrtdim) * sqrtdim
b = (col `div` sqrtdim) * sqrtdim
in range ((a,b),(a+(sqrtdim-1),b+(sqrtdim-1)))
unfixedCells ar = filter (?idx -> not (isSingle (ar!idx))) allCells
arrayList ar = [ar!idx | idx <- allCells]
logicalSolve ar =
let ar' = foldl f ar $ unfixedCells ar
where f ar idx = ar//[(idx, getCandidate ar idx)]
ar'' = foldl f ar' $ unfixedCells ar'
where f ar idx =
case find isSingle $ map (?func -> ar!idx ?? concat [ar!n | n <- func idx, n /= idx]) [rowCells, colCells, boxCells] of
Nothing -> ar
Just x -> ar//[(idx, x)]
in
if any (?idx -> ar!idx /= ar''!idx) $ allCells
then logicalSolve ar''
else ar''
candarList ar = [ar//[(idx,[x])] | x <- ar!idx] where idx = head $ unfixedCells ar
solve ar | all (?idx -> isSingle (ar!idx)) $ allCells = return ar
| any (?idx -> (ar!idx) == []) $ allCells = fail "fail"
| otherwise = do candar <- candarList ar
solve (logicalSolve candar)
getCandidate ar idx =
let used = concat [ar!x | x <- rowCells idx ++ colCells idx ++ boxCells idx, isSingle (ar!x)]
in
[1..dim] ?? used
main :: IO ()
main = do
[file] <- getArgs
contents <- readFile file
let start = listArray ((0,0),(dim-1,dim-1))
$ map (?x -> if x == [0] then [1..dim] else x)
$ map (?x -> [(mdigitToInt x)]) (concat (lines contents))
printArray (head (solve (logicalSolve start)))
where printArray ar = mapM_ putStrLn $ (slice dim l)
where l = map mintToDigit (concat (arrayList ar))
mdigitToInt x | isDigit x = digitToInt x
| x == 'a' = 10
| x == 'b' = 11
| x == 'c' = 12
| x == 'd' = 13
| x == 'e' = 14
| x == 'f' = 15
| x == 'g' = 16
| otherwise = -1
mintToDigit x | x < 10 = intToDigit x
| x == 10 = 'a'
| x == 11 = 'b'
| x == 12 = 'c'
| x == 13 = 'd'
| x == 14 = 'e'
| x == 15 = 'f'
| x == 16 = 'g'
| otherwise = '0'
入力
050g02c00f70b080
0008500f300dc000
c0e0100b80090d03
0f00030000e00010
3000006974000001
00b5380000fc6700
208700500a00df04
0c0e00400d009030
006080f00c030b00
490fcab005g83027
00c0000340000500
80030007b000a00c
0e006f3008c100b0
03d0000cf0000g60
004b00000000fc00
f0004b0e50670008
出力
d53ge2c61f74b98a
b128549f3gadce76
c7e41gab86592df3
af96d378cbe2541g
3afd2c6974beg851
94b538dg21fc67ae
2687be519a3gdfc4
1cgef74a6d85923b
7g6285f4ac13eb9d
491fcabde5g83627
ebca912347d685gf
8d53g6e7b29fa14c
ge796f32d8c14ab5
53d1a98cfe4b7g62
684b7d15g32afce9
f2ac4bge596713d8
timeは、0m2.065s @ Pen4 2.6GHz
*Prolog(sue)[#q7446ee0]
-プログラム
?- use_module(library(bounds)).
resolve([Row1,Row2,Row3,Row4,Row5,Row6,Row7,Row8,Row9]) :-
rowCheck([Row1,Row2,Row3,Row4,Row5,Row6,Row7,Row8,Row9]),
columnCheck(Row1,Row2,Row3,Row4,Row5,Row6,Row7,Row8,Row9),
blockCheck([Row1,Row2,Row3]),
blockCheck([Row4,Row5,Row6]),
blockCheck([Row7,Row8,Row9]),
label(Row1),
label(Row2),
label(Row3),
label(Row4),
label(Row5),
label(Row6),
label(Row7),
label(Row8),
label(Row9).
rowCheck([]).
rowCheck([Row|Rows]) :-
Row in 1..9,
all_different(Row),
rowCheck(Rows).
columnCheck([],[],[],[],[],[],[],[],[]).
columnCheck([N1|Row1],[N2|Row2],[N3|Row3],[N4|Row4],[N5|Row5],[N6|Row6],[N7|Row7],[N8|Row8],[N9|Row9]) :-
all_different([N1, N2, N3, N4, N5, N6, N7, N8, N9]),
columnCheck(Row1, Row2, Row3, Row4, Row5, Row6, Row7, Row8, Row9).
blockCheck([Row1,Row2,Row3]) :-
nth1(1, Row1, N11),
nth1(2, Row1, N12),
nth1(3, Row1, N13),
nth1(1, Row2, N21),
nth1(2, Row2, N22),
nth1(3, Row2, N23),
nth1(1, Row3, N31),
nth1(2, Row3, N32),
nth1(3, Row3, N33),
all_different([N11, N12, N13, N21, N22, N23, N31, N32, N33]),
nth1(4, Row1, N14),
nth1(5, Row1, N15),
nth1(6, Row1, N16),
nth1(4, Row2, N24),
nth1(5, Row2, N25),
nth1(6, Row2, N26),
nth1(4, Row3, N34),
nth1(5, Row3, N35),
nth1(6, Row3, N36),
all_different([N14, N15, N16, N24, N25, N26, N34, N35, N36]),
nth1(7, Row1, N17),
nth1(8, Row1, N18),
nth1(9, Row1, N19),
nth1(7, Row2, N27),
nth1(8, Row2, N28),
nth1(9, Row2, N29),
nth1(7, Row3, N37),
nth1(8, Row3, N38),
nth1(9, Row3, N39),
all_different([N17, N18, N19, N27, N28, N29, N37, N38, N39]).
-実行結果
?- time(resolve(
[[N11, N12, 6, N14, N15, N16, N17, N18, 1],
[N21, 7, N23, N24, 6, N26, N27, 5, N29],
[8, N32, N33, 1, N35, 3, 2, N38, N39],
[N41, N42, 5, N44, 4, N46, 8, N48, N49],
[N51, 4, N53, 7, N55, 2, N57, 9, N59],
[N61, N62, 8, N64, 1, N66, 7, N68, N69],
[N71, N72, 1, 2, N75, 5, N77, N78, 3],
[N81, 6, N83, N84, 7, N86, N87, 8, N89],
[2, N92, N93, N94, N95, N96, 4, N98, N99]]
)).
% 218,588 inferences, 0.05 CPU in 0.05 seconds (94% CPU, 4371760 Lips)
N11 = 5,
N12 = 3,
N14 = 8,
N15 = 2,
・
・
・
長いので略．
一応合ってるっぽい．
拡張性無い & もっとスマートに書けるはず．
でもやっぱり速い．なぜ?
* original [#g4b15298]
11月13日のネタ。とりあえず9x9限定です。
とりあえずソースはこんな感じでした。みなさんにいろいろとつっこまれましたが、とりあえず修正はしてません。それにしてもgoはいただけないね、我ながら。
(追記)Haskell Hackerにデバッグしていただきました！
-- Leftが不確定要素(リスト)でRightが確定要素
import System
import Array
-- 最初のLeftを見つけて候補のリストを作る。
go ar = case first 0 of
Nothing -> [Right ar]
Just n -> map (?c -> Left $ ar//[(n,Right c)]) (getCandidate n)
where
first n = if n>80 then
Nothing
else
case ar!n of
Right _ -> first (n+1)
Left _ -> Just n
-- 候補のリストを作る関数
getCandidate n =
let used = getRow n ar ++ getCol n ar ++ getBox n ar in
[x|x<-"123456789", notElem x used]
-- 9x9 の数独を想定。使われている関数を見つけ出す関数
getRow n ar = let row = n `div` 9 in
concatMap (?n -> case ar!(row*9+n) of
Right x -> [x]
Left _ -> []) [0..8]
getCol n ar = let col = n - (n `div` 9 * 9) in
concatMap (?n -> case ar!n of
Right x -> [x]
Left _ -> []) [col,col+9..col+72]
getBox n ar = let line = n `div` 9 -- 行
col = n - (n `div` 9 * 9) -- 列
-- i = line `div` 3 -- 左上のy
i = line `div` 3 * 3 -- 左上のy <- ここを修正!
j = col `div` 3 * 3 -- 左上のx
in
concatMap (?n -> case ar!n of
Right x -> [x]
Left _ -> []) [x*9+y|x<-[i..i+2], y<-[j..j+2]]
-- ファイルからデータを読み込んで最初の配列を作る
main :: IO ()
main = do args <- getArgs
case args of
[] -> return ()
_ -> do contents <- readFile (args!!0)
let start = array (0,80) $ zip [0..]
[if cs=='0' then Left "0" else Right cs|cs<-contents, cs/='?n']
answer = next [Left start]
putStr9 $ map (?n -> fromRight $ answer!n) [0..80]
where
next ars = case get ars of -- ここを回る
[a] -> a -- found!
[] -> next (next' ars >>= go) -- not yet found
next' [] = [] -- Leftをはがす関数
next' (x:xs) = case x of
Left ars -> ars : next' xs
Right _ -> error "you never see this message."
get [] = [] -- 終了したもの(Right)があるかどうか
get (x:xs) = case x of
Right a -> [a]
Left _ -> get xs
putStr9 [] = return ()
putStr9 str = do let (a,b) = splitAt 9 str
putStrLn a
putStr9 b
fromRight x = case x of
Right y -> y
_ -> error "This is left"
入力例。
006000001
070060050
800103200
005040800
040702090
008010700
001205003
060070080
200000400
出力。
536827941
172964358
894153267
715349826
643782195
928516734
481295673
369471582
257638419
ちなみに、PowerPC 1GHzのiBookで
0.16s user 0.02s system 76% cpu 0.236 total
でした。
![[PukiWiki]](image/caml3.jpg "[PukiWiki]")
