ネタ記録庫/sudoku

Thanks

YEAR OF THE CAT

yet another &dagger;

解説 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) &dagger;

プログラム

?- 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 &dagger;

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"

入力例。

出力。

ちなみに、PowerPC 1GHzのiBookで

0.16s user 0.02s system 76% cpu 0.236 total

でした。

トップページ

OCaml Tips

ネタ記録庫

関数型言語によるWeb開発

ScalaByExample(訳)

限定継続

お勉強リンク

発表資料

活動記録

最新の20件

Thanks

yet another &dagger;

Prolog(sue) &dagger;

original &dagger;