数独(再挑戦)⑦ 禁断の総当たり
前回は、行・列および3×3の範囲に候補となる数が一つしかないなら、その数で確定させてみた。
infoment.hatenablog.com
今日はいよいよ、禁断の「総当たり」に挑戦する。
出来れば、最後の最後まで論理的に解きたかった。しかしこれ以上は、マクロが複雑になりすぎて、自分でも検証できなくなる。
そこで、こう考えた。ピタゴラスイッチの最初の一押しのように、或いは北斗神拳の経絡秘孔のように、必殺の急所がどこかに一つ有るはずだ。そのセルの数さえ確定させれば、あとはパタパタとゴールまでたどり着く、必殺の一マスが。
※ちなみに前回(半年前)は、総当たりのイメージを具現化できずに挫折していた。
というわけで残ったセルで取りうる値を、一つずつ順番に試してみることにした。
- 空白セルに、取りうる値を一つ入れる。
- 検証。
- 解き切れなかったら、1.に戻る。
そこでまず、指定時点での状態が最終解かどうかを返す関数を作成。
' 最終解の正誤判定。 ' 正・・・True ' 誤・・・False Private Function CheckAnswer() As Boolean Dim i As Long For i = 1 To 9 ' 全セル中、1~9までの数が9個以外の場合、間違い。 If ArrayCountIF(AnswerArray, i) <> 9 Then CheckAnswer = False Exit Function End If Next CheckAnswer = True End Function
次いで、未確定セルの情報で、多段階配列を作成する。
' (あくまでこのマクロ内における)論理的解法で解き切れなかった残り。 Private Function UnfixedArray() As Variant Dim arr() As Variant ReDim arr(1 To 27 * 27) Dim i As Long: i = 1 Dim r As Long Dim c As Long ' 27×27の中に残っている0以外の数値のうち、セルの値を ' 確定しきれなかったもので多段階配列を作成する。 For r = 1 To 27 For c = 1 To 27 Dim r2 As Long: r2 = WorksheetFunction.RoundUp(r / 3, 0) Dim c2 As Long: c2 = WorksheetFunction.RoundUp(c / 3, 0) If TempArray(r, c) <> 0 Then If FixedNumber(r2, c2) = 0 Then arr(i) = Array(r2, c2, CLng(TempArray(r, c))) i = i + 1 End If End If Next Next ReDim Preserve arr(1 To i - 1) UnfixedArray = arr End Function
これを元に、既存のSetAnswerを改修した。
Public Sub SetAnswer() Dim r As Long Dim c As Long Dim n As Long Dim SumAll As Long Dim Counter As Long: Counter = 1 ' 編集の有無を確認するために、予め配列の合計値を求めておく。 ' ※何らかの編集があれば、1以上の値が0に置き換わり、合計も変わる。 SumAll = WorksheetFunction.Sum(TempArray) ' 編集の前後で合計値の差が無くなるまで、つまり何も置き換わらなくなる ' まで繰り返す。 Do For r = 1 To 9 For c = 1 To 9 n = FixedNumber(r, c) If n <> 0 Then DeleteNumber r, c, n End If Next Next UniqueExistence ' 一巡したところで解答取得。 GetAnswerArray ' 解答貼り付け範囲に、解答を格納した配列を貼り付け。 DestinationRange = AnswerArray ' 0.2秒待つ。 Application.Wait [Now() + "00:00:00.2"] Dim arr As Variant Dim iMax As Long Dim SaveArray As Variant ' ------------------↓↓今回追加したところ↓↓------------------ If SumAll <> WorksheetFunction.Sum(TempArray) Then SumAll = WorksheetFunction.Sum(TempArray) Else If CheckAnswer Then Exit Do If Counter = 1 Then ' 未確定情報を配列に格納。 arr = UnfixedArray ' 総当たりの最大回数。 iMax = UBound(arr) ' 総当たり突入前の解答を退避させる。 SaveArray = TempArray Else ' 解答を総当たり前の状態に戻す。 TempArray = SaveArray End If Dim r_index As Long r_index = arr(Counter)(0) Dim c_index As Long c_index = arr(Counter)(1) Dim fixed_number As Long fixed_number = arr(Counter)(2) FixedCell r_index, c_index, fixed_number Application.StatusBar = "総当たりモード中:" & Counter & " / " & iMax & "巡目" Counter = Counter + 1 End If ' ------------------↑↑今回追加したところ↑↑------------------ ' 念のため、仮の措置として、27×27回繰り返したらループを抜ける。 If Counter >= 27 * 27 Then Exit Do Loop End Sub
テスト用のマクロを再掲。
Sub test() Dim Sudoku As New Sudoku ' 出題範囲をセット。 Set Sudoku.SourceRange = Sheet1.Range("A1:I9") ' 解答貼り付け先をセット。 Set Sudoku.DestinationRange = Sheet1.Range("K1:S9") ' 初期化。 Sudoku.InitArray ' 解答貼り付け。 Sudoku.SetAnswer End Sub
なお、総当たりになった時点で、以下の調整を行っている。
- 貼り付け後の待ち時間を1秒 ⇒ 0.2秒に短縮(ここが一番時間が掛かるので)
- ステータスバーに、総当たり何巡目かを表示
テスト結果がこちら。
画面左下のステータスバーを見て頂ければ、総当たりモード3巡目で正解に辿り着けたことが分かる。今回は運が良かったが、最後まで正解に辿り着けない可能性もある。
次回は総まとめ、本シリーズの最終回です。
参考まで。