身近な存在としての量子力学（１３）：ブラでの重ね合わせをHaskellで表現する

梅雨の中休みの東京の暑さに耐えるのはとても大変だ。昨年までは、7月一杯、運の悪い場合には、8月の第一週まで、講義があったため、ひたすら耐えるしか方法がなかった。しかし、退職した今年は、東京にいる義理はない。そこで、天城高原の別荘に逃げ込んでいる（この記事を書いた七夕の日（木）の日中は東京はなんと36.7度もあったそうだ。東京に戻ってからアップロードしたので、記事は1週間遅れ）。

別荘は、富士山が見えるようにということで、北西に向かって建てられている。午前中は、明るい日差しがベランダに差し込んでいるものの、部屋の中は嘘のように涼しい。爽やかな風が入ってくれば、幸せな気分を味わうこともできる。午後になると日が差し込みだすが、建物の前に立っている大きな杉の木が影を作るので、直射日光を浴びることはない。もし、暑さを感じるようであれば、北面の部屋に逃げ込めばよい。

不便なこともある。標高が700mある山の中にあるので、文明の恩恵を受けることができない。テレビは室内アンテナで受けているので、電波の状況によって映ったりそうでなかったりする。見たいなと思っていた番組が放送されているときに画面が出ないとがっかりする。強力な外部アンテナをつければよいのだが、壁のどこかに穴をあけてアンテナ線を通す工事が必要なので、なかなか踏み切れないでいる。

携帯電話も使えるとは限らない。4Gになることは決してない。アンテナの数が2－3本の3Gの時が多いのだが、それさえ消えそうな時もある。

買い物も大変だ。近くのスーパーまでは15Kmもある。東京だとうんざりする遠さであるが、そこは田舎の良さで、渋滞に巻き込まれることはない。信号も2－3カ所あるだけだ。それでも、毎日、山を下りていくのは億劫なので、まとめ買いになる。

運動不足になっているのではと主治医が詰問しそうだが、大丈夫、朝早く起きて、別荘地内を1時間も歩いている。しかも、上り下りがあるので、東京でのそれと比較すると、決して楽ではない散歩である。別荘地内の家を見るのも楽しみの一つである。なかには、とっても立派な庭を造っているところさえある。

この別荘地は、富士箱根伊豆国立公園の中にあるので、動植物をむやみにとってはいけない。そのおかげで鹿が繁殖しすぎて、被害が進んでいる。鹿はヒイラギの葉は食べないのだが、増えすぎて食べるものが少なくなったのだろう、いつの間にか食べるようになった。シャクナゲもである。昨年あたりから芽と若い葉を食べるようになってきた。せっかく植えたのにこのままでは枯れそうである。鹿が入れないようにするために庭を柵で囲う必要があるのだが、なんとなく自然を壊すようで踏み切れないでいる。

１０．　ブラでの重ね合わせ

さて、ブラをHaskellで表現するところまで進んだ、次は、ブラでの重ね合わせである。

１０．１　ブラでの重ね合わせの原理

ケットでの重ね合わせを復習しよう。ケットでは次のような線形結合を用意した。
\begin{align*}
\hat{\Psi}^\dagger & = ...+\psi_{-2} \hat{a}_{-2}^\dagger + \psi_{-1} \hat{a}_{-1}^\dagger + \psi_0 \hat{a}_0^\dagger + \psi_1 \hat{a}_1^\dagger + \psi_2 \hat{a}_2^\dagger + ... \\
& = \sum_{i=-\infty}^\infty \psi_i \hat{a}_i^\dagger
\end{align*}

そして、1粒子の重なりを次のように定義した。
\begin{align*}
\hat{\Psi}^\dagger | ...00\dot{0}00...> & = \sum_{i=-\infty}^\infty \psi_i \hat{a}_i^\dagger | ...00\dot{0}00...> \\
& = ... + \psi_{-2} |...0010\dot{0}00...> + \psi_{-1} |...001\dot{0}00...> \\
& \ + \psi_0 |...00\dot{1}00...> + \psi_1 |...00\dot{0}100...> \\
& \ + \psi_2 |...00\dot{0}0100..> + ...
\end{align*}

ブラの場合も同じように次のような線形結合を用意しよう。
\begin{align*}
\hat{\Psi} & = ...\hat{a}_{-2} \psi_{-2}^* + \hat{a}_{-1} \psi_{-1}^* + \hat{a}_0 \psi_0^* + \hat{a}_1 \psi_1^* + \hat{a}_2 \psi_2^* + ... \\
& = \sum_{i=-\infty}^\infty \hat{a}_i \psi_i^*
\end{align*}
ここで、\(\psi_{i}\)と\(\psi_{i}^*\)とは共役な複素数（虚数部の符号が反対）である。例えば、\(3+2i\)の共役複素数は\(3-2i\)である。
そして、1粒子の重なりを次のように定義しよう。
\begin{align*}<...00\dot{0}00...|\hat{\Psi} & = <...00\dot{0}00...| \sum_{i=-\infty}^\infty \hat{a}_i \psi_i \\
& = <...00\dot{0}00...|(...\hat{a}_{-2} \psi_{-2}^* + \hat{a}_{-1} \psi_{-1}^* + \hat{a}_0 \psi_0^* + \hat{a}_1\psi_1^* + \hat{a}_2 \psi_2^* + ...) \\
& = ...<...00\dot{0}00...|\hat{a}_{-2} \psi_{-2}^* + <...00\dot{0}00...|\hat{a}_{-1} \psi_{-1}^* \\
& \ \ + <...00\dot{0}00...|\hat{a}_0 \psi_0^* + <...00\dot{0}00...|\hat{a}_1\psi_1^* \\
& \ \ + <...00\dot{0}00...|\hat{a}_2 \psi_2^* + ... \\
& = ... + <...0010\dot{0}00...| \psi_{-2}^* + <...001\dot{0}00...|_{-1} \psi_{-1}^* \\
& \ \ + <...00\dot{1}00...| \psi_0^* + <...00\dot{0}100...|\psi_1^* \\
& \ \ + <...00\dot{0}0100...| \psi_2^* + ...
\end{align*}

１０．２　ブラでの重ね合わせをhaskellで表現する

ケットの重ね合わせを表す型Entangleは次のように定義した。

infixr 5 :&:

data Entangle a b 
  where
    EnZero  :: Entangle a b
    (:&:) :: (a, b) -> Entangle a b -> Entangle a b

同じように、ブラの重ね合わせCoEntangleは次のように定義しよう。

infixl 5 :|:

data CoEntangle a b 
  where
    EnZero'  :: CoEntangle a b
    (:|:) :: CoEntangle a b -> (a, b) -> CoEntangle a b

このデータ型を表示するために、Showを定義しておこう。

instance (Show a, Read a, Eq a, Ord a, Show b, Read b, Eq b) => Show (CoEntangle a b)  where
    showsPrec _ EnZero' = showString ""
    showsPrec n (EnZero' :|: (xa, xb)) = showString "a" . showsPrec n xa . showString "_" . showsPrec n xb
    showsPrec n (x :|: (ya, yb)) = showsPrec n x . showString " + " . showString "a" . showsPrec n ya . showString "_" . showsPrec n yb

また、Eqも定義しておこう。

instance (Eq a, Eq b, Ord b) => Eq (CoEntangle a b)  where
    EnZero' == EnZero'                  = True
    EnZero' == _                        = False
    _ == EnZero'                        = False
    a :|: (ba, bb) == c :|: (da, db) :|: d = (a == c) && (ba == da) && (bb == db)

また、ブラの重ね合わせが左から右に降順になるようにソートする関数esort'を定義しよう。

esort' :: (Eq a, Ord a) => CoEntangle a b -> CoEntangle a b
esort' EnZero' = EnZero'
esort' (xs :|: (xa,xb)) = esort' (larger xs) ||| (EnZero' :|: (xa,xb)) ||| esort' (smaller xs)
    where 
      smaller xs = smaller' xs EnZero'
      smaller' EnZero' s    = s 
      smaller' (ys :|: (ya, yb)) s = if ya < xa then smaller' ys (s :|: (ya, yb)) else smaller' ys s 
      larger xs  = larger' xs EnZero'
      larger'  EnZero' s    = s
      larger'  (ys :|: (ya, yb)) s = if ya >= xa then larger' ys (s :|: (ya, yb)) else larger' ys s

infixl 5 |||
(|||) :: CoEntangle a b -> CoEntangle a b -> CoEntangle a b
(|||) a b = connect a b
    where 
      connect a EnZero' = a
      connect a (xs :|: x) = connect a xs :|: x

また、ブラの重ね合わせが二つあった時に、これを一緒にする関数(-|)を定義しよう。

infixl 5 -|
(-|) :: (Eq a, Ord a, Num b) => CoEntangle a b -> CoEntangle a b -> CoEntangle a b
(-|) x y = esort' $ (-||) (esort' x) (esort' y) EnZero'
    where
      infixl 5 -||
      (-||) :: (Eq a, Ord a, Num b) => CoEntangle a b -> CoEntangle a b -> CoEntangle a b -> CoEntangle a b
      (-||) x EnZero' s = x ||| s
      (-||) EnZero' y s = y ||| s
      (-||) (xs :|: (xa,xb)) (ys :|: (ya,yb)) s
        | xa < ya = (-||) xs (ys :|: (ya,yb)) (s :|: (xa,xb))
        | xa > ya = (-||) (xs :|: (xa,xb)) ys (s :|: (ya,yb))
        | otherwise = (-||) xs ys (s :|: (xa, xb + yb))

ブラの重ね合わせを綺麗にプリントする関数prCoEntangleを用意しよう。

prCoEntangle :: (Show a, Num a, Eq a, Ord a, Show b, Num b) => CoEntangle a b -> String
prCoEntangle EnZero' = ""
prCoEntangle (EnZero' :|: (xa, xb)) = prBra (liftBra xa) ++ show xb
prCoEntangle (y :|: (xa, xb)) =  prCoEntangle y ++ " + " ++ prBra (liftBra xa) ++ show xb

最後に、ブラの重ね合わせを規格化する関数normalize'も用意する。このプログラムでは、複素数が扱えるようにしないといけない。プログラムは少し厄介だが、特に、型シグネチャの部分がてこずるが、次のようにするとよい。なお、このプログラムでは、複素数以外の整数、実数を用いるとエラーになるので、これらを用いたいときは虚数部を0にして使えばよい。例えば、実数3.3を使いたいときは、3.3 :+ 0とすればよい。

normalize'  :: (RealFloat b) => CoEntangle a (Complex b) -> CoEntangle a (Complex b)
normalize' EnZero' = EnZero'
normalize' x = normalize'' x
    where
      total = sqrt $ sum x 0
      sum ::  (RealFloat b) => CoEntangle a (Complex b) -> b -> b
      sum EnZero' s = s
      sum (x :|: (ya, yb)) s = sum x $ (magnitude yb) * (magnitude yb)  + s
      normalize'' EnZero' = EnZero'
      normalize'' (x :|: (ya, yb)) = normalize'' x :|: (ya, (realPart yb) / total :+ (imagPart yb) / total)

liftBra :: a -> Bra a
liftBra a = BraZero :-: a

この部分についてはケットの重ね合わせを規格化する関数も変更しないとならない。それは次のようになる。

normalize  ::  (RealFloat a) => Entangle (Complex a) b -> Entangle (Complex a) b
normalize EnZero = EnZero
normalize x = normalize'' x
    where
      total = sqrt $ sum x 0
      sum ::  (RealFloat a) => Entangle (Complex a) b -> a -> a
      sum EnZero s = s
      sum ((xa, xb) :&: y) s = sum y $ (magnitude xa) * (magnitude xa)  + s
      normalize'' EnZero = EnZero
      normalize'' ((xa, xb) :&: y) = ((realPart xa) / total :+ (imagPart xa) / total, xb) :&: normalize'' y

liftKet :: a -> Ket a
liftKet a = a :+: KetZero

１０．３　プログラムの全体

モジュールの数が増えてきたので、そろそろ階層化して、整理しよう。量子力学に関連するプログラムはQtmの下に置く。
また、ケットとブラにかかわるものは、Qtmの下のKetBraに置くことにする。また、重ね合わせに関するプログラムは、Qtmの下のEntangleに置くことにする。

ブラの重ね合わせのモジュールをQtm.Entangle.BraEntangleとした時のプログラムの全体を示す。なお、このとき、Braのモジュール名は、Qtm.KetBra.Braに変更する。

{-#LANGUAGE GADTs #-}

module Qtm.Entangle.BraEntangle (CoEntangle (EnZero', (:|:)), esort', (-|), prCoEntangle, normalize')  where

import Qtm.KetBra.Bra
import Data.Complex

infixl 5 :|:

data CoEntangle a b 
  where
    EnZero'  :: CoEntangle a b
    (:|:) :: CoEntangle a b -> (a, b) -> CoEntangle a b

esort' :: (Eq a, Ord a) => CoEntangle a b -> CoEntangle a b
esort' EnZero' = EnZero'
esort' (xs :|: (xa,xb)) = esort' (larger xs) ||| (EnZero' :|: (xa,xb)) ||| esort' (smaller xs)
    where 
      smaller xs = smaller' xs EnZero'
      smaller' EnZero' s    = s 
      smaller' (ys :|: (ya, yb)) s = if ya < xa then smaller' ys (s :|: (ya, yb)) else smaller' ys s 
      larger xs  = larger' xs EnZero'
      larger'  EnZero' s    = s
      larger'  (ys :|: (ya, yb)) s = if ya >= xa then larger' ys (s :|: (ya, yb)) else larger' ys s

infixl 5 |||
(|||) :: CoEntangle a b -> CoEntangle a b -> CoEntangle a b
(|||) a b = connect a b
    where 
      connect a EnZero' = a
      connect a (xs :|: x) = connect a xs :|: x

infixl 5 -|
(-|) :: (Eq a, Ord a, Num b) => CoEntangle a b -> CoEntangle a b -> CoEntangle a b
(-|) x y = esort' $ (-||) (esort' x) (esort' y) EnZero'
    where
      infixl 5 -||
      (-||) :: (Eq a, Ord a, Num b) => CoEntangle a b -> CoEntangle a b -> CoEntangle a b -> CoEntangle a b
      (-||) x EnZero' s = x ||| s
      (-||) EnZero' y s = y ||| s
      (-||) (xs :|: (xa,xb)) (ys :|: (ya,yb)) s
        | xa < ya = (-||) xs (ys :|: (ya,yb)) (s :|: (xa,xb))
        | xa > ya = (-||) (xs :|: (xa,xb)) ys (s :|: (ya,yb))
        | otherwise = (-||) xs ys (s :|: (xa, xb + yb))

instance (Eq a, Eq b, Ord b) => Eq (CoEntangle a b)  where
    EnZero' == EnZero'                  = True
    EnZero' == _                        = False
    _ == EnZero'                        = False
    a :|: (ba, bb) == c :|: (da, db) :|: d = (a == c) && (ba == da) && (bb == db)


instance (Show a, Read a, Eq a, Ord a, Show b, Read b, Eq b) => Show (CoEntangle a b)  where
    showsPrec _ EnZero' = showString ""
    showsPrec n (EnZero' :|: (xa, xb)) = showString "a" . showsPrec n xa . showString "_" . showsPrec n xb
    showsPrec n (x :|: (ya, yb)) = showsPrec n x . showString " + " . showString "a" . showsPrec n ya . showString "_" . showsPrec n yb


prCoEntangle :: (Show a, Num a, Eq a, Ord a, Show b, Num b) => CoEntangle a b -> String
prCoEntangle EnZero' = ""
prCoEntangle (EnZero' :|: (xa, xb)) = prBra (liftBra xa) ++ show xb
prCoEntangle (y :|: (xa, xb)) =  prCoEntangle y ++ " + " ++ prBra (liftBra xa) ++ show xb

liftBra :: a -> Bra a
liftBra a = BraZero :-: a

normalize'  :: (RealFloat b) => CoEntangle a (Complex b) -> CoEntangle a (Complex b)
normalize' EnZero' = EnZero'
normalize' x = normalize'' x
    where
      total = sqrt $ sum x 0
      sum ::  (RealFloat b) => CoEntangle a (Complex b) -> b -> b
      sum EnZero' s = s
      sum (x :|: (ya, yb)) s = sum x $ (magnitude yb) * (magnitude yb)  + s
      normalize'' EnZero' = EnZero'
      normalize'' (x :|: (ya, yb)) = normalize'' x :|: (ya, (realPart yb) / total :+ (imagPart yb) / total)

ケットの重ね合わせの方も一部変更したので、全体を示す。なお、モジュール名は、Qtm.Entangle.KetEntangleとしよう。

{-#LANGUAGE GADTs #-}

module Qtm.Entangle.KetEntangle (Entangle (EnZero, (:&:)), esort, (+&), prEntangle, normalize) where

import Qtm.KetBra.Ket
import Data.Complex

infixr 5 :&:

data Entangle a b 
  where
    EnZero  :: Entangle a b
    (:&:) :: (a, b) -> Entangle a b -> Entangle a b

esort :: (Eq b, Ord b) => Entangle a b -> Entangle a b
esort EnZero = EnZero
esort ((xa,xb) :&: xs) = esort (smaller xs) &&& ((xa,xb) :&: EnZero) &&& esort (larger xs)
    where 
      smaller xs = smaller' xs EnZero
      smaller' EnZero s    = s 
      smaller' ((ya, yb) :&: ys) s = if yb < xb then smaller' ys ((ya, yb) :&: s) else smaller' ys s 
      larger xs  = larger' xs EnZero
      larger'  EnZero s    = s
      larger'  ((ya, yb) :&: ys) s = if yb >= xb then larger' ys ((ya, yb) :&: s) else larger' ys s
infixr 5 &&&
(&&&) :: Entangle a b -> Entangle a b -> Entangle a b
(&&&) a b = connect a b
    where 
      connect EnZero b = b
      connect (x :&: xs) b = x :&: connect xs b

infixr 5 +&
(+&) :: (Num a, Eq b, Ord b) => Entangle a b -> Entangle a b -> Entangle a b
(+&) x y = esort $ (+&&) (esort x) (esort y) EnZero
    where
      infixr 5 +&&
      (+&&) :: (Num a, Eq b, Ord b) => Entangle a b -> Entangle a b -> Entangle a b -> Entangle a b
      (+&&) x EnZero s = x &&& s
      (+&&) EnZero y s = y &&& s
      (+&&) ((xa,xb) :&: xs) ((ya,yb) :&: ys) s
        | xb < yb = (+&&) xs ((ya,yb) :&: ys) ((xa,xb) :&: s)
        | xb > yb = (+&&) ((xa,xb) :&: xs) ys ((ya,yb) :&: s)
        | otherwise = (+&&) xs ys ((xa + ya,xb) :&: s)

instance (Eq a, Eq b, Ord b) => Eq (Entangle a b)  where
    EnZero == EnZero                   = True
    EnZero == _                        = False
    _ == EnZero                        = False
    (aa, ab) :&: b == (ca, cb) :&: d = (aa == ca) && (ab == cb) && (b == d)


instance (Show a, Read a, Eq a, Show b, Read b, Eq b, Ord b) => Show (Entangle a b)  where
    showsPrec _ EnZero   = showString ""
    showsPrec n ((xa, xb) :&: EnZero)   = showsPrec n xa . showString "_a" . showsPrec n xb . showString "^"
    showsPrec n ((xa, xb) :&: y)   = showsPrec n xa . showString "_a" . showsPrec n xb . showString "^ + " . showsPrec n y

prEntangle :: (Show a, Num a, Show b, Num b, Eq b, Ord b) => Entangle a b -> String
prEntangle EnZero = ""
prEntangle ((xa, xb) :&: EnZero) = "(" ++ show xa ++ ")" ++ prKet (liftKet xb)
prEntangle ((xa, xb) :&: y) = "(" ++ show xa ++ ")" ++ prKet (liftKet xb) ++ " + " ++ prEntangle y

liftKet :: a -> Ket a
liftKet a = a :+: KetZero

normalize  ::  (RealFloat a) => Entangle (Complex a) b -> Entangle (Complex a) b
normalize EnZero = EnZero
normalize x = normalize'' x
    where
      total = sqrt $ sum x 0
      sum ::  (RealFloat a) => Entangle (Complex a) b -> a -> a
      sum EnZero s = s
      sum ((xa, xb) :&: y) s = sum y $ (magnitude xa) * (magnitude xa)  + s
      normalize'' EnZero = EnZero
      normalize'' ((xa, xb) :&: y) = ((realPart xa) / total :+ (imagPart xa) / total, xb) :&: normalize'' y