７．ケットをHaskellで表現する
ケットをHaskellで実現することにしよう。プログラムは実装すること自体には、それほど時間を取られることはない。せいぜい数十分、長くても数時間だ。しかし、設計には多くの時間をいつも費やしている。世の中には、これとは逆の人もいるらしいが、手直しが続き、結局は、無駄な多くの時間を浪費しているのではないかと思う。
設計しているときは、それだけを一途にというわけではない。この作業をしている時の姿は、はた目から見ると無駄なことをしているなと感じられることと思う。今回も、ケットの基本的な概念を頭の隅に残して、友人から頂いた、藤沢周平の『三屋清左衛門残日録』と高田郁『八朔の雪』を読むことに集中した。
三屋清左衛門残日録は、隠居したばかりの武士の気持ちの移り変わりと、その後に展開する藩での事件を解決に導く手腕を描いた小説である。話の筋もなかなか面白いのだが、今回は、なぜか、文章の書き方に目を奪われることが多かった。一つ一つの文が、また、一つ一つの単語が、とてもきれいに配置されていて、素晴らしい書き手だなあと恐れ入った。今設計しようとたくらんでいるプログラムもこのようにきれいに書けると素晴らしいのだがと対比づけて読んだ。
八朔の雪は、澪と呼ばれる若い女性が江戸で評判となる料理を開発していく様子を描いた小説である。数々の艱難辛苦が待ち受けているのだが、それを一つ一つ乗り越えていく姿に涙を誘われる。経営学のイノベーションの視点からとらえても面白そうなのだが、料理の開発と日常での出来事がうまく織りなされていて、構成が面白いなと思って読んだ。最終講義に寄せて、数学の話と日常生活の話を織り交ぜたエッセイを書いてみた。分かりやすく書いたつもりではあったが、数学のところは読み飛ばした人が多いようであった。専門的なことと日常的なことを織り交ぜることの難しさを知っていたので、この本は私にとってこれから文章を書くときに、随分と役立つことだろうと思っている。
この二つの本を読み終わったころには、頭の中で設計が完了していたので、それを元にプログラムの形にした。
７．１ ケットの表し方
前の記事で紹介したように、格子点を使っての粒子の表し方は下図のようにしていた。
\( | ...00 \dot{0} 00200...>\)
この表現、目には優しいのだが、プログラム内部での表現としては難しいことがいくつもある。格子点の0番目には数字の上にドットがついているが、これをどのように表したらよいのかは悩ましい問題である。また、格子点は正と負に対して無限の数を取るので、これをどのように表すかも、同じように、いやらしい問題である。
表し方はいろいろあるだろうが、全てが0であるケットを次のように用意する。
\( |KetZero>\)
また、粒子が0でない格子点にはケットの中に粒子の数を書くのではなく、生成演算子\(\hat{a}^\dagger\)を用いて表すことにする。
例えば、格子点が１番目のところに粒子が1個の時は、
\(\hat{a}^\dagger_1 |KetZero>\)
と表す。格子点が１番目のところに粒子が2個の時は
\(\hat{a}^\dagger_1 \hat{a}^\dagger_1|KetZero>\)
とする。格子点が１番目と-2番目のところにそれぞれ粒子が1個の時は
\(\hat{a}^\dagger_{-2} \hat{a}^\dagger_1 |KetZero>\)
とする。
７．２ Haskellでケットを実現
ケットを
\(\hat{a}^\dagger_{-2} \hat{a}^\dagger_1 |KetZero>\)
で表すことにしたので、これを、Haskellのデータ型として用意する必要がある。
どうしたらよいだろうか。
ここまでの話で、答えが分かった人はスマートは人だと思う。リストに何となく似ていると思わないだろうか。代表的な例は文字列だ。
例えば、"word"という単語は、Haskellでは、
'w' : 'o' :'r' :'d' : []
と表すことができる。右端に空のリスト[ ]があり、その左側に、そこに入っていく文字が、その順番に従って並べられている。
リストとケットが同じ構造であることは、空のリスト[ ]をKetZeroで、文字を生成演算子で置き換えることで納得できるだろう。
リストは、代数的データ型を用いて次のように定義されている。
infixr 5 : data [] a = [] | a : [a]
そこで、ケットはこれに倣って次のように定義しよう。
infixr 5 :+: data Ket a = KetZero | a :+: Ket a deriving (Show, Read, Eq, Ord)
リストは:で要素を結合させているが、ケットは新たな演算子を設けて:+:で結合させることにしよう。そして、リストと同じように右側から結合するので、infixrで定義し、その優先度は5としよう。
この定義をファイルKet.hsに格納する。そして、これを読みだし、利用する例をいくつか示そう。
Prelude> :load "Ket.hs" [1 of 1] Compiling Ket ( Ket.hs, interpreted ) Ok, modules loaded: Ket. *Ket> let a = KetZero *Ket> a KetZero *Ket> let b = 1 :+: KetZero *Ket> b 1 :+: KetZero *Ket> let c = 2 :+: (-1) :+: b *Ket> c 2 :+: (-1 :+: (1 :+: KetZero))
上記の例で、aはKetZeroとした。また、bは格子点が1番目のところに粒子が一つある場合である。cはbに付け加えて、2と-1番目にさらに粒子が一つある場合である。
格子点の番号の小さい方から生成演算子を順番に並べる関数ksortを用意しよう。これは次のようになる。
ksort :: Ord a => Ket a -> Ket a ksort KetZero = KetZero ksort (x :+: xs) = ksort (smaller xs) +++ (x :+: KetZero) +++ ksort (larger xs) where smaller xs = smaller' xs KetZero smaller' KetZero s = s smaller' (y :+: ys) s = if y < x then smaller' ys (y :+: s) else smaller' ys s larger xs = larger' xs KetZero larger' KetZero s = s larger' (y :+: ys) s = if y >= x then larger' ys (y :+: s) else larger' ys s infixr 5 +++ (+++) :: Ket a -> Ket a -> Ket a (+++) a b = connect a b where connect KetZero b = b connect (x :+: xs) b = x :+: connect xs b
ksortのプログラムは、Haskell入門で紹介した記事のquicksortと考え方は同じである。その時は次のようになっていた。
quicksort [] = [] quicksort (x:xs) = quicksort smaller ++ [x] ++ quicksort larger where smaller = [a | a <- xs, a < x] larger = [a | a <- xs, a >= x]
quicksortでは、リストとリストを接続するのに、関数++を用いていたが、Ketでは、それらを接続するときは関数+++を用いるものとし、上記のように定義する。
それでは、これを用いてみよう。
Prelude> :load "Ket.hs" [1 of 1] Compiling Ket ( Ket.hs, interpreted ) Ok, modules loaded: Ket. *Ket> let a = 5 :+: 1 :+: 2 :+: (-1) :+: 3 :+: KetZero *Ket> a 5 :+: (1 :+: (2 :+: (-1 :+: (3 :+: KetZero)))) *Ket> ksort a -1 :+: (1 :+: (2 :+: (3 :+: (5 :+: KetZero)))) *Ket>
７．３ Haskellで生成・消滅演算子を実現
生成演算子\(\hat{a}^\dagger\)と消滅演算子\(\hat{a}\)をHaskellでは関数+^と関数-^で表すことにしよう。関数+^は、ケットのデータ型での定義a :+: Ket aと同じなので、次のようにする。
infixr 5 +^ (+^) :: a -> Ket a -> Ket a (+^) a b = a :+: b
消滅演算子は少し厄介である。粒子がないところから粒子を取り去ろうとするとケットではなくなり0になると前の記事では説明した。そこで、ここでは、このようなものは例外処理として表すこととする。即ち、このような場合には、エラー出力を出すこととし、次のようにする。
infixr 5 +^ infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (-^) a b | b == c = error "Nothing (0)" | otherwise = c where c = delete a b delete :: (Eq a) => a -> Ket a -> Ket a delete a KetZero = KetZero delete a (x :+: xs) | a == x = xs | otherwise = x :+: delete a xs
これらを含んだものをファイルKet.hsとし、これを読み込んで実行してみよう。
Prelude> :load "Ket.hs" [1 of 1] Compiling Ket ( Ket.hs, interpreted ) Ok, modules loaded: Ket. *Ket> let a = KetZero *Ket> a KetZero *Ket> let b = (+^) 1 a *Ket> b 1 :+: KetZero *Ket> let c = (+^) (-1) b *Ket> c -1 :+: (1 :+: KetZero) *Ket> let d = (+^) 1 c *Ket> d 1 :+: (-1 :+: (1 :+: KetZero)) *Ket> let e = (-^) 1 d *Ket> e -1 :+: (1 :+: KetZero) *Ket> let f = (-^) 1 e *Ket> f -1 :+: KetZero *Ket> let g = (-^) 1 f *Ket> g *** Exception: Nothing (0)
前半は生成演算子を利用して粒子を増やしている。後半は消滅演算子を利用して粒子を減らしている。最後の例は、粒子の数が0のところから減らそうとしているのでエラーとなっている。
エラーが出るのが嫌であれば、Maybeを用いて、次のように定義することも可能である。
infixr 5 +^ infixr 5 -^ infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Maybe (Ket a) (-^) a b | b == c = Nothing | otherwise = Just c where c = delete a b delete :: (Eq a) => a -> Ket a -> Ket a delete a KetZero = KetZero delete a (x :+: xs) | a == x = xs | otherwise = x :+: delete a xs
７．４ ケットの内部表現を実現
これまでに表示されたケットは、一番最初に約束した表現
\(\hat{a}^\dagger_{-2} \hat{a}^\dagger_1 |KetZero>\)
とは異なる。
そこで、この表現で表示されるようにするために、Ketのデータを表示するためのshowを手動で定義することとする。少し曲がり道をしてみよう。一般的代数的データ型になれるために、代数的データ型で定義されていたKetを一般的代数的データ型を使って定義してみよう（ここは趣味の問題なので、もちろん前のままでもよい。ただしderiving以降は省くこと。私は、一般的代数的データ型の方が代数の構造を直截に表すので、こちらの方が好きである）。
infixr 5 :+: data Ket a where KetZero :: Ket a (:+:) :: a -> Ket a -> Ket a
このときプログラムの先頭に次を加えることを忘れないようにしよう。
{-#LANGUAGE GADTs #-}
前に定義したものと同じだが、derivingがないことに注視して欲しい。そこで、クラスの継承関係を自分で定義しなければならない。手始めに、EqをKetで使えるようにする。これは次のようにする。
instance (Eq a, Ord a) => Eq (Ket a) where KetZero == KetZero = True KetZero == _ = False _ == KetZero = False (a :+: b) == (c :+: d) = (a == c) && (b == d)
これは、Ket aをEqのインスタンスにするための定義である。最初の(Eq a, Ord a)はaはEqとOrdを利用できるデータ型と定義している。
等しいことの判定は、KetZeroに対するものと、a :+: bに対するもので分かれる。KetZeroの場合には、相手がKetZeroの場合だけ等しい。それ以外は等しくない。a :+: bの場合には、相手方もこのような形c :+: dになっていて、aとcそしてbとdが両方とも等しいとき等しくなり、それ以外は等しくない。
次のshowであるがこれは次のように実現した。
instance (Show a, Read a, Eq a, Ord a) => Show (Ket a) where showsPrec _ KetZero = showString "| ...00(0)00... >" showsPrec n (a :+: b) = showString "a" . showsPrec n a . showString "^" . showsPrec n b
KetZeroの時は、ゼロが続くものを用意した。また、0番目の格子の位置は()でくくることとした。a :+: bの時は、aの部分は生成演算子で表すようにし、bについては同じことを繰り返すようにした。
プログラムを実行してみよう。
instance (Show a, Read a, Eq a, Ord a) => Show (Ket a) where Prelude> :load "Ket.hs" [1 of 1] Compiling Ket ( Ket.hs, interpreted ) Ok, modules loaded: Ket. *Ket> let a = KetZero *Ket> a | ...00(0)00... > *Ket> let b = 1 :+: a *Ket> b a1^| ...00(0)00... > *Ket> let c = (+^) 3 b *Ket> c a3^a1^| ...00(0)00... > *Ket> let d = (-1) :+: c *Ket> d a-1^a3^a1^| ...00(0)00... > *Ket> ksort d a-1^a1^a3^| ...00(0)00... >
設計時に、頭に描いたようにプログラムが機能していることが分かる。
７．５ プリティープリント
ここまでくると欲が出てくる。ケットを場の理論で説明していた形で表示したい。そこで、いわゆるプリティプリントを用意することにしよう。関数名は、prKetとしよう。
プログラムの大まかな考え方は次のようである。
1)生成演算子を格子点の大小順ではなく、0番目の位置からどれだけ離れているかで並べる。但し、同じ距離である場合には、負の方を先に並べるようにする。
2)並べ替えられた生成演算子を順番に辿り、真ん中から外へと粒子の数が並ぶようにする。
3)生成関数の処理がすべて終わったら、両端にケットの記号を付けて終了する。
これをもう少し正確に表現すると次のようになる。
1)生成演算子の順を小さいものからではなく、最初は0、次は-1、その次は1、さらに次は-2、その次は2、というように、0から始めて、その右そしてその左、さらにその右そしてその左という順番で並べる。そして、0番目での粒子の個数を書き（ただしこの場合に限りカッコをつける。
2)これを用いてその次は、左端に-1番目での粒子の数を書き次に右端に1番目での粒子の数を書き、さらにその次に、左端に-2番目での粒子の数を書き次に右端に2番目での粒子の数を書くということを続ける。
3)すべての生成演算子を処理したら、左右の端にそれぞれ000を三つ並べて、後はピリオドを繰り返しつけ、左右にケットのマークを付けて終了する。プログラムの動きの概略はこうだが、実際の動きは次のプログラムを参考にして欲しい。
prKet :: (Eq a, Ord a, Num a, Show a) => Ket a -> String prKet KetZero = "|...000(0)000...>" prKet a = "|..." ++ prKet' (ksort' $ ksort a) [] "right" 0 0 ++ "...>" where prKet' :: (Eq a, Ord a, Num a, Show a) => Ket a -> String -> String -> a -> a -> String prKet' KetZero _ _ 0 num = "000" ++ "(" ++ show num ++ ")" ++ "000" prKet' KetZero s "left" _ num = "000" ++ show num ++ s ++ "000" prKet' KetZero s "right" _ num = "000" ++ s ++ show num ++ "000" prKet' (a :+: b) s dir index num | dir == "right" && index == a = prKet' b s dir index (num + 1) | dir == "right" && index == 0 = prKet' (a :+: b) (s ++ "(" ++ show num ++ ")") "left" (index + 1) 0 | dir == "right" = prKet' (a :+: b) (s ++ show num) "left" (index + 1) 0 | dir == "left" && index == (-a) = prKet' b s dir index (num + 1) | otherwise = prKet' (a :+: b) (show num ++ s) "right" index 0 ksort :: Ord a => Ket a -> Ket a ksort KetZero = KetZero ksort (x :+: xs) = ksort (smaller xs) +++ (x :+: KetZero) +++ ksort (larger xs) where smaller xs = smaller' xs KetZero smaller' KetZero s = reverse1 s smaller' (y :+: ys) s = if y < x then smaller' ys (y :+: s) else smaller' ys s larger xs = larger' xs KetZero larger' KetZero s = reverse1 s larger' (y :+: ys) s = if y >= x then larger' ys (y :+: s) else larger' ys s ksort' :: (Num a, Ord a) => Ket a -> Ket a ksort' KetZero = KetZero ksort' (x :+: xs) = ksort' (smaller xs) +++ (x :+: KetZero) +++ ksort' (larger xs) where smaller xs = smaller' xs KetZero smaller' KetZero s = reverse1 s smaller' (y :+: ys) s = if abs y < abs x then smaller' ys (y :+: s) else smaller' ys s larger xs = larger' xs KetZero larger' KetZero s = reverse1 s larger' (y :+: ys) s = if abs y >= abs x then larger' ys (y :+: s) else larger' ys s reverse1 :: Ket a -> Ket a reverse1 x = reverse' x KetZero reverse' KetZero s = s reverse' (y :+: ys) s = reverse' ys (y :+: s)
なお、上記のプログラムで、ksortに変更がある。それは、reverse1を用いている部分であるが、これは、出てきた順番を保つためである。ksort'では、絶対値での昇順に並べ替える。先に述べたように、生成関数を0から始めて、絶対値での昇順に並べ替えるが、その時、絶対値が同じものでは元の数での昇順になっていてほしい。そのためには、ksortで出てきた順番を守る必要がある。そのため、ksortが変更されている。それではプログラムを実行してみよう。
Prelude> :load "Ket.hs" [1 of 1] Compiling Ket ( Ket.hs, interpreted ) Ok, modules loaded: Ket. *Ket> let a = 4 :+: 5 :+: 3 :+: (-1) :+: (3) :+: 2 :+: KetZero *Ket> a a4^a5^a3^a-1^a3^a2^| ...00(0)00... > *Ket> prKet a "|...00000001(0)01211000...>"
７．６ プログラム全体
それでは、プログラム全体をお見せしよう。
{-#LANGUAGE GADTs #-} module Ket (Ket (KetZero, (:+:)), (+^), (-^), prKet) where infixr 5 :+: --data Ket a = KetZero | a :+: Ket a deriving (Show, Read, Eq, Ord) data Ket a where KetZero :: Ket a (:+:) :: a -> Ket a -> Ket a infixr 5 +^ (+^) :: a -> Ket a -> Ket a (+^) a b = a :+: b infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (-^) a b | b == c = error "Nothing (0)" | otherwise = c where c = delete a b delete :: (Eq a) => a -> Ket a -> Ket a delete a KetZero = KetZero delete a (x :+: xs) | a == x = xs | otherwise = x :+: delete a xs {- infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Maybe (Ket a) (-^) a b | b == c = Nothing | otherwise = Just c where c = delete a b delete :: (Eq a) => a -> Ket a -> Ket a delete a KetZero = KetZero delete a (x :+: xs) | a == x = xs | otherwise = x :+: delete a xs -} instance (Eq a, Ord a) => Eq (Ket a) where KetZero == KetZero = True KetZero == _ = False _ == KetZero = False (a :+: b) == (c :+: d) = (a == c) && (b == d) instance (Show a, Read a, Eq a, Ord a) => Show (Ket a) where showsPrec _ KetZero = showString "| ...00(0)00... >" showsPrec n (a :+: b) = showString "a" . showsPrec n a . showString "^" . showsPrec n b prKet :: (Eq a, Ord a, Num a, Show a) => Ket a -> String prKet KetZero = "|...000(0)000...>" prKet a = "|..." ++ prKet' (ksort' $ ksort a) [] "right" 0 0 ++ "...>" where prKet' :: (Eq a, Ord a, Num a, Show a) => Ket a -> String -> String -> a -> a -> String prKet' KetZero _ _ 0 num = "000" ++ "(" ++ show num ++ ")" ++ "000" prKet' KetZero s "left" _ num = "000" ++ show num ++ s ++ "000" prKet' KetZero s "right" _ num = "000" ++ s ++ show num ++ "000" prKet' (a :+: b) s dir index num | dir == "right" && index == a = prKet' b s dir index (num + 1) | dir == "right" && index == 0 = prKet' (a :+: b) (s ++ "(" ++ show num ++ ")") "left" (index + 1) 0 | dir == "right" = prKet' (a :+: b) (s ++ show num) "left" (index + 1) 0 | dir == "left" && index == (-a) = prKet' b s dir index (num + 1) | otherwise = prKet' (a :+: b) (show num ++ s) "right" index 0 ksort :: Ord a => Ket a -> Ket a ksort KetZero = KetZero ksort (x :+: xs) = ksort (smaller xs) +++ (x :+: KetZero) +++ ksort (larger xs) where smaller xs = smaller' xs KetZero smaller' KetZero s = reverse1 s smaller' (y :+: ys) s = if y < x then smaller' ys (y :+: s) else smaller' ys s larger xs = larger' xs KetZero larger' KetZero s = reverse1 s larger' (y :+: ys) s = if y >= x then larger' ys (y :+: s) else larger' ys s ksort' :: (Num a, Ord a) => Ket a -> Ket a ksort' KetZero = KetZero ksort' (x :+: xs) = ksort' (smaller xs) +++ (x :+: KetZero) +++ ksort' (larger xs) where smaller xs = smaller' xs KetZero smaller' KetZero s = reverse1 s smaller' (y :+: ys) s = if abs y < abs x then smaller' ys (y :+: s) else smaller' ys s larger xs = larger' xs KetZero larger' KetZero s = reverse1 s larger' (y :+: ys) s = if abs y >= abs x then larger' ys (y :+: s) else larger' ys s infixr 5 +++ (+++) :: Ket a -> Ket a -> Ket a (+++) a b = connect a b where connect KetZero b = b connect (x :+: xs) b = x :+: connect xs b reverse1 :: Ket a -> Ket a reverse1 x = reverse' x KetZero where reverse' KetZero s = s reverse' (y :+: ys) s = reverse' ys (y :+: s)
