-- | Quantum teleportation example
module Teleport where

import FunQ

-- Example usage:
--
-- >>> dist $ measure =<< teleport =<< hadamard =<< new 0
-- Runs : 100
-- |0>  : 46.0 (46.0 %)
-- |1>  : 54.0 (54.0 %)
--
-- >>> dist exampleTeleport
-- Runs : 100
-- |0>  : 100.0 (100.0 %)
-- |1>  : 0.0 (0.0 %)

-- | The quantum teleportation algorithm
-- 1. create EPR pair (a,b)
-- 2. perform bell measurment on (psi, a)
-- 3. perform corrections on b according to the bell measurement
teleport :: QBit -> QM QBit
teleport :: QBit -> QM QBit
teleport psi :: QBit
psi = do
    QBit
a <- Bit -> QM QBit
new 0
    QBit
b <- Bit -> QM QBit
new 0
    QBit -> QM QBit
hadamard QBit
a
    (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
a,QBit
b)
    (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
psi,QBit
a)
    QBit -> QM QBit
hadamard QBit
psi
    Bit
m_psi <- QBit -> QM Bit
measure QBit
psi
    Bit
m_a <- QBit -> QM Bit
measure QBit
a
    QBit -> QM QBit
pauliX QBit
b QM QBit -> Bit -> QM ()
forall a. QM a -> Bit -> QM ()
`controlbit` Bit
m_a
    QBit -> QM QBit
pauliZ QBit
b QM QBit -> Bit -> QM ()
forall a. QM a -> Bit -> QM ()
`controlbit` Bit
m_psi
    QBit -> QM QBit
forall (m :: * -> *) a. Monad m => a -> m a
return QBit
b

-- | Create a qubit, teleport it, and measure it
exampleTeleport :: QM Bit
exampleTeleport :: QM Bit
exampleTeleport = do
    QBit
q <- Bit -> QM QBit
new 0
    QBit -> QM QBit
hadamard QBit
q
    -- perform manipulations here
    QBit
q' <- QBit -> QM QBit
teleport QBit
q
    -- the resulting distribution should be the same as
    -- for @q@ before the teleportation
    QBit -> QM Bit
measure QBit
q'

correction :: QBit -> (Bit, Bit) -> QM QBit
correction :: QBit -> (Bit, Bit) -> QM QBit
correction q :: QBit
q (x :: Bit
x,y :: Bit
y) = do
    QBit -> QM QBit
pauliX QBit
q QM QBit -> Bit -> QM ()
forall a. QM a -> Bit -> QM ()
`controlbit` Bit
y
    QBit -> QM QBit
pauliZ QBit
q QM QBit -> Bit -> QM ()
forall a. QM a -> Bit -> QM ()
`controlbit` Bit
x
    QBit -> QM QBit
forall (m :: * -> *) a. Monad m => a -> m a
return QBit
q

teleport' :: QBit -> QM QBit
teleport' :: QBit -> QM QBit
teleport' psi :: QBit
psi = do
    (a :: QBit
a,b :: QBit
b) <- (Bit, Bit) -> QM (QBit, QBit)
bell (0,0)
    (Bit, Bit)
m <- (QBit, QBit) -> QM (Bit, Bit)
bellMeasure (QBit
psi,QBit
a)
    QBit -> (Bit, Bit) -> QM QBit
correction QBit
b (Bit, Bit)
m