QIO 1.0 → 1.1
raw patch · 14 files changed
+382/−132 lines, 14 filesdep −haskell98dep ~basedep ~containersdep ~mtl
Dependencies removed: haskell98
Dependency ranges changed: base, containers, mtl, old-time, random
Files
- LICENSE +1/−1
- QIO.cabal +4/−2
- QIO/Heap.hs +14/−1
- QIO/QArith.hs +50/−13
- QIO/QExamples.hs +47/−2
- QIO/QIORandom.hs +50/−33
- QIO/Qdata.hs +16/−3
- QIO/Qft.hs +11/−24
- QIO/Qio.hs +54/−10
- QIO/QioClass.hs +19/−2
- QIO/QioSyn.hs +41/−21
- QIO/Shor.hs +26/−9
- QIO/Vec.hs +12/−1
- QIO/VecEq.hs +37/−10
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2010, Alexander S. Green+Copyright (c) 2010-2012, Alexander S. Green All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
QIO.cabal view
@@ -1,17 +1,19 @@ Name: QIO-Version: 1.0+Version: 1.1 Cabal-Version: >= 1.2 License: BSD3 License-File: LICENSE Author: Alexander S. Green+Maintainer: alexander.s.green@gmail.com Homepage: http://www.cs.nott.ac.uk/~asg/QIO/ Category: Quantum Synopsis: The Quantum IO Monad is a library for defining quantum computations in Haskell+Description: The Quantum IO Monad is a library for defining quantum computations in Haskell. It can be thought of as an embedded language within Haskell, and comes with functions for simulating the running of these quantum computations. The distribution contains many example computations written in QIO, including an implementation of Shor's algorithm. Build-Type: Simple Library Build-Depends: - base >= 4 && < 5, containers, haskell98, mtl, random, old-time+ base >= 4 && < 5, containers, mtl, random, old-time Exposed-modules: QIO.Heap, QIO.QArith, QIO.QExamples, QIO.QIORandom, QIO.Qdata, QIO.Qft, QIO.Qio, QIO.QioClass, QIO.QioSyn, QIO.Shor, QIO.Vec, QIO.VecEq
QIO/Heap.hs view
@@ -1,20 +1,33 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +-- | This module contains the definition of a Type Class that represents a Heap.+-- In the context of QIO, a Heap is the type used to represent a classical +-- basis state. An instance of a Heap is also defined, that makes use of a Map. module QIO.Heap where import qualified Data.Map as Map import Data.Maybe as Maybe import QIO.QioSyn +-- | The Heap Type Class class Eq h => Heap h where+ -- | define an 'initial' (i.e. empty) Heap initial :: h+ -- | 'update' the value of a Qubit within the Heap to the given Boolen value update :: h -> Qbit -> Bool -> h+ -- | Lookup the value of the given Qubit in the Heap (if it exists) (?) :: h -> Qbit -> Maybe Bool+ -- | remove the given Qubit from the Heap forget :: h -> Qbit -> h+ -- | Swap the values associated with two Qubits within the Heap hswap :: h -> Qbit -> Qbit -> h hswap h x y = update (update h y (fromJust (h ? x))) x (fromJust (h ? y)) ++-- | HeapMap is simply a type synonym for a Map from Qubits to Boolean values type HeapMap = Map.Map Qbit Bool +-- | A HeapMap is an instance of the Heap type class, where the Heap functions+-- can make use of the underlying Map functions. instance Heap HeapMap where initial = Map.empty update h q b = Map.insert q b h
QIO/QArith.hs view
@@ -1,5 +1,7 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- | This module contains QIO unitaries that represent various Arithmetic +-- functions. These are exactly the Arithmetic functions required to implement +-- Shor's algorithm. module QIO.QArith where import Data.Monoid as Monoid@@ -9,25 +11,35 @@ import QIO.Qio import QIO.QExamples +-- | A swap operation can be applied to two QInts, by mapping qubit swap operations+-- over the underlying qubits that make up a QInt. swapQInt :: QInt -> QInt -> U swapQInt (QInt xs) (QInt ys) = swapQInt' xs ys where swapQInt' [] [] = mempty swapQInt' (x:xs) (y:ys) = (swap x y) `mappend` swapQInt' xs ys +-- | ifElseQ defines a quantum If statement, whereby depending on the state of+-- the given (control) qubit, one of two unitaries are applied. ifElseQ :: Qbit -> U -> U -> U ifElseQ qa t f = cond qa (\ qa -> if qa then t else f) +-- | ifQ defines a special case of ifElseQ, where the Else part of the computation+-- is simply the identity. ifQ :: Qbit -> U -> U ifQ qa t = ifElseQ qa t mempty +-- | A controlled-not operations, that applies a Not to the second qubit, +-- depending on the state of the first qubit. cnot :: Qbit -> Qbit -> U cnot qa qb = ifQ qa (unot qb) +-- | A three-qubit adder. addBit :: Qbit -> Qbit -> Qbit -> U addBit qc qa qb = cnot qa qb `mappend` cnot qc qb +-- | Calculates the carry (qu)bit. carry :: Qbit -> Qbit -> Qbit -> Qbit -> U carry qci qa qb qcsi = cond qci (\ ci ->@@ -37,6 +49,9 @@ then unot qcsi else mempty))) +-- | uses the 'addBit' and 'carry' unitaries to add the contents of two quantum+-- registers, setting an overflow bit if necessary. This unitary makes use of a+-- letU construct to introduce ancilla bits as necessary. addBits :: [Qbit] -> [Qbit] -> Qbit -> U addBits qas qbs qc' = letU False (addBits' qas qbs)@@ -47,6 +62,8 @@ urev (carry qc qa qb qc')) `mappend` addBit qc qa qb +-- | An alternate implementation of 'addBits' that is explicitly given+-- a register of ancilla qubits for all the intermediate 'carry' results. addBits' :: [Qbit] -> [Qbit] -> [Qbit] -> Qbit -> U addBits' [] [] [] qc = mempty addBits' (qa:qas) (qb:qbs) (qc':qcs') qc =@@ -55,21 +72,27 @@ urev (carry qc qa qb qc')) `mappend` addBit qc qa qb +-- | Defines the QIO unitary that adds two QInts, with an overflow qubit adder :: QInt -> QInt -> Qbit -> U adder (QInt qas) (QInt qbs) qc = addBits qas qbs qc +-- | A small function to test the adder unitary tadder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) tadder xyc = do q @ (qx,(qy,qc)) <- mkQ xyc applyU (adder qx qy qc) xyc <- measQ q return xyc +-- | A small function to test applying the adder unitary in reverse, ie.+-- this defines subtraction. tRadder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) tRadder xyc = do q @ (qx,(qy,qc)) <- mkQ xyc applyU (urev (adder qx qy qc)) xyc <- measQ q return xyc +-- | A small function to test applying the adder unitary, and then applying+-- the reverse of the adder unitary, which should give the identity function. tBiAdder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) tBiAdder xyc = do q @ (qx,(qy,qc)) <- mkQ xyc applyU (adder qx qy qc)@@ -77,6 +100,8 @@ xyc <- measQ q return xyc +-- | This unitary is for modular addition, and is done modulo some fixed+-- classical modulus, given as the first Int argument. adderMod :: Int -> QInt -> QInt -> U adderMod n qa qb = letU n (\ qn ->@@ -98,19 +123,25 @@ `mappend` -- z = False adder qa qb qc))) -- b = a+b mod N, c=False, z=False +-- | A small function to test the modular addition unitary. tadderMod :: Int -> (Int,Int) -> QIO (Int,Int) tadderMod n ab = do q @ (qa,qb) <- mkQ ab applyU (adderMod n qa qb) ab <- measQ q return ab +-- | This unitary defines modular multiplication, whereby the integer 'n' is the+-- the modulus, and the integer 'a' is the scalar by which to multiply the quantum+-- integer 'x'. The result is added to the quantum integer 'y', ie. if 'y' is in +-- state 0 before the operation, then it is left in the sate a*x mod n. multMod :: Int -> Int -> QInt -> QInt -> U multMod n a (QInt x) y = multMod' n a x y 1 where multMod' _ _ [] _ _ = mempty multMod' n a (x:xs) y p = cond x (\x -> (if x then (letU ((p*a) `mod` n) (\ qa -> (adderMod n qa y)) `mappend` (multMod' n a xs y (p*2))) else multMod' n a xs y (p*2))) --- output is a*x mod n+-- | A small function for testing the modular multiplication unitary. This function+-- initialises 'y' as zero, so the output is as expected. tmultMod :: Int -> Int -> Int -> QIO (Int,Int) tmultMod n a x = do y <- mkQ 0 x' <- mkQ x@@ -119,24 +150,26 @@ qx <- measQ x' return (qx,qy) +-- | A unitary that adds a single qubit control to modular multiplication condMultMod :: Qbit -> Int -> Int -> QInt -> QInt -> U condMultMod q n a x y = ifQ q (multMod n a x y) ------------------------------------------------------------------------------ +-- | A classical Haskell function that returns the smalles positive inverse+-- of \a\ `mod \n\ (if one exists). That is, the smallest positive integer+-- \x\, such that \x\*\a\ `mod` \n\ equals 1. inverseMod :: Int -> Int -> Int-inverseMod n a = inverseMod'' n a (inverseMod' n a)--inverseMod' :: Int -> Int -> [Int]-inverseMod' n a = [x | x <- [1..n], ((x*a) `mod` n) == 1]---inverseMod'' :: Int -> Int -> [Int] -> Int-inverseMod'' n a [] = error ("inverseMod: no inverse of "++(show a)++" mod "++(show n)++ " found")-inverseMod'' _ _ xs = head xs+inverseMod n a = case imods of+ [] -> error ("inverseMod: no inverse of "++(show a)++" mod "++(show n)++ " found")+ (x:_) -> x+ where+ imods = [x | x <- [1..n], ((x*a) `mod` n) == 1] ------------------------------------------------------------------------------- +-- | The unitary that represents modular exponentiation is constructed in terms+-- of multiple \"steps\". This function defines those steps. modExpStep :: Qbit -> Int -> Int -> QInt -> Int -> U modExpStep qc n a o p = letU 0 (\z -> (condMultMod qc n p' o z) `mappend` (ifQ qc (swapQInt o z))@@ -144,6 +177,7 @@ where p' | (a^(2^p)) == 0 = error "modExpStep: arguments too large" | otherwise = (a^(2^p)) `mod` n +-- | A QIO computation that forms a test of the 'modExpStep' unitary modExpStept :: Int -> Int -> Int -> Int -> QIO Int modExpStept i n a p = do q <- mkQ True one <- mkQ i@@ -151,14 +185,17 @@ r <- measQ one return r +-- | This function defines a unitary that implements modular exponentiation, as+-- required in Shor's algorithm. Given classical arguments \n\ and \a\, a quantum+-- register containg \x\, and a quantum register \o\ in state 1, this unitary will +-- leave the quantum register \o\ in the state \a\^\x\ mod \n\. modExp :: Int -> Int -> QInt -> QInt -> U modExp n a (QInt x) o = modExp' n a x o 0 where modExp' _ _ [] _ _ = mempty modExp' n a (x:xs) o p = modExpStep x n a o p `mappend` (modExp' n a xs o (p+1)) ---a^x mod N-+-- | A QIO computation that forms a test of the modular exponentiation unitary. modExpt :: Int -> (Int,Int) -> QIO Int modExpt n (a,x) = do qx <- mkQ x one <- mkQ 1
QIO/QExamples.hs view
@@ -1,3 +1,6 @@++-- | This module contains some simple examples of quantum computations written+-- using the Quantum IO Monad. module QIO.QExamples where import Data.Monoid as Monoid@@ -6,50 +9,71 @@ import QIO.QioClass import QIO.Qio -+-- | Initialise a qubit in the |0> state q0 :: QIO Qbit q0 = mkQ False +-- | Initialise a qubit in the |1> state q1 :: QIO Qbit q1 = mkQ True- ++-- | Initialise a qubit in the |+> state. This is done by applying a Hadamard+-- gate to the |0> state. qPlus :: QIO Qbit qPlus = do qa <- q0 applyU (uhad qa) return qa +-- | Initialise a qubit in the |-> state. This is done by applying a Hadamard+-- gate to the |1> state. qMinus :: QIO Qbit qMinus = do qa <- q1 applyU (uhad qa) return qa +-- | Create a random Boolean value, by measuring the state |+> randBit :: QIO Bool randBit = do qa <- qPlus x <- measQbit qa return x +-- | This function can be used to "share" the state of one qubit, with another+-- newly initialised qubit. This is not the same as "cloning", as the two qubits+-- will be in an entangled state. "sharing" is achieved by simply initialising+-- a new qubit in state |0>, and then applying a controlled-not to that qubit, +-- depending on the state of the given qubit. share :: Qbit -> QIO Qbit share qa = do qb <- q0 applyU (cond qa (\a -> if a then (unot qb) else (mempty) ) ) return qb +-- | A Bell state can be created by sharing the |+> state bell :: QIO (Qbit, Qbit) bell = do qa <- qPlus qb <- share qa return (qa,qb) +-- | This function creates a Bell state, and then measures it. The resulting pair+-- of Booleans will always be in the same state as one another. test_bell :: QIO (Bool,Bool) test_bell = do qb <- bell b <- measQ qb return b +-- | This function initiaslised a qubit in the state corresponding to the given+-- Boolean value. The Hadamard transform (which is self-inverse) is applied to+-- the qubit twice, and then the qubit is measured. This should correspond to+-- the identity function on the given Boolean value. hadTwice :: Bool -> QIO Bool hadTwice x = do q <- mkQ x applyU (uhad q `mappend` uhad q) b <- measQ q return b +-- | A different implementation of 'hadTwice' where QIO is used to apply two+-- unitaries, each of which is a single Hadamard gate, as opposed to a single+-- unitary, which is two Hadamard gates. hadTwice' :: Bool -> QIO Bool hadTwice' x = do q <- mkQ x applyU (uhad q)@@ -61,6 +85,8 @@ ---- Teleportation --------------------------- ---------------------------------------------- +-- | The operations that Alice must perform in the classic quantum teleportation+-- example. alice :: Qbit -> Qbit -> QIO (Bool,Bool) alice aq eq = do applyU (cond aq (\a -> if a then (unot eq) else (mempty) ) )@@ -68,9 +94,12 @@ cd <- measQ (aq,eq) return cd +-- | A definition of the Pauli-Z gate. uZZ :: Qbit -> U uZZ qb = (uphase qb pi) +-- | The unitary operations that Bob must perform in the classic quantum+-- teleportation example. bobsU :: (Bool,Bool) -> Qbit -> U bobsU (False,False) eq = mempty bobsU (False,True) eq = (unot eq)@@ -78,37 +107,46 @@ bobsU (True,True) eq = ((unot eq) `mappend` (uZZ eq)) +-- | The overall operations that Bob must perform in the classic quantum+-- teleportation example bob :: Qbit -> (Bool,Bool) -> QIO Qbit bob eq cd = do applyU (bobsU cd eq) return eq +-- | The overall QIO computation that teleports the state of single qubit teleportation :: Qbit -> QIO Qbit teleportation iq = do (eq1,eq2) <- bell cd <- alice iq eq1 tq <- bob eq2 cd return tq +-- | A small test function of quantum teleportation, which teleports a+-- bell state, and then measures it. test_teleport :: QIO (Bool,Bool) test_teleport = do (q1,q2) <- bell tq2 <- teleportation q2 result <- measQ (q1,tq2) return result +-- | teleports a qubit in the state |1> teleport_true' :: QIO Qbit teleport_true' = do q <- q1 tq <- teleportation q return tq +-- | teleports a qubit in the state |1>, and then measures it teleport_true :: QIO Bool teleport_true = do q <- teleport_true' result <- measQ q return result +-- | teleports a qubit in the state |+> teleport_random' :: QIO Qbit teleport_random' = do q <- qPlus tq <- teleportation q return tq +-- | teleports a qubit in the state |+>, and then measures it. teleport_random :: QIO Bool teleport_random = do q <- teleport_random' result <- measQ q@@ -118,9 +156,13 @@ ----- Deutsch's Algorithm --------------------- ----------------------------------------------- +-- | The implementation of Deutsch's algorithm requires a unitary to represent+-- the "oracle" function. u :: (Bool -> Bool) -> Qbit -> Qbit -> U u f x y = cond x (\ b -> if f b then unot y else mempty) +-- | Deutsch's algorithm takes an "oracle" function, and returns a Boolean+-- that states whether the given function is balanced, or consant. deutsch :: (Bool -> Bool) -> QIO Bool deutsch f = do x <- qPlus@@ -131,6 +173,9 @@ ----------------------------------------------- +-- | A test QIO computation that is infinite in one measurement path. This is+-- a problem if we try to calculate the probability distribution of possible+-- results, as the infinite path will be followed. problem :: QIO Bool problem = do q <- qPlus x <- measQ q
QIO/QIORandom.hs view
@@ -1,111 +1,128 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- | This module implements various functions that return a probabilistic result, +-- defined as unitary operators, and quantum computations. module QIO.QIORandom where import Data.Monoid as Monoid import QIO.QioSyn import QIO.Qdata import QIO.Qio-import Complex---- complex numbers-type CC = Complex RR+import Data.Complex +-- | The exponentiated Pauli-X rotation rX :: RR -> Rotation rX r (x,y) = if x==y then (cos (r/2):+0) else (0:+ (-(sin (r/2)))) +-- | The exponentiated Pauli-Y rotation rY :: RR -> Rotation rY r (x,y) = if x==y then (cos (r/2):+0) else (s * sin (r/2):+0) where s = if x then 1 else -1 +-- | Applies a Hadamard rotation to each qubit in the given list of qubits hadamards :: [Qbit] -> U hadamards [] = mempty hadamards (q:qs) = uhad q `mappend` hadamards qs +-- | returns the highest integer power of 2 that is less than or equal to \x\ pow2 :: Int -> Int-pow2 x = pow2' x 0--pow2' :: Int -> Int -> Int-pow2' x y | 2^(y+1) > x = 2^y- | otherwise = pow2' x (y+1)+pow2 x = pow2' 0+ where pow2' y | 2^(y+1) > x = 2^y+ | otherwise = pow2' (y+1) +-- | A rotation that, given a qubit in state 0, leaves it in a super-position of+-- 0 and 1, such that the probability of measuring as state 0 is \ps\. weightedU :: RR -> Qbit -> U weightedU ps q | sqrt ps <= 1 = rot q (rX (2*(acos (sqrt ps)))) | otherwise = error ("weightedU: Invalid Probability: " ++ show ps) -+-- | A QIO computation that uses the "weightedU" unitary, to return a Bool that+-- has a probablity of \pf\ of being False. weightedBool :: RR -> QIO Bool weightedBool pf = do q <- mkQbit False applyU (weightedU pf q) measQ q +-- | removes any leading Falses from a list of booleans rlf :: [Bool] -> [Bool] rlf (False:bs) = rlf bs rlf bs = bs +-- | removes any leading Falses from the (big-endian) bit-wise representation+-- of the given Int. rlf_l :: Int -> [Bool] rlf_l x = rlf (reverse (int2bits x)) +-- | returns the number of bits left after calling the "flf_l" function rlf_n :: Int -> Int rlf_n x = length (rlf_l x) +-- | Given an Int \max\ that is the largest number required to be represented in+-- a quantum register, this function trims the front off the given register, to+-- leave the number of qubits required to represent \max\. trim :: Int -> [Qbit] -> [Qbit]-trim x qbs = drop ((length qbs)-(rlf_n x)) qbs+trim max qbs = drop ((length qbs)-(rlf_n max)) qbs +-- | Given an Int \max\, and a quantum register in the state \max\, this function +-- defines a unitary operation that will leave the quantum register in state that+-- has equal probability of being measured in any of the states 0 to \max\. randomU :: Int -> [Qbit] -> U randomU max qbs = randomU' max (trim max qbs)--randomU' :: Int -> [Qbit] -> U-randomU' _ [] = mempty-randomU' 0 _ = mempty-randomU' max (q:qbs) = weightedU (fromIntegral ((max+1)-p)/fromIntegral (max+1)) q- `mappend`- condQ q (\x -> if x then (randomU (max-p) qbs) - else (hadamards qbs))- where p = pow2 max+ where+ randomU' _ [] = mempty+ randomU' 0 _ = mempty+ randomU' max (q:qbs) = weightedU (fromIntegral ((max+1)-p)/fromIntegral (max+1)) q+ `mappend`+ condQ q (\x -> if x then (randomU (max-p) qbs) + else (hadamards qbs))+ where p = pow2 max +-- | A quantum computation that will return a quantum integer in a state that+-- has equal probabilities of being measured in any of the state 0 to \max\. randomQInt :: Int -> QIO QInt randomQInt max = do qbs <- mkQ (reverse (int2bits max)) applyU (randomU max qbs) return (QInt (reverse qbs)) +-- | A quantum computation that will return a quantum integer in a state that+-- has equal probabilities of being measured in any of the state \min\ to \max\. randomQIO :: (Int,Int) -> QIO Int randomQIO (min,max) = do q <- randomInt (max-min) return (q + min) +-- | A quantum computation that measures the outcome of "randomQInt" randomInt :: Int -> QIO Int randomInt max = do q <- randomQInt max measQ q +-- | A quantum computation that returns an integer that is equally likely to be+-- any number in the range 0 to \x\-1 random :: Int -> QIO Int random x = randomInt (x-1) - +-- | This function uses a Quantum computation to simulate the roll of a dice dice :: IO Int dice = do x <- run (randomInt 5) return (x+1) --inf_dice :: IO [Int]-inf_dice = do x <- dice- y <- inf_dice- return (x:y)-+-- | This function simulates the given number of repitions of dice rolls dice_rolls :: Int -> IO [Int] dice_rolls 0 = return [] dice_rolls y = do x <- dice xs <- dice_rolls (y-1) return (x:xs) -+-- | Returns the number of occurences of 1 through 6 in the given list of Ints occs :: [Int] -> (Int,Int,Int,Int,Int,Int)-occs rs = (rs' rs 1,rs' rs 2,rs' rs 3,rs' rs 4,rs' rs 5,rs' rs 6)--rs' :: [Int] -> Int -> Int-rs' rs x = length ([y|y<-rs,y==x])+occs rs = (rs' 1,rs' 2,rs' 3,rs' 4,rs' 5,rs' 6)+ where + rs' x = length ([y|y<-rs,y==x]) +-- | Returns the number of occurences of 1 through 6 in the given number of+-- rolls of the dice. probs' :: Int -> IO (Int,Int,Int,Int,Int,Int) probs' x = do xs <- dice_rolls x return (occs xs) +-- | Returns the percentage of occurences of 1 through 6, after the given number+-- of rolls of the dice. probs :: Int -> IO (RR,RR,RR,RR,RR,RR) probs x = do (a,b,c,d,e,f) <- probs' x return (fromIntegral a/x',fromIntegral b/x',fromIntegral c/x',fromIntegral d/x',fromIntegral e/x',fromIntegral f/x')
QIO/Qdata.hs view
@@ -1,22 +1,27 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} +-- | This module defines a type class for quantum data types, as well as some+-- instances of this class for pairs, lists, and quantum integers module QIO.Qdata where import Data.Monoid as Monoid import QIO.QioSyn +-- | The 'Qdata' type class defines the operation a quantum datatype must implement. class Qdata a qa | a -> qa, qa -> a where mkQ :: a -> QIO qa measQ :: qa -> QIO a letU :: a -> (qa -> U) -> U condQ :: qa -> (a -> U) -> U +-- | The lowest-level instance of Qdata is the relation between Booleans and Qubits. instance Qdata Bool Qbit where mkQ = mkQbit measQ = measQbit letU b xu = ulet b xu condQ q br = cond q br- ++-- | A pair of quantum data types is itself a quantum data type. instance (Qdata a qa,Qdata b qb) => Qdata (a,b) (qa,qb) where mkQ (a,b) = do qa <- mkQ a@@ -31,6 +36,7 @@ condQ (qa,qb) br = condQ qa (\x -> condQ qb (\y -> br (x,y))) +-- | A list of quantum data is also a quantum data type instance Qdata a qa => Qdata [a] [qa] where mkQ n = sequence (map mkQ n) measQ qs = sequence (map measQ qs)@@ -41,26 +47,33 @@ where condQ' [] xs = qsu xs condQ' (a:as) xs = condQ a (\ x -> condQ' as (xs++[x])) +-- | A recursive conditional on a list of quantum data condQRec :: Qdata a qa => [qa] -> [(a -> U)] -> U condQRec [] [] = mempty condQRec (q:qs) (u:us) = (condQ q u) `mappend` condQRec qs us -+-- | Quantum integers are of a fixed length, which is defined by this constant.+-- Currently, this is set to 4. qIntSize :: Int qIntSize = 4 +-- | A Quantum integer is a wrapper around a fixed-length list of qubits newtype QInt = QInt [Qbit] deriving Show +-- | Convert an integer to a list of Booleans int2bits :: Int -> [Bool] int2bits n = int2bits' n qIntSize where int2bits' 0 0 = [] int2bits' _ 0 = error "int2bits: too large" int2bits' n l = ((n `mod` 2) /= 0) : int2bits' (n `div` 2) (l-1) +-- | Convert a list of Booleans to an integer bits2int :: [Bool] -> Int bits2int [] = 0 bits2int (b:bs) = (2*bits2int bs)+(if b then 1 else 0) +-- | quantum integers form a quantum data type, relating them to the classical+-- Haskell Int type. instance Qdata Int QInt where mkQ n = do qn <- mkQ (int2bits n) return (QInt qn)
QIO/Qft.hs view
@@ -1,3 +1,6 @@++-- | This module provides an implementation of the Quantum Fourier Transform+-- in QIO. module QIO.Qft where import Data.Monoid as Monoid@@ -5,14 +8,18 @@ import QIO.Qio import QIO.Qdata +-- | Defines the unitary the represents appliying a Quantum Fourier Transform+-- to the given quantum register. qft :: [Qbit] -> U qft qs = condQ qs (\bs -> qftAcu qs bs []) -+-- | The definition of the QFT unitary makes use of an accumulator, to repeatedly+-- apply smaller QFTs to the tail of the given quantum register. qftAcu :: [Qbit] -> [Bool] -> [Bool] -> U qftAcu [] [] _ = mempty qftAcu (q:qs) (b:bs) cs = qftBase cs q `mappend` qftAcu qs bs (b:cs) +-- | The \"base\" step involved in a QFT is a series of controlled rotations. qftBase :: [Bool] -> Qbit -> U qftBase bs q = f' bs q 2 where f' [] q _ = uhad q@@ -20,38 +27,18 @@ else f' bs q (x+1) --need to change this into a conQRec???--- -- e.g. qft [Qbit 0] -- = condQ [Qbit 0] (\(b:bs) -> uhad 0 `mappend` mempty) -- but gives cond 0 (\x -> if x then uhad 0 else uhad 0) which is forbidden -testCond :: [Qbit] -> U-testCond [] = mempty-testCond (q:qs) = condQ (q:qs) (\bs -> uhad q)--testCondOk :: [Qbit] -> U-testCondOk [] = mempty-testCondOk (q:qs) = condQ (qs) (\bs -> uhad q)-+-- | The rotation used in the QFT is a phase rotation, parameterised by the +-- angle 1/(2^\k\) rotK :: Int -> Qbit -> U rotK k q = uphase q (1.0/(2.0^k)) +-- | A test of the QFT unitary, over a quantum integer initialised to \n\. tryQft :: Int -> QIO Int tryQft n = do QInt qs <- mkQ n applyU(qft qs) x <- measQ (QInt qs) return x--tC :: (Qbit,Qbit) -> U-tC qxy = condQ qxy (\xy -> tC' qxy xy)--tC' :: (Qbit,Qbit) -> (Bool,Bool) -> U-tC' (qx,qy) (x,y) = if x then unot qy else mempty--testTC :: QIO (Bool,Bool)-testTC = do (qx,qy) <- mkQ (False,False)- applyU (uhad qx)- applyU (tC (qx,qy))- measQ (qx,qy)
QIO/Qio.hs view
@@ -1,6 +1,9 @@++-- | This module defines the functions that can be used to simulate the running of+-- QIO computations. module QIO.Qio where -import List+import Data.List import qualified System.Random as Random import Data.Monoid as Monoid import Data.Maybe as Maybe@@ -10,13 +13,20 @@ import QIO.VecEq import QIO.Heap +-- | A "Pure" state can be thought of as a vector of classical basis states, stored+-- as Heaps, along with complex amplitudes. type Pure = VecEqL CC HeapMap +-- | The state of a qubit can be updated in a Pure state, by mapping the update+-- operation over each Heap. updateP :: Pure -> Qbit -> Bool -> Pure updateP p x b = VecEqL (map (\ (h,pa) -> (update h x b,pa)) (unVecEqL p)) +-- | A "Unitary" can be thought of as an operation on a HeapMap that may produce+-- a Pure state. newtype Unitary = U {unU :: Int -> HeapMap -> Pure } +-- | The Unitary type forms a Monoid instance Monoid Unitary where mempty = U (\ fv h -> unEmbed $ return h) mappend (U f) (U g) = U (\ fv h -> unEmbed $ do h' <- Embed $ f fv h@@ -24,17 +34,16 @@ return h'' ) -uRot :: Qbit -> Rotation -> Unitary-uRot q r = if (unitaryRot r) then (uMatrix q (r (False,False),- r (False,True),- r (True,False),- r (True,True)))- else error "Non unitary Rotation!"-+-- | A function that checks if a given "Rotation" is in face unitary. Note that+-- this is currently a dummy stub function, and states that any rotation is+-- unitary. (This is only o.k. at the moment as all the rotations defined in the+-- QIO library are unitary, but won't catch un-unitary user-defined Rotations) unitaryRot :: Rotation -> Bool unitaryRot r = True--- update to check that the rotation is unitary...+-- TODO: update to check that the rotation is unitary... +-- | Given the four complex numbers that make up a 2-by-2 matrix, we can create+-- a Unitary that applies the rotation to the given qubit. uMatrix :: Qbit -> (CC,CC,CC,CC) -> Unitary uMatrix q (m00,m01,m10,m11) = U (\ fv h -> (if (fromJust(h ? q)) then (m01 <*> (unEmbed $ return (update h q False))) @@ -42,19 +51,31 @@ else (m00 <*> (unEmbed $ return h)) <+> (m10 <*> (unEmbed $ return (update h q True))))) +-- | A rotation can be converted into a "Unitary", using the 'uMatrix' function+uRot :: Qbit -> Rotation -> Unitary+uRot q r = if (unitaryRot r) then (uMatrix q (r (False,False),+ r (False,True),+ r (True,False),+ r (True,True)))+ else error "Non unitary Rotation!"++-- | A swap operation can be defined as a Unitary uSwap :: Qbit -> Qbit -> Unitary uSwap x y = U (\ fv h -> unEmbed $ return (hswap h x y )) +-- | A conditional operation can be defined as a Unitary uCond :: Qbit -> (Bool -> Unitary) -> Unitary --uCond x us = U (\ fv h -> updateP (unU (us (h ? x)) fv (forget h x)) x (h ? x)) uCond x us = U (\ fv h -> unU (us (fromJust(h ? x))) fv h ) --whether or not to forget? (if not then no runtime error for conditionals) +-- | A let operation can be defined as a Unitary uLet :: Bool -> (Qbit -> Unitary) -> Unitary uLet b ux = U (\fv h -> unU (ux (Qbit fv)) (fv + 1) (update h (Qbit fv) b)) --doesn't enforce unitary -- need Unitary -> [Qbit] ??? +-- | Any member of the "U" type can be \"run\" by converting it into a Unitary. runU :: U -> Unitary runU UReturn = mempty runU (Rot x a u) = uRot x a `mappend` runU u@@ -62,16 +83,24 @@ runU (Cond x us u) = uCond x (runU.us) `mappend` runU u runU (Ulet b xu u) = uLet b (runU.xu) `mappend` runU u +-- | A quantum state is a defined as the next free qubit reference, along with the+-- Pure state that represents the overall quantum state data StateQ = StateQ { free :: Int, pure :: Pure } +-- | The initial 'StateQ' initialStateQ :: StateQ initialStateQ = StateQ 0 (unEmbed $ return initial) +-- | Given a Pure state, return a sum of all the amplitudes. pa :: Pure -> RR pa (VecEqL as) = foldr (\ (_,k) p -> p + amp k) 0 as +-- | A Split, is defined as a probability, along with the two Pure states. data Split = Split { p :: RR, ifTrue,ifFalse :: Pure } +-- | Given a Pure state, we can create a Split, by essentially splitting the+-- state into the part where the qubit is True, and the part where the qubit is+-- False. This is how measurements are implemented in QIO. split :: Pure -> Qbit -> Split split (VecEqL as) x = let pas = pa (VecEqL as)@@ -81,26 +110,37 @@ p_ift = if pas==0 then 0 else (pa ift)/pas in Split p_ift ift iff +-- | We can extend a Monad into a PMonad if it defines a way of probabilistically+-- merging two computations, based on a given probability. class Monad m => PMonad m where merge :: RR -> m a -> m a -> m a +-- | IO forms a PMonad, using the random number generator to pick one of the+-- \"merged\" computations probabilistically. instance PMonad IO where merge pr ift iff = do pp <- Random.randomRIO (0,1.0) if pr > pp then ift else iff +-- | The type Prob is defined as a wrapper around Vectors with Real probabilities. data Prob a = Prob {unProb :: Vec RR a} +-- | We can show a probability distribution by filtering out elements with+-- a zero probability. instance Show a => Show (Prob a) where show (Prob (Vec ps)) = show (filter (\ (a,p) -> p>0) ps) +-- | Prob forms a Monad instance Monad Prob where return = Prob . return (Prob ps) >>= f = Prob (ps >>= unProb . f) +-- | Prob is also a PMonad, where the result of both computations are combined into+-- a probability distribution. instance PMonad Prob where merge pr (Prob ift) (Prob iff) = Prob ((pr <**> ift) <++> ((1-pr) <**> iff)) -+-- | Given a PMonad, a QIO Computation can be converted into a Stateful computation+-- over a quantum state (of type 'StateQ'). evalWith :: PMonad m => QIO a -> State StateQ (m a) evalWith (QReturn a) = return (return a) evalWith (MkQbit b g) = do (StateQ f p) <- get @@ -123,11 +163,15 @@ piff <- evalWith (g False) return (merge pr pift piff)) +-- | A QIO computation is evaluated by converting it into a stateful computation+-- and then evaluating that over the initial state. eval :: PMonad m => QIO a -> m a eval p = evalState (evalWith p) initialStateQ +-- | Running a QIO computation evaluates it in the IO PMonad run :: QIO a -> IO a run = eval +-- | Simulating a QIO computation evaluates it in the Prob PMonad sim :: QIO a -> Prob a sim = eval
QIO/QioClass.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- | This module defines the functions that can be used run the classical subset+-- of QIO. That is, QIO computations that only use classical unitary operations. module QIO.QioClass where import Data.Maybe as Maybe@@ -7,28 +8,36 @@ import Control.Monad.State import QIO.QioSyn import QIO.Heap-import Complex +-- | A classical unitary operation is defined as a function that will+-- update the current classical state. newtype UnitaryC = U {unU :: Int -> HeapMap -> HeapMap} +-- | The classical unitary type forms a Monoid instance Monoid UnitaryC where mempty = U (\ fv bs -> bs) mappend (U f) (U g) = U (\ fv h -> g fv (f fv h)) +-- | A single qubit rotation can be converted into the classical unitary type, +-- if it is indeed classical (otherwise an error is thrown). uRotC :: Qbit -> Rotation -> UnitaryC uRotC x f | f==rnot = U (\ _ h -> update h x (not (fromJust (h ? x)))) | f==rid = mempty | otherwise = error "not classical" +-- | A swap operation can be defined in the classical unitary type. uSwapC :: Qbit -> Qbit -> UnitaryC uSwapC x y = U (\ _ h -> hswap h x y ) +-- | A conditional operation can be defined in the classical unitary type. uCondC :: Qbit -> (Bool -> UnitaryC) -> UnitaryC uCondC x br = U (\ fv h -> update (unU (br (fromJust (h ? x))) fv (forget h x)) x (fromJust (h ? x))) +-- | A let operation can be defined in the classical unitary type. uLetC :: Bool -> (Qbit -> UnitaryC) -> UnitaryC uLetC b ux = U (\ fv h -> unU (ux (Qbit fv)) (fv+1) (update h (Qbit fv) b)) +-- | A unitary can be run by converting it into the classical unitary type. runUC :: U -> UnitaryC runUC UReturn = mempty runUC (Rot x r u) = uRotC x r `mappend` runUC u@@ -36,11 +45,17 @@ runUC (Cond x us u) = uCondC x (runUC.us) `mappend` runUC u runUC (Ulet b xu u) = uLetC b (runUC.xu) `mappend` runUC u +-- | A classical state consists of the next free qubit reference, along with +-- a Heap that represents the overall state of the current qubits in scope. data StateC = StateC {fv :: Int, heap :: HeapMap} +-- | An initial state is defined as an empty heap, with 0 set as the next +-- free qubit referece initialStateC :: StateC initialStateC = StateC 0 initial +-- | A QIO computation can be converted into a stateful computation, over+-- a state of type "StateC". runQStateC :: QIO a -> State StateC a runQStateC (QReturn a) = return a runQStateC (MkQbit b xq) = do (StateC fv h) <- get @@ -52,6 +67,8 @@ runQStateC (Meas x qs) = do (StateC _ h) <- get runQStateC (qs (fromJust (h ? x))) +-- | We can run a classical QIO computation by converting it into a stateful+-- computation, and evaluating that using the initial state. runC :: QIO a -> a runC q = evalState (runQStateC q) initialStateC
QIO/QioSyn.hs view
@@ -1,37 +1,39 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} +-- | This module defines the Syntax of the Quantum IO Monad, which is an embedded+-- language for writing quantum computations. module QIO.QioSyn where import Data.Monoid as Monoid-import Complex+import Data.Complex +-- | For Real numbers, we simply use the built in Double type+type RR = Double --- complex numbers+-- | For Complex numbers, we use the built in Complex numbers, over our Real +-- number type (i.e. Double) type CC = Complex RR +-- | The amplitude of a complex number is the magnitude squared. amp :: CC -> RR amp k = (magnitude k)*(magnitude k) ---- real numbers-type RR = Float----- Qubits are references+-- | The type of Qubits in QIO are simply integer references. newtype Qbit = Qbit Int deriving (Num, Enum, Eq, Ord) --- QIO and U as traces+-- | A rotation is in essence a two-by-two complex valued matrix type Rotation = ((Bool,Bool) -> CC) +-- | The underlying data type of a U unitary operation data U = UReturn | Rot Qbit Rotation U | Swap Qbit Qbit U | Cond Qbit (Bool -> U) U | Ulet Bool (Qbit -> U) U +-- | The underlying data type of a QIO Computation data QIO a = QReturn a | MkQbit Bool (Qbit -> QIO a) | ApplyU U (QIO a) | Meas Qbit (Bool -> QIO a) ---- U functions+-- | The type "U" forms a Monoid instance Monoid U where mempty = UReturn mappend UReturn u = u@@ -40,18 +42,23 @@ mappend (Cond x br u') u'' = Cond x br (mappend u' u'') mappend (Ulet b f u) u' = Ulet b f (mappend u u') +-- | Apply the given rotation to the given qubit rot :: Qbit -> Rotation -> U rot x r = Rot x r UReturn +-- | Swap the state of the two given qubits swap :: Qbit -> Qbit -> U swap x y = Swap x y UReturn +-- | Apply the conditional unitary, depending on the value of the given qubit cond :: Qbit -> (Bool -> U) -> U cond x br = Cond x br UReturn +-- | Introduce an Ancilla qubit in the given state, for use in the sub-unitary ulet :: Bool -> (Qbit -> U) -> U ulet b ux = Ulet b ux UReturn +-- | Returns the inverse (or reverse) of the given unitary operation urev :: U -> U urev UReturn = UReturn urev (Rot x r u) = urev u `mappend` rot x (rrev r)@@ -59,17 +66,20 @@ urev (Cond x br u) = urev u `mappend` cond x (urev.br) urev (Ulet b xu u) = urev u `mappend` ulet b (urev.xu) +-- | Apply a not rotation to the given qubit unot :: Qbit -> U unot x = rot x rnot +-- | Apply a hadamard rotation to the given qubit uhad :: Qbit -> U uhad x = rot x rhad +-- | Apply a phase rotation (of the given angle) to the given qubit uphase :: Qbit -> RR -> U uphase x r = rot x (rphase r) ---- QIO functions+-- | The "QIO" type forms a Monad instance Monad QIO where return = QReturn (QReturn a) >>= f = f a@@ -77,36 +87,46 @@ (ApplyU u q) >>= f = ApplyU u (q >>= f) (Meas x g) >>= f = Meas x (\ b -> g b >>= f) +-- | Initialise a qubit in the given state (adding it to the overall quantum state) mkQbit :: Bool -> QIO Qbit mkQbit b = MkQbit b return +-- | Apply the given unitary operation to the current quantum state applyU :: U -> QIO () applyU u = ApplyU u (return ()) +-- | Measure the given qubit, and return the measurement outcome (note that this+-- operation may affect the overall quantum state, as a measurement is destructive) measQbit :: Qbit -> QIO Bool measQbit x = Meas x return --- rotations+-- | The identity rotation rid :: Rotation rid (x,y) = if x==y then 1 else 0 +-- | The not rotation rnot :: Rotation rnot (x,y) = if x==y then 0 else 1 +-- | The hadamard rotation rhad :: Rotation rhad (x,y) = if x && y then -h else h where h = (1/sqrt 2) +-- | The phase rotation rphase :: RR -> Rotation rphase _ (False,False) = 1 rphase r (True,True) = exp(0:+r) rphase _ (_,_) = 0 +-- | Returns the inverse (or reverse) of the given rotation rrev :: Rotation -> Rotation rrev r (False,True) = conjugate (r (True,False)) rrev r (True,False) = conjugate (r (False,True)) rrev r xy = conjugate (r xy) +-- | Rotations can be compared for equality.+-- They are equal if the define the same matrix. instance Eq Rotation where f == g = (f (False,False) == g (False,False)) && (f (False,True) == g (False,True)) @@ -118,29 +138,29 @@ || (f (True,True) /= g (True,True)) --- show functions (for Qbit, Rotation and U)+-- | We can display a qubit reference instance Show Qbit where show (Qbit q) = "(Qbit:" ++ show q ++ ")" +-- | We can display the matrix representation of a rotation instance Show Rotation where show f = "(" ++ (show (f (False,False))) ++ "," ++ (show (f (False,True))) ++ "," ++ (show (f (True,False))) ++ "," ++ (show (f (True,True))) ++ ")" +-- | We can display a representation of a unitary instance Show U where show u = show' u 0 (-1) +-- | A helper function for the show instance of U show' :: U -> Int -> Int -> String- show' (UReturn) x fv = ""- show' (Rot q a u) x fv = spaces x ++ "Rotate " ++ show q ++ " by " ++ show a ++ ".\n" ++ show' u x fv- show' (Swap q1 q2 u) x fv = spaces x ++ "Swap " ++ show q1 ++ " and " ++ show q2 ++ ".\n" ++ show' u x fv- show' (Cond q f u) x fv = spaces x ++ "Cond (if " ++ show q ++ " then \n" ++ spaces (x+1) ++ "(\n" ++ show' (f True) (x+1) fv ++ spaces (x+1) ++ ")\n" ++ spaces x ++ "else \n" ++ spaces (x+1) ++ "(\n" ++ show' (f False) (x+1) fv ++ spaces (x+1) ++ ")\n" ++ show' u x fv- show' (Ulet b f u) x fv = spaces x ++ "Ulet " ++ show b ++ " (\\" ++ show (Qbit fv) ++ "->\n " ++ show' (f (Qbit fv)) x (fv-1) ++ ")\n" ++ show' u x fv +-- | A helper function that returns a string of 4\x\ spaces. spaces :: Int -> String spaces 0 = ""-spaces (n+1) = " " ++ spaces n +spaces n = if (n < 0) then error "spaces: negative argument" + else " " ++ spaces (n-1)
QIO/Shor.hs view
@@ -1,5 +1,7 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- | This module defines the QIO computation that represents Shor's factorisation+-- algorithm. It makes use of the Arithmetic library, and the Quantum Fourier +-- Transform. module QIO.Shor where import Data.Monoid as Monoid@@ -12,12 +14,15 @@ import QIO.Qft import System.Time +-- | The inverse Quantum Fourier Transform is defined by reversing the QFT qftI :: QInt -> U qftI (QInt i) = urev (qft i) +-- | The Hadamard transform can be mapped over the qubits in a Quantum Integer. hadamardsI :: QInt -> U hadamardsI (QInt xs) = hadamards xs +-- | The overall \"phase-estimation\" structure of Shor's algorithm. shorU :: QInt -> QInt -> Int -> Int -> U shorU k i1 x n = hadamardsI k `mappend` @@ -25,6 +30,8 @@ `mappend` qftI k +-- | A quantum computation the implementes shor's algorithm, returning the period+-- of the function. shor :: Int -> Int -> QIO Int shor x n = do i0 <- mkQ 0 i1 <- mkQ 1@@ -32,10 +39,11 @@ p <- measQ i0 return p +-- | A classical (inefficient) implementation of the period finding subroutine period :: Int -> Int -> Int period m q = r where (_,r) = reduce (m,q) -+-- | A wrapper for Shor's algorithm, that returns prime factors of \n\. factor :: Int -> QIO (Int,Int) factor n | even n = return (2,2) | otherwise = do x <- rand_coprime n@@ -47,6 +55,8 @@ --this function can only be run too, for similar reasons to the rand_co' --function below +-- | This function simulates the running of a QIO computation, whilst using+-- System.Time functions to time how long the simulation took. runTime :: QIO a -> IO a runTime a = do start <- getClockTime result <- run a@@ -55,6 +65,7 @@ (timeDiffToString (diffClockTimes stop start) ++ "\n")) return result +-- | Times the running of various subroutines within the factorisation algorithm. factorV' :: Int -> IO (Int,Int) factorV' n | even n = return (2,2) | otherwise = do start <- getClockTime@@ -73,6 +84,7 @@ else do putStr "Result: " return (gcd (xa+1) n,gcd (xa-1) n) +-- | Calls the 'factorV'', and times the overall factorisation. factorV :: Int -> IO () factorV n = do start <- getClockTime (a,b) <- factorV' n@@ -86,7 +98,16 @@ ++ ".\n The total time taken was " ++ (timeDiffToString (diffClockTimes stop start) ++ "\n")) +-- | This function defines a quantum computation that returns a random index, that+-- is used to pick from a list of integers that are co-prime to \n\.+rand_coprime :: Int -> QIO Int+rand_coprime n = do x <- randomQIO (0,(length cps)-1)+ return (cps!!x)+ where cps = [x | x <- [0..n], gcd x n == 1] +-- | A different implementation of "rand_coprime", that defines a quantum+-- computation that returns a random number between 2 and \n\, that is then+-- returned if it is co-prime to \n\. rand_co' :: Int -> QIO Int rand_co' n = do x <- randomQIO (2,n) if gcd x n == 1 then return x else rand_co' n@@ -94,16 +115,12 @@ --the computation, e.g. each path where gcd x n /= 1. However, this function --can still be run (with the run function) always returning a single value. -rand_coprime :: Int -> QIO Int-rand_coprime n = do x <- randomQIO (0,(length cps)-1)- return (cps!!x)- where cps = [x | x <- [0..n], gcd x n == 1]---+-- | Integer division by 2. half :: Int -> Int half x = floor (fromIntegral x/2.0) +-- | Reduces a pair of integers, by dividing them by thier gcd, +-- until their gcd is 1. reduce :: (Int,Int) -> (Int,Int) reduce (x,y) = if g == 1 then (x,y) else (floor ((fromIntegral x)/(fromIntegral g)),floor ((fromIntegral y)/(fromIntegral g))) where g = gcd x y
QIO/Vec.hs view
@@ -1,21 +1,32 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-} +-- | This module defines a Vector as a list of pairs. +-- In the context of QIO, a Vector is the type used to represent a probability+-- distribution. module QIO.Vec where +-- | A Vector over types 'x' and 'a' is a wrapper around list of +-- pairs of 'a' and 'x'. newtype Vec x a = Vec {unVec :: [(a,x)]} deriving Show +-- | An empty Vector is defined as the empty list empty :: Vec x a empty = Vec [] +-- | The \"probability\" of an object in a Vector, is the sum of all the+-- probabilities associated with that object. (<@@>) :: (Num x,Eq a) => Vec x a -> a -> x (Vec ms) <@@> a = foldr (\(b,k) m -> if a == b then m + k else m) 0 ms +-- | A Vector can be multiplied by a scalar, by mapping the multiplcation+-- over each probability in the vector. (<**>) :: Num x => x -> (Vec x a) -> Vec x a l <**> (Vec as) = (Vec (map (\ (a,k) -> (a,l*k)) as)) +-- | Two Vectors can be added, using list concatenation. (<++>) :: (Vec x a) -> (Vec x a) -> Vec x a (Vec as) <++> (Vec bs) = (Vec (as ++ bs)) +-- | Vectors, over Numeric types, can be defined as a Monad. instance Num n => Monad (Vec n) where return a = Vec [(a,1)] (Vec ms) >>= f = Vec [(b,i*j) | (a,i) <- ms, (b,j) <- unVec (f a)]
QIO/VecEq.hs view
@@ -1,45 +1,66 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-undecidable-instances #-}+{-# LANGUAGE GADTs, FlexibleInstances #-} +-- | This module defines a class of Vectors over types with Equality, along with+-- an instance of this class using lists of pairs. In the context of QIO, these+-- Vectors are used to hold the amplitudes of various basis-states within a+-- superposition. module QIO.VecEq where import QIO.QioSyn import QIO.Heap +-- | Any type that fulfills this type class is a Vector over types with equality class VecEq v where+ -- | An empty instance of the vector vzero :: v x a+ -- | Two Vectors can be combined (<+>) :: (Eq a, Num x) => v x a -> v x a -> v x a+ -- | A Vector can be multiplied by a scalar (<*>) :: (Num x) => x -> v x a -> v x a+ -- | The amplitude of a given element can be accessed (<@>) :: (Eq a, Num x) => a -> v x a -> x+ -- | The vector can be created from a list of pairs fromList :: [(a,x)] -> v x a+ -- | The cevtor can be converted into a list of pairs toList :: v x a -> [(a,x)] +-- | This type is a wrapper around a list of pairs. newtype VecEqL x a = VecEqL {unVecEqL :: [(a,x)]} deriving Show +-- | An empty VecEqL is a wrapper around the empty list vEqZero :: VecEqL x a vEqZero = VecEqL [] +-- | A basis state with the given amplitude can be added to a VecEqL by adding+-- the amplitudes if the state is already in the vector, or by inserting the+-- base state if it isn't already in the vector.+add :: (Eq a,Num x) => (a,x) -> VecEqL x a -> VecEqL x a+add (a,x) (VecEqL axs) = VecEqL (addV' axs)+ where addV' [] = [(a,x)]+ addV' ((by @ (b,y)):bys) | a == b = (b,x+y):bys+ | otherwise = by:(addV' bys) +-- | Combining two vectors is achieved by folding the add operation over+-- the second vector vEqPlus :: (Eq a, Num x) => VecEqL x a -> VecEqL x a -> VecEqL x a (VecEqL as) `vEqPlus` vbs = foldr add vbs as -+-- | Scalar multiplcation is achieved by mapping the multiplication over+-- each pair in the vector. Multiplication by 0 is a special case, and will+-- remove all the basis states from the vector. vEqTimes :: (Num x) => x -> VecEqL x a -> VecEqL x a l `vEqTimes` (VecEqL bs) | l==0 = VecEqL [] | otherwise = VecEqL (map (\ (b,k) -> (b,l*k)) bs) -+-- | The amplitude of an element can be found by looking through each element+-- until the matchinf one is found. vEqAt :: (Eq a, Num x) => a -> VecEqL x a -> x a `vEqAt` (VecEqL []) = 0 a `vEqAt` (VecEqL ((a',b):abs)) | a == a' = b | otherwise = a `vEqAt` (VecEqL abs) -add :: (Eq a,Num x) => (a,x) -> VecEqL x a -> VecEqL x a-add (a,x) (VecEqL axs) = VecEqL (addV' axs)- where addV' [] = [(a,x)]- addV' ((by @ (b,y)):bys) | a == b = (b,x+y):bys- | otherwise = by:(addV' bys)-+-- | VecEqL is an instance of the VecEq class instance VecEq VecEqL where vzero = vEqZero (<+>) = vEqPlus@@ -48,10 +69,13 @@ fromList as = VecEqL as toList (VecEqL as) = as +-- | An EqMonad is a monad that has Return and Bind operations that depend on+-- the type in the monad being a member of the Eq class class EqMonad m where eqReturn :: Eq a => a -> m a eqBind :: (Eq a, Eq b) => m a -> (a -> m b) -> m b +-- | Any VecEq over \v\, along with a Numeric tpye \x\ is an EqMonad. instance (VecEq v, Num x) => EqMonad (v x) where eqReturn a = fromList [(a,1)] eqBind va f = case toList va of@@ -59,16 +83,19 @@ ((a,x):[]) -> x <*> f a ((a,x):vas) -> (x <*> f a) <+> ((fromList vas) `eqBind` f) -+-- | We can define a datatype that holds EqMonad operations, so that it can+-- be defined as a Monad. data AsMonad m a where Embed :: (EqMonad m, Eq a) => m a -> AsMonad m a Return :: EqMonad m => a -> AsMonad m a Bind :: EqMonad m => AsMonad m a -> (a -> AsMonad m b) -> AsMonad m b +-- | We can define an AsMonad over an EqMonad, as a Monad instance EqMonad m => Monad (AsMonad m) where return = Return (>>=) = Bind +-- | Given Equality, we can unembed the EqMonad operations from an AsMonad unEmbed :: Eq a => AsMonad m a -> m a unEmbed (Embed m) = m unEmbed (Return a) = eqReturn a