├── LICENSE ├── QIO.cabal ├── QIO ├── Heap.hs ├── QArith.hs ├── QExamples.hs ├── QIORandom.hs ├── Qdata.hs ├── Qft.hs ├── Qio.hs ├── QioClass.hs ├── QioSyn.hs ├── QioSynAlt.hs ├── Shor.hs ├── Vec.hs └── VecEq.hs ├── README.md └── Setup.hs /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2016, Alexander S. Green 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 8 | 9 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 10 | 11 | -------------------------------------------------------------------------------- /QIO.cabal: -------------------------------------------------------------------------------- 1 | Name: QIO 2 | Version: 1.3 3 | Cabal-Version: >= 1.24 4 | License: BSD3 5 | License-File: LICENSE 6 | Author: Alexander S. Green 7 | Maintainer: alexander.s.green@gmail.com 8 | Homepage: https://github.com/alexandersgreen/qio-haskell 9 | Category: Quantum 10 | Synopsis: The Quantum IO Monad is a library for defining quantum computations in Haskell 11 | 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. 12 | Build-Type: Simple 13 | 14 | Library 15 | Default-language: 16 | Haskell2010 17 | Build-Depends: 18 | base >= 4.9, containers, mtl, random, old-time 19 | Exposed-modules: 20 | QIO.Heap, QIO.QArith, QIO.QExamples, QIO.QIORandom, QIO.Qdata, QIO.Qft, 21 | QIO.Qio, QIO.QioClass, QIO.QioSyn, QIO.QioSynAlt, QIO.Shor, QIO.Vec, QIO.VecEq 22 | 23 | -------------------------------------------------------------------------------- /QIO/Heap.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} 2 | 3 | -- | This module contains the definition of a Type Class that represents a Heap. 4 | -- In the context of QIO, a Heap is the type used to represent a classical 5 | -- basis state. An instance of a Heap is also defined, that makes use of a Map. 6 | module QIO.Heap where 7 | 8 | import qualified Data.Map as Map 9 | import Data.Maybe as Maybe 10 | import QIO.QioSyn 11 | 12 | -- | The Heap Type Class 13 | class Eq h => Heap h where 14 | -- | define an 'initial' (i.e. empty) Heap 15 | initial :: h 16 | -- | 'update' the value of a Qubit within the Heap to the given Boolen value 17 | update :: h -> Qbit -> Bool -> h 18 | -- | Lookup the value of the given Qubit in the Heap (if it exists) 19 | (?) :: h -> Qbit -> Maybe Bool 20 | -- | remove the given Qubit from the Heap 21 | forget :: h -> Qbit -> h 22 | -- | Swap the values associated with two Qubits within the Heap 23 | hswap :: h -> Qbit -> Qbit -> h 24 | hswap h x y = update (update h y (fromJust (h ? x))) x (fromJust (h ? y)) 25 | 26 | -- | HeapMap is simply a type synonym for a Map from Qubits to Boolean values 27 | type HeapMap = Map.Map Qbit Bool 28 | 29 | -- | A HeapMap is an instance of the Heap type class, where the Heap functions 30 | -- can make use of the underlying Map functions. 31 | instance Heap HeapMap where 32 | initial = Map.empty 33 | update h q b = Map.insert q b h 34 | h ? q = Map.lookup q h 35 | forget h q = Map.delete q h 36 | 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /QIO/QArith.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module contains QIO unitaries that represent various Arithmetic 3 | -- functions. These are exactly the Arithmetic functions required to implement 4 | -- Shor's algorithm. 5 | module QIO.QArith where 6 | 7 | import Data.Monoid as Monoid 8 | import QIO.QioSyn 9 | import QIO.Qdata 10 | import QIO.QioClass 11 | import QIO.Qio 12 | import QIO.QExamples 13 | 14 | -- | A swap operation can be applied to two QInts, by mapping qubit swap operations 15 | -- over the underlying qubits that make up a QInt. 16 | swapQInt :: QInt -> QInt -> U 17 | swapQInt (QInt xs) (QInt ys) = swapQInt' xs ys 18 | where 19 | swapQInt' [] [] = mempty 20 | swapQInt' (x:xs) (y:ys) = (swap x y) `mappend` swapQInt' xs ys 21 | 22 | -- | ifElseQ defines a quantum If statement, whereby depending on the state of 23 | -- the given (control) qubit, one of two unitaries are applied. 24 | ifElseQ :: Qbit -> U -> U -> U 25 | ifElseQ qa t f = cond qa (\ qa -> if qa then t else f) 26 | 27 | -- | ifQ defines a special case of ifElseQ, where the Else part of the computation 28 | -- is simply the identity. 29 | ifQ :: Qbit -> U -> U 30 | ifQ qa t = ifElseQ qa t mempty 31 | 32 | -- | A controlled-not operations, that applies a Not to the second qubit, 33 | -- depending on the state of the first qubit. 34 | cnot :: Qbit -> Qbit -> U 35 | cnot qa qb = ifQ qa (unot qb) 36 | 37 | -- | A three-qubit adder. 38 | addBit :: Qbit -> Qbit -> Qbit -> U 39 | addBit qc qa qb = 40 | cnot qa qb `mappend` 41 | cnot qc qb 42 | 43 | -- | Calculates the carry (qu)bit. 44 | carry :: Qbit -> Qbit -> Qbit -> Qbit -> U 45 | carry qci qa qb qcsi = 46 | cond qci (\ ci -> 47 | cond qa (\ a -> 48 | cond qb (\ b -> 49 | if ci && a || ci && b || a && b 50 | then unot qcsi 51 | else mempty))) 52 | 53 | -- | uses the 'addBit' and 'carry' unitaries to add the contents of two quantum 54 | -- registers, setting an overflow bit if necessary. This unitary makes use of a 55 | -- letU construct to introduce ancilla bits as necessary. 56 | addBits :: [Qbit] -> [Qbit] -> Qbit -> U 57 | addBits qas qbs qc' = 58 | letU False (addBits' qas qbs) 59 | where addBits' [] [] qc = ifQ qc (unot qc') 60 | addBits' (qa:qas) (qb:qbs) qc = 61 | letU False (\ qc' -> carry qc qa qb qc' `mappend` 62 | addBits' qas qbs qc'`mappend` 63 | urev (carry qc qa qb qc')) `mappend` 64 | addBit qc qa qb 65 | 66 | -- | An alternate implementation of 'addBits' that is explicitly given 67 | -- a register of ancilla qubits for all the intermediate 'carry' results. 68 | addBits' :: [Qbit] -> [Qbit] -> [Qbit] -> Qbit -> U 69 | addBits' [] [] [] qc = mempty 70 | addBits' (qa:qas) (qb:qbs) (qc':qcs') qc = 71 | (carry qc qa qb qc' `mappend` 72 | addBits' qas qbs qcs' qc'`mappend` 73 | urev (carry qc qa qb qc')) `mappend` 74 | addBit qc qa qb 75 | 76 | -- | Defines the QIO unitary that adds two QInts, with an overflow qubit 77 | adder :: QInt -> QInt -> Qbit -> U 78 | adder (QInt qas) (QInt qbs) qc = addBits qas qbs qc 79 | 80 | -- | A small function to test the adder unitary 81 | tadder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) 82 | tadder xyc = do q @ (qx,(qy,qc)) <- mkQ xyc 83 | applyU (adder qx qy qc) 84 | xyc <- measQ q 85 | return xyc 86 | 87 | -- | A small function to test applying the adder unitary in reverse, ie. 88 | -- this defines subtraction. 89 | tRadder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) 90 | tRadder xyc = do q @ (qx,(qy,qc)) <- mkQ xyc 91 | applyU (urev (adder qx qy qc)) 92 | xyc <- measQ q 93 | return xyc 94 | 95 | -- | A small function to test applying the adder unitary, and then applying 96 | -- the reverse of the adder unitary, which should give the identity function. 97 | tBiAdder :: (Int,(Int,Bool)) -> QIO (Int,(Int,Bool)) 98 | tBiAdder xyc = do 99 | q @ (qx,(qy,qc)) <- mkQ xyc 100 | applyU (adder qx qy qc) 101 | applyU (urev (adder qx qy qc)) 102 | xyc <- measQ q 103 | return xyc 104 | 105 | -- | This unitary is for modular addition, and is done modulo some fixed 106 | -- classical modulus, given as the first Int argument. 107 | adderMod :: Int -> QInt -> QInt -> U 108 | adderMod n qa qb = 109 | letU n (\ qn -> 110 | letU False (\ qz -> 111 | letU False (\ qc -> 112 | adder qa qb qc 113 | `mappend` -- b = a+b, c=False 114 | urev (adder qn qb qc) 115 | `mappend` -- b = a+b-N, c = a+b < N 116 | cond qc (\ c -> if c then unot qz else mempty) 117 | `mappend` -- z = c = a+b < N 118 | cond qz (\ z -> if z then adder qn qb qc else mempty) 119 | `mappend` -- b = a+b mod N, c = False, z = a+b < N 120 | urev (adder qa qb qc) 121 | `mappend` -- if a+b < N then a=a,b=b,c=False 122 | -- else a=a,b=a+b mod N - b,c=True 123 | -- z = not c 124 | cond qc (\ c -> if c then mempty else unot qz) 125 | `mappend` -- z = False 126 | adder qa qb qc))) -- b = a+b mod N, c=False, z=False 127 | 128 | -- | A small function to test the modular addition unitary. 129 | tadderMod :: Int -> (Int,Int) -> QIO (Int,Int) 130 | tadderMod n ab = do q @ (qa,qb) <- mkQ ab 131 | applyU (adderMod n qa qb) 132 | ab <- measQ q 133 | return ab 134 | 135 | -- | This unitary defines modular multiplication, whereby the integer 'n' is the 136 | -- the modulus, and the integer 'a' is the scalar by which to multiply the quantum 137 | -- integer 'x'. The result is added to the quantum integer 'y', ie. if 'y' is in 138 | -- state 0 before the operation, then it is left in the sate a*x mod n. 139 | multMod :: Int -> Int -> QInt -> QInt -> U 140 | multMod n a (QInt x) y = multMod' n a x y 1 141 | where 142 | multMod' _ _ [] _ _ = mempty 143 | multMod' n a (x:xs) y p = cond x (\x -> ( 144 | if x then (letU ((p*a) `mod` n) (\ qa -> (adderMod n qa y)) `mappend` (multMod' n a xs y (p*2))) 145 | else multMod' n a xs y (p*2))) 146 | 147 | -- | A small function for testing the modular multiplication unitary. This function 148 | -- initialises 'y' as zero, so the output is as expected. 149 | tmultMod :: Int -> Int -> Int -> QIO (Int,Int) 150 | tmultMod n a x = do y <- mkQ 0 151 | x' <- mkQ x 152 | applyU(multMod n a x' y) 153 | qy <- measQ y 154 | qx <- measQ x' 155 | return (qx,qy) 156 | 157 | -- | A unitary that adds a single qubit control to modular multiplication 158 | condMultMod :: Qbit -> Int -> Int -> QInt -> QInt -> U 159 | condMultMod q n a x y = ifQ q (multMod n a x y) 160 | 161 | ------------------------------------------------------------------------------ 162 | 163 | -- | A classical Haskell function that returns the smalles positive inverse 164 | -- of \a\ `mod \n\ (if one exists). That is, the smallest positive integer 165 | -- \x\, such that \x\*\a\ `mod` \n\ equals 1. 166 | inverseMod :: Int -> Int -> Int 167 | inverseMod n a = case imods of 168 | [] -> error ("inverseMod: no inverse of "++(show a)++" mod "++(show n)++ " found") 169 | (x:_) -> x 170 | where 171 | imods = [x | x <- [1..n], ((x*a) `mod` n) == 1] 172 | 173 | ------------------------------------------------------------------------------- 174 | 175 | -- | The unitary that represents modular exponentiation is constructed in terms 176 | -- of multiple \"steps\". This function defines those steps. 177 | modExpStep :: Qbit -> Int -> Int -> QInt -> Int -> U 178 | modExpStep qc n a o p = letU 0 (\z -> (condMultMod qc n p' o z) 179 | `mappend` (ifQ qc (swapQInt o z)) 180 | `mappend` (urev (condMultMod qc n (inverseMod n p') o z))) 181 | where 182 | p' | (a^(2^p)) == 0 = error "modExpStep: arguments too large" 183 | | otherwise = (a^(2^p)) `mod` n 184 | 185 | -- | A QIO computation that forms a test of the 'modExpStep' unitary 186 | modExpStept :: Int -> Int -> Int -> Int -> QIO Int 187 | modExpStept i n a p = do 188 | q <- mkQ True 189 | one <- mkQ i 190 | applyU (modExpStep q n a one p) 191 | r <- measQ one 192 | return r 193 | 194 | -- | This function defines a unitary that implements modular exponentiation, as 195 | -- required in Shor's algorithm. Given classical arguments \n\ and \a\, a quantum 196 | -- register containg \x\, and a quantum register \o\ in state 1, this unitary will 197 | -- leave the quantum register \o\ in the state \a\^\x\ mod \n\. 198 | modExp :: Int -> Int -> QInt -> QInt -> U 199 | modExp n a (QInt x) o = modExp' n a x o 0 200 | where 201 | modExp' _ _ [] _ _ = mempty 202 | modExp' n a (x:xs) o p = modExpStep x n a o p `mappend` (modExp' n a xs o (p+1)) 203 | 204 | -- | A QIO computation that forms a test of the modular exponentiation unitary. 205 | modExpt :: Int -> (Int,Int) -> QIO Int 206 | modExpt n (a,x) = do 207 | qx <- mkQ x 208 | one <- mkQ 1 209 | applyU (modExp n a qx one) 210 | r <- measQ one 211 | return r 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | -------------------------------------------------------------------------------- /QIO/QExamples.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module contains some simple examples of quantum computations written 3 | -- using the Quantum IO Monad. 4 | module QIO.QExamples where 5 | 6 | import Data.Monoid as Monoid 7 | import QIO.QioSyn 8 | import QIO.Qdata 9 | import QIO.QioClass 10 | import QIO.Qio 11 | 12 | -- | Initialise a qubit in the |0> state 13 | q0 :: QIO Qbit 14 | q0 = mkQ False 15 | 16 | -- | Initialise a qubit in the |1> state 17 | q1 :: QIO Qbit 18 | q1 = mkQ True 19 | 20 | -- | Initialise a qubit in the |+> state. This is done by applying a Hadamard 21 | -- gate to the |0> state. 22 | qPlus :: QIO Qbit 23 | qPlus = do qa <- q0 24 | applyU (uhad qa) 25 | return qa 26 | 27 | -- | Initialise a qubit in the |-> state. This is done by applying a Hadamard 28 | -- gate to the |1> state. 29 | qMinus :: QIO Qbit 30 | qMinus = do qa <- q1 31 | applyU (uhad qa) 32 | return qa 33 | 34 | -- | Create a random Boolean value, by measuring the state |+> 35 | randBit :: QIO Bool 36 | randBit = do qa <- qPlus 37 | x <- measQbit qa 38 | return x 39 | 40 | -- | This function can be used to "share" the state of one qubit, with another 41 | -- newly initialised qubit. This is not the same as "cloning", as the two qubits 42 | -- will be in an entangled state. "sharing" is achieved by simply initialising 43 | -- a new qubit in state |0>, and then applying a controlled-not to that qubit, 44 | -- depending on the state of the given qubit. 45 | share :: Qbit -> QIO Qbit 46 | share qa = do qb <- q0 47 | applyU (cond qa (\a -> if a then (unot qb) 48 | else (mempty) ) ) 49 | return qb 50 | 51 | -- | A Bell state can be created by sharing the |+> state 52 | bell :: QIO (Qbit, Qbit) 53 | bell = do qa <- qPlus 54 | qb <- share qa 55 | return (qa,qb) 56 | 57 | -- | This function creates a Bell state, and then measures it. The resulting pair 58 | -- of Booleans will always be in the same state as one another. 59 | test_bell :: QIO (Bool,Bool) 60 | test_bell = do qb <- bell 61 | b <- measQ qb 62 | return b 63 | 64 | -- | This function initiaslised a qubit in the state corresponding to the given 65 | -- Boolean value. The Hadamard transform (which is self-inverse) is applied to 66 | -- the qubit twice, and then the qubit is measured. This should correspond to 67 | -- the identity function on the given Boolean value. 68 | hadTwice :: Bool -> QIO Bool 69 | hadTwice x = do 70 | q <- mkQ x 71 | applyU (uhad q `mappend` uhad q) 72 | b <- measQ q 73 | return b 74 | 75 | -- | A different implementation of 'hadTwice' where QIO is used to apply two 76 | -- unitaries, each of which is a single Hadamard gate, as opposed to a single 77 | -- unitary, which is two Hadamard gates. 78 | hadTwice' :: Bool -> QIO Bool 79 | hadTwice' x = do 80 | q <- mkQ x 81 | applyU (uhad q) 82 | applyU (uhad q) 83 | b <- measQ q 84 | return b 85 | 86 | ---------------------------------------------- 87 | ---- Teleportation --------------------------- 88 | ---------------------------------------------- 89 | 90 | -- | The operations that Alice must perform in the classic quantum teleportation 91 | -- example. 92 | alice :: Qbit -> Qbit -> QIO (Bool,Bool) 93 | alice aq eq = do 94 | applyU (cond aq (\a -> if a then (unot eq) else (mempty))) 95 | applyU (uhad aq) 96 | cd <- measQ (aq,eq) 97 | return cd 98 | 99 | -- | A definition of the Pauli-Z gate. 100 | uZZ :: Qbit -> U 101 | uZZ qb = (uphase qb pi) 102 | 103 | -- | The unitary operations that Bob must perform in the classic quantum 104 | -- teleportation example. 105 | bobsU :: (Bool,Bool) -> Qbit -> U 106 | bobsU (False,False) eq = mempty 107 | bobsU (False,True) eq = (unot eq) 108 | bobsU (True,False) eq = (uZZ eq) 109 | bobsU (True,True) eq = ((unot eq) `mappend` (uZZ eq)) 110 | 111 | -- | The overall operations that Bob must perform in the classic quantum 112 | -- teleportation example 113 | bob :: Qbit -> (Bool,Bool) -> QIO Qbit 114 | bob eq cd = do applyU (bobsU cd eq) 115 | return eq 116 | 117 | -- | The overall QIO computation that teleports the state of single qubit 118 | teleportation :: Qbit -> QIO Qbit 119 | teleportation iq = do (eq1,eq2) <- bell 120 | cd <- alice iq eq1 121 | tq <- bob eq2 cd 122 | return tq 123 | 124 | -- | A small test function of quantum teleportation, which teleports a 125 | -- bell state, and then measures it. 126 | test_teleport :: QIO (Bool,Bool) 127 | test_teleport = do 128 | (q1,q2) <- bell 129 | tq2 <- teleportation q2 130 | result <- measQ (q1,tq2) 131 | return result 132 | 133 | -- | teleports a qubit in the state |1> 134 | teleport_true' :: QIO Qbit 135 | teleport_true' = do q <- q1 136 | tq <- teleportation q 137 | return tq 138 | 139 | -- | teleports a qubit in the state |1>, and then measures it 140 | teleport_true :: QIO Bool 141 | teleport_true = do q <- teleport_true' 142 | result <- measQ q 143 | return result 144 | 145 | -- | teleports a qubit in the state |+> 146 | teleport_random' :: QIO Qbit 147 | teleport_random' = do q <- qPlus 148 | tq <- teleportation q 149 | return tq 150 | 151 | -- | teleports a qubit in the state |+>, and then measures it. 152 | teleport_random :: QIO Bool 153 | teleport_random = do q <- teleport_random' 154 | result <- measQ q 155 | return result 156 | 157 | ----------------------------------------------- 158 | ----- Deutsch's Algorithm --------------------- 159 | ----------------------------------------------- 160 | 161 | -- | The implementation of Deutsch's algorithm requires a unitary to represent 162 | -- the "oracle" function. 163 | u :: (Bool -> Bool) -> Qbit -> Qbit -> U 164 | u f x y = cond x (\ b -> if f b then unot y else mempty) 165 | 166 | -- | Deutsch's algorithm takes an "oracle" function, and returns a Boolean 167 | -- that states whether the given function is balanced, or consant. 168 | deutsch :: (Bool -> Bool) -> QIO Bool 169 | deutsch f = do 170 | x <- qPlus 171 | y <- qMinus 172 | applyU (u f x y) 173 | applyU (uhad x) 174 | measQ x 175 | 176 | ----------------------------------------------- 177 | 178 | -- | A test QIO computation that is infinite in one measurement path. This is 179 | -- a problem if we try to calculate the probability distribution of possible 180 | -- results, as the infinite path will be followed. 181 | problem :: QIO Bool 182 | problem = do q <- qPlus 183 | x <- measQ q 184 | if x then return x else problem 185 | -- can be run returning True, but cannot be simulated! 186 | -------------------------------------------------------------------------------- /QIO/QIORandom.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module implements various functions that return a probabilistic result, 3 | -- defined as unitary operators, and quantum computations. 4 | module QIO.QIORandom where 5 | 6 | import Data.Monoid as Monoid 7 | import QIO.QioSyn 8 | import QIO.Qdata 9 | import QIO.Qio 10 | import Data.Complex 11 | 12 | -- | The exponentiated Pauli-X rotation 13 | rX :: RR -> Rotation 14 | rX r (x,y) = if x==y then (cos (r/2):+0) else (0:+ (-(sin (r/2)))) 15 | 16 | -- | The exponentiated Pauli-Y rotation 17 | rY :: RR -> Rotation 18 | 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 19 | 20 | -- | Applies a Hadamard rotation to each qubit in the given list of qubits 21 | hadamards :: [Qbit] -> U 22 | hadamards [] = mempty 23 | hadamards (q:qs) = uhad q `mappend` hadamards qs 24 | 25 | -- | returns the highest integer power of 2 that is less than or equal to \x\ 26 | pow2 :: Int -> Int 27 | pow2 x = pow2' 0 28 | where pow2' y | 2^(y+1) > x = 2^y 29 | | otherwise = pow2' (y+1) 30 | 31 | -- | A rotation that, given a qubit in state 0, leaves it in a super-position of 32 | -- 0 and 1, such that the probability of measuring as state 0 is \ps\. 33 | weightedU :: RR -> Qbit -> U 34 | weightedU ps q | sqrt ps <= 1 = rot q (rX (2*(acos (sqrt ps)))) 35 | | otherwise = error ("weightedU: Invalid Probability: " ++ show ps) 36 | -- | A QIO computation that uses the "weightedU" unitary, to return a Bool that 37 | -- has a probablity of \pf\ of being False. 38 | weightedBool :: RR -> QIO Bool 39 | weightedBool pf = do q <- mkQbit False 40 | applyU (weightedU pf q) 41 | measQ q 42 | 43 | -- | removes any leading Falses from a list of booleans 44 | rlf :: [Bool] -> [Bool] 45 | rlf (False:bs) = rlf bs 46 | rlf bs = bs 47 | 48 | -- | removes any leading Falses from the (big-endian) bit-wise representation 49 | -- of the given Int. 50 | rlf_l :: Int -> [Bool] 51 | rlf_l x = rlf (reverse (int2bits x)) 52 | 53 | -- | returns the number of bits left after calling the "flf_l" function 54 | rlf_n :: Int -> Int 55 | rlf_n x = length (rlf_l x) 56 | 57 | -- | Given an Int \max\ that is the largest number required to be represented in 58 | -- a quantum register, this function trims the front off the given register, to 59 | -- leave the number of qubits required to represent \max\. 60 | trim :: Int -> [Qbit] -> [Qbit] 61 | trim max qbs = drop ((length qbs)-(rlf_n max)) qbs 62 | 63 | -- | Given an Int \max\, and a quantum register in the state \max\, this function 64 | -- defines a unitary operation that will leave the quantum register in state that 65 | -- has equal probability of being measured in any of the states 0 to \max\. 66 | randomU :: Int -> [Qbit] -> U 67 | randomU max qbs = randomU' max (trim max qbs) 68 | where 69 | randomU' _ [] = mempty 70 | randomU' 0 _ = mempty 71 | randomU' max (q:qbs) = weightedU (fromIntegral ((max+1)-p)/fromIntegral (max+1)) q 72 | `mappend` 73 | condQ q (\x -> if x then (randomU (max-p) qbs) 74 | else (hadamards qbs)) 75 | where p = pow2 max 76 | 77 | -- | A quantum computation that will return a quantum integer in a state that 78 | -- has equal probabilities of being measured in any of the state 0 to \max\. 79 | randomQInt :: Int -> QIO QInt 80 | randomQInt max = do 81 | qbs <- mkQ (reverse (int2bits max)) 82 | applyU (randomU max qbs) 83 | return (QInt (reverse qbs)) 84 | 85 | -- | A quantum computation that will return a quantum integer in a state that 86 | -- has equal probabilities of being measured in any of the state \min\ to \max\. 87 | randomQIO :: (Int,Int) -> QIO Int 88 | randomQIO (min,max) = do q <- randomInt (max-min) 89 | return (q + min) 90 | 91 | -- | A quantum computation that measures the outcome of "randomQInt" 92 | randomInt :: Int -> QIO Int 93 | randomInt max = do 94 | q <- randomQInt max 95 | measQ q 96 | 97 | -- | A quantum computation that returns an integer that is equally likely to be 98 | -- any number in the range 0 to \x\-1 99 | random :: Int -> QIO Int 100 | random x = randomInt (x-1) 101 | 102 | -- | This function uses a Quantum computation to simulate the roll of a dice 103 | dice :: IO Int 104 | dice = do 105 | x <- run (randomInt 5) 106 | return (x+1) 107 | 108 | -- | This function simulates the given number of repitions of dice rolls 109 | dice_rolls :: Int -> IO [Int] 110 | dice_rolls 0 = return [] 111 | dice_rolls y = do 112 | x <- dice 113 | xs <- dice_rolls (y-1) 114 | return (x:xs) 115 | 116 | -- | Returns the number of occurences of 1 through 6 in the given list of Ints 117 | occs :: [Int] -> (Int,Int,Int,Int,Int,Int) 118 | occs rs = (rs' 1,rs' 2,rs' 3,rs' 4,rs' 5,rs' 6) 119 | where 120 | rs' x = length ([y|y<-rs,y==x]) 121 | 122 | -- | Returns the number of occurences of 1 through 6 in the given number of 123 | -- rolls of the dice. 124 | probs' :: Int -> IO (Int,Int,Int,Int,Int,Int) 125 | probs' x = do 126 | xs <- dice_rolls x 127 | return (occs xs) 128 | 129 | -- | Returns the percentage of occurences of 1 through 6, after the given number 130 | -- of rolls of the dice. 131 | probs :: Int -> IO (RR,RR,RR,RR,RR,RR) 132 | probs x = do 133 | (a,b,c,d,e,f) <- probs' x 134 | return (fromIntegral a/x',fromIntegral b/x',fromIntegral c/x',fromIntegral d/x',fromIntegral e/x',fromIntegral f/x') 135 | where x' = fromIntegral x 136 | 137 | 138 | -------------------------------------------------------------------------------- /QIO/Qdata.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-} 2 | 3 | -- | This module defines a type class for quantum data types, as well as some 4 | -- instances of this class for pairs, lists, and quantum integers 5 | module QIO.Qdata where 6 | 7 | import Data.Monoid as Monoid 8 | import QIO.QioSyn 9 | 10 | -- | The 'Qdata' type class defines the operation a quantum datatype must implement. 11 | class Qdata a qa | a -> qa, qa -> a where 12 | mkQ :: a -> QIO qa 13 | measQ :: qa -> QIO a 14 | letU :: a -> (qa -> U) -> U 15 | condQ :: qa -> (a -> U) -> U 16 | 17 | -- | The lowest-level instance of Qdata is the relation between Booleans and Qubits. 18 | instance Qdata Bool Qbit where 19 | mkQ = mkQbit 20 | measQ = measQbit 21 | letU b xu = ulet b xu 22 | condQ q br = cond q br 23 | 24 | -- | A pair of quantum data types is itself a quantum data type. 25 | instance (Qdata a qa,Qdata b qb) => Qdata (a,b) (qa,qb) where 26 | 27 | mkQ (a,b) = do qa <- mkQ a 28 | qb <- mkQ b 29 | return (qa,qb) 30 | 31 | measQ (qa,qb) = do a <- measQ qa 32 | b <- measQ qb 33 | return (a,b) 34 | 35 | letU (a,b) xyu = letU a (\ x -> letU b (\ y -> xyu (x,y))) 36 | 37 | condQ (qa,qb) br = condQ qa (\x -> condQ qb (\y -> br (x,y))) 38 | 39 | -- | A list of quantum data is also a quantum data type 40 | instance Qdata a qa => Qdata [a] [qa] where 41 | mkQ n = sequence (map mkQ n) 42 | measQ qs = sequence (map measQ qs) 43 | letU as xsu = letU' as [] 44 | where letU' [] xs = xsu xs 45 | letU' (a:as) xs = letU a (\ x -> letU' as (xs++[x])) 46 | condQ qs qsu = condQ' qs [] 47 | where condQ' [] xs = qsu xs 48 | condQ' (a:as) xs = condQ a (\ x -> condQ' as (xs++[x])) 49 | 50 | -- | A recursive conditional on a list of quantum data 51 | condQRec :: Qdata a qa => [qa] -> [(a -> U)] -> U 52 | condQRec [] [] = mempty 53 | condQRec (q:qs) (u:us) = (condQ q u) `mappend` condQRec qs us 54 | 55 | -- | Quantum integers are of a fixed length, which is defined by this constant. 56 | -- Currently, this is set to 4. 57 | qIntSize :: Int 58 | qIntSize = 4 59 | 60 | -- | A Quantum integer is a wrapper around a fixed-length list of qubits 61 | newtype QInt = QInt [Qbit] deriving Show 62 | 63 | -- | Convert an integer to a list of Booleans 64 | int2bits :: Int -> [Bool] 65 | int2bits n = int2bits' n qIntSize 66 | where int2bits' 0 0 = [] 67 | int2bits' _ 0 = error "int2bits: too large" 68 | int2bits' n l = ((n `mod` 2) /= 0) : int2bits' (n `div` 2) (l-1) 69 | 70 | -- | Convert a list of Booleans to an integer 71 | bits2int :: [Bool] -> Int 72 | bits2int [] = 0 73 | bits2int (b:bs) = (2*bits2int bs)+(if b then 1 else 0) 74 | 75 | -- | quantum integers form a quantum data type, relating them to the classical 76 | -- Haskell Int type. 77 | instance Qdata Int QInt where 78 | mkQ n = do qn <- mkQ (int2bits n) 79 | return (QInt qn) 80 | measQ (QInt qbs) = 81 | do bs <- measQ qbs 82 | return (bits2int bs) 83 | letU n xu = letU (int2bits n) (\ bs -> xu (QInt bs)) 84 | condQ (QInt qi) qiu = condQ qi (\ x -> qiu (bits2int x)) 85 | -------------------------------------------------------------------------------- /QIO/Qft.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module provides an implementation of the Quantum Fourier Transform 3 | -- in QIO. 4 | module QIO.Qft where 5 | 6 | import Data.Monoid as Monoid 7 | import QIO.QioSyn 8 | import QIO.Qio 9 | import QIO.Qdata 10 | 11 | -- | Defines the unitary the represents appliying a Quantum Fourier Transform 12 | -- to the given quantum register. 13 | qft :: [Qbit] -> U 14 | qft qs = condQ qs (\bs -> qftAcu qs bs []) 15 | 16 | -- | The definition of the QFT unitary makes use of an accumulator, to repeatedly 17 | -- apply smaller QFTs to the tail of the given quantum register. 18 | qftAcu :: [Qbit] -> [Bool] -> [Bool] -> U 19 | qftAcu [] [] _ = mempty 20 | qftAcu (q:qs) (b:bs) cs = qftBase cs q `mappend` qftAcu qs bs (b:cs) 21 | 22 | -- | The \"base\" step involved in a QFT is a series of controlled rotations. 23 | qftBase :: [Bool] -> Qbit -> U 24 | qftBase bs q = f' bs q 2 25 | where f' [] q _ = uhad q 26 | f' (b:bs) q x = if b then (rotK x q) `mappend` f' bs q (x+1) 27 | else f' bs q (x+1) 28 | 29 | --need to change this into a conQRec??? 30 | -- e.g. qft [Qbit 0] 31 | -- = condQ [Qbit 0] (\(b:bs) -> uhad 0 `mappend` mempty) 32 | -- but gives cond 0 (\x -> if x then uhad 0 else uhad 0) which is forbidden 33 | 34 | -- | The rotation used in the QFT is a phase rotation, parameterised by the 35 | -- angle 1/(2^\k\) 36 | rotK :: Int -> Qbit -> U 37 | rotK k q = uphase q (1.0/(2.0^k)) 38 | 39 | -- | A test of the QFT unitary, over a quantum integer initialised to \n\. 40 | tryQft :: Int -> QIO Int 41 | tryQft n = do 42 | QInt qs <- mkQ n 43 | applyU(qft qs) 44 | x <- measQ (QInt qs) 45 | return x 46 | -------------------------------------------------------------------------------- /QIO/Qio.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module defines the functions that can be used to simulate the running of 3 | -- QIO computations. 4 | module QIO.Qio where 5 | 6 | import Data.List 7 | import qualified System.Random as Random 8 | import Data.Monoid as Monoid 9 | import Data.Maybe as Maybe 10 | import Control.Monad.State 11 | import QIO.QioSyn 12 | import QIO.Vec 13 | import QIO.VecEq 14 | import QIO.Heap 15 | import Control.Applicative (Applicative(..)) 16 | import Control.Monad (liftM, ap) 17 | 18 | -- | A "Pure" state can be thought of as a vector of classical basis states, stored 19 | -- as Heaps, along with complex amplitudes. 20 | type Pure = VecEqL CC HeapMap 21 | 22 | -- | The state of a qubit can be updated in a Pure state, by mapping the update 23 | -- operation over each Heap. 24 | updateP :: Pure -> Qbit -> Bool -> Pure 25 | updateP p x b = VecEqL (map (\ (h,pa) -> (update h x b,pa)) (unVecEqL p)) 26 | 27 | -- | A "Unitary" can be thought of as an operation on a HeapMap that may produce 28 | -- a Pure state. 29 | newtype Unitary = U {unU :: Int -> HeapMap -> Pure } 30 | 31 | -- | The Unitary type forms a Monoid 32 | instance Monoid Unitary where 33 | mempty = U (\ fv h -> unEmbed $ return h) 34 | mappend (U f) (U g) = U (\ fv h -> unEmbed $ do h' <- Embed $ f fv h 35 | h'' <- Embed $ g fv h' 36 | return h'' 37 | ) 38 | 39 | -- | A function that checks if a given "Rotation" is in face unitary. Note that 40 | -- this is currently a dummy stub function, and states that any rotation is 41 | -- unitary. (This is only o.k. at the moment as all the rotations defined in the 42 | -- QIO library are unitary, but won't catch un-unitary user-defined Rotations) 43 | unitaryRot :: Rotation -> Bool 44 | unitaryRot r = True 45 | -- TODO: update to check that the rotation is unitary... 46 | 47 | -- | Given the four complex numbers that make up a 2-by-2 matrix, we can create 48 | -- a Unitary that applies the rotation to the given qubit. 49 | uMatrix :: Qbit -> (CC,CC,CC,CC) -> Unitary 50 | uMatrix q (m00,m01,m10,m11) = U (\ fv h -> (if (fromJust(h ? q)) 51 | then (m01 <.> (unEmbed $ return (update h q False))) 52 | <+> (m11 <.> (unEmbed $ return h)) 53 | else (m00 <.> (unEmbed $ return h)) 54 | <+> (m10 <.> (unEmbed $ return (update h q True))))) 55 | 56 | -- | A rotation can be converted into a "Unitary", using the 'uMatrix' function 57 | uRot :: Qbit -> Rotation -> Unitary 58 | uRot q r = if (unitaryRot r) then (uMatrix q (r (False,False), 59 | r (False,True), 60 | r (True,False), 61 | r (True,True))) 62 | else error "Non unitary Rotation!" 63 | 64 | -- | A swap operation can be defined as a Unitary 65 | uSwap :: Qbit -> Qbit -> Unitary 66 | uSwap x y = U (\ fv h -> unEmbed $ return (hswap h x y )) 67 | 68 | -- | A conditional operation can be defined as a Unitary 69 | uCond :: Qbit -> (Bool -> Unitary) -> Unitary 70 | --uCond x us = U (\ fv h -> updateP (unU (us (h ? x)) fv (forget h x)) x (h ? x)) 71 | uCond x us = U (\ fv h -> unU (us (fromJust(h ? x))) fv h ) 72 | --whether or not to forget? (if not then no runtime error for conditionals) 73 | 74 | -- | A let operation can be defined as a Unitary 75 | uLet :: Bool -> (Qbit -> Unitary) -> Unitary 76 | uLet b ux = U (\fv h -> unU (ux (Qbit fv)) (fv + 1) (update h (Qbit fv) b)) 77 | --doesn't enforce unitary 78 | -- need Unitary -> [Qbit] ??? 79 | 80 | -- | Any member of the "U" type can be \"run\" by converting it into a Unitary. 81 | runU :: U -> Unitary 82 | runU UReturn = mempty 83 | runU (Rot x a u) = uRot x a `mappend` runU u 84 | runU (Swap x y u) = uSwap x y `mappend` runU u 85 | runU (Cond x us u) = uCond x (runU.us) `mappend` runU u 86 | runU (Ulet b xu u) = uLet b (runU.xu) `mappend` runU u 87 | 88 | -- | A quantum state is a defined as the next free qubit reference, along with the 89 | -- Pure state that represents the overall quantum state 90 | data StateQ = StateQ { free :: Int, pureState :: Pure } 91 | 92 | -- | The initial 'StateQ' 93 | initialStateQ :: StateQ 94 | initialStateQ = StateQ 0 (unEmbed $ return initial) 95 | 96 | -- | Given a Pure state, return a sum of all the amplitudes. 97 | pa :: Pure -> RR 98 | pa (VecEqL as) = foldr (\ (_,k) p -> p + amp k) 0 as 99 | 100 | -- | A Split, is defined as a probability, along with the two Pure states. 101 | data Split = Split { p :: RR, ifTrue,ifFalse :: Pure } 102 | 103 | -- | Given a Pure state, we can create a Split, by essentially splitting the 104 | -- state into the part where the qubit is True, and the part where the qubit is 105 | -- False. This is how measurements are implemented in QIO. 106 | split :: Pure -> Qbit -> Split 107 | split (VecEqL as) x = 108 | let pas = pa (VecEqL as) 109 | (ift',iff') = partition (\ (h,_) -> (fromJust(h ? x))) as 110 | ift = VecEqL ift' 111 | iff = VecEqL iff' 112 | p_ift = if pas==0 then 0 else (pa ift)/pas 113 | in Split p_ift ift iff 114 | 115 | -- | We can extend a Monad into a PMonad if it defines a way of probabilistically 116 | -- merging two computations, based on a given probability. 117 | class Monad m => PMonad m where 118 | merge :: RR -> m a -> m a -> m a 119 | 120 | -- | IO forms a PMonad, using the random number generator to pick one of the 121 | -- \"merged\" computations probabilistically. 122 | instance PMonad IO where 123 | merge pr ift iff = do pp <- Random.randomRIO (0,1.0) 124 | if pr > pp then ift else iff 125 | 126 | -- | The type Prob is defined as a wrapper around Vectors with Real probabilities. 127 | data Prob a = Prob {unProb :: Vec RR a} 128 | 129 | -- | We can show a probability distribution by filtering out elements with 130 | -- a zero probability. 131 | instance Show a => Show (Prob a) where 132 | show (Prob (Vec ps)) = show (filter (\ (a,p) -> p>0) ps) 133 | 134 | instance Functor Prob where 135 | fmap = liftM 136 | 137 | instance Applicative Prob where 138 | pure = Prob . return 139 | (<*>) = ap 140 | 141 | -- | Prob forms a Monad 142 | instance Monad Prob where 143 | return = pure 144 | (Prob ps) >>= f = Prob (ps >>= unProb . f) 145 | 146 | -- | Prob is also a PMonad, where the result of both computations are combined into 147 | -- a probability distribution. 148 | instance PMonad Prob where 149 | merge pr (Prob ift) (Prob iff) = Prob ((pr <**> ift) <++> ((1-pr) <**> iff)) 150 | 151 | -- | Given a PMonad, a QIO Computation can be converted into a Stateful computation 152 | -- over a quantum state (of type 'StateQ'). 153 | evalWith :: PMonad m => QIO a -> State StateQ (m a) 154 | evalWith (QReturn a) = return (return a) 155 | evalWith (MkQbit b g) = do (StateQ f p) <- get 156 | put (StateQ (f+1) (updateP p (Qbit f) b)) 157 | evalWith (g (Qbit f)) 158 | evalWith (ApplyU u q) = do (StateQ f p) <- get 159 | put (StateQ f (unEmbed $ do x <- Embed $ p 160 | x' <-Embed $ uu f x 161 | return x' 162 | ) 163 | ) 164 | evalWith q 165 | where U uu = runU u 166 | evalWith (Meas x g) = do (StateQ f p) <- get 167 | (let Split pr ift iff = split p x 168 | in if pr < 0 || pr > 1 then error "pr < 0 or >1" 169 | else do put (StateQ f ift) 170 | pift <- evalWith (g True) 171 | put (StateQ f iff) 172 | piff <- evalWith (g False) 173 | return (merge pr pift piff)) 174 | 175 | -- | A QIO computation is evaluated by converting it into a stateful computation 176 | -- and then evaluating that over the initial state. 177 | eval :: PMonad m => QIO a -> m a 178 | eval p = evalState (evalWith p) initialStateQ 179 | 180 | -- | Running a QIO computation evaluates it in the IO PMonad 181 | run :: QIO a -> IO a 182 | run = eval 183 | 184 | -- | Simulating a QIO computation evaluates it in the Prob PMonad 185 | sim :: QIO a -> Prob a 186 | sim = eval 187 | -------------------------------------------------------------------------------- /QIO/QioClass.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module defines the functions that can be used run the classical subset 3 | -- of QIO. That is, QIO computations that only use classical unitary operations. 4 | module QIO.QioClass where 5 | 6 | import Data.Maybe as Maybe 7 | import Data.Monoid as Monoid 8 | import Control.Monad.State 9 | import QIO.QioSyn 10 | import QIO.Heap 11 | 12 | -- | A classical unitary operation is defined as a function that will 13 | -- update the current classical state. 14 | newtype UnitaryC = U {unU :: Int -> HeapMap -> HeapMap} 15 | 16 | -- | The classical unitary type forms a Monoid 17 | instance Monoid UnitaryC where 18 | mempty = U (\ fv bs -> bs) 19 | mappend (U f) (U g) = U (\ fv h -> g fv (f fv h)) 20 | 21 | -- | A single qubit rotation can be converted into the classical unitary type, 22 | -- if it is indeed classical (otherwise an error is thrown). 23 | uRotC :: Qbit -> Rotation -> UnitaryC 24 | uRotC x f | f==rnot = U (\ _ h -> update h x (not (fromJust (h ? x)))) 25 | | f==rid = mempty 26 | | otherwise = error "not classical" 27 | 28 | -- | A swap operation can be defined in the classical unitary type. 29 | uSwapC :: Qbit -> Qbit -> UnitaryC 30 | uSwapC x y = U (\ _ h -> hswap h x y ) 31 | 32 | -- | A conditional operation can be defined in the classical unitary type. 33 | uCondC :: Qbit -> (Bool -> UnitaryC) -> UnitaryC 34 | uCondC x br = U (\ fv h -> update (unU (br (fromJust (h ? x))) fv (forget h x)) x (fromJust (h ? x))) 35 | 36 | -- | A let operation can be defined in the classical unitary type. 37 | uLetC :: Bool -> (Qbit -> UnitaryC) -> UnitaryC 38 | uLetC b ux = U (\ fv h -> unU (ux (Qbit fv)) (fv+1) (update h (Qbit fv) b)) 39 | 40 | -- | A unitary can be run by converting it into the classical unitary type. 41 | runUC :: U -> UnitaryC 42 | runUC UReturn = mempty 43 | runUC (Rot x r u) = uRotC x r `mappend` runUC u 44 | runUC (Swap x y u) = uSwapC x y `mappend` runUC u 45 | runUC (Cond x us u) = uCondC x (runUC.us) `mappend` runUC u 46 | runUC (Ulet b xu u) = uLetC b (runUC.xu) `mappend` runUC u 47 | 48 | -- | A classical state consists of the next free qubit reference, along with 49 | -- a Heap that represents the overall state of the current qubits in scope. 50 | data StateC = StateC {fv :: Int, heap :: HeapMap} 51 | 52 | -- | An initial state is defined as an empty heap, with 0 set as the next 53 | -- free qubit referece 54 | initialStateC :: StateC 55 | initialStateC = StateC 0 initial 56 | 57 | -- | A QIO computation can be converted into a stateful computation, over 58 | -- a state of type "StateC". 59 | runQStateC :: QIO a -> State StateC a 60 | runQStateC (QReturn a) = return a 61 | runQStateC (MkQbit b xq) = do (StateC fv h) <- get 62 | put (StateC (fv+1) (update h (Qbit fv) b)) 63 | runQStateC (xq (Qbit fv)) 64 | runQStateC (ApplyU u q) = do (StateC fv h) <- get 65 | put (StateC fv (unU (runUC u) fv h)) 66 | runQStateC q 67 | runQStateC (Meas x qs) = do (StateC _ h) <- get 68 | runQStateC (qs (fromJust (h ? x))) 69 | 70 | -- | We can run a classical QIO computation by converting it into a stateful 71 | -- computation, and evaluating that using the initial state. 72 | runC :: QIO a -> a 73 | runC q = evalState (runQStateC q) initialStateC 74 | 75 | 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /QIO/QioSyn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} 2 | 3 | -- | This module defines the Syntax of the Quantum IO Monad, which is an embedded 4 | -- language for writing quantum computations. 5 | module QIO.QioSyn where 6 | 7 | import Data.Monoid as Monoid 8 | import Data.Complex 9 | import Control.Applicative (Applicative(..)) 10 | import Control.Monad (liftM, ap) 11 | 12 | -- | For Real numbers, we simply use the built in Double type 13 | type RR = Double 14 | 15 | -- | For Complex numbers, we use the built in Complex numbers, over our Real 16 | -- number type (i.e. Double) 17 | type CC = Complex RR 18 | 19 | -- | The amplitude of a complex number is the magnitude squared. 20 | amp :: CC -> RR 21 | amp k = (magnitude k)*(magnitude k) 22 | 23 | -- | The type of Qubits in QIO are simply integer references. 24 | newtype Qbit = Qbit Int deriving (Num, Enum, Eq, Ord) 25 | 26 | 27 | -- | A rotation is in essence a two-by-two complex valued matrix 28 | type Rotation = ((Bool,Bool) -> CC) 29 | 30 | -- | The underlying data type of a U unitary operation 31 | data U = UReturn | Rot Qbit Rotation U 32 | | Swap Qbit Qbit U | Cond Qbit (Bool -> U) U | Ulet Bool (Qbit -> U) U 33 | 34 | -- | The underlying data type of a QIO Computation 35 | data QIO a = QReturn a | MkQbit Bool (Qbit -> QIO a) | ApplyU U (QIO a) 36 | | Meas Qbit (Bool -> QIO a) 37 | 38 | -- | The type "U" forms a Monoid 39 | instance Monoid U where 40 | mempty = UReturn 41 | mappend UReturn u = u 42 | mappend (Rot x a u) u' = Rot x a (mappend u u') 43 | mappend (Swap x y u) u' = Swap x y (mappend u u') 44 | mappend (Cond x br u') u'' = Cond x br (mappend u' u'') 45 | mappend (Ulet b f u) u' = Ulet b f (mappend u u') 46 | 47 | -- | Apply the given rotation to the given qubit 48 | rot :: Qbit -> Rotation -> U 49 | rot x r = Rot x r UReturn 50 | 51 | -- | Swap the state of the two given qubits 52 | swap :: Qbit -> Qbit -> U 53 | swap x y = Swap x y UReturn 54 | 55 | -- | Apply the conditional unitary, depending on the value of the given qubit 56 | cond :: Qbit -> (Bool -> U) -> U 57 | cond x br = Cond x br UReturn 58 | 59 | -- | Introduce an Ancilla qubit in the given state, for use in the sub-unitary 60 | ulet :: Bool -> (Qbit -> U) -> U 61 | ulet b ux = Ulet b ux UReturn 62 | 63 | -- | Returns the inverse (or reverse) of the given unitary operation 64 | urev :: U -> U 65 | urev UReturn = UReturn 66 | urev (Rot x r u) = urev u `mappend` rot x (rrev r) 67 | urev (Swap x y u) = urev u `mappend` swap x y 68 | urev (Cond x br u) = urev u `mappend` cond x (urev.br) 69 | urev (Ulet b xu u) = urev u `mappend` ulet b (urev.xu) 70 | 71 | -- | Apply a not rotation to the given qubit 72 | unot :: Qbit -> U 73 | unot x = rot x rnot 74 | 75 | -- | Apply a hadamard rotation to the given qubit 76 | uhad :: Qbit -> U 77 | uhad x = rot x rhad 78 | 79 | -- | Apply a phase rotation (of the given angle) to the given qubit 80 | uphase :: Qbit -> RR -> U 81 | uphase x r = rot x (rphase r) 82 | 83 | instance Functor QIO where 84 | fmap = liftM 85 | 86 | instance Applicative QIO where 87 | pure = QReturn 88 | (<*>) = ap 89 | 90 | -- | The "QIO" type forms a Monad 91 | instance Monad QIO where 92 | return = pure 93 | (QReturn a) >>= f = f a 94 | (MkQbit b g) >>= f = MkQbit b (\ x -> g x >>= f) 95 | (ApplyU u q) >>= f = ApplyU u (q >>= f) 96 | (Meas x g) >>= f = Meas x (\ b -> g b >>= f) 97 | 98 | -- | Initialise a qubit in the given state (adding it to the overall quantum state) 99 | mkQbit :: Bool -> QIO Qbit 100 | mkQbit b = MkQbit b return 101 | 102 | -- | Apply the given unitary operation to the current quantum state 103 | applyU :: U -> QIO () 104 | applyU u = ApplyU u (return ()) 105 | 106 | -- | Measure the given qubit, and return the measurement outcome (note that this 107 | -- operation may affect the overall quantum state, as a measurement is destructive) 108 | measQbit :: Qbit -> QIO Bool 109 | measQbit x = Meas x return 110 | 111 | 112 | -- | The identity rotation 113 | rid :: Rotation 114 | rid (x,y) = if x==y then 1 else 0 115 | 116 | -- | The not rotation 117 | rnot :: Rotation 118 | rnot (x,y) = if x==y then 0 else 1 119 | 120 | -- | The hadamard rotation 121 | rhad :: Rotation 122 | rhad (x,y) = if x && y then -h else h where h = (1/sqrt 2) 123 | 124 | -- | The phase rotation 125 | rphase :: RR -> Rotation 126 | rphase _ (False,False) = 1 127 | rphase r (True,True) = exp(0:+r) 128 | rphase _ (_,_) = 0 129 | 130 | -- | Returns the inverse (or reverse) of the given rotation 131 | rrev :: Rotation -> Rotation 132 | rrev r (False,True) = conjugate (r (True,False)) 133 | rrev r (True,False) = conjugate (r (False,True)) 134 | rrev r xy = conjugate (r xy) 135 | 136 | -- | Rotations can be compared for equality. 137 | -- They are equal if the define the same matrix. 138 | instance Eq Rotation where 139 | f == g = (f (False,False) == g (False,False)) 140 | && (f (False,True) == g (False,True)) 141 | && (f (True,False) == g (True,False)) 142 | && (f (True,True) == g (True,True)) 143 | f /= g = (f (False,False) /= g (False,False)) 144 | || (f (False,True) /= g (False,True)) 145 | || (f (True,False) /= g (True,False)) 146 | || (f (True,True) /= g (True,True)) 147 | 148 | 149 | -- | We can display a qubit reference 150 | instance Show Qbit where 151 | show (Qbit q) = "(Qbit:" ++ show q ++ ")" 152 | 153 | -- | We can display the matrix representation of a rotation 154 | instance Show Rotation where 155 | show f = "(" ++ (show (f (False,False))) ++ "," ++ (show (f (False,True))) ++ "," ++ (show (f (True,False))) ++ "," ++ (show (f (True,True))) ++ ")" 156 | 157 | -- | We can display a representation of a unitary 158 | instance Show U where 159 | show u = show' u 0 (-1) 160 | 161 | -- | A helper function for the show instance of U 162 | show' :: U -> Int -> Int -> String 163 | show' (UReturn) x fv = "" 164 | show' (Rot q a u) x fv = spaces x ++ "Rotate " ++ show q ++ " by " ++ show a ++ ".\n" ++ show' u x fv 165 | show' (Swap q1 q2 u) x fv = spaces x ++ "Swap " ++ show q1 ++ " and " ++ show q2 ++ ".\n" ++ show' u x fv 166 | 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 167 | 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 168 | 169 | -- | A helper function that returns a string of 4\x\ spaces. 170 | spaces :: Int -> String 171 | spaces 0 = "" 172 | spaces n = if (n < 0) then error "spaces: negative argument" 173 | else " " ++ spaces (n-1) 174 | 175 | -------------------------------------------------------------------------------- /QIO/QioSynAlt.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeSynonymInstances #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | -- | This module defines the Syntax of the Quantum IO Monad, which is 6 | -- an embedded language for writing quantum computations. It is an 7 | -- alternative definition using the approach of defining F-Algebras. 8 | module QIO.QioSynAlt where 9 | 10 | import Data.Monoid as Monoid 11 | import Data.Complex 12 | import Control.Applicative (Applicative(..)) 13 | import Control.Monad (liftM, ap) 14 | 15 | -- | For Real numbers, we simply use the built in Double type 16 | type RR = Double 17 | 18 | -- | For Complex numbers, we use the built in Complex numbers, over our Real 19 | -- number type (i.e. Double) 20 | type CC = Complex RR 21 | 22 | -- | The amplitude of a complex number is the magnitude squared. 23 | amp :: CC -> RR 24 | amp k = (magnitude k)*(magnitude k) 25 | 26 | -- | The type of Qubits in QIO are simply integer references. 27 | newtype Qbit = Qbit Int deriving (Num, Enum, Eq, Ord) 28 | 29 | -- | We can display a qubit reference 30 | instance Show Qbit where 31 | show (Qbit q) = "(Qbit:" ++ show q ++ ")" 32 | 33 | -- | A rotation is in essence a two-by-two complex valued matrix 34 | type Rotation = ((Bool,Bool) -> CC) 35 | 36 | -- | We can display the matrix representation of a rotation 37 | instance Show Rotation where 38 | show f = "(" ++ (show (f (False,False))) ++ "," ++ (show (f (False,True))) ++ "," ++ (show (f (True,False))) ++ "," ++ (show (f (True,True))) ++ ")" 39 | 40 | -- | The identity rotation 41 | rid :: Rotation 42 | rid (x,y) = if x==y then 1 else 0 43 | 44 | -- | The not rotation 45 | rnot :: Rotation 46 | rnot (x,y) = if x==y then 0 else 1 47 | 48 | -- | The hadamard rotation 49 | rhad :: Rotation 50 | rhad (x,y) = if x && y then -h else h where h = (1/sqrt 2) 51 | 52 | -- | The phase rotation 53 | rphase :: RR -> Rotation 54 | rphase _ (False,False) = 1 55 | rphase r (True,True) = exp(0:+r) 56 | rphase _ (_,_) = 0 57 | 58 | -- | Returns the inverse (or reverse) of the given rotation 59 | rrev :: Rotation -> Rotation 60 | rrev r (False,True) = conjugate (r (True,False)) 61 | rrev r (True,False) = conjugate (r (False,True)) 62 | rrev r xy = conjugate (r xy) 63 | 64 | -- | Rotations can be compared for equality. 65 | -- They are equal if the define the same matrix. 66 | instance Eq Rotation where 67 | f == g = (f (False,False) == g (False,False)) 68 | && (f (False,True) == g (False,True)) 69 | && (f (True,False) == g (True,False)) 70 | && (f (True,True) == g (True,True)) 71 | f /= g = (f (False,False) /= g (False,False)) 72 | || (f (False,True) /= g (False,True)) 73 | || (f (True,False) /= g (True,False)) 74 | || (f (True,True) /= g (True,True)) 75 | 76 | -- | The non-recursive data type definition of a unitary operation 77 | data UFunctor u = UReturn 78 | | Rot Qbit Rotation u 79 | | Swap Qbit Qbit u 80 | | Cond Qbit (Bool -> u) u 81 | | Ulet Bool (Qbit -> u) u 82 | 83 | -- | In order to define an F-Algebra, 'UFunctor' must be a functor. 84 | instance Functor UFunctor where 85 | fmap eval UReturn = UReturn 86 | fmap eval (Rot q r u) = Rot q r (eval u) 87 | fmap eval (Swap q1 q2 u) = Swap q1 q2 (eval u) 88 | fmap eval (Cond q f u) = Cond q (eval . f) (eval u) 89 | fmap eval (Ulet b f u) = Ulet b (eval . f) (eval u) 90 | 91 | -- | The fix point type construtor. 92 | newtype Fix f = Fx (f (Fix f)) 93 | 94 | -- | We can define the inverse of Fx 95 | unFix :: Fix f -> f (Fix f) 96 | unFix (Fx x) = x 97 | 98 | -- | We fix the non-recursice data-type in order to get our type 'U' 99 | -- of unitary operations. 100 | type U = Fix UFunctor 101 | 102 | -- | The type of an F-Algebra. 103 | type Algebra f a = f a -> a 104 | 105 | -- | The type of the initial algebra for UFunctor 106 | type UInitialAlgebra = Algebra UFunctor U 107 | 108 | -- | We can now define the initial algebra for U 109 | uInitialAlgebra :: UInitialAlgebra 110 | uInitialAlgebra = Fx 111 | 112 | -- | We can use a catamorphism to abstract evaluation over a given 113 | -- algebra 114 | cata :: Functor f => Algebra f a -> Fix f -> a 115 | cata algebra = algebra . fmap (cata algebra) . unFix 116 | 117 | -- | The type "U" forms a Monoid. 118 | instance Monoid U where 119 | mempty = Fx UReturn 120 | mappend (Fx UReturn) u = u 121 | mappend (Fx (Rot x a u)) u' = Fx $ Rot x a (mappend u u') 122 | mappend (Fx (Swap x y u)) u' = Fx $ Swap x y (mappend u u') 123 | mappend (Fx (Cond x br u')) u'' = Fx $ Cond x br (mappend u' u'') 124 | mappend (Fx (Ulet b f u)) u' = Fx $ Ulet b f (mappend u u') 125 | 126 | -- | Apply the given rotation to the given qubit 127 | rot :: Qbit -> Rotation -> U 128 | rot x r = Fx $ Rot x r mempty 129 | 130 | -- | Swap the state of the two given qubits 131 | swap :: Qbit -> Qbit -> U 132 | swap x y = Fx $ Swap x y mempty 133 | 134 | -- | Apply the conditional unitary, depending on the value of the given qubit 135 | cond :: Qbit -> (Bool -> U) -> U 136 | cond x br = Fx $ Cond x br mempty 137 | 138 | -- | Introduce an Ancilla qubit in the given state, for use in the sub-unitary 139 | ulet :: Bool -> (Qbit -> U) -> U 140 | ulet b ux = Fx $ Ulet b ux mempty 141 | 142 | -- | Apply a not rotation to the given qubit 143 | unot :: Qbit -> U 144 | unot x = rot x rnot 145 | 146 | -- | Apply a hadamard rotation to the given qubit 147 | uhad :: Qbit -> U 148 | uhad x = rot x rhad 149 | 150 | -- | Apply a phase rotation (of the given angle) to the given qubit 151 | uphase :: Qbit -> RR -> U 152 | uphase x r = rot x (rphase r) 153 | 154 | -- | Returns the inverse (or reverse) of the given unitary operation, 155 | -- using an F-Algebra 156 | urev :: U -> U 157 | urev = cata urev_algebra 158 | where 159 | urev_algebra :: UFunctor U -> U 160 | urev_algebra UReturn = Fx UReturn 161 | urev_algebra (Rot x r u) = u `mappend` rot x (rrev r) 162 | urev_algebra (Swap x y u) = u `mappend` swap x y 163 | urev_algebra (Cond x br u) = u `mappend` cond x br 164 | urev_algebra (Ulet b xu u) = u `mappend` ulet b xu 165 | 166 | -- | We can display a representation of a unitary, using an F-Algebra 167 | instance Show U where 168 | show = cata showU_algebra 169 | where 170 | showU_algebra :: UFunctor String -> String 171 | showU_algebra UReturn = "" 172 | showU_algebra (Rot q r u) = 173 | "Rotate " ++ show q ++ ":" ++ show r ++ "\n" ++ u 174 | showU_algebra (Swap q1 q2 u) = 175 | "Swap " ++ show q1 ++ " and " ++ show q2 ++ "\n" ++ u 176 | showU_algebra (Cond q br u) = 177 | "Cond " ++ show q ++ " \\b -> if b then (\n" 178 | ++ unlines (map (' ':) (lines $ br True)) 179 | ++ ") else (\n" 180 | ++ unlines (map (' ':) (lines $ br False)) 181 | ++ ")\n" ++ u 182 | showU_algebra (Ulet b xu u) = 183 | let fv = find_fv xu in 184 | "Ulet " ++ show fv ++ " = " ++ (if b then "1" else "0") ++ " in (\n" 185 | ++ unlines (map (' ':) (lines $ xu fv)) 186 | ++ ")\n" ++ u 187 | -- this is currently a dummy function 188 | find_fv :: (Qbit -> String) -> Qbit 189 | find_fv _ = -1 190 | 191 | -- | The non-recursive data type definition of a QIO computation 192 | data QIOFunctor a q = QReturn a 193 | | MkQbit Bool (Qbit -> q) 194 | | ApplyU U q 195 | | Meas Qbit (Bool -> q) 196 | 197 | -- | In order to define an F-Algebra, 'UF' must be a functor. 198 | instance Functor (QIOFunctor a) where 199 | fmap eval (QReturn a) = QReturn a 200 | fmap eval (MkQbit b f) = MkQbit b (eval . f) 201 | fmap eval (ApplyU u q) = ApplyU u (eval q) 202 | fmap eval (Meas q f) = Meas q (eval . f) 203 | 204 | -- | We fix the non-recursice data-type in order to get our type 'U' 205 | -- of unitary operations. 206 | type QIOprim a = Fix (QIOFunctor a) 207 | 208 | -- | The type of the initial algebra for UFunctor 209 | type QIOInitialAlgebra a = Algebra (QIOFunctor a) (QIOprim a) 210 | 211 | -- | We can now define the initial algebra for U 212 | qioInitialAlgebra :: QIOInitialAlgebra a 213 | qioInitialAlgebra = Fx 214 | 215 | -- | The "QIO" type forms a Monad, by wrapping 'QIOprim' 216 | data QIO a = Apply (Fix (QIOFunctor a)) 217 | 218 | -- | We can remove the wrapper. 219 | primQIO :: QIO a -> QIOprim a 220 | primQIO (Apply q) = q 221 | 222 | instance Functor QIO where 223 | fmap = liftM 224 | 225 | instance Applicative QIO where 226 | pure = Apply . Fx . QReturn 227 | (<*>) = ap 228 | 229 | -- | The wrapper type 'ApplyFix' forms a Monad 230 | instance Monad QIO where 231 | return = pure 232 | (Apply (Fx (QReturn a))) >>= f = f a 233 | (Apply (Fx (MkQbit b g))) >>= f = Apply . Fx $ 234 | MkQbit b (\q -> primQIO $ (Apply (g q)) >>= f) 235 | (Apply (Fx (ApplyU u q))) >>= f = Apply . Fx $ 236 | ApplyU u $ primQIO (Apply q >>= f) 237 | (Apply (Fx (Meas x g))) >>= f = Apply . Fx $ 238 | Meas x (\b -> primQIO $ (Apply (g b)) >>= f) 239 | 240 | -- | Initialise a qubit in the given state (adding it to the overall quantum state) 241 | mkQbit :: Bool -> QIO Qbit 242 | mkQbit b = Apply . Fx $ MkQbit b (\q -> primQIO (return q)) 243 | 244 | -- | Apply the given unitary operation to the current quantum state 245 | applyU :: U -> QIO () 246 | applyU u = Apply . Fx $ ApplyU u $ primQIO (return ()) 247 | 248 | -- | Measure the given qubit, and return the measurement outcome (note that this 249 | -- operation may affect the overall quantum state, as a measurement is destructive) 250 | measQbit :: Qbit -> QIO Bool 251 | measQbit x = Apply . Fx $ Meas x (\b -> primQIO (return b)) 252 | 253 | -- | We can show a QIO computation, using an F-Algebra 254 | instance (Show a) => Show (QIO a) where 255 | show = (cata showQIO_algebra) . primQIO 256 | where 257 | showQIO_algebra :: (Show a) => Algebra (QIOFunctor a) String 258 | showQIO_algebra (QReturn a) = 259 | "Return: " ++ show a ++ "\n" 260 | showQIO_algebra (MkQbit b f) = 261 | "Init" ++ (if b then "1" else "0") ++ "\n" 262 | ++ f 0 263 | showQIO_algebra (ApplyU u qio) = 264 | "Apply Unitary: (\n" 265 | ++ unlines (map (' ':) (lines $ show u)) 266 | ++ ")\n" ++ qio 267 | showQIO_algebra (Meas q f) = 268 | "Measure " ++ show q ++ " \\b -> if b then (\n" 269 | ++ unlines (map (' ':) (lines $ f True)) 270 | ++ ") else (\n" 271 | ++ unlines (map (' ':) (lines $ f False)) 272 | ++ ")\n" 273 | 274 | -- | We can count the number of each primitive operation using an F-Algebra 275 | count :: QIO a -> (Int,Int,Int) 276 | count = (cata count_algebra) . primQIO 277 | where 278 | count_algebra :: Algebra (QIOFunctor a) (Int,Int,Int) 279 | count_algebra (QReturn _) = (0,0,0) 280 | count_algebra (MkQbit b f) = let (mk,ap,ms) = f 0 in 281 | (mk+1,ap,ms) 282 | count_algebra (ApplyU _ (mk,ap,ms)) = (mk,ap+1,ms) 283 | count_algebra (Meas q f) = let (mk,ap,ms) = f False in 284 | (mk,ap,ms+1) 285 | 286 | toffoli :: Qbit -> Qbit -> Qbit -> U 287 | toffoli q1 q2 q3 = 288 | cond q1 (\b1 -> if b1 then ( 289 | cond q2 (\b2 -> if b2 then (unot q3) 290 | else mempty)) else mempty) 291 | 292 | and :: Bool -> Bool -> QIO Bool 293 | and a b = do 294 | q1 <- mkQbit a 295 | q2 <- mkQbit b 296 | q3 <- mkQbit False 297 | applyU (toffoli q1 q2 q3) 298 | measQbit q3 299 | -------------------------------------------------------------------------------- /QIO/Shor.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | This module defines the QIO computation that represents Shor's factorisation 3 | -- algorithm. It makes use of the Arithmetic library, and the Quantum Fourier 4 | -- Transform. 5 | module QIO.Shor where 6 | 7 | import Data.Monoid as Monoid 8 | import QIO.QIORandom 9 | import QIO.QioSyn 10 | import QIO.Qdata 11 | import QIO.Qio 12 | import QIO.QExamples 13 | import QIO.QArith 14 | import QIO.Qft 15 | import System.Time 16 | 17 | -- | The inverse Quantum Fourier Transform is defined by reversing the QFT 18 | qftI :: QInt -> U 19 | qftI (QInt i) = urev (qft i) 20 | 21 | -- | The Hadamard transform can be mapped over the qubits in a Quantum Integer. 22 | hadamardsI :: QInt -> U 23 | hadamardsI (QInt xs) = hadamards xs 24 | 25 | -- | The overall \"phase-estimation\" structure of Shor's algorithm. 26 | shorU :: QInt -> QInt -> Int -> Int -> U 27 | shorU k i1 x n = hadamardsI k `mappend` modExp n x k i1 `mappend` qftI k 28 | 29 | -- | A quantum computation the implementes shor's algorithm, returning the period 30 | -- of the function. 31 | shor :: Int -> Int -> QIO Int 32 | shor x n = do 33 | i0 <- mkQ 0 34 | i1 <- mkQ 1 35 | applyU (shorU i0 i1 x n) 36 | measQ i0 37 | 38 | -- | A classical (inefficient) implementation of the period finding subroutine 39 | period :: Int -> Int -> Int 40 | period m q = r where (_,r) = reduce (m,q) 41 | 42 | -- | A wrapper for Shor's algorithm, that returns prime factors of \n\. 43 | factor :: Int -> QIO (Int,Int) 44 | factor n | even n = return (2,2) 45 | | otherwise = do x <- rand_coprime n 46 | a <- shor x n 47 | let xa = x^(half a) 48 | in if odd a || xa == (n-1) `mod` n || a == 0 49 | then factor n 50 | else return (gcd (xa+1) n,gcd (xa-1) n) 51 | --this function can only be run too, for similar reasons to the rand_co' 52 | --function below 53 | 54 | -- | This function simulates the running of a QIO computation, whilst using 55 | -- System.Time functions to time how long the simulation took. 56 | runTime :: QIO a -> IO a 57 | runTime a = do 58 | start <- getClockTime 59 | result <- run a 60 | stop <- getClockTime 61 | putStr ("The total time taken was " ++ (timeDiffToString (diffClockTimes stop start) ++ "\n")) 62 | return result 63 | 64 | -- | Times the running of various subroutines within the factorisation algorithm. 65 | factorV' :: Int -> IO (Int,Int) 66 | factorV' n | even n = return (2,2) 67 | | otherwise = do 68 | start <- getClockTime 69 | putStr ("Started at " ++ (show start) ++ "\n") 70 | x <- run (rand_coprime n) 71 | putStr ("Calling \"shor " ++ show x ++ " " ++ show n ++ "\"\n") 72 | a <- run (shor x n) 73 | stop <- getClockTime 74 | putStr ("Shor took " ++ (timeDiffToString (diffClockTimes stop start)) ++ "\n") 75 | putStr ("period a = " ++ show a) 76 | let xa = x^(half a) 77 | in do putStr (", giving xa = " ++ show xa ++ "\n") 78 | if odd a || xa == (n-1) `mod` n || (gcd (xa+1) n,gcd (xa-1) n) == (1,n) || (gcd (xa+1) n,gcd (xa-1) n) == (n,1) || (gcd (xa+1) n,gcd (xa-1) n) == (1,1) 79 | then do putStr "Recalling factorV\n" 80 | factorV' n 81 | else do putStr "Result: " 82 | return (gcd (xa+1) n,gcd (xa-1) n) 83 | 84 | -- | Calls the 'factorV'', and times the overall factorisation. 85 | factorV :: Int -> IO () 86 | factorV n = do start <- getClockTime 87 | (a,b) <- factorV' n 88 | stop <- getClockTime 89 | putStr ( "Factors of " 90 | ++ (show n) 91 | ++ " include " 92 | ++ (show a) 93 | ++ " and " 94 | ++ (show b) 95 | ++ ".\n The total time taken was " 96 | ++ (timeDiffToString (diffClockTimes stop start) ++ "\n")) 97 | 98 | -- | This function defines a quantum computation that returns a random index, that 99 | -- is used to pick from a list of integers that are co-prime to \n\. 100 | rand_coprime :: Int -> QIO Int 101 | rand_coprime n = do x <- randomQIO (0,(length cps)-1) 102 | return (cps!!x) 103 | where cps = [x | x <- [0..n], gcd x n == 1] 104 | 105 | -- | A different implementation of "rand_coprime", that defines a quantum 106 | -- computation that returns a random number between 2 and \n\, that is then 107 | -- returned if it is co-prime to \n\. 108 | rand_co' :: Int -> QIO Int 109 | rand_co' n = do 110 | x <- randomQIO (2,n) 111 | if gcd x n == 1 then return x else rand_co' n 112 | --simulating this (with the sim function) gives rise to infinite paths in 113 | --the computation, e.g. each path where gcd x n /= 1. However, this function 114 | --can still be run (with the run function) always returning a single value. 115 | 116 | -- | Integer division by 2. 117 | half :: Int -> Int 118 | half x = floor (fromIntegral x/2.0) 119 | 120 | -- | Reduces a pair of integers, by dividing them by thier gcd, 121 | -- until their gcd is 1. 122 | reduce :: (Int,Int) -> (Int,Int) 123 | reduce (x,y) = if g == 1 then (x,y) else (floor ((fromIntegral x)/(fromIntegral g)),floor ((fromIntegral y)/(fromIntegral g))) 124 | where g = gcd x y 125 | 126 | 127 | 128 | 129 | 130 | 131 | -------------------------------------------------------------------------------- /QIO/Vec.hs: -------------------------------------------------------------------------------- 1 | -- | This module defines a Vector as a list of pairs. 2 | -- In the context of QIO, a Vector is the type used to represent a probability 3 | -- distribution. 4 | module QIO.Vec where 5 | 6 | import Control.Applicative (Applicative(..)) 7 | import Control.Monad (liftM, ap) 8 | 9 | -- | A Vector over types 'x' and 'a' is a wrapper around list of 10 | -- pairs of 'a' and 'x'. 11 | newtype Vec x a = Vec {unVec :: [(a,x)]} deriving Show 12 | 13 | -- | An empty Vector is defined as the empty list 14 | empty :: Vec x a 15 | empty = Vec [] 16 | 17 | -- | The \"probability\" of an object in a Vector, is the sum of all the 18 | -- probabilities associated with that object. 19 | (<@@>) :: (Num x,Eq a) => Vec x a -> a -> x 20 | (Vec ms) <@@> a = foldr (\(b,k) m -> if a == b then m + k else m) 0 ms 21 | 22 | -- | A Vector can be multiplied by a scalar, by mapping the multiplcation 23 | -- over each probability in the vector. 24 | (<**>) :: Num x => x -> (Vec x a) -> Vec x a 25 | l <**> (Vec as) = (Vec (map (\ (a,k) -> (a,l*k)) as)) 26 | 27 | -- | Two Vectors can be added, using list concatenation. 28 | (<++>) :: (Vec x a) -> (Vec x a) -> Vec x a 29 | (Vec as) <++> (Vec bs) = (Vec (as ++ bs)) 30 | 31 | instance Num n => Functor (Vec n) where 32 | fmap = liftM 33 | 34 | instance Num n => Applicative (Vec n) where 35 | pure a = Vec [(a,1)] 36 | (<*>) = ap 37 | 38 | -- | Vectors, over Numeric types, can be defined as a Monad. 39 | instance Num n => Monad (Vec n) where 40 | return = pure 41 | (Vec ms) >>= f = Vec [(b,i*j) | (a,i) <- ms, (b,j) <- unVec (f a)] 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /QIO/VecEq.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, FlexibleInstances #-} 2 | 3 | -- | This module defines a class of Vectors over types with Equality, along with 4 | -- an instance of this class using lists of pairs. In the context of QIO, these 5 | -- Vectors are used to hold the amplitudes of various basis-states within a 6 | -- superposition. 7 | module QIO.VecEq where 8 | 9 | import QIO.QioSyn 10 | import QIO.Heap 11 | import Control.Applicative (Applicative(..)) 12 | import Control.Monad (liftM, ap) 13 | 14 | -- | Any type that fulfills this type class is a Vector over types with equality 15 | class VecEq v where 16 | -- | An empty instance of the vector 17 | vzero :: v x a 18 | -- | Two Vectors can be combined 19 | (<+>) :: (Eq a, Num x) => v x a -> v x a -> v x a 20 | -- | A Vector can be multiplied by a scalar 21 | (<.>) :: (Num x, Eq x) => x -> v x a -> v x a 22 | -- | The amplitude of a given element can be accessed 23 | (<@>) :: (Eq a, Num x) => a -> v x a -> x 24 | -- | The vector can be created from a list of pairs 25 | fromList :: [(a,x)] -> v x a 26 | -- | The cevtor can be converted into a list of pairs 27 | toList :: v x a -> [(a,x)] 28 | 29 | -- | This type is a wrapper around a list of pairs. 30 | newtype VecEqL x a = VecEqL {unVecEqL :: [(a,x)]} deriving Show 31 | 32 | -- | An empty VecEqL is a wrapper around the empty list 33 | vEqZero :: VecEqL x a 34 | vEqZero = VecEqL [] 35 | 36 | -- | A basis state with the given amplitude can be added to a VecEqL by adding 37 | -- the amplitudes if the state is already in the vector, or by inserting the 38 | -- base state if it isn't already in the vector. 39 | add :: (Eq a,Num x) => (a,x) -> VecEqL x a -> VecEqL x a 40 | add (a,x) (VecEqL axs) = VecEqL (addV' axs) 41 | where addV' [] = [(a,x)] 42 | addV' ((by @ (b,y)):bys) | a == b = (b,x+y):bys 43 | | otherwise = by:(addV' bys) 44 | 45 | -- | Combining two vectors is achieved by folding the add operation over 46 | -- the second vector 47 | vEqPlus :: (Eq a, Num x) => VecEqL x a -> VecEqL x a -> VecEqL x a 48 | (VecEqL as) `vEqPlus` vbs = foldr add vbs as 49 | 50 | -- | Scalar multiplcation is achieved by mapping the multiplication over 51 | -- each pair in the vector. Multiplication by 0 is a special case, and will 52 | -- remove all the basis states from the vector. 53 | vEqTimes :: (Num x, Eq x) => x -> VecEqL x a -> VecEqL x a 54 | l `vEqTimes` (VecEqL bs) | l==0 = VecEqL [] 55 | | otherwise = VecEqL (map (\ (b,k) -> (b,l*k)) bs) 56 | 57 | -- | The amplitude of an element can be found by looking through each element 58 | -- until the matchinf one is found. 59 | vEqAt :: (Eq a, Num x) => a -> VecEqL x a -> x 60 | a `vEqAt` (VecEqL []) = 0 61 | a `vEqAt` (VecEqL ((a',b):abs)) | a == a' = b 62 | | otherwise = a `vEqAt` (VecEqL abs) 63 | 64 | 65 | -- | VecEqL is an instance of the VecEq class 66 | instance VecEq VecEqL where 67 | vzero = vEqZero 68 | (<+>) = vEqPlus 69 | (<.>) = vEqTimes 70 | (<@>) = vEqAt 71 | fromList as = VecEqL as 72 | toList (VecEqL as) = as 73 | 74 | -- | An EqMonad is a monad that has Return and Bind operations that depend on 75 | -- the type in the monad being a member of the Eq class 76 | class EqMonad m where 77 | eqReturn :: Eq a => a -> m a 78 | eqBind :: (Eq a, Eq b) => m a -> (a -> m b) -> m b 79 | 80 | -- | Any VecEq over \v\, along with a Numeric tpye \x\ is an EqMonad. 81 | instance (VecEq v, Num x, Eq x) => EqMonad (v x) where 82 | eqReturn a = fromList [(a,1)] 83 | eqBind va f = case toList va of 84 | ([]) -> vzero 85 | ((a,x):[]) -> x <.> f a 86 | ((a,x):vas) -> (x <.> f a) <+> ((fromList vas) `eqBind` f) 87 | 88 | -- | We can define a datatype that holds EqMonad operations, so that it can 89 | -- be defined as a Monad. 90 | data AsMonad m a where 91 | Embed :: (EqMonad m, Eq a) => m a -> AsMonad m a 92 | Return :: EqMonad m => a -> AsMonad m a 93 | Bind :: EqMonad m => AsMonad m a -> (a -> AsMonad m b) -> AsMonad m b 94 | 95 | instance EqMonad m => Functor (AsMonad m) where 96 | fmap = liftM 97 | 98 | instance EqMonad m => Applicative (AsMonad m) where 99 | pure = Return 100 | (<*>) = ap 101 | 102 | -- | We can define an AsMonad over an EqMonad, as a Monad 103 | instance EqMonad m => Monad (AsMonad m) where 104 | return = pure 105 | (>>=) = Bind 106 | 107 | -- | Given Equality, we can unembed the EqMonad operations from an AsMonad 108 | unEmbed :: Eq a => AsMonad m a -> m a 109 | unEmbed (Embed m) = m 110 | unEmbed (Return a) = eqReturn a 111 | unEmbed (Bind (Embed m) f) = m `eqBind` (unEmbed.f) 112 | unEmbed (Bind (Return a) f) = unEmbed (f a) 113 | unEmbed (Bind (Bind m f) g) = unEmbed (Bind m (\x -> Bind (f x) g)) 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | qio-haskell 2 | =========== 3 | 4 | The Quantum IO Monad, implemented in Haskell 5 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | 4 | --------------------------------------------------------------------------------