概要
群論を少し勉強したので、Haskell でのコード化を試してみた。
高度なことはしていませんが、数学的な概念が関数設計に反映されています。
どちらかというと、数学的な構造をどうモデル化してコード化するのかといったアイディアの紹介です。
環境
-
GHCi
version 8.0.2
定義
まずは、半群の定義から行います。
-
結合律を満たす
S の各元 a, b, c に対して (a • b) • c = a • (b • c) を満たす。
群の場合は、さらに次を満たします。
- 単位元の存在
- 逆元の存在
設計上のアイディア
次の点がポイントです。この条件を満たすのでリスト構造で数式を管理できます。
- 結合律を満たす
結合律を満たさない場合、評価順序の違いがでるためツリー構造で表現する必要があります。
コード例
位数2: C2
C2と同型な XOR です。演算表は次のようになります。
| ⊕ | 0 | 1 |
|---|---|---|
| 0 | 0 | 1 |
| 0 | 1 | 0 |
コード例1: 独自に実装
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]))
実行結果
$ ghci group_o2_c2_using_int.hs
*Main> main
0^(-1) = 0
1^(-1) = 1
1 ⊕ 1 ⊕ 1 = 1
1 ⊕ 1 ⊕ 1 ⊕ 1 = 0
コード例2: Monoidを使用
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: K4
クラインの四元群(klein four-group)です。
K4は、C2×C2 の直積で表現することができます。(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 |
コード
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"]))
実行結果
$ ghci src/group_k4.hs
*Main> main
p^(-1) = p
r^(-1) = r
p q = r
p q r = e
位数6: D3
特徴
- 最小の非可換群
- 二面体群 D3 と置換群 S3 は同型
- 直積では表現できない (半直積では表現できる)
| e | r | r2 | s | rs | r2s | |
|---|---|---|---|---|---|---|
e |
e |
r |
r2 |
s |
rs |
r2s |
r |
r |
r2 |
e |
rs |
r2s |
s |
r2 |
r2 |
e |
r |
r2s |
s |
rs |
s |
s |
r2s |
rs |
e |
r2 |
r |
rs |
rs |
s |
r2s |
r |
e |
r2 |
r2s |
r2s |
rs |
s |
r2 |
r |
e |
上記の自明でない正規部分群は N={e, r, r2} となります。
部分群 H={e, s} に対して、 N ∩ H = { e } ですから、半直積の必要条件を満たしています。
半直積
次の形で表されるものです。直積の場合はϕ(x)(y) = er です。
(r1, s1) ∘ (r2, s2) = (r1 r2 ϕ(s1)(r2), s1 s2)
D3における半直積
正規部分群 N と部分群 H とで次のように順序列で表すことができます。
直積では表現できないので、例えば直積としての計算結果 (r1, s1) ∘ (r2, s0) = (r1+2, s1+0) = (r0, s1) ですが、 D3では (r1, s1) ∘ (r2, s0) =(r2, s1) ≠ (r0, s1) です。
D3 = N ⋊ H の演算表
| (r0, s0) | (r1, s0) | (r2, s0) | (r0, s1) | (r1, s1) | (r2, s1) | |
|---|---|---|---|---|---|---|
(r0, s0) |
(r0, s0) |
(r1, s0) |
(r2, s0) |
(r0, s1) |
(r1, s1) |
(r2, s1) |
(r1, s0) |
(r1, s0) |
(r2, s0) |
(r0, s0) |
(r1, s1) |
(r2, s1) |
(r0, s1) |
(r2, s0) |
(r2, s0) |
(r0, s0) |
(r1, s0) |
(r2, s1) |
(r0, s1) |
(r1, s1) |
(r0, s1) |
(r0, s1) |
(r2, s1) |
(r1, s1) |
(r0, s0) |
(r2, s0) |
(r0, s1) |
(r1, s1) |
(r1, s1) |
(r0, s1) |
(r2, s1) |
(r1, s0) |
(r0, s0) |
(r2, s0) |
(r2, s1) |
(r2, s1) |
(r1, s1) |
(r0, s1) |
(r2, s0) |
(r1, s0) |
(r0, s0) |
上記 ϕ(x)(y) を探してみると、次のように表現できることが分かります。
\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 では動かせないことに注意します。
-- 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"
実行例
非可換であることを確認。
*Main> d3_sym "s" <> d3_sym "r"
rrs
*Main> d3_sym "r" <> d3_sym "s"
rs
s ∘ r ∘ s を計算する
*Main> mconcat [d3_sym "s", d3_sym "r", d3_sym "s"]
rr
逆元の計算
*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: Q8
最後は Quaternion group の位数 8 の奴です。
特徴
- 非可換群
- 直積や半直積で表現できない群
- 適当な正規部分群と部分で N ∩ H {e, s} ≠ { e } である
重なりがあると直積または半直積の形に表すことができない
- 適当な正規部分群と部分で N ∩ H {e, s} ≠ { e } である
演算表:Q8
今回は s、 i、 j、k の4変数を組み合わせて各元を表現しています。
実は、2変数でも表現できるのですが、群の中心 {e, s} が割と分かりやすいので、今回は4変数で表現しています。
| e | s | i | si | j | sj | k | sk | |
|---|---|---|---|---|---|---|---|---|
e |
e |
s |
i |
si |
j |
sj |
k |
sk |
s |
s |
e |
si |
i |
sj |
j |
sk |
k |
i |
i |
si |
s |
e |
k |
sk |
sj |
j |
si |
si |
i |
e |
s |
sk |
k |
j |
sj |
j |
j |
sj |
sk |
k |
s |
e |
i |
si |
sj |
sj |
j |
k |
sk |
e |
s |
si |
i |
k |
k |
sk |
j |
sj |
si |
i |
s |
e |
sk |
sk |
k |
sj |
j |
i |
si |
e |
s |
コード1: 群の中心を考慮しない
演算表をそのまま書き起こすだけで済むので、群の構造についての情報を知らずともコード化できるので簡単です。
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"
実行結果
$ ghci group_o8_q8_nc.hs
*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 を対消滅させる。
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"
実行結果
$ group_o8_q8_c.hs
*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