[[ネタ記録庫/Haskell]] #contents * 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 でした。