８．重ね合わせ（続き）
最近、日本の古代史を学び始めた。殆どの時間をこの時代のことを記述した書籍を読む時間にあてているのだが、若いころの様にはすっと頭の中に入ってこない。特に、諱（いみな）や諡号（しごう）にはてこずる。現存する天皇家の初代の天皇は、越の国（こしのくに）から来た継体天皇とされているが、諱は男大迹（ヲホド）である。見かけない漢字が出てきて戸惑う。
その後を継いだ欽明天皇の漢風諡号は、天国排開広庭である。知っている漢字ばかりだが、読み方が全く分からない。なんと、和風諡号では「あめくにおしはらきひろにわ」と読む。
倉本一宏著「蘇我氏―古代豪族の興亡」では、天皇は諡号で記載されている。初出では、漢風と和風の諡号が両方記載されているが、その次からは漢風諡号だけになる。名前が出てくる度毎に、和風諡号で読もうとするため、思い出すのにたくさんの時間がとられ、読むスピードが一挙に落ちる。さらに悪いことに、和風諡号の読み出し回路を駆使していると文脈も忘れてしまう。そのため、何度も何度も同じところを読むということが繰り返される。
それでも、よいこともある。欽明天皇は、蘇我稲目の娘を妃にする。その当時は、通い婚で、男が女の家に通う。そして、通う先に姉妹がいた場合には、そこにも通わなければならない。蘇我稲目には、堅塩媛（きたしひめ）と小姉君（おあねのきみ）の二人の娘がいたので、欽明天皇はこの二人を妃とした。二人の妃の中が平穏でなかったことは容易に想像できる。そのあたりの事情を小説にしたのが、永井路子の「冬の夜、じいの物語」である。この話は短編なので、「裸足の皇女」の中に含まれている。蘇我氏が勢力を広め始めたころの経緯を知っていると思い出話を聞くようにこの短編を楽しく読むことができる。
それでは話を元に戻そう。前回は、量子力学での重ね合わせをブラを用いた線形結合でどのように表現できるかを説明した。さらに、演算子と状態の空間に分け、演算子の空間だけで、重ね合わせを表現できることを説明した。そして、ヒントを与えて、Haskellでの表現を考えてもらった。今回は、Haskellでどのように表したらよいかを説明しよう。
８．４ 重ね合わせを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...>
８．５ プログラム全体
前々回のプログラムと合わせて全体を示すと次のようになる。
{-#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 Bra. It is only used when operating Ket data. 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
