Haskell で試す群論

## 概要

群論を少し勉強したので、Haskell でのコード化を試してみた。
高度なことはしていませんが、数学的な概念が関数設計に反映されています。

どちらかというと、数学的な構造をどうモデル化してコード化するのかといったアイディアの紹介です。

### 環境

* **GHCi**
  version 8.0.2

## 定義

まずは、半群の定義から行います。

* **結合律を満たす**
  _S_ の各元 _a_, _b_, _c_ に対して  (_a_ • _b_) • _c_ = _a_ • (_b_ • _c_) を満たす。 


群の場合は、さらに次を満たします。

* 単位元の存在
* 逆元の存在

## 設計上のアイディア

次の点がポイントです。この条件を満たすのでリスト構造で数式を管理できます。

* 結合律を満たす

結合律を満たさない場合、評価順序の違いがでるためツリー構造で表現する必要があります。

## コード例

### 位数2: C<sub>2</sub>

C<sub>2</sub>と同型な XOR です。演算表は次のようになります。

| ⊕ | **0** | **1** |
|---|---|---|
| **0** | 0 | 1 |
| **0** | 1 | 0 |

#### コード例1: 独自に実装

```haskell
c2_e :: Int
c2_e = 0

c2_op :: Int -> Int -> Int
-- c2_op a b = (a + b) `mod` 2
c2_op 0 0 = 0
c2_op 1 1 = 0
c2_op 0 1 = 1
c2_op 1 0 = 1
c2_op _ _ = error "ERROR invalid arguments."

c2_inv :: Int -> Int
c2_inv x = head [y | y <- [0, 1], c2_op x y == c2_e]

c2_eval :: [Int] -> [Int]
c2_eval [] = []
c2_eval [x] = [x]
c2_eval [x, y] = (c2_op x y):[]
c2_eval (x:y:zs) = c2_eval ((c2_eval [x, y]) ++ zs)

main :: IO ()
main = do
  putStrLn $ "0^(-1) = " ++ show (c2_inv 0)
  putStrLn $ "1^(-1) = " ++ show (c2_inv 1)
  putStrLn $ "1 ⊕ 1 ⊕ 1 = " ++ show (head (c2_eval [1, 1, 1]))
  putStrLn $ "1 ⊕ 1 ⊕ 1 ⊕ 1 = " ++ show (head (c2_eval [1, 1, 1, 1]))
```

**実行結果**

```console
$ ghci group_o2_c2_using_int.hs
```

```haskell
*Main> main
0^(-1) = 0
1^(-1) = 1
1 ⊕ 1 ⊕ 1 = 1
1 ⊕ 1 ⊕ 1 ⊕ 1 = 0
```

#### コード例2: Monoidを使用

```haskell
data C2 = C2 Int

instance Eq C2 where
  (C2 x) == (C2 x') = x == x'

instance Show C2 where
  show a = case a of
    C2 0 -> "0"
    C2 1 -> "1"
    _    -> "?"

instance Monoid C2 where
  mempty = C2 0
  mappend (C2 x) (C2 y) = C2 ((x + y) `mod` 2)

c2_inv :: C2 -> C2
c2_inv (C2 x) = head [C2 y | y <- [0..2], (C2 x) `mappend` (C2 y) == (mempty)]

main :: IO ()
main = do
  putStrLn $ "0^(-1) = " ++ show (c2_inv (C2 0))
  putStrLn $ "1^(-1) = " ++ show (c2_inv (C2 1))
  putStrLn $ "1 ⊕ 1 ⊕ 1 = " ++ show (mconcat [C2 1, C2 1, C2 1])
  putStrLn $ "1 ⊕ 1 ⊕ 1 ⊕ 1 = " ++ show (mconcat [C2 1, C2 1, C2 1, C2 1])
```

### 位数4: K<sub>4</sub>
クラインの四元群(klein four-group)です。

K<sub>4</sub>は、C<sub>2</sub>×C<sub>2</sub> の直積で表現することができます。(_a_, _b_) ∘ (_c_, _d_) = (_a_ _c_, _b_ _d_) のように計算できます。

|       | **e**=(0,0) | **p**=(0,1) | **q**=(1,0) | **r**=(1,1) |
|-------|---|---|---|---|
| **e**=(0,0) | e | p | q | r |
| **p**=(0,1) | p | e | r | q |
| **q**=(1,0) | q | r | e | p |
| **r**=(1,1) | r | q | p | e |

#### コード

```haskell
k4_sym :: String -> (Int, Int)
k4_sym "e" = (0, 0)
k4_sym "p" = (0, 1)
k4_sym "q" = (1, 0)
k4_sym "r" = (1, 1)
k4_sym  _  = error "ERROR: Invalid argument."

showTuple :: (Int, Int) -> String
showTuple (0, 0) = "e"
showTuple (0, 1) = "p"
showTuple (1, 0) = "q"
showTuple (1, 1) = "r"
showTuple _ = error "ERROR: Invalid argument."

c2_op :: Int -> Int -> Int
c2_op x y = (x + y) `mod` 2

k4_op :: (Int, Int) -> (Int, Int) -> (Int, Int)
k4_op (x1, y1) (x2, y2) = (c2_op x1 x2, c2_op y1 y2)

k4_inv :: (Int, Int) -> (Int, Int)
k4_inv (x, y) = head [(p, q) | p <- [0..2], q <- [0..2], k4_op (x, y) (p, q) == k4_sym "e"]

k4_eval :: [(Int, Int)] -> [(Int, Int)]
k4_eval [] = []
k4_eval [x] = [x]
k4_eval [x, y] = (k4_op x y):[]
k4_eval (x:y:zs) = k4_eval ((k4_eval [x, y]) ++ zs)

main :: IO ()
main = do
  putStrLn $ "p^(-1) = " ++ showTuple (k4_inv (k4_sym "p"))
  putStrLn $ "r^(-1) = " ++ showTuple (k4_inv (k4_sym "r"))
  putStrLn $ "p q = " ++ showTuple (head (k4_eval [k4_sym "p", k4_sym "q"]))
  putStrLn $ "p q r = " ++ showTuple (head (k4_eval [k4_sym "p", k4_sym "q", k4_sym "r"]))
```


**実行結果**

```console
$ ghci src/group_k4.hs
```

```haskell
*Main> main
p^(-1) = p
r^(-1) = r
p q = r
p q r = e
```

### 位数6: D<sub>3</sub>

**特徴**

* 最小の非可換群
* 二面体群 D<sub>3</sub> と置換群 S<sub>3</sub> は同型
* 直積では表現できない (半直積では表現できる)

<table style="width:100%;">
<caption><strong>演算表</strong></caption>
<colgroup>
<col width="40%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
</colgroup>
<thead>
<tr class="header">
<th></th>
<th><em>e</em></th>
<th><em>r</em></th>
<th><em>r</em><sup>2</sup></th>
<th><em>s</em></th>
<th><em>rs</em></th>
<th><em>r</em><sup>2</sup><em>s</em></th>
</tr>
</thead>
<tbody>
<tr class="odd">
<td><p><strong><em>e</em></strong></p></td>
<td><p><em>e</em></p></td>
<td><p><em>r</em></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
<td><p><em>s</em></p></td>
<td><p><em>rs</em></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>r</em></strong></p></td>
<td><p><em>r</em></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
<td><p><em>e</em></p></td>
<td><p><em>rs</em></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
<td><p><em>s</em></p></td>
</tr>
<tr class="odd">
<td><p><strong><em>r</em><sup>2</sup></strong></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
<td><p><em>e</em></p></td>
<td><p><em>r</em></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>rs</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>s</em></strong></p></td>
<td><p><em>s</em></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
<td><p><em>rs</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
<td><p><em>r</em></p></td>
</tr>
<tr class="odd">
<td><p><strong><em>rs</em></strong></p></td>
<td><p><em>rs</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
<td><p><em>r</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
</tr>
<tr class="even">
<td><p><strong><em>r</em><sup>2</sup><em>s</em></strong></p></td>
<td><p><em>r</em><sup>2</sup><em>s</em></p></td>
<td><p><em>rs</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>r</em><sup>2</sup></p></td>
<td><p><em>r</em></p></td>
<td><p><em>e</em></p></td>
</tr>
</tbody>
</table>

上記の自明でない正規部分群は N={*e*, *r*, *r*<sup>2</sup>} となります。
部分群 H={*e*, *s*} に対して、 N ∩ H = { *e* } ですから、半直積の必要条件を満たしています。

**半直積**

次の形で表されるものです。直積の場合は***ϕ***(x)(y) = ***e***<sub>r</sub> です。

(***r***<sub>1</sub>, ***s***<sub>1</sub>) ∘ (***r***<sub>2</sub>, ***s***<sub>2</sub>) = (***r***<sub>1</sub> ***r***<sub>2</sub> ***ϕ***(***s***<sub>1</sub>)(***r***<sub>2</sub>), ***s***<sub>1</sub> ***s***<sub>2</sub>)

**D<sub>3</sub>における半直積**

正規部分群 ***N*** と部分群 ***H*** とで次のように順序列で表すことができます。
直積では表現できないので、例えば直積としての計算結果 (<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>) ∘ (<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>) = (<em>r</em><sup>1+2</sup>, <em>s</em><sup>1+0</sup>) = (<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>) ですが、 D<sub>3</sub>では (<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>) ∘ (<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>) =(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>) ≠ (<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>) です。

***D***<sub>3</sub> = ***N*** ⋊ ***H*** の演算表

<table style="width:100%;">
<colgroup>
<col width="40%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
<col width="10%" />
</colgroup>
<thead>
<tr class="header">
<th></th>
<th>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</th>
<th>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</th>
<th>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</th>
<th>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</th>
<th>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</th>
<th>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</th>
</tr>
</thead>
<tbody>
<tr class="odd">
<td><p><strong>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
</tr>
<tr class="even">
<td><p><strong>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
</tr>
<tr class="odd">
<td><p><strong>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
</tr>
<tr class="even">
<td><p><strong>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
</tr>
<tr class="odd">
<td><p><strong>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
</tr>
<tr class="even">
<td><p><strong>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</strong></p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>1</sup>)</p></td>
<td><p>(<em>r</em><sup>2</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>1</sup>, <em>s</em><sup>0</sup>)</p></td>
<td><p>(<em>r</em><sup>0</sup>, <em>s</em><sup>0</sup>)</p></td>
</tr>
</tbody>
</table>

上記 ***ϕ***(x)(y) を探してみると、次のように表現できることが分かります。

```math
\phi(s)(r^{k}) = 
\begin{cases}
  r^{0} & \text{if $(s = s^{0})$} \\
  r^{k} & \text{if $(s = s^{1})$}
\end{cases}
```

#### コード例

上記を踏まえるとコードは次のようになります。

GHC 8.4.4 を使用しています。GHC 8.4 から Monoid の親クラスが Semigroup となる非互換があり、それ以前の GHC では動かせないことに注意します。

```haskell
-- An example of Semidirect products
data D3 = C3xdC2 Int Int

instance Eq D3 where
  (C3xdC2 x y) == (C3xdC2 x' y') = x == x' && y == y'

d3_sym :: String -> D3
d3_sym "e"   = C3xdC2 0 0
d3_sym "r"   = C3xdC2 1 0
d3_sym "rr"  = C3xdC2 2 0
d3_sym "s"   = C3xdC2 0 1
d3_sym "rs"  = C3xdC2 1 1
d3_sym "rrs" = C3xdC2 2 1
d3_sym  _  = error "ERROR: Invalid argument."

d3_all :: [D3]
d3_all = [d3_sym "e", d3_sym "r", d3_sym "rr", d3_sym "s", d3_sym "rs", d3_sym "rrs"]

instance Show D3 where
  show a = case a of
    C3xdC2 0 0 -> "e"
    C3xdC2 1 0 -> "r"
    C3xdC2 2 0 -> "rr"
    C3xdC2 0 1 -> "s"
    C3xdC2 1 1 -> "rs"
    C3xdC2 2 1 -> "rrs"
    C3xdC2 r s -> "(" ++ show r ++ "," ++ show s ++ ")"

phi :: Int -> Int -> Int
phi 0 _  = 0
phi 1 r' = r'
phi _ _  = error "ERROR: Invalid arguments."

instance Semigroup D3 where
  -- semidirect products: (r_x, s_x) <> (r_y, s_y) = (r_x * r_y * phi(s_x)(r_y), s_x * s_y)
  (C3xdC2 r s) <> (C3xdC2 r' s') = C3xdC2 ((r + r' + (phi s r')) `mod` 3) ((s + s') `mod` 2)

instance Monoid D3 where
  mempty = C3xdC2 0 0

d3_inv :: D3 -> D3
d3_inv (C3xdC2 r_x s_x) = head [C3xdC2 r_y s_y | r_y <- [0, 1, 2], s_y <- [0, 1], (C3xdC2 r_x s_x) <> (C3xdC2 r_y s_y) == (mempty)]

main :: IO ()
main = do
  print $ [(d3_sym "e")   <> y | y <- d3_all] == [  d3_sym "e",   d3_sym "r",  d3_sym "rr",   d3_sym "s",  d3_sym "rs", d3_sym "rrs"]
  print $ [(d3_sym "r")   <> y | y <- d3_all] == [  d3_sym "r",  d3_sym "rr",   d3_sym "e",  d3_sym "rs", d3_sym "rrs",   d3_sym "s"]
  print $ [(d3_sym "rr")  <> y | y <- d3_all] == [ d3_sym "rr",   d3_sym "e",   d3_sym "r", d3_sym "rrs",   d3_sym "s",  d3_sym "rs"]
  print $ [(d3_sym "s")   <> y | y <- d3_all] == [  d3_sym "s", d3_sym "rrs",  d3_sym "rs",   d3_sym "e",  d3_sym "rr",   d3_sym "r"]
  print $ [(d3_sym "rs")  <> y | y <- d3_all] == [ d3_sym "rs",   d3_sym "s", d3_sym "rrs",   d3_sym "r",   d3_sym "e",  d3_sym "rr"]
  print $ [(d3_sym "rrs") <> y | y <- d3_all] == [ d3_sym "rrs",  d3_sym "rs",  d3_sym "s",  d3_sym "rr",   d3_sym "r",   d3_sym "e"]
  print $ mconcat [d3_sym "s", d3_sym "r", d3_sym "s"] == d3_sym "rr"
  putStrLn $ "s * r * s = " ++ show (mconcat [d3_sym "s", d3_sym "r", d3_sym "s"]) -- == d3_sym "rr"
  print $ d3_inv (d3_sym "rrs") == d3_sym "rrs"
  putStrLn $ "(rrs)^(-1) = " ++ show (d3_inv (d3_sym "rrs")) -- == d3_sym "rrs"
```

**実行例**

非可換であることを確認。

```console
*Main> d3_sym "s" <> d3_sym "r"
rrs
*Main> d3_sym "r" <> d3_sym "s"
rs
```

***s*** ∘ ***r*** ∘ ***s*** を計算する

```console
*Main> mconcat [d3_sym "s", d3_sym "r", d3_sym "s"]
rr
```

逆元の計算

```console
*Main> d3_inv (d3_sym "e")
e
*Main> d3_inv (d3_sym "r")
rr
*Main> d3_inv (d3_sym "rr")
r
*Main> d3_inv (d3_sym "s")
s
*Main> d3_inv (d3_sym "rs")
rs
*Main> d3_inv (d3_sym "rrs")
rrs
```

### 位数8: Q<sub>8</sub>
最後は Quaternion group の位数 8 の奴です。

**特徴**

* 非可換群
* 直積や半直積で表現できない群
  * 適当な正規部分群と部分で N ∩ H {e, s} ≠ { e } である
    重なりがあると直積または半直積の形に表すことができない

**演算表:Q<sub>8</sub>**

今回は `s`、 `i`、 `j`、`k` の4変数を組み合わせて各元を表現しています。

実は、2変数でも表現できるのですが、群の中心 {e, s} が割と分かりやすいので、今回は4変数で表現しています。

<table style="width:100%;">
<colgroup>
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
<col width="11%" />
</colgroup>
<thead>
<tr class="header">
<th></th>
<th><em>e</em></th>
<th><em>s</em></th>
<th><em>i</em></th>
<th><em>si</em></th>
<th><em>j</em></th>
<th><em>sj</em></th>
<th><em>k</em></th>
<th><em>sk</em></th>
</tr>
</thead>
<tbody>
<tr class="odd">
<td><p><strong><em>e</em></strong></p></td>
<td><p><em>e</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>sk</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>s</em></strong></p></td>
<td><p><em>s</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>k</em></p></td>
</tr>
<tr class="odd">
<td><p><strong><em>i</em></strong></p></td>
<td><p><em>i</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>j</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>si</em></strong></p></td>
<td><p><em>si</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>sj</em></p></td>
</tr>
<tr class="odd">
<td><p><strong><em>j</em></strong></p></td>
<td><p><em>j</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>si</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>sj</em></strong></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>i</em></p></td>
</tr>
<tr class="odd">
<td><p><strong><em>k</em></strong></p></td>
<td><p><em>k</em></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>s</em></p></td>
<td><p><em>e</em></p></td>
</tr>
<tr class="even">
<td><p><strong><em>sk</em></strong></p></td>
<td><p><em>sk</em></p></td>
<td><p><em>k</em></p></td>
<td><p><em>sj</em></p></td>
<td><p><em>j</em></p></td>
<td><p><em>i</em></p></td>
<td><p><em>si</em></p></td>
<td><p><em>e</em></p></td>
<td><p><em>s</em></p></td>
</tr>
</tbody>
</table>

#### コード1: 群の中心を考慮しない

演算表をそのまま書き起こすだけで済むので、群の構造についての情報を知らずともコード化できるので簡単です。

```haskell
import Debug.Trace

q8_e :: String
q8_e = "e"

q8_all :: [String]
q8_all = [q8_e, "s", "i", "si", "j", "sj", "k", "sk"]

q8_dot :: String -> String -> String
q8_dot x y | x == q8_e = y
q8_dot x y | y == q8_e = x
q8_dot x y | x == "s" && y == "s" = q8_e
q8_dot x y | x == "i" && y == "i" = "s"
q8_dot x y | x == "j" && y == "j" = "s"
q8_dot x y | x == "k" && y == "k" = "s"

q8_dot x y | x == "s" && y == "i" = "si"
q8_dot x y | x == "s" && y == "si" = "i"
q8_dot x y | x == "s" && y == "j" = "sj"
q8_dot x y | x == "s" && y == "sj" = "j"
q8_dot x y | x == "s" && y == "k" = "sk"
q8_dot x y | x == "s" && y == "sk" = "k"

q8_dot x y | x == "i" && y == "s" = "si"
q8_dot x y | x == "i" && y == "si" = q8_e
q8_dot x y | x == "i" && y == "j" = "k"
q8_dot x y | x == "i" && y == "sj" = "sk"
q8_dot x y | x == "i" && y == "k" = "sj"
q8_dot x y | x == "i" && y == "sk" = "j"

q8_dot x y | x == "si" && y == "s" = "i"
q8_dot x y | x == "si" && y == "i" = q8_e
q8_dot x y | x == "si" && y == "si" = "s"
q8_dot x y | x == "si" && y == "j" = "sk"
q8_dot x y | x == "si" && y == "sj" = "k"
q8_dot x y | x == "si" && y == "k" = "j"
q8_dot x y | x == "si" && y == "sk" = "sj"

q8_dot x y | x == "j" && y == "s" = "sj"
q8_dot x y | x == "j" && y == "i" = "sk"
q8_dot x y | x == "j" && y == "si" = "k"
q8_dot x y | x == "j" && y == "sj" = q8_e
q8_dot x y | x == "j" && y == "k" = "i"
q8_dot x y | x == "j" && y == "sk" = "si"

q8_dot x y | x == "sj" && y == "s" = "j"
q8_dot x y | x == "sj" && y == "i" = "k"
q8_dot x y | x == "sj" && y == "si" = "sk"
q8_dot x y | x == "sj" && y == "j" = q8_e
q8_dot x y | x == "sj" && y == "sj" = "s"
q8_dot x y | x == "sj" && y == "k" = "si"
q8_dot x y | x == "sj" && y == "sk" = "i"

q8_dot x y | x == "k" && y == "s" = "sk"
q8_dot x y | x == "k" && y == "i" = "j"
q8_dot x y | x == "k" && y == "si" = "sj"
q8_dot x y | x == "k" && y == "j" = "si"
q8_dot x y | x == "k" && y == "sj" = "i"
q8_dot x y | x == "k" && y == "sk" = q8_e

q8_dot x y | x == "sk" && y == "s" = "k"
q8_dot x y | x == "sk" && y == "i" = "sj"
q8_dot x y | x == "sk" && y == "si" = "j"
q8_dot x y | x == "sk" && y == "j" = "i"
q8_dot x y | x == "sk" && y == "sj" = "si"
q8_dot x y | x == "sk" && y == "k" = q8_e
q8_dot x y | x == "sk" && y == "sk" = "s"

q8_dot x y = trace ("DEBUG: x=" ++ show x ++ ", y=" ++ show y) "?"

q8 :: [String] -> [String]
q8 [] = []
q8 [x] = [x]
q8 (x:xs) = q8 ([q8_dot x (head xs)] ++ (tail xs))

q8_inv :: String -> String
q8_inv x = head [x | y <- [q8_e, "s", "i", "si", "j", "sj", "k", "sk"], q8_dot x y == q8_e]

main :: IO ()
main = do
  print $ [q8_dot "e"  y | y <- q8_all] == [ "e", "s", "i","si", "j","sj", "k","sk"]
  print $ [q8_dot "s"  y | y <- q8_all] == [ "s", "e","si", "i","sj", "j","sk", "k"]
  print $ [q8_dot "i"  y | y <- q8_all] == [ "i","si", "s", "e", "k","sk","sj", "j"]
  print $ [q8_dot "si" y | y <- q8_all] == ["si", "i", "e", "s","sk", "k", "j","sj"]
  print $ [q8_dot "j"  y | y <- q8_all] == [ "j","sj","sk", "k", "s", "e", "i","si"]
  print $ [q8_dot "sj" y | y <- q8_all] == ["sj", "j", "k","sk", "e", "s","si", "i"]
  print $ [q8_dot "k"  y | y <- q8_all] == [ "k","sk", "j","sj","si", "i", "s", "e"]
  print $ [q8_dot "sk" y | y <- q8_all] == ["sk", "k","sj", "j", "i","si", "e", "s"]
  putStrLn $ "si * si = " ++ head (q8 ["si", "si"])
  putStrLn $ " i * sk = " ++ head (q8 ["i", "sj"])
  putStrLn $ "si * si  = " ++ head (q8 ["si", "si"])
  putStrLn $ "si * i * j * k = " ++ head (q8 ["si", "i", "j", "k"])
  putStrLn $ "(si)^(-1) = " ++ q8_inv "si"
```


**実行結果**

```console
$ ghci group_o8_q8_nc.hs
```

```haskell
*Main> main
True
True
True
True
True
True
True
True
si * si = s
 i * sk = sk
si * si  = s
si * i * j * k = i
(si)^(-1) = si
```

#### コード2: 群の中心を考慮する

_s_ が群の中心であることを踏まえるともう少しガード条件を減らせます。


`s` はすべての元について可換なので、次のように _s_ と _i_ は順序を変えて計算できます(_i_ _j_ ≠ _j_ _i_ であることに注意)。

$$
(s \circ i) \circ (s \circ j) = s \circ (i \circ s) \circ j = s \circ (s \circ i) \circ j = (s \circ s) \circ (i \circ j) = e \circ k = k
$$

_s_ _s_ = _e_ であるから、一か所にまとめると対消滅できます。

今回は _si_, _sj_, _sk_ を群を構成する要素として扱っているが、_si_ ∘ _sj_ = _k_ で見られるように、他の元と可換であることを踏まえて _sx_ ∘ _sy_ = (_s_ ∘ _s_) ∘ (_x_ ∘ _y_) とできる。

このように、_s_ が中心群の要素であることを考慮し、 _s_ を先頭に移動させて偶数個の _s_ を対消滅させる。

```haskell
import Debug.Trace

q8_e :: String
q8_e = "e"

q8_all :: [String]
q8_all = [q8_e, "s", "i", "si", "j", "sj", "k", "sk"]

q8_dot :: String -> String -> String
q8_dot x y | x == q8_e = y
q8_dot x y | y == q8_e = x
q8_dot x y | x == "s" && y == "s" = q8_e
q8_dot x y | x == "i" && y == "i" = "s"
q8_dot x y | x == "j" && y == "j" = "s"
q8_dot x y | x == "k" && y == "k" = "s"

q8_dot x y | x == "s" && y == "i" = "si"
q8_dot x y | x == "s" && y == "j" = "sj"
q8_dot x y | x == "s" && y == "k" = "sk"

q8_dot x y | x == "i" && y == "j" = "k"
q8_dot x y | x == "i" && y == "k" = "sj"

q8_dot x y | x == "j" && y == "i" = "sk"
q8_dot x y | x == "j" && y == "k" = "i"

q8_dot x y | x == "k" && y == "i" = "j"
q8_dot x y | x == "k" && y == "j" = "si"

-- `s` is element of the center of a group Q8
q8_dot x s       | x /= "s" && s == "s" = q8_dot s x
q8_dot x (s:ys)  | x /= "s" && s == 's' = q8_dot [s] (q8_dot x ys)
q8_dot s (s2:ys) | s == "s" && s2 == 's' = ys
q8_dot (s:xs) y  | s == 's' = q8_dot [s] (q8_dot xs y)

q8_dot x y = trace ("DEBUG: x=" ++ show x ++ ", y=" ++ show y) "?"

q8 :: [String] -> [String]
q8 [] = []
q8 [x] = [x]
q8 (x:xs) = q8 ([q8_dot x (head xs)] ++ (tail xs))

q8_inv :: String -> String
q8_inv x = head [x | y <- q8_all, q8_dot x y == q8_e]

main :: IO ()
main = do
  print $ [q8_dot "e"  y | y <- q8_all] == [ "e", "s", "i","si", "j","sj", "k","sk"]
  print $ [q8_dot "s"  y | y <- q8_all] == [ "s", "e","si", "i","sj", "j","sk", "k"]
  print $ [q8_dot "i"  y | y <- q8_all] == [ "i","si", "s", "e", "k","sk","sj", "j"]
  print $ [q8_dot "si" y | y <- q8_all] == ["si", "i", "e", "s","sk", "k", "j","sj"]
  print $ [q8_dot "j"  y | y <- q8_all] == [ "j","sj","sk", "k", "s", "e", "i","si"]
  print $ [q8_dot "sj" y | y <- q8_all] == ["sj", "j", "k","sk", "e", "s","si", "i"]
  print $ [q8_dot "k"  y | y <- q8_all] == [ "k","sk", "j","sj","si", "i", "s", "e"]
  print $ [q8_dot "sk" y | y <- q8_all] == ["sk", "k","sj", "j", "i","si", "e", "s"]
  putStrLn $ "si * si = " ++ head (q8 ["si", "si"])
  putStrLn $ " i * sk = " ++ head (q8 ["i", "sj"])
  putStrLn $ "si * si  = " ++ head (q8 ["si", "si"])
  putStrLn $ "si * i * j * k = " ++ head (q8 ["si", "i", "j", "k"])
  putStrLn $ "(si)^(-1) = " ++ q8_inv "si"
```


**実行結果**

```console
$ group_o8_q8_c.hs
```

```haskell
*Main> main
True
True
True
True
True
True
True
True
si * si = s
 i * sk = sk
si * si  = s
si * i * j * k = i
(si)^(-1) = si
```