スマートフォンのパターンロックについて

スマートフォンに画面ロックを設定しておくと、電源を入れたとき、または画面がオフの状態（スリープ）から復帰するときにロックがかかります。
これは他人に使用されることを防ぐための重要な機能です。
この画面ロックの解除方法は、初期状態では「スワイプ」に設定されていますが、ほかにも「フェイスアンロック」「パターン」「PIN」「パスワード」など色々な種類があります。

|ロックの種類|説明|
|:-:|:-:|
|[設定しない]       |画面ロックがかかりません。|
|[スワイプ]         |上方向または下方向にスワイプして、画面ロックを解除します。|
|[フェイスアンロック]|顔認証による画面ロックの解除をします。|
|[パターン]         |9つの点のうち、4つ以上の点をドラッグして結び、画面ロックを解除します。|
|[PIN]             |4桁～16桁の数字でPINを入力し、画面ロックを解除します。|
|[パスワード]       |4文字～16文字の半角英数・記号でパスワードを入力し、画面ロックを解除します。|

この中でパターンロックと言われる画面ロックに関して、最長のロックがどういうものかを考えてみましょう。

ここでパターンロックの条件のおさらいです。

- 点は 3×3 の合計 9 つある。
- 4 つ以上の点をドラッグして結ぶ
- 一筆書きでないといけない
- 点を通れる回数は各 1 度だけ (上を通過するのは可)

それではまず始めに解く前段階の準備をします。
まずはこの 9 つの点の設定をします。

```math
\begin{array}{|c|c|c|} \hline
a & b & c \\ \hline
d & e & f \\ \hline
g & h & i \\ \hline
\end{array}
```
と名前を付け、

```math
\begin{array}{|c|c|c|} \hline
( 1, -1) & ( 1, 0) & ( 1, 1) \\ \hline
( 0, -1) & ( 0, 0) & ( 1, 1) \\ \hline
(-1, -1) & (-1, 0) & (-1, 1) \\ \hline
\end{array}
```
と座標の情報を与えておきます。

```Mathematica:Lattice
{a, b, c, d, e, f, g, h, i} = 
  Tuples[{Range[1, -1, -1], Range[-1, 1]}]
```

次に点を通れる回数は各 1 度だけですが、上を通過するのは可であるので、通過した座標の情報を付け加える操作をします。
まずはそのための関数を準備します。

```Mathematica:ReplaceFunction
ReplaceFunction[L_, A_, B_] := 
  ReplacePart[L, Position[L, A] -> Riffle[A, B]];
```

|変数|内容|
|:-:|:-:|
|L|ロックのパスの情報|
|A|ジャンプしている箇所|
|B|補う点|

最後に距離を計算する関数を準備します。

```Mathematica:PatternLength
PatternLength = 
 Total[Norm /@ (Delete[L[[k]], -1] - Delete[L[[k]], 1])]
```

あとは対称性を考慮しながらスタートの位置を 3 パターン考えます。

|点|座標|位置関係|
|:-:|:-:|:-:|
|a|(1,-1)|角|
|b|(1,0)|辺|
|e|(0,0)|中心|

これらの 3 パターンを全列挙し、そのうち最大の距離とそのパスを探し出してパターン内の最長を決めます。

```Mathematica:MaximumPatternLengthList1
Timing[
 PatternLengthList1 = {};
 ReplaceFunction[L_, A_, B_] := 
  ReplacePart[L, Position[L, A] -> Riffle[A, B]];
 {a, b, c, d, e, f, g, h, i} = 
  Tuples[{Range[1, -1, -1], Range[-1, 1]}];
 L = Permutations[{a, b, c, d, e, f, g, h, i}];
 startk = Total[Flatten[Position[L, {a, b, c, d, e, f, g, h, i}]]];
 endk = Total[Flatten[Position[L, {b, a, c, d, e, f, g, h, i}]]];
 For[k = startk, k < endk, k++, {
   L[[k]] = Partition[L[[k]], 2, 1];
   L[[k]] = ReplaceFunction[L[[k]], {a, c}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {a, g}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {a, i}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {b, h}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, a}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {c, g}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, i}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {d, f}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {f, d}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, a}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {g, c}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, i}, {h}];
   L[[k]] = ReplaceFunction[L[[k]], {h, b}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, a}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, c}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {i, g}, {h}];
   L[[k]] = First /@ Tally[Flatten[L[[k]], 1]];
   PatternLength = 
    Total[Norm /@ (Delete[L[[k]], -1] - Delete[L[[k]], 1])];
   PatternLengthList1 = Append[PatternLengthList1, PatternLength];
   }];
 MaxPLL1 = Max[PatternLengthList1];
 Print[{MaxPLL1,
   FromDigits /@ ((L[[# + startk - 1]] & /@ 
        Flatten[Position[PatternLengthList1, MaxPLL1]])
      /. Thread[
       Rule[{a, b, c, d, e, f, g, h, i}, {1, 2, 3, 4, 5, 6, 7, 8, 
         9}]])}]
 ]
```

```Mathematica:MaximumPatternLengthList2
Timing[
 PatternLengthList2 = {};
 ReplaceFunction[L_, A_, B_] := 
  ReplacePart[L, Position[L, A] -> Riffle[A, B]];
 {a, b, c, d, e, f, g, h, i} = 
  Tuples[{Range[1, -1, -1], Range[-1, 1]}];
 L = Permutations[{a, b, c, d, e, f, g, h, i}];
 startk = Total[Flatten[Position[L, {b, a, c, d, e, f, g, h, i}]]];
 endk = Total[Flatten[Position[L, {c, a, b, d, e, f, g, h, i}]]];
 For[k = startk, k < endk, k++, {
   L[[k]] = Partition[L[[k]], 2, 1];
   L[[k]] = ReplaceFunction[L[[k]], {a, c}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {a, g}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {a, i}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {b, h}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, a}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {c, g}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, i}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {d, f}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {f, d}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, a}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {g, c}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, i}, {h}];
   L[[k]] = ReplaceFunction[L[[k]], {h, b}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, a}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, c}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {i, g}, {h}];
   L[[k]] = First /@ Tally[Flatten[L[[k]], 1]];
   PatternLength = 
    Total[Norm /@ (Delete[L[[k]], -1] - Delete[L[[k]], 1])];
   PatternLengthList2 = Append[PatternLengthList2, PatternLength];
   }];
 MaxPLL2 = Max[PatternLengthList2];
 Print[{MaxPLL2,
   FromDigits /@ ((L[[# + startk - 1]] & /@ 
        Flatten[Position[PatternLengthList2, MaxPLL2]])
      /. Thread[
       Rule[{a, b, c, d, e, f, g, h, i}, {1, 2, 3, 4, 5, 6, 7, 8, 
         9}]])}]
 ]
```

```Mathematica:MaximumPatternLengthList5
Timing[
 PatternLengthList5 = {};
 ReplaceFunction[L_, A_, B_] := 
  ReplacePart[L, Position[L, A] -> Riffle[A, B]];
 {a, b, c, d, e, f, g, h, i} = 
  Tuples[{Range[1, -1, -1], Range[-1, 1]}];
 L = Permutations[{a, b, c, d, e, f, g, h, i}];
 startk = Total[Flatten[Position[L, {e, a, b, c, d, f, g, h, i}]]];
 endk = Total[Flatten[Position[L, {f, a, b, c, d, e, g, h, i}]]];
 For[k = startk, k < endk, k++, {
   L[[k]] = Partition[L[[k]], 2, 1];
   L[[k]] = ReplaceFunction[L[[k]], {a, c}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {a, g}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {a, i}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {b, h}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, a}, {b}];
   L[[k]] = ReplaceFunction[L[[k]], {c, g}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {c, i}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {d, f}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {f, d}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, a}, {d}];
   L[[k]] = ReplaceFunction[L[[k]], {g, c}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {g, i}, {h}];
   L[[k]] = ReplaceFunction[L[[k]], {h, b}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, a}, {e}];
   L[[k]] = ReplaceFunction[L[[k]], {i, c}, {f}];
   L[[k]] = ReplaceFunction[L[[k]], {i, g}, {h}];
   L[[k]] = First /@ Tally[Flatten[L[[k]], 1]];
   PatternLength = 
    Total[Norm /@ (Delete[L[[k]], -1] - Delete[L[[k]], 1])];
   PatternLengthList5 = Append[PatternLengthList5, PatternLength];
   }];
 MaxPLL5 = Max[PatternLengthList5];
 Print[{MaxPLL5,
   FromDigits /@ ((L[[# + startk - 1]] & /@ 
        Flatten[Position[PatternLengthList5, MaxPLL5]])
      /. Thread[
       Rule[{a, b, c, d, e, f, g, h, i}, {1, 2, 3, 4, 5, 6, 7, 8, 
         9}]])}]
 ]
```

最後にこの 3 つのパターンうち最長のものはどのパターンになるかを調べます。

```Mathematica:MaximumPattern
Max[{MaxPLL1, MaxPLL2, MaxPLL5}]
```

すると結論として回転や反転などで一致するパスを同一視したとき
**519283764**
が最長のパスとなります。
これだけだと一見見づらいですが、
**5 (19) (28) (37) (64)**
と覚えると分かりやすいかと思います。
距離を簡単に計算すると

```math
\overbrace{5(}^{\sqrt{2}}
\underbrace{1 \ 9}_{2\sqrt{2}}
\overbrace{)(}^{\sqrt{5}}
\underbrace{2 \ 8}_{2}
\overbrace{)(}^{\sqrt{5}}
\underbrace{3 \ 7}_{2\sqrt{2}}
\overbrace{)(}^{\sqrt{5}}
\underbrace{6 \ 4}_{2}
)
```

となるので、距離は $4 + 5\sqrt{2} + 3\sqrt{5}$ となります。