お絵かきロジックアナライザ開発記   その9

“候補範囲”という概念を導入し、お絵かきロジックにおける人間の思考法則の第一歩をクリアしましたので、次にこれを利用して「半分越えたら塗潰し」をコード化していきます。

半分越えたら塗潰し

‘塗潰し’や‘空白’をシート上で視覚的に実現するために、最終的には「塗潰しはセル背景を黒にする」「空白は斜め罫線で×印にする」「未定部分は何もしない」というルールでコード化を進めるのですが、これから解説するコードに行き着くまで、かなりの紆余曲折がありました。まず最初はセルに‘未定’や‘塗潰し’、‘空白’を示す数値をセットしてやり、数値そのものは表示させずに[条件付書式]で数値によってセルの見せ方を変えるというものでした。しかし塗潰しは[条件付書式]で簡単に操作できるのですが、罫線を操作しようとしてもなぜか斜線は変更できないということに気付き、やむなく[セルの書式設定]を併用するコトにしました。セルの値が負数なら[セルの書式設定]で全角文字の‘×’を表示させ、ゼロまたは正数の場合は何も表示させないようにし、[条件付書式]では正数(1以上)の場合に背景色を黒くするという曲芸のような組合せワザで当初は乗り切っていました。つまりセルに-1をセットすれば空白、1をセットすれば塗潰し、0をセットするか何もしなければ未定と言うことになります。開発の初期段階ではしばらくこの方式を採用していました。

しかしループ内でのセル参照は処理時間の面で大変不利(簡単なプログラムを組んで比べてみればすぐに判りますが格段に違います)な上、[条件付書式]で斜線を操作できない点が気に入らず、結局この方法は断念しました。候補範囲などと同様に配列変数を設け、その内容に応じてVBAからセルの書式設定を操作する方法を採ります。

フィールド値の定義

フィールドの各マスがどのような状態なのかを保存するため、動的配列ImgFieldを設定します。これはフィールドのマスと一対一に対応するものなので、フィールドサイズと同じ大きさの配列となります。

Sub AnalyzeSheet(Optional ByVal CallSwitch As Boolean)
' シート分析
  Dim HintLen As Integer                          '列内ヒント数
  Dim HintSumHrz As Integer                       '水平ヒント値合計
  Dim HintSumVrt As Integer                       '垂直ヒント値合計
  Dim ScanCnt As Integer                          'スキャンカウンタ
  Dim HintCnt As Integer                          'ヒントカウンタ
  Dim HintPos As Integer                          'ヒントポインタ
  Dim FieldCnt As Integer                         'フィールドカウンタ
  Dim FieldPos As Integer                         'フィールドポインタ
  Dim Discrep As Boolean                          '矛盾フラグ
  Dim ErrorMsg As String                          'エラーメッセージ
  Dim ImgField() As Byte                          '描画フィールド
  Dim HintHrz() As Integer                        '水平ヒント
  Dim HintVrt() As Integer                        '垂直ヒント
  Dim HintCntHrz() As Integer                     '水平ヒント数
  Dim HintCntVrt() As Integer                     '垂直ヒント数
  Dim PndStHrz() As Integer                       '水平未解決ヒント始点
  Dim PndEnHrz() As Integer                       '水平未解決ヒント終点
  Dim PndStVrt() As Integer                       '垂直未解決ヒント始点
  Dim PndEnVrt() As Integer                       '垂直未解決ヒント終点
  Dim PssStHrz() As Integer                       '水平候補範囲始点
  Dim PssEnHrz() As Integer                       '水平候補範囲終点
  Dim PssStVrt() As Integer                       '垂直候補範囲始点
  Dim PssEnVrt() As Integer                       '垂直候補範囲終点
  '＜初期設定＞
  ReDim ImgField(FieldHt, FieldWd)                '描画フィールド領域再定義
  ReDim HintHrz(FieldHt, HintWd)                  'ヒント領域再定義
  ReDim HintVrt(FieldWd, HintHt)
    ....

フィールド値は未定、塗潰し、空白の区別に加え、背理法の導入を視野に入れて‘確定’した状態なのか、取り敢ず‘仮定’的な状態なのかを示すための情報が必要になります。ビット配列は以下の通りとし、配列はByte型変数としています。

   ┏━┯━┯━┯━┯━┯━┯━┯━┓
   ┃０│０│０│０│０│Ｄ│Ｓ│Ｂ┃
   ┗━┷━┷━┷━┷━┷━┷━┷━┛
                         │  │  └ 塗潰フラグ
  ０：未定               │  └── 空白フラグ
  １：仮定塗潰           └──── 確定フラグ（０：仮定段階／１：確定状態）
  ２：仮定空白
  ３：仮定矛盾→仮定不成立
  ４：（使用しない）
  ５：確定塗潰
  ６：確定空白
  ７：確定矛盾→処理中断

実際に使用するのは下位3bitだけなので、数値としては0〜7で各マスの状態を区別することになります。演算により、塗潰しと判断されれば最下位1bitをONにし、同じく空白と判断されれば第2bitをONにします。一通りの演算終了時に第1bit、第2bitが両方ともONになっていたら矛盾となります。

半分を超えたら塗潰し確定

それではお絵かきロジックの基本的な解法である「ヒント値が候補範囲幅の半分を越える場合、範囲幅からヒント値を減じた数の未定部分を両端に残し、中央部分は塗潰しが確定する」というルールをコード化していきましょう。ここまでできあがればページ冒頭の例題は解析完了します。先程で取得した“候補範囲”の幅に対して、それに対応するヒント値が半分を超えたかどうかを判定し、適合する場合は範囲中央部の塗潰しを行うというコードになります。

ここでは一回の解析で解答が得られてしまうのですが、実際の解析では横方向が終わったら縦方向、それが終わったらまた横方向といったカタチで何度もループ処理を繰返して解答に辿り着きます。ループ内で行う‘候補範囲の半分判定’も同じ処理内容になるので、サブプロシージャ化しておきましょう。そうするとシート分析に必要な様々な変数がローカルであることが不都合になってきます。宣言部で変数宣言を行い、NonoModule内のどこでも利用できるようにしておかなければなりません。

Option Explicit                                   '強制変数宣言
Option Base 1                                     '配列最小添字=1
' モジュール内共用変数宣言
Dim HintLen As Integer                            '列内ヒント数
Dim HintSumHrz As Integer                         '水平ヒント値合計
Dim HintSumVrt As Integer                         '垂直ヒント値合計
Dim ScanCnt As Integer                            'スキャンカウンタ
Dim HintCnt As Integer                            'ヒントカウンタ
Dim HintPos As Integer                            'ヒントポインタ
Dim FieldCnt As Integer                           'フィールドカウンタ
Dim FieldPos As Integer                           'フィールドポインタ
Dim Discrep As Boolean                            '矛盾フラグ
Dim ErrorMsg As String                            'エラーメッセージ
Dim ImgField() As Byte                            '描画フィールド
Dim HintHrz() As Integer                          '水平ヒント
Dim HintVrt() As Integer                          '垂直ヒント
Dim HintCntHrz() As Integer                       '水平ヒント数
Dim HintCntVrt() As Integer                       '垂直ヒント数
Dim PndStHrz() As Integer                         '水平未解決ヒント始点
Dim PndEnHrz() As Integer                         '水平未解決ヒント終点
Dim PndStVrt() As Integer                         '垂直未解決ヒント始点
Dim PndEnVrt() As Integer                         '垂直未解決ヒント終点
Dim PssStHrz() As Integer                         '水平候補範囲始点
Dim PssEnHrz() As Integer                         '水平候補範囲終点
Dim PssStVrt() As Integer                         '垂直候補範囲始点
Dim PssEnVrt() As Integer                         '垂直候補範囲終点
    ....

Sub AnalyzeSheet(Optional ByVal CallSwitch As Boolean)
' シート分析
  Dim HintLen As Integer                          '列内ヒント数
  Dim HintSumHrz As Integer                       '水平ヒント値合計
  Dim HintSumVrt As Integer                       '垂直ヒント値合計
  Dim ScanCnt As Integer                          'スキャンカウンタ
  Dim HintCnt As Integer                          'ヒントカウンタ
  Dim HintPos As Integer                          'ヒントポインタ
  Dim FieldCnt As Integer                         'フィールドカウンタ
  Dim FieldPos As Integer                         'フィールドポインタ
  Dim Discrep As Boolean                          '矛盾フラグ
  Dim ErrorMsg As String                          'エラーメッセージ
  Dim ImgField() As Byte                          '描画フィールド
  Dim HintHrz() As Integer                        '水平ヒント
  Dim HintVrt() As Integer                        '垂直ヒント
  Dim HintCntHrz() As Integer                     '水平ヒント数
  Dim HintCntVrt() As Integer                     '垂直ヒント数
  Dim PndStHrz() As Integer                       '水平未解決ヒント始点
  Dim PndEnHrz() As Integer                       '水平未解決ヒント終点
  Dim PndStVrt() As Integer                       '垂直未解決ヒント始点
  Dim PndEnVrt() As Integer                       '垂直未解決ヒント終点
  Dim PssStHrz() As Integer                       '水平候補範囲始点
  Dim PssEnHrz() As Integer                       '水平候補範囲終点
  Dim PssStVrt() As Integer                       '垂直候補範囲始点
  Dim PssEnVrt() As Integer                       '垂直候補範囲終点
  '＜初期設定＞
  ReDim ImgField(FieldHt, FieldWd)                '描画フィールド領域再定義
  ReDim HintHrz(FieldHt, HintWd)                  'ヒント領域再定義
  ReDim HintVrt(FieldWd, HintHt)
    ....

AnalyzeSheetプロシージャ内から宣言部にカット&ペーストで移動してやればOKです(インデントの調整はしておいて下さいね)。

それでは塗潰しチェックのサブプロシージャを追加してこれを呼出してみましょう。既に取得した候補範囲から範囲幅を算出し、ヒント値と比較して2分の1を越えていれば中央部分を塗潰す動作になります。

Sub BlackOutCheck(Optional ByVal CallSwitch As Boolean)
' 塗潰しチェック
' ヒント値が候補範囲の１／２を越える場合、中央部塗潰が確定する。ヒント値と候補範
' 囲が等しければ塗潰ブロックが確定する。
  Dim BlockSt As Integer                          'ブロック始点
  Dim BlockEn As Integer                          'ブロック終点
  Dim BlockLen As Integer                         'ブロック長
  Dim HintVal As Integer                          '対象ヒント値
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    For HintCnt = 1 To HintCntHrz(ScanCnt)
      BlockSt = PssStHrz(ScanCnt, HintCnt)        'ブロック始点取得
      BlockEn = PssEnHrz(ScanCnt, HintCnt)        'ブロック終点取得
      BlockLen = BlockEn - BlockSt + 1            'ブロック長算出
      HintVal = HintHrz(ScanCnt, HintCnt)         '対象ヒント値取得
      If BlockEn - HintVal < 0 Then               'エラーチェック
        Discrep = True
        Exit For
      End If
      If BlockSt + HintVal > FieldWd + 1 Then     'エラーチェック
        Discrep = True
        Exit For
      End If
      If HintVal > BlockLen / 2 Then              '黒塗潰あり
        For FieldCnt = BlockEn - HintVal + 1 To BlockSt + HintVal - 1
          ImgField(ScanCnt, FieldCnt) = ImgField(ScanCnt, FieldCnt) Or &H1
          NonoWorksheet.Cells(HintHt + ScanCnt, HintWd + FieldCnt) _
            .Interior.ColorIndex = 16
        Next FieldCnt
      End If
    Next HintCnt
    If Discrep Then Exit For
  Next ScanCnt
  If Discrep Then Exit Sub
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldWd
    For HintCnt = 1 To HintCntVrt(ScanCnt)
      BlockSt = PssStVrt(ScanCnt, HintCnt)        'ブロック始点取得
      BlockEn = PssEnVrt(ScanCnt, HintCnt)        'ブロック終点取得
      BlockLen = BlockEn - BlockSt + 1            'ブロック長算出
      HintVal = HintVrt(ScanCnt, HintCnt)         '対象ヒント値取得
      If BlockEn - HintVal < 0 Then               'エラーチェック
        Discrep = True
        Exit For
      End If
      If BlockSt + HintVal > FieldHt + 1 Then     'エラーチェック
        Discrep = True
        Exit For
      End If
      If HintVal > BlockLen / 2 Then              '黒塗潰あり
        For FieldCnt = BlockEn - HintVal + 1 To BlockSt + HintVal - 1
          ImgField(FieldCnt, ScanCnt) = ImgField(FieldCnt, ScanCnt) Or &H1
          NonoWorksheet.Cells(HintHt + FieldCnt, HintWd + ScanCnt) _
            .Interior.ColorIndex = 16
        Next FieldCnt
      End If
    Next HintCnt
    If Discrep Then Exit For
  Next ScanCnt
End Sub

ヒントエラーを発見するとDiscrepフラグが立ちますが、エラー処理はまだ手を付けていないので途中でサブプロシージャを抜けるだけです。それではこのプロシージャを呼出すコードを追加します。

Sub AnalyzeSheet(Optional ByVal CallSwitch As Boolean)
' シート分析
  '＜初期設定＞
  ReDim ImgField(FieldHt, FieldWd)                '描画フィールド領域再定義
  ReDim HintHrz(FieldHt, HintWd)                  'ヒント領域再定義
  ReDim HintVrt(FieldWd, HintHt)
    ....

    ....
  If HintSumHrz <> HintSumVrt Then
    Discrep = True
    ErrorMsg = "水平ヒントの合計と垂直ヒントの合計とが" _
      & vbNewLine & "一致しません。"
    GoTo ExitAnalyzeSheet
  End If
  '＜フィールド分析＞
  NonoModule.BlackOutCheck                        '初回塗潰しチェック
  '＜終了表示＞
ExitAnalyzeSheet:
  If Discrep Then                                 '矛盾チェック
    MsgBox ErrorMsg, vbCritical + vbOKOnly, "分析エラー"
  End If
End Sub

メニューバーの[Nonogram]から[シート分析]をクリックすると1回だけ塗潰しチェックが行われ、ここでの例題は解答が得られます。今後は様々なアプローチにより候補範囲を絞りつつ、何度もループ処理で塗潰しチェックを行い、完成に向う形態にしていきます。

イラストを消す

今後分析の試行を繰返すことになるのですが、セル上に前回実行時の残骸が残るので、これがジャマになってきます。イメージ部分をキレイに消去するコマンドが必要です。

Sub NonoMenuAdd(Optional ByVal CallSwitch As Boolean)
' メニュー追加
  Dim MenuBar As CommandBar                       'メニューバーオブジェクト
  Set MenuBar = Application.CommandBars("Worksheet Menu Bar")
  If MenuBar.FindControl(Tag:="Nonogram") Is Nothing Then
    With MenuBar.Controls.Add(Type:=msoControlPopup)
      .Caption = "Nonogram(&N)"                   'メニュー追加
      .Tag = "Nonogram"
      With .Controls.Add                          'コマンド追加
        .Caption = "新規作成(&N)"
        .OnAction = "NonoModule.FieldSizeDialog"
        .FaceId = 18
      End With
      With .Controls.Add
        .Caption = "イメージ消去(&E)"
        .OnAction = "NonoModule.EraseImg"
        .FaceId = 47
      End With
      With .Controls.Add
        .Caption = "シート分析(&Z)"
        .OnAction = "NonoModule.AnalyzeSheet"
        .FaceId = 532
      End With
    End With
  End If
  Set MenuBar = Nothing                           'オブジェクト変数開放
End Sub

Sub EraseImg(Optional ByVal CallSwitch As Boolean)
' イラスト消去
  With NonoField                                  'イメージ消去
    .Interior.ColorIndex = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlLineStyleNone
    .Borders(xlDiagonalDown).LineStyle = xlLineStyleNone
  End With
End Sub

Function NonoField() As Range
' 描画フィールド
  Set NonoField = NonoWorksheet.Range(Cells(HintHt + 1, HintWd + 1) _
    , Cells(HintHt + FieldHt, HintWd + FieldWd))
End Function

三つのプロシージャを立続けに列挙しましたが総てNonoModuleモジュール内です。一つ目のコード追加はメニューへのイメージ消去コマンド追加なので問題ないでしょう。二つ目が消去コマンド本体で、背景色と斜線を消しているところです。三つ目は消去コマンド内で使用しているイメージフィールドをRangeオブジェクトとして返すFunctionプロシージャです。システムシートのところで考察してきたものの仲間ですね。

イメージ部分の消去コマンドができたので、分析開始時には常にイメージ消去を行ってから分析を進めるようにしておきます。AnalyzeSheetプロシージャの先頭でイメージ消去コマンドを呼出しておきましょう。

Sub AnalyzeSheet(Optional ByVal CallSwitch As Boolean)
' シート分析
  '＜初期設定＞
  ReDim ImgField(FieldHt, FieldWd)                '描画フィールド領域再定義
  ReDim HintHrz(FieldHt, HintWd)                  'ヒント領域再定義
  ReDim HintVrt(FieldWd, HintHt)
  ReDim HintCntHrz(FieldHt)                       'ヒント数領域再定義
  ReDim HintCntVrt(FieldWd)
  ReDim PndStHrz(FieldHt)                         '水平未解決ヒント領域再定義
  ReDim PndEnHrz(FieldHt)
  ReDim PndStVrt(FieldWd)                         '垂直未解決ヒント領域再定義
  ReDim PndEnVrt(FieldWd)
  ReDim PssStHrz(FieldHt, HintWd)                 '水平候補範囲領域再定義
  ReDim PssEnHrz(FieldHt, HintWd)
  ReDim PssStVrt(FieldWd, HintHt)                 '垂直候補範囲領域再定義
  ReDim PssEnVrt(FieldWd, HintHt)
  NonoWorksheet.Activate                          'ロジックシートアクティブ
  NonoModule.EraseImg                             'イメージ消去
  '＜水平ヒント転送＞
  HintSumHrz = 0                                  '水平ヒント値合計初期化
    ....

← 前へ   → 次へ ▲ ページトップ