{-# OPTIONS_HADDOCK not-home        #-}

{-| 
Module      : Gates
Description : Gate library
Stability   : experimental

Module containing unitary gates and their matrix representations.
-}
module Lib.Gates (
    -- * Unitary gates
      pauliX
    , pauliY
    , pauliZ
    , hadamard
    , phase
    , phasePi8
    , cnot
    , identity
    , swap
    , tdagger
    , fredkin
    , toffoli
    , urot
    , crot
    , qft
) where

import Lib.Internal.Gates
    ( applyGate,
      applyParallel,
      ccontrolMatrix,
      changeAt,
      controlMatrix,
      i,
      notAdjacent,
      qftMatrix,
      runGate,
      hmat,
      phasemat,
      pXmat,
      pYmat,
      pZmat,
      idmat ) 
import Lib.QM ( QM, QState(QState), QBit(..), getState, put, get )
import Numeric.LinearAlgebra
    ( Complex(..), (#>), (><), ident, kronecker, Matrix, Linear(scale), C, ident, tr )

-- | CNOT gate
-- 
-- \[ \text{CNOT} = \begin{bmatrix} 
--    1 & 0 & 0 & 0 \\
--    0 & 1 & 0 & 0 \\
--    0 & 0 & 0 & 1 \\ 
--    0 & 0 & 1 & 0 
--  \end{bmatrix}
-- \]
-- 
-- ![cnot](images/cnot.PNG)
cnot :: (QBit, QBit) -> QM (QBit, QBit)
cnot :: (QBit, QBit) -> QM (QBit, QBit)
cnot (c :: QBit
c, t :: QBit
t) = do
  (_, size :: Int
size) <- QM (QState, Int)
getState
  let g :: Matrix C
g = Int -> QBit -> QBit -> Matrix C -> Matrix C
controlMatrix Int
size QBit
c QBit
t Matrix C
pXmat 
  Matrix C -> QM ()
applyGate Matrix C
g
  (QBit, QBit) -> QM (QBit, QBit)
forall (m :: * -> *) a. Monad m => a -> m a
return (QBit
c,QBit
t)

-- toffoli :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
-- toffoli (c1,c2,t) = do
--   (_, size) <- getState
--   let matrixX = (2 >< 2) [ 0, 1, 1, 0 ]
--   let g = ccontrolMatrix size c1 c2 t matrixX
--   applyGate g
--   return (c1,c2,t)

-- | Toffoli gate
--
-- \[ \begin{bmatrix}
--    1 & 0 & 0 & 0 & 0 & 0 & 0 & 0 \\ 
--    0 & 1 & 0 & 0 & 0 & 0 & 0 & 0 \\ 
--    0 & 0 & 1 & 0 & 0 & 0 & 0 & 0 \\ 
--    0 & 0 & 0 & 1 & 0 & 0 & 0 & 0 \\ 
--    0 & 0 & 0 & 0 & 1 & 0 & 0 & 0 \\ 
--    0 & 0 & 0 & 0 & 0 & 1 & 0 & 0 \\ 
--    0 & 0 & 0 & 0 & 0 & 0 & 0 & 1 \\ 
--    0 & 0 & 0 & 0 & 0 & 0 & 1 & 0
-- \end{bmatrix} \]
--
--  ![toffoli](images/toffoli.PNG)
toffoli :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
toffoli :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
toffoli (c1 :: QBit
c1,c2 :: QBit
c2,t :: QBit
t) = do
  (_, size :: Int
size) <- QM (QState, Int)
getState
  let g :: Matrix C
g = Int -> QBit -> QBit -> QBit -> Matrix C -> Matrix C
ccontrolMatrix Int
size QBit
c1 QBit
c2 QBit
t Matrix C
pXmat 
  Matrix C -> QM ()
applyGate Matrix C
g
  (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
forall (m :: * -> *) a. Monad m => a -> m a
return (QBit
c1,QBit
c2,QBit
t)

-- | Pauli-X gate
--
-- \[ \text{X} = \begin{bmatrix}
--    0 & 1 \\
--    1 & 0
-- \end{bmatrix} \]
--
-- ![pauliX](images/x.PNG)
pauliX :: QBit -> QM QBit
pauliX :: QBit -> QM QBit
pauliX = Matrix C -> QBit -> QM QBit
runGate Matrix C
pXmat

-- | Pauli-Y gate
--
-- \[ \text{Y} = \begin{bmatrix}
--    0 & -i \\
--    i & 0
-- \end{bmatrix} \]
--
-- ![pauliY](images/y.PNG)
pauliY :: QBit -> QM QBit
pauliY :: QBit -> QM QBit
pauliY = Matrix C -> QBit -> QM QBit
runGate Matrix C
pYmat 

-- | Pauli-Z gate
--
-- \[ \text{Z} = \begin{bmatrix}
--    1 & 0 \\
--    0 & -1
-- \end{bmatrix} \]
--
-- ![pauliZ](images/z.PNG)
pauliZ :: QBit -> QM QBit
pauliZ :: QBit -> QM QBit
pauliZ = Matrix C -> QBit -> QM QBit
runGate Matrix C
pZmat 

-- | Hadamard gate
-- 
-- \[ \text{X} = \frac1{\sqrt2} \begin{bmatrix}
--    0 & 1 \\
--    1 & 0
-- \end{bmatrix} \]
--
-- ![hadamard](images/h.PNG)
hadamard :: QBit -> QM QBit
hadamard :: QBit -> QM QBit
hadamard = Matrix C -> QBit -> QM QBit
runGate Matrix C
hmat

-- | Phase gate
--
-- \[ \text{S} = \begin{bmatrix}
--    1 & 0 \\
--    0 & i
-- \end{bmatrix} \]
--
-- ![phase](images/s.PNG)
phase :: QBit -> QM QBit
phase :: QBit -> QM QBit
phase = Matrix C -> QBit -> QM QBit
runGate (Matrix C -> QBit -> QM QBit) -> Matrix C -> QBit -> QM QBit
forall a b. (a -> b) -> a -> b
$ Double -> Matrix C
phasemat Double
forall a. Floating a => a
piMatrix C -> Matrix C -> Matrix C
forall a. Fractional a => a -> a -> a
/2

-- | Pi/8 gate (T gate)
--
-- \[ \text{T} = \begin{bmatrix}
--    1 & 0 \\
--    0 & e^{i\pi/4}
-- \end{bmatrix} \]
--
-- ![pi8](images/t.PNG)
phasePi8 :: QBit -> QM QBit
phasePi8 :: QBit -> QM QBit
phasePi8 = Matrix C -> QBit -> QM QBit
runGate (Matrix C -> QBit -> QM QBit) -> Matrix C -> QBit -> QM QBit
forall a b. (a -> b) -> a -> b
$ Double -> Matrix C
phasemat Double
forall a. Floating a => a
piMatrix C -> Matrix C -> Matrix C
forall a. Fractional a => a -> a -> a
/4

-- | Hermetian adjoint of T gate (`phasePi8`)
tdagger :: QBit -> QM QBit
tdagger :: QBit -> QM QBit
tdagger = Matrix C -> QBit -> QM QBit
runGate (Matrix C -> QBit -> QM QBit) -> Matrix C -> QBit -> QM QBit
forall a b. (a -> b) -> a -> b
$ Double -> Matrix C
phasemat (-Double
forall a. Floating a => a
piDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/4)

-- | Identity gate
--
-- \[ \text{I} = \begin{bmatrix}
--    1 & 0 \\
--    0 & 1
-- \end{bmatrix} \]
--
identity :: QBit -> QM QBit
identity :: QBit -> QM QBit
identity = Matrix C -> QBit -> QM QBit
runGate Matrix C
idmat

-- | SWAP gate
-- 
-- \[ \text{SWAP} = \begin{bmatrix} 
--    1 & 0 & 0 & 0 \\
--    0 & 0 & 1 & 0 \\
--    0 & 1 & 0 & 0 \\ 
--    0 & 0 & 0 & 1 
--  \end{bmatrix}
-- \]
-- 
-- ![swap](images/swap.PNG)
swap :: (QBit, QBit) -> QM (QBit, QBit)
swap :: (QBit, QBit) -> QM (QBit, QBit)
swap (p :: QBit
p,q :: QBit
q) = do
  (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
p,QBit
q)
  (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
q,QBit
p)
  (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
p,QBit
q)

-- | Fredkin gate
fredkin :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
fredkin :: (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
fredkin (c :: QBit
c,p :: QBit
p,q :: QBit
q) = do
  (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
q,QBit
p)
  (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
toffoli (QBit
c,QBit
p,QBit
q)
  (QBit, QBit) -> QM (QBit, QBit)
cnot (QBit
q,QBit
p)
  (QBit, QBit, QBit) -> QM (QBit, QBit, QBit)
forall (m :: * -> *) a. Monad m => a -> m a
return (QBit
c,QBit
p,QBit
q)

-- | UROT gate
urot :: Int -> QBit -> QM QBit
urot :: Int -> QBit -> QM QBit
urot k :: Int
k = Matrix C -> QBit -> QM QBit
runGate (Matrix C -> QBit -> QM QBit) -> Matrix C -> QBit -> QM QBit
forall a b. (a -> b) -> a -> b
$ (2 Int -> Int -> [C] -> Matrix C
forall a. Storable a => Int -> Int -> [a] -> Matrix a
>< 2)
  [ 1, 0,
    0, C
p ]
  where p :: C
p = C -> C
forall a. Floating a => a -> a
exp ((2C -> C -> C
forall a. Num a => a -> a -> a
*C
forall a. Floating a => a
piC -> C -> C
forall a. Num a => a -> a -> a
*C
i) C -> C -> C
forall a. Fractional a => a -> a -> a
/ (2C -> Int -> C
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k))

-- | Controlled UROT
crot :: Int -> (QBit, QBit) -> QM (QBit, QBit)
crot :: Int -> (QBit, QBit) -> QM (QBit, QBit)
crot k :: Int
k (c :: QBit
c, t :: QBit
t) = do
  (_, size :: Int
size) <- QM (QState, Int)
getState
  let p :: C
p = C -> C
forall a. Floating a => a -> a
exp ((2C -> C -> C
forall a. Num a => a -> a -> a
*C
forall a. Floating a => a
piC -> C -> C
forall a. Num a => a -> a -> a
*C
i) C -> C -> C
forall a. Fractional a => a -> a -> a
/ (2C -> Int -> C
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k))
  let matrixRot :: Matrix C
matrixRot = (2 Int -> Int -> [C] -> Matrix C
forall a. Storable a => Int -> Int -> [a] -> Matrix a
>< 2) [ 1, 0, 0, C
p ]
  let g :: Matrix C
g = Int -> QBit -> QBit -> Matrix C -> Matrix C
controlMatrix Int
size QBit
c QBit
t Matrix C
matrixRot
  Matrix C -> QM ()
applyGate Matrix C
g
  (QBit, QBit) -> QM (QBit, QBit)
forall (m :: * -> *) a. Monad m => a -> m a
return (QBit
c,QBit
t)

-- | Quantum fourier transform
qft :: [QBit] -> QM [QBit]
qft :: [QBit] -> QM [QBit]
qft [] = [Char] -> QM [QBit]
forall a. [Char] -> a
errorWithoutStackTrace "Cannot perform QFT on zero qubits"
qft qs :: [QBit]
qs@((Ptr q :: Int
q):_)
  | [Int] -> Bool
notAdjacent ((QBit -> Int) -> [QBit] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map QBit -> Int
link [QBit]
qs) =
     [Char] -> QM [QBit]
forall a. [Char] -> a
errorWithoutStackTrace "Cannot perform QFT on non-adjacent qubits"
  | Bool
otherwise = do
      (_, size :: Int
size) <- QM (QState, Int)
getState
      let n :: Int
n = [QBit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [QBit]
qs
      let matrixQFT :: Matrix C
matrixQFT = Int -> Matrix C
qftMatrix (2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n)
      let ids :: [Matrix C]
ids = Int -> Matrix C -> [Matrix C]
forall a. Int -> a -> [a]
replicate (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> Matrix C
forall a. (Num a, Element a) => Int -> Matrix a
ident 2)
      let masqwe :: [Matrix C]
masqwe = Matrix C -> Int -> [Matrix C] -> [Matrix C]
forall a. a -> Int -> [a] -> [a]
changeAt Matrix C
matrixQFT Int
q [Matrix C]
ids
      Matrix C -> QM ()
applyGate (Matrix C -> QM ()) -> Matrix C -> QM ()
forall a b. (a -> b) -> a -> b
$ (Matrix C -> Matrix C -> Matrix C) -> [Matrix C] -> Matrix C
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Matrix C -> Matrix C -> Matrix C
applyParallel [Matrix C]
masqwe
      [QBit] -> QM [QBit]
forall (m :: * -> *) a. Monad m => a -> m a
return [QBit]
qs

-- | Inverse quantum fourier transform
qftDagger :: [QBit] -> QM [QBit]
qftDagger :: [QBit] -> QM [QBit]
qftDagger [] = [Char] -> QM [QBit]
forall a. [Char] -> a
errorWithoutStackTrace "Cannot perform QFT on zero qubits"
qftDagger qs :: [QBit]
qs@((Ptr q :: Int
q):_)
  | [Int] -> Bool
notAdjacent ((QBit -> Int) -> [QBit] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map QBit -> Int
link [QBit]
qs) =
     [Char] -> QM [QBit]
forall a. [Char] -> a
errorWithoutStackTrace "Cannot perform QFT on non-adjacent qubits"
  | Bool
otherwise = do
      (_, size :: Int
size) <- QM (QState, Int)
getState
      let n :: Int
n = [QBit] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [QBit]
qs
      let matrixQFT :: Matrix C
matrixQFT = Matrix C -> Matrix C
forall m mt. Transposable m mt => m -> mt
tr (Matrix C -> Matrix C) -> Matrix C -> Matrix C
forall a b. (a -> b) -> a -> b
$ Int -> Matrix C
qftMatrix (2 Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
n)
      let ids :: [Matrix C]
ids = Int -> Matrix C -> [Matrix C]
forall a. Int -> a -> [a]
replicate (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) (Int -> Matrix C
forall a. (Num a, Element a) => Int -> Matrix a
ident 2)
      let masqwe :: [Matrix C]
masqwe = Matrix C -> Int -> [Matrix C] -> [Matrix C]
forall a. a -> Int -> [a] -> [a]
changeAt Matrix C
matrixQFT Int
q [Matrix C]
ids
      Matrix C -> QM ()
applyGate (Matrix C -> QM ()) -> Matrix C -> QM ()
forall a b. (a -> b) -> a -> b
$ (Matrix C -> Matrix C -> Matrix C) -> [Matrix C] -> Matrix C
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Matrix C -> Matrix C -> Matrix C
applyParallel [Matrix C]
masqwe
      [QBit] -> QM [QBit]
forall (m :: * -> *) a. Monad m => a -> m a
return [QBit]
qs