Quantum Technologies. Lecture 03 Task

{-# OPTIONS_HADDOCK prune, ignore-exports #-}

{------------------------------------------------------------------------------}
{- | Фреймворк для представления примитивов для реализации квантовых алгоритмов.

   Автор:     Душкин Р. В.
   Проект:    Курс «Квантовые технологии» в Телешколе teleschool.me
                                                                              -}
{------------------------------------------------------------------------------}

module QuantumFramework
(
  -- * Типы
  QuantumState(..),
  Qubit(..),
  Vector,
  Matrix,

  -- * Функции
  -- ** Общие сервисные функции
  groups,
  changeElement,

  -- ** Создание квантового состояния
  toPair,
  fromPair,

  -- ** Применение функций к квантовому состоянию
  applyQS,
  predicateQS,
  conjugateQS,

  -- ** Создание кубита
  toList,
  fromLists,
  toPairList,
  fromPairList,
  toVector,
  fromVector,

  -- ** Обработка кубита
  liftQubit,
  entangle,
  conjugateQubit,
  scalarProduct,
  norm,
  normalize,
  measure,
  measureP,

  -- ** Обработка гейтов
  apply
--  ylppa,
--  (|>),
--  (>>>)
)
where

{-[ СЕКЦИЯ ИМПОРТА ]-----------------------------------------------------------}

import Control.Arrow ((&&&))
import Control.Monad (replicateM)
import Data.Complex
import Data.Function (on)
import Data.List (inits, sortBy, transpose)
import Data.Maybe (fromMaybe)
import Data.Ord (comparing)
import Data.Tuple (swap)
import System.Random (Random, randomRIO)

{-[ СИНОНИМЫ ТИПОВ ]-----------------------------------------------------------}

-- | Вектор как наименование для списка.
type Vector a = [a]

-- | Матрица как наименование для списка списков.
type Matrix a = [Vector a]

{-[ АЛГЕБРАИЧЕСКИЕ ТИПЫ ДАННЫХ ]-----------------------------------------------}

-- | Тип, представляющий одно квантовое состояние.
data QuantumState a = QS
                      {
                        amplitude :: Complex a,  -- ^ Амплитуда квантового состояния.
                        label     :: String      -- ^ Метка квантового состояния.
                      }

{-[ ИЗОМОРФНЫЕ ТИПЫ ]----------------------------------------------------------}

-- | Тип, представляющий кубит. Это просто список квантовых состояний.
newtype Qubit a = Qubit [QuantumState a]

{-[ ЭКЗЕМПЛЯРЫ КЛАССОВ ]-------------------------------------------------------}

instance (Eq a, Ord a, Num a, RealFloat a, Show a) => Show (QuantumState a) where
  show (QS a l) = brackets ++ "|" ++ l ++ ">"
    where
      brackets = if realPart a /= 0 && imagPart a /= 0
                   then "(" ++ prettyShowComplex a ++ ")"
                   else prettyShowComplex a

instance (RealFloat a, Show a) => Show (Qubit a) where
  show (Qubit       []) = ""
  show (Qubit     [qs]) = show qs
  show (Qubit (qs:qss)) = show qs ++ " + " ++ show (Qubit qss)

{-[ ОПРЕДЕЛЕНИЕ ПРИОРИТЕТА ]---------------------------------------------------}

-- infixl 6 |>

-- infix 5 >>>

{-[ ФУНКЦИИ ]------------------------------------------------------------------}

-- | Сервисная функция для разбиения заданного списка на подсписки заданной
--   длины.
groups :: Int -> [a] -> [[a]]
groups i s | null s = []
           | otherwise  = let (h, t) = splitAt i s
                          in   h : groups i t

-- | Служебная функция для замены элемента в заданном списке на заданной позиции
--   (счёт начинается с 1) на заданное значение.
changeElement :: [a] -> Int -> a -> [a]
changeElement xs i x = take (i - 1) xs ++
                       [x] ++
                       drop i xs

-- | Служебная функция для преобразования комплексного числа в «приятную»
--   строку.
prettyShowComplex :: (Eq a, Ord a, Num a, RealFrac a, Show a) => Complex a -> String
prettyShowComplex (r :+ 0) = prettyShowNumber r
prettyShowComplex (0 :+ i) | i == 1    = "i"
                           | i == -1   = "-i"
                           | otherwise = prettyShowNumber i ++ "i"
prettyShowComplex (r :+ i) | i == 1    = prettyShowNumber r ++ " + i"
                           | i == -1   = prettyShowNumber r ++ " - i"
                           | i >= 0    = prettyShowNumber r ++ " + " ++ prettyShowNumber i ++ "i"
                           | otherwise = prettyShowNumber r ++ " - " ++ prettyShowNumber (abs i) ++ "i"

-- | Служебная функция, которая преобразует в строку числа (целые и
--   действительные) так, что если у числа нет дробной части, то в строку не
--   выносится никакой дробной части: 2.5 -> "2.5", 2.0 -> "2".
prettyShowNumber :: (RealFrac a, Show a) => a -> String
prettyShowNumber f = if d == 0.0
                       then show n
                       else show f
  where
    (n, d) = properFraction f

-- | Функция для преобразования квантового состояния в пару величин.
toPair :: QuantumState a -> (Complex a, String)
toPair (QS a l) = (a, l)

-- | Функция для создания квантового состояния из пары вида (Амплитуда, Метка).
fromPair :: (Complex a, String) -> QuantumState a
fromPair (a, l) = QS a l

-- | Функция высшего порядка для применения заданной функции к амплитуде
--   заданного квантового состояния.
applyQS :: (Complex a -> Complex a) -> QuantumState a -> QuantumState a
applyQS f (QS a l) = QS (f a) l

-- | Ещё одна функция высшего порядка для применения заданного предиката к
--   амплитуде заданного квантового состояния.
predicateQS :: (Complex a -> Bool) -> QuantumState a -> Bool
predicateQS p (QS a _) = p a

-- | Специализированная функция, которая возвращает комплексно-сопряжённое
--   квантовое состояние для заданного. Является обёрткой над функцией
--   \conjugate\ из модуля \Data.Complex\ и предназначена для упрощения работы с
--   квантовыми состояниями.
conjugateQS :: RealFloat a => QuantumState a -> QuantumState a
conjugateQS = applyQS conjugate

-- | Служебная функция для получения из кубита списка его квантовых состояний
--   (разворачиватель). Хотя, конечно, это можно было сделать при помощи
--   именованного поля.
quantumStates :: Qubit a -> [QuantumState a]
quantumStates (Qubit qs) = qs

-- | Функция для преобразования кубита в вектор (список). На выходе получается
--   просто список амплитуд.
toList :: Qubit a -> [Complex a]
toList = map amplitude . quantumStates

-- | Функция для преобразования кубита в список меток его квантовых состояний.
toLabelList :: Qubit a -> [String]
toLabelList = map label . quantumStates

-- | Функция для создания кубита из двух списков — списка комплексных амплитуд и
--   списка меток. Разработчик сам должен следить за тем, что семантика кубита
--   должна выполняться (например, при полном задействовании всех базисных
--   состояний их количество должно составлять степень двойки).
fromLists :: [Complex a] -> [String] -> Qubit a
fromLists a l = Qubit $ zipWith QS a l

-- | Функция для преобразования кубит в список пар.
toPairList :: Qubit a -> [(Complex a, String)]
toPairList = map toPair . quantumStates

-- | Функция для создания кубита из списка пар — пар комплексных амплитуд и
--   меток. Разработчик сам должен следить за тем, что семантика кубита должна
--   выполняться (например, при полном задействовании всех базисных состояний их
--   количество должно составлять степень двойки).
fromPairList :: [(Complex a, String)] -> Qubit a
fromPairList = Qubit . map fromPair

-- | Функция для преобразования кубита к векторному представлению в стандартном
--   базисе.
toVector :: Num a => Qubit a -> [Complex a]
toVector q = if all (`elem` "01") labels
               then map (fromMaybe (0 :+ 0) . flip lookup qsPairs) basis
               else error "Некорректные метки кубита."
  where
    n       = length $ label $ head $ quantumStates q
    labels  = concatMap label $ quantumStates q
    qsPairs = map (swap . toPair) $ sortBy (comparing label) $ quantumStates q
    basis   = replicateM n "01"

-- | Функция для создания кубита из векторного представления в стандартном
--   базисе.
fromVector :: Int -> [Complex a] -> Qubit a
fromVector n q = fromLists q $ replicateM n "01"

-- | Сервисная функция для «втягивания» заданной функции в кубит и применения её
--   к списку квантовых состояний.
liftQubit :: ([QuantumState a] -> [QuantumState b]) -> Qubit a -> Qubit b
liftQubit f (Qubit qs) = Qubit $ f qs

-- | Функция для связывания двух кубитов в одну систему из нескольких кубитов.
--   По сути, производит тензорное умножение кубитов друг на друга.
entangle :: RealFloat a => Qubit a -> Qubit a -> Qubit a
entangle (Qubit qss1) (Qubit qss2)
  = Qubit $ filter (predicateQS (/= 0)) [QS (((*)  `on` amplitude) qs1 qs2)
                                            (((++) `on` label) qs1 qs2) | qs1 <- qss1,
                                                                          qs2 <- qss2]

-- | Функция для получения комплексно-сопряжённого кубита для заданного.
conjugateQubit :: RealFloat a => Qubit a -> Qubit a
conjugateQubit = liftQubit (map conjugateQS)

-- | Функция для вычисления скалярного (внутреннего) произведения двух заданных
--   кубитов.
scalarProduct :: RealFloat a => Qubit a -> Qubit a -> a
scalarProduct q1 q2 = realPart $
                        sum $
                        ((zipWith (*)) `on` toVector) q1 q2

-- | Функция для получения нормы вектора, представляющего собой кубит (то есть
--   его длину).
norm :: RealFloat a => Qubit a -> a
norm q = sqrt $ scalarProduct q (conjugateQubit q)

-- | Функция для нормализации заданного кубита, то есть для получения из кубита
--   нового, норма (длина) которого равна в точности 1. Это значит, что у
--   результирующего кубита сумма квадратов модулей амплитуд равна 1, и
--   выполняется условие нормированности.
normalize :: RealFloat a => Qubit a -> Qubit a
normalize q = liftQubit (map (applyQS (/ (norm q :+ 0)))) q

-- | Функция для осуществления процесса измерения заданного кубита. В
--   зависимости от распределения амплитуд вероятности выбирает одно из
--   квантовых состояний кубита и возвращает его метку.
measure :: (RealFloat a, Random a) => Qubit a -> IO String
measure q = getRandomElementWithProbabilities $
              sortBy (compare `on` snd) $
              map ((swap . \(a, l) -> (realPart (a * conjugate a), l)) . toPair) $
              quantumStates q

-- | Функция для осуществления процесса частичного измерения заданного кубита. В
--   зависимости от распределения амплитуд вероятности выбирает одно из
--   частичных квантовых состояний, определяемых набором индексов (второй
--   аргумент). Возвращает пару (измеренная метка, оставшиеся квантовые
--   состояния)
measureP :: (RealFloat a, Random a) => Qubit a -> [Int] -> IO (String, Qubit a)
measureP q xs = undefined

-- | Служебная функция для получения случайного элемента из заданного списка с
--   учётом распределения вероятностей. Список должен содержать пары, первым
--   элементом которых являются возвращаемые элементы, а вторым — вероятность.
--   Значения вероятности не обязательно должны быть нормированы.
getRandomElementWithProbabilities :: (Ord b, Num b, Random b) => [(a, b)] -> IO a
getRandomElementWithProbabilities l = (head . goodList) `fmap` randomRIO (0, sumProbs l)
  where
    goodList p = map fst $
                   dropWhile (\(_, p') -> p' < p) $
                   map ((fst . last) &&& sumProbs) $
                   tail $
                   inits l
    sumProbs = sum . map snd

-- | Функция, вычисляющая произведение матрицы на вектор. В итоге получается
--   вектор. Разработчик должен сам следить за корректностью размерностей
--   матрицы и вектора, подаваемых на вход этой фунции.
apply :: Num a => Matrix a -> Vector a -> Vector a
apply m v = map (sum . zipWith (*) v) m

{-[ ЗАДАЧА ]-------------------------------------------------------------------}
{- *****************************************************************************

   Вашей задачей является реализация операторов |> и >>>. Первый применяется для
отправки кубита в гейт, а второй — для отправки кубита в операцию измерения.

   Если что-то не будет получаться, можете подсмотреть внизу, как это  сделано у
меня. Дерзайте.

***************************************************************************** -}

{-

-- | Специальный синоним для функции `apply` из модуля `Gate`, которая меняет
--   порядок аргументов. Эта функция предназначена для прямой записи
--   последовательности применения гейтов к кубитам.
ylppa :: Num a => Vector a -> Matrix a -> Vector a
ylppa = flip apply

-- | Синоним для неудобочитаемой функции `ylppa`.
(|>) :: Num a => Vector a -> Matrix a -> Vector a
(|>) = ylppa

-- | Синоним оператора (\$\) для передачи потока управления в функцию измерения.
(>>>) :: a -> (a -> b) -> b
(>>>) = flip ($)

-}

{-[ КОНЕЦ МОДУЛЯ ]-------------------------------------------------------------}