「2015年度 京都大 特色入試(理学部) 第 3 問」を Mathematica を使って解いてみよう！

最近なにかと話題の京都大学の特色入試ですが、ネットのニュースに
**[京大特色入試に超難問　数学の筆記試験“五輪級”](http://www.kyoto-np.co.jp/education/article/20151128000119)**
などと騒がれているようなので、これを Mathematica でサクッと解くというのをやってみようという試みです。
他の問題に関しては

> https://twitter.com/made_leine_/status/670850069491556352
> 京都大学特色入試（理学部）の今年の筆記試験の問題をpdf化しました．よかったら使ってください
> https://drive.google.com/file/d/0B0748abDPeWpQW9OOE94b2hjTkU/view?usp=sharing

を参考にしてみてください。

それでは解いていきます。
一気に飛ばして問 $1$ と問 $2$ をまとめて解いていきます。

この問題で行われている操作は

**$n$ 個の輪になったビットに対して、任意の箇所の連続した $k$ 個のビット反転を行う**

というものです。ということは、

**$1$ 箇所だけビット反転させる事が出来るような操作があれば
任意の状態からすべてを表にする方法がある**

が分かります。
どんな事をやっているのか、何が分かれば良いのかが分かったところで早速問題を解いていきましょう。

#アルゴリズム概要#
入力：$n$, $k$
出力：$1$ 箇所だけ反転させる為に必要な操作

【内容】
まず始めに $n$ 個のコインに対し、順に $1 \sim n$ まで名前を付けます。
ここでコインの状態を

|数値 |状態|
|:---:|:--:|
| $1$ | 表 |
| $0$ | 裏 |

とすることにします。同じ操作を $2$ 回することは恒等操作であることに注意し以下のように定めます。

| 数値 |  状態   |
|:---:|:-------:|
| $1$ |  裏返す  |
| $0$ | そのまま |

また、$a[i] = \\{i \text{番目から始まって連続する} k \text{個のコインを裏返す操作}\\}$ とします。
即ち

```math
a[i] = (\overbrace{\underbrace{0, \ldots , 0}_{i-1}, \underbrace{1, \ldots, 1}_{k},0, \ldots, 0}^n )
```

です。
これをソースで書いてみると、

```Mathematica:a[i]
a[i] = RotateRight[Flatten[{Table[1, {k}], Table[0, {n - k}]}], i - 1]
```

となります。
ここで, Table, Flatten RotateRight は以下の操作をします。

```
Table[expr, n]
の n 個のコピーのリストを作成する．
```

```
Flatten[list]
ネストしたリストを平坦化する．
```

```
RotateRight[expr, n]
expr の要素を n だけ右の位置にずらす．
```

あとは

```math
\sum_{i \in \Lambda \subset \{1, 2, \ldots, n \} }a[i] \equiv (1, \underbrace{0, \ldots , 0}_{n-1}) \pmod{2}
```

となるような $\Lambda$ が見つかれば $\Lambda$ をすべて出力しましょう。
という流れです。

```Mathematica:FindLambda.nb
Select[Subsets[Range[n], {1, n}], Mod[Plus @@ a /@ #, 2] == Mod[Flatten[{0, Table[1, {n - 1}]}] + Table[1, {n}], 2] &]
```
ここで, Range, Subsets, Mod, Select は以下の操作をします。

```
Range[i_max]
リスト{1, 2, ..., i_max}を作成する．
```

```
Subsets[list, {n_min, n_max}]
n_min 個から n_max 個の要素を含むすべての部分集合を与える．
```

```
Mod[m, n]
m を n で割った商の剰余を与える．
```

```
Select[list, crit]
crit[e_i] が True となる list のすべての要素 e_i を取り出す．
```

これらを踏まえると問 $1$ と問 $2$ のソースは以下のようになります.

```Mathematica:Q1.nb
n = 7;
k = 3;
Table[a[i] = RotateRight[Flatten[{Table[1, {k}], Table[0, {n - k}]}], i - 1], {i, 1, n}];
Select[Subsets[Range[n], {1, n}], 
 Mod[Plus @@ a /@ #, 2] == Mod[{1, 0, 0, 1, 0, 1, 0} + Table[1, {n}], 2] &]
```

```Mathematica:Q2.nb
n = 6;
k = 3;
Table[a[i] = RotateRight[Flatten[{Table[1, {k}], Table[0, {n - k}]}], i - 1], {i, 1, n}];
Select[Subsets[Range[n], {1, n}], 
 Mod[Plus @@ a /@ #, 2] == 
   Mod[{1, 0, 0, 1, 1, 0} + Table[1, {n}], 2] &]
```
このとき, 結果が出力されればそれが最小回数の操作の内容であり、何も出力されなければ条件を満たす操作は存在しない事になる。

それではいよいよ問 3 を考えてみましょう。
恒等操作も合わせて数えると全操作は $2^n$ 通りあり、コインの状態も $2^n$ 通りあります。

つまりコインがどんな状態であっても、全てを表にする方法があるならばそれらはすべて異なっていなければいけないので、操作とコインの状態の対応は全単射になります。
この場合はゲームを必ず終了させる事が出来ます。

一方、異なる操作をしたにも関わらず最終結果が同じ操作になってしまった場合は(操作が単射でないならば)、最終結果だけを見た場合は $2^n$ 通り未満の状態しか作れなく、コインの状態は全部で $2^n$ 通りあるので、すべてを表にする操作が存在しないようなコインの状態が存在することになります。
つまり、この場合はゲームを終了する事が出来ないようなものが存在することになります。

これを踏まえるとゲームが終了出来ない条件は 2 通り出てきます。

$1$ つ目は $\gcd(n, k) > 1$ です。

これは、$g = \gcd(n, k) > 1$ としたとき、

```math
\sum_{i \in \{1, g+1, 2g+1, \ldots, n-g+1 \} }a[i] \equiv \sum_{i \in \{2, g+2, 2g+2, \ldots, n-g+2 \} }a[i] \equiv \cdots \pmod{2}
```

となり、異なる操作をしたにも関わらず最終結果が同じ操作になってしまうからです。

$2$ つ目は $2 | k$ です。
これは、

```math
\sum_{i = 1}^{n-1} a[i] \equiv a[n] \pmod{2}
```

となり、異なる操作をしたにも関わらず最終結果が同じ操作になってしまうからです。

これらの 2 つの条件は Mathematica で簡単に確認が取れますし証明も容易です。

では逆に, $k \mid \hspace{-.67em}/ n$ かつ $2 \mid \hspace{-.67em}/ k$ のときはどうなるかを考えてみましょう。

このとき、

```math
\sum_{i = 1}^{n-1} a[i] \equiv - a[n] \pmod{2}
```

であるので、

```math
\sum_{i \in \Lambda \subset \{1, 2, \ldots, n \} }a[i]
\equiv
- \sum_{i \in \{1, 2, \ldots, n \} \setminus \Lambda }a[i]
\pmod{2}
```
がいえます。
よって、このとき全ての操作は異なるのでコインがどんな状態であってもゲームを終了させる事が出来る。

最後に

```math
1 \le n \le 15, 1 \le k \le n
```

の範囲で条件を満たす $(n, k)$ の組をリストアップするソースを確認の意味を込めて載せておきます。

```Mathematica:Q3test.nb
For[n = 1, n <= 15, n++, {
  For[k = 1, k <= n, k++, {
    Table[
     a[i] = RotateRight[Flatten[{Table[1, {k}], Table[0, {n - k}]}], 
       i], {i, 1, n}];
    If[Length@
       Union[Mod[Plus @@ a /@ #, 2] & /@ Subsets[Range[n], {1, n}]] ==
       2^n - 1, Print[{n, k}]]}]}]
```