はじめに
以下の記事で紹介したツールで思いついた、塗りつぶしアルゴリズムです。
2020年7月時点で、ググって見つかった塗りつぶしアルゴリズムはほとんど、「Scan Line Seed Fill」など再帰かスタックを使うものばかりだったので。
名付けて、「一筆書き法」 です
基本のアルゴリズム
まずは塗りつぶし部分のソース
'*****************************************************************************
'[概要] 一筆書きを実行し、行詰れば次の起点となるセルを検索しそのセルから一筆書きを実行する
' 起点となるセルが見つからなくなるまで、一筆書きを続ける
'[引数] x,y:塗りつぶし開始座標、Pixels():塗つぶし用の配列
'[戻値] なし
'*****************************************************************************
Public Sub FillCell(ByVal x As Long, ByVal y As Long, ByRef Pixels() As Byte)
Dim Width As Long, Height As Long
Width = UBound(Pixels, 1) - 1
Height = UBound(Pixels, 2) - 1
'一筆書きが行詰った時、次の起点となるセルを検索し、起点となるセルが見つからなくなるまでLOOP
Do While True
'一筆書きを実行
Call Onestroke(x, y, Pixels())
'次の起点となるセルを検索
For x = 1 To Width
For y = 1 To Height
If Pixels(x, y) = 0 Then '塗りつぶし前の対象セルか
'隣接するセルにすでに塗りつぶしたセルがあるか
If Pixels(x - 1, y) = 1 Or _
Pixels(x + 1, y) = 1 Or _
Pixels(x, y - 1) = 1 Or _
Pixels(x, y + 1) = 1 Then
'起点となるセル(x,y)から一筆書きを実行
GoTo CONTINUE
End If
End If
Next
Next
Exit Sub
CONTINUE:
Loop
End Sub
'*****************************************************************************
'[概要] 一筆書きを行詰るまで実行する
'[引数] x,y:開始座標、Pixels():塗りつぶし用の配列
'[戻値] なし
'*****************************************************************************
Private Sub Onestroke(ByVal x As Long, ByVal y As Long, ByRef Pixels() As Byte)
Do While True
Pixels(x, y) = 1 '塗りつぶし
'上に塗りつぶし前の対象セルがあるか
If Pixels(x, y - 1) = 0 Then
y = y - 1
'下に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x, y + 1) = 0 Then
y = y + 1
'左に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x - 1, y) = 0 Then
x = x - 1
'右に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x + 1, y) = 0 Then
x = x + 1
Else
'一筆書き終了
Exit Sub
End If
Loop
End Sub
解説
実行方法
関数FillCell()に次の引数を設定して実行します
x,y：塗りつぶし開始座標
Pixels()：Pixels(0 to Width+1, 0 to Height+1)の大きさの2次元配列。値には「0:開始セルと同一色の塗りつぶし前の状態, 1:塗りつぶし済み, 9:壁または対象外」のいずれかを格納する
壁：あらかじめキャンバスの四方を壁(値9)で囲んでおく
実行結果
引数のPixels()配列のPixels(1 to Width, 1 to Height)の範囲に1が設定されたセルが、今回塗りつぶした結果となります
アルゴリズム
赤色のセルから塗りつぶすとします
- 開始セルから、上下左右の優先順位で一筆書きの要領で塗りつぶせるところは行詰るまで塗りつぶします。
- 1.が行詰ると、座標(1,1)から座標(7,5)まで2次元LOOPで、次の一筆書きの起点となるセルを検索します。
起点となるセルの対象条件は以下の通りとします
・自身のセルが、対象色の塗りつぶし前の状態
・隣接するセルのいづれかが、塗りつぶし済みとなっている - 2.の起点としたセルから再度一筆書きを実行する
- 2,3を次の一筆書きの起点となるセルがみつからなくなるまでLOOP
実行結果
赤太字のセルは一筆書きが行詰り、再探索の結果次の一筆書きの起点となったセルを指します。
セルの番号は塗りつぶしの順番となります。
ここまでが基本のアルゴリズムとなります。
スタックも再帰も使っていないので、誰でも理解できると思います。
ここまででも、私がリリースしたアイコンエディタ程度であれば充分に実用的な速度で処理が実行されます。
高速化処理
ここからは、処理が幾分か複雑になりますが、何点かの高速化ロジックを実装したいと思います。
高速化するために、以下の２点を改善することにします。
- なるべく一筆書きが行詰らないようにする
- 一筆書きの起点を探索するLOOPの回数を減らす
「1.」の一筆書きが行詰らないようにするための改良
一筆書きにおいて、上下左右に対象セルが見つからない場合、斜め四方向にも一筆書きの続行が可能なセルがないか判定します。
判定条件は以下の通りとなります
・セルの状態が、対象色の塗りつぶし前の状態
・隣接するセルのいづれかが、塗りつぶし済みとなっている
'*****************************************************************************
'[概要] 一筆書きを行詰るまで実行する
'[引数] x,y:開始座標、Pixels():塗りつぶし用の配列
'[戻値] なし
'*****************************************************************************
Private Sub Onestroke(ByVal x As Long, ByVal y As Long, ByRef Pixels() As Byte)
Do While True
Pixels(x, y) = 1 '塗りつぶし
'上に塗りつぶし前の対象セルがあるか
If Pixels(x, y - 1) = 0 Then
y = y - 1
'下に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x, y + 1) = 0 Then
y = y + 1
'左に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x - 1, y) = 0 Then
x = x - 1
'右に塗りつぶし前の対象セルがあるか
ElseIf Pixels(x + 1, y) = 0 Then
x = x + 1
Else
'左上に塗りつぶし前の対象セルがあるか かつ 隣接セルに塗りつぶしが完了したセルがあるか
If Pixels(x - 1, y - 1) = 0 And (Pixels(x - 1, y) = 1 Or Pixels(x, y - 1) = 1) Then
x = x - 1: y = y - 1
'左下に塗りつぶし前の対象セルがあるか かつ 隣接セルに塗りつぶしが完了したセルがあるか
ElseIf Pixels(x - 1, y + 1) = 0 And (Pixels(x - 1, y) = 1 Or Pixels(x, y + 1) = 1) Then
x = x - 1: y = y + 1
'右上に塗りつぶし前の対象セルがあるか かつ 隣接セルに塗りつぶしが完了したセルがあるか
ElseIf Pixels(x + 1, y - 1) = 0 And (Pixels(x + 1, y) = 1 Or Pixels(x, y - 1) = 1) Then
x = x + 1: y = y - 1
'右下に塗りつぶし前の対象セルがあるか かつ 隣接セルに塗りつぶしが完了したセルがあるか
ElseIf Pixels(x + 1, y + 1) = 0 And (Pixels(x + 1, y) = 1 Or Pixels(x, y + 1) = 1) Then
x = x + 1: y = y + 1
Else
'一筆書き終了
Exit Sub
End If
End If
Loop
End Sub
サンプルの実行結果
再探索の対象セルが2セルだけになりました。
「2.」LOOPの回数を減らすための改良
前提：「1.」の対応はいったんなしとして説明をします。
その１
次の一筆書きの起点を探す2次元LOOPを、毎回座標(1,1)から始めるのではなく、1回前の一筆書きの起点から再探索することにします。
例として、終盤に上図のように断片化した白色の塗り残しセルを回収するケースを考えた場合、この方法の利点が想像できると思います。
サンプルの実行結果
赤太字のセルが座標(1,1)から探索した起点セル、黒太字のセルが1回前の起点のセルから探索した起点セルとなります。
基本パターンに比べて、再探索用の2次元LOOPの回数が、5回から2回に減りました。
その２
次の一筆書きの起点を探すLOOPを、x軸→y軸の２次元LOOP から y軸→x軸の２次元のLOOPに変えます。
理由は、一筆書きの優先順位を左方向より、上方向を優先しているためです。
これにより、２次元LOOPで次の起点の発見が左方向優先より早くなります。
サンプルの実行結果
「その１」に比べて、再探索用の2次元LOOPの回数が、2回から1回に減りました。
これらの高速化を実現するために、関数FillCell()を改良します
'*****************************************************************************
'[概要] 一筆書きを実行し、行詰れば次の起点となるセルを検索しそのセルから一筆書きを実行する
' 起点となるセルが見つからなくなるまで、一筆書きを続ける
'[引数] x,y:座標、Pixels():塗りつぶし用の配列
'[戻値] なし
'*****************************************************************************
Public Sub FillCell(ByVal x As Long, ByVal y As Long, ByRef Pixels() As Byte)
Dim Width As Long, Height As Long
Width = UBound(Pixels, 1) - 1
Height = UBound(Pixels, 2) - 1
'一筆書きを実行
Call Onestroke(x, y, Pixels())
Dim blnContinue As Boolean
'一筆書きが行詰った時、次の起点となるセルを検索し、起点となるセルが見つからなくなるまでLOOP
Do While True
blnContinue = False
For y = 1 To Height
For x = 1 To Width
If Pixels(x, y) = 0 Then '塗りつぶし前の対象セルか
'隣接するセルにすでに塗りつぶしセルがあるか
If Pixels(x - 1, y) = 1 Or _
Pixels(x + 1, y) = 1 Or _
Pixels(x, y - 1) = 1 Or _
Pixels(x, y + 1) = 1 Then
'起点となるセルから一筆書きを実行
Call Onestroke(x, y, Pixels())
blnContinue = True
End If
End If
Next
Next
If Not blnContinue Then
Exit Sub
End If
Loop
End Sub
サンプルファイル
こちらにEXCEL用のサンプルソースがあります
アクティブシートに例えば以下のように値を設定して実行してください。
値に9を設定したセルが塗りつぶしの境界となります。
対象範囲と、塗りつぶし開始セルはソースコードの
Const START = "D5"
Const CANVAS = "B2:F6"
にて設定してください。