午後わてんのブログ

ベランダ菜園とWindows用アプリ作成(WPFとC#)

エクセルVBAでライフゲームその3

エクセルExcel2007 #ソフトウェア エクセルVBA
 
別シートで行っていたセルの探査を配列を使うようにしたら2倍くらい速くなった
 
イメージ 1
1世代更新にかかった時間
20ｘ20だと0.22秒から0.11秒
40ｘ20だと0.36秒から0.14秒
セル数が増えると余計に差がでてくる
 
動かしているところ
イメージ 9
http://www.geocities.jp/gogowaten/lifegame14.gif
速くなっていい気分！
 
イメージ 10
http://www.geocities.jp/gogowaten/lifegame16.gif
その後何色かを選べるようにしたら
イメージ 7
0.11秒だったのが0.15秒まで遅くなったｗ
でも前回より速いからね
 
前回との変更点
処理速度向上
生存率のグラフをリアルタイムで変更するようにした
誕生ルールを2つ指定できるようにした
mapの上下左右ループの有無を指定できるようにした
生存し続けたセルの色変化で選べる色を赤、緑、青、水色から選べるようにした
それぞれの色で変化なしもできるようにした
クリアと中止を分けて、中止ボタンはクリアしないで停止するようにした
ゲーム実行中は中止以外のボタンを無効にするようにした
 
 
 
セルの状態を配列に入れる処理の流れ
2次元配列を2つ使う、それぞれA, Bとしたら
  1. Aにmapのすべてのセルの状態(色の有無)を入れる
  2. BにはAを使ってセルの探査結果を入れる

4ｘ2のmap(赤枠)で(0, 0)だけ色付きのセル
イメージ 8
この状態の時に
'現在のmapの状態を返す
'生存セルならTrue、それ以外ならFalseを格納した2次元配列を返す
Function GetState() As Boolean()
    Dim map As Range
    Set map = Range("map")
    '2次元配列を作成、これにセルの状態を入れる
    Dim rc As Long, cc As Long
    rc = map.Rows.Count - 1
    cc = map.Columns.Count - 1
    Dim v() As Boolean
    ReDim v(rc, cc)
    
    Dim x As Long, y As Long
    For x = 0 To rc
        For y = 0 To cc
            'false 0, true -1,塗りつぶしなしなら0、色付きなら-1
            v(x, y) = map.Cells(x + 1, y + 1).Interior.ColorIndex <> xlColorIndexNone
        Next
    Next
    GetState = v
End Function
これが1番の部分になる
2次元配列Aを作ってmapのすべてのセルの状態(色の有無)を入れる
これを実行して返ってきた中身は↓
 
イメージ 5
2次元配列はセルの並びと同じ感じでx, yの座標みたいになるので
同じように探査できる
色付きならTrue、なしならFalseをいれるようにしてあるので
(0, 0)の要素だけTrueが入っている
で、これを使って
 
2番のBにはAを使ってセルの探査結果を入れる
このコードが↓
 
'map全体を探査
'色付きの周囲セルの個数を格納した2次元配列を返す
'           ループなし
Function GetNextLifePointNoLoop() As Long()
    Dim st() As Boolean
    st = GetState '現在のmapの状態を取得
    Dim rc As Long, cc As Long
    rc = UBound(st, 1) 'RowsCount
    cc = UBound(st, 2) 'ColumnCount
    Dim x As Long, y As Long, LifeP As Long
    Dim xx As Long, yy As Long
    Dim v() As Long '配列
    ReDim v(UBound(st, 1), UBound(st, 2))
    
    For x = 0 To rc
        For y = 0 To cc
            LifeP = 0
            
            For i = -1 To 1
                For j = -1 To 1
                    
                    'Offset位置の調整、配列の外側に出たらなにもしない
                    xx = x + i
                    yy = y + j
                    If Not (i = 0 And j = 0) Then
                        If Not (xx < 0 Or xx > rc Or yy < 0 Or yy > cc) Then
                            If st(xx, yy) = True Then
                                LifeP = LifeP + 1 '色付きならカウントアップ
                            End If
                        End If
                    End If
                Next j
            Next i
            'カウントを記入
            v(x, y) = LifeP
            
        Next
    Next
    GetNextLifePointNoLoop = v
End Function
配列の中で探査している
周囲8個のセルで色がついている数を配列Bに入れていく
これで返ってくる中身は
イメージ 4
こう
 
イメージ 2
この状態のときは
 
イメージ 3
こんな感じで自分の周りで色付きのセルの個数がそれぞれ入っている
 
後はこの数値とルールを比べて色を塗ったり消したりするだけ
基本ルールだと3個あれば誕生するので
(0, 2)と(1, 2)が3で自身は空白だからこの2つが黒になって
生存判定だと今生きているセルの判定数値は1だから消滅
なので
□□■□
□□■□
こうなるはず
イメージ 6
 
 
今回のファイル：ライフゲーム3.xlsm
ヤフーボックス
 
 
前回の記事
エクセルVBAでライフゲームその2のコードと名前の付いたセル範囲の一覧作成マクロ ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
http://blogs.yahoo.co.jp/gogowaten/14608298.html
 
 
 
 
2017/02/18コード全文を追記
Private IsRunning As Boolean 'ターン進行中フラグ
Private pauseGame As Boolean '中止フラグ



'周囲8セルと自身セルの塗りつぶしの有無で生存判定
'生存ならそれぞれ+1、自身が生存なら+10
Function GetLifePoint(r As Range) As Long
    Dim xx As Long, yy As Long
    For xx = -1 To 1
        For yy = -1 To 1
            If r.Offset(yy, xx).Interior.ColorIndex <> xlColorIndexNone Then
                If xx = 0 And yy = 0 Then
                    life = life + 10
                Else
                    life = life + 1
                End If
            End If
        Next
    Next
    GetLifePoint = life
End Function

'1世代進む
Sub NextGeneration()
    If IsRunning = True Then Exit Sub
    IsRunning = True
    pauseGame = False
    If Range("mapのループ").Value = "あり" Then
        Call LifeGame(1, True)
    Else
        Call LifeGame(1, False)
    End If
End Sub

'ゲーム開始
Sub GameStart()
    If IsRunning = True Then Exit Sub
    IsRunning = True
    pauseGame = False
    Dim t As Long
    t = Range("ターン数").Value
    If Range("mapのループ").Value = "あり" Then
        Call LifeGame(t, True)
    Else
        Call LifeGame(t, False)
    End If
End Sub

Sub LifeGame(t As Long, mapLoop As Boolean)
   'グラフのクリア
    Dim lifeLog As Range
    Set lifeLog = Range("lifelog")
    lifeLog.Offset(1, 0).ClearContents
   'lifeLog.ClearContents
    Dim cellC As Long, lc As Long
    lc = GetLifeCount生存数カウント
    cellC = Range("map").Cells.Count
    lifeLog.Cells(2, 1).Value = lc / cellC
    lifeLog.Cells(2, 2).Value = lc
    
    Dim ti As String
    ti = Range("ターン間隔").Value
    Dim lifeC As Long
    Dim NextLifePoint() As Long
    For i = 0 To t - 1
'      Dim ts As Single, te As Single '処理時間計測用
'      ts = Timer
       '次世代へ進める
        If mapLoop Then
            NextLifePoint = GetNextLifePoint '上下左右ループあり
        Else
            NextLifePoint = GetNextLifePointNoLoop '上下左右ループなし
        End If
        
       'lifeC = nuri4(NextLifePoint)
        lifeC = nuri5(NextLifePoint)
'      te = Timer - ts '処理時間計測用
'      Debug.Print (te & "秒")
        
        Range("nowtrun").Value = i + 1 '現在ターン表示更新
        Range("lifecount").Value = lifeC  '生存数表示更新
        lifeLog.Cells(3 + i, 1).Value = lifeC / cellC
        lifeLog.Cells(3 + i, 2).Value = lifeC
        If lifeC = 0 Then Exit For  '生存数0(全滅)ならループを抜ける
        If pauseGame Then Exit For  '中止フラグチェック
        
       '表示更新間隔、待ち時間の挿入
        If ti = "最速" Then
           '待ち時間なし
'          Application.Wait [now() + "0:00:00.01"] 'ミリ秒単位
        ElseIf ti = "速い(0.1秒)" Then
            Application.Wait [now() + "0:00:00.1"] 'ミリ秒単位
        ElseIf ti = "普通(0.5秒)" Then
            Application.Wait [now() + "0:00:00.5"]
        ElseIf ti = "ゆっくり(1.0秒)" Then
            Application.Wait [now() + "0:00:01"]
        Else
            Application.Wait [now() + "0:00:00.5"]
        End If
        
        DoEvents 'これがないと画面の更新がされない
    Next
    
    IsRunning = False
    
End Sub


''塗りつぶし4、色分け 誕生セルを黒、それ以外をだんだん赤く
'Function nuri4(nextLP() As Long) As Long
'  Application.ScreenUpdating = False
'  Dim map As Range
'  Set map = Range("map")
'  Dim r As Range
'  Dim LifeP As Long, col As Long, lifeCount As Long
'  Dim lifeLower As Long, lifeUpper As Long
'  Dim lifeBirth As Long, lifeBirth2 As Long
'  lifeLower = Range("下限").Value
'  lifeUpper = Range("上限").Value
'  lifeBirth = Range("誕生").Value
'  If Range("誕生2").Value = "なし" Then
'      lifeBirth2 = lifeBirth
'  Else
'      lifeBirth2 = Range("誕生2").Value
'  End If
'  '徐々に赤くするかどうか
'  Dim colorChange As Boolean
'  If Range("色変化").Value = "あり" Then
'      colorChange = True
'  Else
'      colorChange = False
'  End If
'
'  For x = 0 To UBound(nextLP, 1)
'      For y = 0 To UBound(nextLP, 2) ' - 1
'          Set r = map.Cells(x + 1, y + 1)
'
'          LifeP = nextLP(x, y)
'          If r.Interior.ColorIndex = xlColorIndexNone Then
'          '塗りつぶしなしのセルの場合
'              If (LifeP = lifeBirth) Or (LifeP = lifeBirth2) Then
'                  '誕生
'                  r.Interior.ColorIndex = 1
'                  lifeCount = lifeCount + 1
'              End If
'          Else
'          '色付きセルの場合
'              If (LifeP <= lifeUpper And LifeP >= lifeLower) Then
'                  '生存維持
'                  lifeCount = lifeCount + 1
'                  If colorChange Then
'                      col = r.Interior.Color + 64 '徐々に赤く
'                      If col + LifeP > 256 Then
'                          r.Interior.Color = 255
'                      Else
'                          r.Interior.Color = col
'                      End If
'                  Else
'                      r.Interior.ColorIndex = 1 '黒
'                  End If
'              Else
'                  r.Interior.ColorIndex = xlColorIndexNone
'              End If
'          End If
'      Next
'  Next
'
'  Application.ScreenUpdating = True
'  nuri4 = lifeCount
'End Function


'塗りつぶし5
Function nuri5(nextLP() As Long) As Long
   '色の値設定
    Dim myRed As Long, myGreen As Long, myBlue As Long, myCyan As Long
    myRed = 230: myGreen = CLng(256) * 200: myBlue = CLng(256) * CLng(256) * CLng(255)
    myCyan = (CLng(256) * CLng(256) * CLng(250)) + (CLng(256) * 230)
    
    Application.ScreenUpdating = False
    Dim map As Range
    Set map = Range("map")
    Dim r As Range
    Dim LifeP As Long, col As Long, lifeCount As Long
    Dim lifeLower As Long, lifeUpper As Long
    Dim lifeBirth As Long, lifeBirth2 As Long
    lifeLower = Range("下限").Value
    lifeUpper = Range("上限").Value
    lifeBirth = Range("誕生").Value
    If Range("誕生2").Value = "なし" Then
        lifeBirth2 = lifeBirth
    Else
        lifeBirth2 = Range("誕生2").Value
    End If
   '徐々に赤くするかどうか
    Dim colorChange As Boolean
    If Range("色変化").Value = "あり" Then
        colorChange = True
    Else
        colorChange = False
    End If
    
    Dim iro As String
    iro = Range("色").Value
    
    For x = 0 To UBound(nextLP, 1)
        For y = 0 To UBound(nextLP, 2) ' - 1
            Set r = map.Cells(x + 1, y + 1)
            col = r.Interior.Color
            LifeP = nextLP(x, y)
            If r.Interior.ColorIndex = xlColorIndexNone Then
           '塗りつぶしなしのセルの場合
                If (LifeP = lifeBirth) Or (LifeP = lifeBirth2) Then
                   '誕生
                    lifeCount = lifeCount + 1
                    If colorChange Then
                        r.Interior.ColorIndex = 1
                    Else
                        Select Case iro
                            Case "赤": r.Interior.Color = myRed
                            Case "緑": r.Interior.Color = myGreen
                            Case "青": r.Interior.Color = myBlue
                            Case "水色": r.Interior.Color = myCyan
                            Case Else: r.Interior.ColorIndex = 1
                        End Select
                    End If
                End If
            Else
           '色付きセルの場合
                If (LifeP <= lifeUpper And LifeP >= lifeLower) Then
                   '生存維持
                    lifeCount = lifeCount + 1
                    If colorChange Then
                        If iro = "赤" Then
                            col = col + 64
                            If col > myRed Then
                                col = myRed
                            End If
                        ElseIf iro = "緑" Then
                            col = col + 256 * 64 '徐々に緑に
                            If col > myGreen Then
                                col = myGreen
                            End If
                        ElseIf iro = "青" Then
                            col = col + CLng(256) * CLng(256) * 64 '徐々に青に
                            If col > myBlue Then
                                col = myBlue
                            End If
                        ElseIf iro = "水色" Then
                            col = col + CLng(256) * CLng(256) * 64 + CLng(256) * 64
                            If col > myCyan Then
                                col = myCyan
                            End If
                        End If
                        r.Interior.Color = col
                    Else
                        Select Case iro
                            Case "赤": r.Interior.Color = myRed
                            Case "緑": r.Interior.Color = myGreen
                            Case "青": r.Interior.Color = myBlue
                            Case "水色": r.Interior.Color = myCyan
                            Case Else: r.Interior.ColorIndex = 1 '黒
                        End Select

                    End If
                Else
                   '消滅
                    r.Interior.ColorIndex = xlColorIndexNone
                End If
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    nuri5 = lifeCount
End Function

'現在のmapの状態を返す
'生存セルならTrue、それ以外ならFalseを格納した2次元配列を返す
Function GetState() As Boolean()
    Dim map As Range
    Set map = Range("map")
   '2次元配列を作成、これにセルの状態を入れる
    Dim rc As Long, cc As Long
    rc = map.Rows.Count - 1
    cc = map.Columns.Count - 1
    Dim v() As Boolean
    ReDim v(rc, cc)
    
    Dim x As Long, y As Long
    For x = 0 To rc
        For y = 0 To cc
           'false 0, true -1,塗りつぶしなしなら0、色付きなら-1
            v(x, y) = map.Cells(x + 1, y + 1).Interior.ColorIndex <> xlColorIndexNone
        Next
    Next
    GetState = v
End Function

'map全体を探査
'色付きの周囲セルの個数を格納した2次元配列を返す
'         ループあり
Function GetNextLifePoint() As Long()
    Dim st() As Boolean
    st = GetState '現在のmapの状態を取得
    Dim rc As Long, cc As Long
    rc = UBound(st, 1) 'RowsCount
    cc = UBound(st, 2) 'ColumnCount
    Dim x As Long, y As Long, LifeP As Long
    Dim xx As Long, yy As Long
    Dim v() As Long '配列
    ReDim v(UBound(st, 1), UBound(st, 2))
    
    For x = 0 To rc
        For y = 0 To cc
            LifeP = 0
            
            For i = -1 To 1
                For j = -1 To 1
                    
                   'Offset位置の調整、配列の外側に出たら反対側を参照
                    xx = x + i
                    If xx = -1 Then
                        xx = rc
                    ElseIf xx > rc Then
                        xx = 0
                    End If
                    
                    yy = y + j
                    If yy = -1 Then
                        yy = cc
                    ElseIf yy > cc Then
                        yy = 0
                    End If
                    
                   '色付きセルならlifeP+1
'                  If st(xx, yy) = True And i = 0 And j = 0 Then
''                     LifeP = LifeP + 1
'                  ElseIf st(xx, yy) = True Then
'                      LifeP = LifeP + 1
'                  End If
                    If Not (i = 0 And j = 0) Then
                        If st(xx, yy) = True Then
                            LifeP = LifeP + 1 '色付きならカウントアップ
                        End If
                    End If
                Next j
            Next i
           'カウントを記入
            v(x, y) = LifeP
            
        Next
    Next
    GetNextLifePoint = v
End Function

'map全体を探査
'色付きの周囲セルの個数を格納した2次元配列を返す
'         ループなし
Function GetNextLifePointNoLoop() As Long()
    Dim st() As Boolean
    st = GetState '現在のmapの状態を取得
    Dim rc As Long, cc As Long
    rc = UBound(st, 1) 'RowsCount
    cc = UBound(st, 2) 'ColumnCount
    Dim x As Long, y As Long, LifeP As Long
    Dim xx As Long, yy As Long
    Dim v() As Long '配列
    ReDim v(UBound(st, 1), UBound(st, 2))
    
    For x = 0 To rc
        For y = 0 To cc
            LifeP = 0
            
            For i = -1 To 1
                For j = -1 To 1
                    
                   'Offset位置の調整、配列の外側に出たらなにもしない
                    xx = x + i
                    yy = y + j
                    If Not (i = 0 And j = 0) Then
                        If Not (xx < 0 Or xx > rc Or yy < 0 Or yy > cc) Then
                            If st(xx, yy) = True Then
                                LifeP = LifeP + 1 '色付きならカウントアップ
                            End If
                        End If
                    End If
                Next j
            Next i
           'カウントを記入
            v(x, y) = LifeP
            
        Next
    Next
    GetNextLifePointNoLoop = v
End Function


'マップの範囲変更、選択範囲をライフゲームの範囲にする
Sub ChangeMapRange()
    If IsRunning = True Then Exit Sub
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Areas.Count > 1 Then
        MsgBox "複数の選択範囲は選べない"
        Exit Sub
    End If
    Dim r As Range
    Set r = Selection
   'セルD3より上か右のセルが選択されていたら変更しないで終了
    If TypeName(Intersect(r, Range("1:2"))) = "Range" Then
        MsgBox "セルD3より左か上のセルが選択されているので変更できません"
        Exit Sub
    End If
    If TypeName(Intersect(r, Range("A:C"))) = "Range" Then
        MsgBox "セルD3より左か上のセルが選択されているので変更できません"
        Exit Sub
    End If
    
    
    If MsgBox("選択範囲をライフゲームの範囲に変更します", vbYesNo) = vbYes Then
        Dim rA As Range
        
       'mapA
        Set rA = Range("map")
        ad = rA.Address
        
        rA.ClearFormats '古い範囲の書式をクリア
       '範囲の変更と新しい範囲に枠線
        Set rA = Selection
        rA.Name = "map"
        rA.Borders.Color = RGB(200, 200, 200) '灰色罫線
        rA.BorderAround , xlThin, 3 '赤枠
        Range("セル数").Value = Range("map").Cells.Count 'セル数表示更新
        Range("lifecount").Value = 0
        Worksheets("lifegameA").Calculate
        
    End If
End Sub

'クリア､全セル塗りつぶしなし
Sub ClearColor()
    If IsRunning = True Then Exit Sub '進行中はクリアしない
    
    Range("map").Interior.ColorIndex = xlColorIndexNone
       'グラフのクリア
    Dim lifeLog As Range
    Set lifeLog = Range("lifelog")
    lifeLog.Offset(1, 0).ClearContents
End Sub

'生存数カウント
Function GetLifeCount生存数カウント() As Long
    Dim r As Range
    Dim life As Long
    For Each r In Range("map")
        If r.Interior.ColorIndex <> xlColorIndexNone Then
            life = life + 1
        End If
    Next
    GetLifeCount生存数カウント = life
End Function

'初期配置
Sub initial初期配置()
    If IsRunning = True Then Exit Sub
    Dim r As Range
    Set r = Range("map")
    r.Interior.ColorIndex = xlColorIndexNone
    Dim rr As Range
    For Each rr In r
        Randomize
        If Rnd < Range("liferacio").Value Then '0.2なら約2割のセルを黒で塗る
            rr.Interior.ColorIndex = 1
        End If
    Next
    Range("lifecount").Value = GetLifeCount生存数カウント
End Sub

'ルールリセット
Sub ResetRule()
    Range("下限").Value = 2
    Range("上限").Value = 3
    Range("誕生").Value = 3
    Range("誕生2").Value = "なし"
End Sub

'中止
Sub tyuusi中止()
    pauseGame = True
End Sub
Sub colortest()
    
'      With iRGB
'      .iRed = myColor Mod 256
'      .iGreen = Int(myColor / 256) Mod 256
'      .iBlue = Int(myColor / 256 / 256)
'  End With
    Dim c As Long
    c = ActiveCell.Interior.Color
    c = CLng(256) * CLng(200)
    c = 16386
    r = c Mod 256
    g = Int(c / 256) Mod 256
    b = Int(c / 256 / 256)
End Sub