事務処理合理化に petit OA のイージーオーダーシステム
お絵かきロジックアナライザ開発記 その8
随分とスムーズにロジックシートを新規作成できるようになったので、ここからはいよいよヒントを元に解析を進める部分を考えていきます。お絵かきロジックアナライザにとって「本丸」の部分です。分岐やループなども多く登場しますのでコードはかなり複雑になってきます。時間を掛けて読んで下さい。
早速[Nonogram]→[新規作成]コマンドを使って5×5マスのロジックシートを作成し、右図のようにヒントを入力した状態で上書保存して下さい。非常に簡単なサンプルで、解答が右下図のようになることは明白です。右端と下端の「5」は全マスが塗潰しとなり、そこから左、あるいは上に向ってヒント値分の塗潰しを繰返していけば完成です。
これから進めようとしているのは、一言で言えば“思考のコード化”です。このパズルの場合、人間が「ここは塗潰しだな」と判断するには明確な数学的根拠があり、その‘根拠’をPCが見付けられるようになれば自動解析が可能となります。右図サンプルの場合、「フィールド幅5マスに対してヒント値が5なら全部塗潰しだ」という流れをコード化するということです。アルゴリズムを与えられた上でのコーディングは得意なプログラマでも、アルゴリズムまでコミで新しいモノを生み出すというのは非常に苦しい作業です。「自分はどのように思考しているのか」というコトを自己分析してVBAコードに置換えていくワケですから、自分の脳ミソを自分で覗き込んでいる気分になります。
開発効率を優先すると割切って背理法（あるマスを塗潰しと仮定して解析を進め、矛盾が生じたら仮定した塗潰しが誤りであると結論付けられる解析法）によるチカラ技に逃げるのも「せっかく計算の速いPCで解析をするんだから」という理由付けにより正当化されても良いのですが、あまりに芸がないと思います。“お絵かきロジックアナライザ”はできる限り確定的に解析を進めることで「安定して速い」を目指しているので、その分コードの流れは複雑になってしまいます。できるだけ丁寧に話を進めていきますね。
基本ルールのコード化
お絵かきロジックで最も基本的な解法は「ヒント値が範囲幅の2分の1を越える場合、範囲幅からヒント値を減じた数の未定部分を両端に残し、中央部分は塗潰しが確定する」というモノです。これは「ヒント値と範囲幅が等しい場合は範囲内総ての塗潰しが確定する」を内包します。この‘範囲幅’はヒント値が複数あれば分割され、フィールド内に複数存在します。そのため例えばフィールド幅が5の場合、ヒント値が「1 1 1」なら塗潰しと空白が交互に現れる形で確定するコトになります。
“候補範囲”の導入
「フィールド幅が5でヒント値が4なら中央3マスの塗潰しが確定」のように、フィールド幅とヒント値を直接比較できる場合は気になりませんが、「フィールド幅が5でヒント値が2と1なら右から2マス目の塗潰しが確定」のように、それぞれのヒント値がカバーする範囲が複数ある場合、‘そのヒントが適応される可能性のある範囲’を予め調べておき、その塗潰し候補範囲幅とヒント値を比較して結論を出すようにすると、実はお絵かきロジックの解法とは「総てのヒントに対応する塗潰し候補範囲の幅をヒント値と同値にする」という目的に向っていることが解ります。ひとつの列にヒントがひとつしかない場合も、フィールド幅全体を候補範囲幅として解析をスタートさせれば同じ処理になります。
そこで解析の第一段階として‘候補範囲’を初期設定します。候補範囲はヒント数分以上を確保しなければなりませんので、水平ヒントに関する候補範囲であれば「フィールド高×ヒント幅」のサイズを持つ配列とします。候補範囲は開始位置と終了位置を保存しなければならないので2倍の領域が必要で、さらに垂直ヒントに関しても同じくヒント数に対して2倍の配列が必要になります。配列サイズはフィールドサイズに左右されるので動的配列を準備します。
今から使用することになる配列は、自然数的な数え方になる(1マス目=第1要素)ので、配列添字の最小数は1です。NonoModuleのプロシージャ記述前の宣言部でOption Base 1を追記しておいて下さい。
Option Explicit '強制変数宣言
Option Base 1 '配列最小添字=1
それでは解析プログラム開始です。記述位置はNonoModule内です。いきなりかなりのボリュームなので、少々しんどいですけどガンバりましょう。
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 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 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 'ロジックシートアクティブ
'＜水平ヒント転送＞
HintSumHrz = 0 '水平ヒント値合計初期化
For ScanCnt = 1 To FieldHt '水平ヒント領域ループ
HintLen = 0 '列内ヒント数クリア
For HintCnt = 1 To HintWd
With NonoWorksheet.Cells(HintHt + ScanCnt, HintCnt)
If CInt(.Value) > 0 Then 'ヒント値がゼロでなければ...
HintLen = HintLen + 1 '列内ヒント数加算
HintHrz(ScanCnt, HintLen) _
= CInt(.Value) 'ヒント値左詰転送
HintSumHrz = HintSumHrz + HintHrz(ScanCnt, HintLen)
End If
End With
Next HintCnt
If HintLen > 0 Then 'ヒント数がゼロでなければ...
PndStHrz(ScanCnt) = 1 '水平未解決ヒント始点初期化
PndEnHrz(ScanCnt) = HintLen '水平未解決ヒント終点初期化
HintCntHrz(ScanCnt) = HintLen '水平ヒント数保存
FieldPos = 0 '候補範囲始点ポインタ
For HintCnt = 1 To HintLen
FieldPos = FieldPos + 1
PssStHrz(ScanCnt, HintCnt) = FieldPos '候補範囲始点初期化
FieldPos = FieldPos + HintHrz(ScanCnt, HintCnt)
Next HintCnt
Discrep = (FieldPos > FieldWd + 1) '矛盾チェック
If Discrep Then Exit For
FieldPos = FieldWd + 1 '候補範囲終点ポインタ
For HintCnt = HintLen To 1 Step -1
FieldPos = FieldPos - 1
PssEnHrz(ScanCnt, HintCnt) = FieldPos '候補範囲終点初期化
FieldPos = FieldPos - HintHrz(ScanCnt, HintCnt)
Next HintCnt
Discrep = (FieldPos < 0) '矛盾チェック
If Discrep Then Exit For
Else 'ヒント数がゼロなら...
PndStHrz(ScanCnt) = 0 '水平未解決ヒント始点ゼロ
PndEnHrz(ScanCnt) = 0 '水平未解決ヒント終点ゼロ
HintCntHrz(ScanCnt) = 0 '水平ヒント数ゼロ
End If
Next ScanCnt
If Discrep Then '矛盾チェック
ErrorMsg = "水平方向ヒント " & CStr(ScanCnt) & " 行目の合計値が" _
& vbNewLine & " フィールド幅を超えています。"
GoTo ExitAnalyzeSheet
End If
'＜垂直ヒント転送＞
HintSumVrt = 0 '垂直ヒント値合計初期化
For ScanCnt = 1 To FieldWd '垂直ヒント領域ループ
HintLen = 0 '列内ヒント数クリア
For HintCnt = 1 To HintHt
With NonoWorksheet.Cells(HintCnt, HintWd + ScanCnt)
If CInt(.Value) > 0 Then 'ヒント値がゼロでなければ...
HintLen = HintLen + 1 '列内ヒント数加算
HintVrt(ScanCnt, HintLen) _
= CInt(.Value) 'ヒント値上詰転送
HintSumVrt = HintSumVrt + HintVrt(ScanCnt, HintLen)
End If
End With
Next HintCnt
If HintLen > 0 Then 'ヒント数がゼロでなければ...
PndStVrt(ScanCnt) = 1 '垂直未解決ヒント始点初期化
PndEnVrt(ScanCnt) = HintLen '垂直未解決ヒント終点初期化
HintCintVrt(ScanCnt) = HintLen '垂直ヒント数保存
FieldPos = 0 '候補範囲始点ポインタ
For HintCnt = 1 To HintLen
FieldPos = FieldPos + 1
PssStVrt(ScanCnt, HintCnt) = FieldPos '候補範囲始点初期化
FieldPos = FieldPos + HintVrt(ScanCnt, HintCnt)
Next HintCnt
Discrep = (FieldPos > FieldHt + 1) '矛盾チェック
If Discrep Then Exit For
FieldPos = FieldHt + 1 '候補範囲終点ポインタ
For HintCnt = HintLen To 1 Step -1
FieldPos = FieldPos - 1
PssEnVrt(ScanCnt, HintCnt) = FieldPos '候補範囲始点初期化
FieldPos = FieldPos - HintVrt(ScanCnt, HintCnt)
Next HintCnt
Discrep = (FieldPos < 0) '矛盾チェック
If Discrep Then Exit For
Else 'ヒント数がゼロなら...
PndStVrt(ScanCnt) = 0 '垂直未解決ヒント始点ゼロ
PndEnVrt(ScanCnt) = 0 '垂直未解決ヒント終点ゼロ
HintCntVrt(ScanCnt) = 0 '垂直ヒント数ゼロ
End If
Next ScanCnt
If Discrep Then '矛盾チェック
ErrorMsg = "垂直方向ヒント " & CStr(ScanCnt) & " 列目の合計値が" _
& vbNewLine & " フィールド高を超えています。"
GoTo ExitAnalyzeSheet
End If
'＜ヒント合計チェック＞
If HintSumHrz <> HintSumVrt Then
Discrep = True
ErrorMsg = "水平ヒントの合計と垂直ヒントの合計とが" _
& vbNewLine & "一致しません。"
GoTo ExitAnalyzeSheet
End If
'＜終了表示＞
ExitAnalyzeSheet:
If Discrep Then '矛盾チェック
MsgBox ErrorMsg, vbCritical + vbOKOnly, "分析エラー"
End If
End Sub
水平ヒントと垂直ヒントとでプログラムの構造は同じなので、ここでは水平ヒントについての部分のみ解説します。
対象セルの値がゼロでなければヒント値と認識して配列HintHrzに転送します。同時にヒント数(HintLen)をカウントアップし、ヒント値合計(HintSumHrz)を加算します。ヒント数カウントは続いて実行される解析プログラムにおいて、チェックしなければならないヒント範囲を与えるためのモノです。ヒント値の合計は水平ヒントと垂直ヒントとで合計数が一致するかどうかのチェックに使用されます。お絵かきロジックでは一般に水平ヒントが右詰、垂直ヒントが下詰で表記されますが、配列内では添字の小さい方を左または上と認識すればそれぞれ左詰、上詰での保存になっています。これは今後の処理で開始点を「1」とした方が解りやすいからです。
セルからヒント値が動的配列(HintHrz)に転送されたら、未解決ヒント範囲の開始位置(PndStHrz)と終了位置(PndEnHrz)を初期化し、列内有効ヒント数を保存(HintCntHrz)しておきます。未解決ヒント範囲の初期値は当然、開始点が1で終了点は有効ヒント数となります。有効ヒントが存在しない(HintLenがゼロ)の場合はこれらは総て0にセットします。
そしていよいよ候補範囲(PssStHrz/PssEnHrz)の初期化ですが、該当ヒント以外が総て両端に詰まった状態での残り部分ということになります。今はヒント数が全列全行で一つしかないので、どれも「1〜5」の範囲になります。
候補範囲の取得ができるようになった(ハズ)ので、これを実行するためのメニューを追加しましょう。前述のOptional ByVal CallSwitch As Booleanによるマクロ実行リストからの不可視化を行っているので、このままではマクロ実行できません。
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 = "シート分析(&Z)"
.OnAction = "NonoModule.AnalyzeSheet"
.FaceId = 532
End With
End With
End If
Set MenuBar = Nothing 'オブジェクト変数開放
End Sub
一旦ブックを非アクティブにし、再度アクティブにするとメニューが追加されます。実行するとヒント値の入力ミスがなければ何も変化せずに終わってしまいます。AnalyzeSheetプロシージャのEnd Sub部分にブレークポイントを設定し、終了直前にPssStHrz(1,1)などの内容をイミディエイトウィンドウで確認すると無事ヒント取得が行われていることが解ります。
← 前へ → 次へ ▲ ページトップ