MENU
トップ > ペントミノ > 【VB】ペントミノ３Ｄパズルを解く（８）フォームのコード

【VB】ペントミノ３Ｄパズルを解く（８）フォームのコード

ペントミノ ペントミノ-3D_VB

Form1 のコードを説明します。鏡映の判定を追加した部分が２Ｄ版と大きく異なります。

・クラス宣言

IDEのソリューションエクスプローラで Form1 を右クリックして "コードの表示" で自動表示されるので気にも留めませんが、クラスの名前は "Form1" です。

Public Class Form1

・State プロパティ (状態遷移)

コントロールの状態はプロパティ(State)で管理します。値を変更すると個々のコントロールの Enabled や Visible プロパティを一括して変更できるようにしています。

状態 値 入力関係のコントロール プログレスバーとキャンセルボタン
フォーム入力時 1 Enabled = True Visible = False
探索作業中 2 Enabled = False Visible = True 
Dim _State As Integer = 0

Public Property State As Integer
   Get
      Return _State
   End Get
   Set(value As Integer)
      _State = value
      Dim STS() As Boolean = {value = 0, value = 1, value = 2}
      With Me
         .GroupBox1.Enabled = STS(1)
         .cbx_都度確認あり.Enabled = STS(1)
         .探索開始ボタン.Enabled = STS(1)
         .ProgressBar1.Visible = STS(2)
         .キャンセルボタン.Visible = STS(2)
      End With
   End Set
End Property

'===== 例 =====
State = 1     '入力関係のコントロールは活性化、プログレスバーとキャンセルボタンは非表示にします

・フォームを開くとき

フォームのイベントは Load です。各コントロールの初期値をセットして State プロパティを 1 にします。

Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
   With Me
      .rbt_5x4x3.Checked = True
      .State = 1
   End With
End Sub

・フォームを閉じるとき

フォームのイベントは FormClosing です。State プロパティが 2 のときは、探索作業中にキャンセルボタンを押したりしてここに来たことが考えられるので「中止しますか？」とユーザーに確認します。State プロパティが 1 のときはそのままクローズします。

Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
   If Me.State = 2 Then
      If MsgBox("中止しますか？", MsgBoxStyle.Question + MsgBoxStyle.YesNo) = MsgBoxResult.Yes Then
         DEF.CancelFlag = True
      End If
      e.Cancel = True
   End If
End Sub

・キャンセルボタンを押したとき

フォームのイベントは Click です。キャンセルボタンを押したときにいきなり「中止しますか？」と確認してはいけません。フォーム右上の［×］やタスクバーで閉じる場合もあるので、キャンセルボタンではフォームを閉じるイベントを発生させて、他の閉じる機能と同じように「フォームを閉じるとき」に管理を任せるべきです。

Private Sub キャンセルボタン_Click(sender As Object, e As EventArgs) Handles キャンセルボタン.Click
   Me.Close()
End Sub

・探索開始ボタンを押したとき

ここからがパズルを解く部分です。

Private Sub 探索開始ボタン_Click(sender As Object, e As EventArgs) Handles 探索開始ボタン.Click

'(1) State変更と DEF.CancelFlag の準備
     Me.State = 2
     DEF.CancelFlag = False

'(2) 箱の用意
     Dim box As Box
     Select Case True
        Case rbt_5x4x3.Checked
           box = New Box(5, 4, 3)
        Case rbt_6x5x2.Checked
           box = New Box(6, 5, 2)
        Case Else
           box = New Box(10, 3, 2)
     End Select
     リストビュー初期化(box)

'(3) 部品棚を作成
     Dim shelves = New List(Of Shelf)
     DEF.部品棚作成(shelves, box)

'(4) プログレスバーを初期化
     With Me.ProgressBar1
        .Maximum = shelves.Sum(Function(s) s.Pieces.Count)
        .Minimum = 0
        .Value = 0
     End With

'(6) 探索実行
     Dim startTime = Now
     DEF.SolutionNo = 0
     nextSearch(box, shelves, New Coord(0, 0, 0))
     Dim endTime = Now

'(7) 結果表示と終了
     If Not DEF.CancelFlag Then
        With ProgressBar1
           .Value = .Maximum
        End With
        MsgBox("探索終了" & vbCrLf & vbCrLf & DEF.経過時間(startTime, endTime))
     End If
     Me.State = 1
     Me.Close()

End Sub
(1) State変更と DEF.CancelFlag の準備

State を 2 に変更してコントロールのプロパティを「探索作業中」モードに切り替えます。同時に DEF.CancelFlag に初期値を与えて準備します。

(2) 箱の用意

ラジオボタンの選択にしたがって箱のサイズを設定し、リストビューを初期化します（別メソッド）。

(3) 部品棚を作成

インスタンス作成後、DEFクラスのメソッドで部品棚を作成します。

(4) プログレスバーを初期化

部品棚の中の部品数は合計142個あります。それを Maximum にして Value は探索中の部品がコレクション全体の何番目であるかを示すことにしました（Value の計算は後述）。

(5) 探索実行

ここがメインです。DEF.SolutionNo は解のカウンターです。探索は nextSearch メソッドです（後述）。前後に経過時間を測るために時刻の取得を挟みます。

(6) 結果表示と終了

途中でキャンセルしなければ終了メッセージを表示し、ユーザー確認後フォームを閉じます。途中キャンセルのときはメッセージを表示しないでそのままフォームを閉じます。

・メソッド：nextSearch（再帰）

「探索開始ボタン_Click」から呼ばれる探索の本体部分です。指定の座標位置以降で部品を置くことができる場所を探します。部品が置けたら完成を判定、すべての部品が置けたらパズルの完成です。そうでなければ再帰して次に置く部品を探します。置いた部品数は box.PlacedPieceCount にカウントされます。解は Shelves の各 Shelf 内の PlacedPiece と PlacedCoord に記録しているので完成したものはここからリストビューに表示させます。

Private Sub nextSearch(box As Box, shelves As List(Of Shelf), coord As Coord)

   If box.PlacedPieceCount = 1 Then
      プログレスバー表示(box.PlacedFirstPiece, shelves)
   End If
   Application.DoEvents()
   If DEF.CancelFlag Then
      Exit Sub
   End If

   coord = box.NextBlankCell(coord)

   For Each shelf In shelves
      If shelf.PlacedPiece Is Nothing Then
         For Each piece In shelf.Pieces
            If box.CanPlace(piece, coord) Then
               shelf.PlacedPiece = piece
               shelf.PlacedCoord = coord
               box.PlacePiece(shelf)

               '鏡映チェック
               If shelf.Name = DEF.SynonymJudgePieceName Then
                  Res_Reflection1 = Reflection1(box, shelf)
                  If Res_Reflection1 < 0 Then
                     box.RemovePiece(shelf)
                     shelf.PlacedPiece = Nothing
                     shelf.PlacedCoord = Nothing
                     Continue For
                  End If
               End If

               '完成判定
               If box.PlacedPieceCount = shelves.Count Then
                  If Res_Reflection1 = 0 Then
                     Res_Reflection2 = Reflection2(box, shelves)
                  Else
                     Res_Reflection2 = 1
                  End If
                  If Res_Reflection2 > 0 Then
                     DEF.SolutionNo += 1
                     リストビュー完成表示(box, shelves)
                  End If
               Else
                  nextSearch(box, shelves, coord)       '再帰
               End If

               box.RemovePiece(shelf)
               shelf.PlacedPiece = Nothing
               shelf.PlacedCoord = Nothing
            End If
         Next
      End If
   Next

End Sub

・鏡映関係

nextSearchで置いた部品がDEF.SynonymJudgePieceNameだったとき、鏡映の判定(Reflection1)を行います。置いた部品が箱のちょうど真ん中だったときは鏡映の判断ができないので、その状態での完成を待って他の部品で鏡映の判定(Reflection2)をします。

'** 鏡映1(箱の中心線からの位置,プラスは原点側)
Private Res_Reflection1 As Integer
Private Function Reflection1(box As Box, shelf As Shelf) As Integer
   Dim diff As Single = 0
   With shelf
      Select Case True
         Case .PlacedPiece.LenX = 1
            diff = (box.LenX - 1) / 2 - .PlacedCoord.X
         Case .PlacedPiece.LenY = 1
            diff = (box.LenY - 1) / 2 - .PlacedCoord.Y
         Case .PlacedPiece.LenZ = 1
            diff = (box.LenZ - 1) / 2 - .PlacedCoord.Z
      End Select
   End With
   Select Case diff
      Case Is > 0   '鏡映ではない(解)
         Return 1
      Case Is < 0   '鏡映(シノニム)
         Return -1
      Case Else     'ちょうど真ん中
         Return 0
   End Select
End Function

'鏡映判定２(ちょうど真ん中のときshelvesに登録した部品順に判定)
Private Res_Reflection2 As Integer
Private Function Reflection2(box As Box, shelves As List(Of Shelf)) As Integer
   Dim JudgePiece = shelves.Where(Function(c) c.Name = DEF.SynonymJudgePieceName)(0).PlacedPiece
   For Each shelf In shelves
      If shelf.Name <> DEF.SynonymJudgePieceName Then
         With shelf

            Dim diff As Single = 0
            Select Case True
               Case JudgePiece.LenX = 1
                  diff = .PlacedCoord.X + .PlacedPiece.CentroidX - (box.LenX - 1) / 2
               Case JudgePiece.LenY = 1
                  diff = .PlacedCoord.Y + .PlacedPiece.CentroidY - (box.LenY - 1) / 2
               Case JudgePiece.LenZ = 1
                  diff = .PlacedCoord.Z + .PlacedPiece.CentroidZ - (box.LenZ - 1) / 2
            End Select

            Select Case diff
               Case Is > 0   '鏡映ではない(解)
                  Return 1
               Case Is < 0   '鏡映(シノニム)
                  Return -1
               Case Else     'ちょうど真ん中
                  Continue For
            End Select

         End With
      End If
   Next
   Return 0 'ここまでくることはあり得ない(shelfのどれかでreturnするはず)
End Function

・メソッド：リストビュー初期化

解を表示するリストビューを整形します。列数は解Noの表示用に1列余分に取ります。列幅は解No用の列は普通ですが、残りはセルが正方形に見えるように狭く(30px)しています。行数は箱の　奥行(LenY)を階数(LenZ)分用意します。UserItemStyleForSubitems プロパティは False にするとセルごとに背景色を変更できるのでこのプログラムでは必須の設定です。

Private Sub リストビュー初期化(box As Box)
   With LV1
      .View = View.Details
      .Font = New Font(.Font.Name, 18)
      .Clear()
      '列追加
      .Columns.Add("", 70)
      For x = 0 To box.LenX - 1
         .Columns.Add("", 30)
      Next
      'フォームの横幅変更
      Dim w = box.LenX * 30 + 200
      If w > Me.Width Then
         Me.Width = w
      End If
      '行追加
      For z = 0 To box.LenZ - 1
         For y = 0 To box.LenY - 1
            .Items.Add("")
            With .Items(.Items.Count - 1)
               .UseItemStyleForSubItems = False
               For x = 0 To box.LenX - 1
                  .SubItems.Add("")
               Next
            End With
         Next
         .Items.Add("")
      Next
      'フォームの高さ変更
      Dim h = .Items.Count * 30 + (Me.Height - LV1.Height)
      If h > Me.Height Then
         Me.Height = h
      End If
      '再描画
      .Refresh()
   End With
End Sub

・メソッド：リストビュー完成表示

完成した解をリストビューに表示するメソッドです。解は shelves の各Shelf にあるのでそれをリストビューに転記します。［都度確認あり］のときは「都度確認メソッド」を実行します。

Private Sub リストビュー完成表示(box As Box, shelves As List(Of Shelf))
   With LV1
      .Items(0).SubItems(0).Text = CStr(DEF.SolutionNo)
      For Each shelf In shelves
         Dim piece = shelf.PlacedPiece
         For i = 0 To piece.Size - 1
            Dim x = shelf.PlacedCoord.X + piece.Coords(i).X
            Dim y = shelf.PlacedCoord.Y + piece.Coords(i).Y
            Dim z = shelf.PlacedCoord.Z + piece.Coords(i).Z
            Dim Col = x + 1
            Dim Row = (box.LenY + 1) * z + y
            With .Items(Row).SubItems(Col)
               .Text = shelf.Name
               .BackColor = shelf.Color
               .ForeColor = Color.White
            End With
         Next
      Next
      If cbx_都度確認あり.Checked Then
         都度確認()
      End If
   End With
End Sub

・メソッド：都度確認

都度確認の継続とプログラムのキャンセルを訊くようにしています。

Private Sub 都度確認()
   Dim result = MsgBox("完成！！ (" & DEF.SolutionNo & ")" & vbCrLf & vbCrLf &
                       "都度確認を続けますか？", vbYesNoCancel)
   Select Case result
      Case vbYes
            'Continue
      Case vbNo
         cbx_都度確認あり.Checked = False
      Case vbCancel
         キャンセルボタン.PerformClick()
   End Select
End Sub

・メソッド：プログレスバー表示

プログレスバーの値(Value)の計算は、解の最初の部品（box.PlacedFirstPiece）が部品棚のすべての部品の何番目になるのかを計算しています。

Private Sub プログレスバー表示(piece As Piece, shelves As List(Of Shelf))
   Dim val = 0
   For Each shelf In shelves
      If shelf.Pieces.Contains(piece) Then
         val += shelf.Pieces.IndexOf(piece) + 1
         Exit For
      Else
         val += shelf.Pieces.Count
      End If
   Next
   Me.ProgressBar1.Value = val
End Sub


以上でクラスからフォームまで、すべてのコードを作り終えました。
実際にプログラムを動かして確認してください。

Imports System.Reflection

Public Class Form1
   'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ
   'Z
   'Z                Ｆｏｒｍ１
   'Z
   'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ
#Region "State(状態遷移)"

   Dim _State As Integer = 0

   Public Property State As Integer
      Get
         Return _State
      End Get
      Set(value As Integer)
         _State = value
         Dim STS() As Boolean = {value = 0, value = 1, value = 2}
         With Me
            .GroupBox1.Enabled = STS(1)
            .cbx_都度確認あり.Enabled = STS(1)
            .探索開始ボタン.Enabled = STS(1)
            .ProgressBar1.Visible = STS(2)
            .キャンセルボタン.Visible = STS(2)
         End With
      End Set
   End Property

#End Region

   '****************************************
   '*          フォームを開くとき
   '****************************************
   Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
      With Me
         .rbt_5x4x3.Checked = True
         .State = 1
      End With
   End Sub

   '****************************************
   '*         フォームを閉じるとき
   '****************************************
   Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
      If Me.State = 2 Then
         If MsgBox("中止しますか？", MsgBoxStyle.Question + MsgBoxStyle.YesNo) = MsgBoxResult.Yes Then
            DEF.CancelFlag = True
         End If
         e.Cancel = True
      End If
   End Sub

   Private Sub キャンセルボタン_Click(sender As Object, e As EventArgs) Handles キャンセルボタン.Click
      Me.Close()
   End Sub

   '****************************************
   '*      探索開始ボタンをクリック
   '****************************************
   Private Sub 探索開始ボタン_Click(sender As Object, e As EventArgs) Handles 探索開始ボタン.Click
      Me.State = 2

      DEF.CancelFlag = False

      Dim box As Box
      Select Case True
         Case rbt_5x4x3.Checked
            box = New Box(5, 4, 3)
         Case rbt_6x5x2.Checked
            box = New Box(6, 5, 2)
         Case Else
            box = New Box(10, 3, 2)
      End Select
      リストビュー初期化(box)

      Dim shelves = New List(Of Shelf)
      DEF.部品棚作成(shelves, box)

      With Me.ProgressBar1
         .Maximum = shelves.Sum(Function(s) s.Pieces.Count)
         .Minimum = 0
         .Value = 0
      End With

      Dim startTime = Now
      DEF.SolutionNo = 0
      nextSearch(box, shelves, New Coord(0, 0, 0))
      Dim endTime = Now

      If Not DEF.CancelFlag Then
         With ProgressBar1
            .Value = .Maximum
         End With
         MsgBox("探索終了" & vbCrLf & vbCrLf & DEF.経過時間(startTime, endTime))
      End If

      Me.State = 1
      Me.Close()

   End Sub

   '****************************
   '*        nextSearch           次を探す(再帰)
   '****************************
   Private Sub nextSearch(box As Box, shelves As List(Of Shelf), coord As Coord)

      If box.PlacedPieceCount = 1 Then
         プログレスバー表示(box.PlacedFirstPiece, shelves)
      End If
      Application.DoEvents()
      If DEF.CancelFlag Then
         Exit Sub
      End If

      coord = box.NextBlankCell(coord)

      For Each shelf In shelves
         If shelf.PlacedPiece Is Nothing Then
            For Each piece In shelf.Pieces
               If box.CanPlace(piece, coord) Then
                  shelf.PlacedPiece = piece
                  shelf.PlacedCoord = coord
                  box.PlacePiece(shelf)

                  '鏡映チェック
                  If shelf.Name = DEF.SynonymJudgePieceName Then
                     Res_Reflection1 = Reflection1(box, shelf)
                     If Res_Reflection1 < 0 Then
                        box.RemovePiece(shelf)
                        shelf.PlacedPiece = Nothing
                        shelf.PlacedCoord = Nothing
                        Continue For
                     End If
                  End If

                  '完成判定
                  If box.PlacedPieceCount = shelves.Count Then
                     If Res_Reflection1 = 0 Then
                        Res_Reflection2 = Reflection2(box, shelves)
                     Else
                        Res_Reflection2 = 1
                     End If
                     If Res_Reflection2 > 0 Then
                        DEF.SolutionNo += 1
                        リストビュー完成表示(box, shelves)
                     End If
                  Else
                     nextSearch(box, shelves, coord)       '再帰
                  End If

                  box.RemovePiece(shelf)
                  shelf.PlacedPiece = Nothing
                  shelf.PlacedCoord = Nothing
               End If
            Next
         End If
      Next

   End Sub

   '****************************
   '*        鏡映関係
   '****************************

   '** 鏡映1(箱の中心線からの位置,プラスは原点側)
   Private Res_Reflection1 As Integer
   Private Function Reflection1(box As Box, shelf As Shelf) As Integer
      Dim diff As Single = 0
      With shelf
         Select Case True
            Case .PlacedPiece.LenX = 1
               diff = (box.LenX - 1) / 2 - .PlacedCoord.X
            Case .PlacedPiece.LenY = 1
               diff = (box.LenY - 1) / 2 - .PlacedCoord.Y
            Case .PlacedPiece.LenZ = 1
               diff = (box.LenZ - 1) / 2 - .PlacedCoord.Z
         End Select
      End With
      Select Case diff
         Case Is > 0   '鏡映ではない(解)
            Return 1
         Case Is < 0   '鏡映(シノニム)
            Return -1
         Case Else     'ちょうど真ん中
            Return 0
      End Select
   End Function

   '鏡映判定２(ちょうど真ん中のときshelvesに登録した部品順に判定)
   Private Res_Reflection2 As Integer
   Private Function Reflection2(box As Box, shelves As List(Of Shelf)) As Integer
      Dim JudgePiece = shelves.Where(Function(c) c.Name = DEF.SynonymJudgePieceName)(0).PlacedPiece
      For Each shelf In shelves
         If shelf.Name <> DEF.SynonymJudgePieceName Then
            With shelf

               Dim diff As Single = 0
               Select Case True
                  Case JudgePiece.LenX = 1
                     diff = .PlacedCoord.X + .PlacedPiece.CentroidX - (box.LenX - 1) / 2
                  Case JudgePiece.LenY = 1
                     diff = .PlacedCoord.Y + .PlacedPiece.CentroidY - (box.LenY - 1) / 2
                  Case JudgePiece.LenZ = 1
                     diff = .PlacedCoord.Z + .PlacedPiece.CentroidZ - (box.LenZ - 1) / 2
               End Select

               Select Case diff
                  Case Is > 0   '鏡映ではない(解)
                     Return 1
                  Case Is < 0   '鏡映(シノニム)
                     Return -1
                  Case Else     'ちょうど真ん中
                     Continue For
               End Select

            End With
         End If
      Next
      Return 0 'ここまでくることはあり得ない(shelfのどれかでreturnするはず)
   End Function

   '****************************
   '*     リストビュー関係
   '****************************
   Private Sub リストビュー初期化(box As Box)
      With LV1
         .View = View.Details
         .Font = New Font(.Font.Name, 18)
         .Clear()
         '列追加
         .Columns.Add("", 70)
         For x = 0 To box.LenX - 1
            .Columns.Add("", 30)
         Next
         'フォームの横幅変更
         Dim w = box.LenX * 30 + 200
         If w > Me.Width Then
            Me.Width = w
         End If
         '行追加
         For z = 0 To box.LenZ - 1
            For y = 0 To box.LenY - 1
               .Items.Add("")
               With .Items(.Items.Count - 1)
                  .UseItemStyleForSubItems = False
                  For x = 0 To box.LenX - 1
                     .SubItems.Add("")
                  Next
               End With
            Next
            .Items.Add("")
         Next
         'フォームの高さ変更
         Dim h = .Items.Count * 30 + (Me.Height - LV1.Height)
         If h > Me.Height Then
            Me.Height = h
         End If
         '再描画
         .Refresh()
      End With
   End Sub

   Private Sub リストビュー完成表示(box As Box, shelves As List(Of Shelf))
      With LV1
         .Items(0).SubItems(0).Text = CStr(DEF.SolutionNo)
         For Each shelf In shelves
            Dim piece = shelf.PlacedPiece
            For i = 0 To piece.Size - 1
               Dim x = shelf.PlacedCoord.X + piece.Coords(i).X
               Dim y = shelf.PlacedCoord.Y + piece.Coords(i).Y
               Dim z = shelf.PlacedCoord.Z + piece.Coords(i).Z
               Dim Col = x + 1
               Dim Row = (box.LenY + 1) * z + y
               With .Items(Row).SubItems(Col)
                  .Text = shelf.Name
                  .BackColor = shelf.Color
                  .ForeColor = Color.White
               End With
            Next
         Next
         If cbx_都度確認あり.Checked Then
            都度確認()
         End If
      End With
   End Sub

   Private Sub 都度確認()
      Dim result = MsgBox("完成！！ (" & DEF.SolutionNo & ")" & vbCrLf & vbCrLf &
                          "都度確認を続けますか？", vbYesNoCancel)
      Select Case result
         Case vbYes
               'Continue
         Case vbNo
            cbx_都度確認あり.Checked = False
         Case vbCancel
            キャンセルボタン.PerformClick()
      End Select
   End Sub

   Private Sub プログレスバー表示(piece As Piece, shelves As List(Of Shelf))
      Dim val = 0
      For Each shelf In shelves
         If shelf.Pieces.Contains(piece) Then
            val += shelf.Pieces.IndexOf(piece) + 1
            Exit For
         Else
            val += shelf.Pieces.Count
         End If
      Next
      Me.ProgressBar1.Value = val
   End Sub

End Class