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

チェックの対象となるマスが黒か白かを検査する場合に、Do While (ImgField(AreaEn + 1, ScanCnt) And &H3) = &H1などのコードを書いていますが、この‘&H3’とか‘&H3’とかって、ただの数字で味っ気ないですよね。このような「意味のない数値」に「意味のある名前」を付けてあげることで、コード内での数値に意味合いを持たせてあげよう、という取組みとして、ここでは定数定義から始めて行きます。

定数定義

プログラム内で常に一定の値を示す定数を定義していきます。前出ImgField()配列のビット配置を思い出して下さい。

┏━┯━┯━┯━┯━┯━┯━┯━┓ ┃０│０│０│０│０│Ｄ│Ｓ│Ｂ┃ ┗━┷━┷━┷━┷━┷━┷━┷━┛ │ │ └ 塗潰フラグ │ └── 空白フラグ └──── 確定フラグ（０：仮定段階／１：確定状態）

例えば‘確定塗潰し’なら2進数で[00000101]となり、定数のリテラル値は[&H3]ということになります。このようなパターンに名前を付けて、コード内での数値の意味合いを盛込んでいきます。定数定義を行っておくことのメリットとして、リテラル値を変更しなければならなくなった場合に、コード全体に手を加えなくても、宣言文だけを修正すれば済むという点があります。当サイト内では定数の変更はありませんが、開発段階では結構便利な使い方になりますね。


Option Explicit
Option Base 1                                     '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0                         '未定 = 0
Const Black As Byte = &H1                         '塗潰 = 1
Const White As Byte = &H2                         '空白 = 2
Const MaskPtn As Byte = Black Or White            'マスクパターン = 1 or 2 = 3
Const Discrpnc As Byte = Black Or White           '矛盾 = 1 or 2 = 3
Const ConcBit As Byte = &H4                       '確定 = 4
Const BlackInconc As Byte = Black                 '仮定塗潰 = 1
Const WhiteInconc As Byte = White                 '仮定空白 = 2
Const DiscrpInconc As Byte = Discrpnc             '仮定矛盾 = 3
Const BlackConc As Byte = ConcBit Or Black        '確定塗潰 = 5
Const WhiteConc As Byte = ConcBit Or White        '確定空白 = 6
Const DiscrpConc As Byte = ConcBit Or Discrpnc    '確定矛盾 = 7
' モジュール内共用変数宣言
Dim HintLen As Integer                            '列内ヒント数
    ....

定義した定数を使って今までのコードを書き直してみます。


Sub BlackOutCheck(Optional ByVal CallSwitch As Boolean)
' 塗潰しチェック
    ....

    ....
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    ....

    ....
      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
          If (ImgField(ScanCnt, FieldCnt) And Black) <> Black Then
            LpStp1 = True
            ImgField(ScanCnt, FieldCnt) = ImgField(ScanCnt, FieldCnt) Or Black
            NonoWorksheet.Cells(HintHt + ScanCnt, HintWd + FieldCnt) _
              .Interior.ColorIndex = 16
    ....

    ....
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldWd
    ....

    ....
      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
          If (ImgField(FieldCnt, ScanCnt) And Black) <> Black Then
            LpStp1 = True
            ImgField(FieldCnt, ScanCnt) = ImgField(FieldCnt, ScanCnt) Or Black
            NonoWorksheet.Cells(HintHt + FieldCnt, HintWd + ScanCnt) _
              .Interior.ColorIndex = 16
    ....


Sub PSSrenewal(Optional ByVal CallSwitch As Boolean)
' 候補範囲更新
    ....

    ....
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStHrz(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
  'ヒント走査 左→右
      For HintCnt = PndStHrz(ScanCnt) To PndEnHrz(ScanCnt)
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt > PndStHrz(ScanCnt) Then     '未解決左端ヒントは対象外
            Do While (ImgField(ScanCnt, AreaSt - 1) And MaskPtn) = Black
              If AreaSt < FieldWd Then
    ....

    ....
      If Discrep Then Exit For
  'ヒント走査 左←右
      For HintCnt = PndEnHrz(ScanCnt) To PndStHrz(ScanCnt) Step -1
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt < PndEnHrz(ScanCnt) Then     '未解決右端ヒントは対象外
            Do While (ImgField(ScanCnt, AreaEn + 1) And MaskPtn) = Black
              If AreaEn > 1 Then
    ....

    ....
      If Discrep Then Exit For
    End If
  Next ScanCnt
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStVrt(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
  'ヒント走査 上→下
      For HintCnt = PndStVrt(ScanCnt) To PndEnVrt(ScanCnt)
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt > PndStVrt(ScanCnt) Then     '未解決上端ヒントは対象外
            Do While (ImgField(AreaSt - 1, ScanCnt) And MaskPtn) = Black
              If AreaSt < FieldHt Then
    ....

    ....
      If Discrep Then Exit For
  'ヒント走査 上←下
      For HintCnt = PndEnVrt(ScanCnt) To PndStVrt(ScanCnt) Step -1
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt < PndEnVrt(ScanCnt) Then     '未解決下端ヒントは対象外
            Do While (ImgField(AreaEn + 1, ScanCnt) And MaskPtn) = Black
              If AreaEn > 1 Then
    ....

‘&H3’などの無機質な16進表記が、意味のある定数名で書き換えられました。このような配慮は、コーディング中にはあまり役立ちませんが、時間が経ってプログラムを見直すとき、数値の意味合いを示すワードで書かれていると、内容の把握がスムーズになります。

塗潰しと空白の判定と設置

定数で書き直したコード部分は塗潰しを設置する部分と塗潰しかどうかを判定する部分ですが、今後このような処理は他のプロシージャでも同様に行われるため、独立させてみましょう。判定はファンクションプロシージャ、設置はサブプロシージャとし、位置情報を引数としてNonoModuleに以下の追加をします。


Function CheckBlack(ByVal VrtPos As Byte, ByVal HrzPos As Byte) As Boolean
' 塗潰し判定
  CheckBlack = ((ImgField(VrtPos, HrzPos) And MaskPtn) = Black)
End Function


Function CheckWhite(ByVal VrtPos As Byte, ByVal HrzPos As Byte) As Boolean
' 空白判定
  CheckWhite = ((ImgField(VrtPos, HrzPos) And MaskPtn) = White)
End Function


Sub PutBlack(ByVal VrtPos As Byte, ByVal HrzPos As Byte)
' 塗潰し設置
  ImgField(VrtPos, HrzPos) = ImgField(VrtPos, HrzPos) Or BlackConc
  NonoWorksheet.Cells(HintHt + VrtPos, HintWd + HrzPos).Interior.ColorIndex = 16
  LpStp1 = True
  Discrep = ((ImgField(VrtPos, HrzPos) And MaskPtn) = Discrpnc)
End Sub


Sub PutWhite(ByVal VrtPos As Byte, ByVal HrzPos As Byte)
' 空白設置
  ImgField(VrtPos, HrzPos) = ImgField(VrtPos, HrzPos) Or WhiteConc
  With NonoWorksheet.Cells(HintHt + VrtPos, HintWd + HrzPos)
    .Interior.ColorIndex = 2
    With .Borders(xlDiagonalUp)
      .LineStyle = xlContinuous
      .Weight = xlHairline
      .ColorIndex = 16
    End With
    With .Borders(xlDiagonalDown)
      .LineStyle = xlContinuous
      .Weight = xlHairline
      .ColorIndex = 16
    End With
  End With
  LpStp1 = True
  Discrep = ((ImgField(VrtPos, HrzPos) And MaskPtn) = Discrpnc)
End Sub


Sub PutDiscrepancy(ByVal VrtPos As Byte, ByVal HrzPos As Byte)
' 矛盾設置
  ImgField(VrtPos, HrzPos) = ImgField(VrtPos, HrzPos) Or DiscrpConc
  System.AnalyzeField(VrtPos, HrzPos).Interior.ColorIndex = 3
End Sub

新たに書き加えたプロシージャを呼出して、塗潰しの判定と設置を行ってみましょう。実行結果は全く変化しませんが、CheckBlackとかPutBlackといったプロシージャ名により、何をしているのかがより解りやすくなっています。


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
    ....

    ....
      If HintVal > BlockLen / 2 Then              '黒塗潰あり
        For FieldCnt = BlockEn - HintVal + 1 To BlockSt + HintVal - 1
          If (ImgField(ScanCnt, FieldCnt) And Black) <> Black Then
          If Not CheckBlack(ScanCnt, FieldCnt) Then
            LpStp1 = True
            ImgField(ScanCnt, FieldCnt) = ImgField(ScanCnt, FieldCnt) Or Black
            NonoWorksheet.Cells(HintHt + ScanCnt, HintWd + FieldCnt) _
              .Interior.ColorIndex = 16
            NonoModule.PutBlack ScanCnt, FieldCnt
          End If
        Next FieldCnt
      End If
    Next HintCnt
    If Discrep Then Exit For
  Next ScanCnt
  If Discrep Then Exit Sub
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldWd
    ....

    ....
      If HintVal > BlockLen / 2 Then              '黒塗潰あり
        For FieldCnt = BlockEn - HintVal + 1 To BlockSt + HintVal - 1
          If (ImgField(FieldCnt, ScanCnt) And Black) <> Black Then
          If Not CheckBlack(FieldCnt, ScanCnt) Then
            LpStp1 = True
            ImgField(FieldCnt, ScanCnt) = ImgField(FieldCnt, ScanCnt) Or Black
            NonoWorksheet.Cells(HintHt + FieldCnt, HintWd + ScanCnt) _
              .Interior.ColorIndex = 16
            NonoModule.PutBlack FieldCnt, ScanCnt
          End If
        Next FieldCnt
      End If
    Next HintCnt
    If Discrep Then Exit For
  Next ScanCnt
End Sub


Sub PSSrenewal(Optional ByVal CallSwitch As Boolean)
' 候補範囲更新
    ....

    ....
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStHrz(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
  'ヒント走査 左→右
      For HintCnt = PndStHrz(ScanCnt) To PndEnHrz(ScanCnt)
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt > PndStHrz(ScanCnt) Then     '未解決左端ヒントは対象外
            Do While (ImgField(ScanCnt, AreaSt - 1) And MaskPtn) = Black
            Do While CheckBlack(ScanCnt, AreaSt - 1)
              If AreaSt < FieldWd Then
    ....

    ....
      If Discrep Then Exit For
  'ヒント走査 左←右
      For HintCnt = PndEnHrz(ScanCnt) To PndStHrz(ScanCnt) Step -1
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt < PndEnHrz(ScanCnt) Then     '未解決右端ヒントは対象外
            Do While (ImgField(ScanCnt, AreaEn + 1) And MaskPtn) = Black
            Do While CheckBlack(ScanCnt, AreaEn + 1)
              If AreaEn > 1 Then
    ....

    ....
      If Discrep Then Exit For
    End If
  Next ScanCnt
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStVrt(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
  'ヒント走査 上→下
      For HintCnt = PndStVrt(ScanCnt) To PndEnVrt(ScanCnt)
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt > PndStVrt(ScanCnt) Then     '未解決上端ヒントは対象外
            Do While (ImgField(AreaSt - 1, ScanCnt) And MaskPtn) = Black
            Do While CheckBlack(AreaSt - 1, ScanCnt)
              If AreaSt < FieldHt Then
    ....

    ....
      If Discrep Then Exit For
  'ヒント走査 上←下
      For HintCnt = PndEnVrt(ScanCnt) To PndStVrt(ScanCnt) Step -1
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt < PndEnVrt(ScanCnt) Then     '未解決下端ヒントは対象外
            Do While (ImgField(AreaEn + 1, ScanCnt) And MaskPtn) = Black
            Do While CheckBlack(AreaEn + 1, ScanCnt)
              If AreaEn > 1 Then
    ....

塗潰し補範囲更新その2

それでは棚上げになっていた候補範囲更新の続きを考えていきましょう。塗潰しをチェックして候補範囲を狭める条件としては、以下のようなものがありました。

~~範囲外から続く連続塗潰しは除外。ただし単独配属フィールド内で見付かった場合は矛盾。~~
範囲端にヒント値を超える連続塗潰しがある場合は除外。ただし単独配属フィールド内で見付かった場合は矛盾。
単独範囲内にヒント値以下の連続塗潰しがある場合は、そこから計算される範囲に更新。

条件1は前頁でクリアしていますので、次に条件2以降に取組んでいきます。前ページ冒頭のアルファベット‘A’を模した例では、横ラインの上から3行目の候補範囲が、条件3によって縮みそうなコトが予測できますので、これをコーディングしてみましょう。

ところで条件にある「単独範囲内に」を判定しなければならないのですが、これはちょっと工夫すれば縦と横で同じプロシージャ呼出しにより実現できそうです。範囲更新に先立って、対象フィールドがどのヒントに属しているのかをチェックする方法を考えて行きましょう。ヒントへの所属チェックは、水平、垂直の両スキャンで利用できるように独立した別のサブプロシージャとし、モジュール内で共用できる変数HintAttch()を介して情報の受渡しをする構造とします。


Option Explicit                                   '強制変数宣言
Option Base 1                                     '配列最小添字=1
' モジュール内共用変数宣言
Dim HintLen As Integer                            '列内ヒント数
Dim HintSumHrz As Integer                         '水平ヒント値合計
    ....

    ....
Dim PssStVrt() As Integer                         '垂直候補範囲始点
Dim PssEnVrt() As Integer                         '垂直候補範囲終点
Dim HintAttch() As Integer                        '配属先ヒント番号
Dim DuplChk() As Byte                             '配属先重複チェック
Dim LpStp1 As Boolean                             '進捗フラグ

宣言部でHintAttch()とDuplChk()を定義しました。これは縦または横1列分の配列変数で、HintAttch()は各マスが何番目のヒントに所属しているかを示すもので、その後の分析において各プロシージャ内で使用されるもの、DuplChk()はヒントへの所属が重複していないかをチェックする一時変数です。


Sub SetAttachedHint(ByVal HrzFlg As Boolean, ByVal LinePos As Integer)
' 配属先ヒント番号取得
  Dim HintEnd As Byte                             'ライン内ヒント数
  Dim FieldLen As Byte                            'フィールド長
  Dim PndSt As Byte                               '未解決ヒント先頭
  Dim PndEn As Byte                               '未解決ヒント末尾
  Dim HintVal As Integer                          '対象ヒント値
  Dim HintCpy() As Byte                           'ヒント値バッファ
  Dim PssStCpy() As Byte                          '候補範囲始点バッファ
  Dim PssEnCpy() As Byte                          '候補範囲終点バッファ
  Dim HintNum() As Byte                           'ヒント値一時保存
  If HrzFlg Then                                  '水平／垂直方向判定
    HintEnd = HintCntHrz(LinePos)                 'ライン内ヒント数取得
    FieldLen = FieldWd                            'フィールド長取得
    PndSt = PndStHrz(LinePos)                     '未解決ヒント先頭取得
    PndEn = PndEnHrz(LinePos)                     '未解決ヒント末尾取得
    ReDim HintCpy(HintWd)                         'ヒント内容コピー
    ReDim PssStCpy(HintWd)
    ReDim PssEnCpy(HintWd)
    For HintCnt = 1 To HintEnd
      HintCpy(HintCnt) = HintHrz(LinePos, HintCnt)
      PssStCpy(HintCnt) = PssStHrz(LinePos, HintCnt)
      PssEnCpy(HintCnt) = PssEnHrz(LinePos, HintCnt)
    Next HintCnt
  Else
    HintEnd = HintCntVrt(LinePos)                 'ライン内ヒント数取得
    FieldLen = FieldHt                            'フィールド長取得
    PndSt = PndStVrt(LinePos)                     '未解決ヒント先頭取得
    PndEn = PndEnVrt(LinePos)                     '未解決ヒント末尾取得
    ReDim HintCpy(HintHt)                         'ヒント内容コピー
    ReDim PssStCpy(HintHt)
    ReDim PssEnCpy(HintHt)
    For HintCnt = 1 To HintEnd
      HintCpy(HintCnt) = HintVrt(LinePos, HintCnt)
      PssStCpy(HintCnt) = PssStVrt(LinePos, HintCnt)
      PssEnCpy(HintCnt) = PssEnVrt(LinePos, HintCnt)
    Next HintCnt
  End If
  If PndSt > 0 Then
    ReDim HintAttch(FieldLen)                     '配属先ヒント番号領域クリア
    ReDim DuplChk(FieldLen)                       '配属先重複チェック領域クリア
    ReDim HintNum(FieldLen)                       'ヒント値保存領域クリア
    For HintCnt = 1 To HintEnd
      HintVal = HintCpy(HintCnt)
      If HintVal = 0 Then _
        HintVal = PssEnCpy(HintCnt) - PssStCpy(HintCnt) + 1
      For FieldCnt = PssStCpy(HintCnt) To PssEnCpy(HintCnt)
        DuplChk(FieldCnt) = DuplChk(FieldCnt) Or (HintCnt Mod 2 + 1)
        HintNum(FieldCnt) = HintCnt               '配属先ヒント番号取得
      Next FieldCnt
    Next HintCnt
    For FieldCnt = 1 To FieldLen
      If DuplChk(FieldCnt) > 2 Then
        HintAttch(FieldCnt) = -1                  '重複部：負数
      Else
        HintAttch(FieldCnt) = HintNum(FieldCnt)   '単独配属：ヒント値
      End If
    Next FieldCnt
  End If
End Sub

水平または垂直方向のある1列を切取って、各マスがどのヒントに属しているかをHintAttch()に返します。右のような横方向フィールドの場合、ヒント値2は1マス目から6マス目が、ヒント値3は4マス目から10マス目がそれぞれ候補範囲となるので、例えば1マス目は第1ヒントにのみ属するためHintAttch(1)に‘1’がセットされます。4～6マス目は2つのヒントに所属しており、HintAttch(4)～HintAttch(6)は‘-1’となり、HintAttch(7)以降は第2ヒント所属で‘2’がセットされます。つまり、この例でHintAttch(1)からHintAttch(10)には、1、1、1、-1、-1、-1、2、2、2、2という値がセットされるコトになります。分析が進んで空白が出てくると、空白部はどのヒントにも属さないマスということになり、その場合は‘0’がセットされます。最大ヒント数は75に制限されているので、HintAttch()配列はByte型でもよさそうですが、‘-1’を利用するためにInteger型にしてあります。得意の「こだわり」でByte型でもできるようにすれば変数領域を半分にできるじゃないか、との声も聞こえてきそうですが、理論上どんな大きなロジックでも実現可能なベースを作っている、という「こだわり」がジャマしているからです。

SetAttachedHintプロシージャは水平、垂直方向指定と位置情報を引数として呼出されます。HrzFlgがTrueなら水平方向、という具合です。上から3番目の水平フィールドを対象とするならSetAttachedHint True , 3と呼出されることになり、SetAttachedHint False , 5というカタチで呼出されれば、右から5番目の垂直フィールドが対象となります。

プロシージャの先頭ではHintCpy()、 PssStCpy()、 PssEnCpy()にヒント内容、未解決ヒント先頭位置、未解決ヒント終端位置をコピーしています。縦でも横でも呼出せるプロシージャという狙いなのですが、縦と横とで走査方向が違っているコトにより参照方向の違いがコーディングをメンドくさいものにするため、予め一次元配列にコピーしているってワケです。

さて、コピーしたヒント情報でヒント所属情報を取得していきます。単独ヒントしかなければ、どのヒントに関わっているかが得られればイイのですが、複数のヒントに属する‘グレーゾーン’なフィールドを‘-1’にするための計算がちょっと厄介で、petit-OA的には「隣り合ってるヒントがカブっているなら偶奇性をチェックすればイイのでは?」という方法を採用しました。HintCnt Mod 2 + 1によって偶数番目のヒントでは‘1’、奇数番目では‘2’が得られます。これにより、ヒントに属するフィールドでは‘1’か‘2’、そしてOr演算により、候補範囲のカブるフィールドは‘3’がDuplChk()に格納されます。HintAttch()にヒント番号をセットする際にDuplChk()をチェックして、‘3’だったらHintAttch()は‘-1’が格納されるようにしています。

それではいよいよSetAttachedHintプロシージャを呼出してみましょう。


Option Explicit
Option Base 1                                     '配列最小添字=1
' モジュール内共用定数宣言
Const Blank As Byte = &H0                         '未定 = 0
Const Black As Byte = &H1                         '塗潰 = 1
Const White As Byte = &H2                         '空白 = 2
Const MaskPtn As Byte = Black Or White            'マスクパターン = 1 or 2 = 3
Const Discrpnc As Byte = Black Or White           '矛盾 = 1 or 2 = 3
Const ConcBit As Byte = &H4                       '確定 = 4
Const BlackInconc As Byte = Black                 '仮定塗潰 = 1
Const WhiteInconc As Byte = White                 '仮定空白 = 2
Const DiscrpInconc As Byte = Discrpnc             '仮定矛盾 = 3
Const BlackConc As Byte = ConcBit Or Black        '確定塗潰 = 5
Const WhiteConc As Byte = ConcBit Or White        '確定空白 = 6
Const DiscrpConc As Byte = ConcBit Or Discrpnc    '確定矛盾 = 7
Const Horizontal As Boolean = True                '水平走査
Const Vertical As Boolean = False                 '垂直走査
' モジュール内共用変数宣言
Dim HintLen As Integer                            '列内ヒント数
    ....

SetAttachedHintプロシージャを呼出す際に水平、垂直方向指定をTrueとかFalseとかで指定していると味っ気ないので、名前に意味を持たせた定数を定義して、呼出しに利用します。


Sub PSSrenewal(Optional ByVal CallSwitch As Boolean)
' 候補範囲更新
' ヒント値を上下左右の端点から走査し、以下のチェックを行って候補範囲を縮小する。
' ・候補範囲外から続く連続塗潰しがあれば範囲から除外。
  Dim HintVal As Integer                          '対象ヒント値
  Dim FieldPos As Integer                         'フィールドポインタ
  Dim AreaSt As Integer                           '更新始点ポインタ
  Dim AreaEn As Integer                           '更新終点ポインタ
  NonoModule.PSSresult                            '候補範囲デバッグ表示
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStHrz(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
      NonoModule.SetAttachedHint _
        Horizontal, ScanCnt                       '配属先ヒント番号取得
  'ヒント走査 左→右
      For HintCnt = PndStHrz(ScanCnt) To PndEnHrz(ScanCnt)
    ....

    ....
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStVrt(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
      NonoModule.SetAttachedHint _
        Vertical, ScanCnt                         '配属先ヒント番号取得
  'ヒント走査 上→下
      For HintCnt = PndStVrt(ScanCnt) To PndEnVrt(ScanCnt)
    ....

シート分析を実行しても(またしても、ですが)見た目の変化はありません。ブレークポイントを設定し、イミディエイトウィンドウでHintAttch()の変化を丁寧に各ループでチェックすると、SetAttachedHintプロシージャが正常に動作していることが解ります。

ヒント所属が得られたので、実際に候補範囲を狭める操作をしてみましょう。範囲の端からチェックして対象ヒントと同じヒント番号の部分に塗潰しがあれば、それはそのヒントに属する塗潰しであることが決まります。


Sub PSSrenewal(Optional ByVal CallSwitch As Boolean)
' 候補範囲更新
' ヒント値を上下左右の端点から走査し、以下のチェックを行って候補範囲を縮小する。
' ・候補範囲外から続く連続塗潰しがあれば範囲から除外。
' ・単独ヒント配属または未解決端の塗潰し検出時は範囲更新。
  Dim HintVal As Integer                          '対象ヒント値
  Dim FieldPos As Integer                         'フィールドポインタ
  Dim AreaSt As Integer                           '更新始点ポインタ
  Dim AreaEn As Integer                           '更新終点ポインタ
  Dim BlockSt As Integer                          'ブロックチェック範囲
  Dim BlockEn As Integer
  NonoModule.PSSresult                            '候補範囲デバッグ表示
  '＜水平方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStHrz(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
      NonoModule.SetAttachedHint _
        Horizontal, ScanCnt                       '配属先ヒント番号取得
  'ヒント走査 左→右
      For HintCnt = PndStHrz(ScanCnt) To PndEnHrz(ScanCnt)
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt > PndStHrz(ScanCnt) Then     '未解決左端ヒントは対象外
  '候補範囲左端以前からの連続塗潰しを除外
            Do While CheckBlack(ScanCnt, AreaSt - 1)
              If AreaSt < FieldWd Then
                AreaSt = AreaSt + 1
              Else
                Exit Do
              End If
            Loop
          End If
  '単独ヒント配属または未解決左端の塗潰し検出時は範囲終点更新
          BlockEn = AreaEn                        'ブロック情報初期化
          For FieldCnt = AreaSt To AreaEn
            If CheckBlack(ScanCnt, FieldCnt) Then '塗潰しチェック
              If HintAttch(FieldCnt) = HintCnt _
                Or HintCnt = PndStHrz(ScanCnt) Then
                If BlockEn = AreaEn Then          '範囲更新チェック
                  BlockEn = FieldCnt + HintVal - 1
                End If
              End If
            End If
          Next FieldCnt
          If AreaEn > BlockEn Then AreaEn = BlockEn
  '候補範囲更新
          If AreaEn - AreaSt + 1 >= HintVal Then
            If PssStHrz(ScanCnt, HintCnt) < AreaSt Then
              LpStp1 = True                       '進展チェック
              PssStHrz(ScanCnt, HintCnt) = AreaSt '始点更新
            End If
            If PssEnHrz(ScanCnt, HintCnt) > AreaEn Then
              LpStp1 = True                       '進展チェック
              PssEnHrz(ScanCnt, HintCnt) = AreaEn '終点更新
            End If
          Else
            Discrep = True                        '矛盾発見
            Exit For
          End If
        End If
      Next HintCnt
      If Discrep Then Exit For
  'ヒント走査 左←右
      For HintCnt = PndEnHrz(ScanCnt) To PndStHrz(ScanCnt) Step -1
        HintVal = HintHrz(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStHrz(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnHrz(ScanCnt, HintCnt)
          If HintCnt < PndEnHrz(ScanCnt) Then     '未解決右端ヒントは対象外
  '候補範囲右端以降からの連続塗潰しを除外
            Do While CheckBlack(ScanCnt, AreaEn + 1)
              If AreaEn > 1 Then
                AreaEn = AreaEn - 1
              Else
                Exit Do
              End If
            Loop
          End If
  '単独ヒント配属または未解決右端の塗潰し検出時は範囲始点更新
          BlockSt = AreaSt                        'ブロック情報初期化
          For FieldCnt = AreaEn To AreaSt Step -1
            If CheckBlack(ScanCnt, FieldCnt) Then '塗潰しチェック
              If HintAttch(FieldCnt) = HintCnt _
                Or HintCnt = PndEnHrz(ScanCnt) Then
                If BlockSt = AreaSt Then          '範囲更新チェック
                  BlockSt = FieldCnt - HintVal + 1
                End If
              End If
            End If
          Next FieldCnt
          If AreaSt < BlockSt Then AreaSt = BlockSt
  '候補範囲更新
          If AreaEn - AreaSt + 1 >= HintVal Then
            If PssStHrz(ScanCnt, HintCnt) < AreaSt Then
              LpStp1 = True                       '進展チェック
              PssStHrz(ScanCnt, HintCnt) = AreaSt '始点更新
            End If
            If PssEnHrz(ScanCnt, HintCnt) > AreaEn Then
              LpStp1 = True                       '進展チェック
              PssEnHrz(ScanCnt, HintCnt) = AreaEn '終点更新
            End If
          Else
            Discrep = True                        '矛盾発見
            Exit For
          End If
        End If
      Next HintCnt
      If Discrep Then Exit For
    End If
  Next ScanCnt
  '＜垂直方向スキャン＞
  For ScanCnt = 1 To FieldHt
    If PndStVrt(ScanCnt) > 0 Then                 '未解決ヒントを含む行のみ対象
      NonoModule.SetAttachedHint _
        Vertical, ScanCnt                         '配属先ヒント番号取得
  'ヒント走査 上→下
      For HintCnt = PndStVrt(ScanCnt) To PndEnVrt(ScanCnt)
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt > PndStVrt(ScanCnt) Then     '未解決上端ヒントは対象外
  '候補範囲上端以前からの連続塗潰しを除外
            Do While CheckBlack(AreaSt - 1, ScanCnt)
              If AreaSt < FieldHt Then
                AreaSt = AreaSt + 1
              Else
                Exit Do
              End If
            Loop
          End If
  '単独ヒント配属または未解決上端の塗潰し検出時は範囲終点更新
          BlockEn = AreaEn                        'ブロック情報初期化
          For FieldCnt = AreaSt To AreaEn
            If CheckBlack(FieldCnt, ScanCnt) Then '塗潰しチェック
              If HintAttch(FieldCnt) = HintCnt _
                Or HintCnt = PndStVrt(ScanCnt) Then
                If BlockEn = AreaEn Then          '範囲更新チェック
                  BlockEn = FieldCnt + HintVal - 1
                End If
              End If
            End If
          Next FieldCnt
          If AreaEn > BlockEn Then AreaEn = BlockEn
  '候補範囲更新
          If AreaEn - AreaSt + 1 >= HintVal Then
            If PssStVrt(ScanCnt, HintCnt) < AreaSt Then
              LpStp1 = True                       '進展チェック
              PssStVrt(ScanCnt, HintCnt) = AreaSt '始点更新
            End If
            If PssEnVrt(ScanCnt, HintCnt) > AreaEn Then
              LpStp1 = True                       '進展チェック
              PssEnVrt(ScanCnt, HintCnt) = AreaEn '終点更新
            End If
          Else
            Discrep = True                        '矛盾発見
            Exit For
          End If
        End If
      Next HintCnt
      If Discrep Then Exit For
  'ヒント走査 上←下
      For HintCnt = PndEnVrt(ScanCnt) To PndStVrt(ScanCnt) Step -1
        HintVal = HintVrt(ScanCnt, HintCnt)       '対象ヒント値取得
        If HintVal > 0 Then                       'ヒント値０は無視
          AreaSt = PssStVrt(ScanCnt, HintCnt)     '更新ポインタ初期化
          AreaEn = PssEnVrt(ScanCnt, HintCnt)
          If HintCnt < PndEnVrt(ScanCnt) Then     '未解決下端ヒントは対象外
  '候補範囲下端以降からの連続塗潰しを除外
            Do While CheckBlack(AreaEn + 1, ScanCnt)
              If AreaEn > 1 Then
                AreaEn = AreaEn - 1
              Else
                Exit Do
              End If
            Loop
          End If
  '単独ヒント配属または未解決下端の塗潰し検出時は範囲始点更新
          BlockSt = AreaSt                        'ブロック情報初期化
          For FieldCnt = AreaEn To AreaSt Step -1
            If CheckBlack(FieldCnt, ScanCnt) Then '塗潰しチェック
              If HintAttch(FieldCnt) = HintCnt _
                Or HintCnt = PndEnVrt(ScanCnt) Then
                If BlockSt = AreaSt Then          '範囲更新チェック
                  BlockSt = FieldCnt - HintVal + 1
                End If
              End If
            End If
          Next FieldCnt
          If AreaSt < BlockSt Then AreaSt = BlockSt
  '候補範囲更新
          If AreaEn - AreaSt + 1 >= HintVal Then
            If PssStVrt(ScanCnt, HintCnt) < AreaSt Then
              LpStp1 = True                       '進展チェック
              PssStVrt(ScanCnt, HintCnt) = AreaSt '始点更新
            End If
            If PssEnVrt(ScanCnt, HintCnt) > AreaEn Then
              LpStp1 = True                       '進展チェック
              PssEnVrt(ScanCnt, HintCnt) = AreaEn '終点更新
            End If
          Else
            Discrep = True                        '矛盾発見
            Exit For
          End If
        End If
      Next HintCnt
      If Discrep Then Exit For
    End If
  Next ScanCnt
End Sub

追加部分がプロシージャの全域に渡り、またプロシージャが大きくなってきたこともあって、整理の意味で全コード省略なしで記述しています。候補範囲を絞る条件が増えたためコメントも適宜追加しています。

宣言部ではScanCnt、HintCnt、FieldCntに続くループ変数としてBlockStとBlockEnを定義しています。元の候補範囲をひとつのチェック対象ブロックとして、その中で単独配属の塗潰しを探すという操作を行っています。また範囲更新は‘左から右’と‘上から下’では範囲始点、‘右から左’と‘下から上’では範囲終点のみ更新していましたが、今回の処理で始点、終点ともに各ループ内で更新する必要が出てきたので、これを追加しています。

シート分析を実行してイミディエイトウィンドウをチェックしてみると、水平フィールドの上から3行目と、垂直フィールドの全列で候補範囲が更新されていることが解ります。

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

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

定数定義

塗潰しと空白の判定と設置

塗潰し補範囲更新 その2

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

塗潰し補範囲更新その2