前提・実現したいこと
あるグラフの隣接行列A1とあるグラフの隣接行列A2がわかっているとして
A1 = P * A2__T__ * P__T__ (__T__は転置)
を満たす置換行列(各行各列に1が一つ、それ以外が0の行列)Pが存在するかどうか調べるプログラムを作成したいです。
置換行列Pが存在すれば、A2はA1に含まれる部分グラフだということまでわかったのですが、
Pの求め方がわからなくて困っています。
下のソースは置換行列Pが存在する場合の行列をA1とA2に設定しています。
ご教授願います。
よろしくお願いいたします。
該当のソースコード
VBA
1Option Explicit 2 3Sub main() 4 Dim A1 5 Dim A2 6 7 A1 = [{0,1,1,1,1,0,0,0,0,0,0;1,0,0,0,0,1,0,0,0,0,0;1,0,0,0,0,0,1,1,1,0,0;1,0,0,0,0,0,0,0,0,0,0;1,0,0,0,0,0,0,0,0,0,0;0,1,0,0,0,0,0,0,0,2,1;0,0,1,0,0,0,0,0,0,0,0;0,0,1,0,0,0,0,0,0,0,0;0,0,1,0,0,0,0,0,0,0,0;0,0,0,0,0,2,0,0,0,0,0;0,0,0,0,0,1,0,0,0,0,0}] 8 A2 = [{0,1,0,0,0;1,0,1,0,0;0,1,0,2,1;0,0,2,0,0;0,0,1,0,0}] 9 10 ' 置換行列Pが存在すれば、Pありと出力 11 If SubgraphHomotyping(A1, A2) = True Then 12 Debug.Print "Pあり" 13 Else 14 Debug.Print "Pなし" 15 End If 16End Sub 17 18' 置換行列Pが存在するか判定する処理(存在すればTrue, 存在しなければFalse) 19Function SubgraphHomotyping(A1 As Variant, A2 As Variant) As Boolean 20 21 ' 処理をここに記述 22 23 If Pが存在する Then 24 SubgraphHomotyping = True 25 Else 26 SubgraphHomotyping = False 27 End If 28 29End Function 30
気になる質問をクリップする
クリップした質問は、後からいつでもMYページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
回答3件
0
http://www-erato.ist.hokudai.ac.jp/lecture2013/docs/washio2.pdf
こんなPDFを眺めてみました。p.7にある部分グラフ同型判定のところを見ますとNP完全問題とありました。p.9以降に様々な具体的手法が紹介されていますね。
p.9にUllmannの方法として「一定の約束事(行や列の順列など)で重複なく置換行列Pを生成する」と有りますが、この方法ではNP完全問題をまともに解く(有り得る様々なPを想定してしらみつぶしに調べてゆく)ということのように思えました。しかしこのページ以降に置換行列Pの大きさをしぼれそうな様々な手法が書かれていますね。
いずれにせよ少なくとも重複なく置換行列Pを生成するという論理が必要と思います。A1の大きさと重みありの個数を見ますと、まともに有り得る置換行列の全ての組み合わせを探索しても9!×2 = 725760
となりますので素朴に総当たりしても(ご質問にある規模の問題なら)時間的には大丈夫な気がします。
(追記:最大30x30を想定しておられるとのことでまともに全探索するアプローチでは不十分と思いました)
追記:VBAではありませんが、ご要望があったので全探索をするPythonコードを参考までに挙げておきます。
適当に書いたままなのであまりよいコードではありませんが。
Python
1import numpy as np 2import functools 3import operator 4 5A1=[ 6 [0,1,1,1,1,0,0,0,0,0,0], 7 [1,0,0,0,0,1,0,0,0,0,0], 8 [1,0,0,0,0,0,1,1,1,0,0], 9 [1,0,0,0,0,0,0,0,0,0,0], 10 [1,0,0,0,0,0,0,0,0,0,0], 11 [0,1,0,0,0,0,0,0,0,2,1], 12 [0,0,1,0,0,0,0,0,0,0,0], 13 [0,0,1,0,0,0,0,0,0,0,0], 14 [0,0,1,0,0,0,0,0,0,0,0], 15 [0,0,0,0,0,2,0,0,0,0,0], 16 [0,0,0,0,0,1,0,0,0,0,0] 17] 18A2 = [ 19 [0,1,0,0,0], 20 [1,0,1,0,0], 21 [0,1,0,2,1], 22 [0,0,2,0,0], 23 [0,0,1,0,0] 24] 25 26A1 = np.array(A1, dtype=np.uint8) 27A2 = np.array(A2, dtype=np.uint8) 28 29def genp(): 30 # Pを次々に生成するジェネレーター 31 # Pは5 x 11とする。1の場所は11個の中から5個選ぶ 32 # itertools.permutationsを使えば単純にできるがあえて原始的に実装 33 # 組み合わせはTC1 = 11 * 10 * 9 * 8 * 7 34 S1 = [i for i in range(11, 6, -1)] 35 TC1 = functools.reduce(operator.mul, S1) 36 37 for tc1 in range(TC1): 38 i1 = iii(S1, tc1) 39 a = np.zeros((5, 11), dtype=np.uint8) 40 for i in range(5): 41 # print(f'i2[i]={i2[i]}, i1[i]={i1[i]}') 42 a[i, i1[i]] = 1 43 yield a 44 45def iii(ss, t): 46 # t番目の組み合わせのインデックスを生成 47 i = [i for i in range(ss[0])] 48 r = [] 49 for s in ss: 50 j = t % s 51 # print(f'j={j} i={i}') 52 r.append(i[j]) 53 del i[j] 54 t //= s 55 return r 56 57def main(): 58 count = 1 59 g = genp() 60 for p in g: 61 A3 = p.dot(A1).dot(p.T) 62 if np.all(A2 == A3): 63 print(f'number of trials = {count}') 64 print('p=') 65 print(p) 66 break 67 count += 1 68 # 探索の進捗具合の確認用 69 if count % 10000 == 0: 70 print(f'count={count}') 71 72if __name__ == '__main__': 73 main()
(Python 3.6.5)
投稿2018/05/09 05:26
編集2018/05/11 04:23総合スコア18394
0
自己解決
お世話になっております。
ご提示いただいたpythonコードを参考に、VBAでも欲しい動作を得ることができました。
ご協力いただいた皆様ありがとうございました。
VBA
1Option Explicit 2 3Sub main() 4 Dim A1 '(1 To 11, 1 To 11) 5 Dim A2 '(1 To 5, 1 To 5) 6 Dim A3 '(1 To 5, 1 To 5) 7 Dim MatT 8 Dim MatX 9 Dim A1N As Integer 10 Dim A2n As Integer 11 Dim i, j As Long 12 Dim P() As Integer 13 Dim prm As Long 14 Dim count As Long 15 Dim count_ As Long 16 Dim i1 17 Dim prmttn 18 19 A1 = [{0,1,1,1,1,0,0,0,0,0,0;1,0,0,0,0,1,0,0,0,0,0;1,0,0,0,0,0,1,1,1,0,0;1,0,0,0,0,0,0,0,0,0,0;1,0,0,0,0,0,0,0,0,0,0;0,1,0,0,0,0,0,0,0,2,1;0,0,1,0,0,0,0,0,0,0,0;0,0,1,0,0,0,0,0,0,0,0;0,0,1,0,0,0,0,0,0,0,0;0,0,0,0,0,2,0,0,0,0,0;0,0,0,0,0,1,0,0,0,0,0}] 20 A2 = [{0,1,0,0,0;1,0,1,0,0;0,1,0,2,1;0,0,2,0,0;0,0,1,0,0}] 21 22 A1N = 11 23 A2n = 5 24 25 ReDim P(1 To A1N, 1 To A2n) 26 27 count = 0 28 29 ' 11 * 5のあらゆる置換行列を生成・探索 30 prmttn = Permutation(A1N, A2n) 31 For prm = 1 To prmttn 32 i1 = iii(prm, A1N, A2n) 33 34 ' 11 * 5のゼロ行列を生成 35 For i = 1 To A1N 36 For j = 1 To A2n 37 P(i, j) = 0 38 Next j 39 Next i 40 41 ' 置換行列の1の要素を設定 42 For i = 1 To A2n 43 P(i1(i), i) = 1 44 Next i 45 46 ' PT * A1 * P (5 * 5)を計算 47 MatT = MatrixT(P) 48 MatX = MatrixCross(MatT, A1) 49 A3 = MatrixCross(MatX, P) 50 51 ' A2, A3を比較して、一致する要素をカウント 52 count_ = 0 53 For i = 1 To A2n 54 For j = 1 To A2n 55 If A2(i, j) = A3(i)(j) Then 56 count_ = count_ + 1 57 End If 58 Next j 59 Next i 60 ' A2, A3の要素がすべて一致すれば、"Pあり"と表示 61 If count_ = A2n * A2n Then 62 Debug.Print count 63 Debug.Print "Pあり" 64 65 Exit For 66 End If 67 68 count = count + 1 69 70 ' 探索の進捗状況の確認 71 If count Mod 10000 = 0 Then 72 Debug.Print count 73 End If 74 75 Next prm 76 77End Sub 78 79' 行列同士の掛け算 80Function MatrixCross(ByVal m1, ByVal m2) 81 Dim ans 82 Dim i, j, k 83 Dim sum_ 84 85 ans = CreateMatrix(UBound(m1), UBound(m2, 2)) 86 For i = 1 To UBound(ans) 87 For j = 1 To UBound(ans(2)) 88 sum_ = 0 89 For k = 1 To UBound(m1(2)) 90 sum_ = sum_ + m1(i)(k) * m2(k, j) 91 Next k 92 ans(i)(j) = sum_ 93 Next j 94 Next i 95 MatrixCross = ans 96 97End Function 98 99' 行列の転置 100Function MatrixT(ByVal m) 101 Dim ans 102 Dim i, j 103 104 ans = CreateMatrix(UBound(m, 2), UBound(m)) 105 For i = 1 To UBound(ans) 106 For j = 1 To UBound(ans(2)) 107 ans(i)(j) = m(j, i) 108 Next j 109 Next i 110 MatrixT = ans 111 112End Function 113 114' 任意サイズの行列を作成 115Function CreateMatrix(ByVal row_size, ByVal col_size) 116 Dim ans, row 117 Dim i 118 119 ans = Array() 120 ReDim ans(1 To row_size) 121 For i = 1 To row_size 122 row = Array() ' 新しいオブジェクトのインスタンス代入 123 ReDim row(1 To col_size) 124 ans(i) = row 125 Next i 126 127 CreateMatrix = ans 128 129End Function 130 131' t番目の組合せのインデックスを生成 132Function iii(ByVal t As Long, A1N As Integer, A2n As Integer) 133 Dim i() 134 ReDim i(0 To A1N - 1) 135 Dim r() 136 Dim k As Integer 137 Dim j As Integer 138 Dim count As Integer 139 count = 0 140 141 ' i = 1 ~ A1N 142 For k = 0 To A1N - 1 143 i(k) = k + 1 144 Next k 145 146 ReDim r(1) 147 For k = A1N To A1N - A2n + 1 Step -1 148 count = count + 1 149 j = t Mod k 150 ReDim Preserve r(count) 151 r(count) = i(j) 152 Call ArrayRemove(i, j) 153 t = t \ k 154 155 Next k 156 157 iii = r 158 159End Function 160 161' 配列の要素の削除 162Sub ArrayRemove(ByRef TargetArray, ByVal deleteIndex As Integer) 163 Dim i As Integer 164 165 '削除したい要素以降の要素を前につめて上書きコピー 166 For i = deleteIndex To UBound(TargetArray) - 1 167 TargetArray(i) = TargetArray(i + 1) 168 Next i 169 170 '最後の要素を削除 171 ReDim Preserve TargetArray(UBound(TargetArray) - 1) 172 173End Sub 174 175' 順列(nPk)の計算 176Function Permutation(n, k) 177 Dim i 178 Dim nPk 179 180 nPk = 1 181 For i = n - k + 1 To n 182 nPk = nPk * i 183 Next i 184 185 Permutation = nPk 186 187End Function 188 189
投稿2018/05/15 05:54
総合スコア6
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
0
ご提示のコードを動かそうとしましたが、
A1 = [{0,1,1・・・ の処理で既に動きませんが?
このコードはあなたが作ったものですか?
それとも、何かの宿題ですか?
投稿2018/05/10 04:16
総合スコア1175
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2018/05/10 05:26 編集
2018/05/10 05:36
あなたの回答
tips
太字
斜体
打ち消し線
見出し
引用テキストの挿入
コードの挿入
リンクの挿入
リストの挿入
番号リストの挿入
表の挿入
水平線の挿入
プレビュー
質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2018/05/09 06:10
2018/05/09 06:30 編集
2018/05/10 05:55 編集
2018/05/09 08:15
2018/05/09 08:22
2018/05/09 23:17
2018/05/10 05:36
2018/05/10 05:46
2018/05/10 05:55
2018/05/11 02:06
2018/05/11 02:43 編集
2018/05/11 04:18
2018/05/11 04:50
2018/05/11 05:30
2018/05/11 05:57
2018/05/11 06:00
2018/05/11 06:57