8.4 重ね合わせをHaskellで表現する
前回の記事で、次の図を説明なしに示した。
今回はこの図を説明した後で、Haskellでの表現を考えることにしよう。図の右側は、普通に使われている重ね合わせの状態(この集りをエンタングル状態空間と呼ぶことにする)をHaskellでの表現に変えたものである。
前の記事で説明したように、重ね合わせの状態は、
\(\Psi=...\psi_{-2}|...00010\dot{0}000...>+\psi_{-1}|...0001\dot{0}000...>+\psi_{0}|...000\dot{1}000...>\)
\(+\psi_{1}|...000\dot{0}1000...>+\psi_{2}|...000\dot{0}01000...>...\)
であった。即ち、\(\psi_{i}\)と\(|...000(0)0...010...>\)(この時、1の位置は\(i\)番目の壱である)を対とした線形結合になっている。そこで、\(\psi_{i}=0\)であるものを除いて、これらの対のリスト、即ち、\([(\psi,a)]\)で表すこととする。
例えば、\(\Psi=\psi_1|...0(0)10...>+\psi_2|...0(0)010...>\)であれば、図のように\([(\psi_1,|...0(0)10...>),(\psi_2,|...0(0)010...>)]\)と表す。
しかし、この表現は、状態が無限の長さの数字の列にあっているため、Haskellの中では扱いにくい。そこで、エンタングル状態空間は、エンタングル演算子空間からの写像になっている。また、これらの空間間の写像は、1対1対応であるので、状態を演算子で置き換えて表現することとする。例えば、\([(\psi_1,|...0(0)10...>),(\psi_2,|...0(0)010...>)]\)は\([(\psi_1,\hat{a}_1^\dagger),(\psi_2,\hat{a}_2^\dagger)]\)となる。Haskellではこの表現を用いることにしよう。そこで、エンタングル演算子空間を新たなデータ型で表現することを考える。
エンタングル演算子空間はリストになっているので、リストの形態をとる新たなデータ型を代数的に定義(代数的データ型Entangle)しよう。要素をつなぐものを:&:とする。また、空のリストをEnZeroとして、次のように定義する。また優先度は5とする。
infixr 5 :&:
data Entangle a b
where
EnZero :: Entangle a b
(:&:) :: (a, b) -> Entangle a b -> Entangle a b
このデータ型を表示するために、Showを定義しておこう。
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
上のプログラムで、空のリストの時はなにも出力しない。リストの要素が一つのときは、それを表す生成演算子を出力する。リストの要素が複数の時は、最初の要素を生成演算子で表し、その後に+をつけて出力する。
少し、プログラムを動かしてみよう。下のプログラムで、aからdまでは、Zeroから始めて、一つづつ状態を重ね合わせて作成したものである。eは、いくつかの状態を一緒に重ね合わせた例である。
*Ket> let a = EnZero
*Ket> a
*Ket> let b = (5.3, 1) :&: a
*Ket> b
5.3_a1^
*Ket> let c = (3.3, 3) :&: b
*Ket> c
3.3_a3^ + 5.3_a1^
*Ket> let d = (1.3, 2) :&: c
*Ket> d
1.3_a2^ + 3.3_a3^ + 5.3_a1^
*Ket> let e = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: EnZero
*Ket> e
2.3_a1^ + 4.2_a-1^ + 2.1_a2^ + 3.2_a0^
一緒に、Eqも定義しよう。但し、これを利用するときは、注意が必要である。1粒子の状態の重ね合わせは、生成演算子のリストになっているが、状態の重ね合わせを表している二つのリストに含まれている要素(生成演算子)が同じであっても、その順番が異なっているときはEqとはならないので、これを利用するときは、リストを昇順に並べてから比較することが要求される。
instance (Eq a, Ord a, Eq b, Ord b) => Eq (Entangle a b) where
Zero == Zero = True
Zero == _ = False
_ == Zero = False
(aa, ab) :&: b == (ca, cb) :&: d = (aa == ca) && (ab == cb) && (b == d)
これを利用してみよう。以下の例で、eとgは並び順まで同じ、状態の重ね合わせである。これに対して、hは並び順は異なるが、先の二つと同じ1粒子の状態の重ね合わせである。実行すると、次のようになる。
*Ket> let e = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: Zero
*Ket> let g = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: Zero
*Ket> let h = (2.1, 2) :&: (4.2, -1) :&: (2.3, 1) :&: (3.2, 0) :&: Zero
*Ket> e == g
True
*Ket> g == h
False
リストを昇順に並べることが必要になったので、その関数も定義しておく。おなじみのソートプログラムなので、簡単に理解してもらえると思うが、生成演算子が表す格子点の場所に基づいて、昇順に並べた。
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
なお、上記のプログラムで、関数(&&&)は二つのリストを結合する。
これを用いて確かめてみよう。
*Ket> let g = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: EnZero
*Ket> let h = (2.1, 2) :&: (4.2, -1) :&: (2.3, 1) :&: (3.2, 0) :&: EnZero
*Ket> esort g
4.2_a-1^ + 3.2_a0^ + 2.3_a1^ + 2.1_a2^
*Ket> esort h
4.2_a-1^ + 3.2_a0^ + 2.3_a1^ + 2.1_a2^
*Ket> esort g == esort h
True
それでは、1粒子の状態の重ね合わせが二つあった時、その加算を定義しよう。加算は(+&)で定義する。状態の重ね合わせをxとyにする。加算は、格子点の場所が同じもの同士で、その係数を加えればよい。そこで、xとyをそれぞれ昇順に並べておいて、それぞれの先頭から、係数と格子点の番号を取り出しては、見比べながら、加算を実行するという処理を繰り返すが、それは次のようになる。
0)加算を行うと、二つの状態の重ね合わせを表す新たのリストを出力するが、これを加算後のリストとし、最初は空のリストとする。
1)格子点の番号が異なるときは、それが小さい方を処理済みとし、出来上がりつつある加算後のリストに付け加える。そして、また、同様のことを繰り返す。2)同じときは、二つを処理済みとし、両方の係数を足し合わせ、それに格子点の番号をつけて、出来上がりつつある加算後のリストに付け加える。そして、同様のことを繰り返す。
2)片方のリストが空になった時は、他方のリストをこれまでに得られている加算後のリストに付け加える。最後に、昇順となっていないので、加算後のリストをソートして出力する。
プログラムは次のようになる。
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)
実行例を示す。
*Ket> let a = EnZero
*Ket> let b = (5.3, 1) :&: a
*Ket> let c = (3.3, 3) :&: b
*Ket> let d = (1.3, 2) :&: c
*Ket> d
1.3_a2^ + 3.3_a3^ + 5.3_a1^
*Ket> let e = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: EnZero
*Ket> e
2.3_a1^ + 4.2_a-1^ + 2.1_a2^ + 3.2_a0^
*Ket> let f = d +& e
*Ket> f
4.2_a-1^ + 3.2_a0^ + 7.6_a1^ + 3.4000000000000004_a2^ + 3.3_a3^
それでは、エンタングル演算子空間での表現をエンタングル状態空間で表すことにしよう。この関数はprEntangleとする。前々回の記事で定義したKetを分かりやすく表示するプログラムprKetを利用すると、とても簡単にプログラミングできる。何とも、簡単だったので、どのようになっているかは、読者の方で解読して欲しい。
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
実行例を示す。
*Ket> let a = EnZero
*Ket> prEntangle a
""
*Ket> let b = (5.3, 1) :&: a
*Ket> prEntangle b
"(5.3)|...0000(0)1000...>"
*Ket> let c = (3.3, 3) :&: b
*Ket> prEntangle c
"(3.3)|...000000(0)001000...> + (5.3)|...0000(0)1000...>"
*Ket> let d = (1.3, 2) :&: c
*Ket> prEntangle d
"(1.3)|...00000(0)01000...> + (3.3)|...000000(0)001000...> + (5.3)|...0000(0)1000...>"
*Ket> d
1.3_a2^ + 3.3_a3^ + 5.3_a1^
*Ket> let e = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: EnZero
*Ket> prEntangle e
"(2.3)|...0000(0)1000...> + (4.2)|...0001(0)000...> + (2.1)|...00000(0)01000...> + (3.2)|...0001000...>"
*Ket> let f = d +& e
*Ket> prEntangle f
"(4.2)|...0001(0)000...> + (3.2)|...0001000...> + (7.6)|...0000(0)1000...> + (3.4000000000000004)|...00000(0)01000...> + (3.3)|...000000(0)001000...>"
さて、最後は正規化だ。それぞれの係数を二乗し、その平方根で、それぞれの係数を割れば求めるものが得られる。プログラムは次のようになる。
normalize :: (Floating a) => Entangle a b -> Entangle a b
normalize EnZero = EnZero
normalize x = normalize' x
where
total = sqrt $ sum x 0
sum :: (Floating a) => Entangle a b -> a -> a
sum EnZero s = s
sum ((xa, xb) :&: y) s = sum y (xa * xa + s)
normalize' EnZero = EnZero
実行例を見ることにしよう。
*Ket> let a = EnZero
*Ket> normalize a
*Ket> prEntangle $ normalize a
""
*Ket> let b = (5.3, 1) :&: a
*Ket> normalize b
1.0_a1^
*Ket> prEntangle $ normalize b
"(1.0)|...0000(0)1000...>"
*Ket> let c = (3.3, 3) :&: b
*Ket> normalize c
0.5285584527450004_a3^ + 0.8488969089540915_a1^
*Ket> prEntangle $ normalize c
"(0.5285584527450004)|...000000(0)001000...> + (0.8488969089540915)|...0000(0)1000...>"
*Ket> let d = (1.3, 2) :&: c
*Ket> normalize d
0.20384791140942493_a2^ + 0.5174600828085402_a3^ + 0.8310722542076554_a1^
*Ket> prEntangle $ normalize d
"(0.20384791140942493)|...00000(0)01000...> + (0.5174600828085402)|...000000(0)001000...> + (0.8310722542076554)|...0000(0)1000...>"
*Ket> let e = (2.3, 1) :&: (4.2, -1) :&: (2.1, 2) :&: (3.2, 0) :&: EnZero
*Ket> normalize e
0.37518843943785457_a1^ + 0.6851267154952128_a-1^ + 0.3425633577476064_a2^ + 0.5220013070439716_a0^
*Ket> prEntangle $ normalize e
"(0.37518843943785457)|...0000(0)1000...> + (0.6851267154952128)|...0001(0)000...> + (0.3425633577476064)|...00000(0)01000...> + (0.5220013070439716)|...0001000...>"
*Ket> let f = d +& e
*Ket> normalize f
0.40397689977733287_a-1^ + 0.3077919236398727_a0^ + 0.7310058186446975_a1^ + 0.32702891886736474_a2^ + 0.3174104212536187_a3^
*Ket> prEntangle $ normalize f
"(0.40397689977733287)|...0001(0)000...> + (0.3077919236398727)|...0001000...> + (0.7310058186446975)|...0000(0)1000...> + (0.32702891886736474)|...00000(0)01000...> + (0.3174104212536187)|...000000(0)001000...>
8.5 プログラム全体
前々回のプログラムと合わせて全体を示すと次のようになる。
{-#LANGUAGE GADTs #-}
module Ket (Ket (Zero, KetZero, (:+:)), (+^), (-^), prKet) where
infixr 5 :+:
data Ket a where
Zero :: Ket a
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)
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 :: (Floating a) => Entangle a b -> Entangle a b
normalize EnZero = EnZero
normalize x = normalize' x
where
total = sqrt $ sum x 0
sum :: (Floating a) => Entangle a b -> a -> a
sum EnZero s = s
sum ((xa, xb) :&: y) s = sum y (xa * xa + s)
normalize' EnZero = EnZero
normalize' ((xa, xb) :&: y) = (xa / total, xb) :&: normalize' y