ギフト包装法(凸包アルゴリズム)｜Excel VBAで学ぶ数学とアルゴリズム

今回は凸包とつほうアルゴリズムの「ギフト包装法」について解説していきます。
凸包アルゴリズムはいろいろな種類がありますが、ギフト包装法は最も単純で理解しやすいアルゴリズムです。その分、他の凸包アルゴリズムに比べて処理時間は多くかかってしまいますが、これから凸包アルゴリズムを理解し始めるという場合にはうってつけのアルゴリズムといってもいいです。

本ページではこの「ギフト包装法」のアルゴリズムがどういった仕組みなのかを解説し、Excel VBAのコードとして実装していきます。

こういったアルゴリズムはPythonやC++などのがっつりしたプログラム言語では紹介されていることがあります。これは実際にその言語で使われるというのもそうですが、プログラムのコードとして見ることでアルゴリズムの中身をより深く理解することができるためです。

ここではそういった”がっつりとしたプログラミング言語”ではないVBAを使うことで、幅広い方に向けてギフト包装法のアルゴリズムの内容をご紹介していきます。

1. 凸包アルゴリズムとは
2. ギフト包装法
- 2.1. サンプルコード
3. まとめ

凸包アルゴリズムとは

凸包(Convex Hull)とは

凸包とは「与えられた点をすべてを包含する最小の凸多角形」のことをいいます。
文字の説明だけだとイメージしづらいかもしれませんが下画像のように2次元上にある複数の点に対して、輪ゴムをかけたときにできるような形状が凸包の形状です。

凸包はパターン認識・画像処理・統計学・地理情報システム・抽象解釈による静的コード解析などの幅広い分野で利用がされています。
　

凸包アルゴリズム

凸包アルゴリズムとはその名の通りで、凸包を求めるアルゴリズムです。
点集合を入力した場合に、その凸包頂点を求めるアルゴリズムで、代表的なものは下記の通りです。

・ギフト包装法　処理時間：nh
・グラハムスキャン　処理時間：n log n
・クイックハル　　　処理時間：n log n
(※処理時間表記入力する点の数：n , 凸包頂点数：h とする)

どれも凸包を求めるまでの過程や処理時間は違いますが、基本的には最終出力は同じです。
※各アルゴリズムの利用可能な次元の範囲は違いますが、ここではすべて2次元のみで考えます。

以下では処理時間はかかりますが最も理解しやすく処理内容が単純な「ギフト包装法」のアルゴリズムをVBAコードを使って紹介していきます。

ギフト包装法

ギフト包装法のアルゴリズムはいたって単純で下記の処理を行います。

① Y座標が最も小さい点を基準点として取得
　(※最小Y座標が一致する点が複数ある場合は、その中でもX座標が最も小さい点を取得)
② 選んだ1点から別の点に直線を結び他のすべての点がその直線の片側に来るような点を見つける
③ ②の処理を基準点が再び選ばれるまで繰り返す

　

Animation depicting the gift wrapping algorithm.gif ©Maonus (Licensed under CC BY 4.0)

処理のイメージとしては上のgif画像の通りで、はじめに凸包頂点となる1点(基準点)を取得し、その他のすべての点を網羅的に確認して“基準点の次にある最も左側の点”を取得。取得した点を新たな基準点として設定し、再び同じ処理を行っていきます。
(※判定の”側”が常に一定であるのであれば”最も右側の点”でも求めることができます)

ここでいう“基準点の次にある最も左側の点”は外積を求めることで判定することができます。

たとえば上画像の点Aを基準点とした時、ベクトルABとベクトルACの外積を求めることで、下記の通り点Cが直線ABに対して左側にあるか、右側にあるかを判定することが出来ます。

・ベクトルABとベクトルACの外積が0より大きい場合、点Cは直線ABに対して左側にある
・ベクトルABとベクトルACの外積が0より小さい場合、点Cは直線ABに対して右側にある

上画像の場合は点Cが直線ABより右側にあることからもわかる通りで、ベクトルABとベクトルACの外積が0より小さい場合です。

外積は点座標から求めることができるので、この考えを使って常に最も左側(もしくは最も右側)の点を順に取得していけば、最終的に初めの点に戻ってきて凸包が導き出せるという訳です。

これは少し考え方を変えてみると、下図のように点集合を一定方向に回転させながら凸包を導き出しているというふうにも考えることもできます。このとき、まるでギフト(贈り物)を包装しているように見えることから、このアルゴリズムは「ギフト包装法」と呼ばれています。

サンプルコード

ギフト包装法をVBAコードで書くと下記の通りです。
Excel VBAでの実装ということでShapeオブジェクトの「円」を点として扱います。
上画像(左側)のような点集合を入力すると上画像(右側)のような凸包のエッジを直線で作成します。

Sub main()

    Dim cCircle As Collection
    Dim cConvexHull As Collection
    
    '円(ｼｪｲﾌﾟ)をｺﾚｸｼｮﾝに格納
    Set cCircle = GetCircle
    
    '凸包作成
    Set cConvexHull = GiftWrapping(cCircle)

End Sub
'---------------------------------------------------------------------------------------------
'   ｱｸﾃｨﾌﾞｼｰﾄ内の全ての円(ｼｪｲﾌﾟ)を取得して返す
'       cPoints ：点集合の入ったｺﾚｸｼｮﾝ
'       戻り値  ：凸包頂点の入ったｺﾚｸｼｮﾝ
'---------------------------------------------------------------------------------------------
Function GetCircle() As Collection

    Dim cCircle As Collection
    Dim shpTmp As Shape
    
    Set cCircle = New Collection
    
    For Each shpTmp In ActiveSheet.Shapes
        If shpTmp.AutoShapeType = msoShapeOval Then
            Call cCircle.Add(shpTmp)
        End If
    Next shpTmp

    Set GetCircle = cCircle

End Function
'---------------------------------------------------------------------------------------------
'   【凸包アルゴリズム(ギフト包装法)】
'   入力された点群における凸包頂点をすべて取得する
'       cPoints ：点集合の入ったｺﾚｸｼｮﾝ
'       戻り値  ：凸包頂点の入ったｺﾚｸｼｮﾝ
'---------------------------------------------------------------------------------------------
Function GiftWrapping(cPoints As Collection) As Collection

    Dim cConvexHull As Collection
    Dim oPt As Shape
    Dim oPtMin As Shape
    
    Dim oPtBase As Shape
    Dim oPtLast As Shape
    Dim oPtBefore As Shape
    Dim oLin As Shape
    
    Dim dCoord() As Double
    Dim dCoord1() As Double
    Dim dCoord2() As Double
    Dim dMinX As Double:   dMinX = 10000000#    '|大きい座標値を設定
    Dim dMinY As Double:   dMinY = 10000000#    '|ここから小さくなっていく
    Dim i As Long
    
    
    Set cConvexHull = New Collection

    '【基準点取得】
    ' Y座標値が最も小さい点を取得
    ' 同じY座標が存在する場合はその中でもX座標が最小の点を取得
    For Each oPt In cPoints

        '点座標を取得(円の中心座標)
        dCoord = GetCenterCoord(oPt)
        
        'Y座標最小点を取得
        If dMinX > dCoord(1) Then
            dMinX = dCoord(1)
            Set oPtMin = oPt
            
            'X座標最小点を取得
            If dMinY < dCoord(0) Then
                dMinY = dCoord(0)
                Set oPtMin = oPt
            End If
        End If

    Next oPt
    
    
    '基準点(開始点)と最終点を定義
    '凸包は閉曲線のため基準点＝最終点となる
    Set oPtBase = oPtMin
    Set oPtLast = oPtMin
    
    Do
        '直線の始点と終点を設定
        Set oPtBefore = oPtLast                       '始点
        Set oPtLast = GetNextPoint(oPtLast, cPoints)  '終点(ｷﾞﾌﾄ包装法で次の頂点を取得)
        
        '直線の始点と終点の座標を取得
        dCoord1 = GetCenterCoord(oPtBefore)
        dCoord2 = GetCenterCoord(oPtLast)

        '直線作成
        Set oLin = ActiveSheet.Shapes. _
                   AddConnector(msoConnectorStraight, dCoord1(0), dCoord1(1), dCoord2(0), dCoord2(1))
        
        '凸包頂点をｺﾚｸｼｮﾝに格納
        cConvexHull.Add oPtLast

    Loop While (oPtBase.Name <> oPtLast.Name)
     
    Set GiftWrapping = cConvexHull
    
End Function
'---------------------------------------------------------------------------------------------
'   入力点からみて次に最も左側に位置する点を返す
'       oPtCheck：
'       cPoints ：点集合の入ったｺﾚｸｼｮﾝ
'       戻り値  ：凸包頂点の入ったｺﾚｸｼｮﾝ
'---------------------------------------------------------------------------------------------
Function GetNextPoint(oPtCheck As Shape, cPoints As Collection) As Shape

    Dim oPtNext As Shape
    Dim oPt As Shape

    Dim dVecCross As Double
    Dim dVec1 As Double
    Dim dVec2 As Double
            
    Dim dCoordPt() As Double
    Dim dCoordPtCheck() As Double
    Dim dCoordPtNext() As Double
    Dim i As Long
    
    
    Set oPtNext = cPoints.Item(1)
    For i = 1 To cPoints.Count

        Set oPt = cPoints.Item(i)

        If (oPtCheck.Name = oPtNext.Name) Then
            Set oPtNext = oPt
        Else
            
            '座標取得
            dCoordPt = GetCenterCoord(oPt)
            dCoordPtCheck = GetCenterCoord(oPtCheck)
            dCoordPtNext = GetCenterCoord(oPtNext)
 
            '外積計算
            dVecCross = (dCoordPtCheck(0) - dCoordPtNext(0)) * (dCoordPtCheck(1) - dCoordPt(1)) - _
                        (dCoordPtCheck(0) - dCoordPt(0)) * (dCoordPtCheck(1) - dCoordPtNext(1))

            dVec1 = (dCoordPtCheck(0) - dCoordPtNext(0)) * (dCoordPtCheck(0) - dCoordPtNext(0)) + _
                 (dCoordPtCheck(1) - dCoordPtNext(1)) * (dCoordPtCheck(1) - dCoordPtNext(1))

            dVec2 = (dCoordPtCheck(0) - dCoordPt(0)) * (dCoordPtCheck(0) - dCoordPt(0)) + _
                 (dCoordPtCheck(1) - dCoordPt(1)) * (dCoordPtCheck(1) - dCoordPt(1))

            If dVecCross > 0 Or (dVecCross = 0 And Abs(dVec2) > Abs(dVec1)) Then
                Set oPtNext = oPt
            End If

        End If

    Next i

    Set GetNextPoint = oPtNext

End Function

'---------------------------------------------------------------------------------------------
'   入力された円(ｼｪｲﾌﾟ)の中心座標を返す
'       shpCircle   ：対象の円(ｼｪｲﾌﾟ)
'       戻り値      ：入力された円の中心座標の入った配列
'---------------------------------------------------------------------------------------------
Function GetCenterCoord(shpCircle As Shape) As Double()

    Dim dCoord(0 To 1) As Double
    
    dCoord(0) = shpCircle.Left + (shpCircle.Width / 2)
    dCoord(1) = shpCircle.Top + (shpCircle.Height / 2)

    GetCenterCoord = dCoord()

End Function

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

Sub main()

Dim cCircle As Collection

Dim cConvexHull As Collection

'円(ｼｪｲﾌﾟ)をｺﾚｸｼｮﾝに格納

Set cCircle = GetCircle

'凸包作成

Set cConvexHull = GiftWrapping(cCircle)

End Sub

'---------------------------------------------------------------------------------------------

' ｱｸﾃｨﾌﾞｼｰﾄ内の全ての円(ｼｪｲﾌﾟ)を取得して返す

' cPoints ：点集合の入ったｺﾚｸｼｮﾝ

' 戻り値：凸包頂点の入ったｺﾚｸｼｮﾝ

'---------------------------------------------------------------------------------------------

Function GetCircle() As Collection

Dim cCircle As Collection

Dim shpTmp As Shape

Set cCircle = New Collection

For Each shpTmp In ActiveSheet.Shapes

If shpTmp.AutoShapeType = msoShapeOval Then

Call cCircle.Add(shpTmp)

End If

Next shpTmp

Set GetCircle = cCircle

End Function

'---------------------------------------------------------------------------------------------

' 【凸包アルゴリズム(ギフト包装法)】

' 入力された点群における凸包頂点をすべて取得する

' cPoints ：点集合の入ったｺﾚｸｼｮﾝ

' 戻り値：凸包頂点の入ったｺﾚｸｼｮﾝ

'---------------------------------------------------------------------------------------------

Function GiftWrapping(cPoints As Collection) As Collection

Dim cConvexHull As Collection

Dim oPt As Shape

Dim oPtMin As Shape

Dim oPtBase As Shape

Dim oPtLast As Shape

Dim oPtBefore As Shape

Dim oLin As Shape

Dim dCoord() As Double

Dim dCoord1() As Double

Dim dCoord2() As Double

Dim dMinX As Double: dMinX = 10000000# '|大きい座標値を設定

Dim dMinY As Double: dMinY = 10000000# '|ここから小さくなっていく

Dim i As Long

Set cConvexHull = New Collection

'【基準点取得】

' Y座標値が最も小さい点を取得

' 同じY座標が存在する場合はその中でもX座標が最小の点を取得

For Each oPt In cPoints

'点座標を取得(円の中心座標)

dCoord = GetCenterCoord(oPt)

'Y座標最小点を取得

If dMinX > dCoord(1) Then

dMinX = dCoord(1)

Set oPtMin = oPt

'X座標最小点を取得

If dMinY < dCoord(0) Then

dMinY = dCoord(0)

Set oPtMin = oPt

End If

Next oPt

'基準点(開始点)と最終点を定義

'凸包は閉曲線のため基準点＝最終点となる

Set oPtBase = oPtMin

Set oPtLast = oPtMin

'直線の始点と終点を設定

Set oPtBefore = oPtLast '始点

Set oPtLast = GetNextPoint(oPtLast, cPoints) '終点(ｷﾞﾌﾄ包装法で次の頂点を取得)

'直線の始点と終点の座標を取得

dCoord1 = GetCenterCoord(oPtBefore)

dCoord2 = GetCenterCoord(oPtLast)

'直線作成

Set oLin = ActiveSheet.Shapes. _

AddConnector(msoConnectorStraight, dCoord1(0), dCoord1(1), dCoord2(0), dCoord2(1))

'凸包頂点をｺﾚｸｼｮﾝに格納

cConvexHull.Add oPtLast

Loop While (oPtBase.Name <> oPtLast.Name)

Set GiftWrapping = cConvexHull

End Function

'---------------------------------------------------------------------------------------------

' 入力点からみて次に最も左側に位置する点を返す

' oPtCheck：

' cPoints ：点集合の入ったｺﾚｸｼｮﾝ

' 戻り値：凸包頂点の入ったｺﾚｸｼｮﾝ

'---------------------------------------------------------------------------------------------

Function GetNextPoint(oPtCheck As Shape, cPoints As Collection) As Shape

Dim oPtNext As Shape

Dim oPt As Shape

Dim dVecCross As Double

Dim dVec1 As Double

Dim dVec2 As Double

Dim dCoordPt() As Double

Dim dCoordPtCheck() As Double

Dim dCoordPtNext() As Double

Dim i As Long

Set oPtNext = cPoints.Item(1)

For i = 1 To cPoints.Count

Set oPt = cPoints.Item(i)

If (oPtCheck.Name = oPtNext.Name) Then

Set oPtNext = oPt

Else

'座標取得

dCoordPt = GetCenterCoord(oPt)

dCoordPtCheck = GetCenterCoord(oPtCheck)

dCoordPtNext = GetCenterCoord(oPtNext)

'外積計算

dVecCross = (dCoordPtCheck(0) - dCoordPtNext(0)) * (dCoordPtCheck(1) - dCoordPt(1)) - _

(dCoordPtCheck(0) - dCoordPt(0)) * (dCoordPtCheck(1) - dCoordPtNext(1))

dVec1 = (dCoordPtCheck(0) - dCoordPtNext(0)) * (dCoordPtCheck(0) - dCoordPtNext(0)) + _

(dCoordPtCheck(1) - dCoordPtNext(1)) * (dCoordPtCheck(1) - dCoordPtNext(1))

dVec2 = (dCoordPtCheck(0) - dCoordPt(0)) * (dCoordPtCheck(0) - dCoordPt(0)) + _

(dCoordPtCheck(1) - dCoordPt(1)) * (dCoordPtCheck(1) - dCoordPt(1))

If dVecCross > 0 Or (dVecCross = 0 And Abs(dVec2) > Abs(dVec1)) Then

Set oPtNext = oPt

End If

Next i

Set GetNextPoint = oPtNext

End Function

'---------------------------------------------------------------------------------------------

' 入力された円(ｼｪｲﾌﾟ)の中心座標を返す

' shpCircle ：対象の円(ｼｪｲﾌﾟ)

' 戻り値：入力された円の中心座標の入った配列

'---------------------------------------------------------------------------------------------

Function GetCenterCoord(shpCircle As Shape) As Double()

Dim dCoord(0 To 1) As Double

dCoord(0) = shpCircle.Left + (shpCircle.Width / 2)

dCoord(1) = shpCircle.Top + (shpCircle.Height / 2)

GetCenterCoord = dCoord()

End Function

円を作るのが面倒な場合

円をいちいち作成するのは面倒だと思うので下記コードを利用してください。
「RandomCircle」を実行すれば指定した範囲内に指定した個数だけ円をランダムで作成することができます。(最上部の定数の値を書き換えることで作成範囲や個数を変更することができます)

Const CREATE_COUNT As Long = 20     '作成個数
Const RANGE_MAX As Double = 300#    '作成範囲 最大座標値
Const RANGE_MIN As Double = 50#     '作成範囲 最小座標値

Sub RandomCircle()

    Dim shpCircle As Shape
    Dim dCoordX As Double
    Dim dCoordY As Double
    Dim i As Long
    Dim cCircle As Collection

    Set cCircle = New Collection
    
    For i = 1 To CREATE_COUNT
    
        'ランダム座標生成
        Randomize
        dCoordX = (RANGE_MAX - RANGE_MIN + 1) * Rnd + RANGE_MIN
        dCoordY = (RANGE_MAX - RANGE_MIN + 1) * Rnd + RANGE_MIN

        '円作成
        Set shpCircle = CreateCircle(dCoordX, dCoordY, 5, 5)
        
        Call cCircle.Add(shpCircle)
    
    Next i

End Sub
'---------------------------------------------------------------------------------------------
'   円(ｼｪｲﾌﾟ)を作成する
'       dCoordX   ：X座標
'       dCoordY   ：Y座標
'       dWidth    ：幅
'       dHeight   ：高さ
'       戻り値    ：作成した円
'---------------------------------------------------------------------------------------------
Function CreateCircle(dCoordX As Double, dCoordY As Double, _
                      dWidth As Double, dHeight As Double) As Shape

    Dim shpCircle As Shape
    
    '円(ｼｪｲﾌﾟ)作成
    Set shpCircle = ThisWorkbook.ActiveSheet. _
                    Shapes.AddShape(msoShapeOval, dCoordX, dCoordY, dWidth, dHeight)

    '枠線非表示
    shpCircle.Line.Visible = msoFalse
    
    'ｶﾗｰ変更
    shpCircle.Fill.ForeColor.RGB = RGB(0, 0, 255)
    
    Set CreateCircle = shpCircle

End Function
'---------------------------------------------------------------------------------------------
'   入力された円(ｼｪｲﾌﾟ)の中心座標を返す
'       shpCircle   ：対象の円(ｼｪｲﾌﾟ)
'       戻り値      ：入力された円の中心座標の入った配列
'---------------------------------------------------------------------------------------------
Function GetCenterCoord(shpCircle As Shape) As Double()

    Dim dCoord(0 To 1) As Double
    
    dCoord(0) = shpCircle.Left + (shpCircle.Width / 2)
    dCoord(1) = shpCircle.Top + (shpCircle.Height / 2)

    GetCenterCoord = dCoord()

End Function