本記事は U-TOKYO AP Advent Calendar 2017 の15日目です。

はじめに

こんにちは。東京大学工学部計数工学科の @_yuki です。
師走も半ばとなり、何かと慌ただしくなってきました。忘年会や帰省なんかもあり、鉄道で移動される方も多いのではないでしょうか。本記事では、そんな風に真っすぐ目的地に向かうだけが鉄道じゃない！とばかりに、駅名でしりとりをしてみたいと思います。
ちなみに、単に最長しりとりを構成するだけなら、既に研究対象としても繰り返し取り上げられ¹、優れた解法が存在します。卒論で扱ってねとらぼの記事²になった方もいるようで、別の方が実装³されたものもあるので、しりとりの解のみ欲しい方はそちらへどうぞ。
この記事では、あえて整数計画法のソルバーは使わずに、東京メトロの全143駅から最長しりとりを構成していきます。それによって、このような問題はどのように定式化すると楽なのか？を考える一例となれればと思います。厳密でないところが一部あります⁴が、気にしない。

ルール

東京メトロの駅だけを使い、駅名でしりとりをしながら回る。
同じ駅を使うことなく、なるべくたくさんの駅を回るのが目標。
移動経路は不問（どこを目指すかだけでしりとり）。
濁点と半濁点は無視、拗音は小文字を大文字に取り換える。つまり「和光市」→「神保町」や「北千住」→「有楽町」を認める。
副駅名は連結してもしなくてもよい。つまり「明治神宮前」「明治神宮前＜原宿＞」はいずれか片方を採用。

考え方

駅名は「矢印」

しりとりで大事なのは最初と最後の文字だけなので、駅名をひらがなからひらがなへの矢印として考えます。
例えば「白金台」は「し」で始まり「い」で終わるので、「し」から「い」への矢印です。「新橋」は「し」から「し」に戻ってくる矢印です。

ループと直線に分ける

ループと直線の考え方

しりとりをしていると、いくつかの単語のあと、同じひらがなに戻ってくることがあります。このような円の集まりを矢印の図で見ると、ループが出来上がっています。ループ内ではしりとりの成立条件が単純になるので、しりとりをループとそれ以外の直線部分に分けて考えます。最終的には、直線を始端から進み、途中からループに入り、ループを抜けてから再び直線を終端へ向かう経路（上図）が、最長しりとりになります。

ループ候補と直線候補の分別

最長しりとりの始端に来るひらがなを考えてみましょう。もしこのひらがなで終わる駅があれば、しりとりはもっと長くできます。よって、始端のひらがなには、それで始まる駅だけしかないと分かります。
逆に考えると、あるひらがなに対して、そのひらがなで始まる駅しか存在しないならば、そのような単語は始端にしか使えません。この操作を繰り返すと、始端につながる直線部分に使いうる駅を取り出すことができます。終端についても同様です。
そして、残った駅は、前後をたどっていっても行き止まりにならないものだけになっています。これはつまり、ループを作るときに使う駅の候補ということです。
上図の例で説明します。メトロに「ね」で終わる駅はありません。よって「根津」は始端にしか使えないと分かります。さらに、「つ」で終わる駅は根津しかありません。よって「築地」は根津から続く直線にしか使えないのです。これを繰り返すことで、直線候補が取り出せます。一方、取り出されずに最後まで残った駅がループ候補です。

ループの最長化

ひらがなへの出入りのバランス

まずは、ループをなるべく長くすることを考えます。
ループは最終的に一周するので、それぞれのひらがなへ入る矢印と出る矢印の数は同じになるはずです。バランスが取れていないなら、しりとりを形成するにはその分、矢印（駅）を減らさなければなりません。
上図の例では、「せ」に入る矢印は「北綾瀬」1本なのに、出る矢印は「千川」「千駄木」の2本なので、どちらかを切らなければループの部品にならないと分かります。

お互いにとって余る矢印から切る

矢印には、出所と行先があります。あるひらがなの出入りをつり合わせようとして矢印を切ったら、その矢印がつながっているもう片方のひらがなのバランスを崩してしまうかもしれません。
そこで、出て行く矢印が余っているひらがな（以下、赤色で示します）と、入って来る矢印が余っているひらがな（以下、青色で示します）の間の駅を優先的に切ります。こうすることで、2つのひらがな両方にとって不要な矢印から消していくことができます。
上図の例では、「み」は出る矢印が余っている、「ゆ」は入る矢印が余っているので、その間を結ぶ「南千住」を切ってあげると、どちらのひらがなもバランスのとれた状態に近づきます。

切り足りない分は他を破壊

とはいえ、いつもそううまく行くとは限りません。お互いに余る矢印だけでは切り足りず、つり合っているひらがなとの矢印を切るしかない場合があります。
また、切れる選択肢がありすぎる場合も問題です。全ての相手を切ることができないため、切断対象に選ばれなかった相手は別のひらがなとの矢印を切ることになってしまうからです。
上図の例で、出る矢印が余っている「み」に注目してみましょう。入る矢印が余る「え」「く」「わ」全てへの矢印を切ったとしても、まだつり合いがとれていません。仕方がないので、仮に「南砂町」を切ったとします。すると「ち」のバランスを崩してしまい、「ち」から出る矢印も1本新たに切る必要が出てしまいます。

切る選択肢が多いどうしなら切らなくてよい

逆に、お互いにとって余る矢印なのに、切らないほうが良い例も存在します。それは、切れる選択肢がありすぎるひらがな同士を結ぶ矢印の場合です。その矢印を切らなかったとしても、双方のひらがなともつり合いを達成できるので、実は消す意味がありません。
上図の例で、「し」は出る矢印が2本、「わ」は入る矢印が2本余っているだけです。しかし切断の選択肢、つまり相手側で余っている矢印はそれぞれ7本と4本あります。だったらわざわざ「白金高輪」を切らずとも、他の切ってほしそうにしているひらがなとの矢印を切れば事足ります。

直線の最長化

長い始まりと終わりを選ぶ

当たり前ですが、直線部分の候補のうち長いものを使うのが良いです。ループ中のどのひらがなで直線と接続するかは自由なので、始端側と終端側につながる直線の長さの和が最大となるひらがなを選びます。

ループから排除されても1経路復活する

実は、直線を作るのはもともと直線候補だった矢印だけではありません。ループ候補に入っていたけれど、切られてしまい使われなかった矢印は、直線候補として再利用できるのです。
切断の経路は出る矢印が余るひらがなから入る矢印が余るひらがなまでつながっています。これら切断の起終点にあたるひらがなでループに出入りするようにしてやれば、ループの前または後ろへの連結によって、切られていた部分を復活できます。ただしもちろん、復活できるのは1経路だけです。

短い切断を増やして復活を長くする

では、復活する1経路を長くするためにはどうしたらよいでしょうか。もし、切断が中途半端に長いものばかりだったとしたら、どれが蘇ってもあまりうれしくありません。それよりも、1つだけとても長い切断がある方が、復活の効果は大きくなります。
ここで、ループ内にある出る矢印が余るひらがなや入る矢印が余るひらがなで余っている矢印の総数は一定です。つまり、切断の経路数も一定ですから、1つを長くするには他の全てをなるべく短くするべきです。

初めの解によって探索範囲が定まる

始まりと終わりの端が長くなるようなひらがなの選び方と、復活が長くなるようなひらがなの選び方は、一致するとは限りません。条件が異なれば、組み合わせるためには妥協が必要となり、各自は最長ではなくなってしまいます。
しかし最適化によって、それぞれが到達できる上限の長さが分かります。よって、ばらばらに最長を目指したときに求まるしりとりを初めの解として、例えばそこから端の長さを上限に向けて増やしたときの増加分が、ループや復活に与える損を上回るようなものだけを探索すればよいと分かります。

実装

ChainWord

Option Explicit
Sub ChainWord()
    Dim floop As Object, rloop As Object, fstraight As Object, rstraight As Object
    BuildDictionary floop, rloop    '辞書作成
    DivideStraight floop, rloop, fstraight, rstraight   '直線候補の分別
    CutSurplus floop, rloop, fstraight, rstraight   '余る矢印の切断
End Sub

BuildDictionary

Private Sub BuildDictionary(floop As Object, rloop As Object)
    Dim word As Object, nrow As Long, tmpw As String, tmpc As String
    '初期化
    Set floop = CreateObject("Scripting.Dictionary")
    Set rloop = CreateObject("Scripting.Dictionary")
    nrow = 1
    With Thisworkbook.Worksheets(1)
        Do
            '単語の取得
            tmpw = .Cells(nrow, 1).Value
            If tmpw = "" Then Exit Do
            '始まりのひらがなによる辞書
            tmpc = SplitSonant(Left$(tmpw, 1))
            If Not floop.Exists(tmpc) Then
                Set word = CreateObject("Scripting.Dictionary")
                floop.Add tmpc, word
            End If
            floop(tmpc).Add tmpw, SplitSonant(Right$(tmpw, 1))
            '終わりのひらがなによる辞書
            tmpc = SplitSonant(Right$(tmpw, 1))
            If Not rloop.Exists(tmpc) Then
                Set word = CreateObject("Scripting.Dictionary")
                rloop.Add tmpc, word
            End If
            rloop(tmpc).Add tmpw, SplitSonant(Left$(tmpw, 1))
            nrow = nrow + 1
        Loop
    End With
End Sub

DivideStraight

Private Sub DivideStraight(floop As Object, rloop As Object, fstraight As Object, rstraight As Object)
    Dim char As Variant, word As Variant, divide As Boolean, ntmps As Long, i As Long, tmps As Object, tmpw As Object, tmpc As String
    '始端につながる直線候補
    Set fstraight = CreateObject("Scripting.Dictionary")
    Do
        divide = False
        For Each char In floop
            If Not rloop.Exists(char) Then
                For Each word In floop(char)
                    Set tmps = CreateObject("System.Collections.ArrayList")
                    '別の始端候補の後ろにつながるか
                    If fstraight.Exists(char) Then
                        ntmps = fstraight(char).Item(0).Count
                        For i = 0 To fstraight(char).Count - 1
                            tmps.Add fstraight(char).Item(i).Clone
                        Next
                    Else
                        ntmps = 1
                    End If
                    '直線候補に加える
                    Set tmpw = CreateObject("System.Collections.ArrayList")
                    For i = 1 To ntmps
                        tmpw.Add word
                    Next
                    tmps.Add tmpw
                    'ループとの接続点が同一の候補と統合
                    tmpc = floop(char)(word)
                    If fstraight.Exists(tmpc) Then
                        Select Case tmps.Count - fstraight(tmpc).Count
                        Case Is > 0
                            fstraight.Remove tmpc
                            fstraight.Add tmpc, tmps
                        Case 0
                            For i = 0 To tmps.Count - 1
                                fstraight(tmpc).Item(i).Addrange tmps.Item(i)
                            Next
                        End Select
                    Else
                        fstraight.Add tmpc, tmps
                    End If
                    'ループ候補から削除
                    rloop(tmpc).Remove word
                    If rloop(tmpc).Count = 0 Then rloop.Remove tmpc
                Next
                floop.Remove char
                divide = True
            End If
        Next
    Loop While divide
    '終端につながる直線候補
    Set rstraight = CreateObject("Scripting.Dictionary")
    Do
        divide = False
        For Each char In rloop
            If Not floop.Exists(char) Then
                For Each word In rloop(char)
                    Set tmps = CreateObject("System.Collections.ArrayList")
                    '別の終端候補の前につながるか
                    If rstraight.Exists(char) Then
                        ntmps = rstraight(char).Item(0).Count
                        For i = 0 To rstraight(char).Count - 1
                            tmps.Add rstraight(char).Item(i).Clone
                        Next
                    Else
                        ntmps = 1
                    End If
                    '直線候補に加える
                    Set tmpw = CreateObject("System.Collections.ArrayList")
                    For i = 1 To ntmps
                        tmpw.Add word
                    Next
                    tmps.Insert 0, tmpw
                    'ループとの接続点が同一の候補と統合
                    tmpc = rloop(char)(word)
                    If rstraight.Exists(tmpc) Then
                        Select Case tmps.Count - rstraight(tmpc).Count
                        Case Is > 0
                            rstraight.Remove tmpc
                            rstraight.Add tmpc, tmps
                        Case 0
                            For i = 0 To tmps.Count - 1
                                rstraight(tmpc).Item(i).Addrange tmps.Item(i)
                            Next
                        End Select
                    Else
                        rstraight.Add tmpc, tmps
                    End If
                    'ループ候補から削除
                    floop(tmpc).Remove word
                    If floop(tmpc).Count = 0 Then floop.Remove tmpc
                Next
                rloop.Remove char
                divide = True
            End If
        Next
    Loop While divide
End Sub

CutSurplus

Cutsurplusについては改修中⁵です。恐れ入りますが、公開まで今しばらくお待ちください。

SplitSonant

Private Function SplitSonant(str As String) As String   '濁点や拗音などの処理
    Dim nchar As Integer
    '濁点と半濁点の削除
    nchar = Asc(StrConv(Left$(StrConv(str, vbKatakana + vbNarrow), 1), vbHiragana + vbWide))
    '拗音と促音の変換
    Select Case nchar
    Case -32097 To -32089, -32063, -32031 To -32027
        If nchar Mod 2 = -1 Then
            nchar = nchar + 1
        End If
    End Select
    SplitSonant = Chr(nchar)
End Function

結果

東京メトロ143駅のうち、ループ候補は71駅、直線候補は72駅でした。
ループ候補のうち、ひらがなの出入りのバランスをとるためにまず切らねばならないのは22駅でした。また、切り足りずに他が破壊されることによって追加で切らなければならなくなるのは7駅でした。ただし、切る選択肢が多いどうしを結んでいるものが1駅あったので、結局ループの長さは 71-22-7+1 = 43 駅が最大です。
直線候補は、始端側あるいは終端側の単独では、最大3駅までつながるものがありました。探索の結果、先端側が2駅、終端側が3駅つながり、復活部分は0駅となるものが見つかりました。CutSurplusに怪しいところがある⁵ので検証は必要ですが、おそらくこれが最長しりとりの解であり、ループ部分と合わせて最大で 43+2+3+0 = 48 駅のしりとりが構成できることが分かりました。
48駅を途中どのように回るかはそれなりに自由なのですが、一例を挙げるとすると次のようになります。
根津→築地→新橋→白金台→池袋→六本木→清澄白河→早稲田→竹橋→新大塚→霞ケ関→北綾瀬→千駄木→京橋→新高円寺→志茂→門前仲町→上野→乃木坂→神楽坂→神田→田原町→地下鉄赤塚→葛西→飯田橋→白金高輪→和光市→新御茶ノ水→水天宮前→江戸川橋→新宿御苑前→恵比寿→末広町→上野広小路→新宿三丁目→目黒→六本木一丁目→明治神宮前＜原宿＞→九段下→辰巳→茗荷谷→西葛西→稲荷町→浦安→住吉→新木場→原木中山→町屋

おわりに

今後の展望

しりとりの単語数としての最長解は（多分⁵）求められたので、今後は実移動時間での最長化を試みたいと考えています。しりとり行程表みたいなものが出力できるといいですね。乗り換え時間や時刻表の情報をいかに取り込み、評価していくかが課題になると思われます。

U-TOKYO AP Advent Calendar 2017 について

東京大学工学部応用物理学（=applied physics=AP）系の学科である、計数工学科および物理工学科を中心とした有志によるアドベントカレンダーです。企画の @snowhork さん、ありがとうございます。
明日は @habroptilus さんが、ディープラーニングを使ってギターを簡単に弾けるようにしてくれるみたいですよ。
このカレンダーもあと10日となりました。僕は信者ではないのですが、毎年クリスマスミサには参列しています。一年間の総決算的な意味と、懐かしい方々にも会えますからね。皆さんも、良いクリスマスを！

参考文献と注釈

乾伸雄、品野勇治、鴻池祐輔、小谷善行(2005)「最長しりとり問題の解法」情報処理学会論文誌：数理モデル化と応用（TOM） Vol.46 No.SIG2(TOM11) pp.105-117 ↩
「ポケモンでしりとりしたら最長何匹まで続く？　数学の卒論がネットで話題に」 ↩
「単語集合から最長しりとりを得るプログラム」ただし、少し試してみた感想として、最長解が出ない場合がありそうです。今度暇なときに検証します。 ↩
例えば、ループを作ったつもりが、実は互いに行き来できない2つのループができてしまった、みたいな場合への対策はしていません。 ↩
CutSurplusは、挙動が狙い通りになっていない疑惑が出ているので、改修中です。訂正完了次第、結果を書き直す予定です。しかし、もともと人様にお見せする予定はなく、「動けばいいんだよ！！」というノリで書いたプログラムなので、直すのにはしばらくかかりそうです。すみません。 ↩

VBAで駅名の最長しりとりを遊んでみる