読者です 読者をやめる 読者になる 読者になる

bitterharvest’s diary

A Bitter Harvestは小説の題名。作者は豪州のPeter Yeldham。苦闘の末に勝ちえた偏見からの解放は命との引換になったという悲しい物語

身近な存在としての量子力学(12):ブラをHaskellで記述する

10.ブラをHaskellで記述する

それでは、ブラをHaskellで実現することを考える。

10.1 ブラをデータ型で定義する

ケットと同じように、ブラも代数型データで表すことにしよう。ケットは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,

10.2 演算子を定義する

演算子には、生成演算子\(\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 

10.3 内積を定義する

準備が整ったので、内積を定義しよう。あまりにあっけないのでびっくりすることと思う。これはブラの状態とケットの状態が与えられた時、それらを結合したときの値を求めるものだ。一方のブラの状態から共役であるケットの状態を求め、これが他方のケットの状態と一致していれば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

うまく動いていることが分かる。

10.4 まとめ

これまで説明してきたことを表にまとめると以下のようになる。

量子力学ケットブラ
真空状態(ケット)\(|...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\)ZeroZero'

10.5 プログラム全体

この記事で説明したプログラムの全体を記載しよう。なお、これらのプログラムの開発に要した時間は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)