１０．１ ブラをデータ型で定義する
ケットと同じように、ブラも代数型データで表すことにしよう。ケットは7章で次のように定義した。
infixr 5 :+: data Ket a where KetZero :: Ket a (:+:) :: a -> Ket a -> Ket a
すなわち、真空状態をKetZeroで表した。また、現在の状態に対して、区間\(i\)に1粒子が存在している状態を
i :+: 現在の状態
で表現した。
ブラもこれと同じように表すことにしよう。真空の状態をBraZeroで表すこととする。また、現在の状態に対して、区間\(i\)で1粒子を欲しがっている状態を、
現在の状態 :-: i
で表すことにしよう。
ケットの時は増加の意味を持たせて+を用いたが、ブラの場合には反対に減少と考え-を用いる。
7章では、状態を表していないケットが生じたときは、例外が発生するようにした。即ち、nothing(0)を出力した。しかし、このように定義すると、内積の計算をする時に不備をきたす。そこで、状態を表していないときは、Zero'で表すこととし、これも、ブラのデータ型に含めるようにした。ブラのデータ型は従って次のように定義した（これに伴って、ケットの方も修正し、Zeroを定義する。これは後すぐ述べる）。
infixl 5 :-: data Bra a where Zero' :: Bra a -- Don't use it when defining a Bra. It is only used when operating Bra data. BraZero :: Bra a (:-:) :: Bra a -> a -> Bra a
なお、リストを作るための:-:は左の方に結合されていくので、infixlとした。
ケットの方も、状態を表していないときはZeroで表すこととし、次のように変更した。
infixr 5 :+: data Ket a where Zero :: Ket a -- Don't use it when defining a Ket. It is only used through operatons. KetZero :: Ket a (:+:) :: a -> Ket a -> Ket a
次に、ブラの型に、等しいかどうかを判定するための関数Eqと、表示するための関数Showを、インスタンスとして実現する必要がある。
関数Eqの方は、現在の状態とその後に続く演算子の並びが等しいかどうかで判定する。従って、演算子の並び方は異なるが、現在の状態にこれらの演算子を施した結果得られる新たな状態で比較していない。そのため、新たな状態が等しい場合でも、現在の状態と演算子の並びが作るリストが異なっている場合には等しくないと判定される。
プログラムは次のようになる。なお、表示の方はケットの場合に少し変更を及ぼし、演算子の間にカンマ(,)が入るようにした。
instance (Eq a, Ord a) => Eq (Bra a) where Zero' == Zero' = True Zero' == _ = False _ == Zero' = False BraZero == BraZero = True BraZero == _ = False _ == BraZero = False (a :-: b) == (c :-: d) = (a == c) && (b == d) instance (Show a, Read a, Eq a, Ord a) => Show (Bra a) where showsPrec _ Zero' = showString "0" showsPrec _ BraZero = showString "< ...00(0)00... |" showsPrec n (a :-: b) = showsPrec n a . showString "-a" . showsPrec n b . showString ","
実行してみよう。
Prelude> :load "Bra.hs" [1 of 2] Compiling Ket ( Ket.hs, interpreted ) [2 of 2] Compiling Bra ( Bra.hs, interpreted ) Ok, modules loaded: Bra, Ket. *Bra> let a = BraZero *Bra> let b = a :-: 1 *Bra> let c = b :-: 2 *Bra> let d = a :-: 2 :-: 1 *Bra> a < ...00(0)00... | *Bra> b < ...00(0)00... |-a1, *Bra> c < ...00(0)00... |-a1,-a2, *Bra> d < ...00(0)00... |-a2,-a1, *Bra> c == d False
ケットの方もこれに合わせて変更した。プルグラムを見てみよう。
instance (Eq a, Ord a) => Eq (Ket a) where Zero == Zero = True Zero == _ = False _ == Zero = False 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 _ Zero = showString "0" showsPrec _ KetZero = showString "| ...00(0)00... >" showsPrec n (a :+: b) = showString ",a" . showsPrec n a . showString "+" . showsPrec n b
ブラが表す状態をきれいに印字したい。すでに、ケットの方が出来上がっているので、これを利用することにする。次のようにすればよい。与えられたブラの状態に対して、その共役となるケットの状態を作成し、状態の中身をそのままにして、ケットの記号をブラのそれに代えればよいので、次のようになる。
prBra :: (Eq a, Ord a, Num a, Show a) => Bra a -> String prBra Zero' = "0" prBra b = "<" ++ c ++ "|" where c = init $ tail $ prKet (invB b)
実行してみよう。先の続きである。
*Bra> prBra a "<...000(0)000...|" *Bra> prBra b "<...0000(0)1000...|" *Bra> prBra c "<...00000(0)11000...|" *Bra> prBra d "<...00000(0)11000...|"
なお、PrKetはZeroに対応するために、プログラムの2行目が変更になっている。全体を示すと次のようになる。
prKet :: (Eq a, Ord a, Num a, Show a) => Ket a -> String prKet Zero = "0" 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 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)
ブラの状態の共役はケットの状態であり、ケットの状態の共役はブラの状態であるので、共役を求める関数を用意しよう。ブラの状態の共役を求める関数invBは次のようにしよう。
invB :: (Eq a, Ord a) => Bra a -> Ket a invB Zero' = Zero invB BraZero = KetZero invB (b :-: a) | b == BraZero = a :+: KetZero | otherwise = a :+: (invB b)
逆に、ケットの状態の共役を求める関数invKは次のようになる。
invK :: (Eq a, Ord a) => Ket a -> Bra a invK Zero = Zero' invK KetZero = BraZero invK (a :+: b) | b == KetZero = BraZero :-: a | otherwise = (invK b) :-: a
プログラムを実行してみよう。
*Bra> invB a | ...00(0)00... > *Bra> invB b ,a1+| ...00(0)00... > *Bra> invB c ,a2+,a1+| ...00(0)00... > *Bra> invB d ,a1+,a2+| ...00(0)00... > *Bra> invK $ invB a < ...00(0)00... | *Bra> invK $ invB b < ...00(0)00... |-a1, *Bra> invK $ invB c < ...00(0)00... |-a1,-a2, *Bra> invK $ invB d < ...00(0)00... |-a2,-a1,
１０．２ 演算子を定義する
演算子には、生成演算子\(\hat{a}_i\)と消滅演算子\(\hat{a}^\dagger_i\)がある。量子力学では、これらの演算子は、ブラにもケットにも作用できるようにしているが、Haskellは型にうるさい言語である。どちらにも適応できるようにすると曖昧さが残るので、ここでは、それぞれの型に対して用意しよう。
ケットでは、生成演算子には+^を、消滅演算子には-^を用意した。また、右側に接続するという意味で^を右側において用いた。
そこで、ブラでは、左側に接続するという意味で^を左側におき、生成演算子には^+を、消滅演算子には^-を用意しよう。プログラムは次のようになる。これらのプログラムは、^-の共役は+^であり、^+の共役は-^であることを利用している。
infixl 5 ^- (^-) :: (Eq a, Ord a) => Bra a -> a -> Bra a (^-) Zero' _ = Zero' (^-) b a = invK $ a :+: (invB b) infixl 5 ^+ (^+) :: (Eq a, Ord a) => Bra a -> a -> Bra a (^+) Zero' _ = Zero' (^+) b a | b' == c = Zero' | otherwise = (invK c) where b' = invB b 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
プログラムを実行してみよう。
*Bra> let a = BraZero ^- 2 *Bra> let b = BraZero ^- 2 ^- 3 *Bra> let c = BraZero ^- 2 ^- 3 ^+ 2 *Bra> a < ...00(0)00... |-a2, *Bra> b < ...00(0)00... |-a2,-a3, *Bra> c < ...00(0)00... |-a3,
ケットの方の演算子は次のように定義される。7章でのプログラムに、Zeroの処理を加えた。
infixr 5 +^ (+^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (+^) _ Zero = Zero (+^) a b = a :+: b infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (-^) _ Zero = Zero (-^) a b | b == c = Zero | 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
１０．３ 内積を定義する
準備が整ったので、内積を定義しよう。あまりにあっけないのでびっくりすることと思う。これはブラの状態とケットの状態が与えられた時、それらを結合したときの値を求めるものだ。一方のブラの状態から共役であるケットの状態を求め、これが他方のケットの状態と一致していれば1をそうでなければ0を出力する。プログラムは次のようになる。
infix 4 ^*^ (^*^) :: (Eq a, Ord a, Num a, Show a) => Bra a -> Ket a -> a (^*^) b k | b == Zero' = 0 | k == Zero = 0 | prKet (invB b) == prKet k = 1 | otherwise = 0
実行してみよう。テスト用のプログラムを用意しておこう。
{-#LANGUAGE GADTs #-} module Test where import Bra a = BraZero ^- 3 ^- 4 ^- 1 b = 3 +^ 1 +^ 4 +^ KetZero c = BraZero ^- 3 ^- 4 ^- 1 ^+ 2 d = 2 -^ 3 +^ 1 +^ 4 +^ KetZero
Braのモジュールは
module Bra (Bra (Zero', BraZero, (:-:)), (^+), (^-), prBra, (^*^)) と定義した。
それでは実行してみよう。
*Test> a ^*^ b 1 *Test> a ^*^ d 0 *Test> c ^*^ b 0 *Test> c ^*^ d 0
また、\( < ...00\dot000... | \hat{a}^\dagger_1 \hat{a}^\dagger_2 \hat{a}_1 \hat{a}_2 | ...00\dot000... >\)を内積の位置を動かして実行してみよう。
*Test> BraZero ^- 1 ^- 2 ^*^ 1 +^ 2 +^ KetZero 1 *Test> BraZero ^- 1 ^- 2 ^+ 1 ^*^ 2 +^ KetZero 1 *Test> BraZero ^- 1 ^- 2 ^+ 1 ^+ 2 ^*^ KetZero 1 *Test> BraZero ^- 1 ^*^ 2 -^ 1 +^ 2 +^ KetZero 1 *Test> BraZero ^*^ 1 -^ 2 -^ 1 +^ 2 +^ KetZero 1
うまく動いていることが分かる。
１０．４ まとめ
これまで説明してきたことを表にまとめると以下のようになる。
| 量子力学 | ケット | ブラ | |
|---|---|---|---|
| 真空状態（ケット） | \(|...00\dot000...>\) | KetZero | |
| 真空状態（ブラ） | \(<...00\dot000...|\) | BraZero | |
| 区間1，2に1粒子(有) | \(|...00\dot01100...>\) | 2 :+: 1 :+: KetZero | |
| 区間1，2に1粒子(待) | \(<...00\dot01100...|\) | BraZero :-: 1 :-: 2 | |
| 生成演算子 | \(\hat{a}^\dagger_i\) | i +^ | ^+ i |
| 消滅演算子 | \(\hat{a}_i\) | i -^ | ^- i |
| 生成演算子使用例 | \(\hat{a}^\dagger_1|...00\dot000...>\) | i +^ KetZero | |
| 生成演算子使用例 | \(<...00\dot000...|\hat{a}^\dagger_1\) | BraZero ^+ i | |
| 消滅演算子使用例 | \(\hat{a}_1|...00\dot000...>\) | 1 -^ KetZero | |
| 消滅演算子使用例 | \(<...00\dot000...|\hat{a}_1\) | BraZero ^- 1 | |
| 内積 | ^*^ | ||
| 内積使用例 | \(<...00\dot000...|...00\dot000...>\) | BraZero ^*^ KetZero | |
| 状態でない | \(0\) | Zero | Zero' |
１０．５ プログラム全体
この記事で説明したプログラムの全体を記載しよう。なお、これらのプログラムの開発に要した時間は2時間であった。半日は覚悟していたのだが、短い時間で出来上がり、Haskellの記述能力の高さに感謝している。
Braに関するプログラムは以下のとおりである。
{-#LANGUAGE GADTs #-} module Bra (Bra (Zero', BraZero, (:-:)), (^+), (^-), prBra, (^*^)) where import Ket infixl 5 :-: data Bra a where Zero' :: Bra a -- Don't use it when defining a Bra. It is only used when operating Bra data. BraZero :: Bra a (:-:) :: Bra a -> a -> Bra a -- deriving (Show, Read, Eq, Ord) invB :: (Eq a, Ord a) => Bra a -> Ket a invB Zero' = Zero invB BraZero = KetZero invB (b :-: a) | b == BraZero = a :+: KetZero | otherwise = a :+: (invB b) invK :: (Eq a, Ord a) => Ket a -> Bra a invK Zero = Zero' invK KetZero = BraZero invK (a :+: b) | b == KetZero = BraZero :-: a | otherwise = (invK b) :-: a instance (Eq a, Ord a) => Eq (Bra a) where Zero' == Zero' = True Zero' == _ = False _ == Zero' = False BraZero == BraZero = True BraZero == _ = False _ == BraZero = False (a :-: b) == (c :-: d) = (a == c) && (b == d) instance (Show a, Read a, Eq a, Ord a) => Show (Bra a) where showsPrec _ Zero' = showString "0" showsPrec _ BraZero = showString "< ...00(0)00... |" showsPrec n (a :-: b) = showsPrec n a . showString "-a" . showsPrec n b . showString "," prBra :: (Eq a, Ord a, Num a, Show a) => Bra a -> String prBra Zero' = "0" prBra b = "<" ++ c ++ "|" where c = init $ tail $ prKet (invB b) infixl 5 ^- (^-) :: (Eq a, Ord a) => Bra a -> a -> Bra a (^-) Zero' _ = Zero' (^-) b a = invK $ a :+: (invB b) infixl 5 ^+ (^+) :: (Eq a, Ord a) => Bra a -> a -> Bra a (^+) Zero' _ = Zero' (^+) b a | b' == c = Zero' | otherwise = (invK c) where b' = invB b 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 infix 4 ^*^ (^*^) :: (Eq a, Ord a, Num a, Show a) => Bra a -> Ket a -> a (^*^) b k | b == Zero' = 0 | k == Zero = 0 | prKet (invB b) == prKet k = 1 | otherwise = 0
修正したケットのプログラムは以下のとおりである。
{-#LANGUAGE GADTs #-} module Ket (Ket (Zero, KetZero, (:+:)), (+^), (-^), prKet) where infixr 5 :+: data Ket a where Zero :: Ket a -- Don't use it when defining a Ket. It is only used through operatons. KetZero :: Ket a (:+:) :: a -> Ket a -> Ket a infixr 5 +^ (+^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (+^) _ Zero = Zero (+^) a b = a :+: b infixr 5 -^ (-^) :: (Eq a, Ord a) => a -> Ket a -> Ket a (-^) _ Zero = Zero (-^) a b | b == c = Zero | 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 instance (Eq a, Ord a) => Eq (Ket a) where Zero == Zero = True Zero == _ = False _ == Zero = False 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 _ Zero = showString "0" 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 Zero = "0" 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 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)
