diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,66 @@ +Contributors are listed here, in alphabetical order by last name. +Unless otherwise noted, the copyright for his or her contributions +rests with each individual author. For contributions by authors whose +name is marked (ACS), the copyright rests with Applied Communication +Sciences. + +Copyright (C) 2011-2019. All rights reserved. +Copyright (C) 2012-2013 Applied Communication Sciences. All rights +reserved. + +Richard Eisenberg +Alexander S. Green +Peter LeFanu Lumsdaine +Keith Kim (ACS) +Siun-Chuon Mau (ACS) +Baranidharan Mohan +Won Ng (ACS) +Joel Ravelomanantsoa-Ratsimihah +Neil J. Ross +Artur Scherer (ACS) +Peter Selinger +Benoît Valiron +Alexandr Virodov (ACS) +Stephan A. Zdancewic + +This research was supported by the Intelligence Advanced Research +Projects Activity (IARPA) via Department of Interior National Business +Center contract numbers D11PC20168 and D12PC00527. The U.S. Government +is authorized to reproduce and distribute reprints for Governmental +purposes notwithstanding any copyright annotation thereon. Disclaimer: +The views and conclusions contained herein are those of the authors +and should not be interpreted as necessarily representing the official +policies or endorsements, either expressed or implied, of IARPA, +DoI/NBC, or the U.S. Government. + +---------------------------------------------------------------------- +LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. The name of the authors and copyright holders may not be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. +---------------------------------------------------------------------- diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,76 @@ +December 29, 2019: Release 0.9.0.0 + + * Overhauled module structure: + + Old: New: + ==== ==== + + Quipper.XYZ Quipper.Internal.XYZ + QuipperLib.XYZ Quipper.Libraries.XYZ + Libraries.XYZ Quipper.Utils.XYZ + Algorithms.XYZ Quipper.Algorithms.XYZ + tests Quipper.Demos + Programs Quipper.Programs + + * Re-packaged Quipper as Cabal packages. Added executables quipper, + quipper-pp, quipperi, quipperdoc in lieu of shell scripts. + * Moved PDF Previewer to a separate library in Quipper.Utils.Preview + * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy + * Use type class synonyms to avoid warnings about simplifiable class. + * Compatibility: removed obsolete functoin Map.insertWith'. + * Added MultiControlledNot demo. + * Removed dependency on set-monad, which is broken upstream. + * Fixed some bugs in the stabilizer simulation. + * Moved QuantumIf from BF to Libraries. + * Added --help option to all Quipper tools. + * Removed Quipper.Utils.ShowAll + * Fixed some compiler errors and removed some unnecessary type class + assumptions. + +July 27, 2016: Release 0.8 + + * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too + broken and will not be supported by Quipper. + * Added tests/SimulationTest + * Added QPrep and QUnPrep to the simulator + +October 14, 2014: Release 0.7 + + * Portability: compatibility fixes for GHC 7.8. + +January 16, 2014: Release 0.6 + + * Minor edits and documentation updates. + * Added a new gate gate_iX_inv + * Added "alternate" version of synthesis algorithm, using only + generators of determinant 1 if possible. + * Synthesis code is now in an external package "newsynth". + * Rendering code is now in an external package "easyrender". + * Updated for use with fixedprec-0.2.1.0. + +September 2, 2013: Release 0.5 + + * Portability: compatibility fixes for GHC 7.6.2. + * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C + may or may not work on Windows, depending on console. + * Added quipperi script, analogous to ghci. + * New library QuipperLib.ClassicalOptim: algebraic optimization of + auto-generated classical circuits. Added "optimized" oracle to BWT + algorithm. + * QuipperLib.Decompose: Added decomposition into a "standard" gate + set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT. + Added KeepPhase flag to some transformers. + * QuipperLib.GateDecompositions: added more gates. + * New library Libraries.Synthesis.RotationDecomposition: implements a + variant of the algorithm from Nielsen and Chuang to decompose an + nxn unitary operator into one- and two-level rotations. + * New library QuipperLib.Unboxing: unboxing transformers. + * Updated ASCII output format; improved circuit parser efficiency. + * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits, + floorlog. + * Fixed handling of iterated subroutines in depth transformer. + * Documentation updates and minor refactoring. + +June 19, 2013: Release 0.4 + + * First public release. diff --git a/Quipper/Libraries/Arith.hs b/Quipper/Libraries/Arith.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Arith.hs @@ -0,0 +1,1756 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This library provides a type of quantum integers, as well as +-- basic arithmetic functions on them. +-- +-- The type 'QDInt' holds a fixed-size, ℓ-qubit quantum integer, +-- considered modulo 2[sup ℓ]. The integers may be regarded as +-- signed or unsigned, depending on the operation. If signs are used, +-- they are assumed to be in two's complement. +-- +-- Some of the arithmetic operations are adapted from the GFI for the +-- Triangle Finding algorithm. Most algorithms used are, for now, very +-- naïve (ripple adders, etc). Gate count estimates are given in the +-- Toffoli gatebase. + +-- Documentation note: the table of contents is organized slightly +-- differently than the source code. The guiding idea is that the +-- documentation should expose the interface that is accessible to +-- user-level code, and changeable implementation details are hidden. + +module Quipper.Libraries.Arith ( + -- * Quantum integers + -- ** Data type definitions + -- $DATATYPES + XInt, -- constructors not exported + QDInt, + CInt, + IntM, + -- ** Operations on QDInt + qulist_of_qdint_bh, + qdint_of_qulist_bh, + qulist_of_qdint_lh, + qdint_of_qulist_lh, + qdint_length, + qdint_extend_unsigned, + qdint_extend_signed, + -- ** Operations on CInt + bitlist_of_cint_bh, + cint_of_bitlist_bh, + bitlist_of_cint_lh, + cint_of_bitlist_lh, + cint_length, + cint_extend_unsigned, + cint_extend_signed, + -- ** Operations on IntM + -- $INTMCLASSES + boollist_of_intm_bh, + intm_of_boollist_bh, + intm_length, + integer_of_intm_unsigned, + integer_of_intm_signed, + intm_with_length, + intm_of_integer, + intm, + intm_promote, + intm_interval_signed, + intm_interval_unsigned, + intm_extend_unsigned, + intm_extend_signed, + -- ** Shape parameters + qdint_shape, + cint_shape, + -- ** Operations on XInt + xint_maybe_length, + list_of_xint_bh, + xint_of_list_bh, + list_of_xint_lh, + xint_of_list_lh, + -- * Quantum arithmetic operations + -- ** The QNum type class + QNum(..), + -- ** In-place increment and decrement + q_increment, + q_decrement, + -- ** In-place addition and subtraction + q_add_in_place, + q_sub_in_place, + q_negate_in_place, + -- ** Arithmetic with classical parameter + q_add_param, + q_sub_param, + q_add_param_in_place, + q_sub_param_in_place, + q_mult_param, + -- ** Comparison + q_le_unsigned, + q_le_signed, + q_lt_signed, + q_negative, + -- ** Division and remainder + q_moddiv_unsigned_in_place, + q_mod_unsigned, + q_divrem_unsigned, + q_div_unsigned, + q_div, + q_quot, + q_div_exact_unsigned, + q_div_exact, + -- ** Specialized functions + q_ext_euclid, + -- * Lifting of arithmetic functions + -- $LIFTING + template_symb_plus_, + ) where + +import Quipper +import Quipper.Internal + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +import Control.Monad +import Data.Typeable + +-- ====================================================================== +-- * Quantum integers + +-- ** Data type definitions + +-- $DATATYPES +-- We define three versions of the fixed-length integer type: quantum, +-- classical input, and classical parameter. The triple ('IntM', +-- 'QDInt', 'CInt') forms an instance of the 'QShape' class. All three +-- types are special cases of the type 'XInt' /x/. + +-- | 'XInt' /x/ is the type of fixed-length integers, but using +-- elements of type /x/ instead of bits. It is an abstract type, and +-- details of its implementation is not exposed to user-level code. + +-- Implemenation notes: The integer types are currently implemented as +-- big-headian bit lists. However, the details of the implementation +-- are not exposed to user-level code, and are subject to change. +-- +-- The form ('XInt_indet' /n/ /id/) is permitted as a special case, to +-- represent an integer of indeterminate length. Such a value can only +-- be used when the length is deducible from the context. This form is +-- only allowed in the special case /x/ = 'Bool', and we use an +-- identity type to enforce this. +-- +-- Integers of indeterminate length may only be used in certain +-- operations where the shape information is available from other +-- data. It can be used, for example, for terminating or controlling a +-- 'QDInt', but not for initializing a 'QDInt'. +data XInt x = XInt [x] | XInt_indet Integer (Identity Bool x) + deriving (Show, Typeable) + +-- | The type of fixed-length /m/-qubit quantum integers. This is a +-- circuit execution time value. +type QDInt = XInt Qubit + +instance Show QDInt where + show (XInt l) = "#" ++ show l + show (XInt_indet n id) = error "IntM: internal error" + +-- A better implementation might be something like: +-- show (XInt l) = "qdint_of_qulist_bh " ++ show l +-- However, as 'CInt' and 'QDInt' are currently synonyms, it seems best +-- to keep the instance agnostic between them, while still distinguishing +-- them somehow from naked lists. + +-- | The type of fixed-length /m/-bit classical integer inputs. This +-- is a circuit execution time value. +type CInt = XInt Bit + +-- Currently, 'CInt' is literally a synonym of 'QDInt', since 'Qubit' is +-- a synonym of 'Bit'. If this changes, the following instance will be +-- required: +-- +-- instance Show CInt where +-- show (XInt l) = show l +-- show (XInt_indet n id) = error "IntM: internal error" + +-- | The type of fixed-length /m/-bit integer parameters. Values of +-- this type are parameters, i.e., they are classical and known at +-- circuit generation time. +-- +-- Unlike values of type 'QDInt' and 'CInt', a value of type 'IntM' +-- may have an indeterminate length. This happens, for example, if the +-- value is specified by means of an integer literal (e.g., 17), which +-- does not carry length information. In such cases, the value can +-- only be used when it can be deduced from the context. For example, +-- such values may be used for terminating or controlling a 'QDInt', +-- but not for initializing a 'QDInt'. +type IntM = XInt Bool + +instance Show IntM where + show (XInt l) = "intm " ++ show (length l) ++ " " ++ show (int_of_boollist_signed_bh l) + show (XInt_indet n id) = show n + +-- Note: for the purpose of forming intervals, we regard 'IntM' as an +-- /unsigned/ type. This disagrees with the 'Enum' instance, where +-- 'IntM' is regarded as a /signed/ type. So for example, when /x/ = +-- 'intm' 4 (-2) = 'intm' 4 14 and /y/ = 'intm' 4 10, then [/x/../y/] +-- and 'interval' /y/ /x/ are non-empty, but [/y/../x/] and 'interval' +-- /x/ /y/ are empty. +-- +-- This is confusing but for the time being there is no better +-- alternative, unless we create distinct signed and unsigned types. + +instance Interval IntM where + interval x y = intm_interval_unsigned x y + +instance Zero IntM where + zero x = intm_with_length (intm_length x) 0 + +-- ---------------------------------------------------------------------- +-- ** Primitive combinators on XInt + +-- $ 'XInt' is intended to be an abstract data type, and all access to +-- it should pass through the three access functions of this +-- section. + +-- *** Constructors + +-- | Create a 'XInt' /x/ from a list of /x/s. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +xint_of_list_bh :: [x] -> XInt x +xint_of_list_bh xs = XInt xs + +-- | Create an 'IntM' of indeterminate length from an 'Integer'. +intm_of_integer :: Integer -> IntM +intm_of_integer n = XInt_indet n reflexivity + +-- *** Destructor + +-- | If the 'XInt' is of determinate length, return its list of digits +-- as a big-headian list, i.e., the head of the list holds the most +-- significant digit. If the 'XInt' is of indeterminate length, return +-- (/n/, /id/), where /n/ is the underlying 'Integer' and /id/ is the +-- witness proving that /x/ = 'Bool'. +-- +-- This is a lowest-level access function not intended to be used by +-- user-level code. +xint_case :: XInt x -> Either [x] (Integer, Identity Bool x) +xint_case (XInt xs) = Left xs +xint_case (XInt_indet n id) = Right (n, id) + +-- ---------------------------------------------------------------------- +-- ** Other low-level operations + +-- $ The operations in this section are the only ones intended to use +-- 'xint_case' directly. + +-- | Set the length of an 'XInt' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +-- +-- Note that if /x/ ≠ 'Bool', the input is guaranteed to have +-- determinate length. However, we cannot test for equality of types +-- in a polymorphic function. This is where the 'id' argument to +-- 'XInt_indet' is used. +xint_set_length :: Int -> XInt x -> String -> XInt x +xint_set_length m x errmsg | m < 0 = + error "xint_set_length: negative length not permitted" +xint_set_length m x errmsg = + case xint_case x of + Left xs | m == length xs -> x + | otherwise -> error errmsg + Right (n, id) -> XInt xs where + xs = [ identity id b | b <- boollist_of_int_bh m n ] + +-- | Return 'True' if the 'XInt' is of determinate length, and 'False' +-- if it is of indeterminate length. +xint_is_determinate :: XInt x -> Bool +xint_is_determinate x = + case xint_case x of + Left _ -> True + Right _ -> False + +-- | From a 'XInt', which must be of determinate length, extract a +-- list of /x/s. The conversion is big-headian, i.e., the head of the +-- list holds the most significant digit. It is an error to call this +-- function with an 'XInt' of indeterminate length. +list_of_xint_bh :: XInt x -> [x] +list_of_xint_bh x = + case xint_case x of + Left xs -> xs + Right _ -> error "list_of_xint_bh: integer has indeterminate length" + +-- | Return the size of a 'XInt', or 'Nothing' if indeterminate. +xint_maybe_length :: XInt x -> Maybe Int +xint_maybe_length x = + case xint_case x of + Left xs -> Just (length xs) + Right _ -> Nothing + +-- | Convert an 'IntM' of length /m/ to an 'Integer' in the range {0, +-- …, 2[sup /m/]-1}. If the 'IntM' has indeterminate length, return the +-- original 'Integer'. +integer_of_intm_unsigned :: IntM -> Integer +integer_of_intm_unsigned x = + case xint_case x of + Left xs -> int_of_boollist_unsigned_bh xs + Right (n, id) -> n + +-- | Convert an 'IntM' of length /m/ to an 'Integer' in the range +-- {-2[sup /m/-1], …, 2[sup /m/-1]-1}. If the 'IntM' has indeterminate +-- length, return the original 'Integer'. +integer_of_intm_signed :: IntM -> Integer +integer_of_intm_signed x = + case xint_case x of + Left xs -> int_of_boollist_signed_bh xs + Right (n, id) -> n + +-- | Equality test. If at least one argument has determinate length, +-- test equality modulo 2[sup /m/]. If both have indeterminate length, +-- check equality of the underlying integers. +xint_equals :: (Eq x) => XInt x -> XInt x -> Bool +xint_equals x y = + case (xint_case x, xint_case y) of + (Left xs, Left ys) + | length xs == length ys -> xs == ys + | otherwise -> error "Equality test on XInt: operands must be of equal length" + (_, Left ys) -> xint_equals (xint_set_length m x "xint_equals") y + where m = length ys + (Left xs, _) -> xint_equals x (xint_set_length m y "xint_equals") + where m = length xs + (Right (n, _), Right (n', _)) -> n == n' + +-- ---------------------------------------------------------------------- +-- ** Derived operations on XInt + +-- | Get the nominal length of an integer (in bits). It is an error to +-- apply this function to an integer of indeterminate length. +xint_length :: XInt x -> Int +xint_length x = + case xint_maybe_length x of + Just m -> m + Nothing -> error "xint_length: integer has indeterminate length" + +-- | Convert an integer to a bit list. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +list_of_xint_lh :: XInt x -> [x] +list_of_xint_lh = reverse . list_of_xint_bh + +-- | Convert a bit list to an integer. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +xint_of_list_lh :: [x] -> XInt x +xint_of_list_lh = xint_of_list_bh . reverse + +-- | Extend a 'XInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to /zero/. It is an error to call this +-- function when the new length is shorter than the old one. +xint_extend_unsigned :: (Monad m) => Int -> m x -> XInt x -> m (XInt x) +xint_extend_unsigned len zero x + | len < m = + error "pad_xint: requested length is shorter than current length" + | otherwise = do + pad <- sequence (replicate extra zero) + return $ xint_of_list_bh (pad ++ digits) + where + digits = list_of_xint_bh x + m = length digits + extra = len - m + +-- | Extend a 'XInt' to the given length without changing its (signed) +-- value. This is done by adding the required number of high bits +-- initialized to copies of the sign bit (or to /zero/ if the original +-- integer was of length 0). It is an error to call this function when +-- the new length is shorter than the old one. +xint_extend_signed :: (Monad m) => Int -> m x -> (x -> m x) -> XInt x -> m (XInt x) +xint_extend_signed len zero copy x + | len < m + = error "pad_xint: requested length is shorter than current length" + | m == 0 + = xint_extend_unsigned len zero x + | otherwise = do + pad <- sequence (replicate extra (copy sign)) + return $ xint_of_list_bh (pad ++ digits) + where + digits = list_of_xint_bh x + m = length digits + extra = len - m + sign = head digits + +-- ---------------------------------------------------------------------- +-- ** Operations on IntM + +-- | Return the size of an 'IntM', or 'Nothing' if indeterminate. +intm_length :: IntM -> Maybe Int +intm_length = xint_maybe_length + +-- | Convert an 'IntM' to a list of booleans. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. As usual, 'False' is 0 and 'True' is 1. It is an error to +-- apply this operation to an 'IntM' whose length is indeterminate. +boollist_of_intm_bh :: IntM -> [Bool] +boollist_of_intm_bh = list_of_xint_bh + +-- | Convert a boolean list to an 'IntM'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +intm_of_boollist_bh :: [Bool] -> IntM +intm_of_boollist_bh = xint_of_list_bh + +-- | Create an 'IntM' of the specified length (first argument) and +-- value (second argument). +intm :: Int -> Integer -> IntM +intm m n = intm_set_length m (intm_of_integer n) "intm: internal error" + +-- | Set the length of an 'IntM' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. (Use 'intm_extend_unsigned' or +-- 'intm_extend_signed' to increase a determinate length). +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +intm_set_length :: Int -> IntM -> String -> IntM +intm_set_length = xint_set_length + +-- | Extend an 'IntM' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +intm_extend_unsigned :: Int -> IntM -> IntM +intm_extend_unsigned len x = + getId $ xint_extend_unsigned len (return False) x + +-- | Extend an 'IntM' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +intm_extend_signed :: Int -> IntM -> IntM +intm_extend_signed len x = + getId $ xint_extend_signed len (return False) (return) x + +-- ---------------------------------------------------------------------- +-- ** Operations on CInt + +-- | Convert a 'CInt' to a list of qubits. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +bitlist_of_cint_bh :: CInt -> [Bit] +bitlist_of_cint_bh = list_of_xint_bh + +-- | Convert a list of qubits to a 'CInt'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +cint_of_bitlist_bh :: [Bit] -> CInt +cint_of_bitlist_bh = xint_of_list_bh + +-- | Convert a 'CInt' to a list of bits. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +bitlist_of_cint_lh :: CInt -> [Bit] +bitlist_of_cint_lh = list_of_xint_lh + +-- | Convert a list of bits to a 'CInt'. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +cint_of_bitlist_lh :: [Bit] -> CInt +cint_of_bitlist_lh = xint_of_list_lh + +-- | Return the length of a 'CInt', in bits. +cint_length :: CInt -> Int +cint_length = xint_length + +-- | Extend a 'CInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +cint_extend_unsigned :: Int -> CInt -> Circ CInt +cint_extend_unsigned len x = + xint_extend_unsigned len (cinit False) x + +-- | Extend a 'CInt' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +cint_extend_signed :: Int -> CInt -> Circ CInt +cint_extend_signed len x = + xint_extend_signed len (cinit False) (qc_copy) x + +-- ---------------------------------------------------------------------- +-- ** Operations on QDInt + +-- | Convert a 'QDInt' to a list of qubits. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +qulist_of_qdint_bh :: QDInt -> [Qubit] +qulist_of_qdint_bh = list_of_xint_bh + +-- | Convert a list of qubits to a 'QDInt'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +qdint_of_qulist_bh :: [Qubit] -> QDInt +qdint_of_qulist_bh = xint_of_list_bh + +-- | Convert a 'QDInt' to a list of qubits. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +qulist_of_qdint_lh :: QDInt -> [Qubit] +qulist_of_qdint_lh = list_of_xint_lh + +-- | Convert a list of qubits to a 'QDInt'. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +qdint_of_qulist_lh :: [Qubit] -> QDInt +qdint_of_qulist_lh = xint_of_list_lh + +-- | Return the length of a 'QDInt', in bits. +qdint_length :: QDInt -> Int +qdint_length = xint_length + +-- | Extend a 'QDInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +qdint_extend_unsigned :: Int -> QDInt -> Circ QDInt +qdint_extend_unsigned len x = + xint_extend_unsigned len (qinit False) x + +-- | Extend a 'QDInt' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +qdint_extend_signed :: Int -> QDInt -> Circ QDInt +qdint_extend_signed len x = + xint_extend_signed len (qinit False) (qc_copy) x + +-- ---------------------------------------------------------------------- +-- ** Shape parameters + +-- | Return a piece of shape data to represent an /m/-qubit quantum +-- integer. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qdint_shape :: Int -> QDInt +qdint_shape m = xint_of_list_bh (replicate m qubit) + +-- | Return a piece of shape data to represent an /m/-bit 'CInt'. +-- Please note that the data can only be used as shape; it will be +-- undefined at the leaves. +cint_shape :: Int -> CInt +cint_shape m = xint_of_list_bh (replicate m bit) + +-- ====================================================================== +-- ** Type class instances + +-- Note: instance declarations do not show up in the documentation + +-- | Input the lengths of two inputs to a binary operation, and return +-- the common length. If one length is indeterminate, return the other; +-- if both are indeterminate, return 'Nothing'; if both are determinate but +-- not equal, throw an error with the given error message. +combine_length :: String -> Maybe Int -> Maybe Int -> Maybe Int +combine_length s Nothing m = m +combine_length s m Nothing = m +combine_length s (Just m) (Just m') | m == m' = Just m + | otherwise = error s + +-- | Try to set the length of an 'IntM' to that of another 'XInt' +-- value (which could be a 'QDInt', a 'CInt', or another 'IntM'). This +-- will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. +intm_promote :: IntM -> XInt x -> String -> IntM +intm_promote bi xi errmsg = + case xint_maybe_length xi of + Nothing -> bi + Just m -> intm_set_length m bi errmsg + +type instance QCType x y (XInt z) = XInt (QCType x y z) +type instance QTypeB IntM = QDInt + +instance QCLeaf x => QCData (XInt x) where + qcdata_mapM shape f g xs = + mmap xint_of_list_bh $ qcdata_mapM (list_of_xint_bh shape) f g (list_of_xint_bh xs) + qcdata_zip shape q c q' c' xs ys e = + xint_of_list_bh $ qcdata_zip (list_of_xint_bh shape) q c q' c' (list_of_xint_bh xs) (list_of_xint_bh ys) (const $ e "XInt length mismatch") + qcdata_promote b q e = intm_promote b q (e "IntM length mismatch") + +-- Labeling of QDInt is s[m-1], ..., s[0], with the least significant +-- bit at index 0. +instance QCLeaf x => Labelable (XInt x) String where + label_rec qa = label_rec (list_of_xint_lh qa) + +instance CircLiftingUnpack (Circ QDInt) (Circ QDInt) where + pack x = x + unpack x = x + +-- ====================================================================== +-- * Classical arithmetic on 'IntM' + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | A useful auxiliary function that converts a list of 'IntM's to a +-- list of 'Integer's, while also returning their common length. All +-- arguments whose length is not indeterminate must have the same common +-- length. If the lengths don't match, throw an error with the error +-- message specified by the 'String' argument. +integers_of_intms_signed :: [IntM] -> String -> (Maybe Int, [Integer]) +integers_of_intms_signed xs s = (m, is) where + m = foldl (combine_length s) Nothing [ intm_length x | x <- xs ] + is = [ integer_of_intm_signed x | x <- xs ] + +-- | Like 'integers_of_intms_signed', but regards the 'IntM's as +-- unsigned integers. +integers_of_intms_unsigned :: [IntM] -> String -> (Maybe Int, [Integer]) +integers_of_intms_unsigned xs s = (m, is) where + m = foldl (combine_length s) Nothing [ intm_length x | x <- xs ] + is = [ integer_of_intm_unsigned x | x <- xs ] + +-- | Create an 'IntM' of the given length and value. Leave the length +-- indeterminate if it is given as 'Nothing'. +intm_with_length :: Maybe Int -> Integer -> IntM +intm_with_length (Just m) n = intm m n +intm_with_length Nothing n = intm_of_integer n + +-- | Auxiliary function for lifting a binary operator from 'Integer' +-- to 'IntM'. The string argument is the name of the operator, for +-- error messages. +intm_binop :: (Integer -> Integer -> Integer) -> String -> IntM -> IntM -> IntM +intm_binop op opname x y = intm_with_length m (op x' y') where + (m, [x',y']) = integers_of_intms_signed [x, y] ("Binary operation " ++ opname ++ " on IntM: operands must be of equal length") + +-- | Auxiliary function for lifting a unary operator from 'Integer' to +-- 'IntM'. +intm_unop :: (Integer -> Integer) -> IntM -> IntM +intm_unop op x = intm_with_length xm (op x') where + xm = intm_length x + x' = integer_of_intm_signed x + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $INTMCLASSES +-- +-- 'IntM' is an instance of Haskell's 'Eq', 'Num', 'Ord', 'Real', +-- 'Enum', and 'Integral' type classes. This means that integer +-- literals (e.g., 17), and the usual arithmetic functions, such as +-- '+', '-', '*', 'abs', 'succ', 'pred', 'mod', 'div', and others, can +-- be used for values of type 'IntM'. In general, we treat 'IntM' as a +-- signed integer type. Use 'fromIntegral' to convert an integer to an +-- 'IntM' of indeterminate length. +-- +-- The general convention for binary operations (such as +-- multiplication) is: both operands must have the same length, +-- except: if one operand has indeterminate length, it takes on the +-- length of the other; if both operands have indeterminate length, the +-- result will have indeterminate length. + +instance Eq x => Eq (XInt x) where + x == y = xint_equals x y + +instance Num IntM where + (+) = intm_binop (+) "+" + (*) = intm_binop (*) "*" + (-) = intm_binop (-) "-" + abs = intm_unop abs + signum = intm_unop signum + fromInteger = intm_of_integer + +instance Ord IntM where + compare x y = compare (toInteger x) (toInteger y) + +instance Real IntM where + toRational = toRational . integer_of_intm_signed + +instance Enum IntM where + succ = intm_unop succ + pred = intm_unop pred + toEnum = intm_of_integer . fromIntegral + fromEnum = fromIntegral . integer_of_intm_signed + enumFrom x = map (intm_with_length m) [x'..] where + (m, [x']) = integers_of_intms_signed [x] "enumeration: IntM" + enumFromThen x y = map (intm_with_length m) [x',y'..] where + (m, [x',y']) = integers_of_intms_signed [x,y] "enumeration: IntM operands must be of equal length" + enumFromTo x y = map (intm_with_length m) [x'..y'] where + (m, [x',y']) = integers_of_intms_signed [x,y] "enumeration: IntM operands must be of equal length" + enumFromThenTo x y z = map (intm_with_length m) [x',y'..z'] where + (m, [x',y',z']) = integers_of_intms_signed [x,y,z] "enumeration: IntM operands must be of equal length" + +-- | Return the interval @[/x/../y/]@, with /x/ and /y/ regarded as +-- signed values of type 'IntM'. +intm_interval_signed :: IntM -> IntM -> [IntM] +intm_interval_signed x y = [x..y] -- this comes from the 'Enum' instance defined above + +-- | Return the interval @[/x/../y/]@, with /x/ and /y/ regarded as +-- unsigned values of type 'IntM'. +intm_interval_unsigned :: IntM -> IntM -> [IntM] +intm_interval_unsigned x y = map (intm_with_length m) [x'..y'] where + (m, [x',y']) = integers_of_intms_unsigned [x,y] "intm_interval: operands must be of equal length" + +instance Integral IntM where + toInteger = integer_of_intm_signed + quotRem x y = (intm_with_length m q', intm_with_length m r') where + (m, [x',y']) = integers_of_intms_signed [x, y] "Division on IntM: operands must be of equal length" + (q',r') = quotRem x' y' + +-- ====================================================================== +-- * Quantum arithmetic on 'QDInt' + +-- Developer note: each quantum arithmetic function is implemented by +-- an underlying low-level function operating on qubit lists. However, +-- these lower-level functions are *not* exported. If any module needs +-- them, it should define them explicitly using 'qulist_of_qdint_bh' +-- and 'qdint_of_qulist_bh'. In particular, the low-level functions +-- may not perform error checking if it is already performed by their +-- high-level counterparts. + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | @'common_value' error_str [n1,n2,n3]@: if /n1/, /n2/, /n3/ all equal, return this value; else throw an error. Useful for checking that sizes of 'QDInt's match. +common_value :: (Eq a) => String -> [a] -> a +common_value _ [] = error "common_value: no inputs given" +common_value _ [n] = n +common_value error_str (n:ns) = if common_value error_str ns == n then n else error error_str + +-- | @'common_length' error_str [x1,x2,x3]@: if /x1/, /x2/, /x3/ all have the same length, return this value; else throw an error. +common_length :: String -> [QDInt] -> Int +common_length error_str xs = common_value error_str $ map qdint_length xs + +-- ---------------------------------------------------------------------- +-- ** Incrementing and decrementing + +-- | Increment a 'QDInt' in place. /O/(ℓ) gates. +-- +-- Implementation note: currently tries to minimize gate count, at the cost of a rather long Quipper description. Can the latter be reduced without increasing the former? +q_increment :: QDInt -> Circ QDInt +q_increment = mmap xint_of_list_bh . q_increment_qulist . list_of_xint_bh + +-- | Low-level implementation of 'q_increment': represents integers as +-- big-headian qubit lists. +q_increment_qulist :: [Qubit] -> Circ [Qubit] +q_increment_qulist [] = return [] +q_increment_qulist [x_0] = do x_0 <- qnot x_0; return [x_0] +q_increment_qulist [x_1,x_0] = do x_0 <- qnot x_0; x_1 <- qnot x_1 `controlled` (x_0 .==. 0); return [x_1,x_0] +q_increment_qulist [x_2,x_1,x_0] = do + x_0 <- qnot x_0 + x_1 <- qnot x_1 `controlled` (x_0 .==. 0) + x_2 <- qnot x_2 `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + return [x_2,x_1,x_0] +q_increment_qulist x_bits = do + let x_0 = last x_bits + x_1 = last $ init x_bits + x_higher = init $ init $ x_bits + x_0 <- qnot x_0 + x_1 <- qnot x_1 `controlled` (x_0 .==. 0) + (x_higher,x_1,x_0) <- with_ancilla (\c -> do + c <- qnot c `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + (c,rev_x_higher) <- q_increment_qulist_aux c (reverse x_higher) + c <- qnot c `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + return (reverse rev_x_higher, x_1, x_0)) + return (x_higher ++ [x_1,x_0]) + where + -- increment a LITTLE-endian bit-string, controlled by a single qubit. + q_increment_qulist_aux :: Qubit -> [Qubit] -> Circ (Qubit,[Qubit]) + q_increment_qulist_aux b [] = return (b,[]) + q_increment_qulist_aux b [x_0] = + do x_0 <- qnot x_0 `controlled` b; return (b,[x_0]) + q_increment_qulist_aux b [x_0,x_1] = do + x_0 <- qnot x_0 `controlled` b + x_1 <- qnot x_1 `controlled` b .&&. (x_0 .==. 0) + return (b,[x_0,x_1]) + q_increment_qulist_aux b (x_0:x_higher) = do + x_0 <- qnot x_0 `controlled` b + (b,x_0,x_higher) <- with_ancilla (\c -> do + c <- qnot c `controlled` b .&&. (x_0 .==. 0) + (c,x_higher) <- q_increment_qulist_aux c x_higher + c <- qnot c `controlled` b .&&. (x_0 .==. 0) + return (b,x_0,x_higher)) + return (b, (x_0:x_higher)) + +-- | Decrement a 'QDInt' in place. Inverse of 'q_increment'. /O/(ℓ). +q_decrement :: QDInt -> Circ QDInt +q_decrement = reverse_generic_endo q_increment + +-- ---------------------------------------------------------------------- +-- ** Addition and subtraction + +-- | Add two 'QDInt's into a fresh one. Arguments are assumed to be of equal size. /O/(ℓ) gates, both before and after transformation to Toffoli. +q_add_qdint :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_add_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_add_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_add_qdint': represents integers as +-- big-headian qubit lists. +q_add_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_add_qulist x y = do + let l = length x + when (l /= length y) $ do + error "q_add_qdint: cannot add QDInts of different lengths" + + ((x,y),s_out) <- with_computed_fun (x,y) + (\(x,y) -> do + s <- qinit (replicate l False) -- holds the eventual sum + c <- qinit (replicate l False) -- holds the carries + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + (x,y,s,c) <- loop_with_indexM (l-1) (x,y,s,c) (\j (x,y,s,c) -> do + let c_j1 = c !! (j+1) + let s_j = s !! j + -- If any two of the current bits x_j, y_j, and the carry c_j are true, then set the next carry: + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. y!!j) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. c!!j) + c_j1 <- qnot c_j1 `controlled` (y!!j .&&. c!!j) + -- Now the current sum digit is computed mod 2: + s_j <- qnot s_j `controlled` (x!!j) + s_j <- qnot s_j `controlled` (y!!j) + s_j <- qnot s_j `controlled` (c!!j) + c <- return $ overwriteAt (j+1) c_j1 c + s <- return $ overwriteAt j s_j s + + return (x,y,s,c)) + + -- Final sum digit; no carry required: + let s_l1 = s !! (l-1) + s_l1 <- qnot s_l1 `controlled` (x!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (y!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (c!!(l-1)) + s <- return $ overwriteAt (l-1) s_l1 s + + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + return (x,y,s,c)) + + (\(x,y,s,c) -> do + (s,s_out) <- qc_copy_fun s + return ((x,y,s,c), s_out)) + return (x, y, s_out) + +-- | Subtract two 'QDInt's, into a fresh one. Arguments are assumed to be of equal size. /O/(ℓ). +q_sub_qdint :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_sub_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_sub_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_sub_qdint': represents integers as +-- big-headian qubit lists. +q_sub_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_sub_qulist x y = do + let l = length x + when (l /= length y) $ do + error "q_sub_qdint: cannot subtract QDInts of different lengths" + + ((x,y),d_out) <- with_computed_fun (x,y) + (\(x,y) -> do + d <- qinit (replicate l False) -- holds the eventual difference + b <- qinit (replicate l False) -- holds the borrows + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + d <- return $ reverse d + b <- return $ reverse b + + (x,y,d,b) <- loop_with_indexM (l-1) (x,y,d,b) (\j (x,y,d,b) -> do + let b_j1 = b !! (j+1) + let d_j = d !! j + -- If any two of (not x_j), y_j, and the borrow c_j hold, then set the next borrow. + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + b_j1 <- qnot b_j1 `controlled` (x!!j .==. 0) .&&. (y!!j .==. 1) + b_j1 <- qnot b_j1 `controlled` (x!!j .==. 0) .&&. (b!!j .==. 1) + b_j1 <- qnot b_j1 `controlled` (y!!j .==. 1) .&&. (b!!j .==. 1) + -- Now the current difference digit is computed mod 2: + d_j <- qnot d_j `controlled` (x!!j) + d_j <- qnot d_j `controlled` (y!!j) + d_j <- qnot d_j `controlled` (b!!j) + b <- return $ overwriteAt (j+1) b_j1 b + d <- return $ overwriteAt j d_j d + return (x,y,d,b)) + + -- Final difference digit; no carry required: + let d_l1 = d !! (l-1) + d_l1 <- qnot d_l1 `controlled` (x!!(l-1)) + d_l1 <- qnot d_l1 `controlled` (y!!(l-1)) + d_l1 <- qnot d_l1 `controlled` (b!!(l-1)) + d <- return $ overwriteAt (l-1) d_l1 d + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + d <- return $ reverse d + b <- return $ reverse b + + return (x,y,d,b)) + + (\(x,y,d,b) -> do + (d,d_out) <- qc_copy_fun d + return ((x,y,d,b), d_out)) + return (x, y, d_out) + +-- | Add one 'QDInt' onto a second, in place; i.e. (/x/,/y/) ↦ (/x/,/x/+/y/). Arguments are assumed to be of equal size. /O/(ℓ) gates. +q_add_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +q_add_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y') <- q_add_in_place_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x, y) + +-- | Low-level implementation of 'q_add_in_place': represents integers +-- as big-headian qubit lists. +q_add_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit]) +q_add_in_place_qulist [] [] = return ([], []) +q_add_in_place_qulist [x0] [y0] = do + y0 <- qnot y0 `controlled` x0 + return ([x0], [y0]) +q_add_in_place_qulist x y = do + let (x0:x_higher) = reverse x + (y0:y_higher) = reverse y + + y0 <- qnot y0 `controlled` x0 + + ((x0,y0),(x_higher,y_higher)) <- with_computed_fun (x0,y0) + (\(x0,y0) -> do + c <- qinit False + c <- qnot c `controlled` (x0 .==. 1) .&&. (y0 .==. 0) + return (x0,y0,c)) + (\(x0,y0,c) -> do + (x_higher,y_higher,c) <- q_add_aux (x_higher) (y_higher) c + return ((x0,y0,c),(x_higher,y_higher))) + return (reverse (x0:x_higher), reverse (y0:y_higher)) + where + -- Aux: add two LITTLE-endian bit strings, and an optional extra 1. + q_add_aux :: [Qubit] -> [Qubit] -> Qubit -> Circ ([Qubit],[Qubit],Qubit) + q_add_aux [] [] c = return ([],[],c) + q_add_aux [x0] [y0] c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + return ([x0],[y0],c) + q_add_aux (x0:xs) (y0:ys) c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + ((x0,y0,c),(xs,ys)) <- with_computed_fun (x0,y0,c) + (\(x0,y0,c) -> do + c' <- qinit False + c' <- qnot c' `controlled` (x0 .==. 1) .&&. (y0 .==. 0) + c' <- qnot c' `controlled` (x0 .==. 1) .&&. (c .==. 1) + c' <- qnot c' `controlled` (y0 .==. 0) .&&. (c .==. 1) + return (x0,y0,c,c')) + + (\(x0,y0,c,c') -> do + (xs,ys,c') <- q_add_aux xs ys c' + return ((x0,y0,c,c'),(xs,ys))) + return (x0:xs,y0:ys,c) + q_add_aux _ _ _ = error "q_add_in_place: cannot add integers of different sizes." + +-- | Subtract one 'QDInt' from a second, in place; i.e. (/x/,/y/) ↦ (/x/,/y/–/x/). Arguments are assumed to be of equal size. /O/(ℓ) gates. +q_sub_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +q_sub_in_place x y = reverse_generic_endo (\(x,d) -> q_add_in_place x d) (x,y) + +-- | Low-level version of 'q_sub_in_place': represents integers +-- as big-headian qubit lists. +q_sub_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +q_sub_in_place_qulist x y = reverse_generic_endo (\(x,d) -> q_add_in_place_qulist x d) (x,y) + +-- ---------------------------------------------------------------------- +-- ** Arithmetic with parameters + +-- | Add a parameter 'IntM' and a 'QDInt', into a fresh 'QDInt': (/x/, /y/) ↦ (/y/, /x/+/y/). The parameter /x/ must be of the same length as /y/, or /x/ can also be of undetermined length. /O/(ℓ). +q_add_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_add_param x1 y = do + let x = intm_promote x1 y "q_add_param: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + (y', z') <- q_add_param_qulist x' y' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (y, z) + +-- | Low-level implementation of 'q_add_param': represents integers as +-- big-headian qubit lists. Precondition: /x/ and /y/ have the same length. +q_add_param_qulist :: [Bool] -> [Qubit] -> Circ ([Qubit], [Qubit]) +q_add_param_qulist x y = do + -- Implementation note: compare with q_add_qdint. The code is almost verbatim identical, but since x consists of parameter Bools, `controlled` will omit gates when appropriate. + + -- Further slight optimisation would be possible, since if x doesn’t have low bits then no low carry qubits are required. + + -- Implementation note: once we have a general-purpose classical + -- circuit optimizer (even a primitive one), then this kind of + -- source-code level optimization will hopefully become moot. + + let l = length x + + (y,s_out) <- with_computed_fun y + (\y -> do + s <- qinit (replicate l False) -- holds the eventual sum + c <- qinit (replicate l False) -- holds the carries + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + (y,s,c) <- loop_with_indexM (l-1) (y,s,c) (\j (y,s,c) -> do + let c_j1 = c !! (j+1) + let s_j = s !! j + -- If any two of the current bits x_j, y_j, and the carry c_j are true, then set the next carry: + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. y!!j) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. c!!j) + c_j1 <- qnot c_j1 `controlled` (y!!j .&&. c!!j) + -- Now the current sum digit is computed mod 2: + s_j <- qnot s_j `controlled` (x!!j) + s_j <- qnot s_j `controlled` (y!!j) + s_j <- qnot s_j `controlled` (c!!j) + c <- return $ overwriteAt (j+1) c_j1 c + s <- return $ overwriteAt j s_j s + + return (y,s,c)) + + -- Final sum digit; no carry required: + let s_l1 = s !! (l-1) + s_l1 <- qnot s_l1 `controlled` (x!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (y!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (c!!(l-1)) + s <- return $ overwriteAt (l-1) s_l1 s + + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + return (y,s,c)) + + (\(y,s,c) -> do + (s,s_out) <- qc_copy_fun s + return ((y,s,c), s_out)) + return (y, s_out) + +-- | Subtract a parameter 'IntM' from a 'QDInt', into a fresh 'QDInt'. The 'IntM' cannot be shorter than the 'QDInt' (that would give ill-defined behavior), but can be of undetermined length. /O/(ℓ). +q_sub_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_sub_param x y = q_add_param (-x) y + +-- | Add a parameter 'IntM' onto a 'QDInt', in place; i.e. (/x/,/y/) ↦ /x/+/y/. The parameter /x/ must be of the same length as /y/, or /x/ can also be of undetermined length. /O/(ℓ). +q_add_param_in_place :: IntM -> QDInt -> Circ QDInt +q_add_param_in_place x1 y = do + let x = intm_promote x1 y "q_add_param_in_place: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + y' <- q_add_param_in_place_qulist x' y' + let y = xint_of_list_bh y' + return y + +-- | Low-level implementation of 'q_add_param_in_place': represents +-- integers as big-headian qubit lists. Precondition: /xlist/ and /y/ +-- have the same length. Precondition: /x/ and /y/ have the same length. +q_add_param_in_place_qulist :: [Bool] -> [Qubit] -> Circ [Qubit] +q_add_param_in_place_qulist [] [] = return [] +q_add_param_in_place_qulist [False] [y0] = return [y0] +q_add_param_in_place_qulist [True] [y0] = do + y0 <- qnot y0 + return [y0] +q_add_param_in_place_qulist x y = do + let l = length x + + let (x0:x_higher) = reverse x + (y0:y_higher) = reverse y + + y0 <- qnot y0 `controlled` x0 + + (y0,y_higher) <- with_computed_fun y0 + (\y0 -> do + c <- qinit False + c <- qnot c `controlled` (x0 == 1) .&&. (y0 .==. 0) + return (y0,c)) + (\(y0,c) -> do + (y_higher,c) <- q_add_aux x_higher y_higher c + return ((y0,c),y_higher)) + return (reverse (y0:y_higher)) + where + -- Aux: add two LITTLE-endian bit strings, and an optional extra 1. + q_add_aux :: [Bool] -> [Qubit] -> Qubit -> Circ ([Qubit],Qubit) + q_add_aux [] [] c = return ([],c) + q_add_aux [x0] [y0] c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + return ([y0],c) + q_add_aux (x0:xs) (y0:ys) c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + ((y0,c),ys) <- with_computed_fun (y0,c) + (\(y0,c) -> do + c' <- qinit False + c' <- qnot c' `controlled` (x0 == 1) .&&. (y0 .==. 0) + c' <- qnot c' `controlled` (x0 == 1) .&&. (c .==. 1) + c' <- qnot c' `controlled` (y0 .==. 0) .&&. (c .==. 1) + return (y0,c,c')) + + (\(y0,c,c') -> do + (ys,c') <- q_add_aux xs ys c' + return ((y0,c,c'),ys)) + return (y0:ys,c) + q_add_aux _ _ _ = error "q_add_in_place: cannot add integers of different sizes." + +-- | Subtract a parameter 'IntM' from a 'QDInt', in place; i.e. (/x/,/y/) ↦ (/x/,/x/-/y/). /x/ cannot be shorter than /y/. /O/(/l/) gates. +q_sub_param_in_place :: IntM -> QDInt -> Circ QDInt +q_sub_param_in_place x = q_add_param_in_place (-x) + +-- | Multiply a parameter 'IntM' by a 'QDInt', into a fresh 'QDInt'. The 'IntM' cannot be shorter than the 'QDInt' (that would give ill-defined behavior), but can be of undetermined length. /O/(ℓ). +q_mult_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_mult_param x1 y = do + let x = intm_promote x1 y "q_add_param: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + (y', z') <- q_mult_param_qulist x' y' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (y, z) + +-- | Low-level implementation of 'q_mult_param': represents integers as +-- big-headian (qu)bit lists. +q_mult_param_qulist :: [Bool] -> [Qubit] -> Circ ([Qubit],[Qubit]) +q_mult_param_qulist [] [] = return ([], []) +q_mult_param_qulist xs ys = do + let x0 = last xs + x_higher = init xs + y_high = head ys + y_lower = tail ys + (y_lower, p_higher) + <- q_mult_param_qulist x_higher y_lower + p0 <- qinit False + let y = y_high:y_lower + p = p_higher ++ [p0] + -- Once we have some optimisation, the following line should be replaced by: + -- (y,p) <- q_add_in_place_qulist y p `controlled` x0 + (y,p) <- if x0 then q_add_in_place_qulist y p else return (y,p) + return (y, p) + +-- ---------------------------------------------------------------------- +-- ** Sign and negation + +-- | Negate a (signed) 'QDInt' in place. /O/(ℓ). +q_negate_in_place :: QDInt -> Circ QDInt +q_negate_in_place x = do + x <- mapUnary qnot x + x <- q_increment x + return x + +-- | Low-level version of 'q_negate_in_place': represents integers as +-- big-headian qubit lists. +q_negate_in_place_qulist :: [Qubit] -> Circ [Qubit] +q_negate_in_place_qulist = mmap list_of_xint_bh . q_negate_in_place . xint_of_list_bh + +-- | Compute the negation of a (signed) 'QDInt'. /O/(ℓ). +-- +-- (Fixes the minimum value, consistently with Haskell’s @'negate' 'minBound' :: 'Int'@.) +q_negate_qdint :: QDInt -> Circ (QDInt,QDInt) +q_negate_qdint x = do + (x,nx) <- qc_copy_fun x + nx <- q_negate_in_place nx + return (x,nx) + +-- | Compute the absolute value of a (signed) 'QDInt'. /O/(ℓ). +-- +-- (Fixes the minimum value, consistently with Haskell’s @'abs' 'minBound' :: 'Int'@.) +q_abs_qdint :: QDInt -> Circ (QDInt,QDInt) +q_abs_qdint x = do + let x' = list_of_xint_bh x + (x', a') <- q_abs_qulist x' + let x = xint_of_list_bh x' + let a = xint_of_list_bh a' + return (x, a) + +-- | Low-level implementation of 'q_abs_qdint': represents integers as +-- big-headian qubit lists. +q_abs_qulist :: [Qubit] -> Circ ([Qubit],[Qubit]) +q_abs_qulist [] = return ([], []) +q_abs_qulist (x_high:x_lower) = do + a_high <- qinit False + (x_lower,a_lower) <- qc_copy_fun x_lower + a_lower <- mapUnary qnot a_lower `controlled` x_high + let a = a_high:a_lower + a <- q_increment_qulist a `controlled` x_high + return (x_high:x_lower, a) + +-- | Compute a 'QDInt' of the same length as the input, with value 1, 0, or –1, depending on the sign of the input. Analogous to Haskell’s 'signum'. /O/(ℓ). +q_signum_qdint :: QDInt -> Circ (QDInt,QDInt) +q_signum_qdint x = do + let x' = list_of_xint_bh x + (x', a') <- q_signum_qulist x' + let x = xint_of_list_bh x' + let a = xint_of_list_bh a' + return (x, a) + +-- | Low-level implementation of 'q_abs_qdint': represents integers as +-- big-headian qubit lists. +q_signum_qulist :: [Qubit] -> Circ ([Qubit],[Qubit]) +q_signum_qulist [] = return ([], []) +q_signum_qulist x = do + let l = length x + (s_higher, s_low) <- qinit (replicate (l-1) False, False) + -- first set s = 1 + s_low <- qnot s_low + -- case x < 0: set s to -1 + s_higher <- mapUnary qnot s_higher `controlled` (head x) + -- case x = 0: reset s to 0 + s_low <- qnot s_low `controlled` (x .==. replicate l 0) + return (x,s_higher ++ [s_low]) + +-- ---------------------------------------------------------------------- +-- ** Comparison + +-- | Comparison of two 'QDInt's, considered as unsigned. /O/(ℓ). +q_le_unsigned :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_le_unsigned x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x',y',le_out) <- q_le_unsigned_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x,y,le_out) + +-- | Low-level implementation of 'q_le_unsigned': represents integers +-- as big-headian qubit lists. +q_le_unsigned_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],Qubit) +q_le_unsigned_qulist x y = do + ((x,y),le_out) <- with_computed_fun (x,y) q_le_unsigned_aux + (\(x,y,(le,garbage)) -> do + (le,le_out) <- qc_copy_fun le + return ((x,y,(le,garbage)),le_out)) + return (x,y,le_out) + +-- | Same as 'q_le_unsigned', but uncurried, represents integers as +-- big-headian qubit lists, and doesn’t clean up its garbage. (If +-- each recursive call cleans up its own garbage, gate use becomes +-- /O/(2[sup /n/]).) +q_le_unsigned_aux :: ([Qubit], [Qubit]) -> Circ ([Qubit],[Qubit],(Qubit,[Qubit])) +q_le_unsigned_aux ([], []) = do q <- qinit True; return ([], [], (q,[])) +q_le_unsigned_aux (x_high:x_lower, y_high:y_lower) = do + -- Classically, one would make the recursive call only if needed; but quantumly, it’s cheaper to do it unconditionally. + (x_lower, y_lower, (le_lower, garbage)) <- q_le_unsigned_aux (x_lower, y_lower) + (x_high,y_high,eq_high) <- q_is_equal x_high y_high + le <- qinit False + le <- qnot le `controlled` (x_high .==. 0) .&&. (y_high .==. 1) + le <- qnot le `controlled` eq_high .&&. le_lower + return (x_high:x_lower, y_high:y_lower, (le, eq_high:le_lower:garbage)) +q_le_unsigned_aux _ = error "q_le // QDInt: cannot compare QDInt’s of different lengths." + +-- | Comparison of two 'QDInt's, considered as signed. Used in @instance 'QOrd' 'QDInt'@. /O/(ℓ). +q_le_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_le_signed x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x',y',le_out) <- q_le_signed_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x,y,le_out) + +-- | Low-level implementation of 'q_le_signed': represents integers +-- as big-headian qubit lists. + +-- Implementation note: defined in terms of q_le_unsigned_aux +q_le_signed_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],Qubit) +q_le_signed_qulist [] [] = do q <- qinit True; return ([], [], q) +q_le_signed_qulist (x_high:x_lower) (y_high:y_lower) = do + ((x,y), x_le_y) <- with_computed_fun (x_high:x_lower, y_high:y_lower) + (\(x_high:x_lower, y_high:y_lower) -> do + -- Classically, one would make the recursive call only if needed; but quantumly, it’s cheaper to do it unconditionally. + (x_lower, y_lower, (le_lower, garbage)) <- q_le_unsigned_aux (x_lower, y_lower) + (x_high,y_high,eq_high) <- q_is_equal x_high y_high + return (x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage)) + (\(x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage) -> do + le <- qinit False + le <- qnot le `controlled` (x_high .==. 1) .&&. (y_high .==. 0) + le <- qnot le `controlled` eq_high .&&. le_lower + return ((x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage), le)) + return (x,y,x_le_y) +q_le_signed_qulist _ _ = error "q_le // QDInt: cannot compare QDInt’s of different lengths." + +-- | Comparison of two 'QDInt's, considered as signed. Used in @instance 'QOrd' 'QDInt'@. /O/(ℓ). +q_lt_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_lt_signed x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (y',x',y_le_x) <- q_le_signed_qulist y' x' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + x_lt_y <- qnot y_le_x + return (x,y,x_lt_y) + +-- | Text whether a 'QDInt' is nonnegative. /O/(1) +q_negative :: QDInt -> Circ (QDInt,Qubit) +q_negative x = do + let (x_high:x_lower) = list_of_xint_bh x + (x_high,x_neg) <- qc_copy_fun x_high + return (xint_of_list_bh (x_high:x_lower),x_neg) + +instance QOrd QDInt where + q_less qx qy = do (qx,qy,q) <- q_lt_signed qx qy; return q + q_leq qx qy = do (qx,qy,q) <- q_le_signed qx qy; return q + +-- ---------------------------------------------------------------------- +-- ** Multiplication + +-- | Multiply two 'QDInt's into a fresh third. Arguments are assumed to be of equal size. /O/(ℓ[sup 2]). +q_mult_qdint :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mult_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_mult_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_mult_qdint': represents integers as +-- big-headian qubit lists. +q_mult_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],[Qubit]) +q_mult_qulist [] [] = return ([], [], []) +q_mult_qulist xs ys = do + let x0 = last xs + x_higher = init xs + y_high = head ys + y_lower = tail ys + (x_higher, y_lower, p_higher) + <- q_mult_qulist x_higher y_lower + p0 <- qinit False + let y = y_high:y_lower + p = p_higher ++ [p0] + (y,p) <- q_add_in_place_qulist y p `controlled` x0 + return (x_higher ++ [x0], y, p) + +-- ---------------------------------------------------------------------- +-- ** Division and remainder + +-- | Reduce one 'QDInt' modulo another, in place, returning also the +-- integer quotient, i.e. (/x/, /y/) ↦ (/x/ mod /y/, /y/, /x/ div /y/). +-- All inputs and outputs are considered unsigned. Inputs are assumed +-- to have the same length. Division by zero returns (/x/,0,-1). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_moddiv_unsigned_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_moddiv_unsigned_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (r', y', q') <- q_moddiv_unsigned_in_place_qulist x' y' + let r = xint_of_list_bh r' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (r, y, q) + +-- | Low-level implementation of 'q_moddiv_unsigned_in_place': +-- represents integers as big-headian qubit lists. +-- +-- Implementation note: this algorithm can be optimized significantly: +-- [scratch] is always 0, so can be optimized away. This optimisation +-- is much clearer at the circuit level than the code level, however, +-- so is deferred for now. +q_moddiv_unsigned_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit],[Qubit]) +q_moddiv_unsigned_in_place_qulist x y = do + let l = common_value "q_divrem_unsigned_in_place: arguments must be same length" $ map length [x,y] + -- Set quot = 0, rem = x. At each stage, we will have y * quot + rem = x. + quot_bits <- qinit (replicate l False) + let rem = x + with_ancilla_init (replicate (l-1) False) (\scratch -> do + -- For j from (l-1) to 0, compute the jth bit of the quotient, and update the remainder + (y,scratch,quot_bits,rem) <- loop_with_indexM l (y,scratch,quot_bits,rem) + (\i (y,scratch,quot_bits,rem) -> do + let j = l-1-i + -- Getting y*(2^j) requires no quantum operations, just formal re-bracketing of the data: + let y_init = take j y + y_2j = (drop j y) ++ (take j scratch) + scratch_tail = drop j scratch + -- Compare (2^j) y with rem. If (2^j)y <= rem, then subtract (2^j)y from rem and flip the jth bit of quot. + ((y_init,y_2j,rem,quot_bits),()) <- with_computed_fun + (y_init,y_2j,rem,quot_bits) + (\(y_init,y_2j,rem,quot_bits) -> do + -- first, test that (2^j)y has not overflowed the register, i.e. that y_init is still all 0; + le1 <- qinit False + le1 <- qnot le1 `controlled` (y_init .==. replicate (length y_init) False) + -- next, test that (2^j)y <= rem (this will be correct if (2^j)y has not overflowed yet); + (y_2j,rem,le2) <- q_le_unsigned_qulist y_2j rem + return (y_init,y_2j,rem,quot_bits,le1,le2)) + (\(y_init,y_2j,rem,quot_bits,le1,le2) -> do + -- flip jth bit of quot, if appropriate + -- (leave rem unchanged for now, since it’s needed to uncompute le1) + q_j <- qnot (quot_bits !! (l-1-j)) `controlled` le1 .&&. le2 + return ((y_init,y_2j,rem,(overwriteAt (l-1-j) q_j quot_bits),le1,le2),())) + -- now, subtract (2^j) from rem, if appropriate. + (y_2j,rem) <- q_sub_in_place_qulist y_2j rem `controlled` quot_bits !! (l-1-j) + -- Finally, undo the formal re-bracketing: + let y = y_init ++ (take (l-j) y_2j) + scratch = (drop (l-j) y_2j) ++ scratch_tail + return (y,scratch,quot_bits,rem)) + return (rem, y, quot_bits)) + +-- | Reduce one 'QDInt' modulo another, i.e. (/x/, /y/) ↦ (/x/, /y/, /x/ mod /y/). +-- All inputs and outputs are considered unsigned. Inputs are assumed +-- to have the same length. If /y/ = 0, returns (/x/,0,/x/). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_mod_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_mod_unsigned x y = do + ((x,y),x_mod_y) <- with_computed_fun (x,y) + (\(x,y) -> q_moddiv_unsigned_in_place x y) + (\(x_mod_y, y, x_div_y) -> do + (x_mod_y, x_mod_y_out) <- qc_copy_fun x_mod_y + return ((x_mod_y, y, x_div_y), x_mod_y_out)) + return (x,y,x_mod_y) + +-- | Integer division of two 'QDInt's, returning the quotient and remainder, +-- i.e. (/x/,/y/) ↦ (/x/,/y/,/x/ div /y/,/x/ mod /y/). +-- All inputs and outputs are considered unsigned. +-- Inputs are assumed to have the same length. +-- Division by zero returns (-1,/x/). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_divrem_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt,QDInt) +q_divrem_unsigned x y = do + (x,rem) <- qc_copy_fun x + (rem,y,quot) <- q_moddiv_unsigned_in_place rem y + return (x,y,quot,rem) + +-- | Integer division of two 'QDInt's, returning just the quotient. +-- All inputs/outputs considered unsigned. +-- Inputs are assumed to have the same length. +-- Division by zero returns –1. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. + +-- Implementation note: We use a multiplication to do the +-- uncomputation of the remainder, because this uses fewer total gates +-- than uncomputing divrem would. +q_div_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_unsigned x y = do + (x,y,quot,rem) <- q_divrem_unsigned x y + ((x,y,quot),()) <- with_computed_fun (x,y,quot) + (\(x,y,quot) -> do + (y,quot,y_quot) <- q_mult y quot + (x,y_quot,rem_copy) <- q_sub x y_quot + return (x,y,quot,y_quot,rem_copy)) + (\(x,y,quot,y_quot,rem_copy) -> do + rem_copy <- qc_uncopy_fun rem_copy rem + return ((x,y,quot,y_quot,rem_copy),())) + return (x,y,quot) + +-- | Low-level version of 'q_div_unsigned': represents integers as +-- big-headian qubit lists. +q_div_unsigned_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_div_unsigned_qulist x' y' = do + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + (x, y, q) <- q_div_unsigned x y + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + let q' = list_of_xint_bh q + return (x', y', q') + +-- | Integer division of two 'QDInt's into a fresh third, rounding towards –∞. +-- The first argument is the numerator, and is assumed to be signed. +-- The second argument is the denominator, and is assumed to be unsigned. +-- The output is signed. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', q') <- q_div_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (x, y, q) + +-- | Low-level implementation of 'q_div': represents integers as +-- big-headian qubit lists. +q_div_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_div_qulist [] [] = return ([], [], []) +q_div_qulist (x_high:x_lower) y = do + -- Writing x/y for unsigned division, we have x `div` y = + -- if x>0 then x/y else ~((~x)/y) + -- where ~x := -1-x --- i.e. the bitflip of x. + -- + -- We do this with an ancilla (which can easily be optimized away): + with_ancilla_init False (\fake_x_high -> do + -- flip x if x<0: + x_lower <- mapUnary qnot x_lower `controlled` x_high + let x' = fake_x_high:x_lower + -- x' now holds (if x > 0 then x else ~x) + (x',y,quot) <- q_div_unsigned_qulist x' y + -- restore x and flip quotient, if necessary + let fake_x_high:x_lower = x' + x_lower <- mapUnary qnot x_lower `controlled` x_high + quot <- mapUnary qnot quot `controlled` x_high + return (x_high:x_lower, y, quot)) +q_div_qulist _ _ = error "q_div: arguments must have same length." + +-- | Integer division of two 'QDInt's into a fresh third, rounding towards 0. +-- The first argument is the numerator, and is assumed to be signed. +-- The second argument is the denominator, and is assumed to be unsigned. +-- The output is signed. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_quot :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_quot x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', q') <- q_quot_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (x, y, q) + +-- | Low-level implementation of 'q_quot': represents integers as +-- big-headian qubit lists. +q_quot_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_quot_qulist [] [] = return ([], [], []) +q_quot_qulist (x_high:x_lower) y = do + -- Writing x/y for unsigned division, we have x `div` y = + -- if x>0 then x/y else -((-x)/y) + -- + -- We do this with an ancilla (which can easily be optimized away): + with_ancilla_init False (\fake_x_high -> do + -- flip x if x<0: + x_lower <- q_negate_in_place_qulist x_lower `controlled` x_high + let x' = fake_x_high:x_lower + -- x' now holds (if x > 0 then x else ~x) + (x',y,quot) <- q_div_unsigned_qulist x' y + -- restore x and flip quotient, if necessary + let fake_x_high:x_lower = x' + x_lower <- q_negate_in_place_qulist x_lower `controlled` x_high + quot <- q_negate_in_place_qulist quot `controlled` x_high + return (x_high:x_lower, y, quot)) +q_quot_qulist _ _ = error "q_quot: arguments must have same length." + +-- | Integer division of two 'QDInt's, returning the quotient, +-- assuming that the second exactly divides the first and throwing an error otherwise. +-- All inputs/outputs considered unsigned. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div_exact_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_exact_unsigned x y = do + (x,y,quot,rem) <- q_divrem_unsigned x y + qterm 0 rem + return (x,y,quot) + +-- | Integer division of two 'QDInt's, returning the quotient, +-- assuming that the second exactly divides the first. +-- The first argument is the numerator, considered signed. +-- The second argument is the denominator, considered unsigned. +-- The output is signed. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div_exact :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_exact x y = do + (x,(y,quot)) <- with_computed_fun x + (\x -> do + (x,x_neg) <- q_negative x + x' <- q_negate_in_place x `controlled` x_neg + return (x',x_neg)) + (\(x',x_neg) -> do + (x',y,quot) <- q_div_exact_unsigned x' y + quot <- q_negate_in_place quot `controlled` x_neg + return ((x',x_neg),(y,quot))) + return (x,y,quot) + +-- ---------------------------------------------------------------------- +-- * The QNum type class + +-- $ This section defines a quantum analogue of Haskell’s 'Num' type +-- class. See "Quipper.Internal.QClasses" for the general philosophy behind +-- quantum type classes. +-- +-- The type class 'QNum' corresponds to Haskell’s 'Num', with methods +-- including +-- +-- > add_q :: (QNum qa) => qa -> qa -> Circ (qa,qa,qa), +-- +-- and so on. +-- +-- Note: type class instances don't show up in the documentation. View +-- the source code to see them. + +-- | Quantum analogue of Haskell’s 'Num' type class. This provides +-- basic addition, subtraction, multiplication, sign operations, and +-- conversion from integers. + +class (QData qa) => QNum qa where + -- | Add two quantum numbers into a fresh one. The arguments are + -- assumed to be of equal size. The 'QDInt' instance uses /O/(ℓ) + -- gates, both before and after transformation to Toffoli. + q_add :: qa -> qa -> Circ (qa,qa,qa) + + -- | Multiply two quantum numbers into a fresh third. The arguments + -- are assumed to be of equal size. The 'QDInt' instance is + -- /O/(ℓ[sup 2]). + q_mult :: qa -> qa -> Circ (qa,qa,qa) + + -- | Subtract two quantum numbers into a fresh one. The arguments + -- are assumed to be of equal size. The 'QDInt' instance uses /O/(ℓ) + -- gates, both before and after transformation to Toffoli. + q_sub :: qa -> qa -> Circ (qa,qa,qa) + + -- | Compute the absolute value of a (signed) quantum number. The + -- 'QDInt' instance is /O/(ℓ). + q_abs :: qa -> Circ (qa,qa) + + -- | Compute the negation of a (signed) quantum number. The 'QDInt' + -- instance is /O/(ℓ). + q_negate :: qa -> Circ (qa,qa) + + -- | Compute a quantum number of the same precision as the input, + -- with value 1, 0, or –1, depending on the sign of the + -- input. Analogous to Haskell’s 'signum'. The 'QDInt' instance is + -- /O/(ℓ). + q_signum :: qa -> Circ (qa,qa) + + -- | Convert a 'QDInt' to a quantum number. For the 'QDInt' + -- instance, this is just a copy operation. + q_fromQDInt :: QDInt -> Circ (QDInt,qa) + +instance QNum QDInt where + q_add = q_add_qdint + q_mult = q_mult_qdint + q_sub = q_sub_qdint + q_abs = q_abs_qdint + q_negate = q_negate_qdint + q_signum = q_signum_qdint + q_fromQDInt = qc_copy_fun + +-- ---------------------------------------------------------------------- +-- ** Specialized functions + +-- | Euclid's extended algorithm. 'q_ext_euclid' /a/ /b/: returns +-- (/a/,/b/,/x/,/y/,/d/) such that /ax/ + /by/ = /d/ = gcd(/a/,/b/). +q_ext_euclid :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt,QDInt) +q_ext_euclid a b = do + let l = common_length "q_ext_euclid: inputs must have equal length" [a,b] + + -- Extended Euclidean algorithm: + -- + -- compute three series of numbers (a_i), (x_i), (y_i), such that + -- + -- a_0 = a, a_1 = b, + -- a_{i+2} = a_i `mod` a_{i+1}, + -- and always a_i = (x_i * a) + (y_i * b), + -- + -- When we first get a_{i+2} = 0, we know that a_{i+1} is gcd(a_0,a_1), + -- so we save a_{i+1}, x_{i+1} and y_{i+1} for output. + -- + -- The bound on the length of this loop is standard. + + ((a,b),(x,y)) <- with_computed_fun (a,b) (\(a,b) -> do + x0 <- qinit (intm l 1) + y0 <- qinit (intm l 0) + x1 <- qinit (intm l 0) + y1 <- qinit (intm l 1) + done_yet <- qinit False + x_final <- qinit (intm l 0) + y_final <- qinit (intm l 0) + + (stuff1, stuff2, stuff3, (done_yet, x_final, y_final)) + <- loopM (euclid_bound l) ((a,b,x0,x1,y0,y1),[],[],(done_yet,x_final,y_final)) + (\((a_i, a_i1, x_i, x_i1, y_i, y_i1), quots_scratch, tests_scratch, (done_yet, x_final, y_final)) -> do + (a_i2, a_i1, q_i) <- q_moddiv_unsigned_in_place a_i a_i1 + ((x_i1, y_i1, q_i), (x_i2, y_i2)) <- with_computed_fun + (x_i1, y_i1, q_i) + (\(x_i1, y_i1, q_i) -> do + (q_i, x_i1, qx) <- q_mult q_i x_i1 + (q_i, y_i1, qy) <- q_mult q_i y_i1 + return (x_i1, y_i1, q_i, qx, qy)) + (\(x_i1, y_i1, q_i, qx, qy) -> do + (qx,x_i2) <- q_sub_in_place qx x_i + (qy,y_i2) <- q_sub_in_place qy y_i + return ((x_i1, y_i1, q_i, qx, qy),(x_i2,y_i2))) + done_this_time <- qinit False + done_this_time <- qnot done_this_time `controlled` (a_i2 .==. 0) .&&. (done_yet .==. False) + (x_i1,x_final) <- controlled_not x_final x_i1 `controlled` done_this_time + (y_i1,y_final) <- controlled_not y_final y_i1 `controlled` done_this_time + done_yet <- qnot done_yet `controlled` done_this_time + return ((a_i1, a_i2, x_i1, x_i2, y_i1, y_i2), + (q_i:quots_scratch), (done_this_time:tests_scratch), + (done_yet, x_final, y_final))) + qterm True done_yet -- Assert that we really did reach the end of the algorithm. + return (x_final,y_final,(stuff1, stuff2, stuff3))) + + (\(x_final, y_final, stuff) -> do + (x_final,x) <- qc_copy_fun x_final + (y_final,y) <- qc_copy_fun y_final + return ((x_final, y_final, stuff),(x,y))) + + ((a,b,x,y),gcd) <- with_computed_fun + (a,b,x,y) + (\(a,b,x,y) -> do + (a,x,ax) <- q_mult a x + (b,y,by) <- q_mult b y + return (a,b,x,y,ax,by)) + (\(a,b,x,y,ax,by) -> do + (ax,by,gcd) <- q_add ax by + return ((a,b,x,y,ax,by),gcd)) + + return (a,b,x,y,gcd) + + where + -- Classical bound on running time (Lamé’s theorem), assuming b < a: + -- t <= 1 + log_{phi} b <= 1 + l / (log_2 phi) + -- + -- We allow one extra step since we may have a < b, in which case first step swaps them. + euclid_bound :: Int -> Int + euclid_bound l = 2 + ceiling ( (fromIntegral l) / (logBase 2 phi) ) + phi = (1+sqrt(5))/2 + +-- ---------------------------------------------------------------------- +-- * Lifting of arithmetic functions + +-- $LIFTING +-- This sections provides templates for lifting various arithmetic +-- functions in connection with the @build_circuit@ keyword. This +-- extends the liftings given in "Quipper.Internal.CircLifting" to operations +-- of the 'Num' type class. + +-- | Quantum lifting of the '+' operator. +template_symb_plus_ :: (QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_plus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- q_add qx qy; return qz + +-- TODO: complete templates of methods. + diff --git a/Quipper/Libraries/ClassicalOptim.hs b/Quipper/Libraries/ClassicalOptim.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim.hs @@ -0,0 +1,35 @@ +-- | This library provides functions for optimizing classical +-- circuits. It is intended to reduce the size of +-- automatically-generated circuits, such as those that are built +-- using Quipper's @build_circuit@ keyword. +-- +-- Note: the resulting circuit is not expected to be optimal in +-- absolute terms. In general, finding the smallest possible circuit +-- to represent a given boolean function is an NP-hard +-- problem. Rather, we transform the input circuit by applying a +-- number of heuristics and an algebraic optimization technique. This +-- results in the removal of redundant qubits and gates that are +-- typical for machine-generated circuits. It generally decreases the +-- number of gates and ancillas. +-- +-- For example, consider the circuit for a simple adder, as generated +-- by the @build_circuit@ mechanism: +-- +-- \[image adder-unoptimized.png] +-- +-- The optimized version, as generated by 'simplify_classical', looks +-- like this: +-- +-- \[image adder-optimized.png] +-- +-- The above example can be found in the file +-- @Quipper\/Demos\/OptimTest.hs@ in the @quipper-demos@ package. + +module Quipper.Libraries.ClassicalOptim ( + simplify_classical, + classical_to_reversible_optim, + box_classical_to_reversible_optim +) where + +import Quipper.Libraries.ClassicalOptim.QuipperInterface + diff --git a/Quipper/Libraries/ClassicalOptim/AlgExp.hs b/Quipper/Libraries/ClassicalOptim/AlgExp.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/AlgExp.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# LANGUAGE OverlappingInstances #-} +#endif + +-- | This module contains an efficient representation of algebraic +-- boolean formulas. +module Quipper.Libraries.ClassicalOptim.AlgExp where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import Quipper.Utils.Auxiliary (bool_xor) + +import Quipper.Libraries.ClassicalOptim.Circuit + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Build the characteristic function of a set. +mapOfSet :: Ord a => S.Set a -> M.Map a Int +mapOfSet s = S.foldl' (\m x -> M.insert x 1 m) M.empty s + +-- | Get the set of elements whose images are odd. +setOfMap :: Ord a => M.Map a Int -> S.Set a +setOfMap m = + M.foldlWithKey' (\s x _ -> S.insert x s) S.empty $ + M.filter (\x -> mod x 2 == 1) m + +-- | Split a list in the middle. +split_even :: [a] -> ([a],[a]) +split_even a = splitAt (div (length a) 2) a + +-- ---------------------------------------------------------------------- +-- * Expressions + +-- | The type of algebraic boolean expressions. +-- +-- We represent boolean expressions using \"and\" and \"xor\" as the +-- primitive connectives. Equivalently, we can regard booleans as the +-- elements of the two-element field /F/[sub 2], with operations \"*\" +-- (times) and \"+\" (plus). +-- +-- An algebraic expression +-- @x1*x2*x3 + y1*y2*y3 + z1*z2@ +-- is encoded as +-- @{{x1,x2,x3},{y1,y2,y3},{z1,z2}}@. +-- +-- In particular, +-- @{} == False == 0@ and +-- @{{}} == True == 1@. +type Exp = S.Set IS.IntSet + +instance {-# OVERLAPPING #-} Show Exp where + show e = if (S.null e) then "F" + else if (e == S.singleton (IS.empty)) then "T" + else L.concat $ L.intersperse "+" (L.map (\e -> L.concat $ L.map (\x -> "x" ++ (show x)) $ IS.toList e) $ S.toList e) + +-- | Turn an @Exp@ into a list of lists. +listOfExp :: Exp -> [[Int]] +listOfExp e = S.toList $ S.map IS.toList e + +-- | Turn a list of lists into an @Exp@. +expOfList :: [[Int]] -> Exp +expOfList l = S.fromList $ L.map IS.fromList l + +-- | The conjunction of two expression. +exp_and :: Exp -> Exp -> Exp +exp_and a b = + setOfMap $ + S.foldl (\exp monomial -> M.unionWith (+) exp $ exp_and_aux monomial $ mapOfSet a) M.empty b + where + exp_and_aux :: IS.IntSet -> M.Map IS.IntSet Int -> M.Map IS.IntSet Int + exp_and_aux monomial exp = M.mapKeysWith (+) (IS.union monomial) exp + +-- | The xor of two expressions. +exp_xor :: Exp -> Exp -> Exp +exp_xor a b = setOfMap $ M.unionWith (+) (mapOfSet a) (mapOfSet b) + +-- | The expression \"False\". +exp_false :: Exp +exp_false = S.empty + +-- | The expression \"True\". +exp_true :: Exp +exp_true = S.singleton IS.empty + +-- | The negation of an expression. +exp_not :: Exp -> Exp +exp_not e = exp_xor e exp_true + +-- | The expression /x/[sub /n/]. +exp_var :: Int -> Exp +exp_var x = S.singleton $ IS.singleton x + +-- ---------------------------------------------------------------------- +-- * Properties of expressions + +-- $ The important property of expressions is that two formulas have +-- the same truth table iff they are syntactically equal. This makes +-- the equality test of wires theoretically straightforward. + +-- ---------------------------------------------------------------------- +-- ** Truth tables + +-- $ A /valuation/ on a set of variables is a map from variables to +-- booleans. This can be thought of as a row in a truth table. A +-- /truth table/ is a map from valuations to booleans, but we just +-- represent this as a list of booleans, listed in lexicographically +-- increasing order of valuations. + +-- | Get the variables used in an expression. +vars_of_exp :: Exp -> [Int] +vars_of_exp e = IS.toList $ S.foldl (\a b -> IS.union a b) IS.empty e + +-- | Evaluate the expression with respect to the given valuation. A +-- /valuation/ is a map from variables to booleans, i.e., a row in a +-- truth table. +exp_eval :: Exp -> M.Map Int Bool -> Bool +exp_eval e m = L.foldl bool_xor False $ L.map (L.foldl (&&) True) $ L.map (L.map (m M.!)) $ L.map (IS.toList) $ S.toList e + +-- | Construct the list of all 2[super /n/] valuations for a given +-- list of /n/ variables. +valuations_of_vars :: [Int] -> [M.Map Int Bool] +valuations_of_vars [] = [M.empty] +valuations_of_vars (h:t) = l + where + l = (L.map (M.insert h False) v) ++ (L.map (M.insert h True) v) + v = valuations_of_vars t + +-- | Build the truth table for the given expression, on the given list +-- of variables. The truth table is returned as a list of booleans in +-- lexicographic order of valuations. For example, if +-- +-- > 1 2 | exp +-- > F F | f1 +-- > F T | f2 +-- > T F | f3 +-- > T T | f4 +-- +-- then the output of the function is @[f1,f2,f3,f4]@. +truth_table_of_exp :: [Int] -> Exp -> [Bool] +truth_table_of_exp vars e = L.map (exp_eval e) (valuations_of_vars vars) + +-- | Return an expression realizing the given truth table. Uses +-- variables starting with the given number. +exp_of_truth_table :: Int -> [Bool] -> Exp +exp_of_truth_table i [] = exp_true +exp_of_truth_table i [False] = exp_false +exp_of_truth_table i [True] = exp_true +exp_of_truth_table i t = ((exp_not (exp_var i)) `exp_and` e1) `exp_xor` ((exp_var i) `exp_and` e2) + where + (t1,t2) = split_even t + e1 = exp_of_truth_table (i+1) t1 + e2 = exp_of_truth_table (i+1) t2 + diff --git a/Quipper/Libraries/ClassicalOptim/Circuit.hs b/Quipper/Libraries/ClassicalOptim/Circuit.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/Circuit.hs @@ -0,0 +1,128 @@ +-- | This module provides a simplified representation of classical +-- circuits. +module Quipper.Libraries.ClassicalOptim.Circuit where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Quipper.Utils.Auxiliary as Q + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ---------------------------------------------------------------------- +-- * Simplified circuits + +-- | The type of wires. A wire is determined by an integer ID. +type Wire = Int + +-- | The type of gates. +data Gate = + NoOp -- ^ No operation. + | Init Bool Wire -- ^ Initialization. + | Cnot Wire [(Wire,Bool)] -- ^ Multi-controlled not. + deriving (Show,Eq) + +-- | Get the wire acted upon by a gate, if any. +wireOfGate :: Gate -> Maybe Wire +wireOfGate NoOp = Nothing +wireOfGate (Init _ w) = Just w +wireOfGate (Cnot w _) = Just w + +-- | Get the list of controls, if any. +ctlsOfGate :: Gate -> Maybe [(Wire,Bool)] +ctlsOfGate (Cnot _ ctls) = Just ctls +ctlsOfGate _ = Nothing + +-- | Evaluate a circuit on a given initial state, and return the final +-- state. A state is represented as a map from wires to booleans. +evalCirc :: M.Map Wire Bool -> [Gate] -> M.Map Wire Bool +evalCirc m [] = m +evalCirc m (NoOp:gs) = evalCirc m gs +evalCirc m ((Init b w):gs) = evalCirc (M.insert w b m) gs +evalCirc m ((Cnot w ctls):gs) = evalCirc (M.adjust (Q.bool_xor (ands m ctls)) w m) gs + where + ands m [] = True + ands m ((w,b):ctls) = ((m M.! w) `Q.bool_xor` (not b)) && (ands m ctls) + +-- ---------------------------------------------------------------------- +-- * Simplified Circ monad + +-- | A data structure to represent a \"circuit under +-- construction\". This holds the data needed for circuit generation. +data CircState = CS { + circuit :: [Gate], -- ^ The circuit so far. + freshWire :: Wire -- ^ The next fresh wire. +} deriving (Show) + +-- | The empty state. +emptyState :: CircState +emptyState = CS {circuit = [], freshWire = 0} + +-- | A simplified @Circ@ monad. +data Circ a = Circ (CircState -> (CircState, a)) + +instance Monad Circ where + return x = Circ (\y -> (y,x)) + (>>=) (Circ c) f = Circ (\s -> let (s',x) = c s in + let (Circ c') = f x in + c' s') + +instance Applicative Circ where + pure = return + (<*>) = ap + +instance Functor Circ where + fmap = liftM + +-- ---------------------------------------------------------------------- +-- * Low-level access functions + +-- | Retrieve the next fresh wire. +getFresh :: Circ Wire +getFresh = Circ (\s -> (s, freshWire s)) + +-- | Increment the value of the fresh wire. +incrementFresh :: Circ () +incrementFresh = Circ (\s -> (s { freshWire = freshWire s + 1 }, ())) + +-- | Add a new gate to the circuit. +addGate :: Gate -> Circ () +addGate g = Circ (\s -> (s {circuit = g : (circuit s)}, ())) + +-- | Get the circuit out of the monad. +extractCircuit :: Circ a -> [Gate] +extractCircuit (Circ c) = circuit $ fst $ c emptyState + +-- ---------------------------------------------------------------------- +-- * Higher-level access functions + +-- | Initialize a new wire. +init :: Bool -> Circ Wire +init b = do + w <- getFresh + addGate (Init b w) + incrementFresh + return w + +-- | Add a multi-controlled not gate. +cnot :: Wire -> [(Wire,Bool)] -> Circ () +cnot w ws = do + addGate (Cnot w ws) + return () + +-- ---------------------------------------------------------------------- +-- * Pretty-printing + +-- $ These functions are only used for testing. + +-- | Pretty-print a circuit as a list of gates. +printCircuit :: Circ a -> IO () +printCircuit c = do + mapM_ putStrLn $ map show $ reverse $ extractCircuit c + +-- | Print a gate as Quipper code. +print_quipperStyle :: Gate -> IO () +print_quipperStyle (Init b w) = putStrLn (" x" ++ (show w) ++ " <- Q.qinit " ++ (show b)) +print_quipperStyle (Cnot w ctls) = putStrLn (" Q.qnot x" ++ (show w) ++ " `Q.controlled` " ++ + (L.intercalate " Q..&&. " $ map (\(w,b) -> "x" ++ (show w) ++ " Q..==. " ++ (show b) ++ " ") ctls)) +print_quipperStyle g = putStrLn (" Q.comment \"" ++ (show g) ++ "\"") diff --git a/Quipper/Libraries/ClassicalOptim/QuickCheck.hs b/Quipper/Libraries/ClassicalOptim/QuickCheck.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/QuickCheck.hs @@ -0,0 +1,158 @@ +-- | This module provides some automated tests for the algebraic +-- optimization procedure. The main function are: +-- +-- * 'testArith5': runs the optimization on a reversible adder +-- generated with Template Haskell and exhaustively tests all the +-- values. +-- +-- * 'testCircSimpl' and 'testCircSwap': using the "Test.QuickCheck" +-- library, perform optimization on randomly generated circuits and +-- test validity for some random input. +module Quipper.Libraries.ClassicalOptim.QuickCheck where + +import qualified Data.Map as M +import qualified Data.List as L + +import qualified Test.QuickCheck as Test + +import qualified Quipper as Q +import qualified Quipper.Internal.Circuit as Q +import qualified Quipper.Libraries.Simulation.ClassicalSimulation as Q +import qualified Quipper.Utils.Auxiliary as Q + +import Quipper.Libraries.ClassicalOptim.Circuit +import Quipper.Libraries.ClassicalOptim.Simplification +import Quipper.Libraries.ClassicalOptim.QuipperInterface +import Quipper.Libraries.ClassicalOptim.QuickCheckArith + +-- ---------------------------------------------------------------------- +-- * Testing an adder + +-- | Wrapper around 'template_adder'. +myAdder :: ([Q.Qubit],[Q.Qubit]) -> Q.Circ [Q.Qubit] +myAdder (x,y) = do + Q.label (x,y) ("x","y") + z <- Q.unpack template_adder x y + Q.label z "z" + return (z) + +-- | A synonym for 'myAdder'. +myArith :: ([Q.Qubit], [Q.Qubit]) -> Q.Circ [Q.Qubit] +myArith = myAdder + +-- | The optimized version of 'myArith'. +myCircArith :: Int -> (CircState, [Wire]) +myCircArith n = quipperFunToMyCirc myArith (replicate n Q.qubit, replicate n Q.qubit) + +-- | The 'Q.BCircuit' of the optimized version of 'myArith'. +bCircArith :: Int -> Q.BCircuit +bCircArith n = + fst $ simplify_classical' myArith (replicate n Q.qubit, replicate n Q.qubit) + +-- | Extract the underlying 'Wire' from a 'Q.B_Endpoint'. +wire_of_endpoint :: Q.B_Endpoint t t -> t +wire_of_endpoint (Q.Endpoint_Qubit x) = x +wire_of_endpoint (Q.Endpoint_Bit x) = x + +-- | Run the reversible adder, non-optimized. +runArithDry :: Int -> Int -> Int -> Int +runArithDry n x y = + Q.int_of_boollist_unsigned_bh $ reverse $ Q.run_classical_unary myAdder (Q.boollist_of_int_lh n x, Q.boollist_of_int_lh n y) + +-- | Run the reversible adder, optimized. +runArith :: Int -> Int -> Int -> Int +runArith n x y = Q.int_of_boollist_unsigned_bh $ reverse $ map wire_of_endpoint $ map (mymap M.!) out + where + list = (Q.boollist_of_int_lh n x) ++ (Q.boollist_of_int_lh n y) + (simpl_bc,out) = simplify_classical' myAdder (replicate n Q.qubit, replicate n Q.qubit) + mymap = + Q.run_classical simpl_bc $ + M.fromList $ + zip [0..(length list - 1)] $ map Q.Endpoint_Qubit list + +-- | Exhaustively test all the inputs of the optimized adder. +testArith5 :: Bool +testArith5 = foldl (&&) True is_good + where + op = runArith 5 + inputs = concat [ map (\x -> (i,x)) [0..31] | i <- [0..31]] + results = map (uncurry $ op) inputs + testcase = map (\(x,y) -> mod (x+y) 32) inputs + is_good = map (\(x,y) -> x == y) $ zip results testcase + +-- ---------------------------------------------------------------------- +-- * Randomized tests + +-- $ The following functions use the "Test.QuickCheck" library. They +-- generate random circuits, and run them classically before and after +-- optimization. + +-- | Return all sublists of the given size. +choose :: [b] -> Int -> [[b]] +choose _ 0 = [[]] +choose [] _ = [] +choose (x:xs) k = map (x:) (choose xs (k-1)) ++ (choose xs k) + +-- | Generate a random circuit with the given number of inputs and +-- ancillas. +genCirc :: Int -> Int -> Test.Gen ([Gate],[Wire]) +genCirc size_input nber_ancillas = do + -- random wire + let randWire = Test.choose (0, size_input + nber_ancillas - 1) + -- random gate + let randGate = do + type_gate <- Test.choose (1,3) -- say if it is not, cnot or ccnot + list <- Test.oneof $ map return $ map reverse $ choose [0..(size_input + nber_ancillas - 1)] type_gate + let (w:ws) = list + ctls <- mapM (\x -> do + b <- Test.oneof $ map return [False,True] + return (x,b)) ws + return (Cnot w ctls) + -- create output wires + size_outputs <- Test.choose (1,size_input + nber_ancillas) + outputs <- Test.oneof $ map return $ choose [0..(size_input + nber_ancillas - 1)] size_outputs + -- create gates + nber_gates <- Test.choose (10,50) + -- let nber_gates = 6 + cnots <- Test.vectorOf nber_gates randGate + let ancillas = map (\w -> Init True w) [size_input..size_input+nber_ancillas-1] + return (ancillas ++ cnots, outputs) + + +-- | Print some sample circuits generated by 'genCirc'. +printSampleCirc :: Int -> Int -> IO () +printSampleCirc i a = do + list <- Test.sample' (genCirc i a) + mapM_ (\(a,ws) -> do + putStrLn "\n\n" + putStrLn $ show (a,ws) + putStrLn "goes into\n" + putStrLn $ show $ simplRec (a,ws)) list + +-- | Restrict a map to the given domain. +restrict :: Ord k => [k] -> M.Map k a -> M.Map k a +restrict l m = L.foldl (\a b -> M.insert b (m M.! b) a) M.empty l + +-- | Test of 'simplRec'. +testCircSimpl :: Test.Property +testCircSimpl = Test.forAll (genCirc 2 3) $ \(f,outs) -> + Test.forAll (Test.vectorOf 2 $ Test.oneof [return False,return True]) $ \b -> + let m = M.fromList (zip [0..10] b) in + let (f',o') = simplRec (f,outs) in + L.map ((evalCirc m f) M.!) outs == L.map ((evalCirc m f') M.!) o' + +-- | Test of 'alg_swap'. +testCircSwap :: Test.Property +testCircSwap = Test.forAll (genCirc 2 3) $ \(f,outs) -> + Test.forAll (Test.vectorOf 2 $ Test.oneof [return False,return True]) $ \b -> + let m = M.fromList (zip [0..10] b) in + let (f',o') = alg_swap (f,outs) in + L.map ((evalCirc m f) M.!) outs == L.map ((evalCirc m f') M.!) o' + +-- | A wrapper function to easily run a test. +-- Within the interpreter @quipperi@, use, e.g., as +-- +-- > myQuickTest testCircSimpl +myQuickTest :: Test.Property -> IO Test.Result +myQuickTest x = Test.quickCheckWithResult (Test.stdArgs {Test.maxSuccess = 1000}) x + diff --git a/Quipper/Libraries/ClassicalOptim/QuickCheckAlgExp.hs b/Quipper/Libraries/ClassicalOptim/QuickCheckAlgExp.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/QuickCheckAlgExp.hs @@ -0,0 +1,64 @@ +module Quipper.Libraries.ClassicalOptim.QuickCheckAlgExp where + +import qualified Test.QuickCheck as Test + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import Quipper.Utils.Auxiliary (bool_xor) + +import Quipper.Libraries.ClassicalOptim.Circuit + +import Quipper.Libraries.ClassicalOptim.AlgExp + +-- ---------------------------------------------------------------------- +-- ** Quick-checking + +-- | Compute 2[sup /n/]. +twoExp :: (Integral a) => a -> Int +twoExp 0 = 1 +twoExp n | mod n 2 == 0 = let a = twoExp (div n 2) in a * a + | otherwise = 2 * (twoExp (n-1)) + +-- | Generate a list of 'Bool'. +genBoolList :: Integral a => a -> Test.Gen [Bool] +genBoolList n = Test.vectorOf (twoExp n) $ Test.oneof [return True, return False] + +-- | Arguments for QuickCheck. +test_args :: Test.Args +test_args = Test.stdArgs { Test.maxSize = 100, + Test.maxSuccess = 100, + Test.maxDiscardRatio = 20 } + +-- | First test: truth table to expression to truth table is the identity. +test_truth1 :: Int -> IO () +test_truth1 n = Test.quickCheckWith test_args $ aux + where + aux = Test.forAll (genBoolList n) $ \x -> + x == (truth_table_of_exp [1..n] $ exp_of_truth_table 1 x) + +-- | Generate a random list of @Int@s. +genIntList :: [Int] -> Int -> Test.Gen [Int] +genIntList vars size = do + s <- Test.choose (0,size) + Test.vectorOf s $ Test.elements vars + +-- | Generate a random expression out of the given variables. +genExp :: [Int] -> Test.Gen Exp +genExp vars = do + nber <- Test.choose (0, twoExp (length vars)) + v <- Test.vectorOf nber $ Test.sized $ genIntList vars + return $ expOfList v + +-- | Second test: expression to truth table to expression is the +-- identity. +test_truth2 :: Int -> IO Test.Result +test_truth2 n = Test.quickCheckWithResult test_args $ aux + where + aux = Test.forAll (genExp [1..n]) $ \x -> + x == (exp_of_truth_table 1 $ truth_table_of_exp [1..n] x) + + diff --git a/Quipper/Libraries/ClassicalOptim/QuickCheckArith.hs b/Quipper/Libraries/ClassicalOptim/QuickCheckArith.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/QuickCheckArith.hs @@ -0,0 +1,194 @@ +-- | This module contains small examples of arithmetic functions, +-- coded in Template Haskell, for use with +-- "Quipper.Libraries.ClassicalOptim.QuickCheck". +module Quipper.Libraries.ClassicalOptim.QuickCheckArith where + +import qualified Test.QuickCheck as Test + +import Quipper + +import Data.List +import Quipper +import Quipper.Libraries.Arith +import Quipper.Utils.Auxiliary +import Prelude hiding (subtract) + +-- ---------------------------------------------------------------------- +-- * Binary representation of integers + +-- | Compute an unsigned integer from its binary representation. The +-- input is a big-headian list of booleans. This means that the head +-- of the list is the most significant digit. +int_of_boollist :: [Bool] -> Integer +int_of_boollist = integer_of_intm_unsigned . intm_of_boollist_bh . reverse + +-- | Compute the binary representation of an unsigned integer, using +-- the given number of digits. The output is the binary representation +-- as a big-headian list of booleans. +boollist_of_int :: Int -> Integer -> [Bool] +boollist_of_int m n = reverse (boollist_of_intm_bh $ intm_with_length (Just m) n) + +-- ---------------------------------------------------------------------- +-- * Circuit templates for common functions + +-- | Template Haskell version of 'map'. +template_map :: Circ ((a -> Circ a) -> Circ ([a] -> Circ [a])) +template_map = return $ \func -> return $ \qs -> mapM func qs + +-- | Template Haskell version of 'zip'. +template_zip :: Circ ([a] -> Circ ([b] -> Circ [(a,b)])) +template_zip = return $ \a -> return $ \b -> return (zip a b) + +-- | Template Haskell version of 'tail'. +template_tail :: Circ ([a] -> Circ [a]) +template_tail = return $ \t -> return $ tail t + +-- | Template Haskell version of @[]@. +template_symb_obracket_symb_cbracket_ :: Circ [a] +template_symb_obracket_symb_cbracket_ = return [] + +-- | Monadic version of 'mapAccumL'. +mapAccumLM :: (acc -> x -> Circ (acc,y)) -> acc -> [x] -> Circ (acc,[y]) +mapAccumLM f acc [] = return (acc,[]) +mapAccumLM f acc (h:t) = do + (a,y) <- f acc h + (a',t') <- mapAccumLM f a t + return (a',y:t') + +-- | Template Haskell version of 'mapAccumL'. +template_mapAccumL :: Circ ((acc -> Circ (x -> Circ (acc,y))) -> Circ (acc -> Circ ([x] -> Circ (acc,[y])))) +template_mapAccumL = return $ \fcirc -> return $ \acc -> return $ \xs -> + let f = (\acc x -> do + g <- fcirc acc + g x) + in mapAccumLM f acc xs + +-- ---------------------------------------------------------------------- +-- * Tests + +-- ---------------------------------------------------------------------- +-- ** Addition + +-- | Return the majority of three booleans. +build_circuit +majority :: Bool -> Bool -> Bool -> Bool +majority a b c = if (a `bool_xor` b) then c else a + +-- majority a b c = a `bool_xor` ((a `bool_xor` b) && (a `bool_xor` c)) + +-- | Bit adder. The first input is 'False' for adding, and 'True' for +-- subtracting. The second input is a triple consisting of a carry, +-- and two bits to be added. The output consists of the new carry and +-- the sum. +build_circuit +bit_adder :: Bool -> (Bool,Bool,Bool) -> (Bool,Bool) +bit_adder sign (carry, x,y) = + let y' = y `bool_xor` sign in + let z = carry `bool_xor` x `bool_xor` y' in + let carry' = majority carry x y' in + (carry', z) + + +-- | Multi-bit adder. Add two /n/-bit integers, represented as +-- little-tailian bit lists. +build_circuit +adder :: [Bool] -> [Bool] -> [Bool] +adder f l = + reverse $ snd $ fold_right_zip (bit_adder False) (False, reverse l, reverse f) + +-- | Test the validity of the functional implementation of 'adder'. +test_adder' :: Test.Property +test_adder' = Test.forAll (Test.choose (0,255)) $ \x -> + Test.forAll (Test.choose (0,255)) $ \y -> + boollist_of_int 9 (x + y) + == + adder (boollist_of_int 9 x) (boollist_of_int 9 y) + +-- | Wrapper around 'test_adder''. +test_adder :: IO () +test_adder = Test.quickCheck test_adder' + +-- ---------------------------------------------------------------------- +-- ** Subtraction + +-- | Reversible subtraction. +build_circuit +subtract :: [Bool] -> [Bool] -> [Bool] +subtract f l = + let l' = map not l in + case l' of + [] -> [] + (h:t) -> let one = (True:(map (\x -> False) t)) in + adder one (adder f l') + +-- | Test the validity of the functional implementation of 'subtract'. +test_subtract' :: Test.Property +test_subtract' = Test.forAll (Test.choose (0,255)) $ \x -> + Test.forAll (Test.choose (0,255)) $ \y -> + boollist_of_int 9 x + == + subtract (boollist_of_int 9 (x+y)) (boollist_of_int 9 y) + +-- | Wrapper around 'test_subtract''. +test_subtract :: IO () +test_subtract = Test.quickCheck test_subtract' + +-- ---------------------------------------------------------------------- +-- ** Multiplication + +-- | Pad the second list on the right, to the length of (and using the +-- corresponding elements of) the first list. +build_circuit +pad_right :: [Bool] -> [Bool] -> [Bool] +pad_right shape l = case (shape,l) of + (shape, []) -> shape + ([], l) -> l + ((_:t1), (h:t2)) -> h:(pad_right t1 t2) + +-- | Shift a bit list to the right by one. +build_circuit +shift :: [Bool] -> [Bool] +shift l = False:l + +-- | 'takeOnly' /shape/ /l/: take the first @('length' /shape/)@ +-- elements out of /l/. +build_circuit +takeOnly :: [Bool] -> [Bool] -> [Bool] +takeOnly _ [] = [] +takeOnly [] _ = [] +takeOnly (h1:t1) (h2:t2) = h2:(takeOnly t1 t2) + + +-- | Reversible multiplier stripping high bits. +build_circuit +multiplier' :: [Bool] -> [Bool] -> [Bool] +multiplier' l1 l2 = + let zero = map (\x -> False) (l1 ++ l2) in + takeOnly l1 $ foldl adder zero (snd ( + mapAccumL + (\acc x -> (False:acc, pad_right zero (acc ++ (map (\y -> y && x) l1)))) [] l2 + )) + + +-- | Reversible multiplier keeping high bits. +build_circuit +multiplier :: [Bool] -> [Bool] -> [Bool] +multiplier l1 l2 = + let zero = map (\x -> False) (l1 ++ l2) in + foldl adder zero (snd ( + mapAccumL + (\acc x -> (False:acc, pad_right zero (acc ++ (map (\y -> y && x) l1)))) [] l2 + )) + +-- | Test the validity of the functional implementation of 'multiplier'. +test_multiplier' :: Test.Property +test_multiplier' = Test.forAll (Test.choose (0,255)) $ \x -> + Test.forAll (Test.choose (0,255)) $ \y -> + boollist_of_int 18 (x * y) + == + multiplier (boollist_of_int 9 x) (boollist_of_int 9 y) + +-- | Wrapper around 'test_multiplier''. +test_multiplier :: IO Test.Result +test_multiplier = Test.quickCheckResult test_multiplier' + diff --git a/Quipper/Libraries/ClassicalOptim/QuickCheckMain.hs b/Quipper/Libraries/ClassicalOptim/QuickCheckMain.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/QuickCheckMain.hs @@ -0,0 +1,23 @@ +module Main where + +import Test.QuickCheck +import System.Exit + +import Quipper.Libraries.ClassicalOptim.QuickCheck +import Quipper.Libraries.ClassicalOptim.QuickCheckAlgExp +import Quipper.Libraries.ClassicalOptim.QuickCheckArith + +try :: String -> IO Result -> IO () +try name body = do + putStrLn name + r <- body + if not (isSuccess r) then exitFailure else return () + +main :: IO () +main = do + try "test_truth2 2" $ test_truth2 2 + try "test_truth2 5" $ test_truth2 5 + try "test_truth2 10" $ test_truth2 10 + try "test_multiplier" $ test_multiplier + try "testCircSimpl" $ myQuickTest testCircSimpl + try "testCircSwap" $ myQuickTest testCircSwap diff --git a/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs b/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs @@ -0,0 +1,171 @@ +-- | This module contains the interface between the simplified circuit +-- model and Quipper's internal circuit model. The main useful +-- exported functions are: +-- +-- * @'simplify_classical'@, which optimizes a classical circuit such +-- as those coming from Template Haskell; +-- +-- * @'classical_to_reversible_optim'@, which provides a mechanism +-- equivalent to @'Q.classical_to_reversible'@, but with optimization +-- inlined. + +module Quipper.Libraries.ClassicalOptim.QuipperInterface where + +import Data.Maybe + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import qualified Quipper as Q +import qualified Quipper.Internal.Monad as Q +import qualified Quipper.Internal.QData as Q +import qualified Quipper.Internal.Circuit as Q +import qualified Quipper.Internal.Generic as Q +import qualified Quipper.Internal.Printing as Q +import qualified Quipper.Libraries.Simulation as Q +import qualified Quipper.Libraries.Simulation.ClassicalSimulation as Q +import qualified Quipper.Internal.Transformer as Q +import qualified Quipper.Internal.Control as Q + +import qualified Quipper.Libraries.Arith as Q +import qualified Quipper.Utils.Auxiliary as Q + +import Quipper.Libraries.ClassicalOptim.Circuit +import Quipper.Libraries.ClassicalOptim.Simplification + + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Extract the list of wires from a piece of quantum data. +getListWire :: (Q.QData qc) => qc -> [Wire] +getListWire x = map Q.wire_of_qubit $ Q.qubits_of_qdata x + +-- ---------------------------------------------------------------------- +-- * Quipper circuits to simple circuits + +-- | Translates a Quipper circuit to a simple circuit. The only gates +-- considered are initializations, terminations, and multi-controlled +-- NOT gates. All other gates are ignored. +-- +-- Note that simple circuits do not possess termination wires: these +-- wires are simply not terminated, and all subsequent initializations +-- using the same wire ID are sent to fresh wires. +-- +-- The state of this function is a bit complex, as it keeps track of +-- where the output wires are mapped to. +quipperGateToMyGate :: (IS.IntSet,IM.IntMap Wire,Wire) -> Q.Gate -> ((IS.IntSet,IM.IntMap Wire,Wire), Maybe Gate) +quipperGateToMyGate (s,m,f) (Q.QGate "not" _ [w] _ ctls _) = + ((s,m,f), Just $ Cnot (IM.findWithDefault w w m) $ map (\(Q.Signed a b) -> (IM.findWithDefault a a m,b)) ctls) +quipperGateToMyGate (s,m,f) (Q.QInit b w _) = case (IS.member w s) of + True -> ((s,IM.insert w f m,f+1), Just $ Init b f) + False -> ((s,m,f), Just $ Init b w) +quipperGateToMyGate (s,m,f) (Q.QTerm b w _) = ((IS.insert w s, m,f), Nothing) +quipperGateToMyGate smf _ = (smf, Nothing) + + +-- | Get the wire initialized by the gate, if it is an initialization gate. +quipperGateInitW :: Q.Gate -> Maybe Wire +quipperGateInitW (Q.QInit _ w _) = Just w +quipperGateInitW _ = Nothing + +-- | Given a list of Quipper gates, get the smallest wire id not in use. +quipperGateFreshWire :: Wire -> [Q.Gate] -> Wire +quipperGateFreshWire w gs = (+) 1 $ L.foldl' max w $ catMaybes $ map quipperGateInitW gs + +-- | Send a Quipper 'Q.Circuit' to a 'CircState'. +quipperCircuitToMyCirc :: Q.Circuit -> CircState +quipperCircuitToMyCirc (_, gs, _, n) = + emptyState { + circuit = catMaybes $ snd $ L.mapAccumL quipperGateToMyGate (IS.empty,IM.empty,quipperGateFreshWire n gs) gs, + freshWire = n + } + +-- | Send a Quipper 'Q.BCircuit' to a 'CircState'. +quipperBCircuitToMyCirc :: Q.BCircuit -> CircState +quipperBCircuitToMyCirc (c,_) = quipperCircuitToMyCirc c + +-- | Generate a custom error message. +myCircErrMsg :: String -> String +myCircErrMsg s = "myCirc: " ++ s + +-- | Given a Quipper circuit generating function and a shape argument, +-- return a simple circuit together with the list of non-garbage +-- circuit outputs. +quipperFunToMyCirc :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (CircState,[Wire]) +quipperFunToMyCirc f shape = + let (_, bc, output) = Q.encapsulate_generic myCircErrMsg f shape + in (quipperBCircuitToMyCirc bc, + getListWire output) + +-- ---------------------------------------------------------------------- +-- * Simple circuits to Quipper circuits + +-- | Translate a gate from the simple circuit model into a Quipper gate. +myGateToQuipperGate :: Gate -> Q.Gate +myGateToQuipperGate (Cnot w ctls) = Q.QGate "not" True [w] [] (map (\(w,b) -> Q.Signed w b) ctls) False +myGateToQuipperGate (Init b w) = Q.QInit b w False +myGateToQuipperGate NoOp = error "myGateToQuipperGate cannot deal with NoOp" + +-- | Generate a Quipper comment. The first argument is a comment +-- string, and the second argument is a label to apply to the qubits +-- in the third argument. +makeComment :: String -> String -> [Wire] -> Q.Gate +makeComment comment label ws = + Q.Comment comment False $ map (\(i,x) -> (i, label ++ "[" ++ (show x) ++ "]")) (zip ws [0..(length ws)-1]) + + +-- ---------------------------------------------------------------------- +-- * Algebraic optimization of Quipper circuits + +-- | Optimize a Quipper 'Q.BCircuit'. The second argument is the list +-- of non-garbage outputs. A corresponding list of outputs is also +-- returned along with the circuit. +quipperBCircuitSimpl :: Q.BCircuit -> [Wire] -> (Q.BCircuit,[Wire]) +quipperBCircuitSimpl (c,e) output = (((a1,c'',a2',n'),e),o') + where + (a1,gs,a2,n) = c + mycirc = quipperCircuitToMyCirc c + (c',o') = compressWires (IM.keys a1) $ simplRec $ (\x -> (x,output)) {-set_init_first output-} $ circuit $ mycirc + i' = IM.keys a1 + c'' = (makeComment "Start classical circuit" "in" i') : + (map myGateToQuipperGate c') ++ + [makeComment "End classical circuit" "out" o'] + allwires = getAllWires c' + a2' = IM.fromList $ map (\x -> (x,Q.Qbit)) $ IS.toAscList allwires + n' = (+) 1 $ head $ IS.toDescList allwires + + +-- | Optimize a Quipper circuit producing function (together with a +-- shape argument). Return the optimized circuit as a Quipper +-- 'Q.BCircuit', along with a list of the non-garbage circuit outputs. +simplify_classical' :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (Q.BCircuit, [Wire]) +simplify_classical' f shape = + let (_,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in + let list_output = getListWire output in + quipperBCircuitSimpl bc list_output + +-- | Optimize a Quipper circuit-producing function. This assumes that +-- the function only consists of pseudo-classical quantum gates, i.e., +-- initializations, terminations, and (possibly multiply controlled) +-- NOT gates. The behavior on other kinds of circuits is undefined. +-- The second argument is a shape parameter. +simplify_classical :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> Q.Circ y +simplify_classical f shape = + let (input,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in + let list_output = getListWire output in + let (bc',list_output') = quipperBCircuitSimpl bc list_output in + Q.unencapsulate_generic (input,bc', Q.qdata_of_qubits output $ map Q.qubit_of_wire list_output') shape + +-- | Like 'Q.classical_to_reversible', but also apply circuit optimization. +classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb)) +classical_to_reversible_optim f = Q.classical_to_reversible (simplify_classical f) + +-- | Like 'classical_to_reversible_optim', but insert the optimized +-- circuit as a boxed subroutine. +box_classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => String -> (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb)) +box_classical_to_reversible_optim s f = Q.classical_to_reversible (Q.box s $ simplify_classical f) + diff --git a/Quipper/Libraries/ClassicalOptim/Simplification.hs b/Quipper/Libraries/ClassicalOptim/Simplification.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/ClassicalOptim/Simplification.hs @@ -0,0 +1,1003 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | This module contains the core of the classical circuit +-- optimization algorithm. +module Quipper.Libraries.ClassicalOptim.Simplification where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import qualified Control.DeepSeq as Seq + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +import qualified Quipper.Utils.Auxiliary as Q + +import Quipper.Libraries.ClassicalOptim.Circuit +import Quipper.Libraries.ClassicalOptim.AlgExp + +-- ---------------------------------------------------------------------- +-- * Auxiliary definitions + +-- | Internal definition of a trace, for debugging purposes. This is a +-- no-op, but can be replaced to turn on debugging. +trace :: String -> b -> b +trace a b = b + +-- | Change a wire ID in a gate. The first two arguments are the old +-- and the new wire ID. +moveWire :: Wire -> Wire -> Gate -> Gate +moveWire from to NoOp = NoOp +moveWire from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) +moveWire from to (Cnot w ctls) = Cnot w' ctls' + where + w' = if (from == w) then to else w + ctls' = map moveCtls ctls + moveCtls (w,b) = if (from == w) then (to,b) else (w,b) + +-- | Flip the control on the given wire (from positive to negative or +-- vice versa). +flipCtl :: Wire -> Gate -> Gate +flipCtl _ NoOp = NoOp +flipCtl _ (Init b w) = Init b w +flipCtl w (Cnot w' ctls) = Cnot w' $ map (\(x,b) -> if (x == w) then (x,not b) else (x,b)) ctls + +-- | Change a wire ID in a gate and flip the potential control. +moveWireFlip :: Wire -> Wire -> Gate -> Gate +moveWireFlip from to NoOp = NoOp +moveWireFlip from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) +moveWireFlip from to (Cnot w ctls) = Cnot w' ctls' + where + w' = if (from == w) then to else w + ctls' = map moveCtls ctls + moveCtls (w,b) = if (from == w) then (to,b) else if (to == w) then (w,not b) else (w,b) + +-- ---------------------------------------------------------------------- +-- * Small, simple optimizations + +-- | Suppress gates acting on garbage wires, i.e., wires that are not in the input set. +suppress_garbage :: [Gate] -> IS.IntSet -> [Gate] + +suppress_garbage ((Cnot w ctls):gs) used = + if (IS.member w used) then g:gs1 else gs2 + where + g = Cnot w ctls + gs1 = suppress_garbage gs $ IS.union (IS.insert w used) $ IS.fromList $ L.map fst ctls + gs2 = suppress_garbage gs used + +suppress_garbage (g:gs) used = g:(suppress_garbage gs used) + +suppress_garbage [] _ = [] + + +-- | Like 'suppress_garbage', but packaged in a manner that is friendly for composition. +suppressGarbageGates :: ([Gate],[Wire]) -> ([Gate],[Wire]) + +suppressGarbageGates (gs,out) = (reverse $ suppress_garbage (reverse gs) $ IS.fromList out, out) + + +-- ---------------------------------------------------------------------- +-- * Compression of wire numbering + +-- $ As the optimization process goes on, many /init/ gates will end +-- up being discarded. The function 'compressWires' compacts the wire +-- numbering scheme to make a smaller circuit. + +-- | Get the set of all wires used by the circuit. +getAllWires :: [Gate] -> IS.IntSet +getAllWires gs = L.foldl' IS.union IS.empty $ L.map aux gs + where + aux (Cnot w ctls) = IS.insert w $ L.foldl' (flip IS.insert) IS.empty $ L.map fst ctls + aux (Init _ w) = IS.singleton w + aux NoOp = IS.empty + +-- | Get the set of wires initialized by the circuit. +getInitWires :: [Gate] -> IS.IntSet +getInitWires gs = L.foldl' IS.union IS.empty $ map aux gs + where + aux (Cnot _ _) = IS.empty + aux (Init _ w) = IS.singleton w + aux NoOp = IS.empty + +-- | Get the set of input wires, i.e., the ones that are used but not initialized. +getInputWires :: [Gate] -> IS.IntSet +getInputWires gs = IS.difference (getAllWires gs) (getInitWires gs) + +-- | Compress the wire numbering. +compressWires :: [Wire] -> ([Gate],[Wire]) -> ([Gate],[Wire]) +compressWires inputwires (gs,output) = (gs',out') + where + iws = getInitWires gs + begin = if inputwires == [] + then 0 + else 1 + (head $ reverse $ L.sort inputwires) + end = begin + (IS.size iws) + listmap = zip ([0..begin-1] ++ (IS.toAscList iws)) [0 .. end] + remap = M.fromList $ trace (show listmap) listmap + out' = map (remap M.!) output + gs' = map (rewire remap) gs + + rewire m (Cnot w ctls) = Cnot (m M.! w) $ map (\(x,b) -> (m M.! x, b)) ctls + rewire m (Init b w) = Init b (m M.! w) + rewire m NoOp = NoOp + + +-- ---------------------------------------------------------------------- +-- * A useful data structure + +-- $ When considering a particular point in a circuit (i.e., in a list +-- of gates), to decide whether a given wire is used or controlled +-- before or after, we keep a data-structure 'UsedWire'. + +-- | The type of gate IDs. +type GateId = Int + +-- | A set of gate IDs. +type GateIdSet = IS.IntSet + +-- | A map from wires to pairs of 'GateId's. The left member gives the +-- ID of the first gate using the wire, and the right member gives the +-- ID of the last gate using the wire. +type UsedWire = IM.IntMap GateIdSet + +-- | Get the minimum of a set of gate IDs. +gateIdFindMin :: GateIdSet -> Maybe GateId +gateIdFindMin g = if (IS.null g) then Nothing else Just (IS.findMin g) + +-- | Get the maximum of a set of gate IDs. +gateIdFindMax :: GateIdSet -> Maybe GateId +gateIdFindMax g = if (IS.null g) then Nothing else Just (IS.findMax g) + +-- | Get the pair corresponding to the given wire. +pairUsedWire :: UsedWire -> Wire -> GateIdSet +pairUsedWire m w = IM.findWithDefault IS.empty w m + +-- | Get the first gate using the wire in the future. +firstUsedWire :: UsedWire -> Wire -> Maybe GateId +firstUsedWire = curry $ gateIdFindMin . (uncurry pairUsedWire) + +-- | Get the last gate using the wire in the past. Return 0 if none. +lastUsedWire :: UsedWire -> Wire -> GateId +lastUsedWire w w'= + case (curry $ gateIdFindMax . (uncurry pairUsedWire)) w w' of + Just w -> w + Nothing -> 0 + +-- | 'nextUsedGate' /ws/ /g/ /g/' /w/: Look for the next gate in /ws/ +-- corresponding to wire /w/, starting from /g/. Return /g/' if none. +nextUsedGate :: UsedWire -> GateId -> GateId -> Wire -> GateId +nextUsedGate ws g g' w = + case (do gs <- IM.lookup w ws; IS.lookupGT g gs) of + Just g -> g + Nothing -> g' + +-- | For each wire, find the set of gates placing a control on it. +circuitControlWires :: GateId -> [Gate] -> UsedWire +circuitControlWires id gs = aux id IM.empty gs + where + aux _ m [] = m + aux g m (Init _ _:gs) = aux (g+1) m gs + aux g m ((Cnot _ ctls):gs) = aux (g+1) m' gs + where + wires = map fst ctls + m' = L.foldl (\m'' w -> IM.alter (f g) w m'') m wires + f g Nothing = Just $ IS.singleton g + f g (Just s) = Just $ IS.insert g s + aux g m (NoOp:_) = error "circuitControlWires cannot deal with NoOp" + +-- | For each wire, find the set of gates acting on it with NOT. +circuitNotWires :: GateId -> [Gate] -> UsedWire +circuitNotWires id gs = aux id IM.empty gs + where + aux _ m [] = m + aux g m (Init _ _:gs) = aux (g+1) m gs + aux g m ((Cnot w _):gs) = aux (g+1) m' gs + where + m' = IM.alter (f g) w m + f g Nothing = Just $ IS.singleton g + f g (Just s) = Just $ IS.insert g s + aux g m (_:gs) = aux (g+1) m gs + +-- ---------------------------------------------------------------------- +-- * Algebraic optimization method + +-- $ To each wire in a circuit, we attach a set of formulas. At each +-- iteration, the wire that gets modified is updated with its new +-- value, using all the possible values, possibly together with a +-- fresh variable. At each iteration, we also strip away the +-- expressions that get too large. Here, the size of an algebraic +-- expression is measured by the 'exp_length' function. + +-- | Calculate the size of an algebraic expression. +exp_length :: Exp -> Int +exp_length e = L.foldl' (+) 0 $ L.map (\x -> let y = IS.size x in seq y y) $ S.toList e + +-- | Given a list of sets of expressions, form the conjunction of +-- every possible choice of one expression from each set. For example. +-- +-- > exp_list_and [{a,b}, {c,d}, {e,f}] = +-- > [a∧c∧e, a∧c∧f, a∧d∧e, a∧d∧f, b∧c∧e, b∧c∧f, b∧d∧e, b∧d∧f]. +exp_list_and :: [S.Set Exp] -> S.Set Exp +exp_list_and [] = S.singleton exp_true +exp_list_and [l] = l +exp_list_and (h:k:t) = exp_list_and (S.fromList [exp_and x y | x <- S.toList h, y <- S.toList k]:t) + +-- | Evaluate a control with respect to a state. +expEvalCtl :: (IM.IntMap (S.Set (Exp,Int))) -> (Wire,Bool) -> S.Set Exp +expEvalCtl m (w,True) = S.map fst (m IM.! w) +expEvalCtl m (w,False) = S.map exp_not $ S.map fst $ (IM.!) m w + +-- | Evaluate a gate with respect to a state. +expEvalGate :: (IM.IntMap (S.Set (Exp,Int))) -> Gate -> IM.IntMap (S.Set (Exp,Int)) + +expEvalGate m (Init False w) = IM.insert w (S.singleton (exp_false,0)) m +expEvalGate m (Init True w) = IM.insert w (S.singleton (exp_true,1)) m +expEvalGate m NoOp = m + +expEvalGate m (Cnot w ctls) = IM.insert w cnot m + where + ands = exp_list_and $ L.map (expEvalCtl m) ctls + cnot = S.map (\x -> (x,exp_length x)) (S.fromList [exp_xor x y | + x <- S.toList $ S.map fst $ (IM.!) m w, + y <- S.toList ands ]) + +-- ---------------------------------------------------------------------- +-- ** State of the optimization automaton + +-- | The state of the automaton. This contains in particular the +-- current state, the past and future gates, and a fresh variable. +data ExpState = ExpState { + gates_to_skip :: IM.IntMap Gate, -- ^ For use with 'stepSwapCirc'. + allWiresInCirc :: IS.IntSet, -- ^ All the wires in the circuit. + gateId :: GateId, -- ^ ID of the first gate in the future (starts at 1). + usedControlWires :: UsedWire, -- ^ Location of the controls. + usedNotWires :: UsedWire, -- ^ Location of the NOT gates. + future :: [Gate], -- ^ Gates left to explore. + past :: [Gate], -- ^ Gates already explored. + expMap :: IM.IntMap (S.Set (Exp,Int)), -- ^ Algebraic state of the wires. Also contains the size of the expression, so we don't have to recompute it each time. + freshVar :: Integer, -- ^ The next fresh wire. + outWires :: [Wire], -- ^ The output wires. + sizeCirc :: Int -- ^ Size of the circuit. + } + + +instance Seq.NFData Gate where + rnf (Init a b) = a `seq` b `seq` () + rnf (Cnot w ctls) = ctls `Seq.deepseq` w `Seq.deepseq` () + rnf NoOp = () + +{- +instance Seq.NFData ExpState where + rnf e = {-allWiresInCirc e `Seq.deepseq` gateId e `Seq.deepseq` usedControlWires e `Seq.deepseq` usedNotWires e `Seq.deepseq` future e `Seq.deepseq` past e `Seq.deepseq` expMap e `Seq.deepseq` freshVar e `Seq.deepseq` outWires e-} () `Seq.deepseq` () +-} + +-- | The initial state for a given set of parameters. +initExpState :: IS.IntSet -> [Wire] -> [Gate] -> ExpState +initExpState ws_in ws_out gs = ExpState { + gates_to_skip = IM.empty, + allWiresInCirc = getAllWires gs, + gateId = 1, + usedControlWires = circuitControlWires 1 gs, + usedNotWires = circuitNotWires 1 gs, + future = gs, + past = [], + expMap = IM.fromList $ L.map (\x -> (x, S.singleton (exp_var x, 1))) $ IS.toAscList ws_in, + freshVar = fromIntegral $ (+) 1 $ IS.findMax ws_in, + outWires = ws_out, + sizeCirc = length gs + } + +-- ---------------------------------------------------------------------- +-- ** The state monad + +-- | The state monad corresponding to 'ExpState'. +data EvalCirc a = EvalCirc (ExpState -> (ExpState, a)) + +instance Monad EvalCirc where + return x = EvalCirc (\y -> (y,x)) + (>>=) (EvalCirc c) f = EvalCirc (\s -> let (s',x) = c s in + let (EvalCirc c') = f x in + c' s') + +instance Applicative EvalCirc where + pure = return + (<*>) = ap + +instance Functor EvalCirc where + fmap = liftM + +-- ---------------------------------------------------------------------- +-- ** Low-level access functions + +-- | Construct an @'ExpState'@ out of an @'EvalCirc'@. +runEvalCirc :: IS.IntSet -> [Wire] -> [Gate] -> EvalCirc a -> ExpState +runEvalCirc ws_in ws_out gs (EvalCirc e) = fst $ e $ initExpState ws_in ws_out gs + +-- | Retrieve the state. +getExpState :: EvalCirc ExpState +getExpState = EvalCirc (\s -> (s,s)) + +-- | Set the state. +setExpState :: ExpState -> EvalCirc () +setExpState s = EvalCirc (\_ -> (s,())) + +-- ---------------------------------------------------------------------- +-- ** Higher-level access functions + +-- | Create a fresh variable +newFreshVar :: EvalCirc Integer +newFreshVar = do + s <- getExpState + let v = freshVar s + setExpState (s { freshVar = v + 1 }) + return v + +-- | Pull a new gate to be analyzed out of the future. +pullNewGate :: EvalCirc (Maybe Gate) +pullNewGate = do + s <- getExpState + case (future s) of + (h:t) -> do setExpState (s { future = t } ) + return (Just h) + [] -> return Nothing + +-- | Modify the future gates. +changeFuture :: [Gate] -> EvalCirc () +changeFuture gs = do + s <- getExpState + setExpState (s { future = gs } ) + return () + +-- | Update the future using the given parameter function. Return two sets +-- of 'gateId's that got modified: the first set concerns the controls, +-- the second set the NOT gates. +updateFuture :: (Gate -> Gate) -> EvalCirc (IS.IntSet,IS.IntSet) +updateFuture f = do + s <- getExpState + let ((_,!gsModifCtls,!gsModifNots),new_future) = + L.mapAccumL (\(gid,gs,gs') g -> let g' = f g in + (( + gid+1 + , + if (ctlsOfGate g == ctlsOfGate g') + then gs + else IS.insert gid gs + , + if (wireOfGate g == wireOfGate g') + then gs' + else IS.insert gid gs' + ), + g')) + (1 + (gateId s), IS.empty,IS.empty) (future s) + changeFuture new_future + + return (gsModifCtls,gsModifNots) + +-- | Store a gate in the past. +storeOldGate :: Gate -> EvalCirc () +storeOldGate g = do + s <- getExpState + let p = past s + seq g $ seq p $ setExpState (s { past = g:p } ) + return () + +-- | Increase the '@gateId@' (i.e., go forward). +incrGateId :: EvalCirc () +incrGateId = do + s <- getExpState + setExpState (s { gateId = 1 + (gateId s) } ) + return () + +-- | Get the set of all wires. +getAllWiresInCirc :: EvalCirc IS.IntSet +getAllWiresInCirc = do + s <- getExpState + return (allWiresInCirc s) + +-- | Set the set of all wires. +setAllWiresInCirc :: IS.IntSet -> EvalCirc () +setAllWiresInCirc ws = do + s <- getExpState + ws `seq` setExpState (s {allWiresInCirc = ws}) + return () + +-- | Remove a gate from the set of all wires. +removeFromAllWiresInCirc :: Int -> EvalCirc () +removeFromAllWiresInCirc w = do + ws <- getAllWiresInCirc + setAllWiresInCirc $ IS.delete w ws + return () + +-- | Get the algebraic representation of the set of wires. +getExpMap :: EvalCirc (IM.IntMap (S.Set (Exp,Int))) +getExpMap = do + s <- getExpState + s `seq` return (expMap s) + +-- | Set the algebraic representation of the state of wires. +setExpMap :: (IM.IntMap (S.Set (Exp,Int))) -> EvalCirc () +setExpMap m = do + s <- getExpState + m `seq` setExpState (s { expMap = m } ) + return () + +-- | Update the database recording the controlled wires. +updateUsedControlWires :: (UsedWire -> UsedWire) -> EvalCirc () +updateUsedControlWires f = do + s <- getExpState + let c = f $ usedControlWires s + c `seq` setExpState (s { usedControlWires = c } ) + return () + +-- | Update the database recording the NOT gates. +updateUsedNotWires :: (UsedWire -> UsedWire) -> EvalCirc () +updateUsedNotWires f = do + s <- getExpState + let c = f $ usedNotWires s + c `seq` setExpState (s { usedNotWires = c } ) + return () + +-- | Update the list of output wires. +updateOutWires :: ([Wire] -> [Wire]) -> EvalCirc () +updateOutWires f = do + s <- getExpState + let c = f $ outWires s + c `seq` setExpState (s { outWires = c } ) + return () + +-- | Add a gate ID to the list of gates to skip. +addToSkipGates :: GateId -> Gate -> EvalCirc () +addToSkipGates id g = do + s <- getExpState + let c = IM.insert id g (gates_to_skip s) + c `seq` setExpState (s {gates_to_skip = c} ) + return () + +-- | Send a gate to the end of the future. +sendEndOfTime :: Gate -> EvalCirc () +sendEndOfTime g = do + s <- getExpState + changeFuture ((future s) ++ [g]) + return () + +-- | Place a gate at the given gate ID in the future. +shiftGate :: Gate -> GateId -> EvalCirc () +shiftGate g x = do + s <- getExpState + let (!head, !tail) = splitAt x (future s) + let z = head ++ [g] ++ tail + z `Seq.deepseq` changeFuture z + return () + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | @pairEqualExp m1 m2 ws@: returns a list of pairs of wires @(x,y)@ +-- such that @m2 x = m1 x = m1 y@. +pairEqualExp :: (IM.IntMap [Exp]) -> (IM.IntMap [Exp]) -> [Wire] -> [(Wire,Wire)] +pairEqualExp m1 m2 ws = + L.map fst $ L.filter aux $ L.zip pair_ws (L.map value pair_ws) + where + all_pairs l = [(x,y) | x <- l, y <- l] + pair_ws = all_pairs ws + value (x,y) = (m2 IM.! x, m1 IM.! x, m1 IM.! y) + aux ((_,_),(a,b,c)) = a == b && b == c + +-- | From a set of expressions (annotated with sizes), prune the ones +-- whose size is larger than /n/. +pruneListExp :: Int -> S.Set (Exp,Int) -> S.Set (Exp,Int) +pruneListExp n l = S.filter (\x -> snd x <= n) l + + +-- ---------------------------------------------------------------------- +-- ** The algebraic optimization automaton + +-- | Perform a set of filters acting on one gate at a time, looking +-- for: +-- +-- * gates having no effect; +-- +-- * orphan NOT-gates (i.e. NOT gates negating an out-wire) ; +-- +-- * simple copy-cats (both positive and negative) ; +-- +-- * hidden copy-cats. +-- +-- Return 'False' when the end of the circuit is reached, 'True' otherwise. +stepEvalCirc :: EvalCirc Bool +stepEvalCirc = do + m_before <- getExpMap + trace ("the state of the system is " ++ (show $ m_before)) $ return () + s <- getExpState + if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp... " ++ (show (gateId s))) (return ()) else return () + s <- getExpState + trace ("outside wires " ++ (show $ outWires s)) $ return () + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + case maybe_g of + + Nothing -> return False + + Just g -> do -- analyze the gate + m_before <- getExpMap + let m_after = expEvalGate m_before g + + case g of + + NoOp -> error "stepEvalCirc cannot deal with NoOp" + + Init b w | not ((IM.member w $ usedNotWires s) || (IM.member w $ usedControlWires s) || L.elem w (outWires s))-> do + trace "got an orphan init, removing it" $ return () + storeOldGate NoOp -- store a placeholder for the gate + incrGateId + removeFromAllWiresInCirc w + -- we could also clean expMap from the reference to w but I think it makes no gain + return True + + Init _ _ -> do + trace "got a regular init" $ return () + storeOldGate g + setExpMap m_after + incrGateId + return True + + Cnot w _ | not $ S.null $ S.intersection (m_before IM.! w) (m_after IM.! w) -> do + trace "got a cnot where no change happened..." $ return () + trace (show m_before) $ return () + trace (show m_after) $ return () + storeOldGate NoOp + incrGateId + return True + + Cnot w [] | not (L.elem w $ outWires s) -> do + trace "got a not-gate that can be removed..." $ return () + s <- getExpState + -- update future + changeFuture $ L.map (flipCtl w) $ future s + s <- getExpState + trace (show $ future s) $ return () + storeOldGate NoOp + incrGateId + return True + + + Cnot w ctls | otherwise -> do + trace "got a general cnot" $ return () + trace ("state after the gate is " ++ (show m_after)) $ return () + + allWs <- getAllWiresInCirc + s <- getExpState + let my_elem x = not (L.elem x $ outWires s) + let all_ws = IS.toAscList $ IS.filter future_ctl $ + IS.filter (\x -> my_elem x) $ -- not (L.elem x $ outWires s)) $ + IS.filter (\x -> not $ S.null $ + S.intersection (m_after IM.! x) + (m_after IM.! w)) $ + IS.filter (w /=) allWs -- IS.fromList $ L.map fst ctls + where + future_ctl x = + (lastUsedWire (usedNotWires s) x) <= gateId s + && + (lastUsedWire (usedNotWires s) w) <= gateId s + + let all_ws_neg = IS.toAscList $ IS.filter future_ctl $ + IS.filter (\x -> not (L.elem x $ outWires s)) $ + IS.filter (\x -> not $ S.null $ + S.intersection (m_after IM.! x) + (S.map (\(e,i) -> (exp_not e, i)) (m_after IM.! w))) $ + IS.filter (w /=) $ IS.fromList $ L.map fst ctls + where + future_ctl x = + (lastUsedWire (usedNotWires s) x) <= gateId s + && + (lastUsedWire (usedNotWires s) w) <= gateId s + + trace ("List of outside wires: " ++ (show $ outWires s)) (return ()) + trace ("List of available wires: " ++ (show all_ws)) (return ()) + trace ("List of available wires with neg: " ++ (show all_ws_neg)) (return ()) + + + case all_ws of + + [] -> do + + case all_ws_neg of + [] -> do + + -- There is no "simple" copy-cat... + -- Let's try to find a hidden one. + + s <- getExpState + + -- This helper function take a wire and look in + -- the past for the closest cnot acting on it + let getOlderCnot w = case (do set <- IM.lookup w (usedNotWires s); IS.lookupLT (gateId s) set) of + Nothing -> Nothing -- there is no previous not + Just g' -> -- there is one not... let's check that it is a cnot + case ((past s) !! ((gateId s) - g' - 1)) of + Cnot _ [ctl] -> Just (g',ctl) + _ -> Nothing + + -- Helper acting on controls: only return + -- something if it is a single control. + let getOlderCnot_actOnCtls w1 [(w,b)] = do -- monad Maybe + other_ctl <- getOlderCnot w1 + other_ctl `seq` return ((w,b),other_ctl) + getOlderCnot_actOnCtls _ _ = Nothing + + let retrieveHiddenCnot w1 ctls = do -- monad Maybe + -- if (L.elem w $ outWires s) then Nothing + -- else return () + ((w2,b2),(g',(w3,b3))) <- getOlderCnot_actOnCtls w1 ctls + -- make sure w2 and w3 are distinct + if (w2 == w3) then Nothing else return () + let m = m_after + -- check for the property w1 == w2 oplus w3 + if (S.null $ S.intersection + (S.fromList [exp_xor x y | (x,_) <- S.toList (m IM.! w2), (y,_) <- S.toList (m IM.! w3)]) + (S.fromList [x | (x,_) <- S.toList (m IM.! w1)])) + then Nothing + -- We have two CNOT candidates for hidden copy-cat. + else if ((not (L.elem w2 $ outWires s)) + && + (lastUsedWire (usedNotWires s) w2) <= gateId s + && + (lastUsedWire (usedControlWires s) w2) <= gateId s) + then Just ((w2,b2),(w3,b3)) + else if ((not (L.elem w3 $ outWires s)) + && + (lastUsedWire (usedNotWires s) w3) <= g' + && + (lastUsedWire (usedControlWires s) w3) <= g') + then Just ((w3,b3),(w2,b2)) + else Nothing + + case retrieveHiddenCnot w ctls of + Just ((w2,b2),(w3,b3)) -> -- we have a hidden cnot candidate. Great. + -- w2 is the wire that is not used with NOT in future + do + + trace "found one hidden copy-cat" $ return () + updateOutWires $ map (\x -> if x == w then w2 else x) + + (gsModifCtls,gsModifNots) <- updateFuture $ moveWire w w2 + + trace ("moving " ++ (show w) ++ " to " ++ (show w2)) $ return () + trace (show gsModifCtls) $ return () + trace (show gsModifNots) $ return () + + + s <- getExpState + trace ("before: usedNotWire = " ++ (show $ usedNotWires s)) $ return () + + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls) w2 $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + + updateUsedControlWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (gateId s) gs + Nothing -> Just $ IS.singleton (gateId s)) w3 c + + updateUsedNotWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifNots + Nothing -> Just gsModifNots) w2 $ + IM.update (\gs -> Just $ IS.difference gs gsModifNots) w c + + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w $ + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (gateId s) gs + Nothing -> Just $ IS.singleton (gateId s)) w2 c + + s <- getExpState + trace ("after: usedNotWire = " ++ (show $ usedNotWires s)) $ return () + + -- Update ExpMap + setExpMap $ IM.insert w (m_before IM.! w) $ + IM.insert w2 (m_after IM.! w) m_after + + storeOldGate $ Cnot w2 [(w3,True)] + incrGateId + return True + + _ -> -- No hidden Cnot, let's proceed... + do + let mw = m_after IM.! w + f <- if ((S.foldl' (\a (_,i) -> min a i) 3 mw) <= 1) + then return id + else do + v <- newFreshVar + return (S.insert (exp_var $ fromIntegral v, 1)) + setExpMap $ IM.adjust (\a -> pruneListExp 3 a) w $ + IM.adjust f w m_after + + storeOldGate g + incrGateId + return True + + ----------------- + -- Case of simple copy-cats + (w':_) -> do + s <- getExpState + updateOutWires $ map (\x -> if x == w then w' else x) + + s <- getExpState + trace (show $ future s) $ return () + (gsModifCtls,_) <- updateFuture $ moveWireFlip w w' + + -- update expMap: now, w is null and w' is not(old w) + expMap <- getExpMap + + setExpMap $ IM.insert w (m_before IM.! w) $ + IM.insert w' (S.map (\(e,i) -> (exp_not e,i)) (expMap IM.! w')) expMap + + + + trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () + trace (show gsModifCtls) $ return () + s <- getExpState + trace (show $ future s) $ return () + + s <- getExpState + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls) w' $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c + + storeOldGate (Cnot w' []) -- Set a flip on the w' wire + + incrGateId + + return True + + + + (w':_) -> do + + s <- getExpState + updateOutWires $ map (\x -> if x == w then w' else x) + + s <- getExpState + trace (show $ future s) $ return () + trace ("usedNotWire = " ++ (show $ usedNotWires s)) $ return () + (gsModifCtls,_) <- updateFuture $ moveWire w w' + + trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () + trace (show gsModifCtls) $ return () + s <- getExpState + trace (show $ future s) $ return () + + s <- getExpState + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls + ) w' $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c + + storeOldGate NoOp -- replace g with NoOp so that gateId stays accurate + incrGateId + + return True + + +-- | Shuffle the circuit by sending the CNOT gates as far as +-- possible (i.e., until they hit a control, or to the end). +-- Return 'False' when the end of the circuit is reached, 'True' otherwise. +stepSwapCirc :: EvalCirc Bool +stepSwapCirc = do + s <- getExpState + + case (IM.lookup (gateId s) (gates_to_skip s)) of + + Just g -> do + + storeOldGate g + incrGateId + return True + + Nothing -> do + + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp (swap)... " ++ (show (gateId s))) {-(s `Seq.deepseq` (setExpState s))-} (return ()) else return () + case maybe_g of + + Nothing -> return False + + Just g@(Cnot w1 [(w2,b2)]) | IM.notMember (gateId s) (gates_to_skip s) -> do -- got a CNOT + + trace ("got a cnot to analyze " ++ (show $ gateId s) ++ " " ++ (show $ gates_to_skip s)) $ return () + + let id = min (nextUsedGate (usedNotWires s) (gateId s) (1 + sizeCirc s) w2) $ + (nextUsedGate (usedControlWires s) (gateId s) (1 + sizeCirc s) w1) + + trace ("found id = " ++ (show id)) $ return () + + if ( id > 1 + gateId s ) -- && (id <= (sizeCirc s) ) + then do ------------- there is something to move! + trace ("can be shifted to " ++ (show (id - 1))) $ return () + + addToSkipGates (id - 1) g + -- shiftGate g (id - 1 - (gateId s)) + + s <- getExpState + trace (show $ future s) $ return () + + -- Remove references to (gateId s) + + updateUsedControlWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w1 c + + -- Shift the ones between (gateId s) and id + + updateUsedNotWires $ + IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x + else x - 1 + updateUsedControlWires $ + IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x + else x - 1 + + s <- getExpState + let z = IM.mapKeys (\x -> if (x <= gateId s) || (x >= id) then x + else x - 1) (gates_to_skip s) in + z `seq` setExpState (s { gates_to_skip = z} ) + + -- Set g in position (id - 1) + + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (id - 1) gs + Nothing -> Just $ IS.singleton (id - 1)) w2 c + updateUsedNotWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (id - 1) gs + Nothing -> Just $ IS.singleton (id - 1)) w1 c + + -- Make sure we skip (id - 1) later on. + + + else do ------------- nothing to move... + trace "cannot be shifted" $ return () + storeOldGate g + incrGateId + + return True + + Just g -> do + trace ("got a random " ++ (show g)) $ return () + storeOldGate g + incrGateId + return True + + + +-- | A more elementary version of @'stepSwapCirc'@: shuffle the +-- circuit by sending to the end all the NOT gates that can be sent +-- there. Return 'False' when the end of the circuit is reached, +-- 'True' otherwise. +stepSwapCirc_simple :: EvalCirc Bool +stepSwapCirc_simple = do + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + case maybe_g of + + Nothing -> return False + + Just g | (gateId s) == (length $ past s) + (length $ future s) -> do + storeOldGate g + return False + + Just g@(Cnot w1 [(w2,b2)]) | + (lastUsedWire (usedNotWires s) w2) <= gateId s && + (lastUsedWire (usedNotWires s) w1) <= gateId s && + (lastUsedWire (usedControlWires s) w1) <= gateId s -> do -- got a CNOT + + trace "got a cnot that can be sent to the end" $ return () + + sendEndOfTime g + -- do not store gate, but increase gateId + incrGateId + return True + + Just g -> do + storeOldGate g + incrGateId + return True + +-- ---------------------------------------------------------------------- +-- ** Some wrappers + +-- | Run the monad until 'False' occurs. +runWhile :: Monad m => (a -> Bool) -> m a -> m () +runWhile f c = do + r <- c + if f r then runWhile f c else return () + +-- | Strip the 'NoOp' gates from a list of gates. +stripNoOp :: [Gate] -> [Gate] +stripNoOp = L.filter (/= NoOp) + +-- | Wrapper around 'stepEvalCirc'. +alg_simplify :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_simplify (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepEvalCirc) + +-- | Wrapper around 'stepSwapCirc'. +alg_swap :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_swap (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc) + + +-- | Wrapper around 'stepSwapCirc_simple'. +alg_swap_simple :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_swap_simple (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc_simple) + +-- ---------------------------------------------------------------------- +-- * Multi-pass optimization + +-- | Auxiliary function. Simultaneously compute the maximum of the +-- lengths of two lists, and their point-wise equality. +is_equal_list :: Eq a => [a] -> [a] -> Int -> (Int,Bool) + +is_equal_list [] [] n = (n,True) +is_equal_list (h1:t1) (h2:t2) n | h1 == h2 = is_equal_list t1 t2 (n+1) +is_equal_list t1 t2 n = (n + max (length t1) (length t2),False) + +-- | Get the list of initialized wires from a circuit. +get_list_init :: [Gate] -> [Wire] +get_list_init ((Init _ w):gs) = w:(get_list_init gs) +get_list_init (g:gs) = get_list_init gs +get_list_init [] = [] + +-- | Do several passes of @'alg_simplify'@ until it reaches a fixed point. +simplRec' :: ([Gate],[Wire]) -> ([Gate],[Wire]) +simplRec' (l,output) = trace (show (l,output)) $ + let (l',output') = alg_simplify (l, output) in + let (n,b) = is_equal_list l l' 0 in + if b then (l,output) + else trace (show n) simplRec' $ suppressGarbageGates (l',output') + +-- | Do several passed of @'alg_swap'@ followed with @'simplRec'@ +-- until it reaches a fixed point. +simplRec :: ([Gate],[Wire]) -> ([Gate],[Wire]) +simplRec (l1,o1) = + let (l3,o3) = simplRec' $ alg_swap (l1,o1) in + let (n,b) = is_equal_list l1 l3 0 in + if b then (l3,o3) + else trace "Swapping!" $ simplRec $ (l3,o3) diff --git a/Quipper/Libraries/Decompose.hs b/Quipper/Libraries/Decompose.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Decompose.hs @@ -0,0 +1,20 @@ +-- | Functions to decompose circuits into various gate bases. + +module Quipper.Libraries.Decompose ( + -- * Precision + Precision, + bits, + digits, + -- * Phase + KeepPhase, + -- * Gate bases + GateBase (..), + gatebase_enum, + -- * Generic decomposition + decompose_generic, +) where + +import Quipper.Libraries.Decompose.CliffordT +import Quipper.Libraries.Decompose.GateBase +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.Synthesis diff --git a/Quipper/Libraries/Decompose/CliffordT.hs b/Quipper/Libraries/Decompose/CliffordT.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Decompose/CliffordT.hs @@ -0,0 +1,1067 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +-- | This module provides transformers for decomposing circuits into +-- the Clifford+/T/ gate base. +-- +-- * [bold Control trimming.] This transformer uses doubly-controlled +-- /iX/-gates to reduce the number of controls on gates. Specifically, +-- it ensures that not-gates, Pauli /X/-, /Y/-, and /Z/-gates, and +-- /iX/-gates have at most two controls; that phase gates of the form +-- Diag(1, φ) have no controls; and that all other gates have at most +-- one control. +-- +-- * [bold Approximate Clifford+/T/ decomposition.] This decomposes +-- all rotation and phase gates into Clifford+/T/ up to a given +-- precision ε, using an approximate synthesis algorithm. Other gates +-- are unchanged. +-- +-- * [bold Exact Clifford+/T/ decomposition.] This decomposes all +-- gates that are exactly representable in the Clifford+/T/ base into +-- single-qubit Clifford gates, /T/, /T/[sup †], and singly-controlled +-- not-gates (with positive or negative control). Rotation and phase +-- gates are left unchanged. +-- +-- * [bold Standard gate set.] We define the standard gate set to +-- consist of the gates /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, +-- /T/[sup †], and /CNOT/. This transformer decomposes all gates that +-- remain after applying both approximate and exact Clifford+/T/ +-- decomposition into the standard gate set. If the transformer +-- encounters gates that are not single-qubit Clifford gates, /T/, +-- /T/[sup †], or singly-controlled not-gates (with positive or +-- negative control), then the output is still semantically correct, +-- but may not be in the standard gate set. This transformer +-- suppresses global phases. +-- +-- * [bold Strict gate set.] We define the strict gate set to consist +-- of the gates /H/, /S/, /T/, and /CNOT/. This transformer decomposes +-- all gates that remain after applying both approximate and exact +-- Clifford+/T/ decomposition into the strict gate set. If the +-- transformer encounters gates that are not single-qubit Clifford +-- gates, /T/, /T/[sup †], or singly-controlled not-gates (with +-- positive or negative control), then the output is still +-- semantically correct, but may not be in the strict gate set. This +-- transformer suppresses global phases. +-- +-- These above transformers may be applied in any order. Control +-- trimming is primarily for demonstration purposes; it does not need +-- to be combined with the other transformers as they do their own +-- trimming. The exact and approximate Clifford+/T/ decompositions can +-- be applied in either order; since they each target a different set +-- of gates, they must both be performed to obtain a complete +-- decomposition into the Clifford+/T/ gate set. The standard and +-- strict transformers assume that their input has already been +-- pre-processed by the exact and approximate transformers. + +module Quipper.Libraries.Decompose.CliffordT where + +import Quipper +import Quipper.Internal + +-- Stuff we need to import because the Dynamic Transformer interface +-- is not yet stable. +import Quipper.Internal.Circuit (BoxId, TypedSubroutine(..), OCircuit(..)) +import Quipper.Internal.Transformer +import Quipper.Internal.Generic (provide_subroutine_generic, transform_unary_dynamic) +import Quipper.Internal.Monad (endpoints_of_wires_in_arity, identity_dynamic_transformer, provide_subroutines, named_rotation_qulist_at, named_gate_qulist_at, subroutine) + +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.GateDecompositions +import Quipper.Libraries.Synthesis + +import Quipper.Utils.Auxiliary (optional) +import Quantum.Synthesis.SymReal + +import Control.Monad (when) +import System.Random +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | A version of 'with_combined_controls' that uses doubly-controlled +-- /iX/-gates to do the decomposition. For example, when /n/=2, this +-- yields circuits such as the following: +-- +-- \[image with_combined_controls2.png] +-- +-- And for /n/=1: +-- +-- \[image with_combined_controls1.png] +with_combined_controls_iX :: Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_iX = with_combined_controls cc_iX_plain_at + +-- | A version of 'with_combined_controls_iX' that further decomposes +-- the doubly-controlled /iX/-gates into the Clifford+/T/ gate base. +with_combined_controls_CT :: Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_CT = with_combined_controls cc_iX_at + +-- | Turn a list of signed controls into a list of positive quantum +-- controls, by applying all classical controls directly, and +-- conjugating any negative quantum controls by /X/. Call the +-- inner block with those quantum controls. Usage: +-- +-- > with_normalized_controls ctrls $ \qs -> do +-- > <<>> +with_normalized_controls :: [Signed Endpoint] -> ([Qubit] -> Circ a) -> Circ a +with_normalized_controls cs f = do + let (qcs, ccs) = partition_controls cs + with_controls ccs $ do + aux qcs [] + + where + aux [] qs = f (reverse qs) + aux (qc:qcs) qs = do + with_signed_qubit qc $ \q -> do + aux qcs (q:qs) + +-- | Like 'with_normalized_controls', but use /HSSH/ instead of /X/, +-- so as not to leave the /H/, /S/, /T/, /CNot/ gate base. +with_normalized_controls_HS :: [Signed Endpoint] -> ([Qubit] -> Circ a) -> Circ a +with_normalized_controls_HS cs f = do + let (qcs, ccs) = partition_controls cs + with_controls ccs $ do + aux qcs [] + + where + aux [] qs = f (reverse qs) + aux (qc:qcs) qs = do + with_signed_qubit_HS qc $ \q -> do + aux qcs (q:qs) + with_signed_qubit_HS (Signed q True) f = f q + with_signed_qubit_HS (Signed q False) f = do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + b <- f q + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + return b + +-- | Negate the number if the boolean is true. +negate_if :: (Num r) => Bool -> r -> r +negate_if False x = x +negate_if True x = -x + +-- ---------------------------------------------------------------------- +-- * Transformers + +-- ---------------------------------------------------------------------- +-- ** Control trimming + +-- | This transformer makes sure that not-gates, Pauli /X/-, /Y/-, and +-- /Z/-gates, and /iX/-gates have at most two controls; that phase +-- gates of the form Diag(1, φ) have no controls; and that all other +-- gates have at most one control. +trimcontrols_transformer :: Transformer Circ Qubit Bit +trimcontrols_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 2 cs $ \qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +trimcontrols_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + qmultinot qs `controlled` qcs + return (qs, [], cs) +trimcontrols_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + hadamard q `controlled` qcs + return ([q], [], cs) +trimcontrols_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + swap_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +trimcontrols_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + gate_W_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +trimcontrols_transformer gate@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are allowed two controls + ("X", [q], []) -> 2 + ("Y", [q], []) -> 2 + ("Z", [q], []) -> 2 + ("iX", [q], []) -> 2 + _ -> 1 + with_combined_controls_iX n cs $ \qcs -> do + named_gate_qulist_at name inv qs gctls `controlled` qcs + return (qs,gctls,cs) +trimcontrols_transformer (T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + global_phase_anchored t qs `controlled` qcs + return cs +trimcontrols_transformer gate@(T_QRot name _ _ inv theta ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are decomposed to zero controls + ("R(2pi/%)", [q], []) -> 0 + ("T(%)", [q], []) -> 0 + _ -> 1 + case n of + 0 -> do + let [q] = qs + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + let [c] = qcs + with_signed_qubit c $ \q -> do + named_rotation_qulist_at name inv theta [q] gctls + return (qs,gctls,cs) + _ -> do + with_combined_controls_iX 1 cs $ \qcs -> do + named_rotation_qulist_at name inv theta qs gctls `controlled` qcs + return (qs,gctls,cs) + +-- The subroutine transformer clause is called when a subroutine gate appears, +-- for now we decompose the controls just like for other gates. The recursive +-- decomposition of a subroutine is taken care of in the dynamic transformer. +trimcontrols_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \namespace ws cs -> without_controls_if ncf $ do + let qws = [w | Endpoint_Qubit w <- ws] + provide_subroutines namespace + with_combined_controls_iX 1 cs $ \qcs -> do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` qcs + return (vs,cs) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +trimcontrols_transformer gate@(T_CNot _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CGate _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CSwap _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QPrep _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QUnprep _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QInit _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CInit _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QMeas _) = identity_transformer gate +trimcontrols_transformer gate@(T_QDiscard _) = identity_transformer gate +trimcontrols_transformer gate@(T_CDiscard _) = identity_transformer gate +trimcontrols_transformer gate@(T_DTerm _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_Comment _ _ _) = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Approximate Clifford+/T/ decomposition + +-- | This transformer decomposes rotation and phase gates into the +-- Clifford+/T/ basis, using the approximate synthesis algorithm of +-- . Other gates +-- are unchanged. +-- +-- This transformer requires a precision parameter, as well as a +-- source of randomness. The 'KeepPhase' flag indicates whether to +-- respect global phases. +approx_ct_transformer :: (RandomGen g) => KeepPhase -> Precision -> g -> Transformer Circ Qubit Bit +approx_ct_transformer kp prec g gate@(T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + comment_with_label (printf "ENTER: GPhase (t=%f)" t) cs "c" + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> approximate_synthesis_phase kp prec theta g + where + theta = pi * to_real t + [c] -> do + with_signed_qubit c $ \q -> do + approximate_synthesis_phase_ctrl kp prec theta g q + return () + where + theta = pi * to_real t + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + comment_with_label "EXIT: GPhase" cs "c" + return cs +approx_ct_transformer kp prec g gate@(T_QRot name _ _ inv t ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + comment_with_label (printf "ENTER: %s%s (t=%f)" name (optional inv "*") t) (qs,cs) ("q","c") + case (name, inv, qs, gctls) of + ("exp(-i%Z)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_zrot prec theta g q + return () + where + theta = negate_if inv (2 * to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_zrot_ctrl prec theta g q q2 + return () + where + theta = negate_if inv (2 * to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("exp(% pi i)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (to_real (pi*t)) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_phase_ctrl kp prec theta g q2 + return () + where + theta = negate_if inv (to_real (pi*t)) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("R(2pi/%)", inv, [q], []) -> do + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (2 * pi / to_real t) + [c] -> do + with_signed_qubit c $ \q1 -> do + approximate_synthesis_phase_ctrl kp prec theta g q1 + return () + where + theta = negate_if inv (2 * pi / to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("T(%)", inv, [q], []) -> do + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (-to_real t) + [c] -> do + with_signed_qubit c $ \q1 -> do + approximate_synthesis_phase_ctrl kp prec theta g q1 + return () + where + theta = negate_if inv (-to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("G(%)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (-to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_phase_ctrl kp prec theta g q2 + return () + where + theta = negate_if inv (-to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("Rz(%)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_zrot prec theta g q + return () + where + theta = negate_if inv (to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_zrot_ctrl prec theta g q q2 + return () + where + theta = negate_if inv (to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + _ -> error ("approx_ct_transformer: unimplemented gate: " ++ show gate) + comment_with_label (printf "EXIT: %s%s (t=%f)" name (optional inv "*") t) (qs,cs) ("q","c") + return (qs, gctls, cs) +approx_ct_transformer kp prec g gate = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Exact Clifford+/T/ decomposition + +-- | This transformer decomposes all gates that permit exact +-- Clifford+/T/ representations into the following concrete gate base +-- for Clifford+/T/: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Classical controls and classical gates are not subject to the gate +-- base, and are left untouched. +-- +-- Rotations and phase gates are left unchanged by this transformer, +-- but any controls on those gates will be decomposed. +exact_ct_transformer :: Transformer Circ Qubit Bit +exact_ct_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 2 cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + [c1,c2] -> do + toffoli_AMMR_at q c1 c2 + qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +exact_ct_transformer gate@(T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [] -> do + sequence_ [ gate_X_at q | q <- qs ] + qcs -> do + sequence_ [ qnot_at q | q <- qs ] `controlled` qcs + return (qs, [], cs) +exact_ct_transformer gate@(T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + cH_AMMR_at q c + qcs -> do + hadamard_at q `controlled` qcs + return ([q], [], cs) +exact_ct_transformer gate@(T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + fredkin_at q1 q2 c + qcs -> do + swap_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +exact_ct_transformer gate@(T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + controlled_W_at q1 q2 c + qcs -> do + gate_W_CliffordT_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +exact_ct_transformer gate@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are allowed two controls + ("X", [q], []) -> 2 + ("Y", [q], []) -> 2 + ("Z", [q], []) -> 2 + ("iX", [q], []) -> 2 + _ -> 1 + with_combined_controls_CT n cs $ \qcs -> do + case (name, qs, gctls, qcs) of + + ("X", [q], [], [c1, c2]) -> do + toffoli_AMMR_at q c1 c2 + ("X", [q], [], [c]) -> do + qnot_at q `controlled` c + ("X", [q], [], []) -> do + gate_X_at q + + ("Y", [q], [], [c1, c2]) -> do + gate_S_inv_at q + toffoli_AMMR_at q c1 c2 + gate_S_at q + ("Y", [q], [], [c]) -> do + gate_S_inv_at q + qnot_at q `controlled` c + gate_S_at q + ("Y", [q], [], []) -> do + gate_Y_at q + + ("Z", [q], [], [c1, c2]) -> do + ccZ_AMMR_at q c1 c2 + ("Z", [q], [], [c]) -> do + hadamard_at q + qnot_at q `controlled` c + hadamard_at q + ("Z", [q], [], []) -> do + gate_Z_at q + + ("iX", [q], [], [c1, c2]) -> do + reverse_imp_if inv cc_iX_at q c1 c2 + ("iX", [q], [], [c]) -> do + reverse_imp_if inv controlled_iX_at q c + ("iX", [q], [], []) -> + reverse_imp_if inv gate_iX_at q + + ("S", [q], [], [c]) -> do + reverse_imp_if inv controlled_S_at q c + ("S", [q], [], []) -> do + reverse_imp_if inv gate_S_at q + + ("T", [q], [], [c]) -> do + reverse_imp_if inv controlled_T_at q c + ("T", [q], [], []) -> do + reverse_imp_if inv gate_T_at q + + ("V", [q], [], [c]) -> do + reverse_imp_if inv controlled_V_at q c + ("V", [q], [], []) -> do + reverse_imp_if inv gate_V_at q + + ("E", [q], [], [c]) -> do + reverse_imp_if inv controlled_E_at q c + ("E", [q], [], []) -> do + reverse_imp_if inv gate_E_at q + + ("YY", [q], [], [c]) -> do + reverse_imp_if inv controlled_YY_at q c + ("YY", [q], [], []) -> do + reverse_imp_if inv (named_gate_at "YY") q + + ("omega", [q], [], [c]) -> do + with_signed_qubit c $ \c1 -> do + reverse_imp_if inv gate_T_at c1 + ("omega", [q], [], []) -> do + reverse_imp_if inv gate_omega_at q + + _ -> error ("exact_ct_transformer: gate not implemented: " ++ show gate) + return (qs,gctls,cs) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +exact_ct_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CNot _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CGate _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CSwap _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QPrep _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QUnprep _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QInit _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CInit _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QMeas _) = identity_transformer gate +exact_ct_transformer gate@(T_QDiscard _) = identity_transformer gate +exact_ct_transformer gate@(T_CDiscard _) = identity_transformer gate +exact_ct_transformer gate@(T_DTerm _ _) = identity_transformer gate +exact_ct_transformer gate@(T_Comment _ _ _) = identity_transformer gate + + +-- ---------------------------------------------------------------------- +-- ** Decomposition into standard gate set + +-- | This transformer decomposes a circuit into the standard gate set, +-- which we define to be: +-- +-- * /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the standard gate set. The best way +-- to avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +standard_transformer :: Transformer Circ Qubit Bit +standard_transformer gate@(T_QGate "H" 1 0 _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "Y" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "Z" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "S" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "T" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "multinot" _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "swap" 2 0 _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "W" 2 0 _ _ _) = identity_transformer gate + +standard_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qs -> do + case qs of + [] -> do + gate_X_at q + qs -> qnot_at q `controlled` qs + return ([q], [], cs) + +standard_transformer gate@(T_QGate "X" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + qcs -> do + qnot_at q `controlled` qcs + return ([q],[],cs) + +standard_transformer gate@(T_QGate "iX" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + qcs -> do + reverse_imp_if inv gate_iX_at q `controlled` qcs + return ([q],[],cs) + +standard_transformer gate@(T_QGate "V" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + reverse_imp_if inv gate_S_inv_at q + hadamard_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "E" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_inv_at q + return ([q],[],cs) +standard_transformer gate@(T_QGate "E" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "YY" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + reverse_imp_if inv gate_S_at q + hadamard_at q + reverse_imp_if inv gate_S_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "omega" 1 0 _ ncf f) = f $ + \[q] [] cs -> + return ([q],[],cs) + +standard_transformer gate@(T_QGate name _ _ inv ncf f) = + error ("standard_transformer: gate not implemented: " ++ show gate) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +standard_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +standard_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_CNot _ _) = identity_transformer gate +standard_transformer gate@(T_CGate _ _ _) = identity_transformer gate +standard_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +standard_transformer gate@(T_CSwap _ _) = identity_transformer gate +standard_transformer gate@(T_QPrep _ _) = identity_transformer gate +standard_transformer gate@(T_QUnprep _ _) = identity_transformer gate +standard_transformer gate@(T_QInit _ _ _) = identity_transformer gate +standard_transformer gate@(T_CInit _ _ _) = identity_transformer gate +standard_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +standard_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +standard_transformer gate@(T_QMeas _) = identity_transformer gate +standard_transformer gate@(T_QDiscard _) = identity_transformer gate +standard_transformer gate@(T_CDiscard _) = identity_transformer gate +standard_transformer gate@(T_DTerm _ _) = identity_transformer gate +standard_transformer gate@(T_Comment _ _ _) = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Decomposition into strict gate set + +-- | This transformer decomposes a circuit into the strict gate set, +-- which we define to be: +-- +-- * /H/, /S/, /T/, and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the strict gate set. The best way to +-- avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +strict_transformer :: Transformer Circ Qubit Bit +strict_transformer gate@(T_QGate "H" 1 0 _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "multinot" _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "swap" 2 0 _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "W" 2 0 _ _ _) = identity_transformer gate + +strict_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qs -> do + case qs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qs -> qnot_at q `controlled` qs + return ([q], [], cs) + +strict_transformer gate@(T_QGate "X" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qcs -> do + case qcs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qcs -> do + qnot_at q `controlled` qcs + return ([q],[],cs) + +strict_transformer gate@(T_QGate "Y" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "Z" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "iX" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qcs -> do + case qcs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qcs -> do + reverse_imp_if inv gate_iX_at q `controlled` qcs + return ([q],[],cs) + +strict_transformer gate@(T_QGate "S" 1 0 False ncf f) = + identity_transformer gate +strict_transformer gate@(T_QGate "S" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "T" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_T_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "T" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_T_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "V" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + hadamard_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "V" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + hadamard_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "E" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "E" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "YY" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + when (inv) $ do + gate_S_at q + gate_S_at q + gate_S_at q + hadamard_at q + gate_S_at q + when (inv) $ do + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "omega" 1 0 _ ncf f) = f $ + \[q] [] cs -> + return ([q],[],cs) + +strict_transformer gate@(T_QGate name _ _ inv ncf f) = + error ("strict_transformer: gate not implemented: " ++ show gate) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +strict_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +strict_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_CNot _ _) = identity_transformer gate +strict_transformer gate@(T_CGate _ _ _) = identity_transformer gate +strict_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +strict_transformer gate@(T_CSwap _ _) = identity_transformer gate +strict_transformer gate@(T_QPrep _ _) = identity_transformer gate +strict_transformer gate@(T_QUnprep _ _) = identity_transformer gate +strict_transformer gate@(T_QInit _ _ _) = identity_transformer gate +strict_transformer gate@(T_CInit _ _ _) = identity_transformer gate +strict_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +strict_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +strict_transformer gate@(T_QMeas _) = identity_transformer gate +strict_transformer gate@(T_QDiscard _) = identity_transformer gate +strict_transformer gate@(T_CDiscard _) = identity_transformer gate +strict_transformer gate@(T_DTerm _ _) = identity_transformer gate +strict_transformer gate@(T_Comment _ _ _) = identity_transformer gate + + +-- ---------------------------------------------------------------------- +-- * Glue code for subroutines + +-- $ The following is stuff we have to do because subroutines are not +-- yet handled very abstractly. It is untested whether subroutines +-- work at all. + +-- | Handle subroutines for the 'trimcontrols_transformer'. +trimcontrols_subroutine :: BoxId -> TypedSubroutine -> Circ () +trimcontrols_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = trimcontrols_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "trimcontrols_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'trimcontrols_transformer'. +trimcontrols_dtransformer :: DynamicTransformer Circ Qubit Bit +trimcontrols_dtransformer = identity_dynamic_transformer { + transformer = trimcontrols_transformer, + define_subroutine = trimcontrols_subroutine} + +-- | Unary transformer for the 'trimcontrols_transformer'. +trimcontrols_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +trimcontrols_unary = transform_unary_dynamic trimcontrols_dtransformer + +-- | Handle subroutines for the 'approx_ct_transformer'. +approx_ct_subroutine :: (RandomGen g) => KeepPhase -> Precision -> g -> BoxId -> TypedSubroutine -> Circ () +approx_ct_subroutine kp prec g boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = approx_ct_unary kp prec g circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "approx_ct_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'approx_ct_transformer'. +approx_ct_dtransformer :: (RandomGen g) => KeepPhase -> Precision -> g -> DynamicTransformer Circ Qubit Bit +approx_ct_dtransformer kp prec g = identity_dynamic_transformer { + transformer = approx_ct_transformer kp prec g, + define_subroutine = approx_ct_subroutine kp prec g} + +-- | Unary transformer for the 'approx_ct_transformer'. +approx_ct_unary :: (RandomGen g, QCData qa, QCData qb) => KeepPhase -> Precision -> g -> (qa -> Circ qb) -> (qa -> Circ qb) +approx_ct_unary kp prec g = transform_unary_dynamic (approx_ct_dtransformer kp prec g) + +-- | Handle subroutines for the 'exact_ct_transformer'. +exact_ct_subroutine :: BoxId -> TypedSubroutine -> Circ () +exact_ct_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = exact_ct_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "exact_ct_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'exact_ct_transformer'. +exact_ct_dtransformer :: DynamicTransformer Circ Qubit Bit +exact_ct_dtransformer = identity_dynamic_transformer { + transformer = exact_ct_transformer, + define_subroutine = exact_ct_subroutine} + +-- | Unary transformer for the 'exact_ct_transformer'. +exact_ct_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +exact_ct_unary = transform_unary_dynamic exact_ct_dtransformer + +-- | Handle subroutines for the 'standard_transformer'. +standard_subroutine :: BoxId -> TypedSubroutine -> Circ () +standard_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = standard_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "standard_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'standard_transformer'. +standard_dtransformer :: DynamicTransformer Circ Qubit Bit +standard_dtransformer = identity_dynamic_transformer { + transformer = standard_transformer, + define_subroutine = standard_subroutine} + +-- | Unary transformer for the 'standard_transformer'. +standard_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +standard_unary = transform_unary_dynamic standard_dtransformer + +-- | Handle subroutines for the 'strict_transformer'. +strict_subroutine :: BoxId -> TypedSubroutine -> Circ () +strict_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = strict_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "strict_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'strict_transformer'. +strict_dtransformer :: DynamicTransformer Circ Qubit Bit +strict_dtransformer = identity_dynamic_transformer { + transformer = strict_transformer, + define_subroutine = strict_subroutine} + +-- | Unary transformer for the 'strict_transformer'. +strict_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +strict_unary = transform_unary_dynamic strict_dtransformer + +-- ---------------------------------------------------------------------- +-- * Generic transformers + +-- $ The following generic functions form the high-level interface to +-- these decomposition transformers. This is how the transformers +-- should be accessed by user code. + +-- | This transformer makes sure that not-gates, Pauli /X/-, /Y/-, and +-- /Z/-gates, and /iX/-gates have at most two controls; that phase +-- gates of the form Diag(1, φ) have no controls; and that all other +-- gates have at most one control. +trimcontrols_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +trimcontrols_generic f = h where + f1 = quncurry f + h1 = trimcontrols_unary f1 + h = qcurry h1 + +-- | This transformer decomposes rotation and phase gates into the +-- Clifford+/T/ basis, using the approximate synthesis algorithm of +-- . It requires a precision +-- parameter, as well as a source of randomness. Other gates +-- are unchanged. +approx_ct_generic :: (RandomGen g, QCData qa, QCData qb, QCurry qfun qa qb) => KeepPhase -> Precision -> g -> qfun -> qfun +approx_ct_generic kp prec g f = h where + f1 = quncurry f + h1 = approx_ct_unary kp prec g f1 + h = qcurry h1 + +-- | This transformer decomposes all gates that permit exact +-- Clifford+/T/ representations into the following concrete gate base +-- for Clifford+/T/: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Classical controls and classical gates are not subject to the gate +-- base, and are left untouched. +-- +-- Rotations and phase gates are left unchanged by this transformer, +-- but any controls on those gates will be decomposed. +exact_ct_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +exact_ct_generic f = h where + f1 = quncurry f + h1 = exact_ct_unary f1 + h = qcurry h1 + +-- | This transformer decomposes a circuit into the standard gate set, +-- which we define to be: +-- +-- * /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the standard gate set. The best way +-- to avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +standard_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +standard_generic f = h where + f1 = quncurry f + h1 = standard_unary f1 + h = qcurry h1 + +-- | This transformer decomposes a circuit into the strict gate set, +-- which we define to be: +-- +-- * /H/, /S/, /T/, and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the strict gate set. The best way to +-- avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +strict_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +strict_generic f = h where + f1 = quncurry f + h1 = strict_unary f1 + h = qcurry h1 diff --git a/Quipper/Libraries/Decompose/GateBase.hs b/Quipper/Libraries/Decompose/GateBase.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Decompose/GateBase.hs @@ -0,0 +1,127 @@ +-- | This module provides an enumeration type for gate bases. This is +-- useful, for example, to provide a uniform interface to gate base +-- decomposers, so that they can be selected via command line options +-- or function arguments. + +module Quipper.Libraries.Decompose.GateBase where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Synthesis +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.Decompose.CliffordT + +import Quipper.Utils.RandomSource + +import System.Random + +-- ---------------------------------------------------------------------- +-- * Gate bases + +-- | An enumeration type for gate bases. More cases can be added in +-- the future, for example for using gates from a particular physical +-- machine description. +-- +-- Some gate bases carry additional parameters; for example, in the +-- case of decomposition into a discrete gate base, one may specify a +-- precision ε, a random seed, or other flags. +-- +-- If a 'Precision' parameter is present, it specifies the desired +-- precision per gate. If a 'RandomSource' parameter is present, it +-- specifies a source of randomness. +-- +-- If a 'KeepPhase' parameter is present, it determines whether global +-- phases are respected ('True') or disregarded ('False'). +data GateBase = + Logical + -- ^ Use all logical gates, i.e., leave the circuit unchanged. + | Binary + -- ^ Decompose into binary gates. + | Toffoli + -- ^ Decompose into Toffoli and binary gates. + | CliffordT_old + -- ^ Decompose into Clifford+/T/. This is a legacy transformer + -- that does not handle all gates correctly. For example, it does + -- not handle /W/-gates, rotations, or phase gates. Use + -- 'CliffordT' instead. + | CliffordT KeepPhase Precision RandomSource + -- ^ Decompose into Clifford+/T/, specifically: single-qubit + -- Clifford gates, the controlled-not gate (with positive or + -- negative controls), and the gates /T/ and /T/[sup †]. + | Standard Precision RandomSource + -- ^ Decompose into the standard gate set, which we define to be + -- /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and + -- /CNOT/. Suppresses global phases. + | Strict Precision RandomSource + -- ^ Decompose into /H/, /S/, /T/, /CNOT/ gates only. Suppresses + -- global phases. + | Approximate KeepPhase Precision RandomSource + -- ^ Decompose rotation and phase gates into Clifford+/T/, using + -- an approximate synthesis algorithm. Other gates are unchanged. + | Exact + -- ^ Decompose gates that can be exactly represented in the + -- Clifford+/T/ base into that base, specifically: single-qubit + -- Clifford gates, the controlled-not gate (with positive or + -- negative controls), and the gates /T/ and /T/[sup †]. Leave + -- rotation and phase gates unchanged. + | TrimControls + -- ^ Eliminate excess controls from gates. + deriving Show + +-- | An assignment of gate bases to names. Names are given as +-- lower-case strings. +-- +-- This can be useful, e.g., in the definition of command line +-- options. +-- +-- In the future, the syntax should be extended so that users can +-- specify parameters (e.g., the precision, random seed) on the +-- command line as well. For now, we just use the default precision. +gatebase_enum :: [(String, GateBase)] +gatebase_enum = [ + ("logical", Logical), + ("binary", Binary), + ("toffoli", Toffoli), + ("cliffordt_old", CliffordT_old), + ("cliffordt", CliffordT False (30 * digits) rs), + ("cliffordt_keepphase", CliffordT True (30 * digits) rs), + ("standard", Standard (30 * digits) rs), + ("strict", Strict (30 * digits) rs), + ("approximate", Approximate False (30 * digits) rs), + ("approximate_keepphase", Approximate True (30 * digits) rs), + ("exact", Exact), + ("trimcontrols", TrimControls) + ] + where + rs = RandomSource (read "1" :: StdGen) + +-- ---------------------------------------------------------------------- +-- * Generic decomposition + +-- | Decompose a circuit into gates from the given 'GateBase'. This +-- can be applied to a circuit-generating function in curried form +-- with /n/ arguments, for any /n/ ≥ 0. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > decompose_generic :: (QCData qa) => GateBase -> Circ qa -> Circ qa +-- > decompose_generic :: (QCData qa, QCData qb) => GateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +-- > decompose_generic :: (QCData qa, QCData qb, QCData qc) => GateBase -> (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) +-- +-- and so forth. + +decompose_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => GateBase -> qfun -> qfun +decompose_generic Logical = id +decompose_generic Binary = decompose_legacy_generic GB_Binary +decompose_generic Toffoli = decompose_legacy_generic GB_Toffoli +decompose_generic CliffordT_old = decompose_legacy_generic GB_CliffordT +decompose_generic (CliffordT kp prec (RandomSource g)) = exact_ct_generic . approx_ct_generic kp prec g +decompose_generic (Standard prec (RandomSource g)) = standard_generic . exact_ct_generic . approx_ct_generic False prec g +decompose_generic (Strict prec (RandomSource g)) = strict_generic . exact_ct_generic . approx_ct_generic False prec g +decompose_generic (Approximate kp prec (RandomSource g)) = approx_ct_generic kp prec g +decompose_generic Exact = exact_ct_generic +decompose_generic TrimControls = trimcontrols_generic + + diff --git a/Quipper/Libraries/Decompose/Legacy.hs b/Quipper/Libraries/Decompose/Legacy.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Decompose/Legacy.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE Rank2Types #-} + +-- | Functions to decompose circuits into various gate bases. This +-- decompositions are \"legacy\". The 'GB_Toffoli' and 'GB_CliffordT' +-- decomposers contained here are being superseded by their +-- counterparts in "Quipper.Libraries.Decompose.CliffordT". + +module Quipper.Libraries.Decompose.Legacy where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.GateDecompositions + +-- The following is a bunch of stuff we need to import because, +-- temporarily, Decompose.hs uses low-level interfaces. It should be +-- re-implemented using only high-level interfaces, or in some cases, +-- more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Internal.Transformer (bindings_empty, bind_list, unbind_list, DynamicTransformer(..)) +import Quipper.Internal.Generic (provide_subroutine_generic, transform_unary_dynamic) + +import Control.Monad + +-- ---------------------------------------------------------------------- +-- * Legacy gatebase + +-- | An enumeration type for the three gate bases handled by this +-- module. +data LegacyGateBase = GB_Toffoli | GB_Binary | GB_CliffordT + deriving (Show) +-- ---------------------------------------------------------------------- +-- * Helper functions + +-- | Decompose quantum controls recursively until at most /n/ remain, +-- and then pass these reduced controls to the given circuit. +-- Precondition: /n/ ≥ 1. The decomposition is done using Toffoli +-- gates, decomposed into the gate base. Classical controls are left +-- untouched. +-- +-- For example, when /n/=2, this typically yields a circuit such as +-- the following (but with the Toffoli gates further decomposed into +-- the 'LegacyGateBase'): +-- +-- \[image decompose2Controls.png] +-- +-- And for /n/=1, the circuit typically looks like this: +-- +-- \[image decomposeControls.png] +with_combined_controls_gb :: LegacyGateBase -> Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_gb GB_Toffoli = with_combined_controls toffoli_plain_at +with_combined_controls_gb GB_Binary = with_combined_controls toffoli_V_at +with_combined_controls_gb GB_CliffordT = with_combined_controls toffoli_AMMR_at + +-- | Decompose a Toffoli gate into the given 'LegacyGateBase'. The controls +-- on the Toffoli gate may be positive or negative, as specified. +decomposeQToffoli :: LegacyGateBase -> Qubit -> (Signed Qubit, Signed Qubit) -> Circ () +decomposeQToffoli GB_Toffoli q (c1, c2) = qnot_at q `controlled` [c1,c2] +decomposeQToffoli GB_Binary q (c1, c2) = do + toffoli_V_at q c1 c2 +decomposeQToffoli GB_CliffordT q3 (c1, c2) = do + toffoli_AMMR_at q3 c1 c2 + +-- | The inverse of 'decomposeQToffoli'. +decomposeQToffoli_inv :: LegacyGateBase -> Qubit -> (Signed Qubit, Signed Qubit) -> Circ () +decomposeQToffoli_inv gb = reverse_generic_imp (decomposeQToffoli gb) + +-- | Implement a QMultinot gate in terms of QNot gates. +decomposeQMultinot :: [Qubit] -> Circ () +decomposeQMultinot [] = return () +decomposeQMultinot (q:qs) = do + qnot_at q + decomposeQMultinot qs + +-- ---------------------------------------------------------------------- +-- * Decomposition transformers + +-- | A transformer to decompose a circuit into 'LegacyGateBase' gates. Note +-- that in the case of classically-controlled quantum gates, the +-- classical controls are unaffected. +decompose_transformer :: LegacyGateBase -> Transformer Circ Qubit Bit +decompose_transformer gb (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 2 cs $ \qcs -> do + case qcs of + -- two controls + [c1, c2] -> do + decomposeQToffoli gb q (c1,c2) + return ([q], [], cs) + -- zero or one control + qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +decompose_transformer gb (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + decomposeQMultinot qs `controlled` qcs + return (qs, [], cs) +decompose_transformer gb (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + hadamard q `controlled` qcs + return ([q], [], cs) +decompose_transformer gb (T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + case qcs of + -- one control + [c] -> do + qnot_at q1 `controlled` q2 + decomposeQToffoli gb q2 (c,(Signed q1 True)) + qnot_at q1 `controlled` q2 + return ([q1, q2], [], cs) + -- zero controls + qcs -> do + swap_at q1 q2 + return ([q1, q2], [], cs) +decompose_transformer gb (T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + case qcs of + -- one control + [c] -> do + qnot q2 `controlled` q1 + w' <- qinit_qubit False + decomposeQToffoli gb w' (c,(Signed q2 True)) + hadamard q1 `controlled` w' + decomposeQToffoli_inv gb w' (c,(Signed q2 True)) + qterm_qubit False w' + qnot q2 `controlled` q1 + return ([q1, q2], [], cs) + -- zero controls + qcs -> do + gate_W q1 q2 + return ([q1, q2], [], cs) +decompose_transformer gb (T_QGate name _ _ inv ncf f) = f $ + \qs vs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + named_gate_qulist_at name inv qs vs `controlled` qcs + return (qs, vs, cs) +decompose_transformer gb (T_QRot name _ _ inv theta ncf f) = f $ + \qs vs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + named_rotation_qulist_at name inv theta qs vs `controlled` qcs + return (qs, vs, cs) +decompose_transformer gb (T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + global_phase_anchored_list t qs `controlled` qcs + return cs + +-- The subroutine transformer clause is called when a subroutine gate appears, +-- for now we decompose the controls just like for other gates. The recursive +-- decomposition of a subroutine is taken care of in the dynamic transformer. +decompose_transformer gb (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \namespace ws cs -> without_controls_if ncf $ do + let qws = [w | Endpoint_Qubit w <- ws] + with_combined_controls_gb gb 1 cs $ \qcs -> do + provide_subroutines namespace + case qcs of + -- one control + [c] -> if length qws /= length ws then error "Classical subroutine, used with quantum controls" else do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,cs) + -- zero controls + qcs -> do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws + return (vs,cs) +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +decompose_transformer gb gate@(T_CNot _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CGate _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CGateInv _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CSwap _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QPrep _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QUnprep _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QInit _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CInit _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QTerm _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CTerm _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QMeas _) = identity_transformer gate +decompose_transformer gb gate@(T_QDiscard _) = identity_transformer gate +decompose_transformer gb gate@(T_CDiscard _) = identity_transformer gate +decompose_transformer gb gate@(T_DTerm _ _) = identity_transformer gate +decompose_transformer gb gate@(T_Comment _ _ _) = identity_transformer gate + +-- | Return a circuit producing function from a TypedSubroutine +open_subroutine :: TypedSubroutine -> [Endpoint] -> Circ [Endpoint] +open_subroutine (TypedSubroutine ocircuit _ _ scf) inputs = do + let OCircuit (win, circuit, wout) = ocircuit + when (length win /= length inputs) $ do + error ("open_subroutine: subroutine has been applied to incorrect size of QCData") + let in_bind = bind_list win inputs bindings_empty + out_bind <- apply_circuit_with_bindings circuit in_bind + let outputs = unbind_list out_bind wout + return outputs + +-- | Apply the decompose transformer to the given TypedSubroutine +-- Note: by default, set the classical-control flag to false. +decompose_subroutine :: LegacyGateBase -> BoxId -> TypedSubroutine -> Circ () +decompose_subroutine gb boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = decompose_legacy_unary gb circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "decompose_subroutine: " ++ x) boxid False circ' ein + +-- | A dynamic transformer variant of the decompose transformer +decompose_dynamic_transformer :: LegacyGateBase -> DynamicTransformer Circ Qubit Bit +decompose_dynamic_transformer gb = identity_dynamic_transformer { + transformer = decompose_transformer gb, + define_subroutine = decompose_subroutine gb} + +-- ---------------------------------------------------------------------- +-- * Generic decomposition + +-- | Decompose a circuit into gates from the given 'LegacyGateBase'. +decompose_legacy_unary :: (QCData qa, QCData qb) => LegacyGateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +decompose_legacy_unary gb circ = transform_unary_dynamic (decompose_dynamic_transformer gb) circ + +-- | Decompose a circuit into gates from the given 'LegacyGateBase'. Unlike +-- 'decompose_legacy_unary', this can be applied to a circuit-generating +-- function in curried form with /n/ arguments, for any /n/ ≥ 0. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > decompose_legacy_generic :: (QCData qa) => LegacyGateBase -> Circ qa -> Circ qa +-- > decompose_legacy_generic :: (QCData qa, QCData qb) => LegacyGateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +-- > decompose_legacy_generic :: (QCData qa, QCData qb, QCData qc) => LegacyGateBase -> (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) +-- +-- and so forth. + +decompose_legacy_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => LegacyGateBase -> qfun -> qfun +decompose_legacy_generic gatebase f = g where + f1 = quncurry f + g1 = decompose_legacy_unary gatebase f1 + g = qcurry g1 + diff --git a/Quipper/Libraries/DynamicLiftings.hs b/Quipper/Libraries/DynamicLiftings.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/DynamicLiftings.hs @@ -0,0 +1,653 @@ +-- | This library provides various transformers and functions for +-- performing dynamic liftings based on different mechanisms. Some use +-- simulations to do the dynamic liftings; others just do them +-- randomly. There are also functions for printing the simulated +-- circuit. +-- +-- This code is experimental. + +module Quipper.Libraries.DynamicLiftings where + +import Quipper + +-- The following is a bunch of stuff we need to import because, +-- temporarily, DynamicLiftings.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit (Namespace, namespace_empty, TypedSubroutine(..), OCircuit(..), reverse_ocircuit, showNames) +import Quipper.Internal (BType) +import Quipper.Internal.Transformer +import Quipper.Internal.Monad +import Quipper.Internal.Generic (transform_unary_dynamic_shape) +import Quipper.Internal.Printing (getBit) + +import Quipper.Libraries.Simulation.QuantumSimulation + +import Quipper.Utils.Auxiliary (map_provide) + +-- we use the state monad to hold our \"quantum\" state +import Control.Monad.State +-- we use a random number generator to simulate \"quantum randomness\" +import System.Random hiding (split) +-- we store \"basis\" states as a map, +--i.e., Map Qubit Bool represents a basis state. +import Data.Map (Map) +import qualified Data.Map as Map + +-- ====================================================================== +-- * Random Dynamic Liftings and Liftings from a List + +-- | A State monad that holds a random generator. +type RandomCirc a = StateT StdGen Circ a + +-- | A State monad that holds a list of booleans. +type ListCirc a = StateT [Bool] Circ a + +-- | To evaluate a 'RandomCirc' we require a seed for the random generator. +evalRandomCirc :: Int -> RandomCirc a -> Circ a +evalRandomCirc seed rc = evalStateT rc (mkStdGen seed) + +-- | To evaluate a 'ListCirc' we require a list of booleans. +evalListCirc :: [Bool] -> ListCirc a -> Circ a +evalListCirc bools lc = evalStateT lc bools + +-- | Lift 'evalRandomCirc' to unary random circuit generating functions. +evalRandomCirc_unary :: Int -> (a -> RandomCirc b) -> a -> Circ b +evalRandomCirc_unary seed rcirc input = evalRandomCirc seed (rcirc input) + +-- | Left 'evalListCirc' to unary list circuit generating functions. +evalListCirc_unary :: [Bool] -> (a -> ListCirc b) -> a -> Circ b +evalListCirc_unary bools lcirc input = evalListCirc bools (lcirc input) + +-- | Lift the underlying 'randomR' function into the RandomCirc monad. +randomRRandomCirc :: Random a => (a,a) -> RandomCirc a +randomRRandomCirc (a0,a1) = do + stdgen <- get + let (random_a,stdgen') = randomR (a0,a1) stdgen + put stdgen' + return random_a + +-- | Print a RandomCirc by evaluating it with a seed in the IO monad. +print_unary_random :: (QCData qa) => Format -> (qa -> RandomCirc b) -> qa -> IO () +print_unary_random format rcirc input = do + seed <- randomIO + let circ = evalRandomCirc_unary seed rcirc + print_unary format circ input + +-- | Print a LiftCirc by evaluating it in the IO Monad, so as to read +-- in a given number of booleans. +print_unary_list :: (QCData qa) => Format -> Int -> (qa -> ListCirc b) -> qa -> IO () +print_unary_list format liftings lcirc input = do + bools <- mapM (\() -> getBit) (replicate liftings ()) + let circ = evalListCirc_unary bools lcirc + print_unary format circ input + +-- | Lift the 'identity_transformer' using any monad transformer. +lifted_identity_transformer :: (MonadTrans t) => Transformer (t Circ) Qubit Bit +lifted_identity_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> lift $ without_controls_if ncf $ do + q' <- qnot q `controlled` cs + return ([q'], [] ,cs) +lifted_identity_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \ws [] cs -> lift $ without_controls_if ncf $ do + ws' <- qmultinot_list (map (\x -> (x,True)) ws) `controlled` cs + return (ws', [], cs) +lifted_identity_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> lift $ without_controls_if ncf $ do + q' <- hadamard q `controlled` cs + return ([q'], [], cs) +lifted_identity_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w,v] [] cs -> lift $ without_controls_if ncf $ do + (w',v') <- swap_qubit w v `controlled` cs + return ([w',v'], [], cs) +lifted_identity_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w,v] [] cs -> lift $ without_controls_if ncf $ do + (w',v') <- gate_W w v `controlled` cs + return ([w',v'], [], cs) +lifted_identity_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c + return (ws', vs', c) +lifted_identity_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c + return (ws', vs', c) +lifted_identity_transformer (T_GPhase t ncf f) = f $ + \qs c -> lift $ without_controls_if ncf $ do + global_phase_anchored_list t qs `controlled` c + return c +lifted_identity_transformer (T_CNot ncf f) = f $ + \q c -> lift $ without_controls_if ncf $ do + q' <- cnot q `controlled` c + return (q', c) +lifted_identity_transformer (T_CGate name ncf f) = f $ + \ws -> lift $ without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) +lifted_identity_transformer (T_CGateInv name ncf f) = f $ + \v ws -> lift $ without_controls_if ncf $ do + cgateinv name v ws + return ws +lifted_identity_transformer (T_CSwap ncf f) = f $ + \w v c -> lift $ without_controls_if ncf $ do + (w',v') <- swap_bit w v `controlled` c + return (w',v',c) +lifted_identity_transformer (T_QPrep ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + v <- prepare_qubit w + return v +lifted_identity_transformer (T_QUnprep ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + v <- unprepare_qubit w + return v +lifted_identity_transformer (T_QInit b ncf f) = f $ + lift $ without_controls_if ncf $ do + w <- qinit_qubit b + return w +lifted_identity_transformer (T_CInit b ncf f) = f $ + lift $ without_controls_if ncf $ do + w <- cinit_bit b + return w +lifted_identity_transformer (T_QTerm b ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + qterm_qubit b w + return () +lifted_identity_transformer (T_CTerm b ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + cterm_bit b w + return () +lifted_identity_transformer (T_QMeas f) = f $ + \w -> lift $ do + v <- measure_qubit w + return v +lifted_identity_transformer (T_QDiscard f) = f $ + \w -> lift $ do + qdiscard_qubit w + return () +lifted_identity_transformer (T_CDiscard f) = f $ + \w -> lift $ do + cdiscard_bit w + return () +lifted_identity_transformer (T_DTerm b f) = f $ + \w -> lift $ do + dterm_bit b w + return () +lifted_identity_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \ns ws c -> lift $ without_controls_if ncf $ do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,c) +lifted_identity_transformer (T_Comment s inv f) = f $ + \ws -> lift $ do + comment_label s inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] + return () + +-- | Dynamic lifting can make use of a random result (without caring which wire is +-- being lifted). +random_dynamic_lift :: Bit -> RandomCirc Bool +random_dynamic_lift _ = randomRRandomCirc (False,True) + +-- | Dynamic lifting can pop the head off of a list of booleans, and use that to +-- lift the given wire. +list_dynamic_lift :: Bit -> ListCirc Bool +list_dynamic_lift _ = do + xs <- get + case xs of + [] -> error "ListCirc list of liftings exhausted" + (x:xs') -> do + put xs' + return x + +-- | A dynamic transformer which is the identity transformer (lifted to +-- RandomCirc), except for the dynamic lifting operation. +random_dynamic_lift_transformer :: DynamicTransformer (StateT StdGen Circ) Qubit Bit +random_dynamic_lift_transformer = DT { + transformer = lifted_identity_transformer, + define_subroutine = \name subroutine -> do + lift $ put_subroutine_definition name subroutine, + lifting_function = random_dynamic_lift + } + +-- | A dynamic transformer which is the identity transformer (lifted to +-- ListCirc), except for the dynamic lifting operation. +list_dynamic_lift_transformer :: DynamicTransformer (StateT [Bool] Circ) Qubit Bit +list_dynamic_lift_transformer = DT { + transformer = lifted_identity_transformer, + define_subroutine = \name subroutine -> do + lift $ put_subroutine_definition name subroutine, + lifting_function = list_dynamic_lift + } + +-- | Print a circuit, using random dynamic liftings. +print_unary_with_random_liftings :: (QCData a,QCData b) => Format -> (a -> Circ b) -> a -> IO () +print_unary_with_random_liftings format circ shape = do + let lifted_circ = transform_unary_dynamic_shape random_dynamic_lift_transformer circ shape + print_unary_random format lifted_circ shape + +-- | Print a circuit, using a list of dynamic liftings. +print_unary_with_list_liftings :: (QCData a,QCData b) => Format -> Int -> (a -> Circ b) -> a -> IO () +print_unary_with_list_liftings format liftings circ shape = do + let lifted_circ = transform_unary_dynamic_shape list_dynamic_lift_transformer circ shape + print_unary_list format liftings lifted_circ shape + +-- ====================================================================== +-- * Simulating the Dynamic Liftings + +-- | Add state to the Circ Monad so that we can simulate the circuit +-- and use that data for dynamic liftings. +data SimulationState = SS { + s_quantum_state :: Amplitudes Double, + s_classical_state :: Map Bit Bool, + s_namespace :: Namespace, -- we need a namespace to keep track of subroutines + s_rng :: StdGen + } + +-- | When we start a simulation, we need an empty starting state, with +-- a seed for the generator. +empty_simulation_state :: Int -> SimulationState +empty_simulation_state seed = SS { s_quantum_state = Vector [(Map.empty,1.0)], s_classical_state = Map.empty, s_namespace = namespace_empty, s_rng = mkStdGen seed} + +-- | A State monad that holds our SimulationState. +type SimulatedCirc a = StateT SimulationState Circ a + +-- | Evaluate a 'SimulatedCirc'. This requires a seed for the random generator. +evalSimulatedCirc :: Int -> SimulatedCirc a -> Circ a +evalSimulatedCirc seed sc = evalStateT sc (empty_simulation_state seed) + +-- | Lift 'evalSimulatedCirc' to unary functions. +evalSimulatedCirc_unary :: Int -> (a -> SimulatedCirc b) -> a -> Circ b +evalSimulatedCirc_unary seed scirc input = evalSimulatedCirc seed (scirc input) + +-- | Lift the underlying 'randomR' function into the SimulatedCirc monad. +randomRSimulatedCirc :: Random a => (a,a) -> SimulatedCirc a +randomRSimulatedCirc (a0,a1) = do + state <- get + let stdgen = s_rng state + let (random_a,stdgen') = randomR (a0,a1) stdgen + put (state {s_rng = stdgen'}) + return random_a + +-- | A specialized put function for the quantum state that uses the current state +-- instead of a previously retrieved state. +putQS :: Amplitudes Double -> SimulatedCirc () +putQS amps = do + state <- get + put (state {s_quantum_state = amps}) + +-- | A specialized put function for the classical state that uses the current state +-- instead of a previously retrieved state. +putCS :: Map Bit Bool -> SimulatedCirc () +putCS bits = do + state <- get + put (state {s_classical_state = bits}) + +-- | It doesn't make sense having a quantum control on a classical gate, so +-- we can throw an error if that is the case, and just lookup the boolean +-- result otherwise. +s_classical_control :: Map Bit Bool -> Signed (B_Endpoint Qubit Bit) -> Bool +s_classical_control bits (Signed bep val) = case bep of + (Endpoint_Bit bit) -> val == val' where val' = bits Map.! bit + (Endpoint_Qubit _) -> error "CNot: Quantum Control on Classical Gate" + +-- | Map the 's_classical_control' function to all the controls, and take the +-- 'and' of the result. +s_classical_controls :: Map Bit Bool -> Ctrls Qubit Bit -> Bool +s_classical_controls bits cs = and (map (s_classical_control bits) cs) + +-- | When we want a quantum control, we will be working with one "basis state" at +-- a time, and can look up the qubit's value in that basis state to see whether +-- the control fires. +s_qc_control :: Map Bit Bool -> Map Qubit Bool -> Signed (B_Endpoint Qubit Bit) -> Bool +s_qc_control bits mqb (Signed bep val) = case bep of + (Endpoint_Bit bit) -> val == val' where val' = bits Map.! bit + (Endpoint_Qubit q) -> val == val' where val' = mqb Map.! q + +-- | Map the 's_qc_control' function to all the controls (under the given basis +-- state), and take the 'and' of the result. +s_qc_controls :: Map Bit Bool -> Map Qubit Bool -> Ctrls Qubit Bit -> Bool +s_qc_controls bits mqb cs = and (map (s_qc_control bits mqb) cs) + +-- | Apply the given function only if the controls fire. +s_if_controls :: Map Bit Bool -> Ctrls Qubit Bit -> (Map Qubit Bool -> Amplitudes Double) -> Map Qubit Bool -> Amplitudes Double +s_if_controls bits c f mqb = if (s_qc_controls bits mqb c) then f mqb else Vector [(mqb,1)] + +-- | The 'simulated_lift_transformer' is the actual transformer that does the +-- simulation, while recreating the circuit. +simulated_lift_transformer :: Transformer (StateT SimulationState Circ) Qubit Bit +-- Translation of classical gates: +simulated_lift_transformer (T_CNot ncf f) = f $ + \b c -> do + (b,c) <- lift $ without_controls_if ncf $ do + b' <- cnot b `controlled` c + return (b', c) + state <- get + let bits = s_classical_state state + let ctrl = s_classical_controls bits c + let val = bits Map.! b + let bits' = if ctrl then (Map.insert b (not val) bits) else bits + putCS bits' + return (b,c) +simulated_lift_transformer (T_CInit val ncf f) = f $ + do + b <- lift $ without_controls_if ncf $ do + w <- cinit_bit val + return w + state <- get + let bits = s_classical_state state + putCS (Map.insert b val bits) + return b +simulated_lift_transformer (T_CTerm b ncf f) = f $ + \w -> do + lift $ without_controls_if ncf $ do + cterm_bit b w + return () + state <- get + let bits = s_classical_state state + let val = bits Map.! w + if val /= b then error "CTerm: Assertion Incorrect" + else do + putCS (Map.delete w bits) +simulated_lift_transformer (T_CDiscard f) = f $ + \w -> do + lift $ do + cdiscard_bit w + state <- get + let bits = s_classical_state state + putCS (Map.delete w bits) +simulated_lift_transformer (T_DTerm b f) = f $ + \w -> do + lift $ do + dterm_bit b w + state <- get + let bits = s_classical_state state + putCS (Map.delete w bits) +simulated_lift_transformer (T_CGate name ncf f) = f $ + \ws -> do + (v,ws) <- lift $ without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) + state <- get + let bits = s_classical_state state + let list = map (\w -> bits Map.! w) ws + let result = gateC name list + putCS (Map.insert v result bits) + return (v,ws) +simulated_lift_transformer g@(T_CGateInv name ncf f) = f $ + \v ws -> do + ws <- lift $ without_controls_if ncf $ do + cgateinv name v ws + return ws + state <- get + let bits = s_classical_state state + let list = map (\w -> bits Map.! w) ws + let result = bits Map.! v + let result' = gateC name list + if result == result' then return ws else error "CGateInv: Uncomputation error" +-- Translation of quantum gates: +simulated_lift_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] c -> do + (q,c) <- lift $ without_controls_if ncf $ do + q' <- qnot q `controlled` c + return (q', c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q], [], c) +simulated_lift_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] c -> do + (qs,c) <- lift $ without_controls_if ncf $ do + qs' <- qmultinot_list (map (\x -> (x,True)) qs) `controlled` c + return (qs', c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = foldr (\q a -> apply (s_if_controls bits c (performGateQ gate q)) a) amps qs + putQS amps' + return (qs, [], c) +simulated_lift_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] c -> do + (q,c) <- lift $ without_controls_if ncf $ do + q' <- hadamard q `controlled` c + return (q', c) + let gate = gateQ "hadamard" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q], [], c) +simulated_lift_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w, v] [] c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- swap_qubit w v `controlled` c + return (w',v',c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gate v)) amps + let amps'' = apply (s_if_controls bits ((Signed (Endpoint_Qubit v) True):c) (performGateQ gate w)) amps' + let amps''' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gate v)) amps'' + putQS amps''' + return ([w, v], [], c) +simulated_lift_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w, v] [] c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- gate_W w v `controlled` c + return (w',v',c) + let gateX = gateQ "x" + let gateH = gateQ "hadamard" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gateX v)) amps + let amps'' = apply (s_if_controls bits ((Signed (Endpoint_Qubit v) True):c) (performGateQ gateH w)) amps' + let amps''' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gateX v)) amps'' + putQS amps''' + return ([w, v], [], c) +simulated_lift_transformer (T_QGate "trace" _ _ inv ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist "trace" inv ws vs `controlled` c + return (ws', vs', c) +simulated_lift_transformer (T_QGate name _ _ inv ncf f) = f $ + \[q] [] c -> do + ([q],[],c) <- lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv [q] [] `controlled` c + return (ws', vs', c) + let gate = gateQinv name inv + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q],[],c) +simulated_lift_transformer (T_QRot name _ _ inv theta ncf f) = f $ + \[q] [] c -> do + ([q],[],c) <- lift $ without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv theta [q] [] `controlled` c + return (ws', vs', c) + let gate = rotQinv name inv theta + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q],[],c) +simulated_lift_transformer (T_GPhase t ncf f) = f $ + \w c -> do + c <-lift $ without_controls_if ncf $ do + global_phase_anchored_list t w `controlled` c + return c + state <- get + let gate = rotQ "exp(% pi i)" t + let wire = -1 + let q = qubit_of_wire wire + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (vector (Map.insert q False))) amps + let amps'' = apply (s_if_controls bits c (performGateQ gate q)) amps' + let (p,_,ampsf) = split amps'' q + case p of + 0.0 -> do + let ampsf' = apply (vector (Map.delete q)) ampsf' + putQS ampsf' + return c + _ -> error "GPhase" +simulated_lift_transformer (T_QInit val ncf f) = f $ + do + q <- lift $ without_controls_if ncf $ do + w <- qinit_qubit val + return w + state <- get + let amps = s_quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + putQS amps' + return q +simulated_lift_transformer (T_QMeas f) = f $ + \q -> do + b <- lift $ do + b <- measure_qubit q + return b + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let (p,ift,iff) = split amps q + pp <- randomRSimulatedCirc (0,1.0) + let (val,amps') = if p > pp then (True,ift) else (False,iff) + let amps'' = apply (vector (Map.delete q)) amps' + let bits' = Map.insert b val bits + putQS amps'' + putCS bits' + return b +simulated_lift_transformer (T_QDiscard f) = f $ + \q -> do + lift $ do + qdiscard_qubit q + return () + -- a discard is essentially a measurement, with the result thrown away, so we + -- do that here, as it will reduce the size of the quantum state we are + -- simulating over. + state <- get + let (p,ift,iff) = split (s_quantum_state state) q + pp <- randomRSimulatedCirc (0,1.0) + let amps = if p > pp then ift else iff + let amps' = apply (vector (Map.delete q)) amps + putQS amps' + return () +simulated_lift_transformer (T_QTerm b ncf f) = f $ + \q -> do + lift $ without_controls_if ncf $ qterm_qubit b q + -- with a real quantum computer, when we terminate a qubit with an assertion + -- we have no way of actually checking the assertion. The best we can do is + -- measure the qubit and then throw an error if the assertion is incorrect, + -- which may only occur with a small probability. Here, we are able to split + -- the quantum state and see if the qubit exists in the incorrect state with + -- any non-zero probability, and throw an error. + state <- get + let amps = s_quantum_state state + let (p,ampst,ampsf) = split amps q + case (b,p) of + (True,1.0) -> do + let ampst' = apply (vector (Map.delete q)) ampst + putQS ampst' + return () + (False,0.0) -> do + let ampsf' = apply (vector (Map.delete q)) ampsf + putQS ampsf' + return () + (True,pt) -> error ("QTerm: Assertion Incorrect (True only has probability " ++ show pt ++ ")") + (False,pt) -> error ("QTerm: Assertion Incorrect (False only has probability " ++ show (1.0 - pt) ++ ")") +simulated_lift_transformer (T_Comment name inv f) = f $ + \ws -> do + lift $ do + comment_label name inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] + return () +simulated_lift_transformer g@(T_CSwap ncf f) = f $ + \w v c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- swap_bit w v `controlled` c + return (w',v',c) + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_QPrep ncf f) = f $ + \w -> do + w <- lift $ without_controls_if ncf $ do + v <- prepare_qubit w + return v + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_QUnprep ncf f) = f $ + \w -> do + w <- lift $ without_controls_if ncf $ do + v <- unprepare_qubit w + return v + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \ns ws c -> do + (ws,c) <- lift $ without_controls_if ncf $ do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,c) + case Map.lookup n ns of + Just (TypedSubroutine sub_ocirc _ _ _) -> do + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + let in_bindings = bind_list in_wires ws bindings_empty + let sub_bcirc = (sub_circ,ns) + out_bind <- transform_bcircuit_rec simulated_lift_transformer sub_bcirc in_bindings + return (unbind_list out_bind out_wires, c) + Nothing -> error $ "simulated_lift_transformer: subroutine " ++ show n ++ " not found (in " ++ showNames ns ++ ")" + +-- | Dynamic lifting can make use of a simulated result. +simulated_dynamic_lift :: Bit -> SimulatedCirc Bool +simulated_dynamic_lift b = do + state <- get + let bits = s_classical_state state + case Map.lookup b bits of + Just val -> return val + Nothing -> error $ "simulated_dynamic_lift: bit " ++ show b ++ " not found" + +-- | A dynamic transformer which simulates the circuit, whilst +-- reconstructing it with simulated lifting results. +-- Note: do not handle classical controlling. +simulated_dynamic_lift_transformer :: DynamicTransformer (StateT SimulationState Circ) Qubit Bit +simulated_dynamic_lift_transformer = DT { + transformer = simulated_lift_transformer, + define_subroutine = \name subroutine -> do + lift $ do + s <- get_namespace + let s' = map_provide name subroutine s + set_namespace s' + put_subroutine_definition name subroutine, + lifting_function = simulated_dynamic_lift + } + +-- | Print a RandomCirc by evaluating it with a seed in the IO monad. +print_simulated :: Format -> SimulatedCirc b -> IO () +print_simulated format scirc = do + seed <- randomIO + let circ = evalSimulatedCirc seed scirc + print_unary format (\() -> circ) () + +-- | Print a circuit, using simulated liftings. +print_unary_with_simulated_liftings :: (QCData a,QCData b) => Format -> (a -> Circ b) -> BType a -> IO () +print_unary_with_simulated_liftings format circ input = print_simulated format (lifted_circ ()) + where + circ' = \ () -> do + a <- qc_init input + circ a + lifted_circ = transform_unary_dynamic_shape simulated_dynamic_lift_transformer circ' () + + +-- | Pass a (possibly) dynamic circuit through the +-- 'simulated_dynamic_lift_transformer' and evaluate the liftings so as to +-- leave us with a static circuit that represents a single run of the original +-- circuit, with the given inputs. We also need to pass in a seed for the RNG. +simulate_liftings_unary :: (QCData a, QCData b) => Int -> (a -> Circ b) -> BType a -> Circ b +simulate_liftings_unary seed fcirc_in input = out_circ + where + circ_in = \() -> do + a <- qc_init input + fcirc_in a + s_circ = transform_unary_dynamic_shape simulated_dynamic_lift_transformer circ_in () + out_circ = evalSimulatedCirc seed (s_circ ()) + diff --git a/Quipper/Libraries/FPReal.hs b/Quipper/Libraries/FPReal.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/FPReal.hs @@ -0,0 +1,718 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This library provides a quantum implementation of fixed-precision real numbers (i.e., with precision determined at circuit-generation time), and classical counterpart types. +-- +-- Currently still significantly experimental. TODO: +-- +-- * decide on how much access to provide to underlying representation of 'FPReal'. Full 'fpreal_case', or more like just what’s available through Haskell’s 'RealFloat'? +-- +-- * decide how to use 'ErrMsg': in internal functions only, or exported ones too? +-- +-- * many specific TODO’s in code throughout this file. +-- +-- * write export list. + +module Quipper.Libraries.FPReal where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary + +import Control.Monad (foldM) +import Data.Maybe (fromJust) +import Data.Ratio (numerator, denominator) +import Data.Typeable + +-- =========================================== +-- * Fixed-precision real arithmetic: the FPReal family + +-- | 'FPRealX': a family of datatypes for fixed-precision real numbers. +-- (That is, the precision is a parameter, fixed at circuit-generation time.) +-- +-- 'FPRealX' is based on the family 'XInt' of fixed-length integer types: +-- @'FPRealX' /n/ /a/@ represents 2[sup /n/] /a/, where /a/ is some fixed-length integer. +-- +-- Alternately, in the specific case /x/ = 'Bool', a Haskell 'Double' may be +-- used as an 'FPReal', considered as having indeterminate length and exponent. +-- This is exactly analogous to the case of indeterminate length in 'XInt' / 'IntM'; for a more +-- detailed explanation, see the documentation there. +data FPRealX x = FPRealX Int (XInt x) | FPReal_indet Double (Identity IntM (XInt x)) + deriving (Show, Typeable) + +-- | Fixed-precision real parameters. As with 'IntM', the length and/or exponent +-- of an 'FPReal' may be indeterminate; such an 'FPReal' may only be used in +-- certain contexts, typically either when the length/exponent can be inferred from context +-- (e.g., terminating a 'FPRealQ'), or where the result can again be indeterminate. +-- +-- As with indeterminate 'IntM's, indeterminate 'FPReal's may be used for efficient, +-- high-precision classical calculation, and then explicitly or implicitly coerced +-- to determinate 'FPReal's when required for interfacing with quantum computation. +type FPReal = FPRealX Bool + +instance Show FPReal where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet r id) = show r + +-- | Fixed-precision reals for quantum circuits. +type FPRealQ = FPRealX Qubit + +instance Show FPRealQ where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet _ _) = error "FPRealX: internal error" + +-- | Fixed-precision reals for classical circuits. +type FPRealC = FPRealX Bit + +{- -- for when Qubit /= Bit: +instance Show FPRealC where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet _ _) = error "FPRealX: internal error" +-} + +-- ---------------------------------------------------------------------- +-- ** Primitive combinators on FPReal + +-- $ Like 'XInt', the type 'FPReal' is intended to be an abstract data type, +-- and all access to it should pass through the functions of this +-- section. + +-- *** Constructors + +-- | Create an 'FPRealX' from an 'XInt' together with an exponent. +fprealx :: Int -> XInt x -> FPRealX x +fprealx n x = FPRealX n x + +-- | Create an indeterminate 'FPReal' from a 'Double'. +fpreal_of_double :: Double -> FPReal +fpreal_of_double r = FPReal_indet r reflexivity + +-- *** Destructor + +-- | If the 'FPRealX' is of determinate exponent, return its exponent and mantissa. +-- +-- If the 'FPRealX' is indeterminate, return a pair (/r/, /id/), where /r/ is the underlying 'Double', and /id/ is a witness of the fact that /x/ = 'Bool'. +-- +-- This is a lowest-level access function not intended to be used by +-- user-level code, and is not exported. +fprealx_case :: FPRealX x -> Either (Int, XInt x) (Double, Identity IntM (XInt x)) +fprealx_case (FPRealX n x) = Left (n,x) +fprealx_case (FPReal_indet r id) = Right (r, id) + +-- ---------------------------------------------------------------------- +-- ** Other low-level operations + +-- $ The operations in this section are the only ones intended to use +-- 'fprealx_case' directly. + +-- TODO: fprealx_expt, fprealx_num should probably take ErrMsg arguments, at least for internal use --- I guess only the versions specialized to FPRealQ, FPRealC should be written as though unconditional? Perhaps only these, plus the 'Maybe' version specialized to 'FPReal', should be exported? + +-- | Extract the exponent of an 'FPRealX', assumed to be determinate. +-- +-- When /x/ is not 'Bool', this and 'fprealx_num' should be considered the destructors of 'FPRealX x'. +fprealx_expt :: FPRealX x -> Int +fprealx_expt x = + case fprealx_case x of + Left (n, _) -> n + Right _ -> error "fprealx_expt: indeterminate exponent" + +-- | Extract the mantissa of an 'FPRealX', assumed to be of determinate exponent. +-- +-- When /x/ is not 'Bool', this and 'fprealx_num' should be considered the destructors of 'FPRealX x'. +fprealx_num :: FPRealX x -> XInt x +fprealx_num x = + case fprealx_case x of + Left (_, xi) -> xi + Right _ -> error "fprealx_num: indeterminate exponent" + +-- | Extract the length (in bits) of an 'FPRealX', assumed to be of determinate exponent and length. +fprealx_length :: FPRealX x -> Int +fprealx_length x = + case fprealx_case x of + Left (_, xi) -> fromJust $ xint_maybe_length xi + Right _ -> error "fprealx_length: indeterminate exponent" + +-- | Set the exponent of an 'FPReal' to /n/. This operation is only +-- legal if the input (a) has indeterminate exponent or (b) has +-- determinate exponent already equal to /m/. In particular, it cannot +-- be used to change the exponent from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate exponents, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. + +-- Implementation note: the “intm_of_integer” may seem unnecessary, +-- but needed so that when /r/ is “undefined”, the result is +-- “intm_of_integer undefined” not just “undefined”. +fprealx_set_expt :: Int -> FPRealX x -> String -> FPRealX x +fprealx_set_expt n xr errstr = case fprealx_case xr of + Left (n', xi) -> if n' == n then fprealx n xi else error errstr + Right (r, id) -> fprealx n (identity id $ intm_of_integer $ round $ + if n >= 0 then (r / 2^n) else (r * 2^(-n))) + +-- | Return the (possibly indeterminate) exponent of an 'FPRealX'. +fprealx_maybe_expt :: FPRealX x -> Maybe (Int) +fprealx_maybe_expt xr = case fprealx_case xr of + Left (n, _) -> Just n + Right _ -> Nothing + +-- | Given an 'FPReal', return either the exponent and numerator, or else the double it wraps. +-- +-- A specialized and implementation-hiding wrapper for 'fprealx_case'. + +-- TODO: should this be exported? +fpreal_case :: FPReal -> Either (Int, IntM) (Double) +fpreal_case (FPRealX n x) = Left (n, x) +fpreal_case (FPReal_indet r _) = Right r + +-- | Equality test. If both have indeterminate exponent, check equality of underlying 'Double's. +-- Otherwise, if exponents are compatible (i.e. both determinate and equal, or one indeterminate), +-- check equality of numerators. If exponents are incompatible, throw an error (the test +-- should in this case be considered ill-typed). +fprealx_equals :: (Eq x) => FPRealX x -> FPRealX x -> Bool +fprealx_equals x y = + case (fprealx_case x, fprealx_case y) of + (Left (n,xi), Left (n',yi)) + | n == n' -> xi == yi + | otherwise -> error "Equality test on FPRealx: operands must be of equal exponent" + (_, Left (m,yi)) -> fprealx_equals (fprealx_set_expt m x "fprealx_equals") y + (Left (n,xi), _) -> fprealx_equals x (fprealx_set_expt n y "fprealx_equals") + (Right (r, _), Right (r', _)) -> r == r' + +-- ---------------------------------------------------------------------- +-- ** Shape parameters + +-- | Return a piece of shape data to represent an /l/-qubit quantum +-- real with exponent /n/. +-- Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +fprealq_shape :: Int -> Int -> FPRealQ +fprealq_shape n l = fprealx n $ qdint_shape l + +-- | Return a piece of shape data to represent an /l/-bit 'FPRealC', +-- with exponent /n/. +-- Please note that the data can only be used as shape; it will be +-- undefined at the leaves. +fprealc_shape :: Int -> Int -> FPRealC +fprealc_shape n l = fprealx n $ cint_shape l + +-- ====================================================================== +-- ** Circuit type class instances + +-- Note: instance declarations do not show up in the documentation + +-- | Try to set the exponent/length of an 'FPReal' to that of another 'FPRealX' +-- value (e.g. an 'FPRealQ', an 'FPRealC', or another 'FPReal'). +-- This will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. +-- +-- The possible “shapes” of 'FPReal's may be seen as a partial order, where +-- /s1/ ≤ /s2/ means that values of shape /s1/ are coercible to values of shape +-- /s2/. 'fpreal_promote' may be seen as taking the binary /sup/ in this poset. +fpreal_promote :: FPReal -> FPRealX x -> ErrMsg -> FPReal +fpreal_promote br xr errmsg = + case fprealx_maybe_expt xr of + Nothing -> br + Just n -> + let br' = fprealx_set_expt n br (errmsg "FPReal: exponent mismatch") + in fprealx n $ intm_promote (fprealx_num br') (fprealx_num xr) (errmsg "FPReal: length mismatch") + +type instance QCType x y (FPRealX z) = FPRealX (QCType x y z) +type instance QTypeB FPReal = FPRealQ + +instance QCLeaf x => QCData (FPRealX x) where + qcdata_mapM shape f g xr + = mmap (fprealx (fprealx_expt xr)) $ qcdata_mapM (fprealx_num shape) f g (fprealx_num xr) + qcdata_zip shape q c q' c' xr yr e + | fprealx_expt xr == fprealx_expt yr + = fprealx (fprealx_expt xr) + $ qcdata_zip (fprealx_num shape) q c q' c' (fprealx_num xr) (fprealx_num yr) (const $ e "FPRealX: length mismatch") + | otherwise + = error (e "FPRealX: exponent mismatch") + qcdata_promote = fpreal_promote + +-- Labeling of FPRealX is s[hi-1], ..., s[lo], where lo is the exponent. +instance QCLeaf x => Labelable (FPRealX x) String where + label_rec xr s = do + let n = fprealx_expt xr + xi = fprealx_num xr + qx = list_of_xint_lh xi + sequence_ [ label_rec q s `indexed` show i | (q,i) <- zip qx [n..] ] + +-- ====================================================================== +-- * Classical arithmetic on FPReal + +-- | Convert an 'FPReal' to a 'Double'. +double_of_fpreal :: FPReal -> Double +double_of_fpreal xr = case fpreal_case xr of + Left (n, xi) -> if n >= 0 then (fromIntegral xi) * (2^n) + else (fromIntegral xi) / (2^(abs n)) + Right r -> r + +-- | From a list of 'FPReal's, extract a common shape, provided they have compatible shape +-- (i.e. if any have determinate exponent, they must agree; similarly for length), +-- and throw an error otherwise. +-- +-- Can be seen as producing finitary suprema in the partial order of shapes. +-- +-- The 'FPReal' produced should be considered just a shape; its value is a dummy that +-- should never be used (and will throw an error if it is). +fpreal_common_shape :: [FPReal] -> ErrMsg -> FPReal +fpreal_common_shape xs e = foldl (\x y -> fpreal_promote x y e) + (fpreal_of_double (error $ e "fpreal_common_shape: dummy value produced here was later accessed")) + xs + +-- | Auxiliary function for lifting a binary operator from 'Double' +-- to 'IntM'. The string argument is the name of the operator, for +-- error messages. +fpreal_binop :: (Double -> Double -> Double) -> String -> (FPReal -> FPReal -> FPReal) +fpreal_binop op opname x y = + fpreal_promote + (fpreal_of_double $ op (double_of_fpreal x) (double_of_fpreal y)) + (fpreal_common_shape [x,y] errmsg) + (const "FPReal: internal error (fpreal_binop)") + where errmsg = (\s -> "Binary operation " ++ opname ++ " on FPReal: " ++ s) + +-- | Auxiliary function for lifting a unary operator from 'Double' to +-- 'FPReal'. +fpreal_unop :: (Double -> Double) -> FPReal -> FPReal +fpreal_unop op x = fpreal_promote (fpreal_of_double $ op $ double_of_fpreal x) x + (const "FPReal: internal error (fpreal_unop)") + +------ +-- Classical typeclass instances +------ + +instance Eq x => Eq (FPRealX x) where + (==) = fprealx_equals + +instance Num FPReal where + (+) = fpreal_binop (+) "+" + (*) = fpreal_binop (*) "*" + (-) = fpreal_binop (-) "-" + abs = fpreal_unop abs + signum = fpreal_unop signum + -- Note: signum on determinate exponent/length FPReals has slightly + -- surprising behavior if /n/ ≤ –/l/: this will give + -- 0, since then 1 = –1 = 0 mod 2^{l + n}. In other words, the + -- output 1.0 or -1.0 is not representable in this fixed-precision format. + fromInteger = fpreal_of_double . fromInteger + +instance Ord FPReal where + compare x y = compare (double_of_fpreal x) (double_of_fpreal y) +-- TODO: is this the right thing to do? Perhaps we should first check they have +-- compatible shapes, and throw an error otherwise. + +instance Enum FPReal where + succ = fpreal_unop succ + pred = fpreal_unop pred + toEnum = fromIntegral + fromEnum = fromEnum . double_of_fpreal + +instance Real FPReal where + toRational = toRational . double_of_fpreal + +instance Fractional FPReal where + fromRational = fpreal_of_double . fromRational + recip = fpreal_unop recip + +{- TODO: something along these lines would probably still be good to give. Work on thinking of good interface. Or maybe not really necessary?? + +-- | Convert from any 'RealFrac' type (eg 'Rational', 'Float') to 'FPReal', with specified precision and (possibly indeterminate) length. +fpreal_from_realfrac_with_precision :: (RealFrac a) => Int -> Maybe Int -> a -> FPReal +fpreal_from_realfrac_with_precision n l r = case l of + Just l -> FPRealX n $ intm l (round $ r * (2^n)) + Nothing -> FPRealX n $ fromIntegral (round $ r * (2^n)) +-} + +instance Floating FPReal where + pi = fpreal_of_double pi + log = fpreal_unop log + exp = fpreal_unop exp + sin = fpreal_unop sin + cos = fpreal_unop cos + sinh = fpreal_unop sinh + cosh = fpreal_unop cosh + asin = fpreal_unop asin + acos = fpreal_unop acos + atan = fpreal_unop atan + asinh = fpreal_unop asinh + acosh = fpreal_unop acosh + atanh = fpreal_unop atanh + +instance RealFrac FPReal where + properFraction x = + let (x_int, x_frac_double) = properFraction $ double_of_fpreal x in + (x_int, fpreal_promote (fpreal_of_double x_frac_double) x (const "FPReal: internal error (properFraction)")) + ceiling = ceiling . double_of_fpreal + +{- TODO: would definitely be good to give. +instance RealFloat FPReal +-} + +-- ** Shape/precision control + +-- | Extend the length of a determinate length and precision 'FPReal' by /m/ high and /n/ low bits, without changing its value. +fpreal_pad :: Int -> Int -> FPReal -> FPReal +fpreal_pad m n x = + case fprealx_maybe_expt x of + Nothing -> error e_expt + Just x_expt -> + let x_num = fprealx_num x + in case intm_length x_num of + Nothing -> error e_length + Just x_length -> + fprealx (x_expt - n) (2^n * intm_extend_signed (x_length + m + n) x_num) + where + e_expt = "fpreal_pad: input of indeterminate exponent" + e_length = "fpreal_pad: input of indeterminate length" + +-- | Discard the top /m/ and bottom /n/ bits of a determinate length and precision 'FPReal'. +fpreal_unpad :: Int -> Int -> FPReal -> FPReal +fpreal_unpad m n x = + let x_bits = boollist_of_intm_bh $ fprealx_num x + x_expt = fprealx_expt x + x_bits_new = reverse $ drop n $ reverse $ drop m x_bits + in fprealx (x_expt + n) (intm_of_boollist_bh x_bits_new) + +-- | Fix the length of an 'IntM' (to automatically-generated values), if not already determinate. +-- +-- TODO: belongs in 'Quipper.Libraries.Arith' +intm_fix_length_auto :: IntM -> IntM +intm_fix_length_auto x = case intm_length x of + Just _ -> x + Nothing -> + let l = (1 +) $ ceiling $ logBase 2 $ fromIntegral $ abs x + (if x >= 0 then 1 else 0) + in intm l (fromIntegral x) + +-- | Fix the precision and length of an 'FPReal' (to automatically-generated values), +-- leaving unchanged any parts of the shape that are already set. +-- +-- TODO: discuss \/ reconsider \/ improve implementation of this. + +-- Implementation note: aim to use as few bits as possible, while retaining accuracy. +-- +-- Not clear what should be done in case denominator not a power of 2. However, +-- Haskell’s 'Double' has radix 2, so ordinarily denominator always should be a power of 2. +-- +-- However, this does give pretty high-precision by default! Is that good? Seems expensive in qubits. +fpreal_fix_shape_auto :: FPReal -> FPReal +fpreal_fix_shape_auto x = case fpreal_case x of + Left (e, n) -> fprealx e (intm_fix_length_auto n) + Right x -> + let r = toRational x + d = denominator r + in if d == 2^(round $ logBase 2 $ fromIntegral d) + then fprealx + (negate $ round $ logBase 2 $ fromIntegral d) + (intm_fix_length_auto $ fromIntegral $ numerator r) + else error "fpreal_fix_shape_auto: not yet fully implemented" + +-- ====================================================================== +-- * Quantum operations: FPRealQ + +-- ** Shape/precision control + +-- | Extend the length of an 'FPRealQ' by /m/ high bits and /n/ low bits, without changing its value. +fprealq_pad :: Int -> Int -> FPRealQ -> Circ FPRealQ +fprealq_pad m n x = do + let x_bits = qulist_of_qdint_bh $ fprealx_num x + x_expt = fprealx_expt x + new_high_bits <- qinit $ replicate m False + new_high_bits <- case x_bits of + [] -> return new_high_bits + (x_high:_) -> mapUnary qnot new_high_bits `controlled` x_high + new_low_bits <- qinit $ replicate n False + return $ fprealx (x_expt - n) $ qdint_of_qulist_bh $ new_high_bits ++ x_bits ++ new_low_bits + +-- | Cut off the top /m/ and bottom /n/ bits of an 'FPRealQ', retaining them as explicit garbage. +fprealq_unpad :: Int -> Int -> FPRealQ -> Circ (FPRealQ, [Qubit]) +fprealq_unpad m n x = + let x_bits = qulist_of_qdint_bh $ fprealx_num x + x_expt = fprealx_expt x + x_bits_new = reverse $ drop n $ reverse $ drop m x_bits + garbage = (take m x_bits) ++ (take n $ reverse x_bits) + in return (fprealx (x_expt + n) (qdint_of_qulist_bh x_bits_new), garbage) + +-- | Formally shift an 'FPRealQ' up /n/ bits, i.e. add /n/ to its exponent. +fprealq_shift :: Int -> FPRealQ -> FPRealQ +fprealq_shift n x = + let num = fprealx_num x + expt = fprealx_expt x + in fprealx (expt + n) num + +-- ** Quantum arithmetic + +-- $ Besides the functions appearing here in the documentation, basic operations ('q_add', etc) are also provided as methods of the 'QNum' type class instance; see 'QNum' for documentation of these functions. + +------ +-- Quantum typeclass instances +------ + +instance QNum FPRealQ where + q_add x y = + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + (nx,ny,ns) <- q_add nx ny + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex ns)) + else error "q_add // FPReal: exponent mismatch in arguments." + q_mult x y = -- TODO: to implement + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + np <- qinit $ qc_false $ nx + (nx,ny,np) <- named_gate "q_mult // FPReal" (nx,ny,np) + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex np)) + else error "q_mult // FPReal: length mismatch in arguments." + q_sub x y = + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + (nx,ny,nd) <- q_sub nx ny + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex nd)) + else error "q_sub // FPReal: length mismatch in arguments." + q_abs x = + let ex = fprealx_expt x + nx = fprealx_num x + in do + (nx,nx') <- q_abs nx + return ((fprealx ex nx), (fprealx ex nx')) + q_negate x = + let ex = fprealx_expt x + nx = fprealx_num x + in do + (nx,nx') <- q_negate nx + return ((fprealx ex nx), (fprealx ex nx')) + q_signum = error "FPReal // q_signum: not yet implemented." -- TODO! + q_fromQDInt x = do + (x,x') <- qc_copy_fun x + return (x,(fprealx 0 x')) + +instance QOrd FPRealQ where + q_less x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + x_less_y <- q_less nx ny + return x_less_y + else error "q_less // FPReal: length mismatch in arguments." + q_leq x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + x_leq_y <- q_leq nx ny + return x_leq_y + else error "q_leq // FPReal: length mismatch in arguments." + +-- | Analogue of 'q_add_in_place', for 'FPRealQ'. +fprealq_add_in_place :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_add_in_place x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + (x,y) <- q_add_in_place nx ny + return ((fprealx ex nx), (fprealx ey ny)) + else error "q_add_in_place_fprealq // FPReal: length mismatch in arguments." + +-- | Analogue of 'q_sub_in_place', for 'FPRealQ'. +fprealq_sub_in_place :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_sub_in_place x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + (x,y) <- q_sub_in_place nx ny + return ((fprealx ex nx), (fprealx ey ny)) + else error "q_sub_in_place_fprealq // FPReal: length mismatch in arguments." + +-- | Subtract a parameter 'FPReal' from an 'FPRealQ', in place. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_sub_param_in_place :: FPReal -> FPRealQ -> Circ FPRealQ +fprealq_sub_param_in_place x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy) <- fprealq_sub_in_place qx qy + return qy) + where + e_prec = "fprealq_sub_param_in_place: incompatible precision" + +-- | Add a parameter 'FPReal' to an 'FPRealQ', in place. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_add_param_in_place :: FPReal -> FPRealQ -> Circ FPRealQ +fprealq_add_param_in_place x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy) <- fprealq_add_in_place qx qy + return qy) + where + e_prec = "fprealq_sub_param_in_place: incompatible precision" + +-- | Multiply an 'FPRealQ' by a parameter 'FPReal'. The parameter may have any shape. +fprealq_mult_param_het :: FPReal -> FPRealQ -> Circ (FPRealQ, FPRealQ) +fprealq_mult_param_het x_in qy = do + let x = fpreal_fix_shape_auto x_in + e = fprealx_expt x + l = fromJust $ intm_length $ fprealx_num x + x_bits = boollist_of_intm_bh $ fprealx_num x + qy_expt = fprealx_expt qy + qy_num = fprealx_num qy + qy_length = qdint_length qy_num + prod_bits = [ (is_neg, i) | (x_i, i) <- zip x_bits [e+l-1,e+l-2..e] + , x_i == True + , let is_neg = i == e+l-1 ] + qprod <- if null prod_bits + then qinit $ fpreal_promote 0 qy ("internal error: fprealq_mult_param_het promotion: " ++) + else with_computed (do + let i_max = snd $ head prod_bits + i_min = snd $ last prod_bits + -- Initialise an accumulating product at 0, with as many bits as may be needed in intermediate calculation: + qprod_accum <- qinit $ fprealx (qy_expt + i_min) $ intm (1 + qy_length + i_max - i_min) 0 + -- Add the appropriate shifts of qy to it: + qprod_accum <- foldM + (\qprod_accum (is_neg, i) -> do + qy_i <- qc_copy $ fprealq_shift i qy + qy_i <- fprealq_pad (1 + i_max - i) (i - i_min) qy_i + (qy_i, qprod_accum) <- if is_neg + then fprealq_sub_in_place qy_i qprod_accum + else fprealq_add_in_place qy_i qprod_accum + return qprod_accum) + qprod_accum + prod_bits + -- Now shift/truncate the product to match the input length/precision: + qprod_large <- fprealq_pad (max (-i_max) 0) (max i_min 0) qprod_accum + (qprod, garbage) <- fprealq_unpad (1 + max i_max 0) (max (-i_min) 0) qprod_large + return qprod) + -- Copy it for output, before erasing garbage: + qc_copy + return (qy, qprod) + +-- | Compare an 'FPRealQ' to a parameter 'FPReal'. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_ge_param :: FPReal -> FPRealQ -> Circ (FPRealQ, Qubit) +fprealq_ge_param x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy, test) <- q_ge qx qy + return (qy, test)) + where + e_prec = "fprealq_ge_param: incompatible precision" + +-- | 'fprealq_add_het' /p/ /l/ /qx/ /qy/: add two 'FPRealQ's, of potentially different precisions and lengths, into a fresh one with precision /p/ and length /l/. +-- +-- TODO: not yet implemented; currently just black box. +fprealq_add_het :: Int -> Int -> FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ,FPRealQ) +fprealq_add_het p l qx qy = do + qz <- qinit (fprealx p (intm l 0)) + (qx,qy,qz) <- named_gate "fprealq_add_het" (qx,qy,qz) + return (qx,qy,qz) + +-- | @'fprealq_logBase_internal' /errmsg/ /b/ /h/ /p/ /qx/'@: compute log[sub /b/](/qx/), returning /l/ binary digits before the point and /p/ after. The underlying implementation of the rest of the 'fprealq_log' family. +-- +-- Behavior on non-positive /qx/: currently unspecified. TODO: decide and fix this. Make assertion/post-selection on positivity? Or treat as unsigned? +-- +-- Time-complexity (estimated): /O/((log /l/[sup /qx/] + log log /b/)(/l/[sup /qx/] + (/h/+/p/)[sup 2])). +fprealq_logBase_internal :: (Floating a, RealFrac a) => ErrMsg -> a -> Int -> Int -> FPRealQ -> Circ (FPRealQ, FPRealQ) +fprealq_logBase_internal e b h_out p_out x = + if h_out + p_out < 0 + then error $ e "negative length specified." + else if b <= 0 + then error $ e "base of logarithm must be > 0" + else do + y <- with_computed + (do + -- Shift x into the interval [0,1], and pad it for intermediate calculation: + let l_in = qdint_length $ fprealx_num x + e_in = fprealx_expt x + l_in_pad = 1 + l_in `div` 2 + p_in_pad = p_out - (floor $ logBase 2 $ log b) + 1 + x_0 <- fprealq_pad l_in_pad p_in_pad $ fprealx (1 - l_in) $ fprealx_num x + -- Bound the length and precision needed for computing log_2 x' to precision p_out: + let y_size_bound = 1 + (ceiling $ logBase 2 $ fromIntegral $ l_in - 1) + y_h_pad = max 0 (y_size_bound - h_out) + y_p_pad = 2 + (ceiling $ logBase 2 $ fromIntegral $ l_in_pad + p_in_pad - 1) + y_0 <- qinit $ fprealx (- p_out - y_p_pad) $ intm (y_h_pad + h_out + p_out + y_p_pad) 0 + -- Iteratively compute log x_0, starting with (x0,y0): + let ks_big = 2^(l_in `div` 2) + : (reverse $ [ 2^(2^i) | i <- [0..(ceiling $ logBase 2 $ (fromIntegral l_in) / 2) - 1] ]) + ks_small = [ (2^i + 1)/(2^i) | i <- [1..p_out - (floor $ logBase 2 $ log b) + 1]] + -- bound in ks_small chosen to ensure logBase b k_fin < 2^(-p_out) + (x_fin,y_fin) <- foldM + (\(xi,yi) ki -> do + (xi, xi_ki) <- fprealq_mult_param_het ki xi + (xi_ki, test1) <- fprealq_ge_param 1 xi_ki + (xi_ki, xi, test2) <- q_gt xi_ki xi + (xi1, yi1) <- qc_copy (xi,yi) + (xi1,xi) <- controlled_not xi1 xi `controlled` test1 .&&. test2 + (xi1,xi_ki) <- controlled_not xi1 xi_ki `controlled` test1 .&&. test2 + yi1 <- fprealq_sub_param_in_place (logBase (realToFrac b) ki) yi1 `controlled` test1 .&&. test2 + return (xi1, yi1)) + (x_0,y_0) + (ks_big ++ ks_small) + -- Correct for the shift between x and x_, then unpad y to the output precision: + y_fin <- fprealq_add_param_in_place ((log 2 / log (realToFrac b)) * (fromIntegral $ l_in + e_in - 1)) y_fin + (y_fin, garbage) <- fprealq_unpad y_h_pad y_p_pad y_fin + return y_fin) + qc_copy + return (x,y) + +-- | Compute the natural log of an 'FPRealQ', with length and precision as in the input. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_log :: FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_log x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_log: " ++ ) (exp 1) h l x + +-- | Compute the log (to arbitrary base) of an 'FPRealQ', with length and precision as in the input. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_logBase :: (Floating a, RealFrac a) => a -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_logBase b x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_logBase: " ++ ) b h l x + +-- | @'fprealq_log_with_shape' /x/ /y/@: compute the natural log /y/, with length and precision of /x/. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_log_with_shape :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_log_with_shape x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_log_with_shape: " ++ ) (exp 1) h l + +-- | @'fprealq_log_with_shape' /b/ /x/ /y/@: compute log[sup /b/] /y/, with length and precision of /x/. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_logBase_with_shape :: (Floating a, RealFrac a) + => a -> FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_logBase_with_shape b x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_logBase_with_shape: " ++ ) b h l diff --git a/Quipper/Libraries/GateDecompositions.hs b/Quipper/Libraries/GateDecompositions.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/GateDecompositions.hs @@ -0,0 +1,645 @@ +-- | This library contains special decompositions of particular gates +-- into particular gate bases. It also contains functions for +-- decomposing multiple controls. +-- +-- For example, we provide particular decompositions of the Toffoli, +-- Fredkin, doubly-controlled /iX/-gate, and certain other controlled +-- Clifford gates, into the Clifford+/T/ base. In some cases, we +-- provide more than one decomposition. +-- +-- Many of these decompositions are taken or adapted from the +-- literature, for example, from: +-- +-- * M. A. Nielsen and I. L. Chuang, +-- /Quantum Computation and Quantum Information/, +-- Cambridge University Press, 2002. +-- +-- * M. Amy, D. Maslov, M. Mosca, and M. Roetteler, +-- A meet-in-the-middle algorithm for fast synthesis +-- of depth-optimal quantum circuits, +-- /IEEE Transactions on Computer-Aided Design of/ +-- /Integrated Circuits and Systems/ 32(6):818-830. +-- Also available from . +-- +-- * A. Barenco, C. H. Bennett, R. Cleve, D. P. DiVincenzo, +-- N. Margolus, P. Shor, T. Sleator, J. A. Smolin, and H. Weinfurter, +-- Elementary gates for quantum computation, +-- /Physical Review A/ 52(5):3457-3467, 1995. +-- Also available from . +-- +-- * P. Selinger, Quantum circuits of T-depth one, +-- /Physical Review A/ 87, 042302 (4 pages), 2013. +-- Also available from . +-- +-- * B. Giles and P. Selinger, Exact synthesis of multiqubit +-- Clifford+T circuits, /Physical Review A/ 87, 032332 (7 pages), +-- 2013. Also available from . + +module Quipper.Libraries.GateDecompositions where + +import Quipper + +import Control.Monad + +-- ---------------------------------------------------------------------- +-- * Decomposition of gates + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- from Nielsen and Chuang (Figure 4.9). The first argument is the +-- target, and the other two are the controls. The controls can be +-- positive or negative. +-- +-- \[image toffoli_NC.png] +toffoli_NC_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_NC_at q c1 c2 = do + comment_with_label "ENTER: toffoli_NC" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + hadamard_at q + qnot_at q `controlled` w1 + reverse_imp_if (not x) gate_T_inv_at q + qnot_at q `controlled` w2 + reverse_imp_if (x `xor` y) gate_T_at q + qnot_at q `controlled` w1 + reverse_imp_if (not y) gate_T_inv_at q + qnot_at q `controlled` w2 + gate_T_at q + reverse_imp_if (not x) gate_T_inv_at w1 + hadamard_at q + qnot_at w1 `controlled` w2 + reverse_imp_if (x `xor` y) gate_T_inv_at w1 + qnot_at w1 `controlled` w2 + reverse_imp_if (not x) gate_S_at w1 + reverse_imp_if (not y) gate_T_at w2 + comment_with_label "EXIT: toffoli_NC" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- from Amy et al. (, Figure +-- 13). The first argument is the target, and the other two are the +-- controls. The controls can be positive or negative. +-- +-- \[image toffoli_AMMR.png] +toffoli_AMMR_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_AMMR_at q c1 c2 = do + comment_with_label "ENTER: toffoli_AMMR" (q,c1,c2) ("q","c1","c2") + without_comments $ do + hadamard_at q + ccZ_AMMR_at q c1 c2 + hadamard_at q + comment_with_label "EXIT: toffoli_AMMR" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the Toffoli gate using controlled Clifford +-- operators, from Nielsen and Chuang (Figure 4.8). The controls can be +-- positive or negative. +-- +-- \[image toffoli_V.png] +toffoli_V_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_V_at q c1 c2 = do + comment_with_label "ENTER: toffoli_V" (q,c1,c2) ("q","c1","c2") + let q1 = from_signed c1 + let q2 = from_signed c2 + gate_V_at q `controlled` c1 + qnot_at q1 `controlled` c2 + gate_V_inv_at q `controlled` c1 + qnot_at q1 `controlled` c2 + gate_V_at q `controlled` c2 + comment_with_label "EXIT: toffoli_V" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- using /T/-depth 1 and four ancillas. From +-- (Figure 1). The first argument is +-- the target, and the other two are the controls. The controls can be +-- positive or negative. +-- +-- \[image toffoli_S.png] +toffoli_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_S_at q c1 c2 = do + comment_with_label "ENTER: toffoli_S" (q,c1,c2) ("q","c1","c2") + without_comments $ do + hadamard_at q + ccZ_S_at q c1 c2 + hadamard_at q + comment_with_label "EXIT: toffoli_S" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-count 4 and /T/-depth 2. Adapted from +-- (, Figure 10). The first argument +-- is the target, and the other two are the controls. The controls can +-- be positive or negative. +-- +-- \[image cc_iX.png] +cc_iX_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_at q c1 c2 = do + comment_with_label "ENTER: cc_iX" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + hadamard_at q + qnot_at w1 `controlled` q + qnot_at w2 `controlled` w1 + reverse_imp_if (not x) gate_T_at w1 + reverse_imp_if (x `xor` y) gate_T_inv_at w2 + qnot_at w1 `controlled` q + qnot_at w2 `controlled` w1 + gate_T_inv_at q + reverse_imp_if (not y) gate_T_at w2 + qnot_at w2 `controlled` q + hadamard_at q + when (not x && not y) $ do -- need a phase correction + gate_omega_at w1 + gate_omega_at w2 + comment_with_label "EXIT: cc_iX" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-count 4, and using the control qubits +-- only as controls. Derived from Nielsen and Chuang (Figure 4.9). The +-- controls can be positive or negative. +-- +-- \[image cc_iX_simple.png] +cc_iX_simple_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_simple_at q c1 c2 = do + comment_with_label "ENTER: cc_iX_simple" (q,c1,c2) ("q","c1","c2") + hadamard_at q + qnot_at q `controlled` c1 + gate_T_at q + qnot_at q `controlled` c2 + gate_T_inv_at q + qnot_at q `controlled` c1 + gate_T_at q + qnot_at q `controlled` c2 + gate_T_inv_at q + hadamard_at q + comment_with_label "EXIT: cc_iX_simple" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-depth 1 and one ancilla. Adapted from +-- (, Figure 9). The first argument +-- is the target, and the other two are the controls. The controls can +-- be positive or negative. +-- +-- \[image cc_iX_S.png] +cc_iX_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_S_at q c1 c2 = do + comment_with_label "ENTER: cc_iX_S" (q,c1,c2) ("q","c1","c2") + let sx = get_sign c1 + sy = get_sign c2 + x = from_signed c1 + y = from_signed c2 + z = q + hadamard_at z + with_ancilla $ \w -> do + qnot y `controlled` z + qnot w `controlled` x + qnot x `controlled` z + qnot w `controlled` y + reverse_imp_if (not sx) gate_T_at x + reverse_imp_if (not sy) gate_T_at y + gate_T_inv_at z + reverse_imp_if (sx `xor` sy) gate_T_inv_at w + qnot w `controlled` y + qnot x `controlled` z + qnot w `controlled` x + qnot y `controlled` z + when (not sx && not sy) $ do -- need a phase correction + gate_omega_at x + gate_omega_at y + hadamard_at z + comment_with_label "EXIT: cc_iX_S" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /Z/-gate into the +-- Clifford+/T/ base. Adapted from Amy et +-- al. (, Figure 13). The controls can +-- be positive or negative. +-- +-- \[image ccZ_AMMR.png] +ccZ_AMMR_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +ccZ_AMMR_at q c1 c2 = do + comment_with_label "ENTER: ccZ_AMMR" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + gate_T_at q + reverse_imp_if (not x) gate_T_at w1 + reverse_imp_if (not y) gate_T_at w2 + qnot_at w2 `controlled` w1 + qnot_at w1 `controlled` q + qnot_at q `controlled` w2 + reverse_imp_if (not x) gate_T_inv_at w1 + reverse_imp_if (x `xor` y) gate_T_at q + qnot_at w1 `controlled` w2 + reverse_imp_if (not y) gate_T_inv_at w1 + reverse_imp_if (x `xor` y) gate_T_inv_at w2 + qnot_at w1 `controlled` q + qnot_at q `controlled` w2 + qnot_at w2 `controlled` w1 + comment_with_label "EXIT: ccZ_AMMR" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /Z/-gate into the +-- Clifford+/T/ base, using /T/-depth 1 and four ancillas. From +-- Selinger (, Figure 1). The controls +-- can be positive or negative. +-- +-- \[image ccZ_S.png] +ccZ_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +ccZ_S_at q c1 c2 = do + comment_with_label "ENTER: ccZ_S" (q,c1,c2) ("q","c1","c2") + let sx = get_sign c1 + sy = get_sign c2 + x = from_signed c1 + y = from_signed c2 + z = q + with_ancilla_init (0,0,0,0) $ \(xyz, xy, yz, xz) -> do + qnot yz `controlled` y + qnot xyz `controlled` x + qnot xy `controlled` y + qnot yz `controlled` z + qnot xz `controlled` xyz + qnot xy `controlled` x + qnot xz `controlled` z + qnot xyz `controlled` yz + reverse_imp_if (not sx) gate_T_at x + reverse_imp_if (not sy) gate_T_at y + gate_T_at z + reverse_imp_if (sx `xor` sy) gate_T_at xyz + reverse_imp_if (sx `xor` sy) gate_T_inv_at xy + reverse_imp_if (not sy) gate_T_inv_at yz + reverse_imp_if (not sx) gate_T_inv_at xz + qnot xyz `controlled` yz + qnot xz `controlled` z + qnot xy `controlled` x + qnot xz `controlled` xyz + qnot yz `controlled` z + qnot xy `controlled` y + qnot xyz `controlled` x + qnot yz `controlled` y + comment_with_label "EXIT: ccZ_S" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the Fredkin (controlled-Swap) gate into the +-- Clifford+/T/ base. The first two arguments are the targets, and the +-- last one the control. The controls can be positive or negative. +-- +-- \[image fredkin.png] +fredkin_at :: Qubit -> Qubit -> Signed Qubit -> Circ () +fredkin_at q1 q2 c = do + comment_with_label "ENTER: fredkin" (q1,q2,c) ("q1","q2","c") + without_controls $ do + qnot_at q2 `controlled` q1 + toffoli_AMMR_at q1 (Signed q2 True) c + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: fredkin" (q1,q2,c) ("q1","q2","c") + +-- | Decomposition of a controlled /H/-gate into the Clifford+/T/ +-- base. From Amy et al. (, Figure +-- 5(a)). The first argument is the target and the second one the +-- control. The control can be positive or negative. +-- +-- \[image cH_AMMR.png] +cH_AMMR_at :: Qubit -> Signed Qubit -> Circ () +cH_AMMR_at q c = do + comment_with_label "ENTER: cH_AMMR" (q,c) ("q","c") + gate_S_inv_at q + hadamard_at q + gate_T_inv_at q + qnot_at q `controlled` c + gate_T_at q + hadamard_at q + gate_S_at q + comment_with_label "EXIT: cH_AMMR" (q,c) ("q","c") + +-- | Decomposition of a controlled /W/-gate into the Clifford+/T/ +-- base. The first two arguments are the targets, and the last +-- argument is the control. The control can be positive or negative. +-- +-- \[image controlled_W.png] +controlled_W_at :: Qubit -> Qubit -> Signed Qubit -> Circ () +controlled_W_at q1 q2 c = do + comment_with_label "ENTER: controlled_W" (q1,q2,c) ("W1","W2","c") + without_comments $ do + qnot_at q2 `controlled` q1 + gate_S_inv_at q1 + hadamard_at q1 + gate_T_inv_at q1 + toffoli_AMMR_at q1 (Signed q2 True) c + gate_T_at q1 + hadamard_at q1 + gate_S_at q1 + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: controlled_W" (q1,q2,c) ("W1","W2","c") + +-- | Decomposition of a /W/-gate into the Clifford+/T/ base. +-- +-- \[image gate_W_CliffordT.png] +gate_W_CliffordT_at :: Qubit -> Qubit -> Circ () +gate_W_CliffordT_at q1 q2 = do + comment_with_label "ENTER: gate_W_CliffordT" (q1,q2) ("W1","W2") + without_comments $ do + qnot_at q2 `controlled` q1 + cH_AMMR_at q1 (Signed q2 True) + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: gate_W_CliffordT" (q1,q2) ("W1","W2") + +-- | Decomposition of a controlled /iX/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_iX.png] +controlled_iX_at :: Qubit -> Signed Qubit -> Circ () +controlled_iX_at q c = do + comment_with_label "ENTER: controlled_iX" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + qnot_at q `controlled` c + reverse_imp_if (not x) gate_S_at w + when (not x) $ do -- need a phase correction + gate_omega_at q + gate_omega_at w + comment_with_label "EXIT: controlled_iX" (q,c) ("q","c") + +-- | Decomposition of a controlled /S/-gate into the Clifford+/T/ +-- base. From Amy et al. (, Figure +-- 5(b)). The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_S.png] +controlled_S_at :: Qubit -> Signed Qubit -> Circ () +controlled_S_at q c = do + comment_with_label "ENTER: controlled_S" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + qnot w `controlled` q + reverse_imp_if (not x) gate_T_inv_at w + qnot w `controlled` q + reverse_imp_if (not x) gate_T_at w + gate_T_at q + comment_with_label "EXIT: controlled_S" (q,c) ("q","c") + +-- | Decomposition of a controlled /T/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_T.png] +controlled_T_at :: Qubit -> Signed Qubit -> Circ () +controlled_T_at q c = do + comment_with_label "ENTER: controlled_T" (q,c) ("q","c") + without_comments $ do + with_ancilla_init False $ \r -> do + cc_iX_at r (Signed q True) c + gate_T_at r + reverse_generic_imp cc_iX_at r (Signed q True) c + comment_with_label "EXIT: controlled_T" (q,c) ("q","c") + +-- | Decomposition of a controlled /V/-gate into the Clifford+/T/ +-- base. Adapted from Amy et al. (, +-- Figure 5(c)). Our /V/-gate is /H//S/[sup †]/H/ as in Nielsen and +-- Chuang. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_V.png] +controlled_V_at :: Qubit -> Signed Qubit -> Circ () +controlled_V_at q c = do + comment_with_label "ENTER: controlled_V" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + hadamard_at q + reverse_imp_if (not x) gate_T_inv_at w + qnot w `controlled` q + reverse_imp_if (not x) gate_T_at w + gate_T_inv_at q + qnot w `controlled` q + hadamard_at q + comment_with_label "EXIT: controlled_V" (q,c) ("q","c") + +-- | Decomposition of a controlled /E/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_E.png] +controlled_E_at :: Qubit -> Signed Qubit -> Circ () +controlled_E_at q c = do + comment_with_label "ENTER: controlled_E" (q,c) ("q","c") + with_signed_qubit c $ \r -> do + gate_H_at q + gate_S_at r + gate_T_at q + qnot_at q `controlled` r + gate_T_inv_at q + gate_H_at q + qnot_at r `controlled` q + gate_T_at r + gate_T_inv_at q + qnot_at r `controlled` q + comment_with_label "EXIT: controlled_E" (q,c) ("q","c") + +-- | Decomposition of a controlled [bold Y]-gate into the Clifford+/T/ +-- base. The gate is from the Ground State Estimation algorithm and is +-- defined as [bold Y] = /SHS/, or equivalently, +-- +-- \[image Y.png] +-- +-- It should not be confused with the Pauli /Y/ gate. +-- The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_YY.png] +controlled_YY_at :: Qubit -> Signed Qubit -> Circ () +controlled_YY_at q c = do + comment_with_label "ENTER: controlled_YY" (q,c) ("q","c") + gate_S_at q + qnot_at q `controlled` c + gate_S_inv_at q + hadamard_at q + gate_T_inv_at q + qnot_at q `controlled` c + gate_T_at q + hadamard_at q + comment_with_label "EXIT: controlled_YY" (q,c) ("q","c") + +-- | A \"plain\" Toffoli gate, not decomposed. This is provided for +-- convenience, for example to use with 'with_combined_controls'. +toffoli_plain_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_plain_at q c1 c2 = do + qnot_at q `controlled` (c1,c2) + +-- | A \"plain\" doubly-controlled /iX/-gate, not decomposed. This is +-- provided for convenience, for example to use with +-- 'with_combined_controls'. +cc_iX_plain_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_plain_at q c1 c2 = do + gate_iX_at q `controlled` (c1,c2) + +-- | Decomposition of an /m/-times controlled not-gate, using /m/−2 +-- ancillas that do not need be initialized in a particular +-- state. Adapted from Barenco et al. +-- (, Lemma 7.2). +-- +-- In addition to what is shown in Barenco et al., this function +-- permits some Toffoli gates to be replaced by doubly-controlled +-- /iX/-gates. This may be beneficial in gate bases, such as +-- Clifford+/T/, where a doubly-controlled /iX/-gate has a simpler +-- representation than a Toffoli gate. +-- +-- The first argument is a Toffoli gate to use in the +-- decomposition. The second argument may be either a Toffoli gate or +-- a doubly-controlled /iX/ gate. The third argument is the target, +-- the fourth argument is a list of qubits to be used as ancillas, and +-- the fifth argument is a list of signed controls. The ancillas need +-- not be initialized, and are returned in their original state. +-- +-- The size of this circuit is linear in the number of controls; the +-- decomposition uses 4/m/−8 doubly-controlled gates for /m/ ≥ 3. +-- +-- \[image multi_cnot_barenco.png] +multi_cnot_barenco_at :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Qubit -> [Qubit] -> [Signed Qubit] -> Circ () +multi_cnot_barenco_at my_toffoli_at my_ciX_at q as cs = + case cs of + [] -> do + qnot_at q + [c] -> do + qnot_at q `controlled` c + [c1,c2] -> do + my_toffoli_at q c1 c2 + c:cs -> do + case as of + [] -> error "multi_cnot_barenco_at: too few ancillas" + a:as -> do + my_toffoli_at q (Signed a True) c + aux cs (a:as) + my_toffoli_at q (Signed a True) c + reverse_generic_imp aux cs (a:as) + where + aux :: [Signed Qubit] -> [Qubit] -> Circ () + aux [] as = return () + aux [c] as = return () + aux [c1,c2] (a:as) = do + my_ciX_at a c1 c2 + aux (c:cs) (a1:a2:as) = do + my_ciX_at a1 (Signed a2 True) c + aux cs (a2:as) + my_ciX_at a1 (Signed a2 True) c + aux _ _ = error "multi_cnot_barenco_at: too few ancillas" + +-- | Decomposition of a multiply-controlled /iX/-gate, using no +-- ancillas. Adapted from Giles and Selinger +-- (, Section 5.2). +-- +-- The first argument is a Toffoli gate or a doubly-controlled +-- /iX/-gate. The third argument is the target, and the fourth +-- argument is a list of signed controls. +-- +-- The size of this circuit is linear in the number of controls; the +-- decomposition uses 8/m/−32 doubly-controlled gates, 4 /T/-gates, +-- and 2 /H/-gates, for /m/ ≥ 6. +-- +-- \[image multi_ciX_noancilla.png] +multi_ciX_noancilla_at :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Qubit -> [Signed Qubit] -> Circ () +multi_ciX_noancilla_at my_ciX_at q [] = gate_iX_at q +multi_ciX_noancilla_at my_ciX_at q [c] = gate_iX_at q `controlled` c +multi_ciX_noancilla_at my_ciX_at q [c1,c2] = gate_iX_at q `controlled` [c1,c2] +multi_ciX_noancilla_at my_ciX_at q cs = do + hadamard_at q + gate_T_inv_at q + multi_cnot_barenco_at my_ciX_at my_ciX_at q as1 cs2 + gate_T_at q + multi_cnot_barenco_at my_ciX_at my_ciX_at q as2 cs1 + gate_T_inv_at q + reverse_generic_imp (multi_cnot_barenco_at my_ciX_at my_ciX_at) q as1 cs2 + gate_T_at q + reverse_generic_imp (multi_cnot_barenco_at my_ciX_at my_ciX_at) q as2 cs1 + hadamard_at q + where + n = length cs + (cs1, cs2) = splitAt (n `div` 2) cs + as1 = map from_signed cs1 + as2 = map from_signed cs2 + +-- ---------------------------------------------------------------------- +-- * Decomposition of controls + +-- | Partition a list of controls into quantum and classical. +partition_controls :: [Signed Endpoint] -> ([Signed Qubit], [Signed Bit]) +partition_controls cs = (qcs, ccs) where + qcs = [ Signed q b | Signed (Endpoint_Qubit q) b <- cs ] + ccs = [ Signed c b | Signed (Endpoint_Bit c) b <- cs ] + +-- | Given a function that expects a qubit (typically as a control), +-- turn it into a function that can handle a /signed/ (positive or +-- negative) qubit. This is done by conjugating the circuit with +-- negations on both sides, if the sign is negative. Usage: +-- +-- > with_signed_qubit c $ \q -> do +-- > <<>> +-- +-- \[image with_signed_qubit.png] +with_signed_qubit :: Signed Qubit -> (Qubit -> Circ b) -> Circ b +with_signed_qubit (Signed q True) f = f q +with_signed_qubit (Signed q False) f = do + gate_X_at q + b <- f q + gate_X_at q + return b + +-- | Decompose quantum controls recursively until at most /n/ remain, +-- and then pass these reduced controls to the given circuit. +-- Precondition: /n/ ≥ 1. +-- +-- The decomposition is done using a Toffoli-like gate that is given +-- as the first argument. This should be either a Toffoli gate, a +-- doubly-controlled /iX/-gate, a decomposition thereof, or any other +-- reversible ternary gate with the behavior +-- +-- * |000〉 ↦ |0〉|φ[sub 0]〉 +-- +-- * |001〉 ↦ |0〉|φ[sub 1]〉 +-- +-- * |010〉 ↦ |0〉|φ[sub 2]〉 +-- +-- * |011〉 ↦ |1〉|φ[sub 3]〉, +-- +-- where the states |φ[sub 0]〉, …, |φ[sub 3]〉 are arbitrary. +-- +-- For example, when /n/=2, this typically yields a circuit such as +-- the following (here shown using the doubly-controlled /iX/-gate): +-- +-- \[image with_combined_controls2.png] +-- +-- And for /n/=1, the circuit typically looks like this: +-- +-- \[image with_combined_controls1.png] +-- +-- Classical controls are not decomposed, but are applied to the +-- resulting circuit directly. +with_combined_controls :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls my_toffoli_at n cs code = circ where + (qcs, ccs) = partition_controls cs + len = length qcs + -- m is the number of qcs to remove. + m = if len <= n then 0 else len - n + circ = with_controls ccs $ do + aux m qcs code + + aux 0 qcs code = code qcs + aux n [] code = code [] + aux n [c] code = code [c] + aux n (c1:c2:qcs) code = do + with_computed (quantum_and c1 c2) $ \c -> do + aux (n-1) (qcs ++ [Signed c True]) code + + quantum_and :: Signed Qubit -> Signed Qubit -> Circ Qubit + quantum_and c1 c2 = do + q <- qinit 0 + my_toffoli_at q c1 c2 + return q diff --git a/Quipper/Libraries/QFT.hs b/Quipper/Libraries/QFT.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QFT.hs @@ -0,0 +1,107 @@ +-- | This module implements the Quantum Fourier Transform. + +module Quipper.Libraries.QFT ( + qft_little_endian, + qft_big_endian, + qft_rev, + qft_int + ) where + +import Quipper +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary (mmap) + +-- ---------------------------------------------------------------------- +-- * Low-level implementation + +-- | Like 'qft_rev', but without the comments and labels. +-- +-- Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- The input is little-endian and the output is big-endian. +-- +-- Unlike 'qft_little_endian' and 'qft_big_endian', this function can +-- be used in imperative style, i.e., it modifies its arguments \"in +-- place\". +qft_internal :: [Qubit] -> Circ [Qubit] +qft_internal [] = return [] +qft_internal [x] = do + hadamard x + return [x] +qft_internal (x:xs) = do + xs' <- qft_internal xs + xs'' <- rotations x xs' (length xs') + x' <- hadamard x + return (x':xs'') + where + -- Auxiliary function used by 'qft'. + rotations :: Qubit -> [Qubit] -> Int -> Circ [Qubit] + rotations _ [] _ = return [] + rotations c (q:qs) n = do + qs' <- rotations c qs n + q' <- rGate ((n + 1) - length qs) q `controlled` c + return (q':qs') + +-- ---------------------------------------------------------------------- +-- * Wrappers + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- Both the input and output qubit lists are little-endian, i.e., the +-- leftmost qubit (head of the list) is the least significant one. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_little_endian :: [Qubit] -> Circ [Qubit] +qft_little_endian qs = do + comment_with_label "ENTER: qft_little_endian" qs "qs" + qs' <- qft_internal qs + let qs = reverse qs' + comment_with_label "EXIT: qft_little_endian" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- Both the input and output qubit lists are big-endian, i.e., the +-- leftmost qubit (head of the list) is the most significant one. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_big_endian :: [Qubit] -> Circ [Qubit] +qft_big_endian qs = do + comment_with_label "ENTER: qft_big_endian" qs "qs" + qs <- qft_internal (reverse qs) + comment_with_label "EXIT: qft_big_endian" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- The input is little-endian and the output is big-endian. +-- +-- Unlike 'qft_little_endian' and 'qft_big_endian', this function can +-- be used in imperative style, i.e., it modifies its arguments +-- \"in place\". +qft_rev :: [Qubit] -> Circ [Qubit] +qft_rev qs = do + comment_with_label "ENTER: qft_rev" qs "qs" + qs <- qft_internal qs + comment_with_label "EXIT: qft_rev" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a 'QDInt'. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_int :: QDInt -> Circ QDInt +qft_int x = do + comment_with_label "ENTER: qft_int" x "x" + x <- mmap qdint_of_qulist_bh $ qft_big_endian $ qulist_of_qdint_bh x + comment_with_label "ENTER: qft_int" x "x" + return x + +-- ---------------------------------------------------------------------- +-- * Testing + +-- | A simple test. +test :: Int -> IO () +test n = print_generic Preview qft_little_endian (replicate n qubit) diff --git a/Quipper/Libraries/QFTAdd.hs b/Quipper/Libraries/QFTAdd.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QFTAdd.hs @@ -0,0 +1,48 @@ +-- | This module provides an implementation of the addition circuit found in +-- Thomas G. Draper's paper \"Addition on a Quantum Computer\". +module Quipper.Libraries.QFTAdd +( + qft_add_in_place +) +where + +import Quipper +import Quipper.Libraries.Arith -- we make use of the QDInt data type for quantum integers +import Quipper.Libraries.QFT -- we make use of the big endian QFT + +-- | Add one 'QDInt' onto a second, in place; i.e. (/x/,/y/) ↦ (/x/,/x/+/y/). +-- Arguments are assumed to be of equal size. +-- This implementation follows the implementation in Thomas G. Draper's +-- paper \"Addition on a Quantum Computer\" which doesn't require the use of any +-- ancilla qubits through a clever use of the Quantum Fourier Transform. +qft_add_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +qft_add_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y') <- qft_add_in_place_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x, y) + +-- | Low-level implementation of 'qft_add_in_place': represents integers +-- as big-headian qubit lists. +qft_add_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit]) +qft_add_in_place_qulist a b = do + label (a,b) ("a","b") + with_computed (box "QFT" qft_big_endian b) $ \b' -> do + qft_adder a (reverse b') + label (a,b) ("a","b") + return (a,b) + +-- | The circuit that performs the addition after a QFT +qft_adder :: [Qubit] -> [Qubit] -> Circ () +qft_adder _ [] = return () +qft_adder as (b:bs) = do + qft_adder' as b 1 + qft_adder (tail as) bs + where + qft_adder' :: [Qubit] -> Qubit -> Int -> Circ [Qubit] + qft_adder' [] _ _ = return [] + qft_adder' (a:as) b n = do + b <- rGate n b `controlled` a + qft_adder' as b (n+1) diff --git a/Quipper/Libraries/Qram.hs b/Quipper/Libraries/Qram.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Qram.hs @@ -0,0 +1,65 @@ +-- | A custom qRAM algorithm for fetching and storing quantum data +-- from a quantum array, addressed by a quantum integer. + +module Quipper.Libraries.Qram ( + indexed_access, + indexed_fetch_at, + indexed_store_at, + indexed_swap_at, + ) where + +import Quipper +import Quipper.Libraries.Arith + +-- | Inputs a list /a/ of quantum data and a quantum integer /i/, and +-- returns the /i/th element of /a/. This is done with controlled swap +-- operations, but without ancillas, i.e., the output is the only copy +-- of that quantum data. Note that the remaining elements of the array +-- may be swapped around, so they are not useable until +-- 'indexed_access' has been reversed. +-- +-- Suggested usage: +-- +-- > with_computed (indexed_access i a) $ \x -> do +-- > <<>> +-- +-- If the index is out of bound, return an unpredictable element of +-- /a/. If /a/ is of length 0, raise an error. +indexed_access :: (QData qa) => [qa] -> QDInt -> Circ qa +indexed_access as i = indexed_access_qulist as (qulist_of_qdint_bh i) + +-- | Auxiliary function: like 'indexed_access', but uses a qubit list +-- instead of a quantum integer. The list is big-headian, i.e., the +-- head of the list holds the most significant bit. +indexed_access_qulist :: (QData qa) => [qa] -> [Qubit] -> Circ qa +indexed_access_qulist [] i = error "indexed_access: cannot address length-0 register" +indexed_access_qulist (a:as) [] = return a +indexed_access_qulist as (i:is) = do + let n = 2 ^ length is + r = max 0 $ min n (length as - n) + -- r: number of wires that need swapping if head qdigit is set + for (r-1) 0 (-1) $ \j -> do + swap_at (as !! j) (as !! (j+n)) `controlled` i + a <- indexed_access_qulist as is + return a + +-- | @'indexed_fetch_at' /a/ /i/ /q/@: +-- Perform /q/ ⊕= /a/[/i/]. +indexed_fetch_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_fetch_at as i q = do + with_computed (indexed_access as i) $ \x -> do + controlled_not_at q x + +-- | @'indexed_store_at' /a/ /i/ /q/@: +-- Perform /a/[/i/] ⊕= /q/. +indexed_store_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_store_at as i q = do + with_computed (indexed_access as i) $ \x -> do + controlled_not_at x q + +-- | @'indexed_swap_at' /a/ /i/ /q/@: +-- Swap /a/[/i/] and /q/. +indexed_swap_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_swap_at as i q = do + with_computed (indexed_access as i) $ \x -> do + swap_at x q diff --git a/Quipper/Libraries/QuantumIf.hs b/Quipper/Libraries/QuantumIf.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QuantumIf.hs @@ -0,0 +1,126 @@ +-- | This module introduces a simple way of defining boolean +-- statements acting over qubits. +module Quipper.Libraries.QuantumIf where + +import Quipper + +-- ---------------------------------------------------------------------- +-- * Quantum \"if then else\" statements + +-- $ This module introduces a simple way of defining boolean +-- statements acting over qubits, which can then be used as the +-- control in a quantum \"if then else\" statement. The idea is that +-- an ancilla is initialized that is in the state represented by the +-- boolean statement, and is then used to control the two branches of +-- the \"if then else\", before being uncomputed. The boolean +-- statements can contain \"and\", \"or\", and \"not\". + +-- | We can use @(Boolean Qubit)@ to build up \"boolean statements\" +-- over qubits and use the \"boolean statement\" in an 'if_then_elseQ' +-- construct. +-- +-- > Example (for qubits a, b, c, d): +-- > (a and b) or !(c and !d) is written as: +-- > (a `And` b) `Or` Not (c `And` Not d) +data Boolean a = A a -- ^ 'A' /q/ means if /q/ == 'True'. + | Not (Boolean a) -- ^ 'Not' /b/ means the negation of the boolean statement /b/. + | And (Boolean a) (Boolean a) -- ^ 'And' /a/ /b/ means the and of the boolean statements /a/ and /b/. + | Or (Boolean a) (Boolean a) -- ^ 'Or' /a/ /b/ means the or of the boolean statements /a/ and /b/ + deriving Show + +-- Set the precedence for infix operators 'And' and 'Or'. +infixr 3 `And` -- same precedence as (&&) +infixr 2 `Or` -- same precedence as (||) + +-- | Allow 'And' and 'Or' to be used as infix operators, with the same +-- precedences. + +-- | Internally, a \"boolean statement\" is converted into a statement +-- that doesn't use /or/ (e.g., using De Morgan's laws). +data BooleanAnd a = AA a -- ^ 'AA' /q/ means if /q/ == 'True'. + | NotA (BooleanAnd a) -- ^ 'NotA' /b/ means the negation of the boolean statement /b/. + | AndA (BooleanAnd a) (BooleanAnd a) -- ^ 'AndA' /a/ /b/ means the and of the boolean statements /a/ and /b/. + +-- | Convert any boolean formula to a formula using just /and/ and /not/. This conversion function uses De Morgan's law, +-- i.e., +-- +-- > A or B = !( !A and !B ), +-- +-- but does not remove double negations. For a version that also +-- removes double negations, see 'booleanToAnd'. +booleanToAnd' :: Boolean a -> BooleanAnd a +booleanToAnd' (A a) = AA a +booleanToAnd' (Not ba) = NotA (booleanToAnd' ba) +booleanToAnd' (And ba ba') = AndA (booleanToAnd' ba) (booleanToAnd' ba') +booleanToAnd' (Or ba ba') = NotA (AndA (NotA (booleanToAnd' ba)) (NotA (booleanToAnd' ba'))) + +-- | Strip any redundant double negations, +-- i.e., in this context @!!A = A@. +stripDoubleNot :: BooleanAnd a -> BooleanAnd a +stripDoubleNot (AA a) = AA a +stripDoubleNot (NotA (NotA ba)) = stripDoubleNot ba +stripDoubleNot (NotA ba) = NotA (stripDoubleNot ba) +stripDoubleNot (AndA ba ba') = AndA (stripDoubleNot ba) (stripDoubleNot ba') + +-- | Convert any boolean formula to a formula using just /and/ and +-- /not/, removing double negations. +booleanToAnd :: Boolean a -> BooleanAnd a +booleanToAnd ba = stripDoubleNot (booleanToAnd' ba) + +-- | Create a circuit from the \"boolean statement\". +booleanAnd' :: BooleanAnd Qubit -> Qubit -> Circ () +booleanAnd' (AA q') q = do + qnot_at q `controlled` q' + return () +booleanAnd' (NotA ba) q = do + anc <- qinit False + qnot_at anc + booleanAnd' ba anc + qnot_at q `controlled` anc +booleanAnd' (AndA ba ba') q = do + anc0 <- qinit False + booleanAnd' ba anc0 + anc1 <- qinit False + booleanAnd' ba' anc1 + qnot_at q `controlled` [anc0,anc1] + +-- | Create a circuit from the \"boolean statement\", passing in an ancilla. +booleanAnd :: BooleanAnd Qubit -> Circ Qubit +booleanAnd baq = do + anc <- qinit False + booleanAnd' baq anc + return anc + +-- | The definition of a quantum if_then_else structure +-- uses a \"boolean statement\" to create a single ancilla in the state defined by +-- the boolean statement, and uses this as a control for the two branches of the +-- if statement. The ancilla then needs to be uncomputed, this is achieved using +-- the other given \"boolean statement\", i.e., a new boolean statement that would +-- produce the state of the control ancilla, from the output state of the two +-- branches.This allows the branches to update the state of qubits used in the +-- original \"boolean statement\" as long as it is done in a +-- (reversible) known-manner. +-- This is useful for the WALK algorithm, where TOPARENT and TOCHILD are controlled +-- by the state of the direction register, but also change the state of the +-- direction register. +if_then_elseQinv :: Boolean Qubit -> Circ () -> Circ () -> Boolean Qubit -> Circ () +if_then_elseQinv b_in i e b_out = do + with_ancilla $ \if_control -> do + with_computed (booleanAnd (booleanToAnd b_in)) $ \anc -> do + qnot_at if_control `controlled` anc + with_controls if_control $ do + i + with_controls (if_control .==. False) $ do + e + with_computed (booleanAnd (booleanToAnd b_out)) $ \anc -> do + qnot_at if_control `controlled` anc + +-- | Like 'if_then_elseQinv', but where the original \"boolean statement\" still +-- holds after the branches have taken place. +if_then_elseQ :: Boolean Qubit -> Circ () -> Circ () -> Circ () +if_then_elseQ b i e = do + with_computed (booleanAnd (booleanToAnd b)) $ \if_control -> do + with_controls if_control $ do + i + with_controls (if_control .==. False) $ do + e diff --git a/Quipper/Libraries/QuipperASCIIParser.hs b/Quipper/Libraries/QuipperASCIIParser.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QuipperASCIIParser.hs @@ -0,0 +1,57 @@ +-- ---------------------------------------------------------------------- +-- | This module is the main interface to the QuipperASCIIParser +-- library. It provides functions for parsing circuits in the ASCII +-- format written by 'print_generic' and similar functions. + +module Quipper.Libraries.QuipperASCIIParser where + +import qualified Quipper.Libraries.QuipperASCIIParser.CircInfo as CI +import qualified Quipper.Libraries.QuipperASCIIParser.ASCIICirc as AC + +import Quipper +import Quipper.Internal.Monad + +import Quipper.Utils.PortableSignals +import System.IO +import Data.List + +-- | Parse a string containing a circuit in the format output by +-- Quipper's ASCII format. Return a circuit producing function of the +-- parsed circuit, along with a specimen \"shape\" for the input of +-- the parsed circuit. +parse_circuit :: String -> ([Endpoint],[Endpoint] -> Circ [Endpoint]) +parse_circuit all_lines = AC.run mins gates subs circ_info + where + split_lines = lines' all_lines + (mins, ci) = CI.run_ascii_lines split_lines + (gates,subs,circ_info) = CI.run ci + + +-- | Like 'lines', except that the last line is omitted if it doesn't +-- end with a newline character +lines' :: String -> [String] +lines' [] = [] +lines' s = case elemIndex '\n' s of + Nothing -> [] + Just n -> (take (n) s):lines' (drop (n+1) s) + +-- | Like 'parse_circuit', but read the circuit from the standard +-- input stream, rather than from a string. This can be used to build +-- stand-alone tools that process circuits in a pipeline. +parse_from_stdin :: IO ([Endpoint], [Endpoint] -> Circ [Endpoint]) +parse_from_stdin = do + all_lines <- hGetContents stdin + return $ parse_circuit all_lines + +-- | Like 'parse_from_stdin', but as a special convenience, this +-- function also installs a signal handler that will intercept the first +-- kill signal (e.g., Ctrl-C) and close the standard input stream. +-- This means that whichever part of the circuit was generated before the +-- first Ctrl-C can still be processed as a partial circuit. Note that the +-- second kill signal will still kill the program. Note that this is only +-- defined for Non-Windows OS environments. +parse_from_stdin_with_handler :: IO ([Endpoint], [Endpoint] -> Circ [Endpoint]) +parse_from_stdin_with_handler = do + installHandler Interrupt (CatchOnce (hClose stdin)) + all_lines <- hGetContents stdin + return $ parse_circuit all_lines diff --git a/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs b/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs @@ -0,0 +1,334 @@ +-- ---------------------------------------------------------------------- +-- | This module uses a state transformer monad to rebuild a circuit from +-- the CircInfoState representation. This can only be as lazy as the Quipper +-- ASCII output allows, as subroutine definitions need to be known before +-- a subroutine can be called. + +module Quipper.Libraries.QuipperASCIIParser.ASCIICirc where + +import Quipper.Libraries.QuipperASCIIParser.CircInfo hiding (run,do_gate) + +import Quipper +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Internal.Generic + +import Data.List +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Monad.State + +-- | In the Quipper ASCII output, wires are identified by integers. +-- We have to map these to Quipper's native wires and types. +data WireState = WireState { + wire_map :: IntMap (Wire,Wiretype), + in_sub :: Bool, + subroutines_in_scope :: Map BoxId Sub + } + +-- | An initial, empty WireState, with the given subroutines_in_scope +empty_wirestate :: Map BoxId Sub -> WireState +empty_wirestate subs = WireState {wire_map = IntMap.empty, in_sub = False, + subroutines_in_scope = subs} + +-- | The 'ASCIICirc' monad is like the 'Circ' monad, except that it also +-- keeps track of an additional 'WireState'. The 'lift' function must +-- be used to lift any command for the 'Circ' monad to the 'ASCIICirc' +-- monad. +type ASCIICirc a = StateT WireState Circ a + +-- | The 'in_sub' flag can be set to True, as slightly different behavior is +-- required when evaluating a subroutine. +set_in_sub :: ASCIICirc () +set_in_sub = do + state <- get + put (state {in_sub = True}) + +-- | Look up the qubit corresponding to a ASCII integer representation of a +-- qubit. If it doesn't already exist then initialize a new qubit. +provide_qubit :: Int -> ASCIICirc Qubit +provide_qubit r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,Qbit) -> return (qubit_of_wire w) + Just (w,Cbit) -> error ("Quantum wire " ++ show r ++ " bound as classical " ++ show w) + Nothing -> error ("Quantum wire " ++ show r ++ " not in scope") + True -> return (qubit_of_wire r) + +-- | Look up the bit corresponding to a ASCII integer representation of a +-- bit. If it doesn't already exist then initialize a new bit. +provide_bit :: Int -> ASCIICirc Bit +provide_bit r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,Cbit) -> return (bit_of_wire w) + Just (w,Qbit) -> error ("Classical wire " ++ show r ++ " bound as quantum " ++ show w) + Nothing -> error ("Classical wire " ++ show r ++ " not in scope") + True -> return (bit_of_wire r) + +-- | Look up the wire corresponding to a ASCII integer representation of a +-- bit or qubit. If it doesn't already exist then initialize a new qubit. +provide_wire :: Int -> ASCIICirc Wire +provide_wire r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,_) -> return w + Nothing -> do + q <- provide_qubit r + return (wire_of_qubit q) + True -> return r + +-- | Add a new qubit to the state. +add_qubit :: Int -> Qubit -> ASCIICirc () +add_qubit w q = do + state <- get + let ws = wire_map state + let ws' = IntMap.insert w (wire_of_qubit q,Qbit) ws + put (state {wire_map = ws'}) + +-- | Add a new bit to the state. +add_bit :: Int -> Bit -> ASCIICirc () +add_bit w b = do + state <- get + let ws = wire_map state + let ws' = IntMap.insert w (wire_of_bit b,Cbit) ws + put (state {wire_map = ws'}) + +-- | Remove a wire from the state +remove_wire :: Int -> ASCIICirc () +remove_wire w = do + state <- get + let ws = wire_map state + let ws' = IntMap.delete w ws + put (state {wire_map = ws'}) + +-- | A helper function for providing the qubits within a control structure +provide_control :: Signed Int -> ASCIICirc (Signed Wire) +provide_control (Signed r val) = do + w <- provide_wire r + return (Signed w val) + +-- | provides quantum wires for the controls in a control list +provide_controls :: [Signed Int] -> ASCIICirc [Signed Wire] +provide_controls = mapM provide_control + +-- | Lift a Quipper circuit, preventing the addition of controls depending +-- on the given boolean. +lift_ncf :: Bool -> Circ a -> ASCIICirc a +lift_ncf False ca = lift ca +lift_ncf True ca = lift $ without_controls ca + +-- | Take a Gate and execute it in the 'ASCIICirc' monad. +do_gate :: Gate -> ASCIICirc () +do_gate (QGate name iflg ws1 ws2 wbs ncf) = do + qs1 <- mapM provide_qubit ws1 + qs2 <- mapM provide_qubit ws2 + cs <- provide_controls wbs + lift_ncf ncf $ named_gate_qulist name iflg qs1 qs2 `controlled` cs + return () +do_gate (QRot name iflg theta ws1 ws2 wbs ncf) = do + qs1 <- mapM provide_qubit ws1 + qs2 <- mapM provide_qubit ws2 + cs <- provide_controls wbs + lift_ncf ncf $ named_rotation_qulist name iflg theta qs1 qs2 `controlled` cs + return () +do_gate (GPhase ts ws wbs ncf) = do + qs <- mapM provide_qubit ws + cs <- provide_controls wbs + lift_ncf ncf $ global_phase_anchored_list ts (map (\w -> endpoint_of_wire w Qbit) (map wire_of_qubit qs)) `controlled` cs + return () +do_gate (CNot w wbs ncf) = do + b <- provide_bit w + cs <- provide_controls wbs + lift_ncf ncf $ cnot_at b `controlled` cs +do_gate (CGate name w ws ncf) = do + bs <- mapM provide_bit ws + b <- lift_ncf ncf $ cgate name bs + add_bit w b +do_gate (CGateInv name w ws ncf) = do + b <- provide_bit w + bs <- mapM provide_bit ws + lift_ncf ncf $ cgateinv name b bs +do_gate (CSwap w1 w2 wbs ncf) = do + b1 <- provide_bit w1 + b2 <- provide_bit w2 + cs <- provide_controls wbs + lift_ncf ncf $ swap b1 b2 `controlled` cs + return () +do_gate (QPrep w ncf) = do + b <- provide_bit w + q <- lift_ncf ncf $ prepare_qubit b + add_qubit w q +do_gate (QUnprep w ncf) = do + q <- provide_qubit w + b <- lift_ncf ncf $ unprepare_qubit q + add_bit w b +do_gate (QInit val w ncf) = do + q <- lift_ncf ncf $ qinit val + add_qubit w q +do_gate (CInit val w ncf) = do + b <- lift_ncf ncf $ cinit val + add_bit w b +do_gate (QTerm val w ncf) = do + q <- provide_qubit w + lift_ncf ncf $ qterm val q + remove_wire w +do_gate (CTerm val w ncf) = do + b <- provide_bit w + lift_ncf ncf $ cterm val b + remove_wire w +do_gate (QMeas w) = do + q <- provide_qubit w + b <- lift $ measure q + add_bit w b +do_gate (QDiscard w) = do + q <- provide_qubit w + lift $ qdiscard q + remove_wire w +do_gate (CDiscard w) = do + b <- provide_bit w + lift $ cdiscard b + remove_wire w +do_gate (Subroutine boxid iflg ws_in _ ws_out _ wbs ncf _ (RepeatFlag rf)) = do + -- Note that we ignore the given arities, as they are dummy values + -- the true values are kept in the ASCIICirc state. + -- The controllable flag is also ignored, as it is recalculated. + state <- get + let subs = subroutines_in_scope state + case (Map.lookup boxid subs) of + Nothing -> error ("Subroutine " ++ show boxid ++ " has not been defined in: " ++ show (Map.keys subs)) + Just sub -> do + let ins = inputs sub + let (_,in_as) = unzip ins + let in_wa = zip ws_in in_as + es_in <- mapM (\(w,wt) -> + case wt of + Qbit -> do + q <- provide_qubit w + let wire = endpoint_of_wire (wire_of_qubit q) Qbit + return wire + Cbit -> do + b <- provide_bit w + let wire = endpoint_of_wire (wire_of_bit b) Cbit + return wire + ) in_wa + cs <- provide_controls wbs + let outs = outputs sub + let es_out = map (\(w,wt) -> endpoint_of_wire w wt) outs + let gates = reverse (circuit sub) + let ascii_circ = \_ -> set_in_sub >> (mapM_ do_gate gates) >> return es_out + let circ = run_asciicirc subs ascii_circ + let boxid = BoxId (name sub) (shape sub) + let error_message = \e -> "ASCIICirc.do_gate : " ++ e + let f = \x -> do + -- Provide subroutine generic only uses circ if it isn't already + -- in the namespace. + provide_subroutine_generic error_message boxid False circ x + call_subroutine boxid (RepeatFlag rf) x + es_out' <- case iflg of + False -> lift_ncf ncf $ f es_in `controlled` cs + True -> do + let (_,out_as) = unzip outs + let out_wa = zip ws_in out_as + es_out <- mapM (\(w,wt) -> + case wt of + Qbit -> do + q <- provide_qubit w + let wire = endpoint_of_wire (wire_of_qubit q) Qbit + return wire + Cbit -> do + b <- provide_bit w + let wire = endpoint_of_wire (wire_of_bit b) Cbit + return wire + ) out_wa + lift_ncf ncf $ (reverse_generic f es_in) es_out `controlled` cs + -- a subroutine can add/remove wires from scope, so we remove all the input + -- wires from the state, and add all the output wires to the state. + -- The state may have changed, so we get it again. + state <- get + let wires = wire_map state + let wires' = foldr (\w ws -> IntMap.delete w ws) wires (if iflg then ws_out else ws_in) + let wires'' = foldr (\(w,e) ws -> IntMap.insert w + (case e of + Endpoint_Qubit q -> (wire_of_qubit q, Qbit) + Endpoint_Bit b -> (wire_of_bit b, Cbit)) ws) wires' + (zip (if iflg then ws_in else ws_out) es_out') + put (state {wire_map = if (in_sub state) then wires else wires''}) +do_gate (Comment c iflg wlabels) = do + qlabels <- mapM (\(w,l) -> + do + pw <- provide_wire w + return (pw,l) ) wlabels + lift $ comment_label c iflg qlabels +do_gate (DTerm val w) = do + b <- provide_bit w + lift $ dterm_bit val b + remove_wire w + +-- | Allocate an input endpoint, to an endpoint in the ASCIICirc, by adding it to +-- the map of wires in scope. +allocate_input :: (Endpoint,Endpoint) -> ASCIICirc () +allocate_input (i,e@(Endpoint_Qubit _)) = add_qubit (wire_of_endpoint e) (qubit_of_wire (wire_of_endpoint i)) +allocate_input (i,e@(Endpoint_Bit _)) = add_bit (wire_of_endpoint e) (bit_of_wire (wire_of_endpoint i)) + +-- ---------------------------------------------------------------------- +-- * Unpacking ASCIICirc + +-- | Execute a parsed circuit, i.e. a CircInfoState, in the ASCIICirc monad +run_gates :: [Gate] -> Maybe [(Wire,Wiretype)] -> [Endpoint] -> [Endpoint] -> ASCIICirc [Endpoint] +run_gates gates d_outs es ins = do + mapM_ (\i -> allocate_input i) (zip ins es) + mapM_ (\g -> do_gate g) gates + state <- get + let ws_in_scope = IntMap.elems $ wire_map state + let es_in_scope = map (\(w,wt) -> endpoint_of_wire w wt) ws_in_scope + case d_outs of + Nothing -> return es_in_scope + Just out_ws -> do + es_out <- mapM (\(w,wt) -> do + w' <- provide_wire w + return (endpoint_of_wire w' wt)) out_ws + let es_in_scope' = sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) es_in_scope + let es_out' = sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) es_out + case es_in_scope' == es_out' of + True -> return es_out' + False -> return es_in_scope' + +-- | Run function for the 'ASCIICirc' monad: execute the actions and +-- produce a circuit. +run_asciicirc :: Map BoxId Sub -> (a -> ASCIICirc b) -> a -> Circ b +run_asciicirc subs f es = evalStateT (f es) (empty_wirestate subs) + +-- | A CircInfoState can be turned into a Circ producing function, and the required +-- input "shape". +run :: Maybe [(Wire,Wiretype)] -> [Gate] -> Map BoxId Sub -> CircInfoState -> ([Endpoint],[Endpoint] -> Circ [Endpoint]) +run mins gates subs cis = (ins,circ) + where + d_ins = defined_inputs cis + d_outs = defined_outputs cis + u_ins = map set_qubit (undefined_inputs cis) + d_es = map (\(w,wt) -> endpoint_of_wire w wt) d_ins + u_es = map (\(w,wt) -> endpoint_of_wire w wt) u_ins + ins = case mins of + Nothing -> (d_es ++ sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) u_es) + Just wts -> map (\(w,wt) -> endpoint_of_wire w wt) wts + asciicirc = run_gates gates d_outs ins + circ = run_asciicirc subs asciicirc + +-- | If the type of an undefined_input wire is unknown, then set it to +-- be a qubit. +set_qubit :: (Wire,Maybe Wiretype) -> (Wire,Wiretype) +set_qubit (w,Just wt) = (w,wt) +set_qubit (w,Nothing) = (w,Qbit) diff --git a/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs b/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs @@ -0,0 +1,236 @@ +-- ---------------------------------------------------------------------- +-- | This module uses a state monad to track certain circuit information +-- that is collected during parsing. This information contains +-- the inputs and outputs of a circuit, as well as an entry for each subroutine +-- that is defined within a circuit, and all the gates that make up the circuit. + +module Quipper.Libraries.QuipperASCIIParser.CircInfo where + +import Quipper.Libraries.QuipperASCIIParser.Parse (GatePlus (..),parse_ascii_line) + +import Quipper +import Quipper.Internal.Circuit +import Quipper.Internal.Monad + +import Control.Monad.State + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------- +-- * Data-types for the State + +-- | Information collected about the current subroutine +data Sub = Sub { + name :: String, + shape :: String, + controllable :: ControllableFlag, + inputs :: [(Wire,Wiretype)], + outputs :: [(Wire,Wiretype)], + circuit :: [Gate] + } + +-- | An initial subroutine, with only a name +new_subroutine :: String -> Sub +new_subroutine n = Sub {name = n, shape = "", controllable = NoCtl, inputs = [], outputs = [], circuit = []} + +-- | A 'CircInfoState' is a record containing a list of input wires, along with their +-- types, and a list of output wires, along with their types. We also keep track of +-- whether we're in a subroutine definition, and all the subroutines that have been +-- defined. +data CircInfoState = CircInfoState { + used_wires :: Map Wire (Maybe Wiretype), + defined_inputs :: [(Wire,Wiretype)], + undefined_inputs :: [(Wire,Maybe Wiretype)], + defined_outputs :: Maybe [(Wire,Wiretype)], + current_subroutine :: [Sub] + } + +-- | An initial, empty CircInfoState +empty_circinfostate :: CircInfoState +empty_circinfostate = CircInfoState { used_wires = Map.empty, defined_inputs = [], + undefined_inputs = [], defined_outputs = Nothing, current_subroutine = [] } + +-- | The 'CircInfo' Monad is used to track a 'CircInfoState' during parsing. +type CircInfo a = State CircInfoState a + +-- | The CircInfo Monad tracks wires that are inputs, these can only be given in +-- a "Input" line in the parsed ASCII, so we assume that duplicate wires don't +-- occur, and we add input wires to the state without checking. +add_wire_inputs :: [(Wire,Wiretype)] -> CircInfo () +add_wire_inputs ws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + let ins = defined_inputs state + let wires = used_wires state + put (state {defined_inputs = ws ++ ins, + used_wires = Map.fromList (map (\(w,wt) -> (w,Just wt)) ws)}) + (sub:rest) -> do + let ins = inputs sub + let sub' = sub {inputs = ins ++ ws} + put (state {current_subroutine = (sub':rest)}) + +-- | The CircInfo Monad tracks wires that are outputs, these can only be given in +-- a "Output" line in the parsed ASCII, so we assume that duplicate wires don't +-- occur, and we add output wires to the state without checking. +add_wire_outputs :: [(Wire,Wiretype)] -> CircInfo () +add_wire_outputs ws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + case defined_outputs state of + Nothing -> put (state {defined_outputs = Just ws}) + Just outs -> put (state {defined_outputs = Just (outs ++ ws)}) + (sub:rest) -> do + let outs = outputs sub + let sub' = sub {outputs = outs ++ ws} + put (state {current_subroutine = (sub':rest)}) + +-- | Given a a wire, check whether it is already in scope. +check_input :: Map Wire (Maybe Wiretype) -> (Wire,Maybe Wiretype) -> Bool +check_input wires (w,wt) = case Map.lookup w wires of + Just wt -> False + Nothing -> True + +-- | Given a list of wires that are inputs to a gate, check whether they +-- are already in scope. The returned wires are not in scope, when used by a gate, +-- and must be declared as undefined inputs. +check_inputs :: [(Wire,Maybe Wiretype)] -> Map Wire (Maybe Wiretype) -> [(Wire,Maybe Wiretype)] +check_inputs ins wires = filter (check_input wires) ins + +-- | The CircInfo Monad keeps track of all the gates that have been parsed +-- and adds them to the relevant part of the state. +add_gate :: Gate -> [(Wire,Wiretype)] -> CircInfo CircInfoOut +add_gate gate ctws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + let wires = used_wires state + let ui = undefined_inputs state + let (ws_in,ws_out) = gate_arity gate + let ws = wirelist_of_gate gate + let ws_unchecked = filter (\w -> (notElem w (map fst ws_in)) + && (notElem w (map fst ws_out)) + && (notElem w (map fst ctws))) ws + let ws_in' = (map (\(w,wt) -> (w, Just wt)) (ws_in ++ ctws)) + ++ (zip ws_unchecked (repeat Nothing)) + let ui' = ui ++ check_inputs ws_in' wires + let wires' = Map.union wires (Map.fromList (ws_in' + ++ (map (\(w,wt) -> (w, Just wt)) ws_out))) + put (state {used_wires = wires',undefined_inputs = ui'}) + return (Lazy gate) + (sub:rest) -> do + let gates = circuit sub + let gates' = gate:gates + let sub' = sub {circuit = gates'} + put (state {current_subroutine = (sub':rest)}) + return Empty + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. The entrance to the subroutine contains its name. +enter_subroutine :: String -> CircInfo () +enter_subroutine name = do + state <- get + let ms = current_subroutine state + put (state {current_subroutine = ((new_subroutine name):ms)}) + +-- | We can add the shape to the current subroutine +add_subroutine_shape :: String -> CircInfo () +add_subroutine_shape s = do + state <- get + let ms = current_subroutine state + case ms of + [] -> error "Shape given outside of Subroutine Definition" + (sub:rest) -> put (state {current_subroutine = ((sub {shape = s}):rest)}) + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. The subroutine might be controllable. +set_controllable :: ControllableFlag -> CircInfo () +set_controllable val = do + state <- get + let ms = current_subroutine state + case ms of + [] -> error "Controllable not in Subroutine Definition" + (sub:rest) -> put (state {current_subroutine = ((sub {controllable = val}):rest)}) + +-- | A datatype to represent the various outputs a CircInfo computation +-- may require. +data CircInfoOut = Empty | Lazy Gate | SubDef (BoxId,Sub) + +-- | This function returns True if the given input defines a Gate +isGate :: CircInfoOut -> Bool +isGate (Lazy _) = True +isGate _ = False + +-- | This function returns True if the given inputs defines a SubDef +isSub :: CircInfoOut -> Bool +isSub (SubDef _) = True +isSub _ = False + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. At the end of the subroutine, it stores the subroutine +-- for later use. +exit_subroutine :: CircInfo CircInfoOut +exit_subroutine = do + state <- get + let ms = current_subroutine state + case ms of + [] -> return Empty + (sub:rest) -> do + let n = name sub + let s = shape sub + put (state {current_subroutine = rest}) + return (SubDef ((BoxId n s),sub)) + +-- | Take a GatePlus and execute it in the 'CircInfo' monad. +-- Again, the executed computation may depend upon whether we're in a subroutine +-- definition. +do_gate :: GatePlus -> CircInfo CircInfoOut +do_gate (G gate wts) = add_gate gate wts +do_gate (I ws) = add_wire_inputs ws >> return Empty +do_gate (O ws) = do + add_wire_outputs ws + exit_subroutine +do_gate EmptyLine = return Empty +do_gate (CommentLine comment) = return Empty +do_gate (SubroutineName name) = enter_subroutine name >> return Empty +do_gate (SubroutineShape shape) = add_subroutine_shape shape >> return Empty +do_gate (Controllable b) = set_controllable b >> return Empty + +-- | Monad version of 'parse_ascii_line': parse a string and execute the +-- resulting gate directly in the 'CircInfo' monad. +run_ascii_line :: String -> CircInfo CircInfoOut +run_ascii_line s = case parse_ascii_line s of + Nothing -> error ("unrecognized line: " ++ show s) + Just p -> do_gate p + +-- | Parse a stream consisting of many lines of ASCII output and execute +-- the parsed gates in the 'CircInfo' monad, checking to see if the first +-- line defines the inputs to the circuit. +run_ascii_lines :: [String] -> (Maybe [(Wire,Wiretype)],CircInfo [CircInfoOut]) +run_ascii_lines [] = (Nothing,return []) +run_ascii_lines [f] = case parse_ascii_line f of + Just (I ws) -> (Just ws, return []) + _ -> (Nothing, run_ascii_line f >>= \x -> return [x]) +-- Special case: +-- If the first line contains the input wires, we should +-- be able to parse the circuit lazily (e.g. it is a full circuit), as +-- we don't have to parse all the gates to calculate the inputs. +run_ascii_lines (f:s) = + case parse_ascii_line f of + Just (I ws) -> (Just ws, mapM run_ascii_line s) + _ -> (Nothing, mapM run_ascii_line (f:s)) + +-- | Run function for the 'CircInfo' monad: evaluate the state and +-- produce a list of inputs, outputs, and used wires. +run :: CircInfo [CircInfoOut] -> ([Gate],Map BoxId Sub,CircInfoState) +run f = (gs, subs, cis) + where + gs = [x | Lazy x <- filter isGate ci_outs] + subs = Map.fromList [x | SubDef x <- filter isSub ci_outs] + (ci_outs,cis) = runState f empty_circinfostate + diff --git a/Quipper/Libraries/QuipperASCIIParser/Parse.hs b/Quipper/Libraries/QuipperASCIIParser/Parse.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/QuipperASCIIParser/Parse.hs @@ -0,0 +1,674 @@ +-- ---------------------------------------------------------------------- +-- | This module contains the code for parsing the ASCII output from +-- Quipper, into a GatePlus. +-- This program is heavily based on, and heavily borrows from the QCLParser. + +module Quipper.Libraries.QuipperASCIIParser.Parse where + +import Quipper.Internal.Circuit +import Data.IntMap hiding (map) + +import Text.ParserCombinators.ReadP +import Data.Char (isDigit) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------- +-- | A type for gates, plus other circuit output, empty lines, and subroutine defs. +data GatePlus = G Gate [(Wire,Wiretype)] + | I [(Wire,Wiretype)] + | O [(Wire,Wiretype)] + | EmptyLine + | CommentLine String + | SubroutineName String + | SubroutineShape String + | Controllable ControllableFlag + deriving Show + +-- ---------------------------------------------------------------------- +-- * Parsing + +-- | Parse a string literal. +string_literal :: ReadP String +string_literal = do + char '"' + s <- string_with_escaped_chars "" + char '"' + return s + where + string_with_escaped_chars :: String -> ReadP String + string_with_escaped_chars input = do + s <- munch (\x -> x /= '\\' && x /= '"') + let s' = input ++ s + rest <- look + case rest of + '"' : _ -> return s' + '\\' : _ -> do + e <- escaped_char + string_with_escaped_chars (s' ++ [e]) + _ -> do + pfail + +-- | Parse an escaped character, such as @\0@, @\n@, @\\@, etc. +escaped_char :: ReadP Char +escaped_char = do + char '\\' + c <- get + return (Map.findWithDefault c c map) + where + -- The official escape codes. We allow any other escaped character + -- to denote itself. We do not permit "\&" to denote the empty string. + map = Map.fromList [ + ('0', '\0'), + ('a', '\a'), + ('b', '\b'), + ('f', '\f'), + ('n', '\n'), + ('r', '\r'), + ('t', '\t'), + ('v', '\v'), + ('"', '\"'), + ('\'', '\''), + ('\\', '\\') + ] + +-- | Parse a signless integer. We avoid the usual trick ('readS_to_P' +-- 'reads'), because this introduces backtracking errors. +int :: ReadP Int +int = do + s <- munch1 isDigit + return $ (read s :: Int) + +-- | Parse a floating point number. We avoid the usual trick +-- ('readS_to_P' 'reads'), because this introduces backtracking +-- errors. +double :: ReadP Double +double = do + (s, _) <- gather parse_double + return $ (read s :: Double) + where + parse_double = do + option '+' (char '+' +++ char '-') + munch isDigit + optional (char '.' >> munch1 isDigit) + optional (char 'e' >> option '+' (char '+' +++ char '-') >> int) + +-- | Parse a comma separated list. +commalist :: ReadP a -> ReadP [a] +commalist elt = sepBy elt (skipSpaces >> char ',' >> skipSpaces) + +-- | Parse a control structure. +control :: ReadP (Signed Wire,Wiretype) +control = do + val <- choice [char '+',char '-'] + skipSpaces + w <- int + c <- option 'q' (char 'c') + let wt = case c of + 'c' -> Cbit + _ -> Qbit + return (Signed w (val == '+'),wt) + +-- | Parse a list of controls. +controls :: ReadP ([Signed Wire],[(Wire,Wiretype)]) +controls = do + skipSpaces + string "with controls=[" + cwts <- commalist control + char ']' + let cs = map fst cwts + let wts = map (\(Signed w _,wt) -> (w,wt)) cwts + return (cs,wts) + +-- | Parse a 'Wiretype'. +wiretype :: ReadP Wiretype +wiretype = do + c <- choice [string "Qbit",string "Cbit"] + case c of + "Qbit" -> return Qbit + "Cbit" -> return Cbit + _ -> error "The impossible has happened" + +-- | Parse a wire and its type. +wire :: ReadP (Int,Wiretype) +wire = do + skipSpaces + w <- int + char ':' + t <- wiretype + return (w,t) + +-- | Parse a list of input/output wires and types. +wires :: ReadP [(Int,Wiretype)] +wires = do + skipSpaces + ws <- commalist wire + return ws + +-- | Parse the string \"none\", +-- returning an empty list of input/output wires and types. +none :: ReadP [(Int,Wiretype)] +none = do + skipSpaces + string "none" + return [] + +-- | Consume an optional \"*\". Return 'True' if consumed, and 'False' +-- otherwise. +inversechar :: ReadP Bool +inversechar = do + c <- option '+' (char '*') + return (c == '*') + +-- | Consume a label. +label' :: ReadP (Int,String) +label' = do + w <- int + char ':' + lab <- string_literal + return (w,lab) + +-- | Consumer any character other than \')\', \']\', or \',\'. +labelchar :: ReadP String +labelchar = do + c <- satisfy (\x -> not (x `elem` ")],")) + return [c] + +-- | Consume an index of the form [...]. +labelbracket :: ReadP String +labelbracket = do + char '[' + s <- munch (\x -> not (x `elem` "[]")) + char ']' + return ("[" ++ s ++ "]") + +-- | Consume a list of labels. +labels :: ReadP [(Int,String)] +labels = do + skipSpaces + char '(' + ls <- commalist label' + char ')' + return ls + +-- | Consume a 'BoxId' followed by a \']\' character. +{- +ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape +-} +box_id :: ReadP BoxId +box_id = do + name <- string_literal + skipSpaces + char ',' + skipSpaces + string "shape" + skipSpaces + shape <- string_literal + return (BoxId name shape) + +-- | Consume an optional 'NoControlFlag', returning 'False' if it isn't present. +nocontrolflag :: ReadP NoControlFlag +nocontrolflag = do + skipSpaces + ncf <- option "" (string "with nocontrol") + return (ncf == "with nocontrol") + +-- | Parse a single line of ASCII output into a 'Gate'. This function +-- needs to be kept in line with Quipper's +-- 'Quipper.Internal.Printing.ascii_render_gate' function. +ascii_line :: ReadP GatePlus +ascii_line = choice [ + do -- Inputs: w:Type, w:Type ... + string "Inputs:" + ws <- choice [wires,none] + eof + return (I ws), + do -- Outputs: w:Type, w:Type ... + string "Outputs:" + ws <- choice [wires,none] + eof + return (O ws), + do -- An empty line can be parsed as an EmptyLine + skipSpaces + eof + return EmptyLine, + do -- "A comment in a circuit is any line beginnning with a # character" + -- The comment is stored for later use as a CommentLine + skipSpaces + char '#' + skipSpaces + comment <- manyTill (satisfy (\_ -> True)) eof + eof + return (CommentLine comment), + do -- Subroutine: "name" (keeping unquoted version for backward comp.) + string "Subroutine: " + name <- string_literal +++ manyTill (satisfy (\_ -> True)) eof + eof + return (SubroutineName name), + do -- Shape: "shape" (keeping unquoted version for backward comp.) + string "Shape: " + shape <- string_literal +++ manyTill (satisfy (\_ -> True)) eof + eof + return (SubroutineShape shape), + do -- Controllable: yes/no/classically + string "Controllable: " + val_string <- choice [string "yes",string "no", string "classically"] + let val = case val_string of + "yes" -> AllCtl + "no" -> NoCtl + "classically" -> OnlyClassicalCtl + _ -> error "The impossible happened" + eof + return (Controllable val), +{- +For backward compatibility: +ascii_render_gate (QNot w c ncf) = + "QNot(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QNot(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "not" False [w] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QMultinot ws c ncf) = + "QMultinot(" ++ string_of_list "" ", " "" "" show ws ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QMultinot(" + ws <- commalist int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "multinot" False ws [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QHad w c ncf) = + "QHad(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QHad(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "H" False [w] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QSwap w1 w2 c ncf) = + "QSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QSwap(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "swap" False [w1, w2] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QW w1 w2 c ncf) = + "QW(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QW(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "W" False [w1, w2] [] cs ncf) wts), +{- +ascii_render_gate (GPhase t ws c ncf) = + "GPhase() with t=" ++ show t + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf + ++ string_of_list " with anchors=[" ", " "]" "" show ws +-} + do + string "GPhase() with t=" + t <- double + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + ws <- option [] (do + skipSpaces + string "with anchors=[" + ws <- commalist int + char ']' + return ws ) + eof + return (G (GPhase t ws cs ncf) wts), +{- +ascii_render_gate (QGate name inv ws1 ws2 c ncf) = + "QGate[" ++ show name ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list "; [" "," "]" "" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QGate[" + name <- string_literal + char ']' + inv <- inversechar + char '(' + ws1 <- commalist int + char ')' + ws2 <- option [] (do + string "; [" + ws <- commalist int + char ']' + return ws ) + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate name inv ws1 ws2 cs ncf) wts), +{- +ascii_render_gate (QRot name inv theta ws1 ws2 c ncf) = + "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list "; [" "," "]" "" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QRot[" + name <- string_literal + char ',' + theta <- double + char ']' + inv <- inversechar + char '(' + ws1 <- commalist int + char ')' + ws2 <- option [] ( do + string "; [" + ws <- commalist int + char ']' + return ws ) + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QRot name inv theta ws1 ws2 cs ncf) wts), +{- +ascii_render_gate (CNot w c ncf) = + "CNot(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "CNot(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (CNot w cs ncf) wts), +{- +ascii_render_gate (CGate n w c ncf) = + "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +-} + do + string "CGate[" + name <- string_literal + string "](" + ws <- commalist int + char ')' + ncf <- nocontrolflag + eof + return (G (CGate name (head ws) (tail ws) ncf) []), +{- +ascii_render_gate (CGateInv n w c ncf) = + "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +-} + do + string "CGate[" + name <- string_literal + string "]*(" + ws <- commalist int + char ')' + ncf <- nocontrolflag + eof + return (G (CGateInv name (head ws) (tail ws) ncf) []), +{- +ascii_render_gate (CSwap w1 w2 c ncf) = + "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "CSwap(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (CSwap w1 w2 cs ncf) wts), +{- +ascii_render_gate (QPrep w ncf) = + "QPrep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QPrep(" + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QPrep w ncf) []), +{- +ascii_render_gate (QUnprep w ncf) = + "QUnprep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QUnprep(" + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QUnprep w ncf) []), +{- +ascii_render_gate (QInit b w ncf) = + "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QInit" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QInit val w ncf) []), +{- +ascii_render_gate (CInit b w ncf) = + "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "CInit" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (CInit val w ncf) []), +{- +ascii_render_gate (QTerm b w ncf) = + "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QTerm" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QTerm val w ncf) []), +{- +ascii_render_gate (CTerm b w ncf) = + "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "CTerm" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (CTerm val w ncf) []), +{- +ascii_render_gate (QMeas w) = + "QMeas(" ++ show w ++ ")" +-} + do + string "QMeas(" + w <- int + char ')' + eof + return (G (QMeas w) []), +{- +ascii_render_gate (QDiscard w) = + "QDiscard(" ++ show w ++ ")" +-} + do + string "QDiscard(" + w <- int + char ')' + eof + return (G (QDiscard w) []), +{- +ascii_render_gate (CDiscard w) = + "CDiscard(" ++ show w ++ ")" +-} + do + string "CDiscard(" + w <- int + char ')' + eof + return (G (CDiscard w) []), +{- +ascii_render_gate (DTerm b w) = + "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" +-} + do + string "DTerm" + vc <- char '0' +++ char '1' + let b = case vc of + '0' -> False + '1' -> True + _ -> error "The impossible has happend" + char '(' + w <- int + char ')' + eof + return (G (DTerm b w) []), +{- +ascii_render_gate (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf) = + "Subroutine" ++ show_rep ++ "[" ++ show (string_of_boxid boxid) ++ "]" + ++ optional inv "*" + ++ " " + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list " -> (" "," ")" "()" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf + where + show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")" +-} +-- The parser returns a subroutine with dummy arities, and controllable flag, +-- and repeat flag, as +-- this information is not in a subroutine line in the ASCII output. +-- The information is added when the GatePlus is evaluated, as the first phase of +-- parsing will have collected the information. + do + string "Subroutine" + reps <- option 1 $ do + string "(x" + r <- int + char ')' + return (toInteger r) + char '[' + boxid <- box_id + char ']' + inv <- inversechar + string " (" + ws1 <- commalist int + string ") -> (" + ws2 <- commalist int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + let dummy = error "attempted evaluation of a dummy value" + return (G (Subroutine boxid inv ws1 dummy ws2 dummy cs ncf dummy (RepeatFlag reps)) wts), +{- +ascii_render_gate (Comment s inv ws) = + "Comment[" ++ show s ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws) +-} + do + string "Comment" + skipSpaces + char '[' + comment <- string_literal + char ']' + inv <- inversechar + ls <- labels + eof + return (G (Comment comment inv ls) []) + ] + +-- | The overall parsing function, reading a line of ASCII output, and +-- producing a 'GatePlus'. +parse_ascii_line :: String -> Maybe GatePlus +parse_ascii_line s = + case readP_to_S ascii_line s of + (h, _):_ -> Just h + _ -> Nothing + where + readline = do + skipSpaces + l <- ascii_line + skipSpaces + eof + return l + + diff --git a/Quipper/Libraries/Qureg.hs b/Quipper/Libraries/Qureg.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Qureg.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module provides a data type of quantum registers, as well as +-- associated types of classical and boolean registers. + +module Quipper.Libraries.Qureg ( + -- * Quantum registers + Qureg, + qureg_of_qulist_te, + qulist_of_qureg_te, + qureg_length, + qinit_register, + qterm_register, + qmeasure_register, + with_ancilla_reg, + with_ancilla_reg_init, + qureg_shape, + + -- * Bit registers + Bitreg, + bitreg_of_bitlist_te, + bitlist_of_bitreg_te, + bitreg_length, + + -- * Boolean registers + Boolreg, + boolreg_of_boollist_te, + boollist_of_boolreg_te, + boolreg_length, + boolreg_of_int_le, + int_of_boolreg_unsigned_le, + + -- * General registers + Register, + (.!) + + ) where + +import Quipper +import Quipper.Internal + +import Quipper.Utils.Auxiliary + +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import Data.Typeable + +-- ---------------------------------------------------------------------- +-- * Quantum registers + +-- ** General registers + +-- | A register is an array of elements of some type /x/, indexed by +-- natural numbers in the range from 0 to /n/-1, where /n/ is the +-- length of the register. +newtype Register x = Register { unRegister :: IntMap x } + deriving (Typeable, Show) + +-- | @/r/ !.(/i/)@: Return the /i/th element of a register /r/. +(.!) :: Register x -> Int -> x +a .!(i) = (unRegister a) IntMap.! i + +infixl 9 .! -- same precedence as !! + +-- | Convert a list to a register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +register_of_list_te :: [x] -> Register x +register_of_list_te l = Register $ IntMap.fromList (zip [n-1, n-2 .. 0] l) + where n = length l + +-- | Convert a register to a list. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +list_of_register_te :: Register x -> [x] +list_of_register_te r = map (r .!) [n-1, n-2 .. 0] + where n = register_length r + +-- | Return the length of a register. +register_length :: Register x -> Int +register_length = IntMap.size . unRegister + +-- ---------------------------------------------------------------------- +-- ** Qubit registers + +-- | The type of quantum registers. A quantum register is an array of +-- qubits, indexed by natural numbers in the range from 0 to /n/-1, +-- where /n/ is the length of the register. The syntax /a/ .!(/i/) is +-- used to access the /i/th element of the register /a/. +-- +-- The main advantage of a register over a list is constant-time +-- access. The main disadvantage is that registers don't allow easy +-- appending, pattern matching, or recursion. +type Qureg = Register Qubit + +-- | Convert a 'Qulist' to a 'Qureg'. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qureg_of_qulist_te :: Qulist -> Qureg +qureg_of_qulist_te = register_of_list_te + +-- | Convert a 'Qureg' to a 'Qulist'. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qulist_of_qureg_te :: Qureg -> Qulist +qulist_of_qureg_te = list_of_register_te + +-- | Return the length of a 'Qureg'. +qureg_length :: Qureg -> Int +qureg_length = register_length + +-- | Return a piece of shape data to represent an /m/-qubit quantum +-- register. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qureg_shape :: Int -> Qureg +qureg_shape m = qureg_of_qulist_te (replicate m qubit) + +-- ---------------------------------------------------------------------- +-- ** Bit registers + +-- | The type of 'Bit' registers. The syntax /a/ .!(/i/) is used to +-- access the /i/th element of the register /a/. +type Bitreg = Register Bit + +-- | Turn a bit vector into a bit register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +bitreg_of_bitlist_te :: Bitlist -> Bitreg +bitreg_of_bitlist_te = register_of_list_te + +-- | Turn a bit register into a bit vector. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +bitlist_of_bitreg_te :: Bitreg -> Bitlist +bitlist_of_bitreg_te = list_of_register_te + +-- | Return the length of a 'Bitreg'. +bitreg_length :: Bitreg -> Int +bitreg_length = register_length + +-- ---------------------------------------------------------------------- +-- ** Boolean registers + +-- | The type of boolean registers. +type Boolreg = Register Bool + +-- | Turn a bool vector into a bool register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +boolreg_of_boollist_te :: Boollist -> Boolreg +boolreg_of_boollist_te = register_of_list_te + +-- | Turn a bool register into a bool vector. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +boollist_of_boolreg_te :: Boolreg -> Boollist +boollist_of_boolreg_te = list_of_register_te + +-- | Return the length of a 'Boolreg'. +boolreg_length :: Boolreg -> Int +boolreg_length = register_length + +-- ---------------------------------------------------------------------- +-- * Special functions for quantum registers + +-- | Creates a new quantum register, initialized from a list of +-- booleans. The conversion is tail-endian, i.e., /r/.!(0) holds the +-- tail of the list. +qinit_register :: [Bool] -> Circ Qureg +qinit_register bs = do + qs <- qinit bs + return (qureg_of_qulist_te qs) + +-- | Terminates a quantum register, and assert that its state is as +-- specified by the list of booleans. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qterm_register :: [Bool] -> Qureg -> Circ () +qterm_register bs r = do + let qs = qulist_of_qureg_te r + qterm bs qs + +-- | Measure a quantum register, yielding a list of 'Bit's. +qmeasure_register :: Qureg -> Circ [Bit] +qmeasure_register r = + measure (qulist_of_qureg_te r) + +-- | Temporarily create a quantum register of size /n/ for use as an +-- ancilla. This can be used to introduce an ancilla with a local scope, like this: +-- +-- > with_ancilla_reg n $ \r -> do { +-- > <<>> +-- > } +with_ancilla_reg :: Int -> (Qureg -> Circ a) -> Circ a +with_ancilla_reg n f = do + let falselist = (take n $ repeat False) + q <- qinit_register falselist + a <- f q + qterm_register falselist q + return a + +-- | Like 'with_ancilla_reg', except also initialize the register as +-- specified by a bit vector. In this case, the argument /n/ is not +-- required, because it equals the length of the bit vector. When the +-- ancilla is terminated at the end of its scope, it is asserted to be +-- in the same state it was prepared in. +with_ancilla_reg_init :: Boollist -> (Qureg -> Circ a) -> Circ a +with_ancilla_reg_init v f = do + q <- qinit_register v + a <- f q + qterm_register v q + return a + +-- ---------------------------------------------------------------------- +-- * Special functions for boolean registers + +-- | @boolreg_of_int m x@: Initialize a bool register directly from an +-- integer /x/, regarded as a binary string of length /m/. The +-- conversion is little-endian, i.e., the register holds the least +-- significant digit at index 0. +boolreg_of_int_le :: Integral a => Int -> a -> Boolreg +boolreg_of_int_le m x = boolreg_of_boollist_te (boollist_of_int_bh m x) + +-- | @int_of_boolreg_unsigned_le m r@: Turn a bool register into an +-- integer, regarded as a binary string. The conversion is +-- little-endian, i.e., the register holds the least significant digit +-- at index 0. The integer is unsigned. +int_of_boolreg_unsigned_le :: Integral a => Boolreg -> a +int_of_boolreg_unsigned_le r = int_of_boollist_unsigned_bh (boollist_of_boolreg_te r) + +-- ---------------------------------------------------------------------- + +-- Make 'Qureg' an instance of 'QData' and 'QCData'. +type instance QCType x y Qureg = Register x +type instance QCType x y Bitreg = Register y +type instance QTypeB Boolreg = Qureg +instance QCData Qureg where + + qcdata_mapM shape f g (Register xs) = do + ys <- intmap_mapM f xs + return (Register ys) + + qcdata_zip shape q c q' c' (Register xs) (Register ys) e = (Register zs) where + zs = intmap_zip_errmsg xs ys (e "register length mismatch") + + qcdata_promote as xs e + | register_length as == register_length xs = as + | otherwise = error (e "register length mismatch") + +instance QCData Bitreg where + + qcdata_mapM shape f g (Register xs) = do + ys <- intmap_mapM g xs + return (Register ys) + + qcdata_zip shape q c q' c' (Register xs) (Register ys) e = (Register zs) where + zs = intmap_zip_errmsg xs ys (e "register length mismatch") + + qcdata_promote as xs e + | register_length as == register_length xs = as + | otherwise = error (e "register length mismatch") + +instance Labelable Qureg String where + label_rec (Register xs) s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] + +instance Labelable Bitreg String where + label_rec (Register xs) s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] diff --git a/Quipper/Libraries/Simulation.hs b/Quipper/Libraries/Simulation.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Simulation.hs @@ -0,0 +1,36 @@ +-- | This library provides functions for simulating certain classes of +-- circuits, for testing and debugging purposes. +-- +-- We can efficiently simulate classical (boolean) circuits and +-- Clifford (stabilizer) circuits. We also provide functions for +-- simulating arbitrary quantum circuits; however, the latter is +-- (necessarily) very inefficient. + +module Quipper.Libraries.Simulation ( + -- * Classical simulation + run_classical_generic, + + -- * Stabilizer simulation + run_clifford_generic, + + -- * Quantum simulation + run_generic, + run_generic_io, + sim_amps, + + -- * Special purpose functions + -- ** Simulation with trace + QuantumTrace (..), + run_generic_trace, + run_generic_trace_io, + + -- ** Probability distributions + Vector (..), + ProbabilityDistribution (..), + sim_generic, +) where + +import Quipper.Libraries.Simulation.ClassicalSimulation +import Quipper.Libraries.Simulation.QuantumSimulation +import Quipper.Libraries.Simulation.CliffordSimulation + diff --git a/Quipper/Libraries/Simulation/ClassicalSimulation.hs b/Quipper/Libraries/Simulation/ClassicalSimulation.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Simulation/ClassicalSimulation.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides functions for simulating certain classes of +-- circuits, for testing and debugging purposes. At the moment, the +-- only type of simulation we provide is boolean simulation. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.ClassicalSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, Simulation.hs uses low-level interfaces. It should be +-- re-implemented using only high-level interfaces, or in some cases, +-- more stuff should be exported from Quipper.hs. +import Quipper.Internal.Transformer (bind_list, bindings_empty, unbind_list, Bindings, transform_bcircuit_id) +import Quipper.Internal.Circuit (RepeatFlag(..), TypedSubroutine(..), OCircuit(..), reverse_ocircuit, ControllableFlag(..), BCircuit) +import Quipper.Internal.Generic (qc_bind, qc_unbind, encapsulate_generic) + +import Quipper.Utils.Auxiliary + +import Data.List +import qualified Data.Map as Map + +-- ====================================================================== +-- * Simulation of classical circuits + +-- | Auxiliary function: determine whether a \"control\" is true of false. +controls :: [Signed (B_Endpoint Bool Bool)] -> Bool +controls [] = True +controls ((Signed (Endpoint_Qubit c) b):t) = (c == b) && controls t +controls ((Signed (Endpoint_Bit c) b):t) = (c == b) && controls t + +-- | Auxiliary function: compute the boolean function corresponding to +-- a 'Quipper.Internal.Circuit.CGate' of the given name. +simulate_cgate :: String -> [Bool] -> Bool +simulate_cgate "if" [a,b,c] = if a then b else c +simulate_cgate "if" list = error ("simulate_cgate: \"if\" needs 3 arguments, not " ++ show (length list)) +simulate_cgate "and" list = and list +simulate_cgate "or" list = or list +simulate_cgate "xor" list = foldl' bool_xor False list +simulate_cgate "eq" [a,b] = (a == b) +simulate_cgate "eq" list = error ("simulate_cgate: \"eq\" needs 2 arguments, not " ++ show (length list)) +simulate_cgate "not" [a] = not a +simulate_cgate "not" list = error ("simulate_cgate: \"not\" needs 1 argument, not " ++ show (length list)) +simulate_cgate name list = error ("simulate_cgate: gate \"" ++ name ++ "\" not known") + + +-- | A "Quipper.Internal.Transformer" mapping each gate to the corresponding boolean +-- function. This will fail with an error for gates that don't act +-- within the computational basis, or if some assertion is not +-- met. Some gates are not yet implemented. + +simulate_classical :: Transformer Id Bool Bool + +-- Translation of classical gates: +simulate_classical (T_CNot ncf f) = f $ + \q c -> Id (if controls c then not q else q, c) +simulate_classical (T_CSwap ncf f) = f $ + \w v c -> Id (if controls c then (v,w,c) else (w,v,c)) +simulate_classical (T_CInit b ncf f) = f $ + Id b +simulate_classical (T_CTerm b ncf f) = f $ + \q -> Id (if b==q then () else error "simulate_classical: CTerm assertion not met") +simulate_classical (T_CDiscard f) = f $ + \b -> Id () +simulate_classical (T_DTerm b f) = f $ + \b -> Id () +simulate_classical (T_CGate name ncf f) = f $ + \list -> Id (simulate_cgate name list, list) +simulate_classical (T_CGateInv name ncf f) = f $ + \q list -> if q == simulate_cgate name list + then Id list + else error ("simulate_classical: CGateInv failed assertion " ++ show q ++ " == " ++ name ++ show list) + +-- Translation of quantum gates: +simulate_classical (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] c -> if controls c then Id([not q], [], c) else Id([q], [], c) +simulate_classical (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] c -> Id (if controls c then map not qs else qs, [], c) +simulate_classical (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w,v] [] c -> Id (if controls c then ([v,w], [], c) else ([w,v], [] ,c)) +simulate_classical g@(T_QGate "H" 1 0 _ _ _) = + error ("simulate_classical: gate not classical: " ++ show g) +simulate_classical g@(T_QGate "W" 2 0 _ _ _) = + error ("simulate_classical: gate not classical: " ++ show g) +simulate_classical g@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls c -> case (name, inv, qs, gctls) of + ("X", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + ("Y", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + ("Z", _, [q], []) -> Id([q], [], c) + ("S", _, [q], []) -> Id([q], [], c) + ("T", _, [q], []) -> Id([q], [], c) + ("omega", _, [q], []) -> Id([q], [], c) + ("iX", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + _ -> error ("simulate_classical: unimplemented gate: " ++ show g) +simulate_classical g@(T_QRot name _ _ inv t ncf f) = f $ + \qs gctls c -> case (name, inv, qs, gctls) of + ("R(2pi/%)", _, [q], []) -> Id([q], [], c) + ("exp(-i%Z)", _, [q], []) -> Id([q], [], c) + _ -> error ("simulate_classical: unimplemented gate: " ++ show g) +simulate_classical g@(T_GPhase t ncf f) = f $ + \q c -> Id c +simulate_classical (T_QInit b ncf f) = f $ + Id b +simulate_classical (T_QTerm b ncf f) = f $ + \q -> if b==q then Id() else error "simulate_classical: QTerm assertion not met" +simulate_classical (T_QDiscard f) = f $ + \b -> Id() +simulate_classical (T_Comment s inv f) = f $ + \b -> Id() + +-- Preparation, unpreparation, and measurement: +simulate_classical g@(T_QPrep ncf f) = f $ + \w -> Id w +simulate_classical g@(T_QUnprep ncf f) = f $ + \w -> Id w +simulate_classical g@(T_QMeas f) = f $ + \w -> Id w + +-- Subroutines: +simulate_classical g@(T_Subroutine sub inv ncf scf ws_pat a1_pat vs_pat a2_pat (RepeatFlag repeat) f) = f $ + \namespace in_values c -> Id $ + case Map.lookup sub namespace of + Just (TypedSubroutine sub_ocirc _ _ _) -> + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + in_bindings = bind_list in_wires in_values bindings_empty + out_bindings = + if (case scf of {AllCtl -> True; OnlyClassicalCtl -> True; NoCtl -> False}) + then if controls c then foldl' (\in_b _ -> run_classical (sub_circ, namespace) in_b) in_bindings [1..repeat] else in_bindings + else if length c == 0 + then foldl' (\in_b _ -> run_classical (sub_circ, namespace) in_b) in_bindings [1..repeat] + else error $ "simulate_classical: attempt to control non-controllable subroutine " ++ show sub + in (unbind_list out_bindings out_wires, c) + Nothing -> error $ "simulate_classical: subroutine " ++ show sub ++ " not found" + +-- If adding gates: remember to list any unimplemented gates +-- explicitly, so that the type-checker can warn about new gates that +-- must be added to the list. + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. This function makes use of the concept of a +-- /valuation/. A valuation is a partial map from circuit wires to +-- booleans, represented by the type @'Bindings' Bool@. Given a +-- circuit and a valuation for its inputs, the function +-- 'run_classical' produces a valuation for its outputs. +-- +-- The simulation will fail with an error if the circuit contains a +-- gate not acting within the computational basis, or if some +-- assertion is not met. Not all gates are currently +-- implemented. Subroutines are not currently implemented. +-- +run_classical :: BCircuit -> Bindings Bool Bool -> Bindings Bool Bool +run_classical = transform_bcircuit_id simulate_classical + +-- ====================================================================== +-- * Generic simulation + +-- | Like 'run_classical_unary', but also takes a stub error message. +run_classical_errmsg :: (QCData qa, QCData qb) => ErrMsg -> (qa -> Circ qb) -> BType qa -> BType qb +run_classical_errmsg e (f :: qa -> Circ qb) input = output where + shape = qcdata_makeshape (dummy :: qa) (dummy :: Bool) (dummy :: Bool) input + (qa, circuit, qb) = encapsulate_generic e f shape + valuation_in = qc_bind qa input + valuation_out = run_classical circuit valuation_in + output = qc_unbind valuation_out qb + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. Input a classical circuit, and output the corresponding +-- boolean function. This will fail with an error if the circuit +-- contains a gate not acting within the computational basis, or if +-- some assertion is not met. +run_classical_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> BType qb +run_classical_unary = run_classical_errmsg errmsg + where + errmsg x = "run_classical_unary: operation not currently permitted by simulator: " ++ x + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. Input a classical circuit, and output the corresponding +-- boolean function. This will fail with an error if the circuit +-- contains a gate not acting within the computational basis, or if +-- some assertion is not met. +-- +-- Unlike 'run_classical_unary', this can be applied to a +-- circuit-generating function in curried form with /n/ arguments, for +-- any /n/ ≥ 0. The resulting boolean function then will also have /n/ arguments. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > run_classical_generic :: (QCData qa) => Circ qa -> BType qa +-- > run_classical_generic :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> BType qb +-- > run_classical_generic :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> BType qa -> BType qb -> BType qc +-- +-- and so forth. + +run_classical_generic :: (QCData qa, QCData qb, QCurry qfun qa qb, Curry fun (BType qa) (BType qb)) => qfun -> fun +run_classical_generic f = g where + f1 = quncurry f + g1 = run_classical_errmsg errmsg f1 + g = mcurry g1 + errmsg x = "run_classical_generic: operation not currently permitted by simulator: " ++ x + diff --git a/Quipper/Libraries/Simulation/CliffordSimulation.hs b/Quipper/Libraries/Simulation/CliffordSimulation.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Simulation/CliffordSimulation.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides a Quipper interface to the efficient +-- simulation of Clifford group circuits, using the Stabilizer +-- formalism. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.CliffordSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, CliffordSimulation.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Generic (encapsulate_generic, qc_unbind) +import Quipper.Internal.Transformer (transform_bcircuit_rec, bindings_empty) + +import Quipper.Libraries.Simulation.QuantumSimulation (gateQinv, rotQinv) +import Quipper.Libraries.Simulation.ClassicalSimulation (simulate_cgate) + +import Quipper.Utils.Auxiliary +import qualified Quipper.Utils.Stabilizers.Clifford as C + +import Control.Monad.State (StateT) +import Data.Either + +-- ---------------------------------------------------------------------- +-- * The stabilizer transformer + +-- | The stabilizer transformer. Used to transform a Quipper circuit, +-- made up of Clifford group operators, directly into the 'C.CliffordCirc' +-- monad (where 'C.CliffordCirc' is a type-synonym for StateT Tableau IO). +-- Note that this transformer only deals with 1 and 2-qubit operators. +stabilizer_transformer :: Transformer (StateT C.Tableau IO) C.Qubit Bool +stabilizer_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + -- X and controlled-X are already provided by C.CliffordCirc + \[qt] [] c -> case control_info c of + None -> do + C.gate_X qt + return ([qt], [], c) + Classical b -> do + if b then C.gate_X qt else return () + return ([qt], [], c) + OneQuantum (Signed qc positive) b -> do + if not positive then C.gate_X qc else return () + if b then C.controlled_X qc qt else return () + if not positive then C.gate_X qc else return () + return ([qt], [], c) + _ -> error "stabilizer_transformer: Toffoli gate not available" +stabilizer_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + -- X and controlled-X are already provided by C.CliffordCirc + -- and can be mapped over a list of qubits + \ws [] c -> case control_info c of + None -> do + mapM_ C.gate_X ws + return (ws, [], c) + Classical b -> do + if b then mapM_ C.gate_X ws else return () + return (ws, [], c) + OneQuantum (Signed qc positive) b -> do + if not positive then C.gate_X qc else return () + if b then mapM_ (C.controlled_X qc) ws else return () + if not positive then C.gate_X qc else return () + return (ws, [], c) + _ -> error "stabilizer_transformer: (Multi) Toffoli gate not available" +stabilizer_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + -- Hadamard is already provided by C.CliffordCirc + \[qt] [] c -> case control_info c of + None -> do + C.gate_H qt + return ([qt], [], c) + Classical b -> do + if b then C.gate_H qt else return () + return ([qt], [], c) + -- TODO: ??? + _ -> error "stabilizer_transformer: controlled-Hadamard currently not supported" +stabilizer_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + -- (classically-controlled) swap is already provided by C.CliffordCirc + \[w, v] [] c -> case control_info c of + None -> do + C.swap w v + return ([w, v], [], []) + Classical b -> do + if b then C.swap w v else return () + return ([w, v], [], []) + _ -> error "stabilizer_transformer: quantum controlled-swap not available" +stabilizer_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + -- TODO: ??? + \[w, v] [] c -> error "stabilizer_transformer: W currently not supported" +stabilizer_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> + case vs of + [] -> + case ws of + [qt] -> case control_info c of + None -> do + C.gate_Unitary u1 qt + return ([qt], vs, c) + Classical b -> do + if b then C.gate_Unitary u1 qt else return () + return ([qt], vs, c) + OneQuantum (Signed qc positive) b -> do + if b then C.gate_Unitary2 u2 qc qt else return () + return ([qt], vs, c) + _ -> error "stabilizer_transformer: Multiple quantum controls not supported" + where u1 = case name of + "X" -> C.x + "Y" -> C.y + "Z" -> C.z + "S" -> C.s + "E" -> C.e + name -> C.from_matrix (gateQinv name inv) + u2 = case name of + "X" -> C.cnot + "Z" -> C.cz + name -> C.from_matrix_controlled (gateQinv name inv) + _ -> error "stabilizer_transformer: Named gates on multiple Qubits not available" + _ -> error "stabilizer_transformer: generalised controls not currently supported" +stabilizer_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> error "stabilizer_transformer: QRot not currently supported" --return (ws, vs, c) +stabilizer_transformer (T_GPhase t ncf f) = f $ + -- TODO: ??? + \qs c -> error "stabilizer_transformer: GPhase currently not supported" +stabilizer_transformer (T_CNot ncf f) = f $ + -- we can do a classical not depending on the controls + \q c -> case control_info c of + None -> return (not q,c) + Classical b -> if b then return (not q,c) else return (q,c) + _ -> error "stabilizer_transformer: Quantum control on classical gate" +stabilizer_transformer (T_CGate name ncf f) = f $ + -- we can reuse the classical simulator cgate implementation + \ws -> return (simulate_cgate name ws,ws) +stabilizer_transformer (T_CGateInv name ncf f) = f $ + -- we can check that the inverse is correct using the classical simulator cgate implementation + \v ws -> if (simulate_cgate name ws == v) then return ws else error "stabilizer_transformer: CGateInv not inverse" +stabilizer_transformer (T_CSwap ncf f) = f $ + -- we can do a classical swap depending on the controls + \w v c -> case control_info c of + None -> return (w,v,c) + Classical b -> if b then return (v,w,c) else return (w,v,c) + _ -> error "stabilizer_transformer: Quantum control on classical gate" +stabilizer_transformer (T_QPrep ncf f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: QPrep currently not supported" +stabilizer_transformer (T_QUnprep ncf f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: QUnprep currently not supported" +stabilizer_transformer (T_QInit b ncf f) = f $ + -- initialization is already provided by C.CliffordCirc + C.init_qubit b +stabilizer_transformer (T_CInit b ncf f) = f $ + -- initialisation of a boolean value + return b +stabilizer_transformer (T_QTerm b ncf f) = f $ + -- we can check termination conditions at runtime, using measurement + \w -> do + res <- C.measure_qubit w + if res == b then return () else error "stabilizer_transformer: QTerm condition failed" +stabilizer_transformer (T_CTerm b ncf f) = f $ + -- we can check termination conditions at runtime + \w -> if w == b then return () else error "stabilizer_transformer: CTerm condition failed" +stabilizer_transformer (T_QMeas f) = f $ + -- measurement is already provided by C.CliffordCirc + \w -> C.measure_qubit w +stabilizer_transformer (T_QDiscard f) = f $ + -- we can ignore discards + \w -> return () +stabilizer_transformer (T_CDiscard f) = f $ + -- we can ignore discards + \w -> return () +stabilizer_transformer (T_DTerm b f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: DTerm currently not supported" --return () +stabilizer_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + -- TODO: we can "open" subroutines + \namespace ws c -> error "stabilizer_transformer: Subroutine currently not supported" --return (ws,c) +stabilizer_transformer (T_Comment s inv f) = f $ + -- we can ignore comments + \ws -> return () + +-- | A datatype to represent controls that we can simulate +data ControlInfo = None | Classical Bool | OneQuantum (Signed C.Qubit) Bool | ManyQuantum + +-- | Construct an element of ControlInfo from a list of Controls. +control_info :: Ctrls C.Qubit Bool -> ControlInfo +control_info cs = case split_controls cs of + ([],[]) -> None + ([],cs) -> Classical (all_equal cs) + ([q],cs) -> OneQuantum q (all_equal cs) + _ -> ManyQuantum + where + split_controls :: Ctrls a b -> ([Signed a],[Signed b]) + split_controls cs = partitionEithers (map either_control cs) + either_control :: Signed (B_Endpoint a b) -> Either (Signed a) (Signed b) + either_control (Signed (Endpoint_Qubit a) value) = Left (Signed a value) + either_control (Signed (Endpoint_Bit b) value) = Right (Signed b value) + all_equal :: [Signed Bool] -> Bool + all_equal cs = and (map (\(Signed b val) -> b == val) cs) + +-- ---------------------------------------------------------------------- +-- * High-level functions + +-- | Use the 'stabilizer_transformer' to transform a Quipper circuit +-- into a 'C.CliffordCirc', ready for simulation. +toCliffordCirc :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> C.CliffordCirc (BType qb)) +toCliffordCirc (f :: qa -> Circ qb) input = do + let ((), circuit, cb) = encapsulate_generic errmsg (\() -> qc_init input >>= \qi -> f qi >>= \qi' -> qc_measure qi') () + out_bind' <- transform_bcircuit_rec stabilizer_transformer circuit bindings_empty + let out_bind = out_bind' + let output = qc_unbind out_bind cb + return output + where + errmsg x = ("simulate: " ++ x) + +-- | Return the tableau resulting from simulating the given Quipper +-- circuit. +eval_unary :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> IO C.Tableau) +eval_unary circ input = C.eval (toCliffordCirc circ input) + +-- | Efficiently simulate a unary Quipper circuit that consists +-- entirely of Clifford group operators, using the stabilizer +-- formalism. +run_clifford_unary :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> IO (BType qb)) +run_clifford_unary circ input = C.sim (toCliffordCirc circ input) + +-- | Efficiently simulate a Quipper circuit that consists entirely of +-- Clifford group operators, using the stabilizer formalism. +-- +-- Inputs a quantum circuit, and outputs a corresponding probabilistic +-- boolean function. The inputs to the quantum circuit are initialized +-- according to the given boolean arguments. The outputs of the +-- quantum circuit are measured, and the boolean measurement outcomes +-- are returned. Because the measurement outcomes are probabilistic, +-- this function takes place in the 'IO' monad. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > run_clifford_generic :: (QCData qa) => Circ qa -> IO (BType qa) +-- > run_clifford_generic :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> IO (BType qb) +-- > run_clifford_generic :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> BType qa -> BType qb -> IO (BType qc) +-- +-- and so forth. +run_clifford_generic :: (QCData qa, QCDataPlus qb, QCurry qfun qa qb, Curry qfun' (BType qa) (IO (BType qb))) => qfun -> qfun' +run_clifford_generic f = g where + f1 = quncurry f + g1 = run_clifford_unary f1 + g = mcurry g1 diff --git a/Quipper/Libraries/Simulation/QuantumSimulation.hs b/Quipper/Libraries/Simulation/QuantumSimulation.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Simulation/QuantumSimulation.hs @@ -0,0 +1,850 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} + +-- | This module provides functions for simulating circuits, +-- for testing and debugging purposes. +-- It borrows ideas from the implementation of the Quantum IO Monad. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.QuantumSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, QuantumSimulation.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit +import Quipper.Internal.Transformer +import Quipper.Internal.Monad (qubit_of_wire) +import Quipper.Internal.Generic (encapsulate_dynamic, qc_unbind) + +import Quipper.Utils.Auxiliary + +-- we use the state monad to hold our \"quantum\" state +import Control.Monad.State +-- we use complex numbers as our probability amplitudes +import Quantum.Synthesis.Ring (Cplx (..), i) +-- we use a random number generator to simulate \"quantum randomness\" +import System.Random hiding (split) +-- we store \"basis\" states as a map, +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.List (partition) + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +import qualified Debug.Trace -- used in tracing the simulation of quipper computations + +-- | We define our own trace function that only calls trace if the boolean +-- argument is true. +trace :: Bool -> String -> a -> a +trace False _ a = a +trace True message a = Debug.Trace.trace message a + +-- ====================================================================== +-- * Simulation as a Transformer + +-- $ The quantum simulator takes a Quipper circuit producing function, +-- and uses a transformer to simulate the resulting circuit, one gate at a time. +-- This allows the simulation to progress in a lazy manner, allowing dynamic +-- lifting results to be passed back to the circuit producing function as +-- and when they are required (to generate further gates in the circuit). + +-- $ The implementation of the quantum simulator makes use of a /State/ monad +-- to carry an underlying quantum state throughout the computation. This /State/ +-- is updated by each quantum operation within the circuit. A quantum +-- state is a vector of basis states, along with complex amplitudes. + +-- | Gates that act on a single qubit can be defined by essentially a 2-by-2 matrix. +-- A GateR is written by rows, such that a matrix: +-- +-- \[image GateR.png] +-- +-- would be written as (m00,m01,m10,m11). +type GateR r = (Cplx r,Cplx r, Cplx r, Cplx r) + +-- | Scalar multiplication of a 2-by-2 matrix by a given scalar. +scale :: (Floating r) => Cplx r -> GateR r -> GateR r +scale e (a,b,c,d) = (e*a,e*b,e*c,e*d) + +-- | The inverse of a 'GateR' is its conjugate transpose. +reverseR :: (Floating r) => GateR r -> GateR r +reverseR (m00,m01,m10,m11) = (conjugate m00, conjugate m10, conjugate m01, conjugate m11) + where + conjugate (Cplx a b) = Cplx a (-b) + +-- | A simple pattern matching function that gives each \"gate name\" +-- a /GateR/ representation. Adding (single qubit) quantum gates to +-- this function will give them an implementation in the +-- simulator. Any single qubit named quantum gate that needs to be +-- simulated must have a clause in this function, along with a given +-- /GateR/ that is its matrix representation. Note that unitarity is +-- not enforced, so defined gates must be checked manually to be +-- unitary operators. +-- +-- > Example Gates: +-- > gateQ "x" = (0,1,1,0) +-- > gateQ "hadamard" = (h, h, h,-h) where h = (1/sqrt 2) +gateQ :: (Floating r) => String -> GateR r +gateQ "x" = (0,1,1,0) +gateQ "hadamard" = (h, h, h,-h) where h = Cplx (1/sqrt 2) 0 +gateQ "X" = (0,1,1,0) +gateQ "Y" = (0,-i,i,0) +gateQ "Z" = (1,0,0,-1) +gateQ "S" = (1,0,0,i) +gateQ "E" = ((-1+i)/2, (1+i)/2, (-1+i)/2, (-1-i)/2) +gateQ "YY" = (h,i*h,i*h,h) where h = Cplx (1/sqrt 2) 0 +gateQ "T" = (1,0,0,omega) where omega = (Cplx (1 / sqrt 2) (1 / sqrt 2)) +gateQ "V" = scale 0.5 (a,b,b,a) where a = Cplx 1 (-1) + b = Cplx 1 1 +gateQ "omega" = (omega,0,0,omega) where omega = (Cplx (1 / sqrt 2) (1 / sqrt 2)) +gateQ "iX" = (0,i,i,0) +gateQ name = error ("quantum gate: " ++ name ++ " not implemented") + +-- | Like 'gateQ', but also conditionally invert the gate depending +-- on InverseFlag. +gateQinv :: (Floating r) => String -> InverseFlag -> GateR r +gateQinv name False = gateQ name +gateQinv name True = reverseR (gateQ name) + +-- | The exponential function for 'Cplx' numbers. +expC :: (Floating r) => Cplx r -> Cplx r +expC (Cplx a b) = Cplx (exp a * cos b) (exp a * sin b) + +-- | The constant π, as a complex number. +piC :: (Floating r) => Cplx r +piC = Cplx pi 0 + +-- | Like 'gateQ', but takes the name of a rotation and a real parameter. +rotQ :: (Floating r) => String -> Timestep -> GateR r +rotQ "exp(-i%Z)" theta = expZtR t + where t = fromRational (toRational theta) +rotQ "exp(% pi i)" theta = gPhase t + where t = fromRational (toRational theta) +rotQ "R(2pi/%)" theta = (1,0,0,expC (2*piC*i/t)) + where t = fromRational (toRational theta) +rotQ "T(%)" theta = (1,0,0,expC (-i*t)) + where t = fromRational (toRational theta) +rotQ "G(%)" theta = (expC (-i*t),0,0,expC (-i*t)) + where t = fromRational (toRational theta) +rotQ "Rz(%)" theta = (expC (-i*t/2),0,0,expC (i*t/2)) + where t = fromRational (toRational theta) +rotQ name theta = error ("quantum rotation: " ++ name ++ " not implemented") + +-- | Like 'rotQ', but also conditionally invert the gate depending on +-- InverseFlag. +rotQinv :: (Floating r) => String -> InverseFlag -> Timestep -> GateR r +rotQinv name False theta = rotQ name theta +rotQinv name True theta = reverseR (rotQ name theta) + +-- | Return the matrix for the 'expZt' gate. +expZtR :: (Floating r) => r -> GateR r +expZtR t = (expC (Cplx 0 (-t)),0,0,expC (Cplx 0 t)) + +-- | Return the matrix for the 'GPhase' gate. +gPhase :: (Floating r) => r -> GateR r +gPhase t = (expC (Cplx 0 (t * pi)),0,0,expC (Cplx 0 (t * pi))) + +-- | Translate a classical gate name into a boolean function. +-- Adding classical gates to this function will give them an implementation in +-- the simulator. +-- +-- > Example Gate: +-- > gateC "if" [a,b,c] = if a then b else c +gateC :: String -> ([Bool] -> Bool) +gateC "if" [a,b,c] = if a then b else c +gateC name inputs = error ("classical gate: " ++ name ++ ", not implemented (at least for inputs: " ++ show inputs ++ " )") + +-- | The type of vectors with scalars in /n/ over the basis /a/. A +-- vector is simply a list of pairs. +data Vector n a = Vector [(a,n)] + +-- | An amplitude distribution gives each classical basis state an amplitude. +type Amplitudes r = Vector (Cplx r) (Map Qubit Bool) + +-- | A probability distribution gives each element a probability. +type ProbabilityDistribution r a = Vector r a + +-- | A QuantumTrace is essentially a probability distribution for the current state +-- of the qubits that have been traced. We can represent this using a Vector. The +-- list of Booleans is in the same order as the list of Qubits that was being +-- traced. +type QuantumTrace r = ProbabilityDistribution r [Bool] + +-- | Normalizing is used to make sure the probabilities add up to 1. +normalize :: (Floating r) => QuantumTrace r -> QuantumTrace r +normalize (Vector xs) = Vector xs' + where + p' = Prelude.foldr (\(_,p) accum -> accum + p) 0.0 xs + xs' = map (\(bs,p) -> (bs,p / p')) xs + +-- | A 'QuantumState' is the data structure containing the state that we update +-- throughout the simulation. We need to keep track of the next available wire, +-- and a quantum state in the form of a distribution of basis states. We also +-- track a list of quantum traces, so that we have a \"tracing\" mechanism during +-- the execution of quantum circuits. +data QuantumState r = QState { + next_wire :: Wire, + quantum_state :: Amplitudes r, + traces :: [QuantumTrace r], -- this will be stored in the reverse order in which + -- the traces occured in the circuit. + namespace :: Namespace, -- we need a namespace to keep track of subroutines + trace_flag :: Bool -- whether or not we trace comments during the simulation + } + +-- | When we start a simulation, we need an empty starting state. +empty_quantum_state :: (Floating r) => Bool -> r -> QuantumState r +empty_quantum_state tf _ = QState { next_wire = 0, quantum_state = Vector [(Map.empty,1)], traces = [], namespace = namespace_empty, trace_flag = tf} + +-- | It doesn't make sense having a quantum control on a classical gate, so +-- we can throw an error if that is the case, and just collect the boolean +-- result otherwise. +classical_control :: Signed (B_Endpoint Qubit Bool) -> Bool +classical_control (Signed bep val) = case bep of + (Endpoint_Bit val') -> val == val' + (Endpoint_Qubit _) -> error "CNot: Quantum Control on Classical Gate" + +-- | Map the 'classical_control' function to all the controls, and take the +-- 'and' of the result +classical_controls :: Ctrls Qubit Bool -> Bool +classical_controls cs = and (map classical_control cs) + +-- | When we want a quantum control, we will be working with one \"basis state\" at +-- a time, and can look up the qubit's value in that basis state to see whether +-- the control firs. +qc_control :: Map Qubit Bool -> Signed (B_Endpoint Qubit Bool) -> Bool +qc_control mqb (Signed bep val) = case bep of + (Endpoint_Bit val') -> val == val' + (Endpoint_Qubit q) -> val == val' where val' = mqb Map.! q + +-- | Map the 'qc_control' function to all the controls (under the given basis +-- state), and take the 'and' of the result. +qc_controls :: Map Qubit Bool -> Ctrls Qubit Bool -> Bool +qc_controls mqb cs = and (map (qc_control mqb) cs) + +-- | We can calculate the magnitude of a complex number +magnitude :: (Floating r) => Cplx r -> r +magnitude (Cplx a b) = sqrt (a^2 + b^2) + +-- | The 'split' function splits a Amplitude distribution, by +-- partitioning it around the state of the given qubit within each basis state. It +-- also returns the probability of the qubit being True within the given +-- Amplitudes. This function is used when we want to measure a qubit. +split :: (Floating r, Eq r, Ord r) => Amplitudes r -> Qubit -> (r,Amplitudes r,Amplitudes r) +split (Vector pas) q = if p < 0 || p > 1 + then error "p < 0 or > 1" + else (p,Vector ift,Vector iff) + where + amp x = foldr (\(_,pa) p -> p + ((magnitude pa)*(magnitude pa))) 0 x + apas = amp pas + (ift,iff) = partition (\(mqb,_) -> (mqb Map.! q)) pas + p = if apas == 0 then 0 else (amp ift)/apas + +-- | A PMonad is a Monad enriched with a 'merge' function that takes a probability, +-- and two results, and returns a merged version of these results under the given +-- monad. This idea is taken directly from QIO. +class (Floating r, Monad m) => PMonad r m where + merge :: r -> a -> a -> m a + +-- | We can merge two measurement outcomes, and explicitly keep the first outcome +-- as the True result, and the second as the False result. +merge_with_result :: PMonad r m => r -> a -> a -> m (Bool,a) +merge_with_result p ift iff = merge p (True,ift) (False,iff) + +-- | IO forms a PMonad, where results are merged by choosing one probabilistically +-- using a random number. +instance (Floating r, Random r, Ord r) => PMonad r IO where + merge p ift iff = do + pp <- randomRIO (0,1) + let res = if p > pp then ift else iff + return res + +-- | A State Monad holding a 'RandomGen' forms a 'PMonad', where results are +-- merged by choosing one probabilistically using a random number from the +-- 'RandomGen'. +instance (Floating r, Random r, Ord r, RandomGen g) => PMonad r (State g) where + merge p ift iff = do + gen <- get + let (pp,gen') = randomR (0,1) gen + put gen' + let res = if p > pp then ift else iff + return res + +-- | Any numeric indexed vector forms a 'Monad'. +instance (Num n) => Monad (Vector n) where + return a = Vector [(a,1)] + (Vector ps) >>= f = Vector [(b,i*j) | (a,i) <- ps, (b,j) <- removeVector (f a)] where removeVector (Vector as) = as + +instance (Num n) => Applicative (Vector n) where + pure = return + (<*>) = ap + +instance (Num n) => Functor (Vector n) where + fmap = liftM + +-- | We can show certain vectors, ignoring any 0 probabilities, and +-- combining equal terms. +instance (Show a,Eq a,Num n,Eq n,Show n) => Show (Vector n a) where + show (Vector ps) = show (combine (filter (\ (a,p) -> p /= 0) ps) []) + where + combine [] as = as + combine (x:xs) as = combine xs (combine' x as) + combine' (a,p) [] = [(a,p)] + combine' (a,p) ((a',p'):xs) = if a == a' then (a,p+p'):xs else (a',p'):(combine' (a,p) xs) + +-- | 'ProbabilityDistribution' forms a 'PMonad' such that probabilistic results are +-- \"merged\" by extending the probability distribution by the possible results. +instance (Floating r, Eq r) => PMonad r (Vector r) where + merge 1 ift iff = Vector [(ift,1)] + merge 0 ift iff = Vector [(iff,1)] + merge p ift iff = Vector [(ift,p),(iff,1-p)] + +-- | The 'get_trace' function returns a probability distribution of +-- the state of a list of qubits within a given amplitude +-- distribution. +get_trace :: (Floating r) => [Qubit] -> Amplitudes r -> QuantumTrace r +get_trace qs (Vector amps) = Vector ps + where + ps = map (tracing qs) amps + tracing qs (mqb,cd) = (map (\q -> mqb Map.! q) qs,(magnitude cd)*(magnitude cd)) + +-- | Add an amplitude to an amplitude distribution, combining (adding) the amplitudes for equal states in the distribution. +add :: (Floating r) => ((Map Qubit Bool),Cplx r) -> Amplitudes r -> Amplitudes r +add (a,x) (Vector axs) = Vector (add' axs) + where add' [] = [(a,x)] + add' ((by @ (b,y)):bys) | a == b = (b,x+y):bys + | otherwise = by:(add' bys) + +-- | The apply' function is used to apply a function on \"basis states\" to an +-- entire amplitude distribution. +apply :: (Floating r, Eq r) => (Map Qubit Bool -> Amplitudes r) -> Amplitudes r -> Amplitudes r +apply f (Vector []) = Vector [] +apply f (Vector ((a,0):[])) = Vector [] +apply f (Vector ((a,x):[])) = Vector (map (\(b,k) -> (b,x*k)) (fa)) where Vector fa = f a +apply f (Vector ((a,0):vas)) = apply f (Vector vas) +apply f (Vector ((a,x):vas)) = foldr add (apply f (Vector vas)) (map (\(b,k) -> (b,x*k)) (fa)) where Vector fa = f a + +-- | Lift a function that returns a single basis state, to a function that +-- returns an amplitude distribution (containing a singleton). +vector :: (Floating r) => (Map Qubit Bool -> Map Qubit Bool) -> Map Qubit Bool -> Amplitudes r +vector f a = Vector [(f a,1)] + +-- | apply the given function only if the controls fire. +if_controls :: (Floating r) => Ctrls Qubit Bool -> (Map Qubit Bool -> Amplitudes r) -> Map Qubit Bool -> Amplitudes r +if_controls c f mqb = if (qc_controls mqb c) then f mqb else Vector [(mqb,1)] + +-- | 'performGateQ' defines how a single qubit gate is applied to a +-- quantum state. The application of a /GateR/ to a qubit in a single +-- basis state can split the state into a pair of basis states with +-- corresponding amplitudes. +performGateQ :: (Floating r) => GateR r -> Qubit -> Map Qubit Bool -> Amplitudes r +performGateQ (m00,m01,m10,m11) q mqb = if (mqb Map.! q) then (Vector [(Map.insert q False mqb,m01),(mqb,m11)]) + else (Vector [(mqb,m00),(Map.insert q True mqb,m10)]) + +-- | The 'simulation_transformer' is the actual transformer that does the +-- simulation. The type of the 'simulation_transformer' shows that Qubits are +-- kept as qubits, but Bits are turned into Boolean values, i.e., the results of +-- the computation. We use a StateT Monad, acting over the IO Monad, to store a +-- QuantumState throughout the simulation. This means we carry a state, but also +-- have access to the IO Monad's random number generator (for probabilistic +-- measurement). +simulation_transformer :: (PMonad r m, Ord r) => Transformer (StateT (QuantumState r) m) Qubit Bool +-- Translation of classical gates: +simulation_transformer (T_CNot ncf f) = f $ + \val c -> do + let ctrl = classical_controls c + let val' = if ctrl then not val else val + return (val',c) +simulation_transformer (T_CInit val ncf f) = f $ + return val +simulation_transformer (T_CTerm b ncf f) = f $ + \val -> if val == b then return () else error "CTerm: Assertion Incorrect" +simulation_transformer (T_CDiscard f) = f $ + \val -> return () +simulation_transformer (T_DTerm b f) = f $ + \val -> return () +simulation_transformer (T_CGate name ncf f) = f $ + \list -> do + let result = gateC name list + return (result,list) +simulation_transformer g@(T_CGateInv name ncf f) = f $ + \result list -> do + let result' = gateC name list + if result == result' then return list else error "CGateInv: Uncomputation error" +-- Translation of quantum gates: +simulation_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls cs (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q], [], cs) +simulation_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = foldr (\q a -> apply (if_controls cs (performGateQ gate q)) a) amps qs + put (state {quantum_state = amps'}) + return (qs, [], cs) +simulation_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> do + let gate = gateQ "hadamard" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls cs (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q], [], cs) +simulation_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w, v] [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gate v)) amps + let amps'' = apply (if_controls ((Signed (Endpoint_Qubit v) True):cs) (performGateQ gate w)) amps' + let amps''' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gate v)) amps'' + put (state {quantum_state = amps'''}) + return ([w, v], [], cs) +simulation_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w, v] [] cs -> do + let gateX = gateQ "x" + let gateH = gateQ "hadamard" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gateX v)) amps + let amps'' = apply (if_controls ((Signed (Endpoint_Qubit v) True):cs) (performGateQ gateH w)) amps' + let amps''' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gateX v)) amps'' + put (state {quantum_state = amps'''}) + return ([w, v], [], cs) +simulation_transformer (T_QGate "trace" _ _ False ncf f) = f $ + \qs gc c -> do + -- a \"trace\" gate adds the current probability distribution for the given qubits + -- to the list of previous quantum traces + state <- get + let current_traces = traces state + let amps = quantum_state state + let new_trace = get_trace qs amps + put (state {traces = new_trace:current_traces}) + return (qs,gc,c) +simulation_transformer (T_QGate "trace" _ _ True ncf f) = f $ + \qs gc c -> return (qs,gc,c) -- we don't do anything for the inverse \"trace\" gate +simulation_transformer (T_QGate name 1 0 inv ncf f) = f $ + \[q] [] c -> do + let gate = gateQinv name inv + state <- get + let amps = quantum_state state + let amps' = apply (if_controls c (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q],[],c) +simulation_transformer (T_QRot name 1 0 inv theta ncf f) = f $ + \[q] [] c -> do + let gate = rotQinv name inv theta + state <- get + let amps = quantum_state state + let amps' = apply (if_controls c (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q],[],c) +simulation_transformer (T_GPhase t ncf f) = f $ + \w c -> do + state <- get + let gate = rotQ "exp(% pi i)" t + let wire = next_wire state + let q = qubit_of_wire wire + let amps = quantum_state state + let amps' = apply (vector (Map.insert q False)) amps + let amps'' = apply (if_controls c (performGateQ gate q)) amps' + let (p,ift,iff) = split amps'' q + (val,ampsf) <- lift $ merge_with_result p ift iff + case val of + False -> do + let ampsf' = apply (vector (Map.delete q)) ampsf + put (state {quantum_state = ampsf'}) + return c + _ -> error "GPhase" +simulation_transformer (T_QInit val ncf f) = f $ + do + state <- get + let wire = next_wire state + let q = qubit_of_wire wire + let wire' = wire + 1 + let amps = quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + put (state {quantum_state = amps', next_wire = wire'}) + return q +simulation_transformer (T_QMeas f) = f $ + \q -> do + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + let amps'' = apply (vector (Map.delete q)) amps' + put (state {quantum_state = amps''}) + return val +simulation_transformer (T_QDiscard f) = f $ + \q -> do + -- a discard is essentially a measurement, with the result thrown away, so we + -- do that here, as it will reduce the size of the quantum state we are + -- simulating over. + state <- get + let (p,ift,iff) = split (quantum_state state) q + (_,amps) <- lift $ merge_with_result p ift iff + let amps' = apply (vector (Map.delete q)) amps + put (state {quantum_state = amps'}) + return () +simulation_transformer (T_QTerm b ncf f) = f $ + \q -> do + -- with a real quantum computer, when we terminate a qubit with an + -- assertion we have no way of actually checking the assertion. The + -- best we can do is measure the qubit and then throw an error if + -- the assertion is incorrect, which may only occur with a small + -- probability. Here, we could split the quantum state and see if + -- the qubit exists in the incorrect state with any non-zero + -- probability, and throw an error. However, we don't do this + -- because an error would sometimes be thrown due to rounding. + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + if val == b then put (state {quantum_state = amps'}) else error "QTerm: Assertion doesn't hold" +simulation_transformer (T_Comment "" inv f) = f $ + \_ -> return () + -- e.g. a comment can be (the) empty (string) if it only contains labels +simulation_transformer (T_Comment name inv f) = f $ + \_ -> do + state <- get + -- we don't need to do anything with a comment, but they can be useful + -- to know where we are in the circuit, so we shall output a trace of + -- the (non-empty) comments during a simulation. + trace (trace_flag state) name $ return () +-- The remaining gates are not yet implemented: +simulation_transformer g@(T_QGate _ _ _ _ _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_QRot _ _ _ _ _ _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_CSwap _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_QPrep ncf f) = f $ + \val -> do + state <- get + let wire = next_wire state + let q = qubit_of_wire wire + let wire' = wire + 1 + let amps = quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + put (state {quantum_state = amps', next_wire = wire'}) + return q +simulation_transformer g@(T_QUnprep ncf f) = f $ + \q -> do + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + put (state {quantum_state = amps'}) + return val +simulation_transformer g@(T_Subroutine sub inv ncf scf ws_pat a1_pat vs_pat a2_pat rep f) = f $ + \ns in_values c -> do + case Map.lookup sub ns of + Just (TypedSubroutine sub_ocirc _ _ _) -> do + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + let in_bindings = bind_list in_wires in_values bindings_empty + let sub_bcirc = (sub_circ,ns) + out_bind <- transform_bcircuit_rec simulation_transformer sub_bcirc in_bindings + return (unbind_list out_bind out_wires, c) + Nothing -> error $ "simulation_transformer: subroutine " ++ show sub ++ " not found (in " ++ showNames ns ++ ")" + +-- | The simulation_transformer is also Dynamic, as the simulated wire states +-- can simply be used to perform dynamic liftings. +simulation_dynamic_transformer :: (PMonad r m, Ord r) => DynamicTransformer (StateT (QuantumState r) m) Qubit Bool +simulation_dynamic_transformer = DT { + transformer = simulation_transformer, + define_subroutine = \name subroutine -> return (), + lifting_function = return + } + +-- | Apply the 'simulation_dynamic_transformer' to a (unary) circuit +-- generating function. +simulate_transform_unary :: (PMonad r m, Ord r) => (QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => (qa -> Circ qb) + -> BType qa + -> StateT (QuantumState r) m (QCType Qubit Bool (QCType Bit Bit qb)) +simulate_transform_unary (f :: qa -> Circ qb) input = do + let ((), circuit) = encapsulate_dynamic (\() -> qc_init input >>= \qi -> f qi >>= \qi' -> qc_measure qi') () + (cb,out_bind) <- transform_dbcircuit simulation_dynamic_transformer circuit bindings_empty + let output = qc_unbind out_bind cb + return output + +-- | In order to simulate a circuit using an input basis vector, we need to supply +-- each quantum leaf, with a concrete (i.e., not a dummy) qubit. +qdata_concrete_shape :: (QData qa) => BType qa -> qa +qdata_concrete_shape ba = evalState mqa 0 + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State Wire Qubit + f _ = do + w <- get + put (w+1) + return (qubit_of_wire w) + +-- | In order to simulate a circuit using an input basis vector, we need to supply +-- the transformer with a concrete set of qubit bindings. +qdata_concrete_bindings :: (QData qa) => BType qa -> Bindings Qubit Bool +qdata_concrete_bindings ba = snd $ execState mqa (0,bindings_empty) + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State (Wire,Bindings Qubit Bool) () + f b = do + (w,bindings) <- get + put (w+1,bind_qubit_wire w (qubit_of_wire w) bindings) + return () + +-- | As a helper function, in order to simulate a circuit using an input basis vector, +-- we need to be able to convert each basis into a map from concrete qubits to their +-- value in the given basis. +qdata_to_basis :: (QData qa) => BType qa -> Map Qubit Bool +qdata_to_basis ba = snd $ execState mqa (0,Map.empty) + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State (Wire,Map Qubit Bool) () + f b = do + (w,m) <- get + put (w+1,Map.insert (qubit_of_wire w) b m) + return () + +-- | In order to simulate a circuit using an input basis vector, we need to be able +-- to convert the basis vector into a quantum state suitable for use by the simulator +-- i.e. of type Amplitudes. +qdata_vector_to_amplitudes :: (QData qa, Floating r) => Vector (Cplx r) (BType qa) -> Amplitudes r +qdata_vector_to_amplitudes (Vector das) = (Vector (map (\(a,d) -> (qdata_to_basis a,d)) das)) + +-- | As a helper function, in order to simulate a circuit using an input basis vector, +-- we need to be able to convert a map from concrete qubits to their value into a basis +-- of the given concrete shape. +basis_to_qdata :: (QData qa) => qa -> Map Qubit Bool -> BType qa +basis_to_qdata qa m = getId $ qdata_mapM qa f qa + where + f :: Qubit -> Id Bool + f q = case Map.lookup q m of + Just res -> return res + _ -> error "basis_to_qdata: qubit not in scope" + +-- | In order to simulate a circuit using an input basis vector, we need to be able +-- to convert the quantum state (i.e. of type Amplitudes) into a basis vector. +amplitudes_to_qdata_vector :: (QData qa, Floating r) => qa -> Amplitudes r -> Vector (Cplx r) (BType qa) +amplitudes_to_qdata_vector qa (Vector das) = Vector (map (\(a,d) -> (basis_to_qdata qa a,d)) das) + +-- | Apply the 'simulation_dynamic_transformer' to a (unary) circuit generating +-- function, starting with the quantum state set to the given vector of base states +-- and returning the resulting vector of base states. +simulate_amplitudes_unary :: (PMonad r m, Eq r, Ord r, QData qa, QData qb, qb ~ QCType Qubit Bool qb) => (qa -> Circ qb) -> Vector (Cplx r) (BType qa) -> m (Vector (Cplx r) (BType qb)) +simulate_amplitudes_unary f input@(Vector is) = do + (out_shape,state) <- runStateT circ input_state + let out_amps = quantum_state state + return (amplitudes_to_qdata_vector out_shape (apply (vector id) out_amps)) + where + amps = qdata_vector_to_amplitudes input + specimen = case is of + [] -> error "simulate_amplitudes_unary: can't use empty vector" + ((b,_):_) -> b + shape = qdata_concrete_shape specimen + bindings = qdata_concrete_bindings specimen + max_wire = case wires_of_bindings bindings of + [] -> 0 + ws -> maximum ws + input_state = (empty_quantum_state False undefined) {quantum_state = amps, next_wire = max_wire + 1} + (_,circuit) = encapsulate_dynamic f shape + circ = do + (cb,out_bind) <- transform_dbcircuit simulation_dynamic_transformer circuit bindings + let output = qc_unbind out_bind cb + return output + +-- | Input a source of randomness, a quantum circuit, and an initial +-- state (represented as a map from basis vectors to amplitudes). +-- Simulate the circuit and return the final state. If the circuit +-- includes measurements, the simulation will be probabilistic. +-- +-- The type of this heavily overloaded function is difficult to +-- read. It has, for example, the following types: +-- +-- > sim_amps :: StdGen -> (Qubit -> Circ Qubit) -> Map Bool (Cplx Double) -> Map Bool (Cplx Double) +-- > sim_amps :: StdGen -> ((Qubit,Qubit) -> Circ Qubit) -> Map (Bool,Bool) (Cplx Double) -> Map Bool (Cplx Double) +-- +-- and so forth. Note that instead of 'Double', another real number +-- type, such as 'Data.Number.FixedPrec.FixedPrec' /e/, can be used. +sim_amps :: (RandomGen g, Floating r, Random r, Ord r, QData qa, QData qb, qb ~ QCType Qubit Bool qb, Ord (BType qb)) => g -> (qa -> Circ qb) -> Map (BType qa) (Cplx r) -> Map (BType qb) (Cplx r) +sim_amps gen f input_map = output_map + where + input_vec = Vector (Map.toList input_map) + circ = simulate_amplitudes_unary f input_vec + Vector output = evalState circ gen + output_map = Map.fromList output + +-- | Input a source of randomness, a real number, a circuit, and a +-- basis state. Then simulate the circuit probabilistically. Measure +-- the final state and return the resulting basis vector. +-- +-- The real number argument is a dummy and is never evaluated; its +-- only purpose is to specify the /type/ of real numbers that will be +-- used during the simulation. +run_unary :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => g -> r -> + (qa -> Circ qb) + -> BType qa + -> QCType Qubit Bool (QCType Bit Bit qb) +run_unary g r f input = evalState comp g where + comp = evalStateT f' (empty_quantum_state False r) + f' = simulate_transform_unary f input + +-- | Like 'run_unary', but return the list of 'QuantumTrace' elements +-- that were generated during the computation. This is useful for +-- checking the intermediary state of qubits within a computation. +run_unary_trace :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => g -> r -> + (qa -> Circ qb) + -> BType qa + -> [QuantumTrace r] +run_unary_trace g r f input = evalState comp g where + comp = do + state <- execStateT f' (empty_quantum_state True r) + let qts = traces state + return (reverse qts) + f' = simulate_transform_unary f input + +-- | Like 'run_unary', but run in the 'IO' monad instead of passing an +-- explicit source of randomness. +run_unary_io :: (Floating r, Random r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> IO (QCType Qubit Bool (QCType Bit Bit qb)) +run_unary_io r f input = do + g <- newStdGen + return (run_unary g r f input) + +-- | Like 'run_unary_trace', but run in the 'IO' monad instead of +-- passing an explicit source of randomness. +run_unary_trace_io :: (Floating r, Random r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> IO [QuantumTrace r] +run_unary_trace_io r f input = do + g <- newStdGen + return (run_unary_trace g r f input) + +-- | Apply the 'simulation_transformer' to a (unary) circuit, and then evaluate +-- the resulting stateful computation to get a probability distribution of possible +-- results +sim_unary :: (Floating r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> ProbabilityDistribution r (QCType Qubit Bool (QCType Bit Bit qb)) +sim_unary r f input = evalStateT f' (empty_quantum_state False r) + where f' = simulate_transform_unary f input + +-- ====================================================================== +-- * Generic functions + +-- ** Generic run function + +-- $ Generic functions to run Quipper circuits, using "Random" to +-- simulate quantum states. + +-- | Quantum simulation of a circuit, for testing and debugging +-- purposes. Input a source of randomness, a real number, and a +-- quantum circuit. Output a corresponding probabilistic boolean +-- function. +-- +-- The inputs to the quantum circuit are initialized according to the +-- given boolean arguments. The outputs of the quantum circuit are +-- measured, and the boolean measurement outcomes are +-- returned. +-- +-- The real number argument is a dummy and is never evaluated; its +-- only purpose is to specify the /type/ of real numbers that will be +-- used during the simulation. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa) => g -> r -> Circ qa -> BType qa +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb) => g -> r -> (qa -> Circ qb) -> BType qa -> BType qb +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData qc) => g -> r -> (qa -> qb -> Circ qc) -> BType qa -> BType qb -> BType qc +-- +-- and so forth. +run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (QCType Qubit Bool (QCType Bit Bit qb))) => g -> r -> qfun -> qfun' +run_generic gen r f = g + where + f1 = quncurry f + g1 = run_unary gen r f1 + g = mcurry g1 + +-- | Like 'run_generic', but also output a trace of the states of the +-- given list of qubits at each step during the evaluation. +run_generic_trace :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) [QuantumTrace r]) => g -> r -> qfun -> qfun' +run_generic_trace gen r f = g + where + f1 = quncurry f + g1 = run_unary_trace gen r f1 + g = mcurry g1 + +-- | Like 'run_generic', but run in the 'IO' monad instead of passing +-- an explicit source of randomness. +run_generic_io :: (Floating r, Random r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (IO (QCType Qubit Bool (QCType Bit Bit qb)))) => r -> qfun -> qfun' +run_generic_io r f = g + where + f1 = quncurry f + g1 = run_unary_io r f1 + g = mcurry g1 + +-- | Like 'run_generic_trace', but run in the 'IO' monad instead of +-- passing an explicit source of randomness. +run_generic_trace_io :: (Floating r, Random r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (IO [QuantumTrace r])) => r -> qfun -> qfun' +run_generic_trace_io r f = g + where + f1 = quncurry f + g1 = run_unary_trace_io r f1 + g = mcurry g1 + +-- ---------------------------------------------------------------------- +-- ** Generic sim function + +-- $ A generic function to simulate Quipper circuits, returning a +-- probability distribution of the possible results. + +-- | A generic function to simulate Quipper circuits, returning a +-- probability distribution of the possible results. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > sim_generic :: (Floating r, Ord r, QCData qa) => r -> Circ qa -> ProbabilityDistribution r (BType qa) +-- > sim_generic :: (Floating r, Ord r, QCData qa, QCData qb) => r -> (qa -> Circ qb) -> BType qa -> ProbabilityDistribution r (BType qb) +-- > sim_generic :: (Floating r, Ord r, QCData qa, QCData qb, QCData qc) => r -> (qa -> qb -> Circ qc) -> BType qa -> BType qb -> ProbabilityDistribution r (BType qc) +-- +-- and so forth. +sim_generic :: (Floating r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (ProbabilityDistribution r (QCType Qubit Bool (QCType Bit Bit qb)))) => r -> qfun -> qfun' +sim_generic r f = g where + f1 = quncurry f + g1 = sim_unary r f1 + g = mcurry g1 + diff --git a/Quipper/Libraries/Synthesis.hs b/Quipper/Libraries/Synthesis.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Synthesis.hs @@ -0,0 +1,502 @@ +{-# LANGUAGE DoAndIfThenElse #-} + +-- | A Quipper library for synthesizing Clifford+/T/ circuits directly +-- from a matrix description or Euler angle description of a unitary +-- operator. This library provides both exact and approximate +-- synthesis. + +module Quipper.Libraries.Synthesis where + +import Quipper + +import Quipper.Internal + +import Quantum.Synthesis.CliffordT +import Quantum.Synthesis.MultiQubitSynthesis +import Quantum.Synthesis.Ring +import Quantum.Synthesis.Matrix +import Quantum.Synthesis.Newsynth +import Quantum.Synthesis.SymReal +import Quantum.Synthesis.EulerAngles + +import Quipper.Utils.Auxiliary (boollist_of_int_bh) + +import Control.Monad (when) +import Data.Bits (xor, (.&.)) +import System.Random +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Precision + +-- | A type to measure precision. Precision is expressed as a number +-- /b/ of bits, i.e., binary digits, so that ε = 2[sup −/b/]. +type Precision = Double + +-- | Binary digits, as a unit of precision. For example, the following +-- specifies a precision of 20 binary digits: +-- +-- > prec = 20 * bits +bits :: Precision +bits = 1 + +-- | Decimal digits, as a unit of precision. For example, the +-- following specifies a precision of 30 decimal digits: +-- +-- > prec = 30 * digits +digits :: Precision +digits = logBase 2 10 + +-- ---------------------------------------------------------------------- +-- * Phase + +-- | A boolean flag indicating whether to respect global phases +-- during circuit synthesis ('True') or disregard them ('False'). +type KeepPhase = Bool + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Apply a gate (from the type 'Gate' of Clifford+/T/ operators) to +-- the given 'Qubit'. +apply_gate_at :: Gate -> Qubit -> Circ () +apply_gate_at X q = do + gate_X_at q +apply_gate_at Y q = do + gate_Y_at q +apply_gate_at Z q = do + gate_Z_at q +apply_gate_at H q = do + hadamard_at q +apply_gate_at S q = do + gate_S_at q +apply_gate_at T q = do + gate_T_at q +apply_gate_at E q = do + gate_E_at q +apply_gate_at W q = do + gate_omega_at q + +-- | Apply a gate list (from the type 'Gate' of Clifford+/T/ +-- operators) to the given 'Qubit'. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. +apply_gates_at :: [Gate] -> Qubit -> Circ () +apply_gates_at gates q = do + sequence_ [ apply_gate_at g q | g <- reverse gates ] + +-- | Like 'apply_gates_at', but apply the same list of gates to two +-- qubits in parallel. +apply_gates2_at :: [Gate] -> Qubit -> Qubit -> Circ () +apply_gates2_at gates q1 q2 = do + sequence_ [ do + apply_gate_at g q1 + apply_gate_at g q2 + | g <- reverse gates ] + +-- | Input two indices /i/ and /j/, a list of qubits /qlist/, and an +-- imperative-style single-qubit gate /U/. Apply the two-level +-- operator /U/[sub /i/,/j/] to /qlist/. Intended usage: +-- +-- > twolevel i j qlist gate_U_at +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- This function implements an improved version of Gray codes. +twolevel :: Index -> Index -> [Qubit] -> (Qubit -> Circ ()) -> Circ () +twolevel i j qlist body = aux l1 l2 qlist where + n = length qlist + l1 = boollist_of_int_bh n i + l2 = boollist_of_int_bh n j + + aux [] [] [] = error "twolevel: i=j" + aux (h1:t1) (h2:t2) (q:qs) + | h1 == h2 = + with_controls (q .==. h1) $ do + aux t1 t2 qs + | h1 == True = + with_basis_change (qnot_at q) $ do + aux2 t1 t2 q qs + | otherwise = + aux2 t1 t2 q qs + aux _ _ _ = error "twolevel: internal error 1" -- not reached + + aux2 [] [] q [] = + body q + aux2 (h1:t1) (h2:t2) q0 (q:qs) + | h1 == h2 = + with_controls (q .==. h1) $ do + aux2 t1 t2 q0 qs + | otherwise = + with_basis_change (qnot_at q `controlled` q0) $ do + with_controls (q .==. h1) $ do + aux2 t1 t2 q0 qs + aux2 _ _ _ _ = error "twolevel: internal error 2" -- not reached + +-- | Apply a /T/[sup /m/] gate. This gate is decomposed into /Z/, /S/, +-- /S/[sup †], /T/, and /T/[sup †] gates. +gate_T_power_at :: Int -> Qubit -> Circ () +gate_T_power_at 0 q = do + return () +gate_T_power_at 1 q = do + gate_T_at q +gate_T_power_at 2 q = do + gate_S_at q +gate_T_power_at 3 q = do + gate_S_at q + gate_T_at q +gate_T_power_at 4 q = do + gate_Z_at q +gate_T_power_at 5 q = do + gate_Z_at q + gate_T_at q +gate_T_power_at 6 q = do + gate_S_inv_at q +gate_T_power_at 7 q = do + gate_T_inv_at q +gate_T_power_at m q = gate_T_power_at (m `mod` 8) q + +-- | Apply a 'TwoLevel' gate to the given list of qubits. +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +apply_twolevel_at :: TwoLevel -> [Qubit] -> Circ () +apply_twolevel_at (TL_X i j) qlist = + twolevel i j qlist $ \q -> do + gate_X_at q +apply_twolevel_at (TL_H i j) qlist = + twolevel i j qlist $ \q -> do + hadamard_at q +apply_twolevel_at (TL_T m i j) qlist + | m `mod` 8 == 0 = return () + | otherwise = + twolevel i j qlist $ \q -> do + gate_T_power_at m q +apply_twolevel_at (TL_omega m i) qlist + | m' == 0 = do + return () + | qlist == [] = do + global_phase (fromIntegral m' * 0.25) + | otherwise = + apply_twolevel_at (TL_T m j i) qlist + where + j = if i == 0 then 1 else i .&. (i-1) + m' = m `mod` 8 + +-- | Apply a list of 'TwoLevel' gates to the given list of +-- qubits. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. + +-- Implementation note: this could be improved by combining +-- consecutive two-level gates if they share the same i and j +apply_twolevels_at :: [TwoLevel] -> [Qubit] -> Circ () +apply_twolevels_at ops qlist = + sequence_ [ apply_twolevel_at g qlist | g <- reverse ops ] + +-- | Like 'apply_twolevel_at', but use the alternate generators for +-- two-level gates. +apply_twolevel_alt_at :: TwoLevelAlt -> [Qubit] -> Circ () +apply_twolevel_alt_at (TL_iX j l) qlist = do + twolevel j l qlist $ \q -> do + gate_iX_at q +apply_twolevel_alt_at (TL_TiHT m j l) qlist = do + twolevel j l qlist $ \q -> do + let basischange = do + gate_T_power_at m q + gate_S_at q + gate_H_at q + gate_T_at q + with_basis_change basischange $ do + gate_iX_at q +apply_twolevel_alt_at (TL_W m j l) qlist + | m' == 0 = do + return () + | otherwise = do + twolevel j l qlist $ \q -> do + gate_iX_at q + let basischange = do + gate_T_power_at m' q + with_basis_change basischange $ do + gate_iX_inv_at q + where + m' = m `mod` 8 +apply_twolevel_alt_at (TL_omega_alt m j) qlist + | m' == 0 = do + return () + | qlist == [] = do + global_phase (fromIntegral m' * 0.25) + | otherwise = do + apply_twolevel_at (TL_T m l j) qlist + where + l = if j == 0 then 1 else j .&. (j-1) + m' = m `mod` 8 + +-- | Apply a list of 'TwoLevelAlt' gates to the given list of +-- qubits. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. + +-- Implementation note: this could be improved by combining +-- consecutive two-level gates if they share the same i and j +apply_twolevels_alt_at :: [TwoLevelAlt] -> [Qubit] -> Circ () +apply_twolevels_alt_at ops qlist = + sequence_ [ apply_twolevel_alt_at g qlist | g <- reverse ops ] + + +-- ---------------------------------------------------------------------- +-- * Single-qubit exact synthesis + +-- | Decompose the given operator exactly into a single-qubit +-- Clifford+/T/ circuit. The operator must be given in one of the +-- available exact formats, i.e., any instance of the 'ToGates' class. +-- Typical instances are: +-- +-- * 'U2' 'DOmega': a 2×2 unitary operator with entries from the ring +-- [bold D][ω] = ℤ[1\/√2, /i/]; +-- +-- * 'SO3' 'DRootTwo': a 3×3 Bloch sphere operator with entries from the +-- ring ℤ[1\/√2]. In this last case, the operator will be synthesized +-- up to an unspecified global phase. +exact_synthesis1 :: (ToGates a) => a -> Qubit -> Circ Qubit +exact_synthesis1 op q = do + comment_with_label "ENTER: exact_synthesis1" q "q" + apply_gates_at gates q + comment_with_label "EXIT: exact_synthesis1" q "q" + return q + where + gates = convert (normalize op) :: [Gate] + +-- ---------------------------------------------------------------------- +-- * Multi-qubit exact synthesis + +-- | Decompose the given operator exactly into a Clifford+/T/ circuit. +-- The operator must be given as an /n/×/n/-matrix with coefficients +-- in a ring that is an instance of the 'ToQOmega' class. A typical +-- example of such a ring is 'DOmega'. +-- +-- If this function is applied to a list of /m/ qubits, then we must +-- have /n/ ≤ 2[sup /m/]. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- The generated circuit contains no ancillas, but may contain +-- multi-controlled gates whose decomposition into Clifford+/T/ +-- generators requires ancillas. +exact_synthesis :: (ToQOmega a, Nat n) => Matrix n n a -> [Qubit] -> Circ [Qubit] +exact_synthesis op qlist = do + comment_with_label "ENTER: exact_synthesis" qlist "q" + apply_twolevels_at twolevels qlist + comment_with_label "EXIT: exact_synthesis" qlist "q" + return qlist + where + op_DOmega = matrix_map (to_dyadic . toQOmega) op + twolevels = synthesis_nqubit op_DOmega + +-- | Like 'exact_synthesis', but use the alternate algorithm from +-- Section 6 of Giles-Selinger. This means all but at most one of the +-- generated multi-controlled gates have determinant 1, which means +-- they can be further decomposed without ancillas. +exact_synthesis_alt :: (ToQOmega a, Nat n) => Matrix n n a -> [Qubit] -> Circ [Qubit] +exact_synthesis_alt op qlist = do + comment_with_label "ENTER: exact_synthesis_alt" qlist "q" + apply_twolevels_alt_at twolevels qlist + comment_with_label "EXIT: exact_synthesis_alt" qlist "q" + return qlist + where + op_DOmega = matrix_map (to_dyadic . toQOmega) op + twolevels = synthesis_nqubit_alt op_DOmega + +-- ---------------------------------------------------------------------- +-- * Single-qubit approximate synthesis + +-- ---------------------------------------------------------------------- +-- ** /z/-Rotations + +-- | Decompose an /R/[sub /z/](θ) = [exp −/i/θ/Z/\/2] gate into a +-- single-qubit Clifford+/T/ circuit up to the given precision. +-- +-- \[image Rz.png] +-- +-- The parameters are: +-- +-- * a precision /b/ ≥ 0; +-- +-- * an angle θ, given as a 'SymReal' value; +-- +-- * a source of randomness /g/. +approximate_synthesis_zrot :: (RandomGen g) => Precision -> SymReal -> g -> Qubit -> Circ Qubit +approximate_synthesis_zrot b theta g q = do + comment_with_label (printf "ENTER: approximate_synthesis_zrot (b=%.2f, theta=%s)" b (show theta)) q "q" + q <- without_comments $ do + exact_synthesis1 op q + comment_with_label "EXIT: approximate_synthesis_zrot" q "q" + return q + where + op = newsynth b theta g + +-- ---------------------------------------------------------------------- +-- ** Global phase gates + +-- | Construct a Clifford+/T/ circuit (with no inputs and outputs) +-- that approximates a scalar global phase gate [exp /i/θ] up to the +-- given precision. The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected. (Note that if this is set to 'False', then this function +-- is just a no-op); +-- +-- * a precision /b/ ≥ 0; +-- +-- * an angle θ, given as a 'SymReal' value; +-- +-- * a source of randomness /g/. +-- +-- We use the following decomposition: +-- +-- \[image phase.png] +approximate_synthesis_phase :: (RandomGen g) => KeepPhase -> Precision -> SymReal -> g -> Circ () +approximate_synthesis_phase False b theta g = do + return () +approximate_synthesis_phase True b theta g = do + comment (printf "ENTER: approximate_synthesis_phase (b=%.2f, theta=%s)" b (show theta)) + when (gates /= []) $ do + q <- qinit 0 + apply_gates_at gates q + qterm 0 q + comment "EXIT: approximate_synthesis_phase" + where + op = newsynth b (-2*theta) g + gates = convert (normalize op) :: [Gate] + +-- ---------------------------------------------------------------------- +-- ** /U/(2) from Euler angles + +-- | Decompose the operator +-- +-- * /U/ = [exp /i/α] R[sub /z/](β) R[sub /x/](γ) R[sub /z/](δ) +-- +-- into the Clifford+/T/ gate base, up to the given precision. +-- The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected. If this is 'False', the angle α is disregarded; +-- +-- * a precision /b/ ≥ 0; +-- +-- * a tuple of Euler angles (α, β, γ, δ), given as 'SymReal' values; +-- +-- * a source of randomness /g/. +approximate_synthesis_euler :: (RandomGen g) => KeepPhase -> Precision -> (SymReal, SymReal, SymReal, SymReal) -> g -> Qubit -> Circ Qubit +approximate_synthesis_euler keepphase b (alpha, beta, gamma, delta) g q = do + comment_with_label (printf "ENTER: approximate_synthesis_euler (b=%.2f, alpha=%s, beta=%s, gamma=%s, delta=%s, keepphase=%s)" b (show alpha) (show beta) (show gamma) (show delta) (show keepphase)) q "q" + without_comments $ do + exact_synthesis1 (op_beta * u2_H * op_gamma * u2_H * op_delta) q + approximate_synthesis_phase keepphase b' alpha g1 + comment_with_label "EXIT: approximate_synthesis_euler" q "q" + return q + where + op_beta = newsynth b' beta g2 + op_gamma = newsynth b' gamma g3 + op_delta = newsynth b' delta g4 + (g', g'') = split g + (g1, g2) = split g' + (g3, g4) = split g'' + b' = b + 2 -- ε' = ε / 4 + +-- ---------------------------------------------------------------------- +-- ** /U/(2) from matrix + +-- | Decompose a single-qubit unitary gate /U/ into the Clifford+/T/ +-- gate base, up to the given precision, provided that det /U/ = 1. +-- The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected; +-- +-- * a precision /b/ ≥ 0; +-- +-- * a 2×2 complex matrix, with entries expressed as 'Cplx' 'SymReal' values; +-- +-- * a source of randomness /g/. +approximate_synthesis_u2 :: (RandomGen g) => KeepPhase -> Precision -> U2 (Cplx SymReal) -> g -> Qubit -> Circ Qubit +approximate_synthesis_u2 keepphase b op g q = do + comment_with_label (printf "ENTER: approximate_synthesis_u2 (b=%.2f, op=%s, keepphase=%s)" b (show op) (show keepphase)) q "q" + q <- without_comments $ do + approximate_synthesis_euler keepphase b (alpha, beta, gamma, delta) g q + comment_with_label "EXIT: approximate_synthesis_u2" q "q" + return q + where + (alpha, beta, gamma, delta) = euler_angles op + +-- ---------------------------------------------------------------------- +-- ** Controlled gates + +-- | Decompose a controlled /R/[sub /z/](θ) = [exp −/i/θ/Z/\/2] gate +-- into a single-qubit Clifford+/T/ circuit up to the given +-- precision. The parameters are as for 'approximate_synthesis_phase'. +-- The first input is the target qubit, and the second input the +-- control. +-- +-- We use the following decomposition. It has lower /T/-count than the +-- alternatives and makes good use of parallelism. Since it uses the +-- same rotation twice, only a single run of the synthesis algorithm +-- is required. +-- +-- \[image controlled-zrot.png] +approximate_synthesis_zrot_ctrl :: (RandomGen g) => Precision -> SymReal -> g -> Qubit -> Qubit -> Circ Qubit +approximate_synthesis_zrot_ctrl b theta g q1 c2 = do + comment_with_label (printf "ENTER: approximate_synthesis_zrot_ctrl (b=%.2f, theta=%s)" b (show theta)) (q1,c2) ("q", "c") + qnot_at c2 `controlled` q1 .==. False + apply_gates2_at gates q1 c2 + qnot_at c2 `controlled` q1 .==. False + comment_with_label "EXIT: approximate_synthesis_zrot_ctrl" (q1,c2) ("q", "c") + return q1 + where + gates = convert (normalize op) :: [Gate] + op = newsynth (b+1) (theta/2) g + +-- | Decompose a controlled phase gate +-- +-- \[image controlled_phase.png] +-- +-- into the Clifford+/T/ gate base. The parameters are as for +-- 'approximate_synthesis_phase'. +-- +-- We use the following decomposition. It has lower /T/-count than the +-- alternatives and makes good use of parallelism. Since it uses the +-- same rotation twice, only a single run of the synthesis algorithm +-- is required. +-- +-- \[image controlled-phase-decomp.png] +-- +-- If the 'KeepPhase' flag is set, respect global phase; otherwise, +-- disregard it. +approximate_synthesis_phase_ctrl :: (RandomGen g) => KeepPhase -> Precision -> SymReal -> g -> Qubit -> Circ Qubit +approximate_synthesis_phase_ctrl keepphase b theta g q1 = do + comment_with_label (printf "ENTER: approximate_synthesis_phase_ctrl (b=%.2f, theta=%s keepphase=%s)" b (show theta) (show keepphase)) q1 "q" + if keepphase then do + q2 <- qinit True + apply_gates2_at gates q2 q1 + qterm True q2 + else do + approximate_synthesis_zrot b theta g q1 + return () + comment_with_label "EXIT: approximate_synthesis_phase_ctrl" q1 "q" + return q1 + where + gates = convert (normalize op) :: [Gate] + op = newsynth (b+1) theta g diff --git a/Quipper/Libraries/Unboxing.hs b/Quipper/Libraries/Unboxing.hs new file mode 100644 --- /dev/null +++ b/Quipper/Libraries/Unboxing.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE Rank2Types #-} + +-- | This library provides functions for “unboxing” hierarchical circuits, +-- replacing calls to named subroutines by inlined copies of the subroutines +-- themselves. + +module Quipper.Libraries.Unboxing where + +import Quipper +import Quipper.Internal +import Quipper.Internal.Circuit (BoxId (..), RepeatFlag (..)) +import Quipper.Internal.Monad (endpoints_of_wires_in_arity) +import Quipper.Internal.Generic (inline_subroutine, transform_unary) + +-- | A transformer to peel away one level of boxing. Transforms any +-- top-level subroutine gate into its corresponding circuit. +unbox_transformer :: Transformer Circ Qubit Bit +unbox_transformer (T_Subroutine name inv ncf _ _ _ ws2 a2 (RepeatFlag reps) f) = f $ + \namespace ws c -> do + outputs <- loopM reps ws + ((without_controls_if ncf) . + (with_controls c) . + ((if inv then flip reverse_generic (endpoints_of_wires_in_arity a2 ws2) else id) + (inline_subroutine name namespace))) + return (outputs, c) +unbox_transformer x = identity_transformer x + +-- | Peel away one level of boxing from a circuit. Transforms any +-- top-level subroutine gate into its corresponding circuit. +unbox_unary :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +unbox_unary circ = transform_unary unbox_transformer circ + +-- | Peel away one level of boxing from a circuit. Transforms any +-- top-level subroutine gate into its corresponding circuit. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox :: (QCData x) => Circ x -> Circ x +-- > unbox :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +-- > unbox :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> (x -> y -> Circ z) +-- +-- and so forth. +unbox :: (QCData x, QCData y, QCurry qfun x y) => qfun -> qfun +unbox = qcurry . unbox_unary . quncurry + +-- | A transformer to recursively unbox some specified class of boxed subroutines. +unbox_recursive_filtered_transformer :: (BoxId -> Bool) -> Transformer Circ Qubit Bit +unbox_recursive_filtered_transformer p b@(T_Subroutine boxid inv ncf _ _ _ ws2 a2 (RepeatFlag reps) f) = + if not (p boxid) + then identity_transformer b + else f $ + \namespace ws c -> do + outputs <- loopM reps ws + ((without_controls_if ncf) . + (with_controls c) . + ((if inv then flip reverse_generic (endpoints_of_wires_in_arity a2 ws2) else id) $ + (unbox_recursive_filtered p) $ + (inline_subroutine boxid namespace))) + return (outputs, c) +unbox_recursive_filtered_transformer _ x = identity_transformer x + +-- | Recursively unbox all subroutines satisfying a given predicate. +unbox_recursive_filtered_unary :: (QCData x, QCData y) => (BoxId -> Bool) -> (x -> Circ y) -> (x -> Circ y) +unbox_recursive_filtered_unary p = transform_unary (unbox_recursive_filtered_transformer p) + +-- | Recursively unbox all subroutines satisfying a given predicate. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox_recursive_filtered :: (QCData x) => (BoxId -> Bool) -> Circ x -> Circ x +-- > unbox_recursive_filtered :: (QCData x, QCData y) => (BoxId -> Bool) -> (x -> Circ y) -> (x -> Circ y) +-- +-- and so forth. +unbox_recursive_filtered :: (QCData x, QCData y, QCurry qfun x y) => (BoxId -> Bool) -> qfun -> qfun +unbox_recursive_filtered p = qcurry . (unbox_recursive_filtered_unary p) . quncurry + +-- | Recursively unbox all subroutines of a circuit. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox_recursive :: (QCData x) => Circ x -> Circ x +-- > unbox_recursive :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +-- > unbox_recursive :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> (x -> y -> Circ z) +-- +-- and so forth. +unbox_recursive :: (QCData x, QCData y, QCurry qfun x y) => qfun -> qfun +unbox_recursive = unbox_recursive_filtered (const True) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +import Distribution.Simple +import Distribution.Superdoc +import Quipper.Distribution.Preprocessor + +-- The following is needed because of an incompatible change in Cabal 2. +#if MIN_VERSION_Cabal(2,0,0) +wrap x = \_ _ _ -> x +#else +wrap x = \_ _ -> x +#endif + +main = defaultMainWithHooks superdocHooks { + hookedPreProcessors = [("hs", wrap ppQuipper)] + } diff --git a/dist/build/Quipper/Libraries/Arith.hs b/dist/build/Quipper/Libraries/Arith.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Arith.hs @@ -0,0 +1,1760 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Arith.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This library provides a type of quantum integers, as well as +-- basic arithmetic functions on them. +-- +-- The type 'QDInt' holds a fixed-size, ℓ-qubit quantum integer, +-- considered modulo 2[sup ℓ]. The integers may be regarded as +-- signed or unsigned, depending on the operation. If signs are used, +-- they are assumed to be in two's complement. +-- +-- Some of the arithmetic operations are adapted from the GFI for the +-- Triangle Finding algorithm. Most algorithms used are, for now, very +-- naïve (ripple adders, etc). Gate count estimates are given in the +-- Toffoli gatebase. + +-- Documentation note: the table of contents is organized slightly +-- differently than the source code. The guiding idea is that the +-- documentation should expose the interface that is accessible to +-- user-level code, and changeable implementation details are hidden. + +module Quipper.Libraries.Arith ( + -- * Quantum integers + -- ** Data type definitions + -- $DATATYPES + XInt, -- constructors not exported + QDInt, + CInt, + IntM, + -- ** Operations on QDInt + qulist_of_qdint_bh, + qdint_of_qulist_bh, + qulist_of_qdint_lh, + qdint_of_qulist_lh, + qdint_length, + qdint_extend_unsigned, + qdint_extend_signed, + -- ** Operations on CInt + bitlist_of_cint_bh, + cint_of_bitlist_bh, + bitlist_of_cint_lh, + cint_of_bitlist_lh, + cint_length, + cint_extend_unsigned, + cint_extend_signed, + -- ** Operations on IntM + -- $INTMCLASSES + boollist_of_intm_bh, + intm_of_boollist_bh, + intm_length, + integer_of_intm_unsigned, + integer_of_intm_signed, + intm_with_length, + intm_of_integer, + intm, + intm_promote, + intm_interval_signed, + intm_interval_unsigned, + intm_extend_unsigned, + intm_extend_signed, + -- ** Shape parameters + qdint_shape, + cint_shape, + -- ** Operations on XInt + xint_maybe_length, + list_of_xint_bh, + xint_of_list_bh, + list_of_xint_lh, + xint_of_list_lh, + -- * Quantum arithmetic operations + -- ** The QNum type class + QNum(..), + -- ** In-place increment and decrement + q_increment, + q_decrement, + -- ** In-place addition and subtraction + q_add_in_place, + q_sub_in_place, + q_negate_in_place, + -- ** Arithmetic with classical parameter + q_add_param, + q_sub_param, + q_add_param_in_place, + q_sub_param_in_place, + q_mult_param, + -- ** Comparison + q_le_unsigned, + q_le_signed, + q_lt_signed, + q_negative, + -- ** Division and remainder + q_moddiv_unsigned_in_place, + q_mod_unsigned, + q_divrem_unsigned, + q_div_unsigned, + q_div, + q_quot, + q_div_exact_unsigned, + q_div_exact, + -- ** Specialized functions + q_ext_euclid, + -- * Lifting of arithmetic functions + -- $LIFTING + template_symb_plus_, + ) where + +import Quipper +import Quipper.Internal + +import Quipper.Utils.Sampling +import Quipper.Utils.Auxiliary + +import Control.Monad +import Data.Typeable + +-- ====================================================================== +-- * Quantum integers + +-- ** Data type definitions + +-- $DATATYPES +-- We define three versions of the fixed-length integer type: quantum, +-- classical input, and classical parameter. The triple ('IntM', +-- 'QDInt', 'CInt') forms an instance of the 'QShape' class. All three +-- types are special cases of the type 'XInt' /x/. + +-- | 'XInt' /x/ is the type of fixed-length integers, but using +-- elements of type /x/ instead of bits. It is an abstract type, and +-- details of its implementation is not exposed to user-level code. + +-- Implemenation notes: The integer types are currently implemented as +-- big-headian bit lists. However, the details of the implementation +-- are not exposed to user-level code, and are subject to change. +-- +-- The form ('XInt_indet' /n/ /id/) is permitted as a special case, to +-- represent an integer of indeterminate length. Such a value can only +-- be used when the length is deducible from the context. This form is +-- only allowed in the special case /x/ = 'Bool', and we use an +-- identity type to enforce this. +-- +-- Integers of indeterminate length may only be used in certain +-- operations where the shape information is available from other +-- data. It can be used, for example, for terminating or controlling a +-- 'QDInt', but not for initializing a 'QDInt'. +data XInt x = XInt [x] | XInt_indet Integer (Identity Bool x) + deriving (Show, Typeable) + +-- | The type of fixed-length /m/-qubit quantum integers. This is a +-- circuit execution time value. +type QDInt = XInt Qubit + +instance Show QDInt where + show (XInt l) = "#" ++ show l + show (XInt_indet n id) = error "IntM: internal error" + +-- A better implementation might be something like: +-- show (XInt l) = "qdint_of_qulist_bh " ++ show l +-- However, as 'CInt' and 'QDInt' are currently synonyms, it seems best +-- to keep the instance agnostic between them, while still distinguishing +-- them somehow from naked lists. + +-- | The type of fixed-length /m/-bit classical integer inputs. This +-- is a circuit execution time value. +type CInt = XInt Bit + +-- Currently, 'CInt' is literally a synonym of 'QDInt', since 'Qubit' is +-- a synonym of 'Bit'. If this changes, the following instance will be +-- required: +-- +-- instance Show CInt where +-- show (XInt l) = show l +-- show (XInt_indet n id) = error "IntM: internal error" + +-- | The type of fixed-length /m/-bit integer parameters. Values of +-- this type are parameters, i.e., they are classical and known at +-- circuit generation time. +-- +-- Unlike values of type 'QDInt' and 'CInt', a value of type 'IntM' +-- may have an indeterminate length. This happens, for example, if the +-- value is specified by means of an integer literal (e.g., 17), which +-- does not carry length information. In such cases, the value can +-- only be used when it can be deduced from the context. For example, +-- such values may be used for terminating or controlling a 'QDInt', +-- but not for initializing a 'QDInt'. +type IntM = XInt Bool + +instance Show IntM where + show (XInt l) = "intm " ++ show (length l) ++ " " ++ show (int_of_boollist_signed_bh l) + show (XInt_indet n id) = show n + +-- Note: for the purpose of forming intervals, we regard 'IntM' as an +-- /unsigned/ type. This disagrees with the 'Enum' instance, where +-- 'IntM' is regarded as a /signed/ type. So for example, when /x/ = +-- 'intm' 4 (-2) = 'intm' 4 14 and /y/ = 'intm' 4 10, then [/x/../y/] +-- and 'interval' /y/ /x/ are non-empty, but [/y/../x/] and 'interval' +-- /x/ /y/ are empty. +-- +-- This is confusing but for the time being there is no better +-- alternative, unless we create distinct signed and unsigned types. + +instance Interval IntM where + interval x y = intm_interval_unsigned x y + +instance Zero IntM where + zero x = intm_with_length (intm_length x) 0 + +-- ---------------------------------------------------------------------- +-- ** Primitive combinators on XInt + +-- $ 'XInt' is intended to be an abstract data type, and all access to +-- it should pass through the three access functions of this +-- section. + +-- *** Constructors + +-- | Create a 'XInt' /x/ from a list of /x/s. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +xint_of_list_bh :: [x] -> XInt x +xint_of_list_bh xs = XInt xs + +-- | Create an 'IntM' of indeterminate length from an 'Integer'. +intm_of_integer :: Integer -> IntM +intm_of_integer n = XInt_indet n reflexivity + +-- *** Destructor + +-- | If the 'XInt' is of determinate length, return its list of digits +-- as a big-headian list, i.e., the head of the list holds the most +-- significant digit. If the 'XInt' is of indeterminate length, return +-- (/n/, /id/), where /n/ is the underlying 'Integer' and /id/ is the +-- witness proving that /x/ = 'Bool'. +-- +-- This is a lowest-level access function not intended to be used by +-- user-level code. +xint_case :: XInt x -> Either [x] (Integer, Identity Bool x) +xint_case (XInt xs) = Left xs +xint_case (XInt_indet n id) = Right (n, id) + +-- ---------------------------------------------------------------------- +-- ** Other low-level operations + +-- $ The operations in this section are the only ones intended to use +-- 'xint_case' directly. + +-- | Set the length of an 'XInt' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +-- +-- Note that if /x/ ≠ 'Bool', the input is guaranteed to have +-- determinate length. However, we cannot test for equality of types +-- in a polymorphic function. This is where the 'id' argument to +-- 'XInt_indet' is used. +xint_set_length :: Int -> XInt x -> String -> XInt x +xint_set_length m x errmsg | m < 0 = + error "xint_set_length: negative length not permitted" +xint_set_length m x errmsg = + case xint_case x of + Left xs | m == length xs -> x + | otherwise -> error errmsg + Right (n, id) -> XInt xs where + xs = [ identity id b | b <- boollist_of_int_bh m n ] + +-- | Return 'True' if the 'XInt' is of determinate length, and 'False' +-- if it is of indeterminate length. +xint_is_determinate :: XInt x -> Bool +xint_is_determinate x = + case xint_case x of + Left _ -> True + Right _ -> False + +-- | From a 'XInt', which must be of determinate length, extract a +-- list of /x/s. The conversion is big-headian, i.e., the head of the +-- list holds the most significant digit. It is an error to call this +-- function with an 'XInt' of indeterminate length. +list_of_xint_bh :: XInt x -> [x] +list_of_xint_bh x = + case xint_case x of + Left xs -> xs + Right _ -> error "list_of_xint_bh: integer has indeterminate length" + +-- | Return the size of a 'XInt', or 'Nothing' if indeterminate. +xint_maybe_length :: XInt x -> Maybe Int +xint_maybe_length x = + case xint_case x of + Left xs -> Just (length xs) + Right _ -> Nothing + +-- | Convert an 'IntM' of length /m/ to an 'Integer' in the range {0, +-- …, 2[sup /m/]-1}. If the 'IntM' has indeterminate length, return the +-- original 'Integer'. +integer_of_intm_unsigned :: IntM -> Integer +integer_of_intm_unsigned x = + case xint_case x of + Left xs -> int_of_boollist_unsigned_bh xs + Right (n, id) -> n + +-- | Convert an 'IntM' of length /m/ to an 'Integer' in the range +-- {-2[sup /m/-1], …, 2[sup /m/-1]-1}. If the 'IntM' has indeterminate +-- length, return the original 'Integer'. +integer_of_intm_signed :: IntM -> Integer +integer_of_intm_signed x = + case xint_case x of + Left xs -> int_of_boollist_signed_bh xs + Right (n, id) -> n + +-- | Equality test. If at least one argument has determinate length, +-- test equality modulo 2[sup /m/]. If both have indeterminate length, +-- check equality of the underlying integers. +xint_equals :: (Eq x) => XInt x -> XInt x -> Bool +xint_equals x y = + case (xint_case x, xint_case y) of + (Left xs, Left ys) + | length xs == length ys -> xs == ys + | otherwise -> error "Equality test on XInt: operands must be of equal length" + (_, Left ys) -> xint_equals (xint_set_length m x "xint_equals") y + where m = length ys + (Left xs, _) -> xint_equals x (xint_set_length m y "xint_equals") + where m = length xs + (Right (n, _), Right (n', _)) -> n == n' + +-- ---------------------------------------------------------------------- +-- ** Derived operations on XInt + +-- | Get the nominal length of an integer (in bits). It is an error to +-- apply this function to an integer of indeterminate length. +xint_length :: XInt x -> Int +xint_length x = + case xint_maybe_length x of + Just m -> m + Nothing -> error "xint_length: integer has indeterminate length" + +-- | Convert an integer to a bit list. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +list_of_xint_lh :: XInt x -> [x] +list_of_xint_lh = reverse . list_of_xint_bh + +-- | Convert a bit list to an integer. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +xint_of_list_lh :: [x] -> XInt x +xint_of_list_lh = xint_of_list_bh . reverse + +-- | Extend a 'XInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to /zero/. It is an error to call this +-- function when the new length is shorter than the old one. +xint_extend_unsigned :: (Monad m) => Int -> m x -> XInt x -> m (XInt x) +xint_extend_unsigned len zero x + | len < m = + error "pad_xint: requested length is shorter than current length" + | otherwise = do + pad <- sequence (replicate extra zero) + return $ xint_of_list_bh (pad ++ digits) + where + digits = list_of_xint_bh x + m = length digits + extra = len - m + +-- | Extend a 'XInt' to the given length without changing its (signed) +-- value. This is done by adding the required number of high bits +-- initialized to copies of the sign bit (or to /zero/ if the original +-- integer was of length 0). It is an error to call this function when +-- the new length is shorter than the old one. +xint_extend_signed :: (Monad m) => Int -> m x -> (x -> m x) -> XInt x -> m (XInt x) +xint_extend_signed len zero copy x + | len < m + = error "pad_xint: requested length is shorter than current length" + | m == 0 + = xint_extend_unsigned len zero x + | otherwise = do + pad <- sequence (replicate extra (copy sign)) + return $ xint_of_list_bh (pad ++ digits) + where + digits = list_of_xint_bh x + m = length digits + extra = len - m + sign = head digits + +-- ---------------------------------------------------------------------- +-- ** Operations on IntM + +-- | Return the size of an 'IntM', or 'Nothing' if indeterminate. +intm_length :: IntM -> Maybe Int +intm_length = xint_maybe_length + +-- | Convert an 'IntM' to a list of booleans. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. As usual, 'False' is 0 and 'True' is 1. It is an error to +-- apply this operation to an 'IntM' whose length is indeterminate. +boollist_of_intm_bh :: IntM -> [Bool] +boollist_of_intm_bh = list_of_xint_bh + +-- | Convert a boolean list to an 'IntM'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +intm_of_boollist_bh :: [Bool] -> IntM +intm_of_boollist_bh = xint_of_list_bh + +-- | Create an 'IntM' of the specified length (first argument) and +-- value (second argument). +intm :: Int -> Integer -> IntM +intm m n = intm_set_length m (intm_of_integer n) "intm: internal error" + +-- | Set the length of an 'IntM' to /m/ ≥ 0. This operation is only +-- legal if the input (a) has indeterminate length or (b) has +-- determinate length already equal to /m/. In particular, it cannot +-- be used to change the length from anything other than from +-- indeterminate to determinate. (Use 'intm_extend_unsigned' or +-- 'intm_extend_signed' to increase a determinate length). +-- +-- If both arguments already have determinate lengths, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. +intm_set_length :: Int -> IntM -> String -> IntM +intm_set_length = xint_set_length + +-- | Extend an 'IntM' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +intm_extend_unsigned :: Int -> IntM -> IntM +intm_extend_unsigned len x = + getId $ xint_extend_unsigned len (return False) x + +-- | Extend an 'IntM' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +intm_extend_signed :: Int -> IntM -> IntM +intm_extend_signed len x = + getId $ xint_extend_signed len (return False) (return) x + +-- ---------------------------------------------------------------------- +-- ** Operations on CInt + +-- | Convert a 'CInt' to a list of qubits. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +bitlist_of_cint_bh :: CInt -> [Bit] +bitlist_of_cint_bh = list_of_xint_bh + +-- | Convert a list of qubits to a 'CInt'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +cint_of_bitlist_bh :: [Bit] -> CInt +cint_of_bitlist_bh = xint_of_list_bh + +-- | Convert a 'CInt' to a list of bits. The conversion is +-- little-headian, i.e., the head of the list holds the least +-- significant digit. +bitlist_of_cint_lh :: CInt -> [Bit] +bitlist_of_cint_lh = list_of_xint_lh + +-- | Convert a list of bits to a 'CInt'. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +cint_of_bitlist_lh :: [Bit] -> CInt +cint_of_bitlist_lh = xint_of_list_lh + +-- | Return the length of a 'CInt', in bits. +cint_length :: CInt -> Int +cint_length = xint_length + +-- | Extend a 'CInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +cint_extend_unsigned :: Int -> CInt -> Circ CInt +cint_extend_unsigned len x = + xint_extend_unsigned len (cinit False) x + +-- | Extend a 'CInt' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +cint_extend_signed :: Int -> CInt -> Circ CInt +cint_extend_signed len x = + xint_extend_signed len (cinit False) (qc_copy) x + +-- ---------------------------------------------------------------------- +-- ** Operations on QDInt + +-- | Convert a 'QDInt' to a list of qubits. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +qulist_of_qdint_bh :: QDInt -> [Qubit] +qulist_of_qdint_bh = list_of_xint_bh + +-- | Convert a list of qubits to a 'QDInt'. The conversion is +-- big-headian, i.e., the head of the list holds the most significant +-- digit. +qdint_of_qulist_bh :: [Qubit] -> QDInt +qdint_of_qulist_bh = xint_of_list_bh + +-- | Convert a 'QDInt' to a list of qubits. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +qulist_of_qdint_lh :: QDInt -> [Qubit] +qulist_of_qdint_lh = list_of_xint_lh + +-- | Convert a list of qubits to a 'QDInt'. The conversion is +-- little-headian, i.e., the head of the list holds the least significant +-- digit. +qdint_of_qulist_lh :: [Qubit] -> QDInt +qdint_of_qulist_lh = xint_of_list_lh + +-- | Return the length of a 'QDInt', in bits. +qdint_length :: QDInt -> Int +qdint_length = xint_length + +-- | Extend a 'QDInt' to the given length without changing its +-- (unsigned) value. This is done by adding the required number of +-- high bits initialized to 0. It is an error to call this function +-- when the new length is shorter than the old one. +qdint_extend_unsigned :: Int -> QDInt -> Circ QDInt +qdint_extend_unsigned len x = + xint_extend_unsigned len (qinit False) x + +-- | Extend a 'QDInt' to the given length without changing its +-- (signed) value. This is done by adding the required number of +-- high bits initialized to copies of the sign bit. It is an error to +-- call this function when the new length is shorter than the old one. +qdint_extend_signed :: Int -> QDInt -> Circ QDInt +qdint_extend_signed len x = + xint_extend_signed len (qinit False) (qc_copy) x + +-- ---------------------------------------------------------------------- +-- ** Shape parameters + +-- | Return a piece of shape data to represent an /m/-qubit quantum +-- integer. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qdint_shape :: Int -> QDInt +qdint_shape m = xint_of_list_bh (replicate m qubit) + +-- | Return a piece of shape data to represent an /m/-bit 'CInt'. +-- Please note that the data can only be used as shape; it will be +-- undefined at the leaves. +cint_shape :: Int -> CInt +cint_shape m = xint_of_list_bh (replicate m bit) + +-- ====================================================================== +-- ** Type class instances + +-- Note: instance declarations do not show up in the documentation + +-- | Input the lengths of two inputs to a binary operation, and return +-- the common length. If one length is indeterminate, return the other; +-- if both are indeterminate, return 'Nothing'; if both are determinate but +-- not equal, throw an error with the given error message. +combine_length :: String -> Maybe Int -> Maybe Int -> Maybe Int +combine_length s Nothing m = m +combine_length s m Nothing = m +combine_length s (Just m) (Just m') | m == m' = Just m + | otherwise = error s + +-- | Try to set the length of an 'IntM' to that of another 'XInt' +-- value (which could be a 'QDInt', a 'CInt', or another 'IntM'). This +-- will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. +intm_promote :: IntM -> XInt x -> String -> IntM +intm_promote bi xi errmsg = + case xint_maybe_length xi of + Nothing -> bi + Just m -> intm_set_length m bi errmsg + +type instance QCType x y (XInt z) = XInt (QCType x y z) +type instance QTypeB IntM = QDInt + +instance QCLeaf x => QCData (XInt x) where + qcdata_mapM shape f g xs = + mmap xint_of_list_bh $ qcdata_mapM (list_of_xint_bh shape) f g (list_of_xint_bh xs) + qcdata_zip shape q c q' c' xs ys e = + xint_of_list_bh $ qcdata_zip (list_of_xint_bh shape) q c q' c' (list_of_xint_bh xs) (list_of_xint_bh ys) (const $ e "XInt length mismatch") + qcdata_promote b q e = intm_promote b q (e "IntM length mismatch") + +-- Labeling of QDInt is s[m-1], ..., s[0], with the least significant +-- bit at index 0. +instance QCLeaf x => Labelable (XInt x) String where + label_rec qa = label_rec (list_of_xint_lh qa) + +instance CircLiftingUnpack (Circ QDInt) (Circ QDInt) where + pack x = x + unpack x = x + +-- ====================================================================== +-- * Classical arithmetic on 'IntM' + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | A useful auxiliary function that converts a list of 'IntM's to a +-- list of 'Integer's, while also returning their common length. All +-- arguments whose length is not indeterminate must have the same common +-- length. If the lengths don't match, throw an error with the error +-- message specified by the 'String' argument. +integers_of_intms_signed :: [IntM] -> String -> (Maybe Int, [Integer]) +integers_of_intms_signed xs s = (m, is) where + m = foldl (combine_length s) Nothing [ intm_length x | x <- xs ] + is = [ integer_of_intm_signed x | x <- xs ] + +-- | Like 'integers_of_intms_signed', but regards the 'IntM's as +-- unsigned integers. +integers_of_intms_unsigned :: [IntM] -> String -> (Maybe Int, [Integer]) +integers_of_intms_unsigned xs s = (m, is) where + m = foldl (combine_length s) Nothing [ intm_length x | x <- xs ] + is = [ integer_of_intm_unsigned x | x <- xs ] + +-- | Create an 'IntM' of the given length and value. Leave the length +-- indeterminate if it is given as 'Nothing'. +intm_with_length :: Maybe Int -> Integer -> IntM +intm_with_length (Just m) n = intm m n +intm_with_length Nothing n = intm_of_integer n + +-- | Auxiliary function for lifting a binary operator from 'Integer' +-- to 'IntM'. The string argument is the name of the operator, for +-- error messages. +intm_binop :: (Integer -> Integer -> Integer) -> String -> IntM -> IntM -> IntM +intm_binop op opname x y = intm_with_length m (op x' y') where + (m, [x',y']) = integers_of_intms_signed [x, y] ("Binary operation " ++ opname ++ " on IntM: operands must be of equal length") + +-- | Auxiliary function for lifting a unary operator from 'Integer' to +-- 'IntM'. +intm_unop :: (Integer -> Integer) -> IntM -> IntM +intm_unop op x = intm_with_length xm (op x') where + xm = intm_length x + x' = integer_of_intm_signed x + +-- ---------------------------------------------------------------------- +-- ** Type class instances + +-- $INTMCLASSES +-- +-- 'IntM' is an instance of Haskell's 'Eq', 'Num', 'Ord', 'Real', +-- 'Enum', and 'Integral' type classes. This means that integer +-- literals (e.g., 17), and the usual arithmetic functions, such as +-- '+', '-', '*', 'abs', 'succ', 'pred', 'mod', 'div', and others, can +-- be used for values of type 'IntM'. In general, we treat 'IntM' as a +-- signed integer type. Use 'fromIntegral' to convert an integer to an +-- 'IntM' of indeterminate length. +-- +-- The general convention for binary operations (such as +-- multiplication) is: both operands must have the same length, +-- except: if one operand has indeterminate length, it takes on the +-- length of the other; if both operands have indeterminate length, the +-- result will have indeterminate length. + +instance Eq x => Eq (XInt x) where + x == y = xint_equals x y + +instance Num IntM where + (+) = intm_binop (+) "+" + (*) = intm_binop (*) "*" + (-) = intm_binop (-) "-" + abs = intm_unop abs + signum = intm_unop signum + fromInteger = intm_of_integer + +instance Ord IntM where + compare x y = compare (toInteger x) (toInteger y) + +instance Real IntM where + toRational = toRational . integer_of_intm_signed + +instance Enum IntM where + succ = intm_unop succ + pred = intm_unop pred + toEnum = intm_of_integer . fromIntegral + fromEnum = fromIntegral . integer_of_intm_signed + enumFrom x = map (intm_with_length m) [x'..] where + (m, [x']) = integers_of_intms_signed [x] "enumeration: IntM" + enumFromThen x y = map (intm_with_length m) [x',y'..] where + (m, [x',y']) = integers_of_intms_signed [x,y] "enumeration: IntM operands must be of equal length" + enumFromTo x y = map (intm_with_length m) [x'..y'] where + (m, [x',y']) = integers_of_intms_signed [x,y] "enumeration: IntM operands must be of equal length" + enumFromThenTo x y z = map (intm_with_length m) [x',y'..z'] where + (m, [x',y',z']) = integers_of_intms_signed [x,y,z] "enumeration: IntM operands must be of equal length" + +-- | Return the interval @[/x/../y/]@, with /x/ and /y/ regarded as +-- signed values of type 'IntM'. +intm_interval_signed :: IntM -> IntM -> [IntM] +intm_interval_signed x y = [x..y] -- this comes from the 'Enum' instance defined above + +-- | Return the interval @[/x/../y/]@, with /x/ and /y/ regarded as +-- unsigned values of type 'IntM'. +intm_interval_unsigned :: IntM -> IntM -> [IntM] +intm_interval_unsigned x y = map (intm_with_length m) [x'..y'] where + (m, [x',y']) = integers_of_intms_unsigned [x,y] "intm_interval: operands must be of equal length" + +instance Integral IntM where + toInteger = integer_of_intm_signed + quotRem x y = (intm_with_length m q', intm_with_length m r') where + (m, [x',y']) = integers_of_intms_signed [x, y] "Division on IntM: operands must be of equal length" + (q',r') = quotRem x' y' + +-- ====================================================================== +-- * Quantum arithmetic on 'QDInt' + +-- Developer note: each quantum arithmetic function is implemented by +-- an underlying low-level function operating on qubit lists. However, +-- these lower-level functions are *not* exported. If any module needs +-- them, it should define them explicitly using 'qulist_of_qdint_bh' +-- and 'qdint_of_qulist_bh'. In particular, the low-level functions +-- may not perform error checking if it is already performed by their +-- high-level counterparts. + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | @'common_value' error_str [n1,n2,n3]@: if /n1/, /n2/, /n3/ all equal, return this value; else throw an error. Useful for checking that sizes of 'QDInt's match. +common_value :: (Eq a) => String -> [a] -> a +common_value _ [] = error "common_value: no inputs given" +common_value _ [n] = n +common_value error_str (n:ns) = if common_value error_str ns == n then n else error error_str + +-- | @'common_length' error_str [x1,x2,x3]@: if /x1/, /x2/, /x3/ all have the same length, return this value; else throw an error. +common_length :: String -> [QDInt] -> Int +common_length error_str xs = common_value error_str $ map qdint_length xs + +-- ---------------------------------------------------------------------- +-- ** Incrementing and decrementing + +-- | Increment a 'QDInt' in place. /O/(ℓ) gates. +-- +-- Implementation note: currently tries to minimize gate count, at the cost of a rather long Quipper description. Can the latter be reduced without increasing the former? +q_increment :: QDInt -> Circ QDInt +q_increment = mmap xint_of_list_bh . q_increment_qulist . list_of_xint_bh + +-- | Low-level implementation of 'q_increment': represents integers as +-- big-headian qubit lists. +q_increment_qulist :: [Qubit] -> Circ [Qubit] +q_increment_qulist [] = return [] +q_increment_qulist [x_0] = do x_0 <- qnot x_0; return [x_0] +q_increment_qulist [x_1,x_0] = do x_0 <- qnot x_0; x_1 <- qnot x_1 `controlled` (x_0 .==. 0); return [x_1,x_0] +q_increment_qulist [x_2,x_1,x_0] = do + x_0 <- qnot x_0 + x_1 <- qnot x_1 `controlled` (x_0 .==. 0) + x_2 <- qnot x_2 `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + return [x_2,x_1,x_0] +q_increment_qulist x_bits = do + let x_0 = last x_bits + x_1 = last $ init x_bits + x_higher = init $ init $ x_bits + x_0 <- qnot x_0 + x_1 <- qnot x_1 `controlled` (x_0 .==. 0) + (x_higher,x_1,x_0) <- with_ancilla (\c -> do + c <- qnot c `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + (c,rev_x_higher) <- q_increment_qulist_aux c (reverse x_higher) + c <- qnot c `controlled` (x_0 .==. 0) .&&. (x_1 .==. 0) + return (reverse rev_x_higher, x_1, x_0)) + return (x_higher ++ [x_1,x_0]) + where + -- increment a LITTLE-endian bit-string, controlled by a single qubit. + q_increment_qulist_aux :: Qubit -> [Qubit] -> Circ (Qubit,[Qubit]) + q_increment_qulist_aux b [] = return (b,[]) + q_increment_qulist_aux b [x_0] = + do x_0 <- qnot x_0 `controlled` b; return (b,[x_0]) + q_increment_qulist_aux b [x_0,x_1] = do + x_0 <- qnot x_0 `controlled` b + x_1 <- qnot x_1 `controlled` b .&&. (x_0 .==. 0) + return (b,[x_0,x_1]) + q_increment_qulist_aux b (x_0:x_higher) = do + x_0 <- qnot x_0 `controlled` b + (b,x_0,x_higher) <- with_ancilla (\c -> do + c <- qnot c `controlled` b .&&. (x_0 .==. 0) + (c,x_higher) <- q_increment_qulist_aux c x_higher + c <- qnot c `controlled` b .&&. (x_0 .==. 0) + return (b,x_0,x_higher)) + return (b, (x_0:x_higher)) + +-- | Decrement a 'QDInt' in place. Inverse of 'q_increment'. /O/(ℓ). +q_decrement :: QDInt -> Circ QDInt +q_decrement = reverse_generic_endo q_increment + +-- ---------------------------------------------------------------------- +-- ** Addition and subtraction + +-- | Add two 'QDInt's into a fresh one. Arguments are assumed to be of equal size. /O/(ℓ) gates, both before and after transformation to Toffoli. +q_add_qdint :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_add_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_add_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_add_qdint': represents integers as +-- big-headian qubit lists. +q_add_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_add_qulist x y = do + let l = length x + when (l /= length y) $ do + error "q_add_qdint: cannot add QDInts of different lengths" + + ((x,y),s_out) <- with_computed_fun (x,y) + (\(x,y) -> do + s <- qinit (replicate l False) -- holds the eventual sum + c <- qinit (replicate l False) -- holds the carries + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + (x,y,s,c) <- loop_with_indexM (l-1) (x,y,s,c) (\j (x,y,s,c) -> do + let c_j1 = c !! (j+1) + let s_j = s !! j + -- If any two of the current bits x_j, y_j, and the carry c_j are true, then set the next carry: + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. y!!j) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. c!!j) + c_j1 <- qnot c_j1 `controlled` (y!!j .&&. c!!j) + -- Now the current sum digit is computed mod 2: + s_j <- qnot s_j `controlled` (x!!j) + s_j <- qnot s_j `controlled` (y!!j) + s_j <- qnot s_j `controlled` (c!!j) + c <- return $ overwriteAt (j+1) c_j1 c + s <- return $ overwriteAt j s_j s + + return (x,y,s,c)) + + -- Final sum digit; no carry required: + let s_l1 = s !! (l-1) + s_l1 <- qnot s_l1 `controlled` (x!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (y!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (c!!(l-1)) + s <- return $ overwriteAt (l-1) s_l1 s + + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + return (x,y,s,c)) + + (\(x,y,s,c) -> do + (s,s_out) <- qc_copy_fun s + return ((x,y,s,c), s_out)) + return (x, y, s_out) + +-- | Subtract two 'QDInt's, into a fresh one. Arguments are assumed to be of equal size. /O/(ℓ). +q_sub_qdint :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_sub_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_sub_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_sub_qdint': represents integers as +-- big-headian qubit lists. +q_sub_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_sub_qulist x y = do + let l = length x + when (l /= length y) $ do + error "q_sub_qdint: cannot subtract QDInts of different lengths" + + ((x,y),d_out) <- with_computed_fun (x,y) + (\(x,y) -> do + d <- qinit (replicate l False) -- holds the eventual difference + b <- qinit (replicate l False) -- holds the borrows + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + d <- return $ reverse d + b <- return $ reverse b + + (x,y,d,b) <- loop_with_indexM (l-1) (x,y,d,b) (\j (x,y,d,b) -> do + let b_j1 = b !! (j+1) + let d_j = d !! j + -- If any two of (not x_j), y_j, and the borrow c_j hold, then set the next borrow. + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + b_j1 <- qnot b_j1 `controlled` (x!!j .==. 0) .&&. (y!!j .==. 1) + b_j1 <- qnot b_j1 `controlled` (x!!j .==. 0) .&&. (b!!j .==. 1) + b_j1 <- qnot b_j1 `controlled` (y!!j .==. 1) .&&. (b!!j .==. 1) + -- Now the current difference digit is computed mod 2: + d_j <- qnot d_j `controlled` (x!!j) + d_j <- qnot d_j `controlled` (y!!j) + d_j <- qnot d_j `controlled` (b!!j) + b <- return $ overwriteAt (j+1) b_j1 b + d <- return $ overwriteAt j d_j d + return (x,y,d,b)) + + -- Final difference digit; no carry required: + let d_l1 = d !! (l-1) + d_l1 <- qnot d_l1 `controlled` (x!!(l-1)) + d_l1 <- qnot d_l1 `controlled` (y!!(l-1)) + d_l1 <- qnot d_l1 `controlled` (b!!(l-1)) + d <- return $ overwriteAt (l-1) d_l1 d + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + d <- return $ reverse d + b <- return $ reverse b + + return (x,y,d,b)) + + (\(x,y,d,b) -> do + (d,d_out) <- qc_copy_fun d + return ((x,y,d,b), d_out)) + return (x, y, d_out) + +-- | Add one 'QDInt' onto a second, in place; i.e. (/x/,/y/) ↦ (/x/,/x/+/y/). Arguments are assumed to be of equal size. /O/(ℓ) gates. +q_add_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +q_add_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y') <- q_add_in_place_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x, y) + +-- | Low-level implementation of 'q_add_in_place': represents integers +-- as big-headian qubit lists. +q_add_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit]) +q_add_in_place_qulist [] [] = return ([], []) +q_add_in_place_qulist [x0] [y0] = do + y0 <- qnot y0 `controlled` x0 + return ([x0], [y0]) +q_add_in_place_qulist x y = do + let (x0:x_higher) = reverse x + (y0:y_higher) = reverse y + + y0 <- qnot y0 `controlled` x0 + + ((x0,y0),(x_higher,y_higher)) <- with_computed_fun (x0,y0) + (\(x0,y0) -> do + c <- qinit False + c <- qnot c `controlled` (x0 .==. 1) .&&. (y0 .==. 0) + return (x0,y0,c)) + (\(x0,y0,c) -> do + (x_higher,y_higher,c) <- q_add_aux (x_higher) (y_higher) c + return ((x0,y0,c),(x_higher,y_higher))) + return (reverse (x0:x_higher), reverse (y0:y_higher)) + where + -- Aux: add two LITTLE-endian bit strings, and an optional extra 1. + q_add_aux :: [Qubit] -> [Qubit] -> Qubit -> Circ ([Qubit],[Qubit],Qubit) + q_add_aux [] [] c = return ([],[],c) + q_add_aux [x0] [y0] c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + return ([x0],[y0],c) + q_add_aux (x0:xs) (y0:ys) c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + ((x0,y0,c),(xs,ys)) <- with_computed_fun (x0,y0,c) + (\(x0,y0,c) -> do + c' <- qinit False + c' <- qnot c' `controlled` (x0 .==. 1) .&&. (y0 .==. 0) + c' <- qnot c' `controlled` (x0 .==. 1) .&&. (c .==. 1) + c' <- qnot c' `controlled` (y0 .==. 0) .&&. (c .==. 1) + return (x0,y0,c,c')) + + (\(x0,y0,c,c') -> do + (xs,ys,c') <- q_add_aux xs ys c' + return ((x0,y0,c,c'),(xs,ys))) + return (x0:xs,y0:ys,c) + q_add_aux _ _ _ = error "q_add_in_place: cannot add integers of different sizes." + +-- | Subtract one 'QDInt' from a second, in place; i.e. (/x/,/y/) ↦ (/x/,/y/–/x/). Arguments are assumed to be of equal size. /O/(ℓ) gates. +q_sub_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +q_sub_in_place x y = reverse_generic_endo (\(x,d) -> q_add_in_place x d) (x,y) + +-- | Low-level version of 'q_sub_in_place': represents integers +-- as big-headian qubit lists. +q_sub_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +q_sub_in_place_qulist x y = reverse_generic_endo (\(x,d) -> q_add_in_place_qulist x d) (x,y) + +-- ---------------------------------------------------------------------- +-- ** Arithmetic with parameters + +-- | Add a parameter 'IntM' and a 'QDInt', into a fresh 'QDInt': (/x/, /y/) ↦ (/y/, /x/+/y/). The parameter /x/ must be of the same length as /y/, or /x/ can also be of undetermined length. /O/(ℓ). +q_add_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_add_param x1 y = do + let x = intm_promote x1 y "q_add_param: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + (y', z') <- q_add_param_qulist x' y' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (y, z) + +-- | Low-level implementation of 'q_add_param': represents integers as +-- big-headian qubit lists. Precondition: /x/ and /y/ have the same length. +q_add_param_qulist :: [Bool] -> [Qubit] -> Circ ([Qubit], [Qubit]) +q_add_param_qulist x y = do + -- Implementation note: compare with q_add_qdint. The code is almost verbatim identical, but since x consists of parameter Bools, `controlled` will omit gates when appropriate. + + -- Further slight optimisation would be possible, since if x doesn’t have low bits then no low carry qubits are required. + + -- Implementation note: once we have a general-purpose classical + -- circuit optimizer (even a primitive one), then this kind of + -- source-code level optimization will hopefully become moot. + + let l = length x + + (y,s_out) <- with_computed_fun y + (\y -> do + s <- qinit (replicate l False) -- holds the eventual sum + c <- qinit (replicate l False) -- holds the carries + + -- bring the lists’ indexing in line with usual numeric indexing of binary expansons + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + (y,s,c) <- loop_with_indexM (l-1) (y,s,c) (\j (y,s,c) -> do + let c_j1 = c !! (j+1) + let s_j = s !! j + -- If any two of the current bits x_j, y_j, and the carry c_j are true, then set the next carry: + -- (Note: we use that (a & b) xor (a & c) xor (b & c) == (a & b) or (a & c) or (b & c).) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. y!!j) + c_j1 <- qnot c_j1 `controlled` (x!!j .&&. c!!j) + c_j1 <- qnot c_j1 `controlled` (y!!j .&&. c!!j) + -- Now the current sum digit is computed mod 2: + s_j <- qnot s_j `controlled` (x!!j) + s_j <- qnot s_j `controlled` (y!!j) + s_j <- qnot s_j `controlled` (c!!j) + c <- return $ overwriteAt (j+1) c_j1 c + s <- return $ overwriteAt j s_j s + + return (y,s,c)) + + -- Final sum digit; no carry required: + let s_l1 = s !! (l-1) + s_l1 <- qnot s_l1 `controlled` (x!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (y!!(l-1)) + s_l1 <- qnot s_l1 `controlled` (c!!(l-1)) + s <- return $ overwriteAt (l-1) s_l1 s + + x <- return $ reverse x + y <- return $ reverse y + s <- return $ reverse s + c <- return $ reverse c + + return (y,s,c)) + + (\(y,s,c) -> do + (s,s_out) <- qc_copy_fun s + return ((y,s,c), s_out)) + return (y, s_out) + +-- | Subtract a parameter 'IntM' from a 'QDInt', into a fresh 'QDInt'. The 'IntM' cannot be shorter than the 'QDInt' (that would give ill-defined behavior), but can be of undetermined length. /O/(ℓ). +q_sub_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_sub_param x y = q_add_param (-x) y + +-- | Add a parameter 'IntM' onto a 'QDInt', in place; i.e. (/x/,/y/) ↦ /x/+/y/. The parameter /x/ must be of the same length as /y/, or /x/ can also be of undetermined length. /O/(ℓ). +q_add_param_in_place :: IntM -> QDInt -> Circ QDInt +q_add_param_in_place x1 y = do + let x = intm_promote x1 y "q_add_param_in_place: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + y' <- q_add_param_in_place_qulist x' y' + let y = xint_of_list_bh y' + return y + +-- | Low-level implementation of 'q_add_param_in_place': represents +-- integers as big-headian qubit lists. Precondition: /xlist/ and /y/ +-- have the same length. Precondition: /x/ and /y/ have the same length. +q_add_param_in_place_qulist :: [Bool] -> [Qubit] -> Circ [Qubit] +q_add_param_in_place_qulist [] [] = return [] +q_add_param_in_place_qulist [False] [y0] = return [y0] +q_add_param_in_place_qulist [True] [y0] = do + y0 <- qnot y0 + return [y0] +q_add_param_in_place_qulist x y = do + let l = length x + + let (x0:x_higher) = reverse x + (y0:y_higher) = reverse y + + y0 <- qnot y0 `controlled` x0 + + (y0,y_higher) <- with_computed_fun y0 + (\y0 -> do + c <- qinit False + c <- qnot c `controlled` (x0 == 1) .&&. (y0 .==. 0) + return (y0,c)) + (\(y0,c) -> do + (y_higher,c) <- q_add_aux x_higher y_higher c + return ((y0,c),y_higher)) + return (reverse (y0:y_higher)) + where + -- Aux: add two LITTLE-endian bit strings, and an optional extra 1. + q_add_aux :: [Bool] -> [Qubit] -> Qubit -> Circ ([Qubit],Qubit) + q_add_aux [] [] c = return ([],c) + q_add_aux [x0] [y0] c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + return ([y0],c) + q_add_aux (x0:xs) (y0:ys) c = do + y0 <- qnot y0 `controlled` x0 + y0 <- qnot y0 `controlled` c + ((y0,c),ys) <- with_computed_fun (y0,c) + (\(y0,c) -> do + c' <- qinit False + c' <- qnot c' `controlled` (x0 == 1) .&&. (y0 .==. 0) + c' <- qnot c' `controlled` (x0 == 1) .&&. (c .==. 1) + c' <- qnot c' `controlled` (y0 .==. 0) .&&. (c .==. 1) + return (y0,c,c')) + + (\(y0,c,c') -> do + (ys,c') <- q_add_aux xs ys c' + return ((y0,c,c'),ys)) + return (y0:ys,c) + q_add_aux _ _ _ = error "q_add_in_place: cannot add integers of different sizes." + +-- | Subtract a parameter 'IntM' from a 'QDInt', in place; i.e. (/x/,/y/) ↦ (/x/,/x/-/y/). /x/ cannot be shorter than /y/. /O/(/l/) gates. +q_sub_param_in_place :: IntM -> QDInt -> Circ QDInt +q_sub_param_in_place x = q_add_param_in_place (-x) + +-- | Multiply a parameter 'IntM' by a 'QDInt', into a fresh 'QDInt'. The 'IntM' cannot be shorter than the 'QDInt' (that would give ill-defined behavior), but can be of undetermined length. /O/(ℓ). +q_mult_param :: IntM -> QDInt -> Circ (QDInt,QDInt) +q_mult_param x1 y = do + let x = intm_promote x1 y "q_add_param: inputs must have equal length" + let x' = boollist_of_intm_bh x + let y' = list_of_xint_bh y + (y', z') <- q_mult_param_qulist x' y' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (y, z) + +-- | Low-level implementation of 'q_mult_param': represents integers as +-- big-headian (qu)bit lists. +q_mult_param_qulist :: [Bool] -> [Qubit] -> Circ ([Qubit],[Qubit]) +q_mult_param_qulist [] [] = return ([], []) +q_mult_param_qulist xs ys = do + let x0 = last xs + x_higher = init xs + y_high = head ys + y_lower = tail ys + (y_lower, p_higher) + <- q_mult_param_qulist x_higher y_lower + p0 <- qinit False + let y = y_high:y_lower + p = p_higher ++ [p0] + -- Once we have some optimisation, the following line should be replaced by: + -- (y,p) <- q_add_in_place_qulist y p `controlled` x0 + (y,p) <- if x0 then q_add_in_place_qulist y p else return (y,p) + return (y, p) + +-- ---------------------------------------------------------------------- +-- ** Sign and negation + +-- | Negate a (signed) 'QDInt' in place. /O/(ℓ). +q_negate_in_place :: QDInt -> Circ QDInt +q_negate_in_place x = do + x <- mapUnary qnot x + x <- q_increment x + return x + +-- | Low-level version of 'q_negate_in_place': represents integers as +-- big-headian qubit lists. +q_negate_in_place_qulist :: [Qubit] -> Circ [Qubit] +q_negate_in_place_qulist = mmap list_of_xint_bh . q_negate_in_place . xint_of_list_bh + +-- | Compute the negation of a (signed) 'QDInt'. /O/(ℓ). +-- +-- (Fixes the minimum value, consistently with Haskell’s @'negate' 'minBound' :: 'Int'@.) +q_negate_qdint :: QDInt -> Circ (QDInt,QDInt) +q_negate_qdint x = do + (x,nx) <- qc_copy_fun x + nx <- q_negate_in_place nx + return (x,nx) + +-- | Compute the absolute value of a (signed) 'QDInt'. /O/(ℓ). +-- +-- (Fixes the minimum value, consistently with Haskell’s @'abs' 'minBound' :: 'Int'@.) +q_abs_qdint :: QDInt -> Circ (QDInt,QDInt) +q_abs_qdint x = do + let x' = list_of_xint_bh x + (x', a') <- q_abs_qulist x' + let x = xint_of_list_bh x' + let a = xint_of_list_bh a' + return (x, a) + +-- | Low-level implementation of 'q_abs_qdint': represents integers as +-- big-headian qubit lists. +q_abs_qulist :: [Qubit] -> Circ ([Qubit],[Qubit]) +q_abs_qulist [] = return ([], []) +q_abs_qulist (x_high:x_lower) = do + a_high <- qinit False + (x_lower,a_lower) <- qc_copy_fun x_lower + a_lower <- mapUnary qnot a_lower `controlled` x_high + let a = a_high:a_lower + a <- q_increment_qulist a `controlled` x_high + return (x_high:x_lower, a) + +-- | Compute a 'QDInt' of the same length as the input, with value 1, 0, or –1, depending on the sign of the input. Analogous to Haskell’s 'signum'. /O/(ℓ). +q_signum_qdint :: QDInt -> Circ (QDInt,QDInt) +q_signum_qdint x = do + let x' = list_of_xint_bh x + (x', a') <- q_signum_qulist x' + let x = xint_of_list_bh x' + let a = xint_of_list_bh a' + return (x, a) + +-- | Low-level implementation of 'q_abs_qdint': represents integers as +-- big-headian qubit lists. +q_signum_qulist :: [Qubit] -> Circ ([Qubit],[Qubit]) +q_signum_qulist [] = return ([], []) +q_signum_qulist x = do + let l = length x + (s_higher, s_low) <- qinit (replicate (l-1) False, False) + -- first set s = 1 + s_low <- qnot s_low + -- case x < 0: set s to -1 + s_higher <- mapUnary qnot s_higher `controlled` (head x) + -- case x = 0: reset s to 0 + s_low <- qnot s_low `controlled` (x .==. replicate l 0) + return (x,s_higher ++ [s_low]) + +-- ---------------------------------------------------------------------- +-- ** Comparison + +-- | Comparison of two 'QDInt's, considered as unsigned. /O/(ℓ). +q_le_unsigned :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_le_unsigned x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x',y',le_out) <- q_le_unsigned_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x,y,le_out) + +-- | Low-level implementation of 'q_le_unsigned': represents integers +-- as big-headian qubit lists. +q_le_unsigned_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],Qubit) +q_le_unsigned_qulist x y = do + ((x,y),le_out) <- with_computed_fun (x,y) q_le_unsigned_aux + (\(x,y,(le,garbage)) -> do + (le,le_out) <- qc_copy_fun le + return ((x,y,(le,garbage)),le_out)) + return (x,y,le_out) + +-- | Same as 'q_le_unsigned', but uncurried, represents integers as +-- big-headian qubit lists, and doesn’t clean up its garbage. (If +-- each recursive call cleans up its own garbage, gate use becomes +-- /O/(2[sup /n/]).) +q_le_unsigned_aux :: ([Qubit], [Qubit]) -> Circ ([Qubit],[Qubit],(Qubit,[Qubit])) +q_le_unsigned_aux ([], []) = do q <- qinit True; return ([], [], (q,[])) +q_le_unsigned_aux (x_high:x_lower, y_high:y_lower) = do + -- Classically, one would make the recursive call only if needed; but quantumly, it’s cheaper to do it unconditionally. + (x_lower, y_lower, (le_lower, garbage)) <- q_le_unsigned_aux (x_lower, y_lower) + (x_high,y_high,eq_high) <- q_is_equal x_high y_high + le <- qinit False + le <- qnot le `controlled` (x_high .==. 0) .&&. (y_high .==. 1) + le <- qnot le `controlled` eq_high .&&. le_lower + return (x_high:x_lower, y_high:y_lower, (le, eq_high:le_lower:garbage)) +q_le_unsigned_aux _ = error "q_le // QDInt: cannot compare QDInt’s of different lengths." + +-- | Comparison of two 'QDInt's, considered as signed. Used in @instance 'QOrd' 'QDInt'@. /O/(ℓ). +q_le_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_le_signed x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x',y',le_out) <- q_le_signed_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x,y,le_out) + +-- | Low-level implementation of 'q_le_signed': represents integers +-- as big-headian qubit lists. + +-- Implementation note: defined in terms of q_le_unsigned_aux +q_le_signed_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],Qubit) +q_le_signed_qulist [] [] = do q <- qinit True; return ([], [], q) +q_le_signed_qulist (x_high:x_lower) (y_high:y_lower) = do + ((x,y), x_le_y) <- with_computed_fun (x_high:x_lower, y_high:y_lower) + (\(x_high:x_lower, y_high:y_lower) -> do + -- Classically, one would make the recursive call only if needed; but quantumly, it’s cheaper to do it unconditionally. + (x_lower, y_lower, (le_lower, garbage)) <- q_le_unsigned_aux (x_lower, y_lower) + (x_high,y_high,eq_high) <- q_is_equal x_high y_high + return (x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage)) + (\(x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage) -> do + le <- qinit False + le <- qnot le `controlled` (x_high .==. 1) .&&. (y_high .==. 0) + le <- qnot le `controlled` eq_high .&&. le_lower + return ((x_high, y_high, x_lower, y_lower, le_lower, eq_high, garbage), le)) + return (x,y,x_le_y) +q_le_signed_qulist _ _ = error "q_le // QDInt: cannot compare QDInt’s of different lengths." + +-- | Comparison of two 'QDInt's, considered as signed. Used in @instance 'QOrd' 'QDInt'@. /O/(ℓ). +q_lt_signed :: QDInt -> QDInt -> Circ (QDInt,QDInt,Qubit) +q_lt_signed x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (y',x',y_le_x) <- q_le_signed_qulist y' x' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + x_lt_y <- qnot y_le_x + return (x,y,x_lt_y) + +-- | Text whether a 'QDInt' is nonnegative. /O/(1) +q_negative :: QDInt -> Circ (QDInt,Qubit) +q_negative x = do + let (x_high:x_lower) = list_of_xint_bh x + (x_high,x_neg) <- qc_copy_fun x_high + return (xint_of_list_bh (x_high:x_lower),x_neg) + +instance QOrd QDInt where + q_less qx qy = do (qx,qy,q) <- q_lt_signed qx qy; return q + q_leq qx qy = do (qx,qy,q) <- q_le_signed qx qy; return q + +-- ---------------------------------------------------------------------- +-- ** Multiplication + +-- | Multiply two 'QDInt's into a fresh third. Arguments are assumed to be of equal size. /O/(ℓ[sup 2]). +q_mult_qdint :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt) +q_mult_qdint x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', z') <- q_mult_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let z = xint_of_list_bh z' + return (x, y, z) + +-- | Low-level implementation of 'q_mult_qdint': represents integers as +-- big-headian qubit lists. +q_mult_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit],[Qubit]) +q_mult_qulist [] [] = return ([], [], []) +q_mult_qulist xs ys = do + let x0 = last xs + x_higher = init xs + y_high = head ys + y_lower = tail ys + (x_higher, y_lower, p_higher) + <- q_mult_qulist x_higher y_lower + p0 <- qinit False + let y = y_high:y_lower + p = p_higher ++ [p0] + (y,p) <- q_add_in_place_qulist y p `controlled` x0 + return (x_higher ++ [x0], y, p) + +-- ---------------------------------------------------------------------- +-- ** Division and remainder + +-- | Reduce one 'QDInt' modulo another, in place, returning also the +-- integer quotient, i.e. (/x/, /y/) ↦ (/x/ mod /y/, /y/, /x/ div /y/). +-- All inputs and outputs are considered unsigned. Inputs are assumed +-- to have the same length. Division by zero returns (/x/,0,-1). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_moddiv_unsigned_in_place :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_moddiv_unsigned_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (r', y', q') <- q_moddiv_unsigned_in_place_qulist x' y' + let r = xint_of_list_bh r' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (r, y, q) + +-- | Low-level implementation of 'q_moddiv_unsigned_in_place': +-- represents integers as big-headian qubit lists. +-- +-- Implementation note: this algorithm can be optimized significantly: +-- [scratch] is always 0, so can be optimized away. This optimisation +-- is much clearer at the circuit level than the code level, however, +-- so is deferred for now. +q_moddiv_unsigned_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit],[Qubit]) +q_moddiv_unsigned_in_place_qulist x y = do + let l = common_value "q_divrem_unsigned_in_place: arguments must be same length" $ map length [x,y] + -- Set quot = 0, rem = x. At each stage, we will have y * quot + rem = x. + quot_bits <- qinit (replicate l False) + let rem = x + with_ancilla_init (replicate (l-1) False) (\scratch -> do + -- For j from (l-1) to 0, compute the jth bit of the quotient, and update the remainder + (y,scratch,quot_bits,rem) <- loop_with_indexM l (y,scratch,quot_bits,rem) + (\i (y,scratch,quot_bits,rem) -> do + let j = l-1-i + -- Getting y*(2^j) requires no quantum operations, just formal re-bracketing of the data: + let y_init = take j y + y_2j = (drop j y) ++ (take j scratch) + scratch_tail = drop j scratch + -- Compare (2^j) y with rem. If (2^j)y <= rem, then subtract (2^j)y from rem and flip the jth bit of quot. + ((y_init,y_2j,rem,quot_bits),()) <- with_computed_fun + (y_init,y_2j,rem,quot_bits) + (\(y_init,y_2j,rem,quot_bits) -> do + -- first, test that (2^j)y has not overflowed the register, i.e. that y_init is still all 0; + le1 <- qinit False + le1 <- qnot le1 `controlled` (y_init .==. replicate (length y_init) False) + -- next, test that (2^j)y <= rem (this will be correct if (2^j)y has not overflowed yet); + (y_2j,rem,le2) <- q_le_unsigned_qulist y_2j rem + return (y_init,y_2j,rem,quot_bits,le1,le2)) + (\(y_init,y_2j,rem,quot_bits,le1,le2) -> do + -- flip jth bit of quot, if appropriate + -- (leave rem unchanged for now, since it’s needed to uncompute le1) + q_j <- qnot (quot_bits !! (l-1-j)) `controlled` le1 .&&. le2 + return ((y_init,y_2j,rem,(overwriteAt (l-1-j) q_j quot_bits),le1,le2),())) + -- now, subtract (2^j) from rem, if appropriate. + (y_2j,rem) <- q_sub_in_place_qulist y_2j rem `controlled` quot_bits !! (l-1-j) + -- Finally, undo the formal re-bracketing: + let y = y_init ++ (take (l-j) y_2j) + scratch = (drop (l-j) y_2j) ++ scratch_tail + return (y,scratch,quot_bits,rem)) + return (rem, y, quot_bits)) + +-- | Reduce one 'QDInt' modulo another, i.e. (/x/, /y/) ↦ (/x/, /y/, /x/ mod /y/). +-- All inputs and outputs are considered unsigned. Inputs are assumed +-- to have the same length. If /y/ = 0, returns (/x/,0,/x/). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_mod_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_mod_unsigned x y = do + ((x,y),x_mod_y) <- with_computed_fun (x,y) + (\(x,y) -> q_moddiv_unsigned_in_place x y) + (\(x_mod_y, y, x_div_y) -> do + (x_mod_y, x_mod_y_out) <- qc_copy_fun x_mod_y + return ((x_mod_y, y, x_div_y), x_mod_y_out)) + return (x,y,x_mod_y) + +-- | Integer division of two 'QDInt's, returning the quotient and remainder, +-- i.e. (/x/,/y/) ↦ (/x/,/y/,/x/ div /y/,/x/ mod /y/). +-- All inputs and outputs are considered unsigned. +-- Inputs are assumed to have the same length. +-- Division by zero returns (-1,/x/). +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_divrem_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt,QDInt) +q_divrem_unsigned x y = do + (x,rem) <- qc_copy_fun x + (rem,y,quot) <- q_moddiv_unsigned_in_place rem y + return (x,y,quot,rem) + +-- | Integer division of two 'QDInt's, returning just the quotient. +-- All inputs/outputs considered unsigned. +-- Inputs are assumed to have the same length. +-- Division by zero returns –1. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. + +-- Implementation note: We use a multiplication to do the +-- uncomputation of the remainder, because this uses fewer total gates +-- than uncomputing divrem would. +q_div_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_unsigned x y = do + (x,y,quot,rem) <- q_divrem_unsigned x y + ((x,y,quot),()) <- with_computed_fun (x,y,quot) + (\(x,y,quot) -> do + (y,quot,y_quot) <- q_mult y quot + (x,y_quot,rem_copy) <- q_sub x y_quot + return (x,y,quot,y_quot,rem_copy)) + (\(x,y,quot,y_quot,rem_copy) -> do + rem_copy <- qc_uncopy_fun rem_copy rem + return ((x,y,quot,y_quot,rem_copy),())) + return (x,y,quot) + +-- | Low-level version of 'q_div_unsigned': represents integers as +-- big-headian qubit lists. +q_div_unsigned_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_div_unsigned_qulist x' y' = do + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + (x, y, q) <- q_div_unsigned x y + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + let q' = list_of_xint_bh q + return (x', y', q') + +-- | Integer division of two 'QDInt's into a fresh third, rounding towards –∞. +-- The first argument is the numerator, and is assumed to be signed. +-- The second argument is the denominator, and is assumed to be unsigned. +-- The output is signed. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_div x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', q') <- q_div_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (x, y, q) + +-- | Low-level implementation of 'q_div': represents integers as +-- big-headian qubit lists. +q_div_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_div_qulist [] [] = return ([], [], []) +q_div_qulist (x_high:x_lower) y = do + -- Writing x/y for unsigned division, we have x `div` y = + -- if x>0 then x/y else ~((~x)/y) + -- where ~x := -1-x --- i.e. the bitflip of x. + -- + -- We do this with an ancilla (which can easily be optimized away): + with_ancilla_init False (\fake_x_high -> do + -- flip x if x<0: + x_lower <- mapUnary qnot x_lower `controlled` x_high + let x' = fake_x_high:x_lower + -- x' now holds (if x > 0 then x else ~x) + (x',y,quot) <- q_div_unsigned_qulist x' y + -- restore x and flip quotient, if necessary + let fake_x_high:x_lower = x' + x_lower <- mapUnary qnot x_lower `controlled` x_high + quot <- mapUnary qnot quot `controlled` x_high + return (x_high:x_lower, y, quot)) +q_div_qulist _ _ = error "q_div: arguments must have same length." + +-- | Integer division of two 'QDInt's into a fresh third, rounding towards 0. +-- The first argument is the numerator, and is assumed to be signed. +-- The second argument is the denominator, and is assumed to be unsigned. +-- The output is signed. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_quot :: QDInt -> QDInt -> Circ (QDInt, QDInt, QDInt) +q_quot x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y', q') <- q_quot_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + let q = xint_of_list_bh q' + return (x, y, q) + +-- | Low-level implementation of 'q_quot': represents integers as +-- big-headian qubit lists. +q_quot_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit], [Qubit]) +q_quot_qulist [] [] = return ([], [], []) +q_quot_qulist (x_high:x_lower) y = do + -- Writing x/y for unsigned division, we have x `div` y = + -- if x>0 then x/y else -((-x)/y) + -- + -- We do this with an ancilla (which can easily be optimized away): + with_ancilla_init False (\fake_x_high -> do + -- flip x if x<0: + x_lower <- q_negate_in_place_qulist x_lower `controlled` x_high + let x' = fake_x_high:x_lower + -- x' now holds (if x > 0 then x else ~x) + (x',y,quot) <- q_div_unsigned_qulist x' y + -- restore x and flip quotient, if necessary + let fake_x_high:x_lower = x' + x_lower <- q_negate_in_place_qulist x_lower `controlled` x_high + quot <- q_negate_in_place_qulist quot `controlled` x_high + return (x_high:x_lower, y, quot)) +q_quot_qulist _ _ = error "q_quot: arguments must have same length." + +-- | Integer division of two 'QDInt's, returning the quotient, +-- assuming that the second exactly divides the first and throwing an error otherwise. +-- All inputs/outputs considered unsigned. +-- Inputs are assumed to have the same length. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div_exact_unsigned :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_exact_unsigned x y = do + (x,y,quot,rem) <- q_divrem_unsigned x y + qterm 0 rem + return (x,y,quot) + +-- | Integer division of two 'QDInt's, returning the quotient, +-- assuming that the second exactly divides the first. +-- The first argument is the numerator, considered signed. +-- The second argument is the denominator, considered unsigned. +-- The output is signed. +-- +-- /O/(ℓ[sup 2]) gates, /O/(ℓ) qubits. +q_div_exact :: QDInt -> QDInt -> Circ (QDInt, QDInt,QDInt) +q_div_exact x y = do + (x,(y,quot)) <- with_computed_fun x + (\x -> do + (x,x_neg) <- q_negative x + x' <- q_negate_in_place x `controlled` x_neg + return (x',x_neg)) + (\(x',x_neg) -> do + (x',y,quot) <- q_div_exact_unsigned x' y + quot <- q_negate_in_place quot `controlled` x_neg + return ((x',x_neg),(y,quot))) + return (x,y,quot) + +-- ---------------------------------------------------------------------- +-- * The QNum type class + +-- $ This section defines a quantum analogue of Haskell’s 'Num' type +-- class. See "Quipper.Internal.QClasses" for the general philosophy behind +-- quantum type classes. +-- +-- The type class 'QNum' corresponds to Haskell’s 'Num', with methods +-- including +-- +-- > add_q :: (QNum qa) => qa -> qa -> Circ (qa,qa,qa), +-- +-- and so on. +-- +-- Note: type class instances don't show up in the documentation. View +-- the source code to see them. + +-- | Quantum analogue of Haskell’s 'Num' type class. This provides +-- basic addition, subtraction, multiplication, sign operations, and +-- conversion from integers. + +class (QData qa) => QNum qa where + -- | Add two quantum numbers into a fresh one. The arguments are + -- assumed to be of equal size. The 'QDInt' instance uses /O/(ℓ) + -- gates, both before and after transformation to Toffoli. + q_add :: qa -> qa -> Circ (qa,qa,qa) + + -- | Multiply two quantum numbers into a fresh third. The arguments + -- are assumed to be of equal size. The 'QDInt' instance is + -- /O/(ℓ[sup 2]). + q_mult :: qa -> qa -> Circ (qa,qa,qa) + + -- | Subtract two quantum numbers into a fresh one. The arguments + -- are assumed to be of equal size. The 'QDInt' instance uses /O/(ℓ) + -- gates, both before and after transformation to Toffoli. + q_sub :: qa -> qa -> Circ (qa,qa,qa) + + -- | Compute the absolute value of a (signed) quantum number. The + -- 'QDInt' instance is /O/(ℓ). + q_abs :: qa -> Circ (qa,qa) + + -- | Compute the negation of a (signed) quantum number. The 'QDInt' + -- instance is /O/(ℓ). + q_negate :: qa -> Circ (qa,qa) + + -- | Compute a quantum number of the same precision as the input, + -- with value 1, 0, or –1, depending on the sign of the + -- input. Analogous to Haskell’s 'signum'. The 'QDInt' instance is + -- /O/(ℓ). + q_signum :: qa -> Circ (qa,qa) + + -- | Convert a 'QDInt' to a quantum number. For the 'QDInt' + -- instance, this is just a copy operation. + q_fromQDInt :: QDInt -> Circ (QDInt,qa) + +instance QNum QDInt where + q_add = q_add_qdint + q_mult = q_mult_qdint + q_sub = q_sub_qdint + q_abs = q_abs_qdint + q_negate = q_negate_qdint + q_signum = q_signum_qdint + q_fromQDInt = qc_copy_fun + +-- ---------------------------------------------------------------------- +-- ** Specialized functions + +-- | Euclid's extended algorithm. 'q_ext_euclid' /a/ /b/: returns +-- (/a/,/b/,/x/,/y/,/d/) such that /ax/ + /by/ = /d/ = gcd(/a/,/b/). +q_ext_euclid :: QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt,QDInt,QDInt) +q_ext_euclid a b = do + let l = common_length "q_ext_euclid: inputs must have equal length" [a,b] + + -- Extended Euclidean algorithm: + -- + -- compute three series of numbers (a_i), (x_i), (y_i), such that + -- + -- a_0 = a, a_1 = b, + -- a_{i+2} = a_i `mod` a_{i+1}, + -- and always a_i = (x_i * a) + (y_i * b), + -- + -- When we first get a_{i+2} = 0, we know that a_{i+1} is gcd(a_0,a_1), + -- so we save a_{i+1}, x_{i+1} and y_{i+1} for output. + -- + -- The bound on the length of this loop is standard. + + ((a,b),(x,y)) <- with_computed_fun (a,b) (\(a,b) -> do + x0 <- qinit (intm l 1) + y0 <- qinit (intm l 0) + x1 <- qinit (intm l 0) + y1 <- qinit (intm l 1) + done_yet <- qinit False + x_final <- qinit (intm l 0) + y_final <- qinit (intm l 0) + + (stuff1, stuff2, stuff3, (done_yet, x_final, y_final)) + <- loopM (euclid_bound l) ((a,b,x0,x1,y0,y1),[],[],(done_yet,x_final,y_final)) + (\((a_i, a_i1, x_i, x_i1, y_i, y_i1), quots_scratch, tests_scratch, (done_yet, x_final, y_final)) -> do + (a_i2, a_i1, q_i) <- q_moddiv_unsigned_in_place a_i a_i1 + ((x_i1, y_i1, q_i), (x_i2, y_i2)) <- with_computed_fun + (x_i1, y_i1, q_i) + (\(x_i1, y_i1, q_i) -> do + (q_i, x_i1, qx) <- q_mult q_i x_i1 + (q_i, y_i1, qy) <- q_mult q_i y_i1 + return (x_i1, y_i1, q_i, qx, qy)) + (\(x_i1, y_i1, q_i, qx, qy) -> do + (qx,x_i2) <- q_sub_in_place qx x_i + (qy,y_i2) <- q_sub_in_place qy y_i + return ((x_i1, y_i1, q_i, qx, qy),(x_i2,y_i2))) + done_this_time <- qinit False + done_this_time <- qnot done_this_time `controlled` (a_i2 .==. 0) .&&. (done_yet .==. False) + (x_i1,x_final) <- controlled_not x_final x_i1 `controlled` done_this_time + (y_i1,y_final) <- controlled_not y_final y_i1 `controlled` done_this_time + done_yet <- qnot done_yet `controlled` done_this_time + return ((a_i1, a_i2, x_i1, x_i2, y_i1, y_i2), + (q_i:quots_scratch), (done_this_time:tests_scratch), + (done_yet, x_final, y_final))) + qterm True done_yet -- Assert that we really did reach the end of the algorithm. + return (x_final,y_final,(stuff1, stuff2, stuff3))) + + (\(x_final, y_final, stuff) -> do + (x_final,x) <- qc_copy_fun x_final + (y_final,y) <- qc_copy_fun y_final + return ((x_final, y_final, stuff),(x,y))) + + ((a,b,x,y),gcd) <- with_computed_fun + (a,b,x,y) + (\(a,b,x,y) -> do + (a,x,ax) <- q_mult a x + (b,y,by) <- q_mult b y + return (a,b,x,y,ax,by)) + (\(a,b,x,y,ax,by) -> do + (ax,by,gcd) <- q_add ax by + return ((a,b,x,y,ax,by),gcd)) + + return (a,b,x,y,gcd) + + where + -- Classical bound on running time (Lamé’s theorem), assuming b < a: + -- t <= 1 + log_{phi} b <= 1 + l / (log_2 phi) + -- + -- We allow one extra step since we may have a < b, in which case first step swaps them. + euclid_bound :: Int -> Int + euclid_bound l = 2 + ceiling ( (fromIntegral l) / (logBase 2 phi) ) + phi = (1+sqrt(5))/2 + +-- ---------------------------------------------------------------------- +-- * Lifting of arithmetic functions + +-- $LIFTING +-- This sections provides templates for lifting various arithmetic +-- functions in connection with the @build_circuit@ keyword. This +-- extends the liftings given in "Quipper.Internal.CircLifting" to operations +-- of the 'Num' type class. + +-- | Quantum lifting of the '+' operator. +template_symb_plus_ :: (QNum qa) => Circ (qa -> Circ (qa -> Circ qa)) +template_symb_plus_ = return $ \qx -> return $ \qy -> do (qx,qy,qz) <- q_add qx qy; return qz + +-- TODO: complete templates of methods. + diff --git a/dist/build/Quipper/Libraries/ClassicalOptim.hs b/dist/build/Quipper/Libraries/ClassicalOptim.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/ClassicalOptim.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/ClassicalOptim.hs" #-} +-- | This library provides functions for optimizing classical +-- circuits. It is intended to reduce the size of +-- automatically-generated circuits, such as those that are built +-- using Quipper's @build_circuit@ keyword. +-- +-- Note: the resulting circuit is not expected to be optimal in +-- absolute terms. In general, finding the smallest possible circuit +-- to represent a given boolean function is an NP-hard +-- problem. Rather, we transform the input circuit by applying a +-- number of heuristics and an algebraic optimization technique. This +-- results in the removal of redundant qubits and gates that are +-- typical for machine-generated circuits. It generally decreases the +-- number of gates and ancillas. +-- +-- For example, consider the circuit for a simple adder, as generated +-- by the @build_circuit@ mechanism: +-- +-- \[image adder-unoptimized.png] +-- +-- The optimized version, as generated by 'simplify_classical', looks +-- like this: +-- +-- \[image adder-optimized.png] +-- +-- The above example can be found in the file +-- @Quipper\/Demos\/OptimTest.hs@ in the @quipper-demos@ package. + +module Quipper.Libraries.ClassicalOptim ( + simplify_classical, + classical_to_reversible_optim, + box_classical_to_reversible_optim +) where + +import Quipper.Libraries.ClassicalOptim.QuipperInterface + diff --git a/dist/build/Quipper/Libraries/ClassicalOptim/AlgExp.hs b/dist/build/Quipper/Libraries/ClassicalOptim/AlgExp.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/ClassicalOptim/AlgExp.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/ClassicalOptim/AlgExp.hs" #-} +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# LANGUAGE OverlappingInstances #-} +#endif + +-- | This module contains an efficient representation of algebraic +-- boolean formulas. +module Quipper.Libraries.ClassicalOptim.AlgExp where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import Quipper.Utils.Auxiliary (bool_xor) + +import Quipper.Libraries.ClassicalOptim.Circuit + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Build the characteristic function of a set. +mapOfSet :: Ord a => S.Set a -> M.Map a Int +mapOfSet s = S.foldl' (\m x -> M.insert x 1 m) M.empty s + +-- | Get the set of elements whose images are odd. +setOfMap :: Ord a => M.Map a Int -> S.Set a +setOfMap m = + M.foldlWithKey' (\s x _ -> S.insert x s) S.empty $ + M.filter (\x -> mod x 2 == 1) m + +-- | Split a list in the middle. +split_even :: [a] -> ([a],[a]) +split_even a = splitAt (div (length a) 2) a + +-- ---------------------------------------------------------------------- +-- * Expressions + +-- | The type of algebraic boolean expressions. +-- +-- We represent boolean expressions using \"and\" and \"xor\" as the +-- primitive connectives. Equivalently, we can regard booleans as the +-- elements of the two-element field /F/[sub 2], with operations \"*\" +-- (times) and \"+\" (plus). +-- +-- An algebraic expression +-- @x1*x2*x3 + y1*y2*y3 + z1*z2@ +-- is encoded as +-- @{{x1,x2,x3},{y1,y2,y3},{z1,z2}}@. +-- +-- In particular, +-- @{} == False == 0@ and +-- @{{}} == True == 1@. +type Exp = S.Set IS.IntSet + +instance {-# OVERLAPPING #-} Show Exp where + show e = if (S.null e) then "F" + else if (e == S.singleton (IS.empty)) then "T" + else L.concat $ L.intersperse "+" (L.map (\e -> L.concat $ L.map (\x -> "x" ++ (show x)) $ IS.toList e) $ S.toList e) + +-- | Turn an @Exp@ into a list of lists. +listOfExp :: Exp -> [[Int]] +listOfExp e = S.toList $ S.map IS.toList e + +-- | Turn a list of lists into an @Exp@. +expOfList :: [[Int]] -> Exp +expOfList l = S.fromList $ L.map IS.fromList l + +-- | The conjunction of two expression. +exp_and :: Exp -> Exp -> Exp +exp_and a b = + setOfMap $ + S.foldl (\exp monomial -> M.unionWith (+) exp $ exp_and_aux monomial $ mapOfSet a) M.empty b + where + exp_and_aux :: IS.IntSet -> M.Map IS.IntSet Int -> M.Map IS.IntSet Int + exp_and_aux monomial exp = M.mapKeysWith (+) (IS.union monomial) exp + +-- | The xor of two expressions. +exp_xor :: Exp -> Exp -> Exp +exp_xor a b = setOfMap $ M.unionWith (+) (mapOfSet a) (mapOfSet b) + +-- | The expression \"False\". +exp_false :: Exp +exp_false = S.empty + +-- | The expression \"True\". +exp_true :: Exp +exp_true = S.singleton IS.empty + +-- | The negation of an expression. +exp_not :: Exp -> Exp +exp_not e = exp_xor e exp_true + +-- | The expression /x/[sub /n/]. +exp_var :: Int -> Exp +exp_var x = S.singleton $ IS.singleton x + +-- ---------------------------------------------------------------------- +-- * Properties of expressions + +-- $ The important property of expressions is that two formulas have +-- the same truth table iff they are syntactically equal. This makes +-- the equality test of wires theoretically straightforward. + +-- ---------------------------------------------------------------------- +-- ** Truth tables + +-- $ A /valuation/ on a set of variables is a map from variables to +-- booleans. This can be thought of as a row in a truth table. A +-- /truth table/ is a map from valuations to booleans, but we just +-- represent this as a list of booleans, listed in lexicographically +-- increasing order of valuations. + +-- | Get the variables used in an expression. +vars_of_exp :: Exp -> [Int] +vars_of_exp e = IS.toList $ S.foldl (\a b -> IS.union a b) IS.empty e + +-- | Evaluate the expression with respect to the given valuation. A +-- /valuation/ is a map from variables to booleans, i.e., a row in a +-- truth table. +exp_eval :: Exp -> M.Map Int Bool -> Bool +exp_eval e m = L.foldl bool_xor False $ L.map (L.foldl (&&) True) $ L.map (L.map (m M.!)) $ L.map (IS.toList) $ S.toList e + +-- | Construct the list of all 2[super /n/] valuations for a given +-- list of /n/ variables. +valuations_of_vars :: [Int] -> [M.Map Int Bool] +valuations_of_vars [] = [M.empty] +valuations_of_vars (h:t) = l + where + l = (L.map (M.insert h False) v) ++ (L.map (M.insert h True) v) + v = valuations_of_vars t + +-- | Build the truth table for the given expression, on the given list +-- of variables. The truth table is returned as a list of booleans in +-- lexicographic order of valuations. For example, if +-- +-- > 1 2 | exp +-- > F F | f1 +-- > F T | f2 +-- > T F | f3 +-- > T T | f4 +-- +-- then the output of the function is @[f1,f2,f3,f4]@. +truth_table_of_exp :: [Int] -> Exp -> [Bool] +truth_table_of_exp vars e = L.map (exp_eval e) (valuations_of_vars vars) + +-- | Return an expression realizing the given truth table. Uses +-- variables starting with the given number. +exp_of_truth_table :: Int -> [Bool] -> Exp +exp_of_truth_table i [] = exp_true +exp_of_truth_table i [False] = exp_false +exp_of_truth_table i [True] = exp_true +exp_of_truth_table i t = ((exp_not (exp_var i)) `exp_and` e1) `exp_xor` ((exp_var i) `exp_and` e2) + where + (t1,t2) = split_even t + e1 = exp_of_truth_table (i+1) t1 + e2 = exp_of_truth_table (i+1) t2 + diff --git a/dist/build/Quipper/Libraries/ClassicalOptim/Circuit.hs b/dist/build/Quipper/Libraries/ClassicalOptim/Circuit.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/ClassicalOptim/Circuit.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/ClassicalOptim/Circuit.hs" #-} +-- | This module provides a simplified representation of classical +-- circuits. +module Quipper.Libraries.ClassicalOptim.Circuit where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Quipper.Utils.Auxiliary as Q + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ---------------------------------------------------------------------- +-- * Simplified circuits + +-- | The type of wires. A wire is determined by an integer ID. +type Wire = Int + +-- | The type of gates. +data Gate = + NoOp -- ^ No operation. + | Init Bool Wire -- ^ Initialization. + | Cnot Wire [(Wire,Bool)] -- ^ Multi-controlled not. + deriving (Show,Eq) + +-- | Get the wire acted upon by a gate, if any. +wireOfGate :: Gate -> Maybe Wire +wireOfGate NoOp = Nothing +wireOfGate (Init _ w) = Just w +wireOfGate (Cnot w _) = Just w + +-- | Get the list of controls, if any. +ctlsOfGate :: Gate -> Maybe [(Wire,Bool)] +ctlsOfGate (Cnot _ ctls) = Just ctls +ctlsOfGate _ = Nothing + +-- | Evaluate a circuit on a given initial state, and return the final +-- state. A state is represented as a map from wires to booleans. +evalCirc :: M.Map Wire Bool -> [Gate] -> M.Map Wire Bool +evalCirc m [] = m +evalCirc m (NoOp:gs) = evalCirc m gs +evalCirc m ((Init b w):gs) = evalCirc (M.insert w b m) gs +evalCirc m ((Cnot w ctls):gs) = evalCirc (M.adjust (Q.bool_xor (ands m ctls)) w m) gs + where + ands m [] = True + ands m ((w,b):ctls) = ((m M.! w) `Q.bool_xor` (not b)) && (ands m ctls) + +-- ---------------------------------------------------------------------- +-- * Simplified Circ monad + +-- | A data structure to represent a \"circuit under +-- construction\". This holds the data needed for circuit generation. +data CircState = CS { + circuit :: [Gate], -- ^ The circuit so far. + freshWire :: Wire -- ^ The next fresh wire. +} deriving (Show) + +-- | The empty state. +emptyState :: CircState +emptyState = CS {circuit = [], freshWire = 0} + +-- | A simplified @Circ@ monad. +data Circ a = Circ (CircState -> (CircState, a)) + +instance Monad Circ where + return x = Circ (\y -> (y,x)) + (>>=) (Circ c) f = Circ (\s -> let (s',x) = c s in + let (Circ c') = f x in + c' s') + +instance Applicative Circ where + pure = return + (<*>) = ap + +instance Functor Circ where + fmap = liftM + +-- ---------------------------------------------------------------------- +-- * Low-level access functions + +-- | Retrieve the next fresh wire. +getFresh :: Circ Wire +getFresh = Circ (\s -> (s, freshWire s)) + +-- | Increment the value of the fresh wire. +incrementFresh :: Circ () +incrementFresh = Circ (\s -> (s { freshWire = freshWire s + 1 }, ())) + +-- | Add a new gate to the circuit. +addGate :: Gate -> Circ () +addGate g = Circ (\s -> (s {circuit = g : (circuit s)}, ())) + +-- | Get the circuit out of the monad. +extractCircuit :: Circ a -> [Gate] +extractCircuit (Circ c) = circuit $ fst $ c emptyState + +-- ---------------------------------------------------------------------- +-- * Higher-level access functions + +-- | Initialize a new wire. +init :: Bool -> Circ Wire +init b = do + w <- getFresh + addGate (Init b w) + incrementFresh + return w + +-- | Add a multi-controlled not gate. +cnot :: Wire -> [(Wire,Bool)] -> Circ () +cnot w ws = do + addGate (Cnot w ws) + return () + +-- ---------------------------------------------------------------------- +-- * Pretty-printing + +-- $ These functions are only used for testing. + +-- | Pretty-print a circuit as a list of gates. +printCircuit :: Circ a -> IO () +printCircuit c = do + mapM_ putStrLn $ map show $ reverse $ extractCircuit c + +-- | Print a gate as Quipper code. +print_quipperStyle :: Gate -> IO () +print_quipperStyle (Init b w) = putStrLn (" x" ++ (show w) ++ " <- Q.qinit " ++ (show b)) +print_quipperStyle (Cnot w ctls) = putStrLn (" Q.qnot x" ++ (show w) ++ " `Q.controlled` " ++ + (L.intercalate " Q..&&. " $ map (\(w,b) -> "x" ++ (show w) ++ " Q..==. " ++ (show b) ++ " ") ctls)) +print_quipperStyle g = putStrLn (" Q.comment \"" ++ (show g) ++ "\"") diff --git a/dist/build/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs b/dist/build/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/ClassicalOptim/QuipperInterface.hs" #-} +-- | This module contains the interface between the simplified circuit +-- model and Quipper's internal circuit model. The main useful +-- exported functions are: +-- +-- * @'simplify_classical'@, which optimizes a classical circuit such +-- as those coming from Template Haskell; +-- +-- * @'classical_to_reversible_optim'@, which provides a mechanism +-- equivalent to @'Q.classical_to_reversible'@, but with optimization +-- inlined. + +module Quipper.Libraries.ClassicalOptim.QuipperInterface where + +import Data.Maybe + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import qualified Quipper as Q +import qualified Quipper.Internal.Monad as Q +import qualified Quipper.Internal.QData as Q +import qualified Quipper.Internal.Circuit as Q +import qualified Quipper.Internal.Generic as Q +import qualified Quipper.Internal.Printing as Q +import qualified Quipper.Libraries.Simulation as Q +import qualified Quipper.Libraries.Simulation.ClassicalSimulation as Q +import qualified Quipper.Internal.Transformer as Q +import qualified Quipper.Internal.Control as Q + +import qualified Quipper.Libraries.Arith as Q +import qualified Quipper.Utils.Auxiliary as Q + +import Quipper.Libraries.ClassicalOptim.Circuit +import Quipper.Libraries.ClassicalOptim.Simplification + + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Extract the list of wires from a piece of quantum data. +getListWire :: (Q.QData qc) => qc -> [Wire] +getListWire x = map Q.wire_of_qubit $ Q.qubits_of_qdata x + +-- ---------------------------------------------------------------------- +-- * Quipper circuits to simple circuits + +-- | Translates a Quipper circuit to a simple circuit. The only gates +-- considered are initializations, terminations, and multi-controlled +-- NOT gates. All other gates are ignored. +-- +-- Note that simple circuits do not possess termination wires: these +-- wires are simply not terminated, and all subsequent initializations +-- using the same wire ID are sent to fresh wires. +-- +-- The state of this function is a bit complex, as it keeps track of +-- where the output wires are mapped to. +quipperGateToMyGate :: (IS.IntSet,IM.IntMap Wire,Wire) -> Q.Gate -> ((IS.IntSet,IM.IntMap Wire,Wire), Maybe Gate) +quipperGateToMyGate (s,m,f) (Q.QGate "not" _ [w] _ ctls _) = + ((s,m,f), Just $ Cnot (IM.findWithDefault w w m) $ map (\(Q.Signed a b) -> (IM.findWithDefault a a m,b)) ctls) +quipperGateToMyGate (s,m,f) (Q.QInit b w _) = case (IS.member w s) of + True -> ((s,IM.insert w f m,f+1), Just $ Init b f) + False -> ((s,m,f), Just $ Init b w) +quipperGateToMyGate (s,m,f) (Q.QTerm b w _) = ((IS.insert w s, m,f), Nothing) +quipperGateToMyGate smf _ = (smf, Nothing) + + +-- | Get the wire initialized by the gate, if it is an initialization gate. +quipperGateInitW :: Q.Gate -> Maybe Wire +quipperGateInitW (Q.QInit _ w _) = Just w +quipperGateInitW _ = Nothing + +-- | Given a list of Quipper gates, get the smallest wire id not in use. +quipperGateFreshWire :: Wire -> [Q.Gate] -> Wire +quipperGateFreshWire w gs = (+) 1 $ L.foldl' max w $ catMaybes $ map quipperGateInitW gs + +-- | Send a Quipper 'Q.Circuit' to a 'CircState'. +quipperCircuitToMyCirc :: Q.Circuit -> CircState +quipperCircuitToMyCirc (_, gs, _, n) = + emptyState { + circuit = catMaybes $ snd $ L.mapAccumL quipperGateToMyGate (IS.empty,IM.empty,quipperGateFreshWire n gs) gs, + freshWire = n + } + +-- | Send a Quipper 'Q.BCircuit' to a 'CircState'. +quipperBCircuitToMyCirc :: Q.BCircuit -> CircState +quipperBCircuitToMyCirc (c,_) = quipperCircuitToMyCirc c + +-- | Generate a custom error message. +myCircErrMsg :: String -> String +myCircErrMsg s = "myCirc: " ++ s + +-- | Given a Quipper circuit generating function and a shape argument, +-- return a simple circuit together with the list of non-garbage +-- circuit outputs. +quipperFunToMyCirc :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (CircState,[Wire]) +quipperFunToMyCirc f shape = + let (_, bc, output) = Q.encapsulate_generic myCircErrMsg f shape + in (quipperBCircuitToMyCirc bc, + getListWire output) + +-- ---------------------------------------------------------------------- +-- * Simple circuits to Quipper circuits + +-- | Translate a gate from the simple circuit model into a Quipper gate. +myGateToQuipperGate :: Gate -> Q.Gate +myGateToQuipperGate (Cnot w ctls) = Q.QGate "not" True [w] [] (map (\(w,b) -> Q.Signed w b) ctls) False +myGateToQuipperGate (Init b w) = Q.QInit b w False +myGateToQuipperGate NoOp = error "myGateToQuipperGate cannot deal with NoOp" + +-- | Generate a Quipper comment. The first argument is a comment +-- string, and the second argument is a label to apply to the qubits +-- in the third argument. +makeComment :: String -> String -> [Wire] -> Q.Gate +makeComment comment label ws = + Q.Comment comment False $ map (\(i,x) -> (i, label ++ "[" ++ (show x) ++ "]")) (zip ws [0..(length ws)-1]) + + +-- ---------------------------------------------------------------------- +-- * Algebraic optimization of Quipper circuits + +-- | Optimize a Quipper 'Q.BCircuit'. The second argument is the list +-- of non-garbage outputs. A corresponding list of outputs is also +-- returned along with the circuit. +quipperBCircuitSimpl :: Q.BCircuit -> [Wire] -> (Q.BCircuit,[Wire]) +quipperBCircuitSimpl (c,e) output = (((a1,c'',a2',n'),e),o') + where + (a1,gs,a2,n) = c + mycirc = quipperCircuitToMyCirc c + (c',o') = compressWires (IM.keys a1) $ simplRec $ (\x -> (x,output)) {-set_init_first output-} $ circuit $ mycirc + i' = IM.keys a1 + c'' = (makeComment "Start classical circuit" "in" i') : + (map myGateToQuipperGate c') ++ + [makeComment "End classical circuit" "out" o'] + allwires = getAllWires c' + a2' = IM.fromList $ map (\x -> (x,Q.Qbit)) $ IS.toAscList allwires + n' = (+) 1 $ head $ IS.toDescList allwires + + +-- | Optimize a Quipper circuit producing function (together with a +-- shape argument). Return the optimized circuit as a Quipper +-- 'Q.BCircuit', along with a list of the non-garbage circuit outputs. +simplify_classical' :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (Q.BCircuit, [Wire]) +simplify_classical' f shape = + let (_,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in + let list_output = getListWire output in + quipperBCircuitSimpl bc list_output + +-- | Optimize a Quipper circuit-producing function. This assumes that +-- the function only consists of pseudo-classical quantum gates, i.e., +-- initializations, terminations, and (possibly multiply controlled) +-- NOT gates. The behavior on other kinds of circuits is undefined. +-- The second argument is a shape parameter. +simplify_classical :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> Q.Circ y +simplify_classical f shape = + let (input,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in + let list_output = getListWire output in + let (bc',list_output') = quipperBCircuitSimpl bc list_output in + Q.unencapsulate_generic (input,bc', Q.qdata_of_qubits output $ map Q.qubit_of_wire list_output') shape + +-- | Like 'Q.classical_to_reversible', but also apply circuit optimization. +classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb)) +classical_to_reversible_optim f = Q.classical_to_reversible (simplify_classical f) + +-- | Like 'classical_to_reversible_optim', but insert the optimized +-- circuit as a boxed subroutine. +box_classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => String -> (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb)) +box_classical_to_reversible_optim s f = Q.classical_to_reversible (Q.box s $ simplify_classical f) + diff --git a/dist/build/Quipper/Libraries/ClassicalOptim/Simplification.hs b/dist/build/Quipper/Libraries/ClassicalOptim/Simplification.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/ClassicalOptim/Simplification.hs @@ -0,0 +1,1007 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/ClassicalOptim/Simplification.hs" #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MonadComprehensions #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | This module contains the core of the classical circuit +-- optimization algorithm. +module Quipper.Libraries.ClassicalOptim.Simplification where + +import qualified Data.Map as M +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.IntSet as IS +import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -} + +import qualified Control.DeepSeq as Seq + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +import qualified Quipper.Utils.Auxiliary as Q + +import Quipper.Libraries.ClassicalOptim.Circuit +import Quipper.Libraries.ClassicalOptim.AlgExp + +-- ---------------------------------------------------------------------- +-- * Auxiliary definitions + +-- | Internal definition of a trace, for debugging purposes. This is a +-- no-op, but can be replaced to turn on debugging. +trace :: String -> b -> b +trace a b = b + +-- | Change a wire ID in a gate. The first two arguments are the old +-- and the new wire ID. +moveWire :: Wire -> Wire -> Gate -> Gate +moveWire from to NoOp = NoOp +moveWire from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) +moveWire from to (Cnot w ctls) = Cnot w' ctls' + where + w' = if (from == w) then to else w + ctls' = map moveCtls ctls + moveCtls (w,b) = if (from == w) then (to,b) else (w,b) + +-- | Flip the control on the given wire (from positive to negative or +-- vice versa). +flipCtl :: Wire -> Gate -> Gate +flipCtl _ NoOp = NoOp +flipCtl _ (Init b w) = Init b w +flipCtl w (Cnot w' ctls) = Cnot w' $ map (\(x,b) -> if (x == w) then (x,not b) else (x,b)) ctls + +-- | Change a wire ID in a gate and flip the potential control. +moveWireFlip :: Wire -> Wire -> Gate -> Gate +moveWireFlip from to NoOp = NoOp +moveWireFlip from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) +moveWireFlip from to (Cnot w ctls) = Cnot w' ctls' + where + w' = if (from == w) then to else w + ctls' = map moveCtls ctls + moveCtls (w,b) = if (from == w) then (to,b) else if (to == w) then (w,not b) else (w,b) + +-- ---------------------------------------------------------------------- +-- * Small, simple optimizations + +-- | Suppress gates acting on garbage wires, i.e., wires that are not in the input set. +suppress_garbage :: [Gate] -> IS.IntSet -> [Gate] + +suppress_garbage ((Cnot w ctls):gs) used = + if (IS.member w used) then g:gs1 else gs2 + where + g = Cnot w ctls + gs1 = suppress_garbage gs $ IS.union (IS.insert w used) $ IS.fromList $ L.map fst ctls + gs2 = suppress_garbage gs used + +suppress_garbage (g:gs) used = g:(suppress_garbage gs used) + +suppress_garbage [] _ = [] + + +-- | Like 'suppress_garbage', but packaged in a manner that is friendly for composition. +suppressGarbageGates :: ([Gate],[Wire]) -> ([Gate],[Wire]) + +suppressGarbageGates (gs,out) = (reverse $ suppress_garbage (reverse gs) $ IS.fromList out, out) + + +-- ---------------------------------------------------------------------- +-- * Compression of wire numbering + +-- $ As the optimization process goes on, many /init/ gates will end +-- up being discarded. The function 'compressWires' compacts the wire +-- numbering scheme to make a smaller circuit. + +-- | Get the set of all wires used by the circuit. +getAllWires :: [Gate] -> IS.IntSet +getAllWires gs = L.foldl' IS.union IS.empty $ L.map aux gs + where + aux (Cnot w ctls) = IS.insert w $ L.foldl' (flip IS.insert) IS.empty $ L.map fst ctls + aux (Init _ w) = IS.singleton w + aux NoOp = IS.empty + +-- | Get the set of wires initialized by the circuit. +getInitWires :: [Gate] -> IS.IntSet +getInitWires gs = L.foldl' IS.union IS.empty $ map aux gs + where + aux (Cnot _ _) = IS.empty + aux (Init _ w) = IS.singleton w + aux NoOp = IS.empty + +-- | Get the set of input wires, i.e., the ones that are used but not initialized. +getInputWires :: [Gate] -> IS.IntSet +getInputWires gs = IS.difference (getAllWires gs) (getInitWires gs) + +-- | Compress the wire numbering. +compressWires :: [Wire] -> ([Gate],[Wire]) -> ([Gate],[Wire]) +compressWires inputwires (gs,output) = (gs',out') + where + iws = getInitWires gs + begin = if inputwires == [] + then 0 + else 1 + (head $ reverse $ L.sort inputwires) + end = begin + (IS.size iws) + listmap = zip ([0..begin-1] ++ (IS.toAscList iws)) [0 .. end] + remap = M.fromList $ trace (show listmap) listmap + out' = map (remap M.!) output + gs' = map (rewire remap) gs + + rewire m (Cnot w ctls) = Cnot (m M.! w) $ map (\(x,b) -> (m M.! x, b)) ctls + rewire m (Init b w) = Init b (m M.! w) + rewire m NoOp = NoOp + + +-- ---------------------------------------------------------------------- +-- * A useful data structure + +-- $ When considering a particular point in a circuit (i.e., in a list +-- of gates), to decide whether a given wire is used or controlled +-- before or after, we keep a data-structure 'UsedWire'. + +-- | The type of gate IDs. +type GateId = Int + +-- | A set of gate IDs. +type GateIdSet = IS.IntSet + +-- | A map from wires to pairs of 'GateId's. The left member gives the +-- ID of the first gate using the wire, and the right member gives the +-- ID of the last gate using the wire. +type UsedWire = IM.IntMap GateIdSet + +-- | Get the minimum of a set of gate IDs. +gateIdFindMin :: GateIdSet -> Maybe GateId +gateIdFindMin g = if (IS.null g) then Nothing else Just (IS.findMin g) + +-- | Get the maximum of a set of gate IDs. +gateIdFindMax :: GateIdSet -> Maybe GateId +gateIdFindMax g = if (IS.null g) then Nothing else Just (IS.findMax g) + +-- | Get the pair corresponding to the given wire. +pairUsedWire :: UsedWire -> Wire -> GateIdSet +pairUsedWire m w = IM.findWithDefault IS.empty w m + +-- | Get the first gate using the wire in the future. +firstUsedWire :: UsedWire -> Wire -> Maybe GateId +firstUsedWire = curry $ gateIdFindMin . (uncurry pairUsedWire) + +-- | Get the last gate using the wire in the past. Return 0 if none. +lastUsedWire :: UsedWire -> Wire -> GateId +lastUsedWire w w'= + case (curry $ gateIdFindMax . (uncurry pairUsedWire)) w w' of + Just w -> w + Nothing -> 0 + +-- | 'nextUsedGate' /ws/ /g/ /g/' /w/: Look for the next gate in /ws/ +-- corresponding to wire /w/, starting from /g/. Return /g/' if none. +nextUsedGate :: UsedWire -> GateId -> GateId -> Wire -> GateId +nextUsedGate ws g g' w = + case (do gs <- IM.lookup w ws; IS.lookupGT g gs) of + Just g -> g + Nothing -> g' + +-- | For each wire, find the set of gates placing a control on it. +circuitControlWires :: GateId -> [Gate] -> UsedWire +circuitControlWires id gs = aux id IM.empty gs + where + aux _ m [] = m + aux g m (Init _ _:gs) = aux (g+1) m gs + aux g m ((Cnot _ ctls):gs) = aux (g+1) m' gs + where + wires = map fst ctls + m' = L.foldl (\m'' w -> IM.alter (f g) w m'') m wires + f g Nothing = Just $ IS.singleton g + f g (Just s) = Just $ IS.insert g s + aux g m (NoOp:_) = error "circuitControlWires cannot deal with NoOp" + +-- | For each wire, find the set of gates acting on it with NOT. +circuitNotWires :: GateId -> [Gate] -> UsedWire +circuitNotWires id gs = aux id IM.empty gs + where + aux _ m [] = m + aux g m (Init _ _:gs) = aux (g+1) m gs + aux g m ((Cnot w _):gs) = aux (g+1) m' gs + where + m' = IM.alter (f g) w m + f g Nothing = Just $ IS.singleton g + f g (Just s) = Just $ IS.insert g s + aux g m (_:gs) = aux (g+1) m gs + +-- ---------------------------------------------------------------------- +-- * Algebraic optimization method + +-- $ To each wire in a circuit, we attach a set of formulas. At each +-- iteration, the wire that gets modified is updated with its new +-- value, using all the possible values, possibly together with a +-- fresh variable. At each iteration, we also strip away the +-- expressions that get too large. Here, the size of an algebraic +-- expression is measured by the 'exp_length' function. + +-- | Calculate the size of an algebraic expression. +exp_length :: Exp -> Int +exp_length e = L.foldl' (+) 0 $ L.map (\x -> let y = IS.size x in seq y y) $ S.toList e + +-- | Given a list of sets of expressions, form the conjunction of +-- every possible choice of one expression from each set. For example. +-- +-- > exp_list_and [{a,b}, {c,d}, {e,f}] = +-- > [a∧c∧e, a∧c∧f, a∧d∧e, a∧d∧f, b∧c∧e, b∧c∧f, b∧d∧e, b∧d∧f]. +exp_list_and :: [S.Set Exp] -> S.Set Exp +exp_list_and [] = S.singleton exp_true +exp_list_and [l] = l +exp_list_and (h:k:t) = exp_list_and (S.fromList [exp_and x y | x <- S.toList h, y <- S.toList k]:t) + +-- | Evaluate a control with respect to a state. +expEvalCtl :: (IM.IntMap (S.Set (Exp,Int))) -> (Wire,Bool) -> S.Set Exp +expEvalCtl m (w,True) = S.map fst (m IM.! w) +expEvalCtl m (w,False) = S.map exp_not $ S.map fst $ (IM.!) m w + +-- | Evaluate a gate with respect to a state. +expEvalGate :: (IM.IntMap (S.Set (Exp,Int))) -> Gate -> IM.IntMap (S.Set (Exp,Int)) + +expEvalGate m (Init False w) = IM.insert w (S.singleton (exp_false,0)) m +expEvalGate m (Init True w) = IM.insert w (S.singleton (exp_true,1)) m +expEvalGate m NoOp = m + +expEvalGate m (Cnot w ctls) = IM.insert w cnot m + where + ands = exp_list_and $ L.map (expEvalCtl m) ctls + cnot = S.map (\x -> (x,exp_length x)) (S.fromList [exp_xor x y | + x <- S.toList $ S.map fst $ (IM.!) m w, + y <- S.toList ands ]) + +-- ---------------------------------------------------------------------- +-- ** State of the optimization automaton + +-- | The state of the automaton. This contains in particular the +-- current state, the past and future gates, and a fresh variable. +data ExpState = ExpState { + gates_to_skip :: IM.IntMap Gate, -- ^ For use with 'stepSwapCirc'. + allWiresInCirc :: IS.IntSet, -- ^ All the wires in the circuit. + gateId :: GateId, -- ^ ID of the first gate in the future (starts at 1). + usedControlWires :: UsedWire, -- ^ Location of the controls. + usedNotWires :: UsedWire, -- ^ Location of the NOT gates. + future :: [Gate], -- ^ Gates left to explore. + past :: [Gate], -- ^ Gates already explored. + expMap :: IM.IntMap (S.Set (Exp,Int)), -- ^ Algebraic state of the wires. Also contains the size of the expression, so we don't have to recompute it each time. + freshVar :: Integer, -- ^ The next fresh wire. + outWires :: [Wire], -- ^ The output wires. + sizeCirc :: Int -- ^ Size of the circuit. + } + + +instance Seq.NFData Gate where + rnf (Init a b) = a `seq` b `seq` () + rnf (Cnot w ctls) = ctls `Seq.deepseq` w `Seq.deepseq` () + rnf NoOp = () + +{- +instance Seq.NFData ExpState where + rnf e = {-allWiresInCirc e `Seq.deepseq` gateId e `Seq.deepseq` usedControlWires e `Seq.deepseq` usedNotWires e `Seq.deepseq` future e `Seq.deepseq` past e `Seq.deepseq` expMap e `Seq.deepseq` freshVar e `Seq.deepseq` outWires e-} () `Seq.deepseq` () +-} + +-- | The initial state for a given set of parameters. +initExpState :: IS.IntSet -> [Wire] -> [Gate] -> ExpState +initExpState ws_in ws_out gs = ExpState { + gates_to_skip = IM.empty, + allWiresInCirc = getAllWires gs, + gateId = 1, + usedControlWires = circuitControlWires 1 gs, + usedNotWires = circuitNotWires 1 gs, + future = gs, + past = [], + expMap = IM.fromList $ L.map (\x -> (x, S.singleton (exp_var x, 1))) $ IS.toAscList ws_in, + freshVar = fromIntegral $ (+) 1 $ IS.findMax ws_in, + outWires = ws_out, + sizeCirc = length gs + } + +-- ---------------------------------------------------------------------- +-- ** The state monad + +-- | The state monad corresponding to 'ExpState'. +data EvalCirc a = EvalCirc (ExpState -> (ExpState, a)) + +instance Monad EvalCirc where + return x = EvalCirc (\y -> (y,x)) + (>>=) (EvalCirc c) f = EvalCirc (\s -> let (s',x) = c s in + let (EvalCirc c') = f x in + c' s') + +instance Applicative EvalCirc where + pure = return + (<*>) = ap + +instance Functor EvalCirc where + fmap = liftM + +-- ---------------------------------------------------------------------- +-- ** Low-level access functions + +-- | Construct an @'ExpState'@ out of an @'EvalCirc'@. +runEvalCirc :: IS.IntSet -> [Wire] -> [Gate] -> EvalCirc a -> ExpState +runEvalCirc ws_in ws_out gs (EvalCirc e) = fst $ e $ initExpState ws_in ws_out gs + +-- | Retrieve the state. +getExpState :: EvalCirc ExpState +getExpState = EvalCirc (\s -> (s,s)) + +-- | Set the state. +setExpState :: ExpState -> EvalCirc () +setExpState s = EvalCirc (\_ -> (s,())) + +-- ---------------------------------------------------------------------- +-- ** Higher-level access functions + +-- | Create a fresh variable +newFreshVar :: EvalCirc Integer +newFreshVar = do + s <- getExpState + let v = freshVar s + setExpState (s { freshVar = v + 1 }) + return v + +-- | Pull a new gate to be analyzed out of the future. +pullNewGate :: EvalCirc (Maybe Gate) +pullNewGate = do + s <- getExpState + case (future s) of + (h:t) -> do setExpState (s { future = t } ) + return (Just h) + [] -> return Nothing + +-- | Modify the future gates. +changeFuture :: [Gate] -> EvalCirc () +changeFuture gs = do + s <- getExpState + setExpState (s { future = gs } ) + return () + +-- | Update the future using the given parameter function. Return two sets +-- of 'gateId's that got modified: the first set concerns the controls, +-- the second set the NOT gates. +updateFuture :: (Gate -> Gate) -> EvalCirc (IS.IntSet,IS.IntSet) +updateFuture f = do + s <- getExpState + let ((_,!gsModifCtls,!gsModifNots),new_future) = + L.mapAccumL (\(gid,gs,gs') g -> let g' = f g in + (( + gid+1 + , + if (ctlsOfGate g == ctlsOfGate g') + then gs + else IS.insert gid gs + , + if (wireOfGate g == wireOfGate g') + then gs' + else IS.insert gid gs' + ), + g')) + (1 + (gateId s), IS.empty,IS.empty) (future s) + changeFuture new_future + + return (gsModifCtls,gsModifNots) + +-- | Store a gate in the past. +storeOldGate :: Gate -> EvalCirc () +storeOldGate g = do + s <- getExpState + let p = past s + seq g $ seq p $ setExpState (s { past = g:p } ) + return () + +-- | Increase the '@gateId@' (i.e., go forward). +incrGateId :: EvalCirc () +incrGateId = do + s <- getExpState + setExpState (s { gateId = 1 + (gateId s) } ) + return () + +-- | Get the set of all wires. +getAllWiresInCirc :: EvalCirc IS.IntSet +getAllWiresInCirc = do + s <- getExpState + return (allWiresInCirc s) + +-- | Set the set of all wires. +setAllWiresInCirc :: IS.IntSet -> EvalCirc () +setAllWiresInCirc ws = do + s <- getExpState + ws `seq` setExpState (s {allWiresInCirc = ws}) + return () + +-- | Remove a gate from the set of all wires. +removeFromAllWiresInCirc :: Int -> EvalCirc () +removeFromAllWiresInCirc w = do + ws <- getAllWiresInCirc + setAllWiresInCirc $ IS.delete w ws + return () + +-- | Get the algebraic representation of the set of wires. +getExpMap :: EvalCirc (IM.IntMap (S.Set (Exp,Int))) +getExpMap = do + s <- getExpState + s `seq` return (expMap s) + +-- | Set the algebraic representation of the state of wires. +setExpMap :: (IM.IntMap (S.Set (Exp,Int))) -> EvalCirc () +setExpMap m = do + s <- getExpState + m `seq` setExpState (s { expMap = m } ) + return () + +-- | Update the database recording the controlled wires. +updateUsedControlWires :: (UsedWire -> UsedWire) -> EvalCirc () +updateUsedControlWires f = do + s <- getExpState + let c = f $ usedControlWires s + c `seq` setExpState (s { usedControlWires = c } ) + return () + +-- | Update the database recording the NOT gates. +updateUsedNotWires :: (UsedWire -> UsedWire) -> EvalCirc () +updateUsedNotWires f = do + s <- getExpState + let c = f $ usedNotWires s + c `seq` setExpState (s { usedNotWires = c } ) + return () + +-- | Update the list of output wires. +updateOutWires :: ([Wire] -> [Wire]) -> EvalCirc () +updateOutWires f = do + s <- getExpState + let c = f $ outWires s + c `seq` setExpState (s { outWires = c } ) + return () + +-- | Add a gate ID to the list of gates to skip. +addToSkipGates :: GateId -> Gate -> EvalCirc () +addToSkipGates id g = do + s <- getExpState + let c = IM.insert id g (gates_to_skip s) + c `seq` setExpState (s {gates_to_skip = c} ) + return () + +-- | Send a gate to the end of the future. +sendEndOfTime :: Gate -> EvalCirc () +sendEndOfTime g = do + s <- getExpState + changeFuture ((future s) ++ [g]) + return () + +-- | Place a gate at the given gate ID in the future. +shiftGate :: Gate -> GateId -> EvalCirc () +shiftGate g x = do + s <- getExpState + let (!head, !tail) = splitAt x (future s) + let z = head ++ [g] ++ tail + z `Seq.deepseq` changeFuture z + return () + +-- ---------------------------------------------------------------------- +-- ** Auxiliary functions + +-- | @pairEqualExp m1 m2 ws@: returns a list of pairs of wires @(x,y)@ +-- such that @m2 x = m1 x = m1 y@. +pairEqualExp :: (IM.IntMap [Exp]) -> (IM.IntMap [Exp]) -> [Wire] -> [(Wire,Wire)] +pairEqualExp m1 m2 ws = + L.map fst $ L.filter aux $ L.zip pair_ws (L.map value pair_ws) + where + all_pairs l = [(x,y) | x <- l, y <- l] + pair_ws = all_pairs ws + value (x,y) = (m2 IM.! x, m1 IM.! x, m1 IM.! y) + aux ((_,_),(a,b,c)) = a == b && b == c + +-- | From a set of expressions (annotated with sizes), prune the ones +-- whose size is larger than /n/. +pruneListExp :: Int -> S.Set (Exp,Int) -> S.Set (Exp,Int) +pruneListExp n l = S.filter (\x -> snd x <= n) l + + +-- ---------------------------------------------------------------------- +-- ** The algebraic optimization automaton + +-- | Perform a set of filters acting on one gate at a time, looking +-- for: +-- +-- * gates having no effect; +-- +-- * orphan NOT-gates (i.e. NOT gates negating an out-wire) ; +-- +-- * simple copy-cats (both positive and negative) ; +-- +-- * hidden copy-cats. +-- +-- Return 'False' when the end of the circuit is reached, 'True' otherwise. +stepEvalCirc :: EvalCirc Bool +stepEvalCirc = do + m_before <- getExpMap + trace ("the state of the system is " ++ (show $ m_before)) $ return () + s <- getExpState + if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp... " ++ (show (gateId s))) (return ()) else return () + s <- getExpState + trace ("outside wires " ++ (show $ outWires s)) $ return () + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + case maybe_g of + + Nothing -> return False + + Just g -> do -- analyze the gate + m_before <- getExpMap + let m_after = expEvalGate m_before g + + case g of + + NoOp -> error "stepEvalCirc cannot deal with NoOp" + + Init b w | not ((IM.member w $ usedNotWires s) || (IM.member w $ usedControlWires s) || L.elem w (outWires s))-> do + trace "got an orphan init, removing it" $ return () + storeOldGate NoOp -- store a placeholder for the gate + incrGateId + removeFromAllWiresInCirc w + -- we could also clean expMap from the reference to w but I think it makes no gain + return True + + Init _ _ -> do + trace "got a regular init" $ return () + storeOldGate g + setExpMap m_after + incrGateId + return True + + Cnot w _ | not $ S.null $ S.intersection (m_before IM.! w) (m_after IM.! w) -> do + trace "got a cnot where no change happened..." $ return () + trace (show m_before) $ return () + trace (show m_after) $ return () + storeOldGate NoOp + incrGateId + return True + + Cnot w [] | not (L.elem w $ outWires s) -> do + trace "got a not-gate that can be removed..." $ return () + s <- getExpState + -- update future + changeFuture $ L.map (flipCtl w) $ future s + s <- getExpState + trace (show $ future s) $ return () + storeOldGate NoOp + incrGateId + return True + + + Cnot w ctls | otherwise -> do + trace "got a general cnot" $ return () + trace ("state after the gate is " ++ (show m_after)) $ return () + + allWs <- getAllWiresInCirc + s <- getExpState + let my_elem x = not (L.elem x $ outWires s) + let all_ws = IS.toAscList $ IS.filter future_ctl $ + IS.filter (\x -> my_elem x) $ -- not (L.elem x $ outWires s)) $ + IS.filter (\x -> not $ S.null $ + S.intersection (m_after IM.! x) + (m_after IM.! w)) $ + IS.filter (w /=) allWs -- IS.fromList $ L.map fst ctls + where + future_ctl x = + (lastUsedWire (usedNotWires s) x) <= gateId s + && + (lastUsedWire (usedNotWires s) w) <= gateId s + + let all_ws_neg = IS.toAscList $ IS.filter future_ctl $ + IS.filter (\x -> not (L.elem x $ outWires s)) $ + IS.filter (\x -> not $ S.null $ + S.intersection (m_after IM.! x) + (S.map (\(e,i) -> (exp_not e, i)) (m_after IM.! w))) $ + IS.filter (w /=) $ IS.fromList $ L.map fst ctls + where + future_ctl x = + (lastUsedWire (usedNotWires s) x) <= gateId s + && + (lastUsedWire (usedNotWires s) w) <= gateId s + + trace ("List of outside wires: " ++ (show $ outWires s)) (return ()) + trace ("List of available wires: " ++ (show all_ws)) (return ()) + trace ("List of available wires with neg: " ++ (show all_ws_neg)) (return ()) + + + case all_ws of + + [] -> do + + case all_ws_neg of + [] -> do + + -- There is no "simple" copy-cat... + -- Let's try to find a hidden one. + + s <- getExpState + + -- This helper function take a wire and look in + -- the past for the closest cnot acting on it + let getOlderCnot w = case (do set <- IM.lookup w (usedNotWires s); IS.lookupLT (gateId s) set) of + Nothing -> Nothing -- there is no previous not + Just g' -> -- there is one not... let's check that it is a cnot + case ((past s) !! ((gateId s) - g' - 1)) of + Cnot _ [ctl] -> Just (g',ctl) + _ -> Nothing + + -- Helper acting on controls: only return + -- something if it is a single control. + let getOlderCnot_actOnCtls w1 [(w,b)] = do -- monad Maybe + other_ctl <- getOlderCnot w1 + other_ctl `seq` return ((w,b),other_ctl) + getOlderCnot_actOnCtls _ _ = Nothing + + let retrieveHiddenCnot w1 ctls = do -- monad Maybe + -- if (L.elem w $ outWires s) then Nothing + -- else return () + ((w2,b2),(g',(w3,b3))) <- getOlderCnot_actOnCtls w1 ctls + -- make sure w2 and w3 are distinct + if (w2 == w3) then Nothing else return () + let m = m_after + -- check for the property w1 == w2 oplus w3 + if (S.null $ S.intersection + (S.fromList [exp_xor x y | (x,_) <- S.toList (m IM.! w2), (y,_) <- S.toList (m IM.! w3)]) + (S.fromList [x | (x,_) <- S.toList (m IM.! w1)])) + then Nothing + -- We have two CNOT candidates for hidden copy-cat. + else if ((not (L.elem w2 $ outWires s)) + && + (lastUsedWire (usedNotWires s) w2) <= gateId s + && + (lastUsedWire (usedControlWires s) w2) <= gateId s) + then Just ((w2,b2),(w3,b3)) + else if ((not (L.elem w3 $ outWires s)) + && + (lastUsedWire (usedNotWires s) w3) <= g' + && + (lastUsedWire (usedControlWires s) w3) <= g') + then Just ((w3,b3),(w2,b2)) + else Nothing + + case retrieveHiddenCnot w ctls of + Just ((w2,b2),(w3,b3)) -> -- we have a hidden cnot candidate. Great. + -- w2 is the wire that is not used with NOT in future + do + + trace "found one hidden copy-cat" $ return () + updateOutWires $ map (\x -> if x == w then w2 else x) + + (gsModifCtls,gsModifNots) <- updateFuture $ moveWire w w2 + + trace ("moving " ++ (show w) ++ " to " ++ (show w2)) $ return () + trace (show gsModifCtls) $ return () + trace (show gsModifNots) $ return () + + + s <- getExpState + trace ("before: usedNotWire = " ++ (show $ usedNotWires s)) $ return () + + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls) w2 $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + + updateUsedControlWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (gateId s) gs + Nothing -> Just $ IS.singleton (gateId s)) w3 c + + updateUsedNotWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifNots + Nothing -> Just gsModifNots) w2 $ + IM.update (\gs -> Just $ IS.difference gs gsModifNots) w c + + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w $ + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (gateId s) gs + Nothing -> Just $ IS.singleton (gateId s)) w2 c + + s <- getExpState + trace ("after: usedNotWire = " ++ (show $ usedNotWires s)) $ return () + + -- Update ExpMap + setExpMap $ IM.insert w (m_before IM.! w) $ + IM.insert w2 (m_after IM.! w) m_after + + storeOldGate $ Cnot w2 [(w3,True)] + incrGateId + return True + + _ -> -- No hidden Cnot, let's proceed... + do + let mw = m_after IM.! w + f <- if ((S.foldl' (\a (_,i) -> min a i) 3 mw) <= 1) + then return id + else do + v <- newFreshVar + return (S.insert (exp_var $ fromIntegral v, 1)) + setExpMap $ IM.adjust (\a -> pruneListExp 3 a) w $ + IM.adjust f w m_after + + storeOldGate g + incrGateId + return True + + ----------------- + -- Case of simple copy-cats + (w':_) -> do + s <- getExpState + updateOutWires $ map (\x -> if x == w then w' else x) + + s <- getExpState + trace (show $ future s) $ return () + (gsModifCtls,_) <- updateFuture $ moveWireFlip w w' + + -- update expMap: now, w is null and w' is not(old w) + expMap <- getExpMap + + setExpMap $ IM.insert w (m_before IM.! w) $ + IM.insert w' (S.map (\(e,i) -> (exp_not e,i)) (expMap IM.! w')) expMap + + + + trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () + trace (show gsModifCtls) $ return () + s <- getExpState + trace (show $ future s) $ return () + + s <- getExpState + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls) w' $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c + + storeOldGate (Cnot w' []) -- Set a flip on the w' wire + + incrGateId + + return True + + + + (w':_) -> do + + s <- getExpState + updateOutWires $ map (\x -> if x == w then w' else x) + + s <- getExpState + trace (show $ future s) $ return () + trace ("usedNotWire = " ++ (show $ usedNotWires s)) $ return () + (gsModifCtls,_) <- updateFuture $ moveWire w w' + + trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () + trace (show gsModifCtls) $ return () + s <- getExpState + trace (show $ future s) $ return () + + s <- getExpState + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.union gs gsModifCtls + Nothing -> Just gsModifCtls + ) w' $ + IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c + + storeOldGate NoOp -- replace g with NoOp so that gateId stays accurate + incrGateId + + return True + + +-- | Shuffle the circuit by sending the CNOT gates as far as +-- possible (i.e., until they hit a control, or to the end). +-- Return 'False' when the end of the circuit is reached, 'True' otherwise. +stepSwapCirc :: EvalCirc Bool +stepSwapCirc = do + s <- getExpState + + case (IM.lookup (gateId s) (gates_to_skip s)) of + + Just g -> do + + storeOldGate g + incrGateId + return True + + Nothing -> do + + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp (swap)... " ++ (show (gateId s))) {-(s `Seq.deepseq` (setExpState s))-} (return ()) else return () + case maybe_g of + + Nothing -> return False + + Just g@(Cnot w1 [(w2,b2)]) | IM.notMember (gateId s) (gates_to_skip s) -> do -- got a CNOT + + trace ("got a cnot to analyze " ++ (show $ gateId s) ++ " " ++ (show $ gates_to_skip s)) $ return () + + let id = min (nextUsedGate (usedNotWires s) (gateId s) (1 + sizeCirc s) w2) $ + (nextUsedGate (usedControlWires s) (gateId s) (1 + sizeCirc s) w1) + + trace ("found id = " ++ (show id)) $ return () + + if ( id > 1 + gateId s ) -- && (id <= (sizeCirc s) ) + then do ------------- there is something to move! + trace ("can be shifted to " ++ (show (id - 1))) $ return () + + addToSkipGates (id - 1) g + -- shiftGate g (id - 1 - (gateId s)) + + s <- getExpState + trace (show $ future s) $ return () + + -- Remove references to (gateId s) + + updateUsedControlWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c + updateUsedNotWires $ \c -> + IM.update (\gs -> Just $ IS.delete (gateId s) gs) w1 c + + -- Shift the ones between (gateId s) and id + + updateUsedNotWires $ + IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x + else x - 1 + updateUsedControlWires $ + IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x + else x - 1 + + s <- getExpState + let z = IM.mapKeys (\x -> if (x <= gateId s) || (x >= id) then x + else x - 1) (gates_to_skip s) in + z `seq` setExpState (s { gates_to_skip = z} ) + + -- Set g in position (id - 1) + + updateUsedControlWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (id - 1) gs + Nothing -> Just $ IS.singleton (id - 1)) w2 c + updateUsedNotWires $ \c -> + IM.alter (\maybe_gs -> case maybe_gs of + Just gs -> Just $ IS.insert (id - 1) gs + Nothing -> Just $ IS.singleton (id - 1)) w1 c + + -- Make sure we skip (id - 1) later on. + + + else do ------------- nothing to move... + trace "cannot be shifted" $ return () + storeOldGate g + incrGateId + + return True + + Just g -> do + trace ("got a random " ++ (show g)) $ return () + storeOldGate g + incrGateId + return True + + + +-- | A more elementary version of @'stepSwapCirc'@: shuffle the +-- circuit by sending to the end all the NOT gates that can be sent +-- there. Return 'False' when the end of the circuit is reached, +-- 'True' otherwise. +stepSwapCirc_simple :: EvalCirc Bool +stepSwapCirc_simple = do + maybe_g <- pullNewGate + trace ("pulled new gate " ++ (show maybe_g)) $ return () + s <- getExpState + case maybe_g of + + Nothing -> return False + + Just g | (gateId s) == (length $ past s) + (length $ future s) -> do + storeOldGate g + return False + + Just g@(Cnot w1 [(w2,b2)]) | + (lastUsedWire (usedNotWires s) w2) <= gateId s && + (lastUsedWire (usedNotWires s) w1) <= gateId s && + (lastUsedWire (usedControlWires s) w1) <= gateId s -> do -- got a CNOT + + trace "got a cnot that can be sent to the end" $ return () + + sendEndOfTime g + -- do not store gate, but increase gateId + incrGateId + return True + + Just g -> do + storeOldGate g + incrGateId + return True + +-- ---------------------------------------------------------------------- +-- ** Some wrappers + +-- | Run the monad until 'False' occurs. +runWhile :: Monad m => (a -> Bool) -> m a -> m () +runWhile f c = do + r <- c + if f r then runWhile f c else return () + +-- | Strip the 'NoOp' gates from a list of gates. +stripNoOp :: [Gate] -> [Gate] +stripNoOp = L.filter (/= NoOp) + +-- | Wrapper around 'stepEvalCirc'. +alg_simplify :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_simplify (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepEvalCirc) + +-- | Wrapper around 'stepSwapCirc'. +alg_swap :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_swap (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc) + + +-- | Wrapper around 'stepSwapCirc_simple'. +alg_swap_simple :: ([Gate],[Wire]) -> ([Gate],[Wire]) +alg_swap_simple (gs,out) = (stripNoOp gs',out') + where + gs' = (reverse $ past s) ++ (future s) + out' = outWires s + ws_in = getAllWires gs + s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc_simple) + +-- ---------------------------------------------------------------------- +-- * Multi-pass optimization + +-- | Auxiliary function. Simultaneously compute the maximum of the +-- lengths of two lists, and their point-wise equality. +is_equal_list :: Eq a => [a] -> [a] -> Int -> (Int,Bool) + +is_equal_list [] [] n = (n,True) +is_equal_list (h1:t1) (h2:t2) n | h1 == h2 = is_equal_list t1 t2 (n+1) +is_equal_list t1 t2 n = (n + max (length t1) (length t2),False) + +-- | Get the list of initialized wires from a circuit. +get_list_init :: [Gate] -> [Wire] +get_list_init ((Init _ w):gs) = w:(get_list_init gs) +get_list_init (g:gs) = get_list_init gs +get_list_init [] = [] + +-- | Do several passes of @'alg_simplify'@ until it reaches a fixed point. +simplRec' :: ([Gate],[Wire]) -> ([Gate],[Wire]) +simplRec' (l,output) = trace (show (l,output)) $ + let (l',output') = alg_simplify (l, output) in + let (n,b) = is_equal_list l l' 0 in + if b then (l,output) + else trace (show n) simplRec' $ suppressGarbageGates (l',output') + +-- | Do several passed of @'alg_swap'@ followed with @'simplRec'@ +-- until it reaches a fixed point. +simplRec :: ([Gate],[Wire]) -> ([Gate],[Wire]) +simplRec (l1,o1) = + let (l3,o3) = simplRec' $ alg_swap (l1,o1) in + let (n,b) = is_equal_list l1 l3 0 in + if b then (l3,o3) + else trace "Swapping!" $ simplRec $ (l3,o3) diff --git a/dist/build/Quipper/Libraries/Decompose.hs b/dist/build/Quipper/Libraries/Decompose.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Decompose.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Decompose.hs" #-} +-- | Functions to decompose circuits into various gate bases. + +module Quipper.Libraries.Decompose ( + -- * Precision + Precision, + bits, + digits, + -- * Phase + KeepPhase, + -- * Gate bases + GateBase (..), + gatebase_enum, + -- * Generic decomposition + decompose_generic, +) where + +import Quipper.Libraries.Decompose.CliffordT +import Quipper.Libraries.Decompose.GateBase +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.Synthesis diff --git a/dist/build/Quipper/Libraries/Decompose/CliffordT.hs b/dist/build/Quipper/Libraries/Decompose/CliffordT.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Decompose/CliffordT.hs @@ -0,0 +1,1071 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Decompose/CliffordT.hs" #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + +-- | This module provides transformers for decomposing circuits into +-- the Clifford+/T/ gate base. +-- +-- * [bold Control trimming.] This transformer uses doubly-controlled +-- /iX/-gates to reduce the number of controls on gates. Specifically, +-- it ensures that not-gates, Pauli /X/-, /Y/-, and /Z/-gates, and +-- /iX/-gates have at most two controls; that phase gates of the form +-- Diag(1, φ) have no controls; and that all other gates have at most +-- one control. +-- +-- * [bold Approximate Clifford+/T/ decomposition.] This decomposes +-- all rotation and phase gates into Clifford+/T/ up to a given +-- precision ε, using an approximate synthesis algorithm. Other gates +-- are unchanged. +-- +-- * [bold Exact Clifford+/T/ decomposition.] This decomposes all +-- gates that are exactly representable in the Clifford+/T/ base into +-- single-qubit Clifford gates, /T/, /T/[sup †], and singly-controlled +-- not-gates (with positive or negative control). Rotation and phase +-- gates are left unchanged. +-- +-- * [bold Standard gate set.] We define the standard gate set to +-- consist of the gates /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, +-- /T/[sup †], and /CNOT/. This transformer decomposes all gates that +-- remain after applying both approximate and exact Clifford+/T/ +-- decomposition into the standard gate set. If the transformer +-- encounters gates that are not single-qubit Clifford gates, /T/, +-- /T/[sup †], or singly-controlled not-gates (with positive or +-- negative control), then the output is still semantically correct, +-- but may not be in the standard gate set. This transformer +-- suppresses global phases. +-- +-- * [bold Strict gate set.] We define the strict gate set to consist +-- of the gates /H/, /S/, /T/, and /CNOT/. This transformer decomposes +-- all gates that remain after applying both approximate and exact +-- Clifford+/T/ decomposition into the strict gate set. If the +-- transformer encounters gates that are not single-qubit Clifford +-- gates, /T/, /T/[sup †], or singly-controlled not-gates (with +-- positive or negative control), then the output is still +-- semantically correct, but may not be in the strict gate set. This +-- transformer suppresses global phases. +-- +-- These above transformers may be applied in any order. Control +-- trimming is primarily for demonstration purposes; it does not need +-- to be combined with the other transformers as they do their own +-- trimming. The exact and approximate Clifford+/T/ decompositions can +-- be applied in either order; since they each target a different set +-- of gates, they must both be performed to obtain a complete +-- decomposition into the Clifford+/T/ gate set. The standard and +-- strict transformers assume that their input has already been +-- pre-processed by the exact and approximate transformers. + +module Quipper.Libraries.Decompose.CliffordT where + +import Quipper +import Quipper.Internal + +-- Stuff we need to import because the Dynamic Transformer interface +-- is not yet stable. +import Quipper.Internal.Circuit (BoxId, TypedSubroutine(..), OCircuit(..)) +import Quipper.Internal.Transformer +import Quipper.Internal.Generic (provide_subroutine_generic, transform_unary_dynamic) +import Quipper.Internal.Monad (endpoints_of_wires_in_arity, identity_dynamic_transformer, provide_subroutines, named_rotation_qulist_at, named_gate_qulist_at, subroutine) + +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.GateDecompositions +import Quipper.Libraries.Synthesis + +import Quipper.Utils.Auxiliary (optional) +import Quantum.Synthesis.SymReal + +import Control.Monad (when) +import System.Random +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | A version of 'with_combined_controls' that uses doubly-controlled +-- /iX/-gates to do the decomposition. For example, when /n/=2, this +-- yields circuits such as the following: +-- +-- \[image with_combined_controls2.png] +-- +-- And for /n/=1: +-- +-- \[image with_combined_controls1.png] +with_combined_controls_iX :: Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_iX = with_combined_controls cc_iX_plain_at + +-- | A version of 'with_combined_controls_iX' that further decomposes +-- the doubly-controlled /iX/-gates into the Clifford+/T/ gate base. +with_combined_controls_CT :: Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_CT = with_combined_controls cc_iX_at + +-- | Turn a list of signed controls into a list of positive quantum +-- controls, by applying all classical controls directly, and +-- conjugating any negative quantum controls by /X/. Call the +-- inner block with those quantum controls. Usage: +-- +-- > with_normalized_controls ctrls $ \qs -> do +-- > <<>> +with_normalized_controls :: [Signed Endpoint] -> ([Qubit] -> Circ a) -> Circ a +with_normalized_controls cs f = do + let (qcs, ccs) = partition_controls cs + with_controls ccs $ do + aux qcs [] + + where + aux [] qs = f (reverse qs) + aux (qc:qcs) qs = do + with_signed_qubit qc $ \q -> do + aux qcs (q:qs) + +-- | Like 'with_normalized_controls', but use /HSSH/ instead of /X/, +-- so as not to leave the /H/, /S/, /T/, /CNot/ gate base. +with_normalized_controls_HS :: [Signed Endpoint] -> ([Qubit] -> Circ a) -> Circ a +with_normalized_controls_HS cs f = do + let (qcs, ccs) = partition_controls cs + with_controls ccs $ do + aux qcs [] + + where + aux [] qs = f (reverse qs) + aux (qc:qcs) qs = do + with_signed_qubit_HS qc $ \q -> do + aux qcs (q:qs) + with_signed_qubit_HS (Signed q True) f = f q + with_signed_qubit_HS (Signed q False) f = do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + b <- f q + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + return b + +-- | Negate the number if the boolean is true. +negate_if :: (Num r) => Bool -> r -> r +negate_if False x = x +negate_if True x = -x + +-- ---------------------------------------------------------------------- +-- * Transformers + +-- ---------------------------------------------------------------------- +-- ** Control trimming + +-- | This transformer makes sure that not-gates, Pauli /X/-, /Y/-, and +-- /Z/-gates, and /iX/-gates have at most two controls; that phase +-- gates of the form Diag(1, φ) have no controls; and that all other +-- gates have at most one control. +trimcontrols_transformer :: Transformer Circ Qubit Bit +trimcontrols_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 2 cs $ \qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +trimcontrols_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + qmultinot qs `controlled` qcs + return (qs, [], cs) +trimcontrols_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + hadamard q `controlled` qcs + return ([q], [], cs) +trimcontrols_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + swap_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +trimcontrols_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + gate_W_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +trimcontrols_transformer gate@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are allowed two controls + ("X", [q], []) -> 2 + ("Y", [q], []) -> 2 + ("Z", [q], []) -> 2 + ("iX", [q], []) -> 2 + _ -> 1 + with_combined_controls_iX n cs $ \qcs -> do + named_gate_qulist_at name inv qs gctls `controlled` qcs + return (qs,gctls,cs) +trimcontrols_transformer (T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + with_combined_controls_iX 1 cs $ \qcs -> do + global_phase_anchored t qs `controlled` qcs + return cs +trimcontrols_transformer gate@(T_QRot name _ _ inv theta ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are decomposed to zero controls + ("R(2pi/%)", [q], []) -> 0 + ("T(%)", [q], []) -> 0 + _ -> 1 + case n of + 0 -> do + let [q] = qs + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + let [c] = qcs + with_signed_qubit c $ \q -> do + named_rotation_qulist_at name inv theta [q] gctls + return (qs,gctls,cs) + _ -> do + with_combined_controls_iX 1 cs $ \qcs -> do + named_rotation_qulist_at name inv theta qs gctls `controlled` qcs + return (qs,gctls,cs) + +-- The subroutine transformer clause is called when a subroutine gate appears, +-- for now we decompose the controls just like for other gates. The recursive +-- decomposition of a subroutine is taken care of in the dynamic transformer. +trimcontrols_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \namespace ws cs -> without_controls_if ncf $ do + let qws = [w | Endpoint_Qubit w <- ws] + provide_subroutines namespace + with_combined_controls_iX 1 cs $ \qcs -> do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` qcs + return (vs,cs) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +trimcontrols_transformer gate@(T_CNot _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CGate _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CSwap _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QPrep _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QUnprep _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QInit _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CInit _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_QMeas _) = identity_transformer gate +trimcontrols_transformer gate@(T_QDiscard _) = identity_transformer gate +trimcontrols_transformer gate@(T_CDiscard _) = identity_transformer gate +trimcontrols_transformer gate@(T_DTerm _ _) = identity_transformer gate +trimcontrols_transformer gate@(T_Comment _ _ _) = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Approximate Clifford+/T/ decomposition + +-- | This transformer decomposes rotation and phase gates into the +-- Clifford+/T/ basis, using the approximate synthesis algorithm of +-- . Other gates +-- are unchanged. +-- +-- This transformer requires a precision parameter, as well as a +-- source of randomness. The 'KeepPhase' flag indicates whether to +-- respect global phases. +approx_ct_transformer :: (RandomGen g) => KeepPhase -> Precision -> g -> Transformer Circ Qubit Bit +approx_ct_transformer kp prec g gate@(T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + comment_with_label (printf "ENTER: GPhase (t=%f)" t) cs "c" + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> approximate_synthesis_phase kp prec theta g + where + theta = pi * to_real t + [c] -> do + with_signed_qubit c $ \q -> do + approximate_synthesis_phase_ctrl kp prec theta g q + return () + where + theta = pi * to_real t + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + comment_with_label "EXIT: GPhase" cs "c" + return cs +approx_ct_transformer kp prec g gate@(T_QRot name _ _ inv t ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + comment_with_label (printf "ENTER: %s%s (t=%f)" name (optional inv "*") t) (qs,cs) ("q","c") + case (name, inv, qs, gctls) of + ("exp(-i%Z)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_zrot prec theta g q + return () + where + theta = negate_if inv (2 * to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_zrot_ctrl prec theta g q q2 + return () + where + theta = negate_if inv (2 * to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("exp(% pi i)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (to_real (pi*t)) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_phase_ctrl kp prec theta g q2 + return () + where + theta = negate_if inv (to_real (pi*t)) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("R(2pi/%)", inv, [q], []) -> do + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (2 * pi / to_real t) + [c] -> do + with_signed_qubit c $ \q1 -> do + approximate_synthesis_phase_ctrl kp prec theta g q1 + return () + where + theta = negate_if inv (2 * pi / to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("T(%)", inv, [q], []) -> do + with_combined_controls_iX 1 (Signed (Endpoint_Qubit q) True : cs) $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (-to_real t) + [c] -> do + with_signed_qubit c $ \q1 -> do + approximate_synthesis_phase_ctrl kp prec theta g q1 + return () + where + theta = negate_if inv (-to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("G(%)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_phase kp prec theta g + return () + where + theta = negate_if inv (-to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_phase_ctrl kp prec theta g q2 + return () + where + theta = negate_if inv (-to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + ("Rz(%)", inv, [q], []) -> do + with_combined_controls_iX 1 cs $ \qcs -> do + case qcs of + [] -> do + approximate_synthesis_zrot prec theta g q + return () + where + theta = negate_if inv (to_real t) + [c] -> do + with_signed_qubit c $ \q2 -> do + approximate_synthesis_zrot_ctrl prec theta g q q2 + return () + where + theta = negate_if inv (to_real t) + _ -> error ("approx_ct_transformer: internal error. " ++ show gate) + + _ -> error ("approx_ct_transformer: unimplemented gate: " ++ show gate) + comment_with_label (printf "EXIT: %s%s (t=%f)" name (optional inv "*") t) (qs,cs) ("q","c") + return (qs, gctls, cs) +approx_ct_transformer kp prec g gate = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Exact Clifford+/T/ decomposition + +-- | This transformer decomposes all gates that permit exact +-- Clifford+/T/ representations into the following concrete gate base +-- for Clifford+/T/: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Classical controls and classical gates are not subject to the gate +-- base, and are left untouched. +-- +-- Rotations and phase gates are left unchanged by this transformer, +-- but any controls on those gates will be decomposed. +exact_ct_transformer :: Transformer Circ Qubit Bit +exact_ct_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 2 cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + [c1,c2] -> do + toffoli_AMMR_at q c1 c2 + qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +exact_ct_transformer gate@(T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [] -> do + sequence_ [ gate_X_at q | q <- qs ] + qcs -> do + sequence_ [ qnot_at q | q <- qs ] `controlled` qcs + return (qs, [], cs) +exact_ct_transformer gate@(T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + cH_AMMR_at q c + qcs -> do + hadamard_at q `controlled` qcs + return ([q], [], cs) +exact_ct_transformer gate@(T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + fredkin_at q1 q2 c + qcs -> do + swap_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +exact_ct_transformer gate@(T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_CT 1 cs $ \qcs -> do + case qcs of + [c] -> do + controlled_W_at q1 q2 c + qcs -> do + gate_W_CliffordT_at q1 q2 `controlled` qcs + return ([q1, q2], [], cs) +exact_ct_transformer gate@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls cs -> without_controls_if ncf $ do + let n = case (name, qs, gctls) of + -- certain gates are allowed two controls + ("X", [q], []) -> 2 + ("Y", [q], []) -> 2 + ("Z", [q], []) -> 2 + ("iX", [q], []) -> 2 + _ -> 1 + with_combined_controls_CT n cs $ \qcs -> do + case (name, qs, gctls, qcs) of + + ("X", [q], [], [c1, c2]) -> do + toffoli_AMMR_at q c1 c2 + ("X", [q], [], [c]) -> do + qnot_at q `controlled` c + ("X", [q], [], []) -> do + gate_X_at q + + ("Y", [q], [], [c1, c2]) -> do + gate_S_inv_at q + toffoli_AMMR_at q c1 c2 + gate_S_at q + ("Y", [q], [], [c]) -> do + gate_S_inv_at q + qnot_at q `controlled` c + gate_S_at q + ("Y", [q], [], []) -> do + gate_Y_at q + + ("Z", [q], [], [c1, c2]) -> do + ccZ_AMMR_at q c1 c2 + ("Z", [q], [], [c]) -> do + hadamard_at q + qnot_at q `controlled` c + hadamard_at q + ("Z", [q], [], []) -> do + gate_Z_at q + + ("iX", [q], [], [c1, c2]) -> do + reverse_imp_if inv cc_iX_at q c1 c2 + ("iX", [q], [], [c]) -> do + reverse_imp_if inv controlled_iX_at q c + ("iX", [q], [], []) -> + reverse_imp_if inv gate_iX_at q + + ("S", [q], [], [c]) -> do + reverse_imp_if inv controlled_S_at q c + ("S", [q], [], []) -> do + reverse_imp_if inv gate_S_at q + + ("T", [q], [], [c]) -> do + reverse_imp_if inv controlled_T_at q c + ("T", [q], [], []) -> do + reverse_imp_if inv gate_T_at q + + ("V", [q], [], [c]) -> do + reverse_imp_if inv controlled_V_at q c + ("V", [q], [], []) -> do + reverse_imp_if inv gate_V_at q + + ("E", [q], [], [c]) -> do + reverse_imp_if inv controlled_E_at q c + ("E", [q], [], []) -> do + reverse_imp_if inv gate_E_at q + + ("YY", [q], [], [c]) -> do + reverse_imp_if inv controlled_YY_at q c + ("YY", [q], [], []) -> do + reverse_imp_if inv (named_gate_at "YY") q + + ("omega", [q], [], [c]) -> do + with_signed_qubit c $ \c1 -> do + reverse_imp_if inv gate_T_at c1 + ("omega", [q], [], []) -> do + reverse_imp_if inv gate_omega_at q + + _ -> error ("exact_ct_transformer: gate not implemented: " ++ show gate) + return (qs,gctls,cs) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +exact_ct_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CNot _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CGate _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CSwap _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QPrep _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QUnprep _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QInit _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CInit _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +exact_ct_transformer gate@(T_QMeas _) = identity_transformer gate +exact_ct_transformer gate@(T_QDiscard _) = identity_transformer gate +exact_ct_transformer gate@(T_CDiscard _) = identity_transformer gate +exact_ct_transformer gate@(T_DTerm _ _) = identity_transformer gate +exact_ct_transformer gate@(T_Comment _ _ _) = identity_transformer gate + + +-- ---------------------------------------------------------------------- +-- ** Decomposition into standard gate set + +-- | This transformer decomposes a circuit into the standard gate set, +-- which we define to be: +-- +-- * /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the standard gate set. The best way +-- to avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +standard_transformer :: Transformer Circ Qubit Bit +standard_transformer gate@(T_QGate "H" 1 0 _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "Y" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "Z" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "S" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "T" 1 0 _ ncf f) = identity_transformer gate +standard_transformer gate@(T_QGate "multinot" _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "swap" 2 0 _ _ _) = identity_transformer gate +standard_transformer gate@(T_QGate "W" 2 0 _ _ _) = identity_transformer gate + +standard_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qs -> do + case qs of + [] -> do + gate_X_at q + qs -> qnot_at q `controlled` qs + return ([q], [], cs) + +standard_transformer gate@(T_QGate "X" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + qcs -> do + qnot_at q `controlled` qcs + return ([q],[],cs) + +standard_transformer gate@(T_QGate "iX" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls cs $ \qcs -> do + case qcs of + [] -> do + gate_X_at q + qcs -> do + reverse_imp_if inv gate_iX_at q `controlled` qcs + return ([q],[],cs) + +standard_transformer gate@(T_QGate "V" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + reverse_imp_if inv gate_S_inv_at q + hadamard_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "E" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_inv_at q + return ([q],[],cs) +standard_transformer gate@(T_QGate "E" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "YY" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + reverse_imp_if inv gate_S_at q + hadamard_at q + reverse_imp_if inv gate_S_at q + return ([q],[],cs) + +standard_transformer gate@(T_QGate "omega" 1 0 _ ncf f) = f $ + \[q] [] cs -> + return ([q],[],cs) + +standard_transformer gate@(T_QGate name _ _ inv ncf f) = + error ("standard_transformer: gate not implemented: " ++ show gate) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +standard_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +standard_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +standard_transformer gate@(T_CNot _ _) = identity_transformer gate +standard_transformer gate@(T_CGate _ _ _) = identity_transformer gate +standard_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +standard_transformer gate@(T_CSwap _ _) = identity_transformer gate +standard_transformer gate@(T_QPrep _ _) = identity_transformer gate +standard_transformer gate@(T_QUnprep _ _) = identity_transformer gate +standard_transformer gate@(T_QInit _ _ _) = identity_transformer gate +standard_transformer gate@(T_CInit _ _ _) = identity_transformer gate +standard_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +standard_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +standard_transformer gate@(T_QMeas _) = identity_transformer gate +standard_transformer gate@(T_QDiscard _) = identity_transformer gate +standard_transformer gate@(T_CDiscard _) = identity_transformer gate +standard_transformer gate@(T_DTerm _ _) = identity_transformer gate +standard_transformer gate@(T_Comment _ _ _) = identity_transformer gate + +-- ---------------------------------------------------------------------- +-- ** Decomposition into strict gate set + +-- | This transformer decomposes a circuit into the strict gate set, +-- which we define to be: +-- +-- * /H/, /S/, /T/, and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the strict gate set. The best way to +-- avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +strict_transformer :: Transformer Circ Qubit Bit +strict_transformer gate@(T_QGate "H" 1 0 _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "multinot" _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "swap" 2 0 _ _ _) = identity_transformer gate +strict_transformer gate@(T_QGate "W" 2 0 _ _ _) = identity_transformer gate + +strict_transformer gate@(T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qs -> do + case qs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qs -> qnot_at q `controlled` qs + return ([q], [], cs) + +strict_transformer gate@(T_QGate "X" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qcs -> do + case qcs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qcs -> do + qnot_at q `controlled` qcs + return ([q],[],cs) + +strict_transformer gate@(T_QGate "Y" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "Z" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "iX" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_normalized_controls_HS cs $ \qcs -> do + case qcs of + [] -> do + hadamard_at q + gate_S_at q + gate_S_at q + hadamard_at q + qcs -> do + reverse_imp_if inv gate_iX_at q `controlled` qcs + return ([q],[],cs) + +strict_transformer gate@(T_QGate "S" 1 0 False ncf f) = + identity_transformer gate +strict_transformer gate@(T_QGate "S" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "T" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_T_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "T" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_T_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "V" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + hadamard_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "V" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + hadamard_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "E" 1 0 False ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + hadamard_at q + gate_S_at q + gate_S_at q + gate_S_at q + return ([q],[],cs) +strict_transformer gate@(T_QGate "E" 1 0 True ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + gate_S_at q + hadamard_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "YY" 1 0 inv ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_controls cs $ do + when (inv) $ do + gate_S_at q + gate_S_at q + gate_S_at q + hadamard_at q + gate_S_at q + when (inv) $ do + gate_S_at q + gate_S_at q + return ([q],[],cs) + +strict_transformer gate@(T_QGate "omega" 1 0 _ ncf f) = f $ + \[q] [] cs -> + return ([q],[],cs) + +strict_transformer gate@(T_QGate name _ _ inv ncf f) = + error ("strict_transformer: gate not implemented: " ++ show gate) + +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +strict_transformer gate@(T_QRot _ _ _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_GPhase _ _ _) = identity_transformer gate +strict_transformer gate@(T_Subroutine _ _ _ _ _ _ _ _ _ _) = identity_transformer gate +strict_transformer gate@(T_CNot _ _) = identity_transformer gate +strict_transformer gate@(T_CGate _ _ _) = identity_transformer gate +strict_transformer gate@(T_CGateInv _ _ _) = identity_transformer gate +strict_transformer gate@(T_CSwap _ _) = identity_transformer gate +strict_transformer gate@(T_QPrep _ _) = identity_transformer gate +strict_transformer gate@(T_QUnprep _ _) = identity_transformer gate +strict_transformer gate@(T_QInit _ _ _) = identity_transformer gate +strict_transformer gate@(T_CInit _ _ _) = identity_transformer gate +strict_transformer gate@(T_QTerm _ _ _) = identity_transformer gate +strict_transformer gate@(T_CTerm _ _ _) = identity_transformer gate +strict_transformer gate@(T_QMeas _) = identity_transformer gate +strict_transformer gate@(T_QDiscard _) = identity_transformer gate +strict_transformer gate@(T_CDiscard _) = identity_transformer gate +strict_transformer gate@(T_DTerm _ _) = identity_transformer gate +strict_transformer gate@(T_Comment _ _ _) = identity_transformer gate + + +-- ---------------------------------------------------------------------- +-- * Glue code for subroutines + +-- $ The following is stuff we have to do because subroutines are not +-- yet handled very abstractly. It is untested whether subroutines +-- work at all. + +-- | Handle subroutines for the 'trimcontrols_transformer'. +trimcontrols_subroutine :: BoxId -> TypedSubroutine -> Circ () +trimcontrols_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = trimcontrols_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "trimcontrols_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'trimcontrols_transformer'. +trimcontrols_dtransformer :: DynamicTransformer Circ Qubit Bit +trimcontrols_dtransformer = identity_dynamic_transformer { + transformer = trimcontrols_transformer, + define_subroutine = trimcontrols_subroutine} + +-- | Unary transformer for the 'trimcontrols_transformer'. +trimcontrols_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +trimcontrols_unary = transform_unary_dynamic trimcontrols_dtransformer + +-- | Handle subroutines for the 'approx_ct_transformer'. +approx_ct_subroutine :: (RandomGen g) => KeepPhase -> Precision -> g -> BoxId -> TypedSubroutine -> Circ () +approx_ct_subroutine kp prec g boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = approx_ct_unary kp prec g circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "approx_ct_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'approx_ct_transformer'. +approx_ct_dtransformer :: (RandomGen g) => KeepPhase -> Precision -> g -> DynamicTransformer Circ Qubit Bit +approx_ct_dtransformer kp prec g = identity_dynamic_transformer { + transformer = approx_ct_transformer kp prec g, + define_subroutine = approx_ct_subroutine kp prec g} + +-- | Unary transformer for the 'approx_ct_transformer'. +approx_ct_unary :: (RandomGen g, QCData qa, QCData qb) => KeepPhase -> Precision -> g -> (qa -> Circ qb) -> (qa -> Circ qb) +approx_ct_unary kp prec g = transform_unary_dynamic (approx_ct_dtransformer kp prec g) + +-- | Handle subroutines for the 'exact_ct_transformer'. +exact_ct_subroutine :: BoxId -> TypedSubroutine -> Circ () +exact_ct_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = exact_ct_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "exact_ct_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'exact_ct_transformer'. +exact_ct_dtransformer :: DynamicTransformer Circ Qubit Bit +exact_ct_dtransformer = identity_dynamic_transformer { + transformer = exact_ct_transformer, + define_subroutine = exact_ct_subroutine} + +-- | Unary transformer for the 'exact_ct_transformer'. +exact_ct_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +exact_ct_unary = transform_unary_dynamic exact_ct_dtransformer + +-- | Handle subroutines for the 'standard_transformer'. +standard_subroutine :: BoxId -> TypedSubroutine -> Circ () +standard_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = standard_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "standard_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'standard_transformer'. +standard_dtransformer :: DynamicTransformer Circ Qubit Bit +standard_dtransformer = identity_dynamic_transformer { + transformer = standard_transformer, + define_subroutine = standard_subroutine} + +-- | Unary transformer for the 'standard_transformer'. +standard_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +standard_unary = transform_unary_dynamic standard_dtransformer + +-- | Handle subroutines for the 'strict_transformer'. +strict_subroutine :: BoxId -> TypedSubroutine -> Circ () +strict_subroutine boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = strict_unary circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "strict_subroutine: " ++ x) boxid False circ' ein + +-- | Dynamic transformer for the 'strict_transformer'. +strict_dtransformer :: DynamicTransformer Circ Qubit Bit +strict_dtransformer = identity_dynamic_transformer { + transformer = strict_transformer, + define_subroutine = strict_subroutine} + +-- | Unary transformer for the 'strict_transformer'. +strict_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +strict_unary = transform_unary_dynamic strict_dtransformer + +-- ---------------------------------------------------------------------- +-- * Generic transformers + +-- $ The following generic functions form the high-level interface to +-- these decomposition transformers. This is how the transformers +-- should be accessed by user code. + +-- | This transformer makes sure that not-gates, Pauli /X/-, /Y/-, and +-- /Z/-gates, and /iX/-gates have at most two controls; that phase +-- gates of the form Diag(1, φ) have no controls; and that all other +-- gates have at most one control. +trimcontrols_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +trimcontrols_generic f = h where + f1 = quncurry f + h1 = trimcontrols_unary f1 + h = qcurry h1 + +-- | This transformer decomposes rotation and phase gates into the +-- Clifford+/T/ basis, using the approximate synthesis algorithm of +-- . It requires a precision +-- parameter, as well as a source of randomness. Other gates +-- are unchanged. +approx_ct_generic :: (RandomGen g, QCData qa, QCData qb, QCurry qfun qa qb) => KeepPhase -> Precision -> g -> qfun -> qfun +approx_ct_generic kp prec g f = h where + f1 = quncurry f + h1 = approx_ct_unary kp prec g f1 + h = qcurry h1 + +-- | This transformer decomposes all gates that permit exact +-- Clifford+/T/ representations into the following concrete gate base +-- for Clifford+/T/: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Classical controls and classical gates are not subject to the gate +-- base, and are left untouched. +-- +-- Rotations and phase gates are left unchanged by this transformer, +-- but any controls on those gates will be decomposed. +exact_ct_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +exact_ct_generic f = h where + f1 = quncurry f + h1 = exact_ct_unary f1 + h = qcurry h1 + +-- | This transformer decomposes a circuit into the standard gate set, +-- which we define to be: +-- +-- * /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the standard gate set. The best way +-- to avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +standard_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +standard_generic f = h where + f1 = quncurry f + h1 = standard_unary f1 + h = qcurry h1 + +-- | This transformer decomposes a circuit into the strict gate set, +-- which we define to be: +-- +-- * /H/, /S/, /T/, and /CNOT/. +-- +-- As a precondition, the input circuit must only contain the +-- following gates: +-- +-- * controlled-not (with one positive or negative control), +-- +-- * any single-qubit Clifford gates, +-- +-- * /T/ and /T/[sup †]. +-- +-- Global phases are suppressed. Classical controls and classical +-- gates are not subject to the gate base, and are left untouched. +-- +-- Any gates that are not among the input gates listed above will be +-- transformed to a semantically correct circuit which may, however, +-- contain gates that are not in the strict gate set. The best way to +-- avoid this is to apply exact and approximate Clifford+/T/ +-- decomposition first. +strict_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +strict_generic f = h where + f1 = quncurry f + h1 = strict_unary f1 + h = qcurry h1 diff --git a/dist/build/Quipper/Libraries/Decompose/GateBase.hs b/dist/build/Quipper/Libraries/Decompose/GateBase.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Decompose/GateBase.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Decompose/GateBase.hs" #-} +-- | This module provides an enumeration type for gate bases. This is +-- useful, for example, to provide a uniform interface to gate base +-- decomposers, so that they can be selected via command line options +-- or function arguments. + +module Quipper.Libraries.Decompose.GateBase where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Synthesis +import Quipper.Libraries.Decompose.Legacy +import Quipper.Libraries.Decompose.CliffordT + +import Quipper.Utils.RandomSource + +import System.Random + +-- ---------------------------------------------------------------------- +-- * Gate bases + +-- | An enumeration type for gate bases. More cases can be added in +-- the future, for example for using gates from a particular physical +-- machine description. +-- +-- Some gate bases carry additional parameters; for example, in the +-- case of decomposition into a discrete gate base, one may specify a +-- precision ε, a random seed, or other flags. +-- +-- If a 'Precision' parameter is present, it specifies the desired +-- precision per gate. If a 'RandomSource' parameter is present, it +-- specifies a source of randomness. +-- +-- If a 'KeepPhase' parameter is present, it determines whether global +-- phases are respected ('True') or disregarded ('False'). +data GateBase = + Logical + -- ^ Use all logical gates, i.e., leave the circuit unchanged. + | Binary + -- ^ Decompose into binary gates. + | Toffoli + -- ^ Decompose into Toffoli and binary gates. + | CliffordT_old + -- ^ Decompose into Clifford+/T/. This is a legacy transformer + -- that does not handle all gates correctly. For example, it does + -- not handle /W/-gates, rotations, or phase gates. Use + -- 'CliffordT' instead. + | CliffordT KeepPhase Precision RandomSource + -- ^ Decompose into Clifford+/T/, specifically: single-qubit + -- Clifford gates, the controlled-not gate (with positive or + -- negative controls), and the gates /T/ and /T/[sup †]. + | Standard Precision RandomSource + -- ^ Decompose into the standard gate set, which we define to be + -- /X/, /Y/, /Z/, /H/, /S/, /S/[sup †], /T/, /T/[sup †], and + -- /CNOT/. Suppresses global phases. + | Strict Precision RandomSource + -- ^ Decompose into /H/, /S/, /T/, /CNOT/ gates only. Suppresses + -- global phases. + | Approximate KeepPhase Precision RandomSource + -- ^ Decompose rotation and phase gates into Clifford+/T/, using + -- an approximate synthesis algorithm. Other gates are unchanged. + | Exact + -- ^ Decompose gates that can be exactly represented in the + -- Clifford+/T/ base into that base, specifically: single-qubit + -- Clifford gates, the controlled-not gate (with positive or + -- negative controls), and the gates /T/ and /T/[sup †]. Leave + -- rotation and phase gates unchanged. + | TrimControls + -- ^ Eliminate excess controls from gates. + deriving Show + +-- | An assignment of gate bases to names. Names are given as +-- lower-case strings. +-- +-- This can be useful, e.g., in the definition of command line +-- options. +-- +-- In the future, the syntax should be extended so that users can +-- specify parameters (e.g., the precision, random seed) on the +-- command line as well. For now, we just use the default precision. +gatebase_enum :: [(String, GateBase)] +gatebase_enum = [ + ("logical", Logical), + ("binary", Binary), + ("toffoli", Toffoli), + ("cliffordt_old", CliffordT_old), + ("cliffordt", CliffordT False (30 * digits) rs), + ("cliffordt_keepphase", CliffordT True (30 * digits) rs), + ("standard", Standard (30 * digits) rs), + ("strict", Strict (30 * digits) rs), + ("approximate", Approximate False (30 * digits) rs), + ("approximate_keepphase", Approximate True (30 * digits) rs), + ("exact", Exact), + ("trimcontrols", TrimControls) + ] + where + rs = RandomSource (read "1" :: StdGen) + +-- ---------------------------------------------------------------------- +-- * Generic decomposition + +-- | Decompose a circuit into gates from the given 'GateBase'. This +-- can be applied to a circuit-generating function in curried form +-- with /n/ arguments, for any /n/ ≥ 0. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > decompose_generic :: (QCData qa) => GateBase -> Circ qa -> Circ qa +-- > decompose_generic :: (QCData qa, QCData qb) => GateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +-- > decompose_generic :: (QCData qa, QCData qb, QCData qc) => GateBase -> (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) +-- +-- and so forth. + +decompose_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => GateBase -> qfun -> qfun +decompose_generic Logical = id +decompose_generic Binary = decompose_legacy_generic GB_Binary +decompose_generic Toffoli = decompose_legacy_generic GB_Toffoli +decompose_generic CliffordT_old = decompose_legacy_generic GB_CliffordT +decompose_generic (CliffordT kp prec (RandomSource g)) = exact_ct_generic . approx_ct_generic kp prec g +decompose_generic (Standard prec (RandomSource g)) = standard_generic . exact_ct_generic . approx_ct_generic False prec g +decompose_generic (Strict prec (RandomSource g)) = strict_generic . exact_ct_generic . approx_ct_generic False prec g +decompose_generic (Approximate kp prec (RandomSource g)) = approx_ct_generic kp prec g +decompose_generic Exact = exact_ct_generic +decompose_generic TrimControls = trimcontrols_generic + + diff --git a/dist/build/Quipper/Libraries/Decompose/Legacy.hs b/dist/build/Quipper/Libraries/Decompose/Legacy.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Decompose/Legacy.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Decompose/Legacy.hs" #-} +{-# LANGUAGE Rank2Types #-} + +-- | Functions to decompose circuits into various gate bases. This +-- decompositions are \"legacy\". The 'GB_Toffoli' and 'GB_CliffordT' +-- decomposers contained here are being superseded by their +-- counterparts in "Quipper.Libraries.Decompose.CliffordT". + +module Quipper.Libraries.Decompose.Legacy where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.GateDecompositions + +-- The following is a bunch of stuff we need to import because, +-- temporarily, Decompose.hs uses low-level interfaces. It should be +-- re-implemented using only high-level interfaces, or in some cases, +-- more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Internal.Transformer (bindings_empty, bind_list, unbind_list, DynamicTransformer(..)) +import Quipper.Internal.Generic (provide_subroutine_generic, transform_unary_dynamic) + +import Control.Monad + +-- ---------------------------------------------------------------------- +-- * Legacy gatebase + +-- | An enumeration type for the three gate bases handled by this +-- module. +data LegacyGateBase = GB_Toffoli | GB_Binary | GB_CliffordT + deriving (Show) +-- ---------------------------------------------------------------------- +-- * Helper functions + +-- | Decompose quantum controls recursively until at most /n/ remain, +-- and then pass these reduced controls to the given circuit. +-- Precondition: /n/ ≥ 1. The decomposition is done using Toffoli +-- gates, decomposed into the gate base. Classical controls are left +-- untouched. +-- +-- For example, when /n/=2, this typically yields a circuit such as +-- the following (but with the Toffoli gates further decomposed into +-- the 'LegacyGateBase'): +-- +-- \[image decompose2Controls.png] +-- +-- And for /n/=1, the circuit typically looks like this: +-- +-- \[image decomposeControls.png] +with_combined_controls_gb :: LegacyGateBase -> Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls_gb GB_Toffoli = with_combined_controls toffoli_plain_at +with_combined_controls_gb GB_Binary = with_combined_controls toffoli_V_at +with_combined_controls_gb GB_CliffordT = with_combined_controls toffoli_AMMR_at + +-- | Decompose a Toffoli gate into the given 'LegacyGateBase'. The controls +-- on the Toffoli gate may be positive or negative, as specified. +decomposeQToffoli :: LegacyGateBase -> Qubit -> (Signed Qubit, Signed Qubit) -> Circ () +decomposeQToffoli GB_Toffoli q (c1, c2) = qnot_at q `controlled` [c1,c2] +decomposeQToffoli GB_Binary q (c1, c2) = do + toffoli_V_at q c1 c2 +decomposeQToffoli GB_CliffordT q3 (c1, c2) = do + toffoli_AMMR_at q3 c1 c2 + +-- | The inverse of 'decomposeQToffoli'. +decomposeQToffoli_inv :: LegacyGateBase -> Qubit -> (Signed Qubit, Signed Qubit) -> Circ () +decomposeQToffoli_inv gb = reverse_generic_imp (decomposeQToffoli gb) + +-- | Implement a QMultinot gate in terms of QNot gates. +decomposeQMultinot :: [Qubit] -> Circ () +decomposeQMultinot [] = return () +decomposeQMultinot (q:qs) = do + qnot_at q + decomposeQMultinot qs + +-- ---------------------------------------------------------------------- +-- * Decomposition transformers + +-- | A transformer to decompose a circuit into 'LegacyGateBase' gates. Note +-- that in the case of classically-controlled quantum gates, the +-- classical controls are unaffected. +decompose_transformer :: LegacyGateBase -> Transformer Circ Qubit Bit +decompose_transformer gb (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 2 cs $ \qcs -> do + case qcs of + -- two controls + [c1, c2] -> do + decomposeQToffoli gb q (c1,c2) + return ([q], [], cs) + -- zero or one control + qcs -> do + qnot_at q `controlled` qcs + return ([q], [], cs) +decompose_transformer gb (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + decomposeQMultinot qs `controlled` qcs + return (qs, [], cs) +decompose_transformer gb (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + hadamard q `controlled` qcs + return ([q], [], cs) +decompose_transformer gb (T_QGate "swap" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + case qcs of + -- one control + [c] -> do + qnot_at q1 `controlled` q2 + decomposeQToffoli gb q2 (c,(Signed q1 True)) + qnot_at q1 `controlled` q2 + return ([q1, q2], [], cs) + -- zero controls + qcs -> do + swap_at q1 q2 + return ([q1, q2], [], cs) +decompose_transformer gb (T_QGate "W" 2 0 _ ncf f) = f $ + \[q1, q2] [] cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + case qcs of + -- one control + [c] -> do + qnot q2 `controlled` q1 + w' <- qinit_qubit False + decomposeQToffoli gb w' (c,(Signed q2 True)) + hadamard q1 `controlled` w' + decomposeQToffoli_inv gb w' (c,(Signed q2 True)) + qterm_qubit False w' + qnot q2 `controlled` q1 + return ([q1, q2], [], cs) + -- zero controls + qcs -> do + gate_W q1 q2 + return ([q1, q2], [], cs) +decompose_transformer gb (T_QGate name _ _ inv ncf f) = f $ + \qs vs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + named_gate_qulist_at name inv qs vs `controlled` qcs + return (qs, vs, cs) +decompose_transformer gb (T_QRot name _ _ inv theta ncf f) = f $ + \qs vs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + named_rotation_qulist_at name inv theta qs vs `controlled` qcs + return (qs, vs, cs) +decompose_transformer gb (T_GPhase t ncf f) = f $ + \qs cs -> without_controls_if ncf $ do + with_combined_controls_gb gb 1 cs $ \qcs -> do + global_phase_anchored_list t qs `controlled` qcs + return cs + +-- The subroutine transformer clause is called when a subroutine gate appears, +-- for now we decompose the controls just like for other gates. The recursive +-- decomposition of a subroutine is taken care of in the dynamic transformer. +decompose_transformer gb (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \namespace ws cs -> without_controls_if ncf $ do + let qws = [w | Endpoint_Qubit w <- ws] + with_combined_controls_gb gb 1 cs $ \qcs -> do + provide_subroutines namespace + case qcs of + -- one control + [c] -> if length qws /= length ws then error "Classical subroutine, used with quantum controls" else do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,cs) + -- zero controls + qcs -> do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws + return (vs,cs) +-- We list catch-all cases explicitly, so that the type-checker can +-- warn about new gates that must be added to the list. +decompose_transformer gb gate@(T_CNot _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CGate _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CGateInv _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CSwap _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QPrep _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QUnprep _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QInit _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CInit _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QTerm _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_CTerm _ _ _) = identity_transformer gate +decompose_transformer gb gate@(T_QMeas _) = identity_transformer gate +decompose_transformer gb gate@(T_QDiscard _) = identity_transformer gate +decompose_transformer gb gate@(T_CDiscard _) = identity_transformer gate +decompose_transformer gb gate@(T_DTerm _ _) = identity_transformer gate +decompose_transformer gb gate@(T_Comment _ _ _) = identity_transformer gate + +-- | Return a circuit producing function from a TypedSubroutine +open_subroutine :: TypedSubroutine -> [Endpoint] -> Circ [Endpoint] +open_subroutine (TypedSubroutine ocircuit _ _ scf) inputs = do + let OCircuit (win, circuit, wout) = ocircuit + when (length win /= length inputs) $ do + error ("open_subroutine: subroutine has been applied to incorrect size of QCData") + let in_bind = bind_list win inputs bindings_empty + out_bind <- apply_circuit_with_bindings circuit in_bind + let outputs = unbind_list out_bind wout + return outputs + +-- | Apply the decompose transformer to the given TypedSubroutine +-- Note: by default, set the classical-control flag to false. +decompose_subroutine :: LegacyGateBase -> BoxId -> TypedSubroutine -> Circ () +decompose_subroutine gb boxid sub@(TypedSubroutine ocirc is os ctl) = do + let circ = open_subroutine sub + let circ' = decompose_legacy_unary gb circ + let OCircuit (win, (arity,_,_,_), _) = ocirc + let ein = endpoints_of_wires_in_arity arity win + provide_subroutine_generic (\x -> "decompose_subroutine: " ++ x) boxid False circ' ein + +-- | A dynamic transformer variant of the decompose transformer +decompose_dynamic_transformer :: LegacyGateBase -> DynamicTransformer Circ Qubit Bit +decompose_dynamic_transformer gb = identity_dynamic_transformer { + transformer = decompose_transformer gb, + define_subroutine = decompose_subroutine gb} + +-- ---------------------------------------------------------------------- +-- * Generic decomposition + +-- | Decompose a circuit into gates from the given 'LegacyGateBase'. +decompose_legacy_unary :: (QCData qa, QCData qb) => LegacyGateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +decompose_legacy_unary gb circ = transform_unary_dynamic (decompose_dynamic_transformer gb) circ + +-- | Decompose a circuit into gates from the given 'LegacyGateBase'. Unlike +-- 'decompose_legacy_unary', this can be applied to a circuit-generating +-- function in curried form with /n/ arguments, for any /n/ ≥ 0. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > decompose_legacy_generic :: (QCData qa) => LegacyGateBase -> Circ qa -> Circ qa +-- > decompose_legacy_generic :: (QCData qa, QCData qb) => LegacyGateBase -> (qa -> Circ qb) -> (qa -> Circ qb) +-- > decompose_legacy_generic :: (QCData qa, QCData qb, QCData qc) => LegacyGateBase -> (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) +-- +-- and so forth. + +decompose_legacy_generic :: (QCData qa, QCData qb, QCurry qfun qa qb) => LegacyGateBase -> qfun -> qfun +decompose_legacy_generic gatebase f = g where + f1 = quncurry f + g1 = decompose_legacy_unary gatebase f1 + g = qcurry g1 + diff --git a/dist/build/Quipper/Libraries/DynamicLiftings.hs b/dist/build/Quipper/Libraries/DynamicLiftings.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/DynamicLiftings.hs @@ -0,0 +1,657 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/DynamicLiftings.hs" #-} +-- | This library provides various transformers and functions for +-- performing dynamic liftings based on different mechanisms. Some use +-- simulations to do the dynamic liftings; others just do them +-- randomly. There are also functions for printing the simulated +-- circuit. +-- +-- This code is experimental. + +module Quipper.Libraries.DynamicLiftings where + +import Quipper + +-- The following is a bunch of stuff we need to import because, +-- temporarily, DynamicLiftings.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit (Namespace, namespace_empty, TypedSubroutine(..), OCircuit(..), reverse_ocircuit, showNames) +import Quipper.Internal (BType) +import Quipper.Internal.Transformer +import Quipper.Internal.Monad +import Quipper.Internal.Generic (transform_unary_dynamic_shape) +import Quipper.Internal.Printing (getBit) + +import Quipper.Libraries.Simulation.QuantumSimulation + +import Quipper.Utils.Auxiliary (map_provide) + +-- we use the state monad to hold our \"quantum\" state +import Control.Monad.State +-- we use a random number generator to simulate \"quantum randomness\" +import System.Random hiding (split) +-- we store \"basis\" states as a map, +--i.e., Map Qubit Bool represents a basis state. +import Data.Map (Map) +import qualified Data.Map as Map + +-- ====================================================================== +-- * Random Dynamic Liftings and Liftings from a List + +-- | A State monad that holds a random generator. +type RandomCirc a = StateT StdGen Circ a + +-- | A State monad that holds a list of booleans. +type ListCirc a = StateT [Bool] Circ a + +-- | To evaluate a 'RandomCirc' we require a seed for the random generator. +evalRandomCirc :: Int -> RandomCirc a -> Circ a +evalRandomCirc seed rc = evalStateT rc (mkStdGen seed) + +-- | To evaluate a 'ListCirc' we require a list of booleans. +evalListCirc :: [Bool] -> ListCirc a -> Circ a +evalListCirc bools lc = evalStateT lc bools + +-- | Lift 'evalRandomCirc' to unary random circuit generating functions. +evalRandomCirc_unary :: Int -> (a -> RandomCirc b) -> a -> Circ b +evalRandomCirc_unary seed rcirc input = evalRandomCirc seed (rcirc input) + +-- | Left 'evalListCirc' to unary list circuit generating functions. +evalListCirc_unary :: [Bool] -> (a -> ListCirc b) -> a -> Circ b +evalListCirc_unary bools lcirc input = evalListCirc bools (lcirc input) + +-- | Lift the underlying 'randomR' function into the RandomCirc monad. +randomRRandomCirc :: Random a => (a,a) -> RandomCirc a +randomRRandomCirc (a0,a1) = do + stdgen <- get + let (random_a,stdgen') = randomR (a0,a1) stdgen + put stdgen' + return random_a + +-- | Print a RandomCirc by evaluating it with a seed in the IO monad. +print_unary_random :: (QCData qa) => Format -> (qa -> RandomCirc b) -> qa -> IO () +print_unary_random format rcirc input = do + seed <- randomIO + let circ = evalRandomCirc_unary seed rcirc + print_unary format circ input + +-- | Print a LiftCirc by evaluating it in the IO Monad, so as to read +-- in a given number of booleans. +print_unary_list :: (QCData qa) => Format -> Int -> (qa -> ListCirc b) -> qa -> IO () +print_unary_list format liftings lcirc input = do + bools <- mapM (\() -> getBit) (replicate liftings ()) + let circ = evalListCirc_unary bools lcirc + print_unary format circ input + +-- | Lift the 'identity_transformer' using any monad transformer. +lifted_identity_transformer :: (MonadTrans t) => Transformer (t Circ) Qubit Bit +lifted_identity_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> lift $ without_controls_if ncf $ do + q' <- qnot q `controlled` cs + return ([q'], [] ,cs) +lifted_identity_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \ws [] cs -> lift $ without_controls_if ncf $ do + ws' <- qmultinot_list (map (\x -> (x,True)) ws) `controlled` cs + return (ws', [], cs) +lifted_identity_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> lift $ without_controls_if ncf $ do + q' <- hadamard q `controlled` cs + return ([q'], [], cs) +lifted_identity_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w,v] [] cs -> lift $ without_controls_if ncf $ do + (w',v') <- swap_qubit w v `controlled` cs + return ([w',v'], [], cs) +lifted_identity_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w,v] [] cs -> lift $ without_controls_if ncf $ do + (w',v') <- gate_W w v `controlled` cs + return ([w',v'], [], cs) +lifted_identity_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c + return (ws', vs', c) +lifted_identity_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c + return (ws', vs', c) +lifted_identity_transformer (T_GPhase t ncf f) = f $ + \qs c -> lift $ without_controls_if ncf $ do + global_phase_anchored_list t qs `controlled` c + return c +lifted_identity_transformer (T_CNot ncf f) = f $ + \q c -> lift $ without_controls_if ncf $ do + q' <- cnot q `controlled` c + return (q', c) +lifted_identity_transformer (T_CGate name ncf f) = f $ + \ws -> lift $ without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) +lifted_identity_transformer (T_CGateInv name ncf f) = f $ + \v ws -> lift $ without_controls_if ncf $ do + cgateinv name v ws + return ws +lifted_identity_transformer (T_CSwap ncf f) = f $ + \w v c -> lift $ without_controls_if ncf $ do + (w',v') <- swap_bit w v `controlled` c + return (w',v',c) +lifted_identity_transformer (T_QPrep ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + v <- prepare_qubit w + return v +lifted_identity_transformer (T_QUnprep ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + v <- unprepare_qubit w + return v +lifted_identity_transformer (T_QInit b ncf f) = f $ + lift $ without_controls_if ncf $ do + w <- qinit_qubit b + return w +lifted_identity_transformer (T_CInit b ncf f) = f $ + lift $ without_controls_if ncf $ do + w <- cinit_bit b + return w +lifted_identity_transformer (T_QTerm b ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + qterm_qubit b w + return () +lifted_identity_transformer (T_CTerm b ncf f) = f $ + \w -> lift $ without_controls_if ncf $ do + cterm_bit b w + return () +lifted_identity_transformer (T_QMeas f) = f $ + \w -> lift $ do + v <- measure_qubit w + return v +lifted_identity_transformer (T_QDiscard f) = f $ + \w -> lift $ do + qdiscard_qubit w + return () +lifted_identity_transformer (T_CDiscard f) = f $ + \w -> lift $ do + cdiscard_bit w + return () +lifted_identity_transformer (T_DTerm b f) = f $ + \w -> lift $ do + dterm_bit b w + return () +lifted_identity_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \ns ws c -> lift $ without_controls_if ncf $ do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,c) +lifted_identity_transformer (T_Comment s inv f) = f $ + \ws -> lift $ do + comment_label s inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] + return () + +-- | Dynamic lifting can make use of a random result (without caring which wire is +-- being lifted). +random_dynamic_lift :: Bit -> RandomCirc Bool +random_dynamic_lift _ = randomRRandomCirc (False,True) + +-- | Dynamic lifting can pop the head off of a list of booleans, and use that to +-- lift the given wire. +list_dynamic_lift :: Bit -> ListCirc Bool +list_dynamic_lift _ = do + xs <- get + case xs of + [] -> error "ListCirc list of liftings exhausted" + (x:xs') -> do + put xs' + return x + +-- | A dynamic transformer which is the identity transformer (lifted to +-- RandomCirc), except for the dynamic lifting operation. +random_dynamic_lift_transformer :: DynamicTransformer (StateT StdGen Circ) Qubit Bit +random_dynamic_lift_transformer = DT { + transformer = lifted_identity_transformer, + define_subroutine = \name subroutine -> do + lift $ put_subroutine_definition name subroutine, + lifting_function = random_dynamic_lift + } + +-- | A dynamic transformer which is the identity transformer (lifted to +-- ListCirc), except for the dynamic lifting operation. +list_dynamic_lift_transformer :: DynamicTransformer (StateT [Bool] Circ) Qubit Bit +list_dynamic_lift_transformer = DT { + transformer = lifted_identity_transformer, + define_subroutine = \name subroutine -> do + lift $ put_subroutine_definition name subroutine, + lifting_function = list_dynamic_lift + } + +-- | Print a circuit, using random dynamic liftings. +print_unary_with_random_liftings :: (QCData a,QCData b) => Format -> (a -> Circ b) -> a -> IO () +print_unary_with_random_liftings format circ shape = do + let lifted_circ = transform_unary_dynamic_shape random_dynamic_lift_transformer circ shape + print_unary_random format lifted_circ shape + +-- | Print a circuit, using a list of dynamic liftings. +print_unary_with_list_liftings :: (QCData a,QCData b) => Format -> Int -> (a -> Circ b) -> a -> IO () +print_unary_with_list_liftings format liftings circ shape = do + let lifted_circ = transform_unary_dynamic_shape list_dynamic_lift_transformer circ shape + print_unary_list format liftings lifted_circ shape + +-- ====================================================================== +-- * Simulating the Dynamic Liftings + +-- | Add state to the Circ Monad so that we can simulate the circuit +-- and use that data for dynamic liftings. +data SimulationState = SS { + s_quantum_state :: Amplitudes Double, + s_classical_state :: Map Bit Bool, + s_namespace :: Namespace, -- we need a namespace to keep track of subroutines + s_rng :: StdGen + } + +-- | When we start a simulation, we need an empty starting state, with +-- a seed for the generator. +empty_simulation_state :: Int -> SimulationState +empty_simulation_state seed = SS { s_quantum_state = Vector [(Map.empty,1.0)], s_classical_state = Map.empty, s_namespace = namespace_empty, s_rng = mkStdGen seed} + +-- | A State monad that holds our SimulationState. +type SimulatedCirc a = StateT SimulationState Circ a + +-- | Evaluate a 'SimulatedCirc'. This requires a seed for the random generator. +evalSimulatedCirc :: Int -> SimulatedCirc a -> Circ a +evalSimulatedCirc seed sc = evalStateT sc (empty_simulation_state seed) + +-- | Lift 'evalSimulatedCirc' to unary functions. +evalSimulatedCirc_unary :: Int -> (a -> SimulatedCirc b) -> a -> Circ b +evalSimulatedCirc_unary seed scirc input = evalSimulatedCirc seed (scirc input) + +-- | Lift the underlying 'randomR' function into the SimulatedCirc monad. +randomRSimulatedCirc :: Random a => (a,a) -> SimulatedCirc a +randomRSimulatedCirc (a0,a1) = do + state <- get + let stdgen = s_rng state + let (random_a,stdgen') = randomR (a0,a1) stdgen + put (state {s_rng = stdgen'}) + return random_a + +-- | A specialized put function for the quantum state that uses the current state +-- instead of a previously retrieved state. +putQS :: Amplitudes Double -> SimulatedCirc () +putQS amps = do + state <- get + put (state {s_quantum_state = amps}) + +-- | A specialized put function for the classical state that uses the current state +-- instead of a previously retrieved state. +putCS :: Map Bit Bool -> SimulatedCirc () +putCS bits = do + state <- get + put (state {s_classical_state = bits}) + +-- | It doesn't make sense having a quantum control on a classical gate, so +-- we can throw an error if that is the case, and just lookup the boolean +-- result otherwise. +s_classical_control :: Map Bit Bool -> Signed (B_Endpoint Qubit Bit) -> Bool +s_classical_control bits (Signed bep val) = case bep of + (Endpoint_Bit bit) -> val == val' where val' = bits Map.! bit + (Endpoint_Qubit _) -> error "CNot: Quantum Control on Classical Gate" + +-- | Map the 's_classical_control' function to all the controls, and take the +-- 'and' of the result. +s_classical_controls :: Map Bit Bool -> Ctrls Qubit Bit -> Bool +s_classical_controls bits cs = and (map (s_classical_control bits) cs) + +-- | When we want a quantum control, we will be working with one "basis state" at +-- a time, and can look up the qubit's value in that basis state to see whether +-- the control fires. +s_qc_control :: Map Bit Bool -> Map Qubit Bool -> Signed (B_Endpoint Qubit Bit) -> Bool +s_qc_control bits mqb (Signed bep val) = case bep of + (Endpoint_Bit bit) -> val == val' where val' = bits Map.! bit + (Endpoint_Qubit q) -> val == val' where val' = mqb Map.! q + +-- | Map the 's_qc_control' function to all the controls (under the given basis +-- state), and take the 'and' of the result. +s_qc_controls :: Map Bit Bool -> Map Qubit Bool -> Ctrls Qubit Bit -> Bool +s_qc_controls bits mqb cs = and (map (s_qc_control bits mqb) cs) + +-- | Apply the given function only if the controls fire. +s_if_controls :: Map Bit Bool -> Ctrls Qubit Bit -> (Map Qubit Bool -> Amplitudes Double) -> Map Qubit Bool -> Amplitudes Double +s_if_controls bits c f mqb = if (s_qc_controls bits mqb c) then f mqb else Vector [(mqb,1)] + +-- | The 'simulated_lift_transformer' is the actual transformer that does the +-- simulation, while recreating the circuit. +simulated_lift_transformer :: Transformer (StateT SimulationState Circ) Qubit Bit +-- Translation of classical gates: +simulated_lift_transformer (T_CNot ncf f) = f $ + \b c -> do + (b,c) <- lift $ without_controls_if ncf $ do + b' <- cnot b `controlled` c + return (b', c) + state <- get + let bits = s_classical_state state + let ctrl = s_classical_controls bits c + let val = bits Map.! b + let bits' = if ctrl then (Map.insert b (not val) bits) else bits + putCS bits' + return (b,c) +simulated_lift_transformer (T_CInit val ncf f) = f $ + do + b <- lift $ without_controls_if ncf $ do + w <- cinit_bit val + return w + state <- get + let bits = s_classical_state state + putCS (Map.insert b val bits) + return b +simulated_lift_transformer (T_CTerm b ncf f) = f $ + \w -> do + lift $ without_controls_if ncf $ do + cterm_bit b w + return () + state <- get + let bits = s_classical_state state + let val = bits Map.! w + if val /= b then error "CTerm: Assertion Incorrect" + else do + putCS (Map.delete w bits) +simulated_lift_transformer (T_CDiscard f) = f $ + \w -> do + lift $ do + cdiscard_bit w + state <- get + let bits = s_classical_state state + putCS (Map.delete w bits) +simulated_lift_transformer (T_DTerm b f) = f $ + \w -> do + lift $ do + dterm_bit b w + state <- get + let bits = s_classical_state state + putCS (Map.delete w bits) +simulated_lift_transformer (T_CGate name ncf f) = f $ + \ws -> do + (v,ws) <- lift $ without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) + state <- get + let bits = s_classical_state state + let list = map (\w -> bits Map.! w) ws + let result = gateC name list + putCS (Map.insert v result bits) + return (v,ws) +simulated_lift_transformer g@(T_CGateInv name ncf f) = f $ + \v ws -> do + ws <- lift $ without_controls_if ncf $ do + cgateinv name v ws + return ws + state <- get + let bits = s_classical_state state + let list = map (\w -> bits Map.! w) ws + let result = bits Map.! v + let result' = gateC name list + if result == result' then return ws else error "CGateInv: Uncomputation error" +-- Translation of quantum gates: +simulated_lift_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] c -> do + (q,c) <- lift $ without_controls_if ncf $ do + q' <- qnot q `controlled` c + return (q', c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q], [], c) +simulated_lift_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] c -> do + (qs,c) <- lift $ without_controls_if ncf $ do + qs' <- qmultinot_list (map (\x -> (x,True)) qs) `controlled` c + return (qs', c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = foldr (\q a -> apply (s_if_controls bits c (performGateQ gate q)) a) amps qs + putQS amps' + return (qs, [], c) +simulated_lift_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] c -> do + (q,c) <- lift $ without_controls_if ncf $ do + q' <- hadamard q `controlled` c + return (q', c) + let gate = gateQ "hadamard" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q], [], c) +simulated_lift_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w, v] [] c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- swap_qubit w v `controlled` c + return (w',v',c) + let gate = gateQ "x" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gate v)) amps + let amps'' = apply (s_if_controls bits ((Signed (Endpoint_Qubit v) True):c) (performGateQ gate w)) amps' + let amps''' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gate v)) amps'' + putQS amps''' + return ([w, v], [], c) +simulated_lift_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w, v] [] c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- gate_W w v `controlled` c + return (w',v',c) + let gateX = gateQ "x" + let gateH = gateQ "hadamard" + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gateX v)) amps + let amps'' = apply (s_if_controls bits ((Signed (Endpoint_Qubit v) True):c) (performGateQ gateH w)) amps' + let amps''' = apply (s_if_controls bits ((Signed (Endpoint_Qubit w) True):c) (performGateQ gateX v)) amps'' + putQS amps''' + return ([w, v], [], c) +simulated_lift_transformer (T_QGate "trace" _ _ inv ncf f) = f $ + \ws vs c -> lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist "trace" inv ws vs `controlled` c + return (ws', vs', c) +simulated_lift_transformer (T_QGate name _ _ inv ncf f) = f $ + \[q] [] c -> do + ([q],[],c) <- lift $ without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv [q] [] `controlled` c + return (ws', vs', c) + let gate = gateQinv name inv + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q],[],c) +simulated_lift_transformer (T_QRot name _ _ inv theta ncf f) = f $ + \[q] [] c -> do + ([q],[],c) <- lift $ without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv theta [q] [] `controlled` c + return (ws', vs', c) + let gate = rotQinv name inv theta + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (performGateQ gate q)) amps + putQS amps' + return ([q],[],c) +simulated_lift_transformer (T_GPhase t ncf f) = f $ + \w c -> do + c <-lift $ without_controls_if ncf $ do + global_phase_anchored_list t w `controlled` c + return c + state <- get + let gate = rotQ "exp(% pi i)" t + let wire = -1 + let q = qubit_of_wire wire + let amps = s_quantum_state state + let bits = s_classical_state state + let amps' = apply (s_if_controls bits c (vector (Map.insert q False))) amps + let amps'' = apply (s_if_controls bits c (performGateQ gate q)) amps' + let (p,_,ampsf) = split amps'' q + case p of + 0.0 -> do + let ampsf' = apply (vector (Map.delete q)) ampsf' + putQS ampsf' + return c + _ -> error "GPhase" +simulated_lift_transformer (T_QInit val ncf f) = f $ + do + q <- lift $ without_controls_if ncf $ do + w <- qinit_qubit val + return w + state <- get + let amps = s_quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + putQS amps' + return q +simulated_lift_transformer (T_QMeas f) = f $ + \q -> do + b <- lift $ do + b <- measure_qubit q + return b + state <- get + let amps = s_quantum_state state + let bits = s_classical_state state + let (p,ift,iff) = split amps q + pp <- randomRSimulatedCirc (0,1.0) + let (val,amps') = if p > pp then (True,ift) else (False,iff) + let amps'' = apply (vector (Map.delete q)) amps' + let bits' = Map.insert b val bits + putQS amps'' + putCS bits' + return b +simulated_lift_transformer (T_QDiscard f) = f $ + \q -> do + lift $ do + qdiscard_qubit q + return () + -- a discard is essentially a measurement, with the result thrown away, so we + -- do that here, as it will reduce the size of the quantum state we are + -- simulating over. + state <- get + let (p,ift,iff) = split (s_quantum_state state) q + pp <- randomRSimulatedCirc (0,1.0) + let amps = if p > pp then ift else iff + let amps' = apply (vector (Map.delete q)) amps + putQS amps' + return () +simulated_lift_transformer (T_QTerm b ncf f) = f $ + \q -> do + lift $ without_controls_if ncf $ qterm_qubit b q + -- with a real quantum computer, when we terminate a qubit with an assertion + -- we have no way of actually checking the assertion. The best we can do is + -- measure the qubit and then throw an error if the assertion is incorrect, + -- which may only occur with a small probability. Here, we are able to split + -- the quantum state and see if the qubit exists in the incorrect state with + -- any non-zero probability, and throw an error. + state <- get + let amps = s_quantum_state state + let (p,ampst,ampsf) = split amps q + case (b,p) of + (True,1.0) -> do + let ampst' = apply (vector (Map.delete q)) ampst + putQS ampst' + return () + (False,0.0) -> do + let ampsf' = apply (vector (Map.delete q)) ampsf + putQS ampsf' + return () + (True,pt) -> error ("QTerm: Assertion Incorrect (True only has probability " ++ show pt ++ ")") + (False,pt) -> error ("QTerm: Assertion Incorrect (False only has probability " ++ show (1.0 - pt) ++ ")") +simulated_lift_transformer (T_Comment name inv f) = f $ + \ws -> do + lift $ do + comment_label name inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] + return () +simulated_lift_transformer g@(T_CSwap ncf f) = f $ + \w v c -> do + (w,v,c) <- lift $ without_controls_if ncf $ do + (w',v') <- swap_bit w v `controlled` c + return (w',v',c) + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_QPrep ncf f) = f $ + \w -> do + w <- lift $ without_controls_if ncf $ do + v <- prepare_qubit w + return v + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_QUnprep ncf f) = f $ + \w -> do + w <- lift $ without_controls_if ncf $ do + v <- unprepare_qubit w + return v + error ("simulated_lift_transformer: unimplemented gate: " ++ show g) +simulated_lift_transformer g@(T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \ns ws c -> do + (ws,c) <- lift $ without_controls_if ncf $ do + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,c) + case Map.lookup n ns of + Just (TypedSubroutine sub_ocirc _ _ _) -> do + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + let in_bindings = bind_list in_wires ws bindings_empty + let sub_bcirc = (sub_circ,ns) + out_bind <- transform_bcircuit_rec simulated_lift_transformer sub_bcirc in_bindings + return (unbind_list out_bind out_wires, c) + Nothing -> error $ "simulated_lift_transformer: subroutine " ++ show n ++ " not found (in " ++ showNames ns ++ ")" + +-- | Dynamic lifting can make use of a simulated result. +simulated_dynamic_lift :: Bit -> SimulatedCirc Bool +simulated_dynamic_lift b = do + state <- get + let bits = s_classical_state state + case Map.lookup b bits of + Just val -> return val + Nothing -> error $ "simulated_dynamic_lift: bit " ++ show b ++ " not found" + +-- | A dynamic transformer which simulates the circuit, whilst +-- reconstructing it with simulated lifting results. +-- Note: do not handle classical controlling. +simulated_dynamic_lift_transformer :: DynamicTransformer (StateT SimulationState Circ) Qubit Bit +simulated_dynamic_lift_transformer = DT { + transformer = simulated_lift_transformer, + define_subroutine = \name subroutine -> do + lift $ do + s <- get_namespace + let s' = map_provide name subroutine s + set_namespace s' + put_subroutine_definition name subroutine, + lifting_function = simulated_dynamic_lift + } + +-- | Print a RandomCirc by evaluating it with a seed in the IO monad. +print_simulated :: Format -> SimulatedCirc b -> IO () +print_simulated format scirc = do + seed <- randomIO + let circ = evalSimulatedCirc seed scirc + print_unary format (\() -> circ) () + +-- | Print a circuit, using simulated liftings. +print_unary_with_simulated_liftings :: (QCData a,QCData b) => Format -> (a -> Circ b) -> BType a -> IO () +print_unary_with_simulated_liftings format circ input = print_simulated format (lifted_circ ()) + where + circ' = \ () -> do + a <- qc_init input + circ a + lifted_circ = transform_unary_dynamic_shape simulated_dynamic_lift_transformer circ' () + + +-- | Pass a (possibly) dynamic circuit through the +-- 'simulated_dynamic_lift_transformer' and evaluate the liftings so as to +-- leave us with a static circuit that represents a single run of the original +-- circuit, with the given inputs. We also need to pass in a seed for the RNG. +simulate_liftings_unary :: (QCData a, QCData b) => Int -> (a -> Circ b) -> BType a -> Circ b +simulate_liftings_unary seed fcirc_in input = out_circ + where + circ_in = \() -> do + a <- qc_init input + fcirc_in a + s_circ = transform_unary_dynamic_shape simulated_dynamic_lift_transformer circ_in () + out_circ = evalSimulatedCirc seed (s_circ ()) + diff --git a/dist/build/Quipper/Libraries/FPReal.hs b/dist/build/Quipper/Libraries/FPReal.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/FPReal.hs @@ -0,0 +1,722 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/FPReal.hs" #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This library provides a quantum implementation of fixed-precision real numbers (i.e., with precision determined at circuit-generation time), and classical counterpart types. +-- +-- Currently still significantly experimental. TODO: +-- +-- * decide on how much access to provide to underlying representation of 'FPReal'. Full 'fpreal_case', or more like just what’s available through Haskell’s 'RealFloat'? +-- +-- * decide how to use 'ErrMsg': in internal functions only, or exported ones too? +-- +-- * many specific TODO’s in code throughout this file. +-- +-- * write export list. + +module Quipper.Libraries.FPReal where + +import Quipper +import Quipper.Internal + +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary + +import Control.Monad (foldM) +import Data.Maybe (fromJust) +import Data.Ratio (numerator, denominator) +import Data.Typeable + +-- =========================================== +-- * Fixed-precision real arithmetic: the FPReal family + +-- | 'FPRealX': a family of datatypes for fixed-precision real numbers. +-- (That is, the precision is a parameter, fixed at circuit-generation time.) +-- +-- 'FPRealX' is based on the family 'XInt' of fixed-length integer types: +-- @'FPRealX' /n/ /a/@ represents 2[sup /n/] /a/, where /a/ is some fixed-length integer. +-- +-- Alternately, in the specific case /x/ = 'Bool', a Haskell 'Double' may be +-- used as an 'FPReal', considered as having indeterminate length and exponent. +-- This is exactly analogous to the case of indeterminate length in 'XInt' / 'IntM'; for a more +-- detailed explanation, see the documentation there. +data FPRealX x = FPRealX Int (XInt x) | FPReal_indet Double (Identity IntM (XInt x)) + deriving (Show, Typeable) + +-- | Fixed-precision real parameters. As with 'IntM', the length and/or exponent +-- of an 'FPReal' may be indeterminate; such an 'FPReal' may only be used in +-- certain contexts, typically either when the length/exponent can be inferred from context +-- (e.g., terminating a 'FPRealQ'), or where the result can again be indeterminate. +-- +-- As with indeterminate 'IntM's, indeterminate 'FPReal's may be used for efficient, +-- high-precision classical calculation, and then explicitly or implicitly coerced +-- to determinate 'FPReal's when required for interfacing with quantum computation. +type FPReal = FPRealX Bool + +instance Show FPReal where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet r id) = show r + +-- | Fixed-precision reals for quantum circuits. +type FPRealQ = FPRealX Qubit + +instance Show FPRealQ where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet _ _) = error "FPRealX: internal error" + +-- | Fixed-precision reals for classical circuits. +type FPRealC = FPRealX Bit + +{- -- for when Qubit /= Bit: +instance Show FPRealC where + show (FPRealX n x) = "fprealx " ++ show n ++ " (" ++ show x ++ ")" + show (FPReal_indet _ _) = error "FPRealX: internal error" +-} + +-- ---------------------------------------------------------------------- +-- ** Primitive combinators on FPReal + +-- $ Like 'XInt', the type 'FPReal' is intended to be an abstract data type, +-- and all access to it should pass through the functions of this +-- section. + +-- *** Constructors + +-- | Create an 'FPRealX' from an 'XInt' together with an exponent. +fprealx :: Int -> XInt x -> FPRealX x +fprealx n x = FPRealX n x + +-- | Create an indeterminate 'FPReal' from a 'Double'. +fpreal_of_double :: Double -> FPReal +fpreal_of_double r = FPReal_indet r reflexivity + +-- *** Destructor + +-- | If the 'FPRealX' is of determinate exponent, return its exponent and mantissa. +-- +-- If the 'FPRealX' is indeterminate, return a pair (/r/, /id/), where /r/ is the underlying 'Double', and /id/ is a witness of the fact that /x/ = 'Bool'. +-- +-- This is a lowest-level access function not intended to be used by +-- user-level code, and is not exported. +fprealx_case :: FPRealX x -> Either (Int, XInt x) (Double, Identity IntM (XInt x)) +fprealx_case (FPRealX n x) = Left (n,x) +fprealx_case (FPReal_indet r id) = Right (r, id) + +-- ---------------------------------------------------------------------- +-- ** Other low-level operations + +-- $ The operations in this section are the only ones intended to use +-- 'fprealx_case' directly. + +-- TODO: fprealx_expt, fprealx_num should probably take ErrMsg arguments, at least for internal use --- I guess only the versions specialized to FPRealQ, FPRealC should be written as though unconditional? Perhaps only these, plus the 'Maybe' version specialized to 'FPReal', should be exported? + +-- | Extract the exponent of an 'FPRealX', assumed to be determinate. +-- +-- When /x/ is not 'Bool', this and 'fprealx_num' should be considered the destructors of 'FPRealX x'. +fprealx_expt :: FPRealX x -> Int +fprealx_expt x = + case fprealx_case x of + Left (n, _) -> n + Right _ -> error "fprealx_expt: indeterminate exponent" + +-- | Extract the mantissa of an 'FPRealX', assumed to be of determinate exponent. +-- +-- When /x/ is not 'Bool', this and 'fprealx_num' should be considered the destructors of 'FPRealX x'. +fprealx_num :: FPRealX x -> XInt x +fprealx_num x = + case fprealx_case x of + Left (_, xi) -> xi + Right _ -> error "fprealx_num: indeterminate exponent" + +-- | Extract the length (in bits) of an 'FPRealX', assumed to be of determinate exponent and length. +fprealx_length :: FPRealX x -> Int +fprealx_length x = + case fprealx_case x of + Left (_, xi) -> fromJust $ xint_maybe_length xi + Right _ -> error "fprealx_length: indeterminate exponent" + +-- | Set the exponent of an 'FPReal' to /n/. This operation is only +-- legal if the input (a) has indeterminate exponent or (b) has +-- determinate exponent already equal to /m/. In particular, it cannot +-- be used to change the exponent from anything other than from +-- indeterminate to determinate. +-- +-- If both arguments already have determinate exponents, and they do not +-- coincide, throw an error. The 'String' argument is used as an error +-- message in that case. + +-- Implementation note: the “intm_of_integer” may seem unnecessary, +-- but needed so that when /r/ is “undefined”, the result is +-- “intm_of_integer undefined” not just “undefined”. +fprealx_set_expt :: Int -> FPRealX x -> String -> FPRealX x +fprealx_set_expt n xr errstr = case fprealx_case xr of + Left (n', xi) -> if n' == n then fprealx n xi else error errstr + Right (r, id) -> fprealx n (identity id $ intm_of_integer $ round $ + if n >= 0 then (r / 2^n) else (r * 2^(-n))) + +-- | Return the (possibly indeterminate) exponent of an 'FPRealX'. +fprealx_maybe_expt :: FPRealX x -> Maybe (Int) +fprealx_maybe_expt xr = case fprealx_case xr of + Left (n, _) -> Just n + Right _ -> Nothing + +-- | Given an 'FPReal', return either the exponent and numerator, or else the double it wraps. +-- +-- A specialized and implementation-hiding wrapper for 'fprealx_case'. + +-- TODO: should this be exported? +fpreal_case :: FPReal -> Either (Int, IntM) (Double) +fpreal_case (FPRealX n x) = Left (n, x) +fpreal_case (FPReal_indet r _) = Right r + +-- | Equality test. If both have indeterminate exponent, check equality of underlying 'Double's. +-- Otherwise, if exponents are compatible (i.e. both determinate and equal, or one indeterminate), +-- check equality of numerators. If exponents are incompatible, throw an error (the test +-- should in this case be considered ill-typed). +fprealx_equals :: (Eq x) => FPRealX x -> FPRealX x -> Bool +fprealx_equals x y = + case (fprealx_case x, fprealx_case y) of + (Left (n,xi), Left (n',yi)) + | n == n' -> xi == yi + | otherwise -> error "Equality test on FPRealx: operands must be of equal exponent" + (_, Left (m,yi)) -> fprealx_equals (fprealx_set_expt m x "fprealx_equals") y + (Left (n,xi), _) -> fprealx_equals x (fprealx_set_expt n y "fprealx_equals") + (Right (r, _), Right (r', _)) -> r == r' + +-- ---------------------------------------------------------------------- +-- ** Shape parameters + +-- | Return a piece of shape data to represent an /l/-qubit quantum +-- real with exponent /n/. +-- Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +fprealq_shape :: Int -> Int -> FPRealQ +fprealq_shape n l = fprealx n $ qdint_shape l + +-- | Return a piece of shape data to represent an /l/-bit 'FPRealC', +-- with exponent /n/. +-- Please note that the data can only be used as shape; it will be +-- undefined at the leaves. +fprealc_shape :: Int -> Int -> FPRealC +fprealc_shape n l = fprealx n $ cint_shape l + +-- ====================================================================== +-- ** Circuit type class instances + +-- Note: instance declarations do not show up in the documentation + +-- | Try to set the exponent/length of an 'FPReal' to that of another 'FPRealX' +-- value (e.g. an 'FPRealQ', an 'FPRealC', or another 'FPReal'). +-- This will fail with an error if both numbers already have determinate +-- lengths that don't coincide. In this case, the string argument is +-- used as an error message. +-- +-- The possible “shapes” of 'FPReal's may be seen as a partial order, where +-- /s1/ ≤ /s2/ means that values of shape /s1/ are coercible to values of shape +-- /s2/. 'fpreal_promote' may be seen as taking the binary /sup/ in this poset. +fpreal_promote :: FPReal -> FPRealX x -> ErrMsg -> FPReal +fpreal_promote br xr errmsg = + case fprealx_maybe_expt xr of + Nothing -> br + Just n -> + let br' = fprealx_set_expt n br (errmsg "FPReal: exponent mismatch") + in fprealx n $ intm_promote (fprealx_num br') (fprealx_num xr) (errmsg "FPReal: length mismatch") + +type instance QCType x y (FPRealX z) = FPRealX (QCType x y z) +type instance QTypeB FPReal = FPRealQ + +instance QCLeaf x => QCData (FPRealX x) where + qcdata_mapM shape f g xr + = mmap (fprealx (fprealx_expt xr)) $ qcdata_mapM (fprealx_num shape) f g (fprealx_num xr) + qcdata_zip shape q c q' c' xr yr e + | fprealx_expt xr == fprealx_expt yr + = fprealx (fprealx_expt xr) + $ qcdata_zip (fprealx_num shape) q c q' c' (fprealx_num xr) (fprealx_num yr) (const $ e "FPRealX: length mismatch") + | otherwise + = error (e "FPRealX: exponent mismatch") + qcdata_promote = fpreal_promote + +-- Labeling of FPRealX is s[hi-1], ..., s[lo], where lo is the exponent. +instance QCLeaf x => Labelable (FPRealX x) String where + label_rec xr s = do + let n = fprealx_expt xr + xi = fprealx_num xr + qx = list_of_xint_lh xi + sequence_ [ label_rec q s `indexed` show i | (q,i) <- zip qx [n..] ] + +-- ====================================================================== +-- * Classical arithmetic on FPReal + +-- | Convert an 'FPReal' to a 'Double'. +double_of_fpreal :: FPReal -> Double +double_of_fpreal xr = case fpreal_case xr of + Left (n, xi) -> if n >= 0 then (fromIntegral xi) * (2^n) + else (fromIntegral xi) / (2^(abs n)) + Right r -> r + +-- | From a list of 'FPReal's, extract a common shape, provided they have compatible shape +-- (i.e. if any have determinate exponent, they must agree; similarly for length), +-- and throw an error otherwise. +-- +-- Can be seen as producing finitary suprema in the partial order of shapes. +-- +-- The 'FPReal' produced should be considered just a shape; its value is a dummy that +-- should never be used (and will throw an error if it is). +fpreal_common_shape :: [FPReal] -> ErrMsg -> FPReal +fpreal_common_shape xs e = foldl (\x y -> fpreal_promote x y e) + (fpreal_of_double (error $ e "fpreal_common_shape: dummy value produced here was later accessed")) + xs + +-- | Auxiliary function for lifting a binary operator from 'Double' +-- to 'IntM'. The string argument is the name of the operator, for +-- error messages. +fpreal_binop :: (Double -> Double -> Double) -> String -> (FPReal -> FPReal -> FPReal) +fpreal_binop op opname x y = + fpreal_promote + (fpreal_of_double $ op (double_of_fpreal x) (double_of_fpreal y)) + (fpreal_common_shape [x,y] errmsg) + (const "FPReal: internal error (fpreal_binop)") + where errmsg = (\s -> "Binary operation " ++ opname ++ " on FPReal: " ++ s) + +-- | Auxiliary function for lifting a unary operator from 'Double' to +-- 'FPReal'. +fpreal_unop :: (Double -> Double) -> FPReal -> FPReal +fpreal_unop op x = fpreal_promote (fpreal_of_double $ op $ double_of_fpreal x) x + (const "FPReal: internal error (fpreal_unop)") + +------ +-- Classical typeclass instances +------ + +instance Eq x => Eq (FPRealX x) where + (==) = fprealx_equals + +instance Num FPReal where + (+) = fpreal_binop (+) "+" + (*) = fpreal_binop (*) "*" + (-) = fpreal_binop (-) "-" + abs = fpreal_unop abs + signum = fpreal_unop signum + -- Note: signum on determinate exponent/length FPReals has slightly + -- surprising behavior if /n/ ≤ –/l/: this will give + -- 0, since then 1 = –1 = 0 mod 2^{l + n}. In other words, the + -- output 1.0 or -1.0 is not representable in this fixed-precision format. + fromInteger = fpreal_of_double . fromInteger + +instance Ord FPReal where + compare x y = compare (double_of_fpreal x) (double_of_fpreal y) +-- TODO: is this the right thing to do? Perhaps we should first check they have +-- compatible shapes, and throw an error otherwise. + +instance Enum FPReal where + succ = fpreal_unop succ + pred = fpreal_unop pred + toEnum = fromIntegral + fromEnum = fromEnum . double_of_fpreal + +instance Real FPReal where + toRational = toRational . double_of_fpreal + +instance Fractional FPReal where + fromRational = fpreal_of_double . fromRational + recip = fpreal_unop recip + +{- TODO: something along these lines would probably still be good to give. Work on thinking of good interface. Or maybe not really necessary?? + +-- | Convert from any 'RealFrac' type (eg 'Rational', 'Float') to 'FPReal', with specified precision and (possibly indeterminate) length. +fpreal_from_realfrac_with_precision :: (RealFrac a) => Int -> Maybe Int -> a -> FPReal +fpreal_from_realfrac_with_precision n l r = case l of + Just l -> FPRealX n $ intm l (round $ r * (2^n)) + Nothing -> FPRealX n $ fromIntegral (round $ r * (2^n)) +-} + +instance Floating FPReal where + pi = fpreal_of_double pi + log = fpreal_unop log + exp = fpreal_unop exp + sin = fpreal_unop sin + cos = fpreal_unop cos + sinh = fpreal_unop sinh + cosh = fpreal_unop cosh + asin = fpreal_unop asin + acos = fpreal_unop acos + atan = fpreal_unop atan + asinh = fpreal_unop asinh + acosh = fpreal_unop acosh + atanh = fpreal_unop atanh + +instance RealFrac FPReal where + properFraction x = + let (x_int, x_frac_double) = properFraction $ double_of_fpreal x in + (x_int, fpreal_promote (fpreal_of_double x_frac_double) x (const "FPReal: internal error (properFraction)")) + ceiling = ceiling . double_of_fpreal + +{- TODO: would definitely be good to give. +instance RealFloat FPReal +-} + +-- ** Shape/precision control + +-- | Extend the length of a determinate length and precision 'FPReal' by /m/ high and /n/ low bits, without changing its value. +fpreal_pad :: Int -> Int -> FPReal -> FPReal +fpreal_pad m n x = + case fprealx_maybe_expt x of + Nothing -> error e_expt + Just x_expt -> + let x_num = fprealx_num x + in case intm_length x_num of + Nothing -> error e_length + Just x_length -> + fprealx (x_expt - n) (2^n * intm_extend_signed (x_length + m + n) x_num) + where + e_expt = "fpreal_pad: input of indeterminate exponent" + e_length = "fpreal_pad: input of indeterminate length" + +-- | Discard the top /m/ and bottom /n/ bits of a determinate length and precision 'FPReal'. +fpreal_unpad :: Int -> Int -> FPReal -> FPReal +fpreal_unpad m n x = + let x_bits = boollist_of_intm_bh $ fprealx_num x + x_expt = fprealx_expt x + x_bits_new = reverse $ drop n $ reverse $ drop m x_bits + in fprealx (x_expt + n) (intm_of_boollist_bh x_bits_new) + +-- | Fix the length of an 'IntM' (to automatically-generated values), if not already determinate. +-- +-- TODO: belongs in 'Quipper.Libraries.Arith' +intm_fix_length_auto :: IntM -> IntM +intm_fix_length_auto x = case intm_length x of + Just _ -> x + Nothing -> + let l = (1 +) $ ceiling $ logBase 2 $ fromIntegral $ abs x + (if x >= 0 then 1 else 0) + in intm l (fromIntegral x) + +-- | Fix the precision and length of an 'FPReal' (to automatically-generated values), +-- leaving unchanged any parts of the shape that are already set. +-- +-- TODO: discuss \/ reconsider \/ improve implementation of this. + +-- Implementation note: aim to use as few bits as possible, while retaining accuracy. +-- +-- Not clear what should be done in case denominator not a power of 2. However, +-- Haskell’s 'Double' has radix 2, so ordinarily denominator always should be a power of 2. +-- +-- However, this does give pretty high-precision by default! Is that good? Seems expensive in qubits. +fpreal_fix_shape_auto :: FPReal -> FPReal +fpreal_fix_shape_auto x = case fpreal_case x of + Left (e, n) -> fprealx e (intm_fix_length_auto n) + Right x -> + let r = toRational x + d = denominator r + in if d == 2^(round $ logBase 2 $ fromIntegral d) + then fprealx + (negate $ round $ logBase 2 $ fromIntegral d) + (intm_fix_length_auto $ fromIntegral $ numerator r) + else error "fpreal_fix_shape_auto: not yet fully implemented" + +-- ====================================================================== +-- * Quantum operations: FPRealQ + +-- ** Shape/precision control + +-- | Extend the length of an 'FPRealQ' by /m/ high bits and /n/ low bits, without changing its value. +fprealq_pad :: Int -> Int -> FPRealQ -> Circ FPRealQ +fprealq_pad m n x = do + let x_bits = qulist_of_qdint_bh $ fprealx_num x + x_expt = fprealx_expt x + new_high_bits <- qinit $ replicate m False + new_high_bits <- case x_bits of + [] -> return new_high_bits + (x_high:_) -> mapUnary qnot new_high_bits `controlled` x_high + new_low_bits <- qinit $ replicate n False + return $ fprealx (x_expt - n) $ qdint_of_qulist_bh $ new_high_bits ++ x_bits ++ new_low_bits + +-- | Cut off the top /m/ and bottom /n/ bits of an 'FPRealQ', retaining them as explicit garbage. +fprealq_unpad :: Int -> Int -> FPRealQ -> Circ (FPRealQ, [Qubit]) +fprealq_unpad m n x = + let x_bits = qulist_of_qdint_bh $ fprealx_num x + x_expt = fprealx_expt x + x_bits_new = reverse $ drop n $ reverse $ drop m x_bits + garbage = (take m x_bits) ++ (take n $ reverse x_bits) + in return (fprealx (x_expt + n) (qdint_of_qulist_bh x_bits_new), garbage) + +-- | Formally shift an 'FPRealQ' up /n/ bits, i.e. add /n/ to its exponent. +fprealq_shift :: Int -> FPRealQ -> FPRealQ +fprealq_shift n x = + let num = fprealx_num x + expt = fprealx_expt x + in fprealx (expt + n) num + +-- ** Quantum arithmetic + +-- $ Besides the functions appearing here in the documentation, basic operations ('q_add', etc) are also provided as methods of the 'QNum' type class instance; see 'QNum' for documentation of these functions. + +------ +-- Quantum typeclass instances +------ + +instance QNum FPRealQ where + q_add x y = + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + (nx,ny,ns) <- q_add nx ny + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex ns)) + else error "q_add // FPReal: exponent mismatch in arguments." + q_mult x y = -- TODO: to implement + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + np <- qinit $ qc_false $ nx + (nx,ny,np) <- named_gate "q_mult // FPReal" (nx,ny,np) + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex np)) + else error "q_mult // FPReal: length mismatch in arguments." + q_sub x y = + let ex = fprealx_expt x + ey = fprealx_expt y + in if ex == ey then do + let nx = fprealx_num x + ny = fprealx_num y + (nx,ny,nd) <- q_sub nx ny + return ((fprealx ex nx), (fprealx ey ny), (fprealx ex nd)) + else error "q_sub // FPReal: length mismatch in arguments." + q_abs x = + let ex = fprealx_expt x + nx = fprealx_num x + in do + (nx,nx') <- q_abs nx + return ((fprealx ex nx), (fprealx ex nx')) + q_negate x = + let ex = fprealx_expt x + nx = fprealx_num x + in do + (nx,nx') <- q_negate nx + return ((fprealx ex nx), (fprealx ex nx')) + q_signum = error "FPReal // q_signum: not yet implemented." -- TODO! + q_fromQDInt x = do + (x,x') <- qc_copy_fun x + return (x,(fprealx 0 x')) + +instance QOrd FPRealQ where + q_less x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + x_less_y <- q_less nx ny + return x_less_y + else error "q_less // FPReal: length mismatch in arguments." + q_leq x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + x_leq_y <- q_leq nx ny + return x_leq_y + else error "q_leq // FPReal: length mismatch in arguments." + +-- | Analogue of 'q_add_in_place', for 'FPRealQ'. +fprealq_add_in_place :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_add_in_place x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + (x,y) <- q_add_in_place nx ny + return ((fprealx ex nx), (fprealx ey ny)) + else error "q_add_in_place_fprealq // FPReal: length mismatch in arguments." + +-- | Analogue of 'q_sub_in_place', for 'FPRealQ'. +fprealq_sub_in_place :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_sub_in_place x y = + let ex = fprealx_expt x + ey = fprealx_expt y + nx = fprealx_num x + ny = fprealx_num y + in if ex == ey then do + (x,y) <- q_sub_in_place nx ny + return ((fprealx ex nx), (fprealx ey ny)) + else error "q_sub_in_place_fprealq // FPReal: length mismatch in arguments." + +-- | Subtract a parameter 'FPReal' from an 'FPRealQ', in place. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_sub_param_in_place :: FPReal -> FPRealQ -> Circ FPRealQ +fprealq_sub_param_in_place x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy) <- fprealq_sub_in_place qx qy + return qy) + where + e_prec = "fprealq_sub_param_in_place: incompatible precision" + +-- | Add a parameter 'FPReal' to an 'FPRealQ', in place. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_add_param_in_place :: FPReal -> FPRealQ -> Circ FPRealQ +fprealq_add_param_in_place x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy) <- fprealq_add_in_place qx qy + return qy) + where + e_prec = "fprealq_sub_param_in_place: incompatible precision" + +-- | Multiply an 'FPRealQ' by a parameter 'FPReal'. The parameter may have any shape. +fprealq_mult_param_het :: FPReal -> FPRealQ -> Circ (FPRealQ, FPRealQ) +fprealq_mult_param_het x_in qy = do + let x = fpreal_fix_shape_auto x_in + e = fprealx_expt x + l = fromJust $ intm_length $ fprealx_num x + x_bits = boollist_of_intm_bh $ fprealx_num x + qy_expt = fprealx_expt qy + qy_num = fprealx_num qy + qy_length = qdint_length qy_num + prod_bits = [ (is_neg, i) | (x_i, i) <- zip x_bits [e+l-1,e+l-2..e] + , x_i == True + , let is_neg = i == e+l-1 ] + qprod <- if null prod_bits + then qinit $ fpreal_promote 0 qy ("internal error: fprealq_mult_param_het promotion: " ++) + else with_computed (do + let i_max = snd $ head prod_bits + i_min = snd $ last prod_bits + -- Initialise an accumulating product at 0, with as many bits as may be needed in intermediate calculation: + qprod_accum <- qinit $ fprealx (qy_expt + i_min) $ intm (1 + qy_length + i_max - i_min) 0 + -- Add the appropriate shifts of qy to it: + qprod_accum <- foldM + (\qprod_accum (is_neg, i) -> do + qy_i <- qc_copy $ fprealq_shift i qy + qy_i <- fprealq_pad (1 + i_max - i) (i - i_min) qy_i + (qy_i, qprod_accum) <- if is_neg + then fprealq_sub_in_place qy_i qprod_accum + else fprealq_add_in_place qy_i qprod_accum + return qprod_accum) + qprod_accum + prod_bits + -- Now shift/truncate the product to match the input length/precision: + qprod_large <- fprealq_pad (max (-i_max) 0) (max i_min 0) qprod_accum + (qprod, garbage) <- fprealq_unpad (1 + max i_max 0) (max (-i_min) 0) qprod_large + return qprod) + -- Copy it for output, before erasing garbage: + qc_copy + return (qy, qprod) + +-- | Compare an 'FPRealQ' to a parameter 'FPReal'. Assume compatible precision. +-- +-- Note: highly sub-optimal. TODO: optimize! +fprealq_ge_param :: FPReal -> FPRealQ -> Circ (FPRealQ, Qubit) +fprealq_ge_param x qy = + with_ancilla_init (fpreal_promote x qy $ const e_prec) (\qx -> do + (qx, qy, test) <- q_ge qx qy + return (qy, test)) + where + e_prec = "fprealq_ge_param: incompatible precision" + +-- | 'fprealq_add_het' /p/ /l/ /qx/ /qy/: add two 'FPRealQ's, of potentially different precisions and lengths, into a fresh one with precision /p/ and length /l/. +-- +-- TODO: not yet implemented; currently just black box. +fprealq_add_het :: Int -> Int -> FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ,FPRealQ) +fprealq_add_het p l qx qy = do + qz <- qinit (fprealx p (intm l 0)) + (qx,qy,qz) <- named_gate "fprealq_add_het" (qx,qy,qz) + return (qx,qy,qz) + +-- | @'fprealq_logBase_internal' /errmsg/ /b/ /h/ /p/ /qx/'@: compute log[sub /b/](/qx/), returning /l/ binary digits before the point and /p/ after. The underlying implementation of the rest of the 'fprealq_log' family. +-- +-- Behavior on non-positive /qx/: currently unspecified. TODO: decide and fix this. Make assertion/post-selection on positivity? Or treat as unsigned? +-- +-- Time-complexity (estimated): /O/((log /l/[sup /qx/] + log log /b/)(/l/[sup /qx/] + (/h/+/p/)[sup 2])). +fprealq_logBase_internal :: (Floating a, RealFrac a) => ErrMsg -> a -> Int -> Int -> FPRealQ -> Circ (FPRealQ, FPRealQ) +fprealq_logBase_internal e b h_out p_out x = + if h_out + p_out < 0 + then error $ e "negative length specified." + else if b <= 0 + then error $ e "base of logarithm must be > 0" + else do + y <- with_computed + (do + -- Shift x into the interval [0,1], and pad it for intermediate calculation: + let l_in = qdint_length $ fprealx_num x + e_in = fprealx_expt x + l_in_pad = 1 + l_in `div` 2 + p_in_pad = p_out - (floor $ logBase 2 $ log b) + 1 + x_0 <- fprealq_pad l_in_pad p_in_pad $ fprealx (1 - l_in) $ fprealx_num x + -- Bound the length and precision needed for computing log_2 x' to precision p_out: + let y_size_bound = 1 + (ceiling $ logBase 2 $ fromIntegral $ l_in - 1) + y_h_pad = max 0 (y_size_bound - h_out) + y_p_pad = 2 + (ceiling $ logBase 2 $ fromIntegral $ l_in_pad + p_in_pad - 1) + y_0 <- qinit $ fprealx (- p_out - y_p_pad) $ intm (y_h_pad + h_out + p_out + y_p_pad) 0 + -- Iteratively compute log x_0, starting with (x0,y0): + let ks_big = 2^(l_in `div` 2) + : (reverse $ [ 2^(2^i) | i <- [0..(ceiling $ logBase 2 $ (fromIntegral l_in) / 2) - 1] ]) + ks_small = [ (2^i + 1)/(2^i) | i <- [1..p_out - (floor $ logBase 2 $ log b) + 1]] + -- bound in ks_small chosen to ensure logBase b k_fin < 2^(-p_out) + (x_fin,y_fin) <- foldM + (\(xi,yi) ki -> do + (xi, xi_ki) <- fprealq_mult_param_het ki xi + (xi_ki, test1) <- fprealq_ge_param 1 xi_ki + (xi_ki, xi, test2) <- q_gt xi_ki xi + (xi1, yi1) <- qc_copy (xi,yi) + (xi1,xi) <- controlled_not xi1 xi `controlled` test1 .&&. test2 + (xi1,xi_ki) <- controlled_not xi1 xi_ki `controlled` test1 .&&. test2 + yi1 <- fprealq_sub_param_in_place (logBase (realToFrac b) ki) yi1 `controlled` test1 .&&. test2 + return (xi1, yi1)) + (x_0,y_0) + (ks_big ++ ks_small) + -- Correct for the shift between x and x_, then unpad y to the output precision: + y_fin <- fprealq_add_param_in_place ((log 2 / log (realToFrac b)) * (fromIntegral $ l_in + e_in - 1)) y_fin + (y_fin, garbage) <- fprealq_unpad y_h_pad y_p_pad y_fin + return y_fin) + qc_copy + return (x,y) + +-- | Compute the natural log of an 'FPRealQ', with length and precision as in the input. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_log :: FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_log x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_log: " ++ ) (exp 1) h l x + +-- | Compute the log (to arbitrary base) of an 'FPRealQ', with length and precision as in the input. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_logBase :: (Floating a, RealFrac a) => a -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_logBase b x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_logBase: " ++ ) b h l x + +-- | @'fprealq_log_with_shape' /x/ /y/@: compute the natural log /y/, with length and precision of /x/. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_log_with_shape :: FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_log_with_shape x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_log_with_shape: " ++ ) (exp 1) h l + +-- | @'fprealq_log_with_shape' /b/ /x/ /y/@: compute log[sup /b/] /y/, with length and precision of /x/. +-- +-- Note: the behavior on negative inputs is unspecified. +fprealq_logBase_with_shape :: (Floating a, RealFrac a) + => a -> FPRealQ -> FPRealQ -> Circ (FPRealQ,FPRealQ) +fprealq_logBase_with_shape b x = + let h = fprealx_length x + fprealx_expt x + l = - fprealx_expt x + in fprealq_logBase_internal ("fprealq_logBase_with_shape: " ++ ) b h l diff --git a/dist/build/Quipper/Libraries/GateDecompositions.hs b/dist/build/Quipper/Libraries/GateDecompositions.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/GateDecompositions.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/GateDecompositions.hs" #-} +-- | This library contains special decompositions of particular gates +-- into particular gate bases. It also contains functions for +-- decomposing multiple controls. +-- +-- For example, we provide particular decompositions of the Toffoli, +-- Fredkin, doubly-controlled /iX/-gate, and certain other controlled +-- Clifford gates, into the Clifford+/T/ base. In some cases, we +-- provide more than one decomposition. +-- +-- Many of these decompositions are taken or adapted from the +-- literature, for example, from: +-- +-- * M. A. Nielsen and I. L. Chuang, +-- /Quantum Computation and Quantum Information/, +-- Cambridge University Press, 2002. +-- +-- * M. Amy, D. Maslov, M. Mosca, and M. Roetteler, +-- A meet-in-the-middle algorithm for fast synthesis +-- of depth-optimal quantum circuits, +-- /IEEE Transactions on Computer-Aided Design of/ +-- /Integrated Circuits and Systems/ 32(6):818-830. +-- Also available from . +-- +-- * A. Barenco, C. H. Bennett, R. Cleve, D. P. DiVincenzo, +-- N. Margolus, P. Shor, T. Sleator, J. A. Smolin, and H. Weinfurter, +-- Elementary gates for quantum computation, +-- /Physical Review A/ 52(5):3457-3467, 1995. +-- Also available from . +-- +-- * P. Selinger, Quantum circuits of T-depth one, +-- /Physical Review A/ 87, 042302 (4 pages), 2013. +-- Also available from . +-- +-- * B. Giles and P. Selinger, Exact synthesis of multiqubit +-- Clifford+T circuits, /Physical Review A/ 87, 032332 (7 pages), +-- 2013. Also available from . + +module Quipper.Libraries.GateDecompositions where + +import Quipper + +import Control.Monad + +-- ---------------------------------------------------------------------- +-- * Decomposition of gates + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- from Nielsen and Chuang (Figure 4.9). The first argument is the +-- target, and the other two are the controls. The controls can be +-- positive or negative. +-- +-- \[image toffoli_NC.png] +toffoli_NC_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_NC_at q c1 c2 = do + comment_with_label "ENTER: toffoli_NC" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + hadamard_at q + qnot_at q `controlled` w1 + reverse_imp_if (not x) gate_T_inv_at q + qnot_at q `controlled` w2 + reverse_imp_if (x `xor` y) gate_T_at q + qnot_at q `controlled` w1 + reverse_imp_if (not y) gate_T_inv_at q + qnot_at q `controlled` w2 + gate_T_at q + reverse_imp_if (not x) gate_T_inv_at w1 + hadamard_at q + qnot_at w1 `controlled` w2 + reverse_imp_if (x `xor` y) gate_T_inv_at w1 + qnot_at w1 `controlled` w2 + reverse_imp_if (not x) gate_S_at w1 + reverse_imp_if (not y) gate_T_at w2 + comment_with_label "EXIT: toffoli_NC" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- from Amy et al. (, Figure +-- 13). The first argument is the target, and the other two are the +-- controls. The controls can be positive or negative. +-- +-- \[image toffoli_AMMR.png] +toffoli_AMMR_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_AMMR_at q c1 c2 = do + comment_with_label "ENTER: toffoli_AMMR" (q,c1,c2) ("q","c1","c2") + without_comments $ do + hadamard_at q + ccZ_AMMR_at q c1 c2 + hadamard_at q + comment_with_label "EXIT: toffoli_AMMR" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the Toffoli gate using controlled Clifford +-- operators, from Nielsen and Chuang (Figure 4.8). The controls can be +-- positive or negative. +-- +-- \[image toffoli_V.png] +toffoli_V_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_V_at q c1 c2 = do + comment_with_label "ENTER: toffoli_V" (q,c1,c2) ("q","c1","c2") + let q1 = from_signed c1 + let q2 = from_signed c2 + gate_V_at q `controlled` c1 + qnot_at q1 `controlled` c2 + gate_V_inv_at q `controlled` c1 + qnot_at q1 `controlled` c2 + gate_V_at q `controlled` c2 + comment_with_label "EXIT: toffoli_V" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the Toffoli gate into the Clifford+/T/ base, +-- using /T/-depth 1 and four ancillas. From +-- (Figure 1). The first argument is +-- the target, and the other two are the controls. The controls can be +-- positive or negative. +-- +-- \[image toffoli_S.png] +toffoli_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_S_at q c1 c2 = do + comment_with_label "ENTER: toffoli_S" (q,c1,c2) ("q","c1","c2") + without_comments $ do + hadamard_at q + ccZ_S_at q c1 c2 + hadamard_at q + comment_with_label "EXIT: toffoli_S" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-count 4 and /T/-depth 2. Adapted from +-- (, Figure 10). The first argument +-- is the target, and the other two are the controls. The controls can +-- be positive or negative. +-- +-- \[image cc_iX.png] +cc_iX_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_at q c1 c2 = do + comment_with_label "ENTER: cc_iX" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + hadamard_at q + qnot_at w1 `controlled` q + qnot_at w2 `controlled` w1 + reverse_imp_if (not x) gate_T_at w1 + reverse_imp_if (x `xor` y) gate_T_inv_at w2 + qnot_at w1 `controlled` q + qnot_at w2 `controlled` w1 + gate_T_inv_at q + reverse_imp_if (not y) gate_T_at w2 + qnot_at w2 `controlled` q + hadamard_at q + when (not x && not y) $ do -- need a phase correction + gate_omega_at w1 + gate_omega_at w2 + comment_with_label "EXIT: cc_iX" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-count 4, and using the control qubits +-- only as controls. Derived from Nielsen and Chuang (Figure 4.9). The +-- controls can be positive or negative. +-- +-- \[image cc_iX_simple.png] +cc_iX_simple_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_simple_at q c1 c2 = do + comment_with_label "ENTER: cc_iX_simple" (q,c1,c2) ("q","c1","c2") + hadamard_at q + qnot_at q `controlled` c1 + gate_T_at q + qnot_at q `controlled` c2 + gate_T_inv_at q + qnot_at q `controlled` c1 + gate_T_at q + qnot_at q `controlled` c2 + gate_T_inv_at q + hadamard_at q + comment_with_label "EXIT: cc_iX_simple" (q,c1,c2) ("q","c1","c2") + +-- | Decomposition of the doubly-controlled /iX/-gate into the +-- Clifford+/T/ base, using /T/-depth 1 and one ancilla. Adapted from +-- (, Figure 9). The first argument +-- is the target, and the other two are the controls. The controls can +-- be positive or negative. +-- +-- \[image cc_iX_S.png] +cc_iX_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_S_at q c1 c2 = do + comment_with_label "ENTER: cc_iX_S" (q,c1,c2) ("q","c1","c2") + let sx = get_sign c1 + sy = get_sign c2 + x = from_signed c1 + y = from_signed c2 + z = q + hadamard_at z + with_ancilla $ \w -> do + qnot y `controlled` z + qnot w `controlled` x + qnot x `controlled` z + qnot w `controlled` y + reverse_imp_if (not sx) gate_T_at x + reverse_imp_if (not sy) gate_T_at y + gate_T_inv_at z + reverse_imp_if (sx `xor` sy) gate_T_inv_at w + qnot w `controlled` y + qnot x `controlled` z + qnot w `controlled` x + qnot y `controlled` z + when (not sx && not sy) $ do -- need a phase correction + gate_omega_at x + gate_omega_at y + hadamard_at z + comment_with_label "EXIT: cc_iX_S" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /Z/-gate into the +-- Clifford+/T/ base. Adapted from Amy et +-- al. (, Figure 13). The controls can +-- be positive or negative. +-- +-- \[image ccZ_AMMR.png] +ccZ_AMMR_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +ccZ_AMMR_at q c1 c2 = do + comment_with_label "ENTER: ccZ_AMMR" (q,c1,c2) ("q","c1","c2") + let x = get_sign c1 + y = get_sign c2 + w1 = from_signed c1 + w2 = from_signed c2 + gate_T_at q + reverse_imp_if (not x) gate_T_at w1 + reverse_imp_if (not y) gate_T_at w2 + qnot_at w2 `controlled` w1 + qnot_at w1 `controlled` q + qnot_at q `controlled` w2 + reverse_imp_if (not x) gate_T_inv_at w1 + reverse_imp_if (x `xor` y) gate_T_at q + qnot_at w1 `controlled` w2 + reverse_imp_if (not y) gate_T_inv_at w1 + reverse_imp_if (x `xor` y) gate_T_inv_at w2 + qnot_at w1 `controlled` q + qnot_at q `controlled` w2 + qnot_at w2 `controlled` w1 + comment_with_label "EXIT: ccZ_AMMR" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the doubly-controlled /Z/-gate into the +-- Clifford+/T/ base, using /T/-depth 1 and four ancillas. From +-- Selinger (, Figure 1). The controls +-- can be positive or negative. +-- +-- \[image ccZ_S.png] +ccZ_S_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +ccZ_S_at q c1 c2 = do + comment_with_label "ENTER: ccZ_S" (q,c1,c2) ("q","c1","c2") + let sx = get_sign c1 + sy = get_sign c2 + x = from_signed c1 + y = from_signed c2 + z = q + with_ancilla_init (0,0,0,0) $ \(xyz, xy, yz, xz) -> do + qnot yz `controlled` y + qnot xyz `controlled` x + qnot xy `controlled` y + qnot yz `controlled` z + qnot xz `controlled` xyz + qnot xy `controlled` x + qnot xz `controlled` z + qnot xyz `controlled` yz + reverse_imp_if (not sx) gate_T_at x + reverse_imp_if (not sy) gate_T_at y + gate_T_at z + reverse_imp_if (sx `xor` sy) gate_T_at xyz + reverse_imp_if (sx `xor` sy) gate_T_inv_at xy + reverse_imp_if (not sy) gate_T_inv_at yz + reverse_imp_if (not sx) gate_T_inv_at xz + qnot xyz `controlled` yz + qnot xz `controlled` z + qnot xy `controlled` x + qnot xz `controlled` xyz + qnot yz `controlled` z + qnot xy `controlled` y + qnot xyz `controlled` x + qnot yz `controlled` y + comment_with_label "EXIT: ccZ_S" (q,c1,c2) ("q","c1","c2") + where + xor = (/=) + +-- | Decomposition of the Fredkin (controlled-Swap) gate into the +-- Clifford+/T/ base. The first two arguments are the targets, and the +-- last one the control. The controls can be positive or negative. +-- +-- \[image fredkin.png] +fredkin_at :: Qubit -> Qubit -> Signed Qubit -> Circ () +fredkin_at q1 q2 c = do + comment_with_label "ENTER: fredkin" (q1,q2,c) ("q1","q2","c") + without_controls $ do + qnot_at q2 `controlled` q1 + toffoli_AMMR_at q1 (Signed q2 True) c + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: fredkin" (q1,q2,c) ("q1","q2","c") + +-- | Decomposition of a controlled /H/-gate into the Clifford+/T/ +-- base. From Amy et al. (, Figure +-- 5(a)). The first argument is the target and the second one the +-- control. The control can be positive or negative. +-- +-- \[image cH_AMMR.png] +cH_AMMR_at :: Qubit -> Signed Qubit -> Circ () +cH_AMMR_at q c = do + comment_with_label "ENTER: cH_AMMR" (q,c) ("q","c") + gate_S_inv_at q + hadamard_at q + gate_T_inv_at q + qnot_at q `controlled` c + gate_T_at q + hadamard_at q + gate_S_at q + comment_with_label "EXIT: cH_AMMR" (q,c) ("q","c") + +-- | Decomposition of a controlled /W/-gate into the Clifford+/T/ +-- base. The first two arguments are the targets, and the last +-- argument is the control. The control can be positive or negative. +-- +-- \[image controlled_W.png] +controlled_W_at :: Qubit -> Qubit -> Signed Qubit -> Circ () +controlled_W_at q1 q2 c = do + comment_with_label "ENTER: controlled_W" (q1,q2,c) ("W1","W2","c") + without_comments $ do + qnot_at q2 `controlled` q1 + gate_S_inv_at q1 + hadamard_at q1 + gate_T_inv_at q1 + toffoli_AMMR_at q1 (Signed q2 True) c + gate_T_at q1 + hadamard_at q1 + gate_S_at q1 + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: controlled_W" (q1,q2,c) ("W1","W2","c") + +-- | Decomposition of a /W/-gate into the Clifford+/T/ base. +-- +-- \[image gate_W_CliffordT.png] +gate_W_CliffordT_at :: Qubit -> Qubit -> Circ () +gate_W_CliffordT_at q1 q2 = do + comment_with_label "ENTER: gate_W_CliffordT" (q1,q2) ("W1","W2") + without_comments $ do + qnot_at q2 `controlled` q1 + cH_AMMR_at q1 (Signed q2 True) + qnot_at q2 `controlled` q1 + comment_with_label "EXIT: gate_W_CliffordT" (q1,q2) ("W1","W2") + +-- | Decomposition of a controlled /iX/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_iX.png] +controlled_iX_at :: Qubit -> Signed Qubit -> Circ () +controlled_iX_at q c = do + comment_with_label "ENTER: controlled_iX" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + qnot_at q `controlled` c + reverse_imp_if (not x) gate_S_at w + when (not x) $ do -- need a phase correction + gate_omega_at q + gate_omega_at w + comment_with_label "EXIT: controlled_iX" (q,c) ("q","c") + +-- | Decomposition of a controlled /S/-gate into the Clifford+/T/ +-- base. From Amy et al. (, Figure +-- 5(b)). The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_S.png] +controlled_S_at :: Qubit -> Signed Qubit -> Circ () +controlled_S_at q c = do + comment_with_label "ENTER: controlled_S" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + qnot w `controlled` q + reverse_imp_if (not x) gate_T_inv_at w + qnot w `controlled` q + reverse_imp_if (not x) gate_T_at w + gate_T_at q + comment_with_label "EXIT: controlled_S" (q,c) ("q","c") + +-- | Decomposition of a controlled /T/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_T.png] +controlled_T_at :: Qubit -> Signed Qubit -> Circ () +controlled_T_at q c = do + comment_with_label "ENTER: controlled_T" (q,c) ("q","c") + without_comments $ do + with_ancilla_init False $ \r -> do + cc_iX_at r (Signed q True) c + gate_T_at r + reverse_generic_imp cc_iX_at r (Signed q True) c + comment_with_label "EXIT: controlled_T" (q,c) ("q","c") + +-- | Decomposition of a controlled /V/-gate into the Clifford+/T/ +-- base. Adapted from Amy et al. (, +-- Figure 5(c)). Our /V/-gate is /H//S/[sup †]/H/ as in Nielsen and +-- Chuang. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_V.png] +controlled_V_at :: Qubit -> Signed Qubit -> Circ () +controlled_V_at q c = do + comment_with_label "ENTER: controlled_V" (q,c) ("q","c") + let x = get_sign c + w = from_signed c + hadamard_at q + reverse_imp_if (not x) gate_T_inv_at w + qnot w `controlled` q + reverse_imp_if (not x) gate_T_at w + gate_T_inv_at q + qnot w `controlled` q + hadamard_at q + comment_with_label "EXIT: controlled_V" (q,c) ("q","c") + +-- | Decomposition of a controlled /E/-gate into the Clifford+/T/ +-- base. The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_E.png] +controlled_E_at :: Qubit -> Signed Qubit -> Circ () +controlled_E_at q c = do + comment_with_label "ENTER: controlled_E" (q,c) ("q","c") + with_signed_qubit c $ \r -> do + gate_H_at q + gate_S_at r + gate_T_at q + qnot_at q `controlled` r + gate_T_inv_at q + gate_H_at q + qnot_at r `controlled` q + gate_T_at r + gate_T_inv_at q + qnot_at r `controlled` q + comment_with_label "EXIT: controlled_E" (q,c) ("q","c") + +-- | Decomposition of a controlled [bold Y]-gate into the Clifford+/T/ +-- base. The gate is from the Ground State Estimation algorithm and is +-- defined as [bold Y] = /SHS/, or equivalently, +-- +-- \[image Y.png] +-- +-- It should not be confused with the Pauli /Y/ gate. +-- The first argument is the target, and the second one is the +-- control. The control can be positive or negative. +-- +-- \[image controlled_YY.png] +controlled_YY_at :: Qubit -> Signed Qubit -> Circ () +controlled_YY_at q c = do + comment_with_label "ENTER: controlled_YY" (q,c) ("q","c") + gate_S_at q + qnot_at q `controlled` c + gate_S_inv_at q + hadamard_at q + gate_T_inv_at q + qnot_at q `controlled` c + gate_T_at q + hadamard_at q + comment_with_label "EXIT: controlled_YY" (q,c) ("q","c") + +-- | A \"plain\" Toffoli gate, not decomposed. This is provided for +-- convenience, for example to use with 'with_combined_controls'. +toffoli_plain_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +toffoli_plain_at q c1 c2 = do + qnot_at q `controlled` (c1,c2) + +-- | A \"plain\" doubly-controlled /iX/-gate, not decomposed. This is +-- provided for convenience, for example to use with +-- 'with_combined_controls'. +cc_iX_plain_at :: Qubit -> Signed Qubit -> Signed Qubit -> Circ () +cc_iX_plain_at q c1 c2 = do + gate_iX_at q `controlled` (c1,c2) + +-- | Decomposition of an /m/-times controlled not-gate, using /m/−2 +-- ancillas that do not need be initialized in a particular +-- state. Adapted from Barenco et al. +-- (, Lemma 7.2). +-- +-- In addition to what is shown in Barenco et al., this function +-- permits some Toffoli gates to be replaced by doubly-controlled +-- /iX/-gates. This may be beneficial in gate bases, such as +-- Clifford+/T/, where a doubly-controlled /iX/-gate has a simpler +-- representation than a Toffoli gate. +-- +-- The first argument is a Toffoli gate to use in the +-- decomposition. The second argument may be either a Toffoli gate or +-- a doubly-controlled /iX/ gate. The third argument is the target, +-- the fourth argument is a list of qubits to be used as ancillas, and +-- the fifth argument is a list of signed controls. The ancillas need +-- not be initialized, and are returned in their original state. +-- +-- The size of this circuit is linear in the number of controls; the +-- decomposition uses 4/m/−8 doubly-controlled gates for /m/ ≥ 3. +-- +-- \[image multi_cnot_barenco.png] +multi_cnot_barenco_at :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Qubit -> [Qubit] -> [Signed Qubit] -> Circ () +multi_cnot_barenco_at my_toffoli_at my_ciX_at q as cs = + case cs of + [] -> do + qnot_at q + [c] -> do + qnot_at q `controlled` c + [c1,c2] -> do + my_toffoli_at q c1 c2 + c:cs -> do + case as of + [] -> error "multi_cnot_barenco_at: too few ancillas" + a:as -> do + my_toffoli_at q (Signed a True) c + aux cs (a:as) + my_toffoli_at q (Signed a True) c + reverse_generic_imp aux cs (a:as) + where + aux :: [Signed Qubit] -> [Qubit] -> Circ () + aux [] as = return () + aux [c] as = return () + aux [c1,c2] (a:as) = do + my_ciX_at a c1 c2 + aux (c:cs) (a1:a2:as) = do + my_ciX_at a1 (Signed a2 True) c + aux cs (a2:as) + my_ciX_at a1 (Signed a2 True) c + aux _ _ = error "multi_cnot_barenco_at: too few ancillas" + +-- | Decomposition of a multiply-controlled /iX/-gate, using no +-- ancillas. Adapted from Giles and Selinger +-- (, Section 5.2). +-- +-- The first argument is a Toffoli gate or a doubly-controlled +-- /iX/-gate. The third argument is the target, and the fourth +-- argument is a list of signed controls. +-- +-- The size of this circuit is linear in the number of controls; the +-- decomposition uses 8/m/−32 doubly-controlled gates, 4 /T/-gates, +-- and 2 /H/-gates, for /m/ ≥ 6. +-- +-- \[image multi_ciX_noancilla.png] +multi_ciX_noancilla_at :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Qubit -> [Signed Qubit] -> Circ () +multi_ciX_noancilla_at my_ciX_at q [] = gate_iX_at q +multi_ciX_noancilla_at my_ciX_at q [c] = gate_iX_at q `controlled` c +multi_ciX_noancilla_at my_ciX_at q [c1,c2] = gate_iX_at q `controlled` [c1,c2] +multi_ciX_noancilla_at my_ciX_at q cs = do + hadamard_at q + gate_T_inv_at q + multi_cnot_barenco_at my_ciX_at my_ciX_at q as1 cs2 + gate_T_at q + multi_cnot_barenco_at my_ciX_at my_ciX_at q as2 cs1 + gate_T_inv_at q + reverse_generic_imp (multi_cnot_barenco_at my_ciX_at my_ciX_at) q as1 cs2 + gate_T_at q + reverse_generic_imp (multi_cnot_barenco_at my_ciX_at my_ciX_at) q as2 cs1 + hadamard_at q + where + n = length cs + (cs1, cs2) = splitAt (n `div` 2) cs + as1 = map from_signed cs1 + as2 = map from_signed cs2 + +-- ---------------------------------------------------------------------- +-- * Decomposition of controls + +-- | Partition a list of controls into quantum and classical. +partition_controls :: [Signed Endpoint] -> ([Signed Qubit], [Signed Bit]) +partition_controls cs = (qcs, ccs) where + qcs = [ Signed q b | Signed (Endpoint_Qubit q) b <- cs ] + ccs = [ Signed c b | Signed (Endpoint_Bit c) b <- cs ] + +-- | Given a function that expects a qubit (typically as a control), +-- turn it into a function that can handle a /signed/ (positive or +-- negative) qubit. This is done by conjugating the circuit with +-- negations on both sides, if the sign is negative. Usage: +-- +-- > with_signed_qubit c $ \q -> do +-- > <<>> +-- +-- \[image with_signed_qubit.png] +with_signed_qubit :: Signed Qubit -> (Qubit -> Circ b) -> Circ b +with_signed_qubit (Signed q True) f = f q +with_signed_qubit (Signed q False) f = do + gate_X_at q + b <- f q + gate_X_at q + return b + +-- | Decompose quantum controls recursively until at most /n/ remain, +-- and then pass these reduced controls to the given circuit. +-- Precondition: /n/ ≥ 1. +-- +-- The decomposition is done using a Toffoli-like gate that is given +-- as the first argument. This should be either a Toffoli gate, a +-- doubly-controlled /iX/-gate, a decomposition thereof, or any other +-- reversible ternary gate with the behavior +-- +-- * |000〉 ↦ |0〉|φ[sub 0]〉 +-- +-- * |001〉 ↦ |0〉|φ[sub 1]〉 +-- +-- * |010〉 ↦ |0〉|φ[sub 2]〉 +-- +-- * |011〉 ↦ |1〉|φ[sub 3]〉, +-- +-- where the states |φ[sub 0]〉, …, |φ[sub 3]〉 are arbitrary. +-- +-- For example, when /n/=2, this typically yields a circuit such as +-- the following (here shown using the doubly-controlled /iX/-gate): +-- +-- \[image with_combined_controls2.png] +-- +-- And for /n/=1, the circuit typically looks like this: +-- +-- \[image with_combined_controls1.png] +-- +-- Classical controls are not decomposed, but are applied to the +-- resulting circuit directly. +with_combined_controls :: (Qubit -> Signed Qubit -> Signed Qubit -> Circ ()) -> Int -> [Signed Endpoint] -> ([Signed Qubit] -> Circ a) -> Circ a +with_combined_controls my_toffoli_at n cs code = circ where + (qcs, ccs) = partition_controls cs + len = length qcs + -- m is the number of qcs to remove. + m = if len <= n then 0 else len - n + circ = with_controls ccs $ do + aux m qcs code + + aux 0 qcs code = code qcs + aux n [] code = code [] + aux n [c] code = code [c] + aux n (c1:c2:qcs) code = do + with_computed (quantum_and c1 c2) $ \c -> do + aux (n-1) (qcs ++ [Signed c True]) code + + quantum_and :: Signed Qubit -> Signed Qubit -> Circ Qubit + quantum_and c1 c2 = do + q <- qinit 0 + my_toffoli_at q c1 c2 + return q diff --git a/dist/build/Quipper/Libraries/QFT.hs b/dist/build/Quipper/Libraries/QFT.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QFT.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QFT.hs" #-} +-- | This module implements the Quantum Fourier Transform. + +module Quipper.Libraries.QFT ( + qft_little_endian, + qft_big_endian, + qft_rev, + qft_int + ) where + +import Quipper +import Quipper.Libraries.Arith + +import Quipper.Utils.Auxiliary (mmap) + +-- ---------------------------------------------------------------------- +-- * Low-level implementation + +-- | Like 'qft_rev', but without the comments and labels. +-- +-- Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- The input is little-endian and the output is big-endian. +-- +-- Unlike 'qft_little_endian' and 'qft_big_endian', this function can +-- be used in imperative style, i.e., it modifies its arguments \"in +-- place\". +qft_internal :: [Qubit] -> Circ [Qubit] +qft_internal [] = return [] +qft_internal [x] = do + hadamard x + return [x] +qft_internal (x:xs) = do + xs' <- qft_internal xs + xs'' <- rotations x xs' (length xs') + x' <- hadamard x + return (x':xs'') + where + -- Auxiliary function used by 'qft'. + rotations :: Qubit -> [Qubit] -> Int -> Circ [Qubit] + rotations _ [] _ = return [] + rotations c (q:qs) n = do + qs' <- rotations c qs n + q' <- rGate ((n + 1) - length qs) q `controlled` c + return (q':qs') + +-- ---------------------------------------------------------------------- +-- * Wrappers + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- Both the input and output qubit lists are little-endian, i.e., the +-- leftmost qubit (head of the list) is the least significant one. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_little_endian :: [Qubit] -> Circ [Qubit] +qft_little_endian qs = do + comment_with_label "ENTER: qft_little_endian" qs "qs" + qs' <- qft_internal qs + let qs = reverse qs' + comment_with_label "EXIT: qft_little_endian" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- Both the input and output qubit lists are big-endian, i.e., the +-- leftmost qubit (head of the list) is the most significant one. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_big_endian :: [Qubit] -> Circ [Qubit] +qft_big_endian qs = do + comment_with_label "ENTER: qft_big_endian" qs "qs" + qs <- qft_internal (reverse qs) + comment_with_label "EXIT: qft_big_endian" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a list of /n/ qubits. +-- The input is little-endian and the output is big-endian. +-- +-- Unlike 'qft_little_endian' and 'qft_big_endian', this function can +-- be used in imperative style, i.e., it modifies its arguments +-- \"in place\". +qft_rev :: [Qubit] -> Circ [Qubit] +qft_rev qs = do + comment_with_label "ENTER: qft_rev" qs "qs" + qs <- qft_internal qs + comment_with_label "EXIT: qft_rev" qs "qs" + return qs + +-- | Apply the Quantum Fourier Transform to a 'QDInt'. +-- +-- Note that this function cannot be used in imperative style, i.e., +-- it does not update its arguments \"in place\". The output qubits +-- are in different physical locations than the input ones. +qft_int :: QDInt -> Circ QDInt +qft_int x = do + comment_with_label "ENTER: qft_int" x "x" + x <- mmap qdint_of_qulist_bh $ qft_big_endian $ qulist_of_qdint_bh x + comment_with_label "ENTER: qft_int" x "x" + return x + +-- ---------------------------------------------------------------------- +-- * Testing + +-- | A simple test. +test :: Int -> IO () +test n = print_generic Preview qft_little_endian (replicate n qubit) diff --git a/dist/build/Quipper/Libraries/QFTAdd.hs b/dist/build/Quipper/Libraries/QFTAdd.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QFTAdd.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QFTAdd.hs" #-} +-- | This module provides an implementation of the addition circuit found in +-- Thomas G. Draper's paper \"Addition on a Quantum Computer\". +module Quipper.Libraries.QFTAdd +( + qft_add_in_place +) +where + +import Quipper +import Quipper.Libraries.Arith -- we make use of the QDInt data type for quantum integers +import Quipper.Libraries.QFT -- we make use of the big endian QFT + +-- | Add one 'QDInt' onto a second, in place; i.e. (/x/,/y/) ↦ (/x/,/x/+/y/). +-- Arguments are assumed to be of equal size. +-- This implementation follows the implementation in Thomas G. Draper's +-- paper \"Addition on a Quantum Computer\" which doesn't require the use of any +-- ancilla qubits through a clever use of the Quantum Fourier Transform. +qft_add_in_place :: QDInt -> QDInt -> Circ (QDInt,QDInt) +qft_add_in_place x y = do + let x' = list_of_xint_bh x + let y' = list_of_xint_bh y + (x', y') <- qft_add_in_place_qulist x' y' + let x = xint_of_list_bh x' + let y = xint_of_list_bh y' + return (x, y) + +-- | Low-level implementation of 'qft_add_in_place': represents integers +-- as big-headian qubit lists. +qft_add_in_place_qulist :: [Qubit] -> [Qubit] -> Circ ([Qubit], [Qubit]) +qft_add_in_place_qulist a b = do + label (a,b) ("a","b") + with_computed (box "QFT" qft_big_endian b) $ \b' -> do + qft_adder a (reverse b') + label (a,b) ("a","b") + return (a,b) + +-- | The circuit that performs the addition after a QFT +qft_adder :: [Qubit] -> [Qubit] -> Circ () +qft_adder _ [] = return () +qft_adder as (b:bs) = do + qft_adder' as b 1 + qft_adder (tail as) bs + where + qft_adder' :: [Qubit] -> Qubit -> Int -> Circ [Qubit] + qft_adder' [] _ _ = return [] + qft_adder' (a:as) b n = do + b <- rGate n b `controlled` a + qft_adder' as b (n+1) diff --git a/dist/build/Quipper/Libraries/Qram.hs b/dist/build/Quipper/Libraries/Qram.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Qram.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Qram.hs" #-} +-- | A custom qRAM algorithm for fetching and storing quantum data +-- from a quantum array, addressed by a quantum integer. + +module Quipper.Libraries.Qram ( + indexed_access, + indexed_fetch_at, + indexed_store_at, + indexed_swap_at, + ) where + +import Quipper +import Quipper.Libraries.Arith + +-- | Inputs a list /a/ of quantum data and a quantum integer /i/, and +-- returns the /i/th element of /a/. This is done with controlled swap +-- operations, but without ancillas, i.e., the output is the only copy +-- of that quantum data. Note that the remaining elements of the array +-- may be swapped around, so they are not useable until +-- 'indexed_access' has been reversed. +-- +-- Suggested usage: +-- +-- > with_computed (indexed_access i a) $ \x -> do +-- > <<>> +-- +-- If the index is out of bound, return an unpredictable element of +-- /a/. If /a/ is of length 0, raise an error. +indexed_access :: (QData qa) => [qa] -> QDInt -> Circ qa +indexed_access as i = indexed_access_qulist as (qulist_of_qdint_bh i) + +-- | Auxiliary function: like 'indexed_access', but uses a qubit list +-- instead of a quantum integer. The list is big-headian, i.e., the +-- head of the list holds the most significant bit. +indexed_access_qulist :: (QData qa) => [qa] -> [Qubit] -> Circ qa +indexed_access_qulist [] i = error "indexed_access: cannot address length-0 register" +indexed_access_qulist (a:as) [] = return a +indexed_access_qulist as (i:is) = do + let n = 2 ^ length is + r = max 0 $ min n (length as - n) + -- r: number of wires that need swapping if head qdigit is set + for (r-1) 0 (-1) $ \j -> do + swap_at (as !! j) (as !! (j+n)) `controlled` i + a <- indexed_access_qulist as is + return a + +-- | @'indexed_fetch_at' /a/ /i/ /q/@: +-- Perform /q/ ⊕= /a/[/i/]. +indexed_fetch_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_fetch_at as i q = do + with_computed (indexed_access as i) $ \x -> do + controlled_not_at q x + +-- | @'indexed_store_at' /a/ /i/ /q/@: +-- Perform /a/[/i/] ⊕= /q/. +indexed_store_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_store_at as i q = do + with_computed (indexed_access as i) $ \x -> do + controlled_not_at x q + +-- | @'indexed_swap_at' /a/ /i/ /q/@: +-- Swap /a/[/i/] and /q/. +indexed_swap_at :: (QData qa) => [qa] -> QDInt -> qa -> Circ () +indexed_swap_at as i q = do + with_computed (indexed_access as i) $ \x -> do + swap_at x q diff --git a/dist/build/Quipper/Libraries/QuantumIf.hs b/dist/build/Quipper/Libraries/QuantumIf.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QuantumIf.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QuantumIf.hs" #-} +-- | This module introduces a simple way of defining boolean +-- statements acting over qubits. +module Quipper.Libraries.QuantumIf where + +import Quipper + +-- ---------------------------------------------------------------------- +-- * Quantum \"if then else\" statements + +-- $ This module introduces a simple way of defining boolean +-- statements acting over qubits, which can then be used as the +-- control in a quantum \"if then else\" statement. The idea is that +-- an ancilla is initialized that is in the state represented by the +-- boolean statement, and is then used to control the two branches of +-- the \"if then else\", before being uncomputed. The boolean +-- statements can contain \"and\", \"or\", and \"not\". + +-- | We can use @(Boolean Qubit)@ to build up \"boolean statements\" +-- over qubits and use the \"boolean statement\" in an 'if_then_elseQ' +-- construct. +-- +-- > Example (for qubits a, b, c, d): +-- > (a and b) or !(c and !d) is written as: +-- > (a `And` b) `Or` Not (c `And` Not d) +data Boolean a = A a -- ^ 'A' /q/ means if /q/ == 'True'. + | Not (Boolean a) -- ^ 'Not' /b/ means the negation of the boolean statement /b/. + | And (Boolean a) (Boolean a) -- ^ 'And' /a/ /b/ means the and of the boolean statements /a/ and /b/. + | Or (Boolean a) (Boolean a) -- ^ 'Or' /a/ /b/ means the or of the boolean statements /a/ and /b/ + deriving Show + +-- Set the precedence for infix operators 'And' and 'Or'. +infixr 3 `And` -- same precedence as (&&) +infixr 2 `Or` -- same precedence as (||) + +-- | Allow 'And' and 'Or' to be used as infix operators, with the same +-- precedences. + +-- | Internally, a \"boolean statement\" is converted into a statement +-- that doesn't use /or/ (e.g., using De Morgan's laws). +data BooleanAnd a = AA a -- ^ 'AA' /q/ means if /q/ == 'True'. + | NotA (BooleanAnd a) -- ^ 'NotA' /b/ means the negation of the boolean statement /b/. + | AndA (BooleanAnd a) (BooleanAnd a) -- ^ 'AndA' /a/ /b/ means the and of the boolean statements /a/ and /b/. + +-- | Convert any boolean formula to a formula using just /and/ and /not/. This conversion function uses De Morgan's law, +-- i.e., +-- +-- > A or B = !( !A and !B ), +-- +-- but does not remove double negations. For a version that also +-- removes double negations, see 'booleanToAnd'. +booleanToAnd' :: Boolean a -> BooleanAnd a +booleanToAnd' (A a) = AA a +booleanToAnd' (Not ba) = NotA (booleanToAnd' ba) +booleanToAnd' (And ba ba') = AndA (booleanToAnd' ba) (booleanToAnd' ba') +booleanToAnd' (Or ba ba') = NotA (AndA (NotA (booleanToAnd' ba)) (NotA (booleanToAnd' ba'))) + +-- | Strip any redundant double negations, +-- i.e., in this context @!!A = A@. +stripDoubleNot :: BooleanAnd a -> BooleanAnd a +stripDoubleNot (AA a) = AA a +stripDoubleNot (NotA (NotA ba)) = stripDoubleNot ba +stripDoubleNot (NotA ba) = NotA (stripDoubleNot ba) +stripDoubleNot (AndA ba ba') = AndA (stripDoubleNot ba) (stripDoubleNot ba') + +-- | Convert any boolean formula to a formula using just /and/ and +-- /not/, removing double negations. +booleanToAnd :: Boolean a -> BooleanAnd a +booleanToAnd ba = stripDoubleNot (booleanToAnd' ba) + +-- | Create a circuit from the \"boolean statement\". +booleanAnd' :: BooleanAnd Qubit -> Qubit -> Circ () +booleanAnd' (AA q') q = do + qnot_at q `controlled` q' + return () +booleanAnd' (NotA ba) q = do + anc <- qinit False + qnot_at anc + booleanAnd' ba anc + qnot_at q `controlled` anc +booleanAnd' (AndA ba ba') q = do + anc0 <- qinit False + booleanAnd' ba anc0 + anc1 <- qinit False + booleanAnd' ba' anc1 + qnot_at q `controlled` [anc0,anc1] + +-- | Create a circuit from the \"boolean statement\", passing in an ancilla. +booleanAnd :: BooleanAnd Qubit -> Circ Qubit +booleanAnd baq = do + anc <- qinit False + booleanAnd' baq anc + return anc + +-- | The definition of a quantum if_then_else structure +-- uses a \"boolean statement\" to create a single ancilla in the state defined by +-- the boolean statement, and uses this as a control for the two branches of the +-- if statement. The ancilla then needs to be uncomputed, this is achieved using +-- the other given \"boolean statement\", i.e., a new boolean statement that would +-- produce the state of the control ancilla, from the output state of the two +-- branches.This allows the branches to update the state of qubits used in the +-- original \"boolean statement\" as long as it is done in a +-- (reversible) known-manner. +-- This is useful for the WALK algorithm, where TOPARENT and TOCHILD are controlled +-- by the state of the direction register, but also change the state of the +-- direction register. +if_then_elseQinv :: Boolean Qubit -> Circ () -> Circ () -> Boolean Qubit -> Circ () +if_then_elseQinv b_in i e b_out = do + with_ancilla $ \if_control -> do + with_computed (booleanAnd (booleanToAnd b_in)) $ \anc -> do + qnot_at if_control `controlled` anc + with_controls if_control $ do + i + with_controls (if_control .==. False) $ do + e + with_computed (booleanAnd (booleanToAnd b_out)) $ \anc -> do + qnot_at if_control `controlled` anc + +-- | Like 'if_then_elseQinv', but where the original \"boolean statement\" still +-- holds after the branches have taken place. +if_then_elseQ :: Boolean Qubit -> Circ () -> Circ () -> Circ () +if_then_elseQ b i e = do + with_computed (booleanAnd (booleanToAnd b)) $ \if_control -> do + with_controls if_control $ do + i + with_controls (if_control .==. False) $ do + e diff --git a/dist/build/Quipper/Libraries/QuipperASCIIParser.hs b/dist/build/Quipper/Libraries/QuipperASCIIParser.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QuipperASCIIParser.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QuipperASCIIParser.hs" #-} +-- ---------------------------------------------------------------------- +-- | This module is the main interface to the QuipperASCIIParser +-- library. It provides functions for parsing circuits in the ASCII +-- format written by 'print_generic' and similar functions. + +module Quipper.Libraries.QuipperASCIIParser where + +import qualified Quipper.Libraries.QuipperASCIIParser.CircInfo as CI +import qualified Quipper.Libraries.QuipperASCIIParser.ASCIICirc as AC + +import Quipper +import Quipper.Internal.Monad + +import Quipper.Utils.PortableSignals +import System.IO +import Data.List + +-- | Parse a string containing a circuit in the format output by +-- Quipper's ASCII format. Return a circuit producing function of the +-- parsed circuit, along with a specimen \"shape\" for the input of +-- the parsed circuit. +parse_circuit :: String -> ([Endpoint],[Endpoint] -> Circ [Endpoint]) +parse_circuit all_lines = AC.run mins gates subs circ_info + where + split_lines = lines' all_lines + (mins, ci) = CI.run_ascii_lines split_lines + (gates,subs,circ_info) = CI.run ci + + +-- | Like 'lines', except that the last line is omitted if it doesn't +-- end with a newline character +lines' :: String -> [String] +lines' [] = [] +lines' s = case elemIndex '\n' s of + Nothing -> [] + Just n -> (take (n) s):lines' (drop (n+1) s) + +-- | Like 'parse_circuit', but read the circuit from the standard +-- input stream, rather than from a string. This can be used to build +-- stand-alone tools that process circuits in a pipeline. +parse_from_stdin :: IO ([Endpoint], [Endpoint] -> Circ [Endpoint]) +parse_from_stdin = do + all_lines <- hGetContents stdin + return $ parse_circuit all_lines + +-- | Like 'parse_from_stdin', but as a special convenience, this +-- function also installs a signal handler that will intercept the first +-- kill signal (e.g., Ctrl-C) and close the standard input stream. +-- This means that whichever part of the circuit was generated before the +-- first Ctrl-C can still be processed as a partial circuit. Note that the +-- second kill signal will still kill the program. Note that this is only +-- defined for Non-Windows OS environments. +parse_from_stdin_with_handler :: IO ([Endpoint], [Endpoint] -> Circ [Endpoint]) +parse_from_stdin_with_handler = do + installHandler Interrupt (CatchOnce (hClose stdin)) + all_lines <- hGetContents stdin + return $ parse_circuit all_lines diff --git a/dist/build/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs b/dist/build/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs @@ -0,0 +1,338 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs" #-} +-- ---------------------------------------------------------------------- +-- | This module uses a state transformer monad to rebuild a circuit from +-- the CircInfoState representation. This can only be as lazy as the Quipper +-- ASCII output allows, as subroutine definitions need to be known before +-- a subroutine can be called. + +module Quipper.Libraries.QuipperASCIIParser.ASCIICirc where + +import Quipper.Libraries.QuipperASCIIParser.CircInfo hiding (run,do_gate) + +import Quipper +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Internal.Generic + +import Data.List +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map + +import Control.Monad.State + +-- | In the Quipper ASCII output, wires are identified by integers. +-- We have to map these to Quipper's native wires and types. +data WireState = WireState { + wire_map :: IntMap (Wire,Wiretype), + in_sub :: Bool, + subroutines_in_scope :: Map BoxId Sub + } + +-- | An initial, empty WireState, with the given subroutines_in_scope +empty_wirestate :: Map BoxId Sub -> WireState +empty_wirestate subs = WireState {wire_map = IntMap.empty, in_sub = False, + subroutines_in_scope = subs} + +-- | The 'ASCIICirc' monad is like the 'Circ' monad, except that it also +-- keeps track of an additional 'WireState'. The 'lift' function must +-- be used to lift any command for the 'Circ' monad to the 'ASCIICirc' +-- monad. +type ASCIICirc a = StateT WireState Circ a + +-- | The 'in_sub' flag can be set to True, as slightly different behavior is +-- required when evaluating a subroutine. +set_in_sub :: ASCIICirc () +set_in_sub = do + state <- get + put (state {in_sub = True}) + +-- | Look up the qubit corresponding to a ASCII integer representation of a +-- qubit. If it doesn't already exist then initialize a new qubit. +provide_qubit :: Int -> ASCIICirc Qubit +provide_qubit r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,Qbit) -> return (qubit_of_wire w) + Just (w,Cbit) -> error ("Quantum wire " ++ show r ++ " bound as classical " ++ show w) + Nothing -> error ("Quantum wire " ++ show r ++ " not in scope") + True -> return (qubit_of_wire r) + +-- | Look up the bit corresponding to a ASCII integer representation of a +-- bit. If it doesn't already exist then initialize a new bit. +provide_bit :: Int -> ASCIICirc Bit +provide_bit r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,Cbit) -> return (bit_of_wire w) + Just (w,Qbit) -> error ("Classical wire " ++ show r ++ " bound as quantum " ++ show w) + Nothing -> error ("Classical wire " ++ show r ++ " not in scope") + True -> return (bit_of_wire r) + +-- | Look up the wire corresponding to a ASCII integer representation of a +-- bit or qubit. If it doesn't already exist then initialize a new qubit. +provide_wire :: Int -> ASCIICirc Wire +provide_wire r = do + state <- get + case (in_sub state) of + False -> do + let ws = wire_map state + case IntMap.lookup r ws of + Just (w,_) -> return w + Nothing -> do + q <- provide_qubit r + return (wire_of_qubit q) + True -> return r + +-- | Add a new qubit to the state. +add_qubit :: Int -> Qubit -> ASCIICirc () +add_qubit w q = do + state <- get + let ws = wire_map state + let ws' = IntMap.insert w (wire_of_qubit q,Qbit) ws + put (state {wire_map = ws'}) + +-- | Add a new bit to the state. +add_bit :: Int -> Bit -> ASCIICirc () +add_bit w b = do + state <- get + let ws = wire_map state + let ws' = IntMap.insert w (wire_of_bit b,Cbit) ws + put (state {wire_map = ws'}) + +-- | Remove a wire from the state +remove_wire :: Int -> ASCIICirc () +remove_wire w = do + state <- get + let ws = wire_map state + let ws' = IntMap.delete w ws + put (state {wire_map = ws'}) + +-- | A helper function for providing the qubits within a control structure +provide_control :: Signed Int -> ASCIICirc (Signed Wire) +provide_control (Signed r val) = do + w <- provide_wire r + return (Signed w val) + +-- | provides quantum wires for the controls in a control list +provide_controls :: [Signed Int] -> ASCIICirc [Signed Wire] +provide_controls = mapM provide_control + +-- | Lift a Quipper circuit, preventing the addition of controls depending +-- on the given boolean. +lift_ncf :: Bool -> Circ a -> ASCIICirc a +lift_ncf False ca = lift ca +lift_ncf True ca = lift $ without_controls ca + +-- | Take a Gate and execute it in the 'ASCIICirc' monad. +do_gate :: Gate -> ASCIICirc () +do_gate (QGate name iflg ws1 ws2 wbs ncf) = do + qs1 <- mapM provide_qubit ws1 + qs2 <- mapM provide_qubit ws2 + cs <- provide_controls wbs + lift_ncf ncf $ named_gate_qulist name iflg qs1 qs2 `controlled` cs + return () +do_gate (QRot name iflg theta ws1 ws2 wbs ncf) = do + qs1 <- mapM provide_qubit ws1 + qs2 <- mapM provide_qubit ws2 + cs <- provide_controls wbs + lift_ncf ncf $ named_rotation_qulist name iflg theta qs1 qs2 `controlled` cs + return () +do_gate (GPhase ts ws wbs ncf) = do + qs <- mapM provide_qubit ws + cs <- provide_controls wbs + lift_ncf ncf $ global_phase_anchored_list ts (map (\w -> endpoint_of_wire w Qbit) (map wire_of_qubit qs)) `controlled` cs + return () +do_gate (CNot w wbs ncf) = do + b <- provide_bit w + cs <- provide_controls wbs + lift_ncf ncf $ cnot_at b `controlled` cs +do_gate (CGate name w ws ncf) = do + bs <- mapM provide_bit ws + b <- lift_ncf ncf $ cgate name bs + add_bit w b +do_gate (CGateInv name w ws ncf) = do + b <- provide_bit w + bs <- mapM provide_bit ws + lift_ncf ncf $ cgateinv name b bs +do_gate (CSwap w1 w2 wbs ncf) = do + b1 <- provide_bit w1 + b2 <- provide_bit w2 + cs <- provide_controls wbs + lift_ncf ncf $ swap b1 b2 `controlled` cs + return () +do_gate (QPrep w ncf) = do + b <- provide_bit w + q <- lift_ncf ncf $ prepare_qubit b + add_qubit w q +do_gate (QUnprep w ncf) = do + q <- provide_qubit w + b <- lift_ncf ncf $ unprepare_qubit q + add_bit w b +do_gate (QInit val w ncf) = do + q <- lift_ncf ncf $ qinit val + add_qubit w q +do_gate (CInit val w ncf) = do + b <- lift_ncf ncf $ cinit val + add_bit w b +do_gate (QTerm val w ncf) = do + q <- provide_qubit w + lift_ncf ncf $ qterm val q + remove_wire w +do_gate (CTerm val w ncf) = do + b <- provide_bit w + lift_ncf ncf $ cterm val b + remove_wire w +do_gate (QMeas w) = do + q <- provide_qubit w + b <- lift $ measure q + add_bit w b +do_gate (QDiscard w) = do + q <- provide_qubit w + lift $ qdiscard q + remove_wire w +do_gate (CDiscard w) = do + b <- provide_bit w + lift $ cdiscard b + remove_wire w +do_gate (Subroutine boxid iflg ws_in _ ws_out _ wbs ncf _ (RepeatFlag rf)) = do + -- Note that we ignore the given arities, as they are dummy values + -- the true values are kept in the ASCIICirc state. + -- The controllable flag is also ignored, as it is recalculated. + state <- get + let subs = subroutines_in_scope state + case (Map.lookup boxid subs) of + Nothing -> error ("Subroutine " ++ show boxid ++ " has not been defined in: " ++ show (Map.keys subs)) + Just sub -> do + let ins = inputs sub + let (_,in_as) = unzip ins + let in_wa = zip ws_in in_as + es_in <- mapM (\(w,wt) -> + case wt of + Qbit -> do + q <- provide_qubit w + let wire = endpoint_of_wire (wire_of_qubit q) Qbit + return wire + Cbit -> do + b <- provide_bit w + let wire = endpoint_of_wire (wire_of_bit b) Cbit + return wire + ) in_wa + cs <- provide_controls wbs + let outs = outputs sub + let es_out = map (\(w,wt) -> endpoint_of_wire w wt) outs + let gates = reverse (circuit sub) + let ascii_circ = \_ -> set_in_sub >> (mapM_ do_gate gates) >> return es_out + let circ = run_asciicirc subs ascii_circ + let boxid = BoxId (name sub) (shape sub) + let error_message = \e -> "ASCIICirc.do_gate : " ++ e + let f = \x -> do + -- Provide subroutine generic only uses circ if it isn't already + -- in the namespace. + provide_subroutine_generic error_message boxid False circ x + call_subroutine boxid (RepeatFlag rf) x + es_out' <- case iflg of + False -> lift_ncf ncf $ f es_in `controlled` cs + True -> do + let (_,out_as) = unzip outs + let out_wa = zip ws_in out_as + es_out <- mapM (\(w,wt) -> + case wt of + Qbit -> do + q <- provide_qubit w + let wire = endpoint_of_wire (wire_of_qubit q) Qbit + return wire + Cbit -> do + b <- provide_bit w + let wire = endpoint_of_wire (wire_of_bit b) Cbit + return wire + ) out_wa + lift_ncf ncf $ (reverse_generic f es_in) es_out `controlled` cs + -- a subroutine can add/remove wires from scope, so we remove all the input + -- wires from the state, and add all the output wires to the state. + -- The state may have changed, so we get it again. + state <- get + let wires = wire_map state + let wires' = foldr (\w ws -> IntMap.delete w ws) wires (if iflg then ws_out else ws_in) + let wires'' = foldr (\(w,e) ws -> IntMap.insert w + (case e of + Endpoint_Qubit q -> (wire_of_qubit q, Qbit) + Endpoint_Bit b -> (wire_of_bit b, Cbit)) ws) wires' + (zip (if iflg then ws_in else ws_out) es_out') + put (state {wire_map = if (in_sub state) then wires else wires''}) +do_gate (Comment c iflg wlabels) = do + qlabels <- mapM (\(w,l) -> + do + pw <- provide_wire w + return (pw,l) ) wlabels + lift $ comment_label c iflg qlabels +do_gate (DTerm val w) = do + b <- provide_bit w + lift $ dterm_bit val b + remove_wire w + +-- | Allocate an input endpoint, to an endpoint in the ASCIICirc, by adding it to +-- the map of wires in scope. +allocate_input :: (Endpoint,Endpoint) -> ASCIICirc () +allocate_input (i,e@(Endpoint_Qubit _)) = add_qubit (wire_of_endpoint e) (qubit_of_wire (wire_of_endpoint i)) +allocate_input (i,e@(Endpoint_Bit _)) = add_bit (wire_of_endpoint e) (bit_of_wire (wire_of_endpoint i)) + +-- ---------------------------------------------------------------------- +-- * Unpacking ASCIICirc + +-- | Execute a parsed circuit, i.e. a CircInfoState, in the ASCIICirc monad +run_gates :: [Gate] -> Maybe [(Wire,Wiretype)] -> [Endpoint] -> [Endpoint] -> ASCIICirc [Endpoint] +run_gates gates d_outs es ins = do + mapM_ (\i -> allocate_input i) (zip ins es) + mapM_ (\g -> do_gate g) gates + state <- get + let ws_in_scope = IntMap.elems $ wire_map state + let es_in_scope = map (\(w,wt) -> endpoint_of_wire w wt) ws_in_scope + case d_outs of + Nothing -> return es_in_scope + Just out_ws -> do + es_out <- mapM (\(w,wt) -> do + w' <- provide_wire w + return (endpoint_of_wire w' wt)) out_ws + let es_in_scope' = sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) es_in_scope + let es_out' = sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) es_out + case es_in_scope' == es_out' of + True -> return es_out' + False -> return es_in_scope' + +-- | Run function for the 'ASCIICirc' monad: execute the actions and +-- produce a circuit. +run_asciicirc :: Map BoxId Sub -> (a -> ASCIICirc b) -> a -> Circ b +run_asciicirc subs f es = evalStateT (f es) (empty_wirestate subs) + +-- | A CircInfoState can be turned into a Circ producing function, and the required +-- input "shape". +run :: Maybe [(Wire,Wiretype)] -> [Gate] -> Map BoxId Sub -> CircInfoState -> ([Endpoint],[Endpoint] -> Circ [Endpoint]) +run mins gates subs cis = (ins,circ) + where + d_ins = defined_inputs cis + d_outs = defined_outputs cis + u_ins = map set_qubit (undefined_inputs cis) + d_es = map (\(w,wt) -> endpoint_of_wire w wt) d_ins + u_es = map (\(w,wt) -> endpoint_of_wire w wt) u_ins + ins = case mins of + Nothing -> (d_es ++ sortBy (\e1 e2 -> compare (wire_of_endpoint e1) (wire_of_endpoint e2)) u_es) + Just wts -> map (\(w,wt) -> endpoint_of_wire w wt) wts + asciicirc = run_gates gates d_outs ins + circ = run_asciicirc subs asciicirc + +-- | If the type of an undefined_input wire is unknown, then set it to +-- be a qubit. +set_qubit :: (Wire,Maybe Wiretype) -> (Wire,Wiretype) +set_qubit (w,Just wt) = (w,wt) +set_qubit (w,Nothing) = (w,Qbit) diff --git a/dist/build/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs b/dist/build/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QuipperASCIIParser/CircInfo.hs" #-} +-- ---------------------------------------------------------------------- +-- | This module uses a state monad to track certain circuit information +-- that is collected during parsing. This information contains +-- the inputs and outputs of a circuit, as well as an entry for each subroutine +-- that is defined within a circuit, and all the gates that make up the circuit. + +module Quipper.Libraries.QuipperASCIIParser.CircInfo where + +import Quipper.Libraries.QuipperASCIIParser.Parse (GatePlus (..),parse_ascii_line) + +import Quipper +import Quipper.Internal.Circuit +import Quipper.Internal.Monad + +import Control.Monad.State + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------- +-- * Data-types for the State + +-- | Information collected about the current subroutine +data Sub = Sub { + name :: String, + shape :: String, + controllable :: ControllableFlag, + inputs :: [(Wire,Wiretype)], + outputs :: [(Wire,Wiretype)], + circuit :: [Gate] + } + +-- | An initial subroutine, with only a name +new_subroutine :: String -> Sub +new_subroutine n = Sub {name = n, shape = "", controllable = NoCtl, inputs = [], outputs = [], circuit = []} + +-- | A 'CircInfoState' is a record containing a list of input wires, along with their +-- types, and a list of output wires, along with their types. We also keep track of +-- whether we're in a subroutine definition, and all the subroutines that have been +-- defined. +data CircInfoState = CircInfoState { + used_wires :: Map Wire (Maybe Wiretype), + defined_inputs :: [(Wire,Wiretype)], + undefined_inputs :: [(Wire,Maybe Wiretype)], + defined_outputs :: Maybe [(Wire,Wiretype)], + current_subroutine :: [Sub] + } + +-- | An initial, empty CircInfoState +empty_circinfostate :: CircInfoState +empty_circinfostate = CircInfoState { used_wires = Map.empty, defined_inputs = [], + undefined_inputs = [], defined_outputs = Nothing, current_subroutine = [] } + +-- | The 'CircInfo' Monad is used to track a 'CircInfoState' during parsing. +type CircInfo a = State CircInfoState a + +-- | The CircInfo Monad tracks wires that are inputs, these can only be given in +-- a "Input" line in the parsed ASCII, so we assume that duplicate wires don't +-- occur, and we add input wires to the state without checking. +add_wire_inputs :: [(Wire,Wiretype)] -> CircInfo () +add_wire_inputs ws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + let ins = defined_inputs state + let wires = used_wires state + put (state {defined_inputs = ws ++ ins, + used_wires = Map.fromList (map (\(w,wt) -> (w,Just wt)) ws)}) + (sub:rest) -> do + let ins = inputs sub + let sub' = sub {inputs = ins ++ ws} + put (state {current_subroutine = (sub':rest)}) + +-- | The CircInfo Monad tracks wires that are outputs, these can only be given in +-- a "Output" line in the parsed ASCII, so we assume that duplicate wires don't +-- occur, and we add output wires to the state without checking. +add_wire_outputs :: [(Wire,Wiretype)] -> CircInfo () +add_wire_outputs ws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + case defined_outputs state of + Nothing -> put (state {defined_outputs = Just ws}) + Just outs -> put (state {defined_outputs = Just (outs ++ ws)}) + (sub:rest) -> do + let outs = outputs sub + let sub' = sub {outputs = outs ++ ws} + put (state {current_subroutine = (sub':rest)}) + +-- | Given a a wire, check whether it is already in scope. +check_input :: Map Wire (Maybe Wiretype) -> (Wire,Maybe Wiretype) -> Bool +check_input wires (w,wt) = case Map.lookup w wires of + Just wt -> False + Nothing -> True + +-- | Given a list of wires that are inputs to a gate, check whether they +-- are already in scope. The returned wires are not in scope, when used by a gate, +-- and must be declared as undefined inputs. +check_inputs :: [(Wire,Maybe Wiretype)] -> Map Wire (Maybe Wiretype) -> [(Wire,Maybe Wiretype)] +check_inputs ins wires = filter (check_input wires) ins + +-- | The CircInfo Monad keeps track of all the gates that have been parsed +-- and adds them to the relevant part of the state. +add_gate :: Gate -> [(Wire,Wiretype)] -> CircInfo CircInfoOut +add_gate gate ctws = do + state <- get + let ms = current_subroutine state + case ms of + [] -> do + let wires = used_wires state + let ui = undefined_inputs state + let (ws_in,ws_out) = gate_arity gate + let ws = wirelist_of_gate gate + let ws_unchecked = filter (\w -> (notElem w (map fst ws_in)) + && (notElem w (map fst ws_out)) + && (notElem w (map fst ctws))) ws + let ws_in' = (map (\(w,wt) -> (w, Just wt)) (ws_in ++ ctws)) + ++ (zip ws_unchecked (repeat Nothing)) + let ui' = ui ++ check_inputs ws_in' wires + let wires' = Map.union wires (Map.fromList (ws_in' + ++ (map (\(w,wt) -> (w, Just wt)) ws_out))) + put (state {used_wires = wires',undefined_inputs = ui'}) + return (Lazy gate) + (sub:rest) -> do + let gates = circuit sub + let gates' = gate:gates + let sub' = sub {circuit = gates'} + put (state {current_subroutine = (sub':rest)}) + return Empty + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. The entrance to the subroutine contains its name. +enter_subroutine :: String -> CircInfo () +enter_subroutine name = do + state <- get + let ms = current_subroutine state + put (state {current_subroutine = ((new_subroutine name):ms)}) + +-- | We can add the shape to the current subroutine +add_subroutine_shape :: String -> CircInfo () +add_subroutine_shape s = do + state <- get + let ms = current_subroutine state + case ms of + [] -> error "Shape given outside of Subroutine Definition" + (sub:rest) -> put (state {current_subroutine = ((sub {shape = s}):rest)}) + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. The subroutine might be controllable. +set_controllable :: ControllableFlag -> CircInfo () +set_controllable val = do + state <- get + let ms = current_subroutine state + case ms of + [] -> error "Controllable not in Subroutine Definition" + (sub:rest) -> put (state {current_subroutine = ((sub {controllable = val}):rest)}) + +-- | A datatype to represent the various outputs a CircInfo computation +-- may require. +data CircInfoOut = Empty | Lazy Gate | SubDef (BoxId,Sub) + +-- | This function returns True if the given input defines a Gate +isGate :: CircInfoOut -> Bool +isGate (Lazy _) = True +isGate _ = False + +-- | This function returns True if the given inputs defines a SubDef +isSub :: CircInfoOut -> Bool +isSub (SubDef _) = True +isSub _ = False + +-- | The CircInfo Monad tracks whether we are in a subroutine, and collects info +-- about that subroutine. At the end of the subroutine, it stores the subroutine +-- for later use. +exit_subroutine :: CircInfo CircInfoOut +exit_subroutine = do + state <- get + let ms = current_subroutine state + case ms of + [] -> return Empty + (sub:rest) -> do + let n = name sub + let s = shape sub + put (state {current_subroutine = rest}) + return (SubDef ((BoxId n s),sub)) + +-- | Take a GatePlus and execute it in the 'CircInfo' monad. +-- Again, the executed computation may depend upon whether we're in a subroutine +-- definition. +do_gate :: GatePlus -> CircInfo CircInfoOut +do_gate (G gate wts) = add_gate gate wts +do_gate (I ws) = add_wire_inputs ws >> return Empty +do_gate (O ws) = do + add_wire_outputs ws + exit_subroutine +do_gate EmptyLine = return Empty +do_gate (CommentLine comment) = return Empty +do_gate (SubroutineName name) = enter_subroutine name >> return Empty +do_gate (SubroutineShape shape) = add_subroutine_shape shape >> return Empty +do_gate (Controllable b) = set_controllable b >> return Empty + +-- | Monad version of 'parse_ascii_line': parse a string and execute the +-- resulting gate directly in the 'CircInfo' monad. +run_ascii_line :: String -> CircInfo CircInfoOut +run_ascii_line s = case parse_ascii_line s of + Nothing -> error ("unrecognized line: " ++ show s) + Just p -> do_gate p + +-- | Parse a stream consisting of many lines of ASCII output and execute +-- the parsed gates in the 'CircInfo' monad, checking to see if the first +-- line defines the inputs to the circuit. +run_ascii_lines :: [String] -> (Maybe [(Wire,Wiretype)],CircInfo [CircInfoOut]) +run_ascii_lines [] = (Nothing,return []) +run_ascii_lines [f] = case parse_ascii_line f of + Just (I ws) -> (Just ws, return []) + _ -> (Nothing, run_ascii_line f >>= \x -> return [x]) +-- Special case: +-- If the first line contains the input wires, we should +-- be able to parse the circuit lazily (e.g. it is a full circuit), as +-- we don't have to parse all the gates to calculate the inputs. +run_ascii_lines (f:s) = + case parse_ascii_line f of + Just (I ws) -> (Just ws, mapM run_ascii_line s) + _ -> (Nothing, mapM run_ascii_line (f:s)) + +-- | Run function for the 'CircInfo' monad: evaluate the state and +-- produce a list of inputs, outputs, and used wires. +run :: CircInfo [CircInfoOut] -> ([Gate],Map BoxId Sub,CircInfoState) +run f = (gs, subs, cis) + where + gs = [x | Lazy x <- filter isGate ci_outs] + subs = Map.fromList [x | SubDef x <- filter isSub ci_outs] + (ci_outs,cis) = runState f empty_circinfostate + diff --git a/dist/build/Quipper/Libraries/QuipperASCIIParser/Parse.hs b/dist/build/Quipper/Libraries/QuipperASCIIParser/Parse.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/QuipperASCIIParser/Parse.hs @@ -0,0 +1,678 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/QuipperASCIIParser/Parse.hs" #-} +-- ---------------------------------------------------------------------- +-- | This module contains the code for parsing the ASCII output from +-- Quipper, into a GatePlus. +-- This program is heavily based on, and heavily borrows from the QCLParser. + +module Quipper.Libraries.QuipperASCIIParser.Parse where + +import Quipper.Internal.Circuit +import Data.IntMap hiding (map) + +import Text.ParserCombinators.ReadP +import Data.Char (isDigit) +import qualified Data.Map as Map + +-- ---------------------------------------------------------------------- +-- | A type for gates, plus other circuit output, empty lines, and subroutine defs. +data GatePlus = G Gate [(Wire,Wiretype)] + | I [(Wire,Wiretype)] + | O [(Wire,Wiretype)] + | EmptyLine + | CommentLine String + | SubroutineName String + | SubroutineShape String + | Controllable ControllableFlag + deriving Show + +-- ---------------------------------------------------------------------- +-- * Parsing + +-- | Parse a string literal. +string_literal :: ReadP String +string_literal = do + char '"' + s <- string_with_escaped_chars "" + char '"' + return s + where + string_with_escaped_chars :: String -> ReadP String + string_with_escaped_chars input = do + s <- munch (\x -> x /= '\\' && x /= '"') + let s' = input ++ s + rest <- look + case rest of + '"' : _ -> return s' + '\\' : _ -> do + e <- escaped_char + string_with_escaped_chars (s' ++ [e]) + _ -> do + pfail + +-- | Parse an escaped character, such as @\0@, @\n@, @\\@, etc. +escaped_char :: ReadP Char +escaped_char = do + char '\\' + c <- get + return (Map.findWithDefault c c map) + where + -- The official escape codes. We allow any other escaped character + -- to denote itself. We do not permit "\&" to denote the empty string. + map = Map.fromList [ + ('0', '\0'), + ('a', '\a'), + ('b', '\b'), + ('f', '\f'), + ('n', '\n'), + ('r', '\r'), + ('t', '\t'), + ('v', '\v'), + ('"', '\"'), + ('\'', '\''), + ('\\', '\\') + ] + +-- | Parse a signless integer. We avoid the usual trick ('readS_to_P' +-- 'reads'), because this introduces backtracking errors. +int :: ReadP Int +int = do + s <- munch1 isDigit + return $ (read s :: Int) + +-- | Parse a floating point number. We avoid the usual trick +-- ('readS_to_P' 'reads'), because this introduces backtracking +-- errors. +double :: ReadP Double +double = do + (s, _) <- gather parse_double + return $ (read s :: Double) + where + parse_double = do + option '+' (char '+' +++ char '-') + munch isDigit + optional (char '.' >> munch1 isDigit) + optional (char 'e' >> option '+' (char '+' +++ char '-') >> int) + +-- | Parse a comma separated list. +commalist :: ReadP a -> ReadP [a] +commalist elt = sepBy elt (skipSpaces >> char ',' >> skipSpaces) + +-- | Parse a control structure. +control :: ReadP (Signed Wire,Wiretype) +control = do + val <- choice [char '+',char '-'] + skipSpaces + w <- int + c <- option 'q' (char 'c') + let wt = case c of + 'c' -> Cbit + _ -> Qbit + return (Signed w (val == '+'),wt) + +-- | Parse a list of controls. +controls :: ReadP ([Signed Wire],[(Wire,Wiretype)]) +controls = do + skipSpaces + string "with controls=[" + cwts <- commalist control + char ']' + let cs = map fst cwts + let wts = map (\(Signed w _,wt) -> (w,wt)) cwts + return (cs,wts) + +-- | Parse a 'Wiretype'. +wiretype :: ReadP Wiretype +wiretype = do + c <- choice [string "Qbit",string "Cbit"] + case c of + "Qbit" -> return Qbit + "Cbit" -> return Cbit + _ -> error "The impossible has happened" + +-- | Parse a wire and its type. +wire :: ReadP (Int,Wiretype) +wire = do + skipSpaces + w <- int + char ':' + t <- wiretype + return (w,t) + +-- | Parse a list of input/output wires and types. +wires :: ReadP [(Int,Wiretype)] +wires = do + skipSpaces + ws <- commalist wire + return ws + +-- | Parse the string \"none\", +-- returning an empty list of input/output wires and types. +none :: ReadP [(Int,Wiretype)] +none = do + skipSpaces + string "none" + return [] + +-- | Consume an optional \"*\". Return 'True' if consumed, and 'False' +-- otherwise. +inversechar :: ReadP Bool +inversechar = do + c <- option '+' (char '*') + return (c == '*') + +-- | Consume a label. +label' :: ReadP (Int,String) +label' = do + w <- int + char ':' + lab <- string_literal + return (w,lab) + +-- | Consumer any character other than \')\', \']\', or \',\'. +labelchar :: ReadP String +labelchar = do + c <- satisfy (\x -> not (x `elem` ")],")) + return [c] + +-- | Consume an index of the form [...]. +labelbracket :: ReadP String +labelbracket = do + char '[' + s <- munch (\x -> not (x `elem` "[]")) + char ']' + return ("[" ++ s ++ "]") + +-- | Consume a list of labels. +labels :: ReadP [(Int,String)] +labels = do + skipSpaces + char '(' + ls <- commalist label' + char ')' + return ls + +-- | Consume a 'BoxId' followed by a \']\' character. +{- +ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape +-} +box_id :: ReadP BoxId +box_id = do + name <- string_literal + skipSpaces + char ',' + skipSpaces + string "shape" + skipSpaces + shape <- string_literal + return (BoxId name shape) + +-- | Consume an optional 'NoControlFlag', returning 'False' if it isn't present. +nocontrolflag :: ReadP NoControlFlag +nocontrolflag = do + skipSpaces + ncf <- option "" (string "with nocontrol") + return (ncf == "with nocontrol") + +-- | Parse a single line of ASCII output into a 'Gate'. This function +-- needs to be kept in line with Quipper's +-- 'Quipper.Internal.Printing.ascii_render_gate' function. +ascii_line :: ReadP GatePlus +ascii_line = choice [ + do -- Inputs: w:Type, w:Type ... + string "Inputs:" + ws <- choice [wires,none] + eof + return (I ws), + do -- Outputs: w:Type, w:Type ... + string "Outputs:" + ws <- choice [wires,none] + eof + return (O ws), + do -- An empty line can be parsed as an EmptyLine + skipSpaces + eof + return EmptyLine, + do -- "A comment in a circuit is any line beginnning with a # character" + -- The comment is stored for later use as a CommentLine + skipSpaces + char '#' + skipSpaces + comment <- manyTill (satisfy (\_ -> True)) eof + eof + return (CommentLine comment), + do -- Subroutine: "name" (keeping unquoted version for backward comp.) + string "Subroutine: " + name <- string_literal +++ manyTill (satisfy (\_ -> True)) eof + eof + return (SubroutineName name), + do -- Shape: "shape" (keeping unquoted version for backward comp.) + string "Shape: " + shape <- string_literal +++ manyTill (satisfy (\_ -> True)) eof + eof + return (SubroutineShape shape), + do -- Controllable: yes/no/classically + string "Controllable: " + val_string <- choice [string "yes",string "no", string "classically"] + let val = case val_string of + "yes" -> AllCtl + "no" -> NoCtl + "classically" -> OnlyClassicalCtl + _ -> error "The impossible happened" + eof + return (Controllable val), +{- +For backward compatibility: +ascii_render_gate (QNot w c ncf) = + "QNot(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QNot(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "not" False [w] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QMultinot ws c ncf) = + "QMultinot(" ++ string_of_list "" ", " "" "" show ws ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QMultinot(" + ws <- commalist int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "multinot" False ws [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QHad w c ncf) = + "QHad(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QHad(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "H" False [w] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QSwap w1 w2 c ncf) = + "QSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QSwap(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "swap" False [w1, w2] [] cs ncf) wts), +{- +For backward compatibility: +ascii_render_gate (QW w1 w2 c ncf) = + "QW(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QW(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate "W" False [w1, w2] [] cs ncf) wts), +{- +ascii_render_gate (GPhase t ws c ncf) = + "GPhase() with t=" ++ show t + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf + ++ string_of_list " with anchors=[" ", " "]" "" show ws +-} + do + string "GPhase() with t=" + t <- double + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + ws <- option [] (do + skipSpaces + string "with anchors=[" + ws <- commalist int + char ']' + return ws ) + eof + return (G (GPhase t ws cs ncf) wts), +{- +ascii_render_gate (QGate name inv ws1 ws2 c ncf) = + "QGate[" ++ show name ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list "; [" "," "]" "" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QGate[" + name <- string_literal + char ']' + inv <- inversechar + char '(' + ws1 <- commalist int + char ')' + ws2 <- option [] (do + string "; [" + ws <- commalist int + char ']' + return ws ) + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QGate name inv ws1 ws2 cs ncf) wts), +{- +ascii_render_gate (QRot name inv theta ws1 ws2 c ncf) = + "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list "; [" "," "]" "" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "QRot[" + name <- string_literal + char ',' + theta <- double + char ']' + inv <- inversechar + char '(' + ws1 <- commalist int + char ')' + ws2 <- option [] ( do + string "; [" + ws <- commalist int + char ']' + return ws ) + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (QRot name inv theta ws1 ws2 cs ncf) wts), +{- +ascii_render_gate (CNot w c ncf) = + "CNot(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "CNot(" + w <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (CNot w cs ncf) wts), +{- +ascii_render_gate (CGate n w c ncf) = + "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +-} + do + string "CGate[" + name <- string_literal + string "](" + ws <- commalist int + char ')' + ncf <- nocontrolflag + eof + return (G (CGate name (head ws) (tail ws) ncf) []), +{- +ascii_render_gate (CGateInv n w c ncf) = + "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +-} + do + string "CGate[" + name <- string_literal + string "]*(" + ws <- commalist int + char ')' + ncf <- nocontrolflag + eof + return (G (CGateInv name (head ws) (tail ws) ncf) []), +{- +ascii_render_gate (CSwap w1 w2 c ncf) = + "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +-} + do + string "CSwap(" + w1 <- int + char ',' + w2 <- int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + return (G (CSwap w1 w2 cs ncf) wts), +{- +ascii_render_gate (QPrep w ncf) = + "QPrep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QPrep(" + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QPrep w ncf) []), +{- +ascii_render_gate (QUnprep w ncf) = + "QUnprep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QUnprep(" + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QUnprep w ncf) []), +{- +ascii_render_gate (QInit b w ncf) = + "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QInit" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QInit val w ncf) []), +{- +ascii_render_gate (CInit b w ncf) = + "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "CInit" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (CInit val w ncf) []), +{- +ascii_render_gate (QTerm b w ncf) = + "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "QTerm" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (QTerm val w ncf) []), +{- +ascii_render_gate (CTerm b w ncf) = + "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +-} + do + string "CTerm" + val_char <- choice [char '0',char '1'] + let val = val_char == '1' + char '(' + w <- int + char ')' + ncf <- nocontrolflag + eof + return (G (CTerm val w ncf) []), +{- +ascii_render_gate (QMeas w) = + "QMeas(" ++ show w ++ ")" +-} + do + string "QMeas(" + w <- int + char ')' + eof + return (G (QMeas w) []), +{- +ascii_render_gate (QDiscard w) = + "QDiscard(" ++ show w ++ ")" +-} + do + string "QDiscard(" + w <- int + char ')' + eof + return (G (QDiscard w) []), +{- +ascii_render_gate (CDiscard w) = + "CDiscard(" ++ show w ++ ")" +-} + do + string "CDiscard(" + w <- int + char ')' + eof + return (G (CDiscard w) []), +{- +ascii_render_gate (DTerm b w) = + "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" +-} + do + string "DTerm" + vc <- char '0' +++ char '1' + let b = case vc of + '0' -> False + '1' -> True + _ -> error "The impossible has happend" + char '(' + w <- int + char ')' + eof + return (G (DTerm b w) []), +{- +ascii_render_gate (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf) = + "Subroutine" ++ show_rep ++ "[" ++ show (string_of_boxid boxid) ++ "]" + ++ optional inv "*" + ++ " " + ++ (string_of_list "(" "," ")" "()" show ws1) + ++ (string_of_list " -> (" "," ")" "()" show ws2) + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf + where + show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")" +-} +-- The parser returns a subroutine with dummy arities, and controllable flag, +-- and repeat flag, as +-- this information is not in a subroutine line in the ASCII output. +-- The information is added when the GatePlus is evaluated, as the first phase of +-- parsing will have collected the information. + do + string "Subroutine" + reps <- option 1 $ do + string "(x" + r <- int + char ')' + return (toInteger r) + char '[' + boxid <- box_id + char ']' + inv <- inversechar + string " (" + ws1 <- commalist int + string ") -> (" + ws2 <- commalist int + char ')' + (cs,wts) <- option ([],[]) controls + ncf <- nocontrolflag + eof + let dummy = error "attempted evaluation of a dummy value" + return (G (Subroutine boxid inv ws1 dummy ws2 dummy cs ncf dummy (RepeatFlag reps)) wts), +{- +ascii_render_gate (Comment s inv ws) = + "Comment[" ++ show s ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws) +-} + do + string "Comment" + skipSpaces + char '[' + comment <- string_literal + char ']' + inv <- inversechar + ls <- labels + eof + return (G (Comment comment inv ls) []) + ] + +-- | The overall parsing function, reading a line of ASCII output, and +-- producing a 'GatePlus'. +parse_ascii_line :: String -> Maybe GatePlus +parse_ascii_line s = + case readP_to_S ascii_line s of + (h, _):_ -> Just h + _ -> Nothing + where + readline = do + skipSpaces + l <- ascii_line + skipSpaces + eof + return l + + diff --git a/dist/build/Quipper/Libraries/Qureg.hs b/dist/build/Quipper/Libraries/Qureg.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Qureg.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Qureg.hs" #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | This module provides a data type of quantum registers, as well as +-- associated types of classical and boolean registers. + +module Quipper.Libraries.Qureg ( + -- * Quantum registers + Qureg, + qureg_of_qulist_te, + qulist_of_qureg_te, + qureg_length, + qinit_register, + qterm_register, + qmeasure_register, + with_ancilla_reg, + with_ancilla_reg_init, + qureg_shape, + + -- * Bit registers + Bitreg, + bitreg_of_bitlist_te, + bitlist_of_bitreg_te, + bitreg_length, + + -- * Boolean registers + Boolreg, + boolreg_of_boollist_te, + boollist_of_boolreg_te, + boolreg_length, + boolreg_of_int_le, + int_of_boolreg_unsigned_le, + + -- * General registers + Register, + (.!) + + ) where + +import Quipper +import Quipper.Internal + +import Quipper.Utils.Auxiliary + +import qualified Data.IntMap as IntMap +import Data.IntMap (IntMap) +import Data.Typeable + +-- ---------------------------------------------------------------------- +-- * Quantum registers + +-- ** General registers + +-- | A register is an array of elements of some type /x/, indexed by +-- natural numbers in the range from 0 to /n/-1, where /n/ is the +-- length of the register. +newtype Register x = Register { unRegister :: IntMap x } + deriving (Typeable, Show) + +-- | @/r/ !.(/i/)@: Return the /i/th element of a register /r/. +(.!) :: Register x -> Int -> x +a .!(i) = (unRegister a) IntMap.! i + +infixl 9 .! -- same precedence as !! + +-- | Convert a list to a register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +register_of_list_te :: [x] -> Register x +register_of_list_te l = Register $ IntMap.fromList (zip [n-1, n-2 .. 0] l) + where n = length l + +-- | Convert a register to a list. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +list_of_register_te :: Register x -> [x] +list_of_register_te r = map (r .!) [n-1, n-2 .. 0] + where n = register_length r + +-- | Return the length of a register. +register_length :: Register x -> Int +register_length = IntMap.size . unRegister + +-- ---------------------------------------------------------------------- +-- ** Qubit registers + +-- | The type of quantum registers. A quantum register is an array of +-- qubits, indexed by natural numbers in the range from 0 to /n/-1, +-- where /n/ is the length of the register. The syntax /a/ .!(/i/) is +-- used to access the /i/th element of the register /a/. +-- +-- The main advantage of a register over a list is constant-time +-- access. The main disadvantage is that registers don't allow easy +-- appending, pattern matching, or recursion. +type Qureg = Register Qubit + +-- | Convert a 'Qulist' to a 'Qureg'. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qureg_of_qulist_te :: Qulist -> Qureg +qureg_of_qulist_te = register_of_list_te + +-- | Convert a 'Qureg' to a 'Qulist'. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qulist_of_qureg_te :: Qureg -> Qulist +qulist_of_qureg_te = list_of_register_te + +-- | Return the length of a 'Qureg'. +qureg_length :: Qureg -> Int +qureg_length = register_length + +-- | Return a piece of shape data to represent an /m/-qubit quantum +-- register. Please note that the data can only be used as shape; it +-- will be undefined at the leaves. +qureg_shape :: Int -> Qureg +qureg_shape m = qureg_of_qulist_te (replicate m qubit) + +-- ---------------------------------------------------------------------- +-- ** Bit registers + +-- | The type of 'Bit' registers. The syntax /a/ .!(/i/) is used to +-- access the /i/th element of the register /a/. +type Bitreg = Register Bit + +-- | Turn a bit vector into a bit register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +bitreg_of_bitlist_te :: Bitlist -> Bitreg +bitreg_of_bitlist_te = register_of_list_te + +-- | Turn a bit register into a bit vector. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +bitlist_of_bitreg_te :: Bitreg -> Bitlist +bitlist_of_bitreg_te = list_of_register_te + +-- | Return the length of a 'Bitreg'. +bitreg_length :: Bitreg -> Int +bitreg_length = register_length + +-- ---------------------------------------------------------------------- +-- ** Boolean registers + +-- | The type of boolean registers. +type Boolreg = Register Bool + +-- | Turn a bool vector into a bool register. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +boolreg_of_boollist_te :: Boollist -> Boolreg +boolreg_of_boollist_te = register_of_list_te + +-- | Turn a bool register into a bool vector. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +boollist_of_boolreg_te :: Boolreg -> Boollist +boollist_of_boolreg_te = list_of_register_te + +-- | Return the length of a 'Boolreg'. +boolreg_length :: Boolreg -> Int +boolreg_length = register_length + +-- ---------------------------------------------------------------------- +-- * Special functions for quantum registers + +-- | Creates a new quantum register, initialized from a list of +-- booleans. The conversion is tail-endian, i.e., /r/.!(0) holds the +-- tail of the list. +qinit_register :: [Bool] -> Circ Qureg +qinit_register bs = do + qs <- qinit bs + return (qureg_of_qulist_te qs) + +-- | Terminates a quantum register, and assert that its state is as +-- specified by the list of booleans. The conversion is tail-endian, +-- i.e., /r/.!(0) holds the tail of the list. +qterm_register :: [Bool] -> Qureg -> Circ () +qterm_register bs r = do + let qs = qulist_of_qureg_te r + qterm bs qs + +-- | Measure a quantum register, yielding a list of 'Bit's. +qmeasure_register :: Qureg -> Circ [Bit] +qmeasure_register r = + measure (qulist_of_qureg_te r) + +-- | Temporarily create a quantum register of size /n/ for use as an +-- ancilla. This can be used to introduce an ancilla with a local scope, like this: +-- +-- > with_ancilla_reg n $ \r -> do { +-- > <<>> +-- > } +with_ancilla_reg :: Int -> (Qureg -> Circ a) -> Circ a +with_ancilla_reg n f = do + let falselist = (take n $ repeat False) + q <- qinit_register falselist + a <- f q + qterm_register falselist q + return a + +-- | Like 'with_ancilla_reg', except also initialize the register as +-- specified by a bit vector. In this case, the argument /n/ is not +-- required, because it equals the length of the bit vector. When the +-- ancilla is terminated at the end of its scope, it is asserted to be +-- in the same state it was prepared in. +with_ancilla_reg_init :: Boollist -> (Qureg -> Circ a) -> Circ a +with_ancilla_reg_init v f = do + q <- qinit_register v + a <- f q + qterm_register v q + return a + +-- ---------------------------------------------------------------------- +-- * Special functions for boolean registers + +-- | @boolreg_of_int m x@: Initialize a bool register directly from an +-- integer /x/, regarded as a binary string of length /m/. The +-- conversion is little-endian, i.e., the register holds the least +-- significant digit at index 0. +boolreg_of_int_le :: Integral a => Int -> a -> Boolreg +boolreg_of_int_le m x = boolreg_of_boollist_te (boollist_of_int_bh m x) + +-- | @int_of_boolreg_unsigned_le m r@: Turn a bool register into an +-- integer, regarded as a binary string. The conversion is +-- little-endian, i.e., the register holds the least significant digit +-- at index 0. The integer is unsigned. +int_of_boolreg_unsigned_le :: Integral a => Boolreg -> a +int_of_boolreg_unsigned_le r = int_of_boollist_unsigned_bh (boollist_of_boolreg_te r) + +-- ---------------------------------------------------------------------- + +-- Make 'Qureg' an instance of 'QData' and 'QCData'. +type instance QCType x y Qureg = Register x +type instance QCType x y Bitreg = Register y +type instance QTypeB Boolreg = Qureg +instance QCData Qureg where + + qcdata_mapM shape f g (Register xs) = do + ys <- intmap_mapM f xs + return (Register ys) + + qcdata_zip shape q c q' c' (Register xs) (Register ys) e = (Register zs) where + zs = intmap_zip_errmsg xs ys (e "register length mismatch") + + qcdata_promote as xs e + | register_length as == register_length xs = as + | otherwise = error (e "register length mismatch") + +instance QCData Bitreg where + + qcdata_mapM shape f g (Register xs) = do + ys <- intmap_mapM g xs + return (Register ys) + + qcdata_zip shape q c q' c' (Register xs) (Register ys) e = (Register zs) where + zs = intmap_zip_errmsg xs ys (e "register length mismatch") + + qcdata_promote as xs e + | register_length as == register_length xs = as + | otherwise = error (e "register length mismatch") + +instance Labelable Qureg String where + label_rec (Register xs) s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] + +instance Labelable Bitreg String where + label_rec (Register xs) s = do + sequence_ [ label_rec x s `indexed` show i | (i,x) <- IntMap.toList xs ] diff --git a/dist/build/Quipper/Libraries/Simulation.hs b/dist/build/Quipper/Libraries/Simulation.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Simulation.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Simulation.hs" #-} +-- | This library provides functions for simulating certain classes of +-- circuits, for testing and debugging purposes. +-- +-- We can efficiently simulate classical (boolean) circuits and +-- Clifford (stabilizer) circuits. We also provide functions for +-- simulating arbitrary quantum circuits; however, the latter is +-- (necessarily) very inefficient. + +module Quipper.Libraries.Simulation ( + -- * Classical simulation + run_classical_generic, + + -- * Stabilizer simulation + run_clifford_generic, + + -- * Quantum simulation + run_generic, + run_generic_io, + sim_amps, + + -- * Special purpose functions + -- ** Simulation with trace + QuantumTrace (..), + run_generic_trace, + run_generic_trace_io, + + -- ** Probability distributions + Vector (..), + ProbabilityDistribution (..), + sim_generic, +) where + +import Quipper.Libraries.Simulation.ClassicalSimulation +import Quipper.Libraries.Simulation.QuantumSimulation +import Quipper.Libraries.Simulation.CliffordSimulation + diff --git a/dist/build/Quipper/Libraries/Simulation/ClassicalSimulation.hs b/dist/build/Quipper/Libraries/Simulation/ClassicalSimulation.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Simulation/ClassicalSimulation.hs @@ -0,0 +1,215 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Simulation/ClassicalSimulation.hs" #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides functions for simulating certain classes of +-- circuits, for testing and debugging purposes. At the moment, the +-- only type of simulation we provide is boolean simulation. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.ClassicalSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, Simulation.hs uses low-level interfaces. It should be +-- re-implemented using only high-level interfaces, or in some cases, +-- more stuff should be exported from Quipper.hs. +import Quipper.Internal.Transformer (bind_list, bindings_empty, unbind_list, Bindings, transform_bcircuit_id) +import Quipper.Internal.Circuit (RepeatFlag(..), TypedSubroutine(..), OCircuit(..), reverse_ocircuit, ControllableFlag(..), BCircuit) +import Quipper.Internal.Generic (qc_bind, qc_unbind, encapsulate_generic) + +import Quipper.Utils.Auxiliary + +import Data.List +import qualified Data.Map as Map + +-- ====================================================================== +-- * Simulation of classical circuits + +-- | Auxiliary function: determine whether a \"control\" is true of false. +controls :: [Signed (B_Endpoint Bool Bool)] -> Bool +controls [] = True +controls ((Signed (Endpoint_Qubit c) b):t) = (c == b) && controls t +controls ((Signed (Endpoint_Bit c) b):t) = (c == b) && controls t + +-- | Auxiliary function: compute the boolean function corresponding to +-- a 'Quipper.Internal.Circuit.CGate' of the given name. +simulate_cgate :: String -> [Bool] -> Bool +simulate_cgate "if" [a,b,c] = if a then b else c +simulate_cgate "if" list = error ("simulate_cgate: \"if\" needs 3 arguments, not " ++ show (length list)) +simulate_cgate "and" list = and list +simulate_cgate "or" list = or list +simulate_cgate "xor" list = foldl' bool_xor False list +simulate_cgate "eq" [a,b] = (a == b) +simulate_cgate "eq" list = error ("simulate_cgate: \"eq\" needs 2 arguments, not " ++ show (length list)) +simulate_cgate "not" [a] = not a +simulate_cgate "not" list = error ("simulate_cgate: \"not\" needs 1 argument, not " ++ show (length list)) +simulate_cgate name list = error ("simulate_cgate: gate \"" ++ name ++ "\" not known") + + +-- | A "Quipper.Internal.Transformer" mapping each gate to the corresponding boolean +-- function. This will fail with an error for gates that don't act +-- within the computational basis, or if some assertion is not +-- met. Some gates are not yet implemented. + +simulate_classical :: Transformer Id Bool Bool + +-- Translation of classical gates: +simulate_classical (T_CNot ncf f) = f $ + \q c -> Id (if controls c then not q else q, c) +simulate_classical (T_CSwap ncf f) = f $ + \w v c -> Id (if controls c then (v,w,c) else (w,v,c)) +simulate_classical (T_CInit b ncf f) = f $ + Id b +simulate_classical (T_CTerm b ncf f) = f $ + \q -> Id (if b==q then () else error "simulate_classical: CTerm assertion not met") +simulate_classical (T_CDiscard f) = f $ + \b -> Id () +simulate_classical (T_DTerm b f) = f $ + \b -> Id () +simulate_classical (T_CGate name ncf f) = f $ + \list -> Id (simulate_cgate name list, list) +simulate_classical (T_CGateInv name ncf f) = f $ + \q list -> if q == simulate_cgate name list + then Id list + else error ("simulate_classical: CGateInv failed assertion " ++ show q ++ " == " ++ name ++ show list) + +-- Translation of quantum gates: +simulate_classical (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] c -> if controls c then Id([not q], [], c) else Id([q], [], c) +simulate_classical (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] c -> Id (if controls c then map not qs else qs, [], c) +simulate_classical (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w,v] [] c -> Id (if controls c then ([v,w], [], c) else ([w,v], [] ,c)) +simulate_classical g@(T_QGate "H" 1 0 _ _ _) = + error ("simulate_classical: gate not classical: " ++ show g) +simulate_classical g@(T_QGate "W" 2 0 _ _ _) = + error ("simulate_classical: gate not classical: " ++ show g) +simulate_classical g@(T_QGate name _ _ inv ncf f) = f $ + \qs gctls c -> case (name, inv, qs, gctls) of + ("X", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + ("Y", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + ("Z", _, [q], []) -> Id([q], [], c) + ("S", _, [q], []) -> Id([q], [], c) + ("T", _, [q], []) -> Id([q], [], c) + ("omega", _, [q], []) -> Id([q], [], c) + ("iX", _, [q], []) -> + if controls c then Id([not q], [], c) else Id([q], [], c) + _ -> error ("simulate_classical: unimplemented gate: " ++ show g) +simulate_classical g@(T_QRot name _ _ inv t ncf f) = f $ + \qs gctls c -> case (name, inv, qs, gctls) of + ("R(2pi/%)", _, [q], []) -> Id([q], [], c) + ("exp(-i%Z)", _, [q], []) -> Id([q], [], c) + _ -> error ("simulate_classical: unimplemented gate: " ++ show g) +simulate_classical g@(T_GPhase t ncf f) = f $ + \q c -> Id c +simulate_classical (T_QInit b ncf f) = f $ + Id b +simulate_classical (T_QTerm b ncf f) = f $ + \q -> if b==q then Id() else error "simulate_classical: QTerm assertion not met" +simulate_classical (T_QDiscard f) = f $ + \b -> Id() +simulate_classical (T_Comment s inv f) = f $ + \b -> Id() + +-- Preparation, unpreparation, and measurement: +simulate_classical g@(T_QPrep ncf f) = f $ + \w -> Id w +simulate_classical g@(T_QUnprep ncf f) = f $ + \w -> Id w +simulate_classical g@(T_QMeas f) = f $ + \w -> Id w + +-- Subroutines: +simulate_classical g@(T_Subroutine sub inv ncf scf ws_pat a1_pat vs_pat a2_pat (RepeatFlag repeat) f) = f $ + \namespace in_values c -> Id $ + case Map.lookup sub namespace of + Just (TypedSubroutine sub_ocirc _ _ _) -> + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + in_bindings = bind_list in_wires in_values bindings_empty + out_bindings = + if (case scf of {AllCtl -> True; OnlyClassicalCtl -> True; NoCtl -> False}) + then if controls c then foldl' (\in_b _ -> run_classical (sub_circ, namespace) in_b) in_bindings [1..repeat] else in_bindings + else if length c == 0 + then foldl' (\in_b _ -> run_classical (sub_circ, namespace) in_b) in_bindings [1..repeat] + else error $ "simulate_classical: attempt to control non-controllable subroutine " ++ show sub + in (unbind_list out_bindings out_wires, c) + Nothing -> error $ "simulate_classical: subroutine " ++ show sub ++ " not found" + +-- If adding gates: remember to list any unimplemented gates +-- explicitly, so that the type-checker can warn about new gates that +-- must be added to the list. + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. This function makes use of the concept of a +-- /valuation/. A valuation is a partial map from circuit wires to +-- booleans, represented by the type @'Bindings' Bool@. Given a +-- circuit and a valuation for its inputs, the function +-- 'run_classical' produces a valuation for its outputs. +-- +-- The simulation will fail with an error if the circuit contains a +-- gate not acting within the computational basis, or if some +-- assertion is not met. Not all gates are currently +-- implemented. Subroutines are not currently implemented. +-- +run_classical :: BCircuit -> Bindings Bool Bool -> Bindings Bool Bool +run_classical = transform_bcircuit_id simulate_classical + +-- ====================================================================== +-- * Generic simulation + +-- | Like 'run_classical_unary', but also takes a stub error message. +run_classical_errmsg :: (QCData qa, QCData qb) => ErrMsg -> (qa -> Circ qb) -> BType qa -> BType qb +run_classical_errmsg e (f :: qa -> Circ qb) input = output where + shape = qcdata_makeshape (dummy :: qa) (dummy :: Bool) (dummy :: Bool) input + (qa, circuit, qb) = encapsulate_generic e f shape + valuation_in = qc_bind qa input + valuation_out = run_classical circuit valuation_in + output = qc_unbind valuation_out qb + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. Input a classical circuit, and output the corresponding +-- boolean function. This will fail with an error if the circuit +-- contains a gate not acting within the computational basis, or if +-- some assertion is not met. +run_classical_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> BType qb +run_classical_unary = run_classical_errmsg errmsg + where + errmsg x = "run_classical_unary: operation not currently permitted by simulator: " ++ x + +-- | Boolean simulation of a circuit, for testing and debugging +-- purposes. Input a classical circuit, and output the corresponding +-- boolean function. This will fail with an error if the circuit +-- contains a gate not acting within the computational basis, or if +-- some assertion is not met. +-- +-- Unlike 'run_classical_unary', this can be applied to a +-- circuit-generating function in curried form with /n/ arguments, for +-- any /n/ ≥ 0. The resulting boolean function then will also have /n/ arguments. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > run_classical_generic :: (QCData qa) => Circ qa -> BType qa +-- > run_classical_generic :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> BType qb +-- > run_classical_generic :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> BType qa -> BType qb -> BType qc +-- +-- and so forth. + +run_classical_generic :: (QCData qa, QCData qb, QCurry qfun qa qb, Curry fun (BType qa) (BType qb)) => qfun -> fun +run_classical_generic f = g where + f1 = quncurry f + g1 = run_classical_errmsg errmsg f1 + g = mcurry g1 + errmsg x = "run_classical_generic: operation not currently permitted by simulator: " ++ x + diff --git a/dist/build/Quipper/Libraries/Simulation/CliffordSimulation.hs b/dist/build/Quipper/Libraries/Simulation/CliffordSimulation.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Simulation/CliffordSimulation.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Simulation/CliffordSimulation.hs" #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides a Quipper interface to the efficient +-- simulation of Clifford group circuits, using the Stabilizer +-- formalism. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.CliffordSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, CliffordSimulation.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Generic (encapsulate_generic, qc_unbind) +import Quipper.Internal.Transformer (transform_bcircuit_rec, bindings_empty) + +import Quipper.Libraries.Simulation.QuantumSimulation (gateQinv, rotQinv) +import Quipper.Libraries.Simulation.ClassicalSimulation (simulate_cgate) + +import Quipper.Utils.Auxiliary +import qualified Quipper.Utils.Stabilizers.Clifford as C + +import Control.Monad.State (StateT) +import Data.Either + +-- ---------------------------------------------------------------------- +-- * The stabilizer transformer + +-- | The stabilizer transformer. Used to transform a Quipper circuit, +-- made up of Clifford group operators, directly into the 'C.CliffordCirc' +-- monad (where 'C.CliffordCirc' is a type-synonym for StateT Tableau IO). +-- Note that this transformer only deals with 1 and 2-qubit operators. +stabilizer_transformer :: Transformer (StateT C.Tableau IO) C.Qubit Bool +stabilizer_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + -- X and controlled-X are already provided by C.CliffordCirc + \[qt] [] c -> case control_info c of + None -> do + C.gate_X qt + return ([qt], [], c) + Classical b -> do + if b then C.gate_X qt else return () + return ([qt], [], c) + OneQuantum (Signed qc positive) b -> do + if not positive then C.gate_X qc else return () + if b then C.controlled_X qc qt else return () + if not positive then C.gate_X qc else return () + return ([qt], [], c) + _ -> error "stabilizer_transformer: Toffoli gate not available" +stabilizer_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + -- X and controlled-X are already provided by C.CliffordCirc + -- and can be mapped over a list of qubits + \ws [] c -> case control_info c of + None -> do + mapM_ C.gate_X ws + return (ws, [], c) + Classical b -> do + if b then mapM_ C.gate_X ws else return () + return (ws, [], c) + OneQuantum (Signed qc positive) b -> do + if not positive then C.gate_X qc else return () + if b then mapM_ (C.controlled_X qc) ws else return () + if not positive then C.gate_X qc else return () + return (ws, [], c) + _ -> error "stabilizer_transformer: (Multi) Toffoli gate not available" +stabilizer_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + -- Hadamard is already provided by C.CliffordCirc + \[qt] [] c -> case control_info c of + None -> do + C.gate_H qt + return ([qt], [], c) + Classical b -> do + if b then C.gate_H qt else return () + return ([qt], [], c) + -- TODO: ??? + _ -> error "stabilizer_transformer: controlled-Hadamard currently not supported" +stabilizer_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + -- (classically-controlled) swap is already provided by C.CliffordCirc + \[w, v] [] c -> case control_info c of + None -> do + C.swap w v + return ([w, v], [], []) + Classical b -> do + if b then C.swap w v else return () + return ([w, v], [], []) + _ -> error "stabilizer_transformer: quantum controlled-swap not available" +stabilizer_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + -- TODO: ??? + \[w, v] [] c -> error "stabilizer_transformer: W currently not supported" +stabilizer_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> + case vs of + [] -> + case ws of + [qt] -> case control_info c of + None -> do + C.gate_Unitary u1 qt + return ([qt], vs, c) + Classical b -> do + if b then C.gate_Unitary u1 qt else return () + return ([qt], vs, c) + OneQuantum (Signed qc positive) b -> do + if b then C.gate_Unitary2 u2 qc qt else return () + return ([qt], vs, c) + _ -> error "stabilizer_transformer: Multiple quantum controls not supported" + where u1 = case name of + "X" -> C.x + "Y" -> C.y + "Z" -> C.z + "S" -> C.s + "E" -> C.e + name -> C.from_matrix (gateQinv name inv) + u2 = case name of + "X" -> C.cnot + "Z" -> C.cz + name -> C.from_matrix_controlled (gateQinv name inv) + _ -> error "stabilizer_transformer: Named gates on multiple Qubits not available" + _ -> error "stabilizer_transformer: generalised controls not currently supported" +stabilizer_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> error "stabilizer_transformer: QRot not currently supported" --return (ws, vs, c) +stabilizer_transformer (T_GPhase t ncf f) = f $ + -- TODO: ??? + \qs c -> error "stabilizer_transformer: GPhase currently not supported" +stabilizer_transformer (T_CNot ncf f) = f $ + -- we can do a classical not depending on the controls + \q c -> case control_info c of + None -> return (not q,c) + Classical b -> if b then return (not q,c) else return (q,c) + _ -> error "stabilizer_transformer: Quantum control on classical gate" +stabilizer_transformer (T_CGate name ncf f) = f $ + -- we can reuse the classical simulator cgate implementation + \ws -> return (simulate_cgate name ws,ws) +stabilizer_transformer (T_CGateInv name ncf f) = f $ + -- we can check that the inverse is correct using the classical simulator cgate implementation + \v ws -> if (simulate_cgate name ws == v) then return ws else error "stabilizer_transformer: CGateInv not inverse" +stabilizer_transformer (T_CSwap ncf f) = f $ + -- we can do a classical swap depending on the controls + \w v c -> case control_info c of + None -> return (w,v,c) + Classical b -> if b then return (v,w,c) else return (w,v,c) + _ -> error "stabilizer_transformer: Quantum control on classical gate" +stabilizer_transformer (T_QPrep ncf f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: QPrep currently not supported" +stabilizer_transformer (T_QUnprep ncf f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: QUnprep currently not supported" +stabilizer_transformer (T_QInit b ncf f) = f $ + -- initialization is already provided by C.CliffordCirc + C.init_qubit b +stabilizer_transformer (T_CInit b ncf f) = f $ + -- initialisation of a boolean value + return b +stabilizer_transformer (T_QTerm b ncf f) = f $ + -- we can check termination conditions at runtime, using measurement + \w -> do + res <- C.measure_qubit w + if res == b then return () else error "stabilizer_transformer: QTerm condition failed" +stabilizer_transformer (T_CTerm b ncf f) = f $ + -- we can check termination conditions at runtime + \w -> if w == b then return () else error "stabilizer_transformer: CTerm condition failed" +stabilizer_transformer (T_QMeas f) = f $ + -- measurement is already provided by C.CliffordCirc + \w -> C.measure_qubit w +stabilizer_transformer (T_QDiscard f) = f $ + -- we can ignore discards + \w -> return () +stabilizer_transformer (T_CDiscard f) = f $ + -- we can ignore discards + \w -> return () +stabilizer_transformer (T_DTerm b f) = f $ + -- TODO: ?? + \w -> error "stabilizer_transformer: DTerm currently not supported" --return () +stabilizer_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + -- TODO: we can "open" subroutines + \namespace ws c -> error "stabilizer_transformer: Subroutine currently not supported" --return (ws,c) +stabilizer_transformer (T_Comment s inv f) = f $ + -- we can ignore comments + \ws -> return () + +-- | A datatype to represent controls that we can simulate +data ControlInfo = None | Classical Bool | OneQuantum (Signed C.Qubit) Bool | ManyQuantum + +-- | Construct an element of ControlInfo from a list of Controls. +control_info :: Ctrls C.Qubit Bool -> ControlInfo +control_info cs = case split_controls cs of + ([],[]) -> None + ([],cs) -> Classical (all_equal cs) + ([q],cs) -> OneQuantum q (all_equal cs) + _ -> ManyQuantum + where + split_controls :: Ctrls a b -> ([Signed a],[Signed b]) + split_controls cs = partitionEithers (map either_control cs) + either_control :: Signed (B_Endpoint a b) -> Either (Signed a) (Signed b) + either_control (Signed (Endpoint_Qubit a) value) = Left (Signed a value) + either_control (Signed (Endpoint_Bit b) value) = Right (Signed b value) + all_equal :: [Signed Bool] -> Bool + all_equal cs = and (map (\(Signed b val) -> b == val) cs) + +-- ---------------------------------------------------------------------- +-- * High-level functions + +-- | Use the 'stabilizer_transformer' to transform a Quipper circuit +-- into a 'C.CliffordCirc', ready for simulation. +toCliffordCirc :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> C.CliffordCirc (BType qb)) +toCliffordCirc (f :: qa -> Circ qb) input = do + let ((), circuit, cb) = encapsulate_generic errmsg (\() -> qc_init input >>= \qi -> f qi >>= \qi' -> qc_measure qi') () + out_bind' <- transform_bcircuit_rec stabilizer_transformer circuit bindings_empty + let out_bind = out_bind' + let output = qc_unbind out_bind cb + return output + where + errmsg x = ("simulate: " ++ x) + +-- | Return the tableau resulting from simulating the given Quipper +-- circuit. +eval_unary :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> IO C.Tableau) +eval_unary circ input = C.eval (toCliffordCirc circ input) + +-- | Efficiently simulate a unary Quipper circuit that consists +-- entirely of Clifford group operators, using the stabilizer +-- formalism. +run_clifford_unary :: (QCData qa, QCDataPlus qb) => (qa -> Circ qb) -> (BType qa -> IO (BType qb)) +run_clifford_unary circ input = C.sim (toCliffordCirc circ input) + +-- | Efficiently simulate a Quipper circuit that consists entirely of +-- Clifford group operators, using the stabilizer formalism. +-- +-- Inputs a quantum circuit, and outputs a corresponding probabilistic +-- boolean function. The inputs to the quantum circuit are initialized +-- according to the given boolean arguments. The outputs of the +-- quantum circuit are measured, and the boolean measurement outcomes +-- are returned. Because the measurement outcomes are probabilistic, +-- this function takes place in the 'IO' monad. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > run_clifford_generic :: (QCData qa) => Circ qa -> IO (BType qa) +-- > run_clifford_generic :: (QCData qa, QCData qb) => (qa -> Circ qb) -> BType qa -> IO (BType qb) +-- > run_clifford_generic :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> BType qa -> BType qb -> IO (BType qc) +-- +-- and so forth. +run_clifford_generic :: (QCData qa, QCDataPlus qb, QCurry qfun qa qb, Curry qfun' (BType qa) (IO (BType qb))) => qfun -> qfun' +run_clifford_generic f = g where + f1 = quncurry f + g1 = run_clifford_unary f1 + g = mcurry g1 diff --git a/dist/build/Quipper/Libraries/Simulation/QuantumSimulation.hs b/dist/build/Quipper/Libraries/Simulation/QuantumSimulation.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Simulation/QuantumSimulation.hs @@ -0,0 +1,854 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Simulation/QuantumSimulation.hs" #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} + +-- | This module provides functions for simulating circuits, +-- for testing and debugging purposes. +-- It borrows ideas from the implementation of the Quantum IO Monad. +-- +-- This module provides the internal implementation of the library, +-- and can be imported by other libraries. The public interface to +-- simulation is "Quipper.Libraries.Simulation". + +module Quipper.Libraries.Simulation.QuantumSimulation where + +import Quipper +import Quipper.Internal + +-- The following is a bunch of stuff we need to import because, +-- temporarily, QuantumSimulation.hs uses low-level interfaces. It +-- should be re-implemented using only high-level interfaces, or in +-- some cases, more stuff should be exported from Quipper.hs. +import Quipper.Internal.Circuit +import Quipper.Internal.Transformer +import Quipper.Internal.Monad (qubit_of_wire) +import Quipper.Internal.Generic (encapsulate_dynamic, qc_unbind) + +import Quipper.Utils.Auxiliary + +-- we use the state monad to hold our \"quantum\" state +import Control.Monad.State +-- we use complex numbers as our probability amplitudes +import Quantum.Synthesis.Ring (Cplx (..), i) +-- we use a random number generator to simulate \"quantum randomness\" +import System.Random hiding (split) +-- we store \"basis\" states as a map, +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.List (partition) + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +import qualified Debug.Trace -- used in tracing the simulation of quipper computations + +-- | We define our own trace function that only calls trace if the boolean +-- argument is true. +trace :: Bool -> String -> a -> a +trace False _ a = a +trace True message a = Debug.Trace.trace message a + +-- ====================================================================== +-- * Simulation as a Transformer + +-- $ The quantum simulator takes a Quipper circuit producing function, +-- and uses a transformer to simulate the resulting circuit, one gate at a time. +-- This allows the simulation to progress in a lazy manner, allowing dynamic +-- lifting results to be passed back to the circuit producing function as +-- and when they are required (to generate further gates in the circuit). + +-- $ The implementation of the quantum simulator makes use of a /State/ monad +-- to carry an underlying quantum state throughout the computation. This /State/ +-- is updated by each quantum operation within the circuit. A quantum +-- state is a vector of basis states, along with complex amplitudes. + +-- | Gates that act on a single qubit can be defined by essentially a 2-by-2 matrix. +-- A GateR is written by rows, such that a matrix: +-- +-- \[image GateR.png] +-- +-- would be written as (m00,m01,m10,m11). +type GateR r = (Cplx r,Cplx r, Cplx r, Cplx r) + +-- | Scalar multiplication of a 2-by-2 matrix by a given scalar. +scale :: (Floating r) => Cplx r -> GateR r -> GateR r +scale e (a,b,c,d) = (e*a,e*b,e*c,e*d) + +-- | The inverse of a 'GateR' is its conjugate transpose. +reverseR :: (Floating r) => GateR r -> GateR r +reverseR (m00,m01,m10,m11) = (conjugate m00, conjugate m10, conjugate m01, conjugate m11) + where + conjugate (Cplx a b) = Cplx a (-b) + +-- | A simple pattern matching function that gives each \"gate name\" +-- a /GateR/ representation. Adding (single qubit) quantum gates to +-- this function will give them an implementation in the +-- simulator. Any single qubit named quantum gate that needs to be +-- simulated must have a clause in this function, along with a given +-- /GateR/ that is its matrix representation. Note that unitarity is +-- not enforced, so defined gates must be checked manually to be +-- unitary operators. +-- +-- > Example Gates: +-- > gateQ "x" = (0,1,1,0) +-- > gateQ "hadamard" = (h, h, h,-h) where h = (1/sqrt 2) +gateQ :: (Floating r) => String -> GateR r +gateQ "x" = (0,1,1,0) +gateQ "hadamard" = (h, h, h,-h) where h = Cplx (1/sqrt 2) 0 +gateQ "X" = (0,1,1,0) +gateQ "Y" = (0,-i,i,0) +gateQ "Z" = (1,0,0,-1) +gateQ "S" = (1,0,0,i) +gateQ "E" = ((-1+i)/2, (1+i)/2, (-1+i)/2, (-1-i)/2) +gateQ "YY" = (h,i*h,i*h,h) where h = Cplx (1/sqrt 2) 0 +gateQ "T" = (1,0,0,omega) where omega = (Cplx (1 / sqrt 2) (1 / sqrt 2)) +gateQ "V" = scale 0.5 (a,b,b,a) where a = Cplx 1 (-1) + b = Cplx 1 1 +gateQ "omega" = (omega,0,0,omega) where omega = (Cplx (1 / sqrt 2) (1 / sqrt 2)) +gateQ "iX" = (0,i,i,0) +gateQ name = error ("quantum gate: " ++ name ++ " not implemented") + +-- | Like 'gateQ', but also conditionally invert the gate depending +-- on InverseFlag. +gateQinv :: (Floating r) => String -> InverseFlag -> GateR r +gateQinv name False = gateQ name +gateQinv name True = reverseR (gateQ name) + +-- | The exponential function for 'Cplx' numbers. +expC :: (Floating r) => Cplx r -> Cplx r +expC (Cplx a b) = Cplx (exp a * cos b) (exp a * sin b) + +-- | The constant π, as a complex number. +piC :: (Floating r) => Cplx r +piC = Cplx pi 0 + +-- | Like 'gateQ', but takes the name of a rotation and a real parameter. +rotQ :: (Floating r) => String -> Timestep -> GateR r +rotQ "exp(-i%Z)" theta = expZtR t + where t = fromRational (toRational theta) +rotQ "exp(% pi i)" theta = gPhase t + where t = fromRational (toRational theta) +rotQ "R(2pi/%)" theta = (1,0,0,expC (2*piC*i/t)) + where t = fromRational (toRational theta) +rotQ "T(%)" theta = (1,0,0,expC (-i*t)) + where t = fromRational (toRational theta) +rotQ "G(%)" theta = (expC (-i*t),0,0,expC (-i*t)) + where t = fromRational (toRational theta) +rotQ "Rz(%)" theta = (expC (-i*t/2),0,0,expC (i*t/2)) + where t = fromRational (toRational theta) +rotQ name theta = error ("quantum rotation: " ++ name ++ " not implemented") + +-- | Like 'rotQ', but also conditionally invert the gate depending on +-- InverseFlag. +rotQinv :: (Floating r) => String -> InverseFlag -> Timestep -> GateR r +rotQinv name False theta = rotQ name theta +rotQinv name True theta = reverseR (rotQ name theta) + +-- | Return the matrix for the 'expZt' gate. +expZtR :: (Floating r) => r -> GateR r +expZtR t = (expC (Cplx 0 (-t)),0,0,expC (Cplx 0 t)) + +-- | Return the matrix for the 'GPhase' gate. +gPhase :: (Floating r) => r -> GateR r +gPhase t = (expC (Cplx 0 (t * pi)),0,0,expC (Cplx 0 (t * pi))) + +-- | Translate a classical gate name into a boolean function. +-- Adding classical gates to this function will give them an implementation in +-- the simulator. +-- +-- > Example Gate: +-- > gateC "if" [a,b,c] = if a then b else c +gateC :: String -> ([Bool] -> Bool) +gateC "if" [a,b,c] = if a then b else c +gateC name inputs = error ("classical gate: " ++ name ++ ", not implemented (at least for inputs: " ++ show inputs ++ " )") + +-- | The type of vectors with scalars in /n/ over the basis /a/. A +-- vector is simply a list of pairs. +data Vector n a = Vector [(a,n)] + +-- | An amplitude distribution gives each classical basis state an amplitude. +type Amplitudes r = Vector (Cplx r) (Map Qubit Bool) + +-- | A probability distribution gives each element a probability. +type ProbabilityDistribution r a = Vector r a + +-- | A QuantumTrace is essentially a probability distribution for the current state +-- of the qubits that have been traced. We can represent this using a Vector. The +-- list of Booleans is in the same order as the list of Qubits that was being +-- traced. +type QuantumTrace r = ProbabilityDistribution r [Bool] + +-- | Normalizing is used to make sure the probabilities add up to 1. +normalize :: (Floating r) => QuantumTrace r -> QuantumTrace r +normalize (Vector xs) = Vector xs' + where + p' = Prelude.foldr (\(_,p) accum -> accum + p) 0.0 xs + xs' = map (\(bs,p) -> (bs,p / p')) xs + +-- | A 'QuantumState' is the data structure containing the state that we update +-- throughout the simulation. We need to keep track of the next available wire, +-- and a quantum state in the form of a distribution of basis states. We also +-- track a list of quantum traces, so that we have a \"tracing\" mechanism during +-- the execution of quantum circuits. +data QuantumState r = QState { + next_wire :: Wire, + quantum_state :: Amplitudes r, + traces :: [QuantumTrace r], -- this will be stored in the reverse order in which + -- the traces occured in the circuit. + namespace :: Namespace, -- we need a namespace to keep track of subroutines + trace_flag :: Bool -- whether or not we trace comments during the simulation + } + +-- | When we start a simulation, we need an empty starting state. +empty_quantum_state :: (Floating r) => Bool -> r -> QuantumState r +empty_quantum_state tf _ = QState { next_wire = 0, quantum_state = Vector [(Map.empty,1)], traces = [], namespace = namespace_empty, trace_flag = tf} + +-- | It doesn't make sense having a quantum control on a classical gate, so +-- we can throw an error if that is the case, and just collect the boolean +-- result otherwise. +classical_control :: Signed (B_Endpoint Qubit Bool) -> Bool +classical_control (Signed bep val) = case bep of + (Endpoint_Bit val') -> val == val' + (Endpoint_Qubit _) -> error "CNot: Quantum Control on Classical Gate" + +-- | Map the 'classical_control' function to all the controls, and take the +-- 'and' of the result +classical_controls :: Ctrls Qubit Bool -> Bool +classical_controls cs = and (map classical_control cs) + +-- | When we want a quantum control, we will be working with one \"basis state\" at +-- a time, and can look up the qubit's value in that basis state to see whether +-- the control firs. +qc_control :: Map Qubit Bool -> Signed (B_Endpoint Qubit Bool) -> Bool +qc_control mqb (Signed bep val) = case bep of + (Endpoint_Bit val') -> val == val' + (Endpoint_Qubit q) -> val == val' where val' = mqb Map.! q + +-- | Map the 'qc_control' function to all the controls (under the given basis +-- state), and take the 'and' of the result. +qc_controls :: Map Qubit Bool -> Ctrls Qubit Bool -> Bool +qc_controls mqb cs = and (map (qc_control mqb) cs) + +-- | We can calculate the magnitude of a complex number +magnitude :: (Floating r) => Cplx r -> r +magnitude (Cplx a b) = sqrt (a^2 + b^2) + +-- | The 'split' function splits a Amplitude distribution, by +-- partitioning it around the state of the given qubit within each basis state. It +-- also returns the probability of the qubit being True within the given +-- Amplitudes. This function is used when we want to measure a qubit. +split :: (Floating r, Eq r, Ord r) => Amplitudes r -> Qubit -> (r,Amplitudes r,Amplitudes r) +split (Vector pas) q = if p < 0 || p > 1 + then error "p < 0 or > 1" + else (p,Vector ift,Vector iff) + where + amp x = foldr (\(_,pa) p -> p + ((magnitude pa)*(magnitude pa))) 0 x + apas = amp pas + (ift,iff) = partition (\(mqb,_) -> (mqb Map.! q)) pas + p = if apas == 0 then 0 else (amp ift)/apas + +-- | A PMonad is a Monad enriched with a 'merge' function that takes a probability, +-- and two results, and returns a merged version of these results under the given +-- monad. This idea is taken directly from QIO. +class (Floating r, Monad m) => PMonad r m where + merge :: r -> a -> a -> m a + +-- | We can merge two measurement outcomes, and explicitly keep the first outcome +-- as the True result, and the second as the False result. +merge_with_result :: PMonad r m => r -> a -> a -> m (Bool,a) +merge_with_result p ift iff = merge p (True,ift) (False,iff) + +-- | IO forms a PMonad, where results are merged by choosing one probabilistically +-- using a random number. +instance (Floating r, Random r, Ord r) => PMonad r IO where + merge p ift iff = do + pp <- randomRIO (0,1) + let res = if p > pp then ift else iff + return res + +-- | A State Monad holding a 'RandomGen' forms a 'PMonad', where results are +-- merged by choosing one probabilistically using a random number from the +-- 'RandomGen'. +instance (Floating r, Random r, Ord r, RandomGen g) => PMonad r (State g) where + merge p ift iff = do + gen <- get + let (pp,gen') = randomR (0,1) gen + put gen' + let res = if p > pp then ift else iff + return res + +-- | Any numeric indexed vector forms a 'Monad'. +instance (Num n) => Monad (Vector n) where + return a = Vector [(a,1)] + (Vector ps) >>= f = Vector [(b,i*j) | (a,i) <- ps, (b,j) <- removeVector (f a)] where removeVector (Vector as) = as + +instance (Num n) => Applicative (Vector n) where + pure = return + (<*>) = ap + +instance (Num n) => Functor (Vector n) where + fmap = liftM + +-- | We can show certain vectors, ignoring any 0 probabilities, and +-- combining equal terms. +instance (Show a,Eq a,Num n,Eq n,Show n) => Show (Vector n a) where + show (Vector ps) = show (combine (filter (\ (a,p) -> p /= 0) ps) []) + where + combine [] as = as + combine (x:xs) as = combine xs (combine' x as) + combine' (a,p) [] = [(a,p)] + combine' (a,p) ((a',p'):xs) = if a == a' then (a,p+p'):xs else (a',p'):(combine' (a,p) xs) + +-- | 'ProbabilityDistribution' forms a 'PMonad' such that probabilistic results are +-- \"merged\" by extending the probability distribution by the possible results. +instance (Floating r, Eq r) => PMonad r (Vector r) where + merge 1 ift iff = Vector [(ift,1)] + merge 0 ift iff = Vector [(iff,1)] + merge p ift iff = Vector [(ift,p),(iff,1-p)] + +-- | The 'get_trace' function returns a probability distribution of +-- the state of a list of qubits within a given amplitude +-- distribution. +get_trace :: (Floating r) => [Qubit] -> Amplitudes r -> QuantumTrace r +get_trace qs (Vector amps) = Vector ps + where + ps = map (tracing qs) amps + tracing qs (mqb,cd) = (map (\q -> mqb Map.! q) qs,(magnitude cd)*(magnitude cd)) + +-- | Add an amplitude to an amplitude distribution, combining (adding) the amplitudes for equal states in the distribution. +add :: (Floating r) => ((Map Qubit Bool),Cplx r) -> Amplitudes r -> Amplitudes r +add (a,x) (Vector axs) = Vector (add' axs) + where add' [] = [(a,x)] + add' ((by @ (b,y)):bys) | a == b = (b,x+y):bys + | otherwise = by:(add' bys) + +-- | The apply' function is used to apply a function on \"basis states\" to an +-- entire amplitude distribution. +apply :: (Floating r, Eq r) => (Map Qubit Bool -> Amplitudes r) -> Amplitudes r -> Amplitudes r +apply f (Vector []) = Vector [] +apply f (Vector ((a,0):[])) = Vector [] +apply f (Vector ((a,x):[])) = Vector (map (\(b,k) -> (b,x*k)) (fa)) where Vector fa = f a +apply f (Vector ((a,0):vas)) = apply f (Vector vas) +apply f (Vector ((a,x):vas)) = foldr add (apply f (Vector vas)) (map (\(b,k) -> (b,x*k)) (fa)) where Vector fa = f a + +-- | Lift a function that returns a single basis state, to a function that +-- returns an amplitude distribution (containing a singleton). +vector :: (Floating r) => (Map Qubit Bool -> Map Qubit Bool) -> Map Qubit Bool -> Amplitudes r +vector f a = Vector [(f a,1)] + +-- | apply the given function only if the controls fire. +if_controls :: (Floating r) => Ctrls Qubit Bool -> (Map Qubit Bool -> Amplitudes r) -> Map Qubit Bool -> Amplitudes r +if_controls c f mqb = if (qc_controls mqb c) then f mqb else Vector [(mqb,1)] + +-- | 'performGateQ' defines how a single qubit gate is applied to a +-- quantum state. The application of a /GateR/ to a qubit in a single +-- basis state can split the state into a pair of basis states with +-- corresponding amplitudes. +performGateQ :: (Floating r) => GateR r -> Qubit -> Map Qubit Bool -> Amplitudes r +performGateQ (m00,m01,m10,m11) q mqb = if (mqb Map.! q) then (Vector [(Map.insert q False mqb,m01),(mqb,m11)]) + else (Vector [(mqb,m00),(Map.insert q True mqb,m10)]) + +-- | The 'simulation_transformer' is the actual transformer that does the +-- simulation. The type of the 'simulation_transformer' shows that Qubits are +-- kept as qubits, but Bits are turned into Boolean values, i.e., the results of +-- the computation. We use a StateT Monad, acting over the IO Monad, to store a +-- QuantumState throughout the simulation. This means we carry a state, but also +-- have access to the IO Monad's random number generator (for probabilistic +-- measurement). +simulation_transformer :: (PMonad r m, Ord r) => Transformer (StateT (QuantumState r) m) Qubit Bool +-- Translation of classical gates: +simulation_transformer (T_CNot ncf f) = f $ + \val c -> do + let ctrl = classical_controls c + let val' = if ctrl then not val else val + return (val',c) +simulation_transformer (T_CInit val ncf f) = f $ + return val +simulation_transformer (T_CTerm b ncf f) = f $ + \val -> if val == b then return () else error "CTerm: Assertion Incorrect" +simulation_transformer (T_CDiscard f) = f $ + \val -> return () +simulation_transformer (T_DTerm b f) = f $ + \val -> return () +simulation_transformer (T_CGate name ncf f) = f $ + \list -> do + let result = gateC name list + return (result,list) +simulation_transformer g@(T_CGateInv name ncf f) = f $ + \result list -> do + let result' = gateC name list + if result == result' then return list else error "CGateInv: Uncomputation error" +-- Translation of quantum gates: +simulation_transformer (T_QGate "not" 1 0 _ ncf f) = f $ + \[q] [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls cs (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q], [], cs) +simulation_transformer (T_QGate "multinot" _ 0 _ ncf f) = f $ + \qs [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = foldr (\q a -> apply (if_controls cs (performGateQ gate q)) a) amps qs + put (state {quantum_state = amps'}) + return (qs, [], cs) +simulation_transformer (T_QGate "H" 1 0 _ ncf f) = f $ + \[q] [] cs -> do + let gate = gateQ "hadamard" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls cs (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q], [], cs) +simulation_transformer (T_QGate "swap" 2 0 _ ncf f) = f $ + \[w, v] [] cs -> do + let gate = gateQ "x" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gate v)) amps + let amps'' = apply (if_controls ((Signed (Endpoint_Qubit v) True):cs) (performGateQ gate w)) amps' + let amps''' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gate v)) amps'' + put (state {quantum_state = amps'''}) + return ([w, v], [], cs) +simulation_transformer (T_QGate "W" 2 0 _ ncf f) = f $ + \[w, v] [] cs -> do + let gateX = gateQ "x" + let gateH = gateQ "hadamard" + state <- get + let amps = quantum_state state + let amps' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gateX v)) amps + let amps'' = apply (if_controls ((Signed (Endpoint_Qubit v) True):cs) (performGateQ gateH w)) amps' + let amps''' = apply (if_controls ((Signed (Endpoint_Qubit w) True):cs) (performGateQ gateX v)) amps'' + put (state {quantum_state = amps'''}) + return ([w, v], [], cs) +simulation_transformer (T_QGate "trace" _ _ False ncf f) = f $ + \qs gc c -> do + -- a \"trace\" gate adds the current probability distribution for the given qubits + -- to the list of previous quantum traces + state <- get + let current_traces = traces state + let amps = quantum_state state + let new_trace = get_trace qs amps + put (state {traces = new_trace:current_traces}) + return (qs,gc,c) +simulation_transformer (T_QGate "trace" _ _ True ncf f) = f $ + \qs gc c -> return (qs,gc,c) -- we don't do anything for the inverse \"trace\" gate +simulation_transformer (T_QGate name 1 0 inv ncf f) = f $ + \[q] [] c -> do + let gate = gateQinv name inv + state <- get + let amps = quantum_state state + let amps' = apply (if_controls c (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q],[],c) +simulation_transformer (T_QRot name 1 0 inv theta ncf f) = f $ + \[q] [] c -> do + let gate = rotQinv name inv theta + state <- get + let amps = quantum_state state + let amps' = apply (if_controls c (performGateQ gate q)) amps + put (state {quantum_state = amps'}) + return ([q],[],c) +simulation_transformer (T_GPhase t ncf f) = f $ + \w c -> do + state <- get + let gate = rotQ "exp(% pi i)" t + let wire = next_wire state + let q = qubit_of_wire wire + let amps = quantum_state state + let amps' = apply (vector (Map.insert q False)) amps + let amps'' = apply (if_controls c (performGateQ gate q)) amps' + let (p,ift,iff) = split amps'' q + (val,ampsf) <- lift $ merge_with_result p ift iff + case val of + False -> do + let ampsf' = apply (vector (Map.delete q)) ampsf + put (state {quantum_state = ampsf'}) + return c + _ -> error "GPhase" +simulation_transformer (T_QInit val ncf f) = f $ + do + state <- get + let wire = next_wire state + let q = qubit_of_wire wire + let wire' = wire + 1 + let amps = quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + put (state {quantum_state = amps', next_wire = wire'}) + return q +simulation_transformer (T_QMeas f) = f $ + \q -> do + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + let amps'' = apply (vector (Map.delete q)) amps' + put (state {quantum_state = amps''}) + return val +simulation_transformer (T_QDiscard f) = f $ + \q -> do + -- a discard is essentially a measurement, with the result thrown away, so we + -- do that here, as it will reduce the size of the quantum state we are + -- simulating over. + state <- get + let (p,ift,iff) = split (quantum_state state) q + (_,amps) <- lift $ merge_with_result p ift iff + let amps' = apply (vector (Map.delete q)) amps + put (state {quantum_state = amps'}) + return () +simulation_transformer (T_QTerm b ncf f) = f $ + \q -> do + -- with a real quantum computer, when we terminate a qubit with an + -- assertion we have no way of actually checking the assertion. The + -- best we can do is measure the qubit and then throw an error if + -- the assertion is incorrect, which may only occur with a small + -- probability. Here, we could split the quantum state and see if + -- the qubit exists in the incorrect state with any non-zero + -- probability, and throw an error. However, we don't do this + -- because an error would sometimes be thrown due to rounding. + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + if val == b then put (state {quantum_state = amps'}) else error "QTerm: Assertion doesn't hold" +simulation_transformer (T_Comment "" inv f) = f $ + \_ -> return () + -- e.g. a comment can be (the) empty (string) if it only contains labels +simulation_transformer (T_Comment name inv f) = f $ + \_ -> do + state <- get + -- we don't need to do anything with a comment, but they can be useful + -- to know where we are in the circuit, so we shall output a trace of + -- the (non-empty) comments during a simulation. + trace (trace_flag state) name $ return () +-- The remaining gates are not yet implemented: +simulation_transformer g@(T_QGate _ _ _ _ _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_QRot _ _ _ _ _ _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_CSwap _ _) = + error ("simulation_transformer: unimplemented gate: " ++ show g) +simulation_transformer g@(T_QPrep ncf f) = f $ + \val -> do + state <- get + let wire = next_wire state + let q = qubit_of_wire wire + let wire' = wire + 1 + let amps = quantum_state state + let amps' = apply (vector (Map.insert q val)) amps + put (state {quantum_state = amps', next_wire = wire'}) + return q +simulation_transformer g@(T_QUnprep ncf f) = f $ + \q -> do + state <- get + let amps = quantum_state state + let (p,ift,iff) = split amps q + (val,amps') <- lift $ merge_with_result p ift iff + put (state {quantum_state = amps'}) + return val +simulation_transformer g@(T_Subroutine sub inv ncf scf ws_pat a1_pat vs_pat a2_pat rep f) = f $ + \ns in_values c -> do + case Map.lookup sub ns of + Just (TypedSubroutine sub_ocirc _ _ _) -> do + let OCircuit (in_wires, sub_circ, out_wires) = if inv then reverse_ocircuit sub_ocirc else sub_ocirc + let in_bindings = bind_list in_wires in_values bindings_empty + let sub_bcirc = (sub_circ,ns) + out_bind <- transform_bcircuit_rec simulation_transformer sub_bcirc in_bindings + return (unbind_list out_bind out_wires, c) + Nothing -> error $ "simulation_transformer: subroutine " ++ show sub ++ " not found (in " ++ showNames ns ++ ")" + +-- | The simulation_transformer is also Dynamic, as the simulated wire states +-- can simply be used to perform dynamic liftings. +simulation_dynamic_transformer :: (PMonad r m, Ord r) => DynamicTransformer (StateT (QuantumState r) m) Qubit Bool +simulation_dynamic_transformer = DT { + transformer = simulation_transformer, + define_subroutine = \name subroutine -> return (), + lifting_function = return + } + +-- | Apply the 'simulation_dynamic_transformer' to a (unary) circuit +-- generating function. +simulate_transform_unary :: (PMonad r m, Ord r) => (QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => (qa -> Circ qb) + -> BType qa + -> StateT (QuantumState r) m (QCType Qubit Bool (QCType Bit Bit qb)) +simulate_transform_unary (f :: qa -> Circ qb) input = do + let ((), circuit) = encapsulate_dynamic (\() -> qc_init input >>= \qi -> f qi >>= \qi' -> qc_measure qi') () + (cb,out_bind) <- transform_dbcircuit simulation_dynamic_transformer circuit bindings_empty + let output = qc_unbind out_bind cb + return output + +-- | In order to simulate a circuit using an input basis vector, we need to supply +-- each quantum leaf, with a concrete (i.e., not a dummy) qubit. +qdata_concrete_shape :: (QData qa) => BType qa -> qa +qdata_concrete_shape ba = evalState mqa 0 + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State Wire Qubit + f _ = do + w <- get + put (w+1) + return (qubit_of_wire w) + +-- | In order to simulate a circuit using an input basis vector, we need to supply +-- the transformer with a concrete set of qubit bindings. +qdata_concrete_bindings :: (QData qa) => BType qa -> Bindings Qubit Bool +qdata_concrete_bindings ba = snd $ execState mqa (0,bindings_empty) + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State (Wire,Bindings Qubit Bool) () + f b = do + (w,bindings) <- get + put (w+1,bind_qubit_wire w (qubit_of_wire w) bindings) + return () + +-- | As a helper function, in order to simulate a circuit using an input basis vector, +-- we need to be able to convert each basis into a map from concrete qubits to their +-- value in the given basis. +qdata_to_basis :: (QData qa) => BType qa -> Map Qubit Bool +qdata_to_basis ba = snd $ execState mqa (0,Map.empty) + where + shape = shapetype_b ba + mqa = qdata_mapM shape f ba + f :: Bool -> State (Wire,Map Qubit Bool) () + f b = do + (w,m) <- get + put (w+1,Map.insert (qubit_of_wire w) b m) + return () + +-- | In order to simulate a circuit using an input basis vector, we need to be able +-- to convert the basis vector into a quantum state suitable for use by the simulator +-- i.e. of type Amplitudes. +qdata_vector_to_amplitudes :: (QData qa, Floating r) => Vector (Cplx r) (BType qa) -> Amplitudes r +qdata_vector_to_amplitudes (Vector das) = (Vector (map (\(a,d) -> (qdata_to_basis a,d)) das)) + +-- | As a helper function, in order to simulate a circuit using an input basis vector, +-- we need to be able to convert a map from concrete qubits to their value into a basis +-- of the given concrete shape. +basis_to_qdata :: (QData qa) => qa -> Map Qubit Bool -> BType qa +basis_to_qdata qa m = getId $ qdata_mapM qa f qa + where + f :: Qubit -> Id Bool + f q = case Map.lookup q m of + Just res -> return res + _ -> error "basis_to_qdata: qubit not in scope" + +-- | In order to simulate a circuit using an input basis vector, we need to be able +-- to convert the quantum state (i.e. of type Amplitudes) into a basis vector. +amplitudes_to_qdata_vector :: (QData qa, Floating r) => qa -> Amplitudes r -> Vector (Cplx r) (BType qa) +amplitudes_to_qdata_vector qa (Vector das) = Vector (map (\(a,d) -> (basis_to_qdata qa a,d)) das) + +-- | Apply the 'simulation_dynamic_transformer' to a (unary) circuit generating +-- function, starting with the quantum state set to the given vector of base states +-- and returning the resulting vector of base states. +simulate_amplitudes_unary :: (PMonad r m, Eq r, Ord r, QData qa, QData qb, qb ~ QCType Qubit Bool qb) => (qa -> Circ qb) -> Vector (Cplx r) (BType qa) -> m (Vector (Cplx r) (BType qb)) +simulate_amplitudes_unary f input@(Vector is) = do + (out_shape,state) <- runStateT circ input_state + let out_amps = quantum_state state + return (amplitudes_to_qdata_vector out_shape (apply (vector id) out_amps)) + where + amps = qdata_vector_to_amplitudes input + specimen = case is of + [] -> error "simulate_amplitudes_unary: can't use empty vector" + ((b,_):_) -> b + shape = qdata_concrete_shape specimen + bindings = qdata_concrete_bindings specimen + max_wire = case wires_of_bindings bindings of + [] -> 0 + ws -> maximum ws + input_state = (empty_quantum_state False undefined) {quantum_state = amps, next_wire = max_wire + 1} + (_,circuit) = encapsulate_dynamic f shape + circ = do + (cb,out_bind) <- transform_dbcircuit simulation_dynamic_transformer circuit bindings + let output = qc_unbind out_bind cb + return output + +-- | Input a source of randomness, a quantum circuit, and an initial +-- state (represented as a map from basis vectors to amplitudes). +-- Simulate the circuit and return the final state. If the circuit +-- includes measurements, the simulation will be probabilistic. +-- +-- The type of this heavily overloaded function is difficult to +-- read. It has, for example, the following types: +-- +-- > sim_amps :: StdGen -> (Qubit -> Circ Qubit) -> Map Bool (Cplx Double) -> Map Bool (Cplx Double) +-- > sim_amps :: StdGen -> ((Qubit,Qubit) -> Circ Qubit) -> Map (Bool,Bool) (Cplx Double) -> Map Bool (Cplx Double) +-- +-- and so forth. Note that instead of 'Double', another real number +-- type, such as 'Data.Number.FixedPrec.FixedPrec' /e/, can be used. +sim_amps :: (RandomGen g, Floating r, Random r, Ord r, QData qa, QData qb, qb ~ QCType Qubit Bool qb, Ord (BType qb)) => g -> (qa -> Circ qb) -> Map (BType qa) (Cplx r) -> Map (BType qb) (Cplx r) +sim_amps gen f input_map = output_map + where + input_vec = Vector (Map.toList input_map) + circ = simulate_amplitudes_unary f input_vec + Vector output = evalState circ gen + output_map = Map.fromList output + +-- | Input a source of randomness, a real number, a circuit, and a +-- basis state. Then simulate the circuit probabilistically. Measure +-- the final state and return the resulting basis vector. +-- +-- The real number argument is a dummy and is never evaluated; its +-- only purpose is to specify the /type/ of real numbers that will be +-- used during the simulation. +run_unary :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => g -> r -> + (qa -> Circ qb) + -> BType qa + -> QCType Qubit Bool (QCType Bit Bit qb) +run_unary g r f input = evalState comp g where + comp = evalStateT f' (empty_quantum_state False r) + f' = simulate_transform_unary f input + +-- | Like 'run_unary', but return the list of 'QuantumTrace' elements +-- that were generated during the computation. This is useful for +-- checking the intermediary state of qubits within a computation. +run_unary_trace :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => g -> r -> + (qa -> Circ qb) + -> BType qa + -> [QuantumTrace r] +run_unary_trace g r f input = evalState comp g where + comp = do + state <- execStateT f' (empty_quantum_state True r) + let qts = traces state + return (reverse qts) + f' = simulate_transform_unary f input + +-- | Like 'run_unary', but run in the 'IO' monad instead of passing an +-- explicit source of randomness. +run_unary_io :: (Floating r, Random r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> IO (QCType Qubit Bool (QCType Bit Bit qb)) +run_unary_io r f input = do + g <- newStdGen + return (run_unary g r f input) + +-- | Like 'run_unary_trace', but run in the 'IO' monad instead of +-- passing an explicit source of randomness. +run_unary_trace_io :: (Floating r, Random r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> IO [QuantumTrace r] +run_unary_trace_io r f input = do + g <- newStdGen + return (run_unary_trace g r f input) + +-- | Apply the 'simulation_transformer' to a (unary) circuit, and then evaluate +-- the resulting stateful computation to get a probability distribution of possible +-- results +sim_unary :: (Floating r, Ord r, QCData qa, QCData qb, QCData (QCType Bit Bit qb), QCType Bool Bool qb ~ QCType Bool Bool (QCType Bit Bit qb)) => r -> + (qa -> Circ qb) + -> BType qa + -> ProbabilityDistribution r (QCType Qubit Bool (QCType Bit Bit qb)) +sim_unary r f input = evalStateT f' (empty_quantum_state False r) + where f' = simulate_transform_unary f input + +-- ====================================================================== +-- * Generic functions + +-- ** Generic run function + +-- $ Generic functions to run Quipper circuits, using "Random" to +-- simulate quantum states. + +-- | Quantum simulation of a circuit, for testing and debugging +-- purposes. Input a source of randomness, a real number, and a +-- quantum circuit. Output a corresponding probabilistic boolean +-- function. +-- +-- The inputs to the quantum circuit are initialized according to the +-- given boolean arguments. The outputs of the quantum circuit are +-- measured, and the boolean measurement outcomes are +-- returned. +-- +-- The real number argument is a dummy and is never evaluated; its +-- only purpose is to specify the /type/ of real numbers that will be +-- used during the simulation. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa) => g -> r -> Circ qa -> BType qa +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb) => g -> r -> (qa -> Circ qb) -> BType qa -> BType qb +-- > run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCData qb, QCData qc) => g -> r -> (qa -> qb -> Circ qc) -> BType qa -> BType qb -> BType qc +-- +-- and so forth. +run_generic :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (QCType Qubit Bool (QCType Bit Bit qb))) => g -> r -> qfun -> qfun' +run_generic gen r f = g + where + f1 = quncurry f + g1 = run_unary gen r f1 + g = mcurry g1 + +-- | Like 'run_generic', but also output a trace of the states of the +-- given list of qubits at each step during the evaluation. +run_generic_trace :: (Floating r, Random r, Ord r, RandomGen g, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) [QuantumTrace r]) => g -> r -> qfun -> qfun' +run_generic_trace gen r f = g + where + f1 = quncurry f + g1 = run_unary_trace gen r f1 + g = mcurry g1 + +-- | Like 'run_generic', but run in the 'IO' monad instead of passing +-- an explicit source of randomness. +run_generic_io :: (Floating r, Random r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (IO (QCType Qubit Bool (QCType Bit Bit qb)))) => r -> qfun -> qfun' +run_generic_io r f = g + where + f1 = quncurry f + g1 = run_unary_io r f1 + g = mcurry g1 + +-- | Like 'run_generic_trace', but run in the 'IO' monad instead of +-- passing an explicit source of randomness. +run_generic_trace_io :: (Floating r, Random r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (IO [QuantumTrace r])) => r -> qfun -> qfun' +run_generic_trace_io r f = g + where + f1 = quncurry f + g1 = run_unary_trace_io r f1 + g = mcurry g1 + +-- ---------------------------------------------------------------------- +-- ** Generic sim function + +-- $ A generic function to simulate Quipper circuits, returning a +-- probability distribution of the possible results. + +-- | A generic function to simulate Quipper circuits, returning a +-- probability distribution of the possible results. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types (for +-- example): +-- +-- > sim_generic :: (Floating r, Ord r, QCData qa) => r -> Circ qa -> ProbabilityDistribution r (BType qa) +-- > sim_generic :: (Floating r, Ord r, QCData qa, QCData qb) => r -> (qa -> Circ qb) -> BType qa -> ProbabilityDistribution r (BType qb) +-- > sim_generic :: (Floating r, Ord r, QCData qa, QCData qb, QCData qc) => r -> (qa -> qb -> Circ qc) -> BType qa -> BType qb -> ProbabilityDistribution r (BType qc) +-- +-- and so forth. +sim_generic :: (Floating r, Ord r, QCData qa, QCDataPlus qb, QCurry qfun qa qb, + Curry qfun' (QCType Bool Bool qa) (ProbabilityDistribution r (QCType Qubit Bool (QCType Bit Bit qb)))) => r -> qfun -> qfun' +sim_generic r f = g where + f1 = quncurry f + g1 = sim_unary r f1 + g = mcurry g1 + diff --git a/dist/build/Quipper/Libraries/Synthesis.hs b/dist/build/Quipper/Libraries/Synthesis.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Synthesis.hs @@ -0,0 +1,506 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Synthesis.hs" #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | A Quipper library for synthesizing Clifford+/T/ circuits directly +-- from a matrix description or Euler angle description of a unitary +-- operator. This library provides both exact and approximate +-- synthesis. + +module Quipper.Libraries.Synthesis where + +import Quipper + +import Quipper.Internal + +import Quantum.Synthesis.CliffordT +import Quantum.Synthesis.MultiQubitSynthesis +import Quantum.Synthesis.Ring +import Quantum.Synthesis.Matrix +import Quantum.Synthesis.Newsynth +import Quantum.Synthesis.SymReal +import Quantum.Synthesis.EulerAngles + +import Quipper.Utils.Auxiliary (boollist_of_int_bh) + +import Control.Monad (when) +import Data.Bits (xor, (.&.)) +import System.Random +import Text.Printf + +-- ---------------------------------------------------------------------- +-- * Precision + +-- | A type to measure precision. Precision is expressed as a number +-- /b/ of bits, i.e., binary digits, so that ε = 2[sup −/b/]. +type Precision = Double + +-- | Binary digits, as a unit of precision. For example, the following +-- specifies a precision of 20 binary digits: +-- +-- > prec = 20 * bits +bits :: Precision +bits = 1 + +-- | Decimal digits, as a unit of precision. For example, the +-- following specifies a precision of 30 decimal digits: +-- +-- > prec = 30 * digits +digits :: Precision +digits = logBase 2 10 + +-- ---------------------------------------------------------------------- +-- * Phase + +-- | A boolean flag indicating whether to respect global phases +-- during circuit synthesis ('True') or disregard them ('False'). +type KeepPhase = Bool + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions + +-- | Apply a gate (from the type 'Gate' of Clifford+/T/ operators) to +-- the given 'Qubit'. +apply_gate_at :: Gate -> Qubit -> Circ () +apply_gate_at X q = do + gate_X_at q +apply_gate_at Y q = do + gate_Y_at q +apply_gate_at Z q = do + gate_Z_at q +apply_gate_at H q = do + hadamard_at q +apply_gate_at S q = do + gate_S_at q +apply_gate_at T q = do + gate_T_at q +apply_gate_at E q = do + gate_E_at q +apply_gate_at W q = do + gate_omega_at q + +-- | Apply a gate list (from the type 'Gate' of Clifford+/T/ +-- operators) to the given 'Qubit'. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. +apply_gates_at :: [Gate] -> Qubit -> Circ () +apply_gates_at gates q = do + sequence_ [ apply_gate_at g q | g <- reverse gates ] + +-- | Like 'apply_gates_at', but apply the same list of gates to two +-- qubits in parallel. +apply_gates2_at :: [Gate] -> Qubit -> Qubit -> Circ () +apply_gates2_at gates q1 q2 = do + sequence_ [ do + apply_gate_at g q1 + apply_gate_at g q2 + | g <- reverse gates ] + +-- | Input two indices /i/ and /j/, a list of qubits /qlist/, and an +-- imperative-style single-qubit gate /U/. Apply the two-level +-- operator /U/[sub /i/,/j/] to /qlist/. Intended usage: +-- +-- > twolevel i j qlist gate_U_at +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- This function implements an improved version of Gray codes. +twolevel :: Index -> Index -> [Qubit] -> (Qubit -> Circ ()) -> Circ () +twolevel i j qlist body = aux l1 l2 qlist where + n = length qlist + l1 = boollist_of_int_bh n i + l2 = boollist_of_int_bh n j + + aux [] [] [] = error "twolevel: i=j" + aux (h1:t1) (h2:t2) (q:qs) + | h1 == h2 = + with_controls (q .==. h1) $ do + aux t1 t2 qs + | h1 == True = + with_basis_change (qnot_at q) $ do + aux2 t1 t2 q qs + | otherwise = + aux2 t1 t2 q qs + aux _ _ _ = error "twolevel: internal error 1" -- not reached + + aux2 [] [] q [] = + body q + aux2 (h1:t1) (h2:t2) q0 (q:qs) + | h1 == h2 = + with_controls (q .==. h1) $ do + aux2 t1 t2 q0 qs + | otherwise = + with_basis_change (qnot_at q `controlled` q0) $ do + with_controls (q .==. h1) $ do + aux2 t1 t2 q0 qs + aux2 _ _ _ _ = error "twolevel: internal error 2" -- not reached + +-- | Apply a /T/[sup /m/] gate. This gate is decomposed into /Z/, /S/, +-- /S/[sup †], /T/, and /T/[sup †] gates. +gate_T_power_at :: Int -> Qubit -> Circ () +gate_T_power_at 0 q = do + return () +gate_T_power_at 1 q = do + gate_T_at q +gate_T_power_at 2 q = do + gate_S_at q +gate_T_power_at 3 q = do + gate_S_at q + gate_T_at q +gate_T_power_at 4 q = do + gate_Z_at q +gate_T_power_at 5 q = do + gate_Z_at q + gate_T_at q +gate_T_power_at 6 q = do + gate_S_inv_at q +gate_T_power_at 7 q = do + gate_T_inv_at q +gate_T_power_at m q = gate_T_power_at (m `mod` 8) q + +-- | Apply a 'TwoLevel' gate to the given list of qubits. +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +apply_twolevel_at :: TwoLevel -> [Qubit] -> Circ () +apply_twolevel_at (TL_X i j) qlist = + twolevel i j qlist $ \q -> do + gate_X_at q +apply_twolevel_at (TL_H i j) qlist = + twolevel i j qlist $ \q -> do + hadamard_at q +apply_twolevel_at (TL_T m i j) qlist + | m `mod` 8 == 0 = return () + | otherwise = + twolevel i j qlist $ \q -> do + gate_T_power_at m q +apply_twolevel_at (TL_omega m i) qlist + | m' == 0 = do + return () + | qlist == [] = do + global_phase (fromIntegral m' * 0.25) + | otherwise = + apply_twolevel_at (TL_T m j i) qlist + where + j = if i == 0 then 1 else i .&. (i-1) + m' = m `mod` 8 + +-- | Apply a list of 'TwoLevel' gates to the given list of +-- qubits. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. + +-- Implementation note: this could be improved by combining +-- consecutive two-level gates if they share the same i and j +apply_twolevels_at :: [TwoLevel] -> [Qubit] -> Circ () +apply_twolevels_at ops qlist = + sequence_ [ apply_twolevel_at g qlist | g <- reverse ops ] + +-- | Like 'apply_twolevel_at', but use the alternate generators for +-- two-level gates. +apply_twolevel_alt_at :: TwoLevelAlt -> [Qubit] -> Circ () +apply_twolevel_alt_at (TL_iX j l) qlist = do + twolevel j l qlist $ \q -> do + gate_iX_at q +apply_twolevel_alt_at (TL_TiHT m j l) qlist = do + twolevel j l qlist $ \q -> do + let basischange = do + gate_T_power_at m q + gate_S_at q + gate_H_at q + gate_T_at q + with_basis_change basischange $ do + gate_iX_at q +apply_twolevel_alt_at (TL_W m j l) qlist + | m' == 0 = do + return () + | otherwise = do + twolevel j l qlist $ \q -> do + gate_iX_at q + let basischange = do + gate_T_power_at m' q + with_basis_change basischange $ do + gate_iX_inv_at q + where + m' = m `mod` 8 +apply_twolevel_alt_at (TL_omega_alt m j) qlist + | m' == 0 = do + return () + | qlist == [] = do + global_phase (fromIntegral m' * 0.25) + | otherwise = do + apply_twolevel_at (TL_T m l j) qlist + where + l = if j == 0 then 1 else j .&. (j-1) + m' = m `mod` 8 + +-- | Apply a list of 'TwoLevelAlt' gates to the given list of +-- qubits. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- Note: the operators in the list are applied right-to-left, i.e., +-- the gate list is assumed given in matrix multiplication order, but +-- are applied in circuit order. + +-- Implementation note: this could be improved by combining +-- consecutive two-level gates if they share the same i and j +apply_twolevels_alt_at :: [TwoLevelAlt] -> [Qubit] -> Circ () +apply_twolevels_alt_at ops qlist = + sequence_ [ apply_twolevel_alt_at g qlist | g <- reverse ops ] + + +-- ---------------------------------------------------------------------- +-- * Single-qubit exact synthesis + +-- | Decompose the given operator exactly into a single-qubit +-- Clifford+/T/ circuit. The operator must be given in one of the +-- available exact formats, i.e., any instance of the 'ToGates' class. +-- Typical instances are: +-- +-- * 'U2' 'DOmega': a 2×2 unitary operator with entries from the ring +-- [bold D][ω] = ℤ[1\/√2, /i/]; +-- +-- * 'SO3' 'DRootTwo': a 3×3 Bloch sphere operator with entries from the +-- ring ℤ[1\/√2]. In this last case, the operator will be synthesized +-- up to an unspecified global phase. +exact_synthesis1 :: (ToGates a) => a -> Qubit -> Circ Qubit +exact_synthesis1 op q = do + comment_with_label "ENTER: exact_synthesis1" q "q" + apply_gates_at gates q + comment_with_label "EXIT: exact_synthesis1" q "q" + return q + where + gates = convert (normalize op) :: [Gate] + +-- ---------------------------------------------------------------------- +-- * Multi-qubit exact synthesis + +-- | Decompose the given operator exactly into a Clifford+/T/ circuit. +-- The operator must be given as an /n/×/n/-matrix with coefficients +-- in a ring that is an instance of the 'ToQOmega' class. A typical +-- example of such a ring is 'DOmega'. +-- +-- If this function is applied to a list of /m/ qubits, then we must +-- have /n/ ≤ 2[sup /m/]. +-- +-- The qubits in /qlist/ are ordered lexicographically left-to-right, +-- e.g., [|00〉, |01〉, |10〉, |11〉]. +-- +-- The generated circuit contains no ancillas, but may contain +-- multi-controlled gates whose decomposition into Clifford+/T/ +-- generators requires ancillas. +exact_synthesis :: (ToQOmega a, Nat n) => Matrix n n a -> [Qubit] -> Circ [Qubit] +exact_synthesis op qlist = do + comment_with_label "ENTER: exact_synthesis" qlist "q" + apply_twolevels_at twolevels qlist + comment_with_label "EXIT: exact_synthesis" qlist "q" + return qlist + where + op_DOmega = matrix_map (to_dyadic . toQOmega) op + twolevels = synthesis_nqubit op_DOmega + +-- | Like 'exact_synthesis', but use the alternate algorithm from +-- Section 6 of Giles-Selinger. This means all but at most one of the +-- generated multi-controlled gates have determinant 1, which means +-- they can be further decomposed without ancillas. +exact_synthesis_alt :: (ToQOmega a, Nat n) => Matrix n n a -> [Qubit] -> Circ [Qubit] +exact_synthesis_alt op qlist = do + comment_with_label "ENTER: exact_synthesis_alt" qlist "q" + apply_twolevels_alt_at twolevels qlist + comment_with_label "EXIT: exact_synthesis_alt" qlist "q" + return qlist + where + op_DOmega = matrix_map (to_dyadic . toQOmega) op + twolevels = synthesis_nqubit_alt op_DOmega + +-- ---------------------------------------------------------------------- +-- * Single-qubit approximate synthesis + +-- ---------------------------------------------------------------------- +-- ** /z/-Rotations + +-- | Decompose an /R/[sub /z/](θ) = [exp −/i/θ/Z/\/2] gate into a +-- single-qubit Clifford+/T/ circuit up to the given precision. +-- +-- \[image Rz.png] +-- +-- The parameters are: +-- +-- * a precision /b/ ≥ 0; +-- +-- * an angle θ, given as a 'SymReal' value; +-- +-- * a source of randomness /g/. +approximate_synthesis_zrot :: (RandomGen g) => Precision -> SymReal -> g -> Qubit -> Circ Qubit +approximate_synthesis_zrot b theta g q = do + comment_with_label (printf "ENTER: approximate_synthesis_zrot (b=%.2f, theta=%s)" b (show theta)) q "q" + q <- without_comments $ do + exact_synthesis1 op q + comment_with_label "EXIT: approximate_synthesis_zrot" q "q" + return q + where + op = newsynth b theta g + +-- ---------------------------------------------------------------------- +-- ** Global phase gates + +-- | Construct a Clifford+/T/ circuit (with no inputs and outputs) +-- that approximates a scalar global phase gate [exp /i/θ] up to the +-- given precision. The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected. (Note that if this is set to 'False', then this function +-- is just a no-op); +-- +-- * a precision /b/ ≥ 0; +-- +-- * an angle θ, given as a 'SymReal' value; +-- +-- * a source of randomness /g/. +-- +-- We use the following decomposition: +-- +-- \[image phase.png] +approximate_synthesis_phase :: (RandomGen g) => KeepPhase -> Precision -> SymReal -> g -> Circ () +approximate_synthesis_phase False b theta g = do + return () +approximate_synthesis_phase True b theta g = do + comment (printf "ENTER: approximate_synthesis_phase (b=%.2f, theta=%s)" b (show theta)) + when (gates /= []) $ do + q <- qinit 0 + apply_gates_at gates q + qterm 0 q + comment "EXIT: approximate_synthesis_phase" + where + op = newsynth b (-2*theta) g + gates = convert (normalize op) :: [Gate] + +-- ---------------------------------------------------------------------- +-- ** /U/(2) from Euler angles + +-- | Decompose the operator +-- +-- * /U/ = [exp /i/α] R[sub /z/](β) R[sub /x/](γ) R[sub /z/](δ) +-- +-- into the Clifford+/T/ gate base, up to the given precision. +-- The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected. If this is 'False', the angle α is disregarded; +-- +-- * a precision /b/ ≥ 0; +-- +-- * a tuple of Euler angles (α, β, γ, δ), given as 'SymReal' values; +-- +-- * a source of randomness /g/. +approximate_synthesis_euler :: (RandomGen g) => KeepPhase -> Precision -> (SymReal, SymReal, SymReal, SymReal) -> g -> Qubit -> Circ Qubit +approximate_synthesis_euler keepphase b (alpha, beta, gamma, delta) g q = do + comment_with_label (printf "ENTER: approximate_synthesis_euler (b=%.2f, alpha=%s, beta=%s, gamma=%s, delta=%s, keepphase=%s)" b (show alpha) (show beta) (show gamma) (show delta) (show keepphase)) q "q" + without_comments $ do + exact_synthesis1 (op_beta * u2_H * op_gamma * u2_H * op_delta) q + approximate_synthesis_phase keepphase b' alpha g1 + comment_with_label "EXIT: approximate_synthesis_euler" q "q" + return q + where + op_beta = newsynth b' beta g2 + op_gamma = newsynth b' gamma g3 + op_delta = newsynth b' delta g4 + (g', g'') = split g + (g1, g2) = split g' + (g3, g4) = split g'' + b' = b + 2 -- ε' = ε / 4 + +-- ---------------------------------------------------------------------- +-- ** /U/(2) from matrix + +-- | Decompose a single-qubit unitary gate /U/ into the Clifford+/T/ +-- gate base, up to the given precision, provided that det /U/ = 1. +-- The parameters are: +-- +-- * a flag /keepphase/ to indicate whether global phase should be +-- respected; +-- +-- * a precision /b/ ≥ 0; +-- +-- * a 2×2 complex matrix, with entries expressed as 'Cplx' 'SymReal' values; +-- +-- * a source of randomness /g/. +approximate_synthesis_u2 :: (RandomGen g) => KeepPhase -> Precision -> U2 (Cplx SymReal) -> g -> Qubit -> Circ Qubit +approximate_synthesis_u2 keepphase b op g q = do + comment_with_label (printf "ENTER: approximate_synthesis_u2 (b=%.2f, op=%s, keepphase=%s)" b (show op) (show keepphase)) q "q" + q <- without_comments $ do + approximate_synthesis_euler keepphase b (alpha, beta, gamma, delta) g q + comment_with_label "EXIT: approximate_synthesis_u2" q "q" + return q + where + (alpha, beta, gamma, delta) = euler_angles op + +-- ---------------------------------------------------------------------- +-- ** Controlled gates + +-- | Decompose a controlled /R/[sub /z/](θ) = [exp −/i/θ/Z/\/2] gate +-- into a single-qubit Clifford+/T/ circuit up to the given +-- precision. The parameters are as for 'approximate_synthesis_phase'. +-- The first input is the target qubit, and the second input the +-- control. +-- +-- We use the following decomposition. It has lower /T/-count than the +-- alternatives and makes good use of parallelism. Since it uses the +-- same rotation twice, only a single run of the synthesis algorithm +-- is required. +-- +-- \[image controlled-zrot.png] +approximate_synthesis_zrot_ctrl :: (RandomGen g) => Precision -> SymReal -> g -> Qubit -> Qubit -> Circ Qubit +approximate_synthesis_zrot_ctrl b theta g q1 c2 = do + comment_with_label (printf "ENTER: approximate_synthesis_zrot_ctrl (b=%.2f, theta=%s)" b (show theta)) (q1,c2) ("q", "c") + qnot_at c2 `controlled` q1 .==. False + apply_gates2_at gates q1 c2 + qnot_at c2 `controlled` q1 .==. False + comment_with_label "EXIT: approximate_synthesis_zrot_ctrl" (q1,c2) ("q", "c") + return q1 + where + gates = convert (normalize op) :: [Gate] + op = newsynth (b+1) (theta/2) g + +-- | Decompose a controlled phase gate +-- +-- \[image controlled_phase.png] +-- +-- into the Clifford+/T/ gate base. The parameters are as for +-- 'approximate_synthesis_phase'. +-- +-- We use the following decomposition. It has lower /T/-count than the +-- alternatives and makes good use of parallelism. Since it uses the +-- same rotation twice, only a single run of the synthesis algorithm +-- is required. +-- +-- \[image controlled-phase-decomp.png] +-- +-- If the 'KeepPhase' flag is set, respect global phase; otherwise, +-- disregard it. +approximate_synthesis_phase_ctrl :: (RandomGen g) => KeepPhase -> Precision -> SymReal -> g -> Qubit -> Circ Qubit +approximate_synthesis_phase_ctrl keepphase b theta g q1 = do + comment_with_label (printf "ENTER: approximate_synthesis_phase_ctrl (b=%.2f, theta=%s keepphase=%s)" b (show theta) (show keepphase)) q1 "q" + if keepphase then do + q2 <- qinit True + apply_gates2_at gates q2 q1 + qterm True q2 + else do + approximate_synthesis_zrot b theta g q1 + return () + comment_with_label "EXIT: approximate_synthesis_phase_ctrl" q1 "q" + return q1 + where + gates = convert (normalize op) :: [Gate] + op = newsynth (b+1) theta g diff --git a/dist/build/Quipper/Libraries/Unboxing.hs b/dist/build/Quipper/Libraries/Unboxing.hs new file mode 100644 --- /dev/null +++ b/dist/build/Quipper/Libraries/Unboxing.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LINE 1 "Quipper/Libraries/Unboxing.hs" #-} +{-# LANGUAGE Rank2Types #-} + +-- | This library provides functions for “unboxing” hierarchical circuits, +-- replacing calls to named subroutines by inlined copies of the subroutines +-- themselves. + +module Quipper.Libraries.Unboxing where + +import Quipper +import Quipper.Internal +import Quipper.Internal.Circuit (BoxId (..), RepeatFlag (..)) +import Quipper.Internal.Monad (endpoints_of_wires_in_arity) +import Quipper.Internal.Generic (inline_subroutine, transform_unary) + +-- | A transformer to peel away one level of boxing. Transforms any +-- top-level subroutine gate into its corresponding circuit. +unbox_transformer :: Transformer Circ Qubit Bit +unbox_transformer (T_Subroutine name inv ncf _ _ _ ws2 a2 (RepeatFlag reps) f) = f $ + \namespace ws c -> do + outputs <- loopM reps ws + ((without_controls_if ncf) . + (with_controls c) . + ((if inv then flip reverse_generic (endpoints_of_wires_in_arity a2 ws2) else id) + (inline_subroutine name namespace))) + return (outputs, c) +unbox_transformer x = identity_transformer x + +-- | Peel away one level of boxing from a circuit. Transforms any +-- top-level subroutine gate into its corresponding circuit. +unbox_unary :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +unbox_unary circ = transform_unary unbox_transformer circ + +-- | Peel away one level of boxing from a circuit. Transforms any +-- top-level subroutine gate into its corresponding circuit. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox :: (QCData x) => Circ x -> Circ x +-- > unbox :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +-- > unbox :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> (x -> y -> Circ z) +-- +-- and so forth. +unbox :: (QCData x, QCData y, QCurry qfun x y) => qfun -> qfun +unbox = qcurry . unbox_unary . quncurry + +-- | A transformer to recursively unbox some specified class of boxed subroutines. +unbox_recursive_filtered_transformer :: (BoxId -> Bool) -> Transformer Circ Qubit Bit +unbox_recursive_filtered_transformer p b@(T_Subroutine boxid inv ncf _ _ _ ws2 a2 (RepeatFlag reps) f) = + if not (p boxid) + then identity_transformer b + else f $ + \namespace ws c -> do + outputs <- loopM reps ws + ((without_controls_if ncf) . + (with_controls c) . + ((if inv then flip reverse_generic (endpoints_of_wires_in_arity a2 ws2) else id) $ + (unbox_recursive_filtered p) $ + (inline_subroutine boxid namespace))) + return (outputs, c) +unbox_recursive_filtered_transformer _ x = identity_transformer x + +-- | Recursively unbox all subroutines satisfying a given predicate. +unbox_recursive_filtered_unary :: (QCData x, QCData y) => (BoxId -> Bool) -> (x -> Circ y) -> (x -> Circ y) +unbox_recursive_filtered_unary p = transform_unary (unbox_recursive_filtered_transformer p) + +-- | Recursively unbox all subroutines satisfying a given predicate. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox_recursive_filtered :: (QCData x) => (BoxId -> Bool) -> Circ x -> Circ x +-- > unbox_recursive_filtered :: (QCData x, QCData y) => (BoxId -> Bool) -> (x -> Circ y) -> (x -> Circ y) +-- +-- and so forth. +unbox_recursive_filtered :: (QCData x, QCData y, QCurry qfun x y) => (BoxId -> Bool) -> qfun -> qfun +unbox_recursive_filtered p = qcurry . (unbox_recursive_filtered_unary p) . quncurry + +-- | Recursively unbox all subroutines of a circuit. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > unbox_recursive :: (QCData x) => Circ x -> Circ x +-- > unbox_recursive :: (QCData x, QCData y) => (x -> Circ y) -> (x -> Circ y) +-- > unbox_recursive :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> (x -> y -> Circ z) +-- +-- and so forth. +unbox_recursive :: (QCData x, QCData y, QCurry qfun x y) => qfun -> qfun +unbox_recursive = unbox_recursive_filtered (const True) diff --git a/images/CosetState.png b/images/CosetState.png new file mode 100644 Binary files /dev/null and b/images/CosetState.png differ diff --git a/images/E.png b/images/E.png new file mode 100644 Binary files /dev/null and b/images/E.png differ diff --git a/images/ERot_phase.png b/images/ERot_phase.png new file mode 100644 Binary files /dev/null and b/images/ERot_phase.png differ diff --git a/images/ERot_zx.png b/images/ERot_zx.png new file mode 100644 Binary files /dev/null and b/images/ERot_zx.png differ diff --git a/images/G.png b/images/G.png new file mode 100644 Binary files /dev/null and b/images/G.png differ diff --git a/images/GateR.png b/images/GateR.png new file mode 100644 Binary files /dev/null and b/images/GateR.png differ diff --git a/images/Rz.png b/images/Rz.png new file mode 100644 Binary files /dev/null and b/images/Rz.png differ diff --git a/images/T.png b/images/T.png new file mode 100644 Binary files /dev/null and b/images/T.png differ diff --git a/images/V.png b/images/V.png new file mode 100644 Binary files /dev/null and b/images/V.png differ diff --git a/images/W.png b/images/W.png new file mode 100644 Binary files /dev/null and b/images/W.png differ diff --git a/images/Y.png b/images/Y.png new file mode 100644 Binary files /dev/null and b/images/Y.png differ diff --git a/images/adder-optimized.png b/images/adder-optimized.png new file mode 100644 Binary files /dev/null and b/images/adder-optimized.png differ diff --git a/images/adder-unoptimized.png b/images/adder-unoptimized.png new file mode 100644 Binary files /dev/null and b/images/adder-unoptimized.png differ diff --git a/images/b0-template.png b/images/b0-template.png new file mode 100644 Binary files /dev/null and b/images/b0-template.png differ diff --git a/images/b1-template.png b/images/b1-template.png new file mode 100644 Binary files /dev/null and b/images/b1-template.png differ diff --git a/images/b2-orthodox.png b/images/b2-orthodox.png new file mode 100644 Binary files /dev/null and b/images/b2-orthodox.png differ diff --git a/images/b2-template.png b/images/b2-template.png new file mode 100644 Binary files /dev/null and b/images/b2-template.png differ diff --git a/images/b3-template.png b/images/b3-template.png new file mode 100644 Binary files /dev/null and b/images/b3-template.png differ diff --git a/images/b4-template.png b/images/b4-template.png new file mode 100644 Binary files /dev/null and b/images/b4-template.png differ diff --git a/images/cH_AMMR.png b/images/cH_AMMR.png new file mode 100644 Binary files /dev/null and b/images/cH_AMMR.png differ diff --git a/images/ccZ_AMMR.png b/images/ccZ_AMMR.png new file mode 100644 Binary files /dev/null and b/images/ccZ_AMMR.png differ diff --git a/images/ccZ_S.png b/images/ccZ_S.png new file mode 100644 Binary files /dev/null and b/images/ccZ_S.png differ diff --git a/images/cc_iX.png b/images/cc_iX.png new file mode 100644 Binary files /dev/null and b/images/cc_iX.png differ diff --git a/images/cc_iX_S.png b/images/cc_iX_S.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_S.png differ diff --git a/images/cc_iX_simple.png b/images/cc_iX_simple.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_simple.png differ diff --git a/images/contfrac.png b/images/contfrac.png new file mode 100644 Binary files /dev/null and b/images/contfrac.png differ diff --git a/images/controlled-phase-decomp.png b/images/controlled-phase-decomp.png new file mode 100644 Binary files /dev/null and b/images/controlled-phase-decomp.png differ diff --git a/images/controlled-zrot.png b/images/controlled-zrot.png new file mode 100644 Binary files /dev/null and b/images/controlled-zrot.png differ diff --git a/images/controlled_E.png b/images/controlled_E.png new file mode 100644 Binary files /dev/null and b/images/controlled_E.png differ diff --git a/images/controlled_S.png b/images/controlled_S.png new file mode 100644 Binary files /dev/null and b/images/controlled_S.png differ diff --git a/images/controlled_T.png b/images/controlled_T.png new file mode 100644 Binary files /dev/null and b/images/controlled_T.png differ diff --git a/images/controlled_V.png b/images/controlled_V.png new file mode 100644 Binary files /dev/null and b/images/controlled_V.png differ diff --git a/images/controlled_W.png b/images/controlled_W.png new file mode 100644 Binary files /dev/null and b/images/controlled_W.png differ diff --git a/images/controlled_YY.png b/images/controlled_YY.png new file mode 100644 Binary files /dev/null and b/images/controlled_YY.png differ diff --git a/images/controlled_iX.png b/images/controlled_iX.png new file mode 100644 Binary files /dev/null and b/images/controlled_iX.png differ diff --git a/images/controlled_phase.png b/images/controlled_phase.png new file mode 100644 Binary files /dev/null and b/images/controlled_phase.png differ diff --git a/images/coord.png b/images/coord.png new file mode 100644 Binary files /dev/null and b/images/coord.png differ diff --git a/images/dashed-cnot-bwd.png b/images/dashed-cnot-bwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-bwd.png differ diff --git a/images/dashed-cnot-fwd.png b/images/dashed-cnot-fwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-fwd.png differ diff --git a/images/decompose2Controls.png b/images/decompose2Controls.png new file mode 100644 Binary files /dev/null and b/images/decompose2Controls.png differ diff --git a/images/decomposeControls.png b/images/decomposeControls.png new file mode 100644 Binary files /dev/null and b/images/decomposeControls.png differ diff --git a/images/def_f.png b/images/def_f.png new file mode 100644 Binary files /dev/null and b/images/def_f.png differ diff --git a/images/def_g.png b/images/def_g.png new file mode 100644 Binary files /dev/null and b/images/def_g.png differ diff --git a/images/def_g1.png b/images/def_g1.png new file mode 100644 Binary files /dev/null and b/images/def_g1.png differ diff --git a/images/def_h.png b/images/def_h.png new file mode 100644 Binary files /dev/null and b/images/def_h.png differ diff --git a/images/expDA.png b/images/expDA.png new file mode 100644 Binary files /dev/null and b/images/expDA.png differ diff --git a/images/floor.png b/images/floor.png new file mode 100644 Binary files /dev/null and b/images/floor.png differ diff --git a/images/floor2.png b/images/floor2.png new file mode 100644 Binary files /dev/null and b/images/floor2.png differ diff --git a/images/fredkin.png b/images/fredkin.png new file mode 100644 Binary files /dev/null and b/images/fredkin.png differ diff --git a/images/gate_W_CliffordT.png b/images/gate_W_CliffordT.png new file mode 100644 Binary files /dev/null and b/images/gate_W_CliffordT.png differ diff --git a/images/hex-coord.png b/images/hex-coord.png new file mode 100644 Binary files /dev/null and b/images/hex-coord.png differ diff --git a/images/hex1.png b/images/hex1.png new file mode 100644 Binary files /dev/null and b/images/hex1.png differ diff --git a/images/hex2.png b/images/hex2.png new file mode 100644 Binary files /dev/null and b/images/hex2.png differ diff --git a/images/iX.png b/images/iX.png new file mode 100644 Binary files /dev/null and b/images/iX.png differ diff --git a/images/multi_ciX_noancilla.png b/images/multi_ciX_noancilla.png new file mode 100644 Binary files /dev/null and b/images/multi_ciX_noancilla.png differ diff --git a/images/multi_cnot_barenco.png b/images/multi_cnot_barenco.png new file mode 100644 Binary files /dev/null and b/images/multi_cnot_barenco.png differ diff --git a/images/phase.png b/images/phase.png new file mode 100644 Binary files /dev/null and b/images/phase.png differ diff --git a/images/quantum_and.png b/images/quantum_and.png new file mode 100644 Binary files /dev/null and b/images/quantum_and.png differ diff --git a/images/quantum_and_iX.png b/images/quantum_and_iX.png new file mode 100644 Binary files /dev/null and b/images/quantum_and_iX.png differ diff --git a/images/rGate.png b/images/rGate.png new file mode 100644 Binary files /dev/null and b/images/rGate.png differ diff --git a/images/spin1.png b/images/spin1.png new file mode 100644 Binary files /dev/null and b/images/spin1.png differ diff --git a/images/spin2.png b/images/spin2.png new file mode 100644 Binary files /dev/null and b/images/spin2.png differ diff --git a/images/toffoli_AMMR.png b/images/toffoli_AMMR.png new file mode 100644 Binary files /dev/null and b/images/toffoli_AMMR.png differ diff --git a/images/toffoli_NC.png b/images/toffoli_NC.png new file mode 100644 Binary files /dev/null and b/images/toffoli_NC.png differ diff --git a/images/toffoli_S.png b/images/toffoli_S.png new file mode 100644 Binary files /dev/null and b/images/toffoli_S.png differ diff --git a/images/toffoli_V.png b/images/toffoli_V.png new file mode 100644 Binary files /dev/null and b/images/toffoli_V.png differ diff --git a/images/weldedtree.png b/images/weldedtree.png new file mode 100644 Binary files /dev/null and b/images/weldedtree.png differ diff --git a/images/with_combined_controls1.png b/images/with_combined_controls1.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls1.png differ diff --git a/images/with_combined_controls2.png b/images/with_combined_controls2.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls2.png differ diff --git a/images/with_computed.png b/images/with_computed.png new file mode 100644 Binary files /dev/null and b/images/with_computed.png differ diff --git a/images/with_signed_qubit.png b/images/with_signed_qubit.png new file mode 100644 Binary files /dev/null and b/images/with_signed_qubit.png differ diff --git a/quipper-libraries.cabal b/quipper-libraries.cabal new file mode 100644 --- /dev/null +++ b/quipper-libraries.cabal @@ -0,0 +1,136 @@ +-- The name of the package. +name: quipper-libraries + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.9.0.0 + +-- A short (one-line) description of the package. +synopsis: The standard libraries for Quipper. + +-- A longer description of the package. +description: + + This package provides the standard libraries for Quipper, the + embedded functional programming language for quantum computing. + This includes libraries for quantum integer and fixed-point + arithmetic, decomposition into standard gate sets, the quantum + Fourier transform, simulation, among other things. + +-- URL for the project homepage or repository. +homepage: http://www.mathstat.dal.ca/~selinger/quipper/ + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: COPYRIGHT + +-- The package author(s). +author: Alexander S. Green, Peter LeFanu Lumsdaine, + Neil J. Ross, Peter Selinger, Benoît Valiron + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: selinger@mathstat.dal.ca + +-- A copyright notice. +copyright: Copyright (c) 2011-2019. All rights reserved. + +-- A classification category for future use by the package catalogue +-- Hackage. These categories have not yet been specified, but the +-- upper levels of the module hierarchy make a good start. +category: Quipper + +-- The type of build used by this package. +build-type: Custom + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >= 1.8 + +-- A list of additional files to be included in source distributions +-- built with setup sdist. +extra-source-files: images/*.png ChangeLog + +library + -- Modules exported by the library. + exposed-modules: + Quipper.Libraries.Arith + Quipper.Libraries.Decompose + Quipper.Libraries.Decompose.CliffordT + Quipper.Libraries.Decompose.GateBase + Quipper.Libraries.Decompose.Legacy + Quipper.Libraries.DynamicLiftings + Quipper.Libraries.GateDecompositions + Quipper.Libraries.FPReal + Quipper.Libraries.QFT + Quipper.Libraries.QFTAdd + Quipper.Libraries.Qram + Quipper.Libraries.QuantumIf + Quipper.Libraries.QuipperASCIIParser.Parse + Quipper.Libraries.QuipperASCIIParser.CircInfo + Quipper.Libraries.QuipperASCIIParser.ASCIICirc + Quipper.Libraries.QuipperASCIIParser + Quipper.Libraries.Qureg + Quipper.Libraries.Simulation + Quipper.Libraries.Simulation.ClassicalSimulation + Quipper.Libraries.Simulation.CliffordSimulation + Quipper.Libraries.Simulation.QuantumSimulation + Quipper.Libraries.Synthesis + Quipper.Libraries.Unboxing + Quipper.Libraries.ClassicalOptim.Circuit + Quipper.Libraries.ClassicalOptim.AlgExp + Quipper.Libraries.ClassicalOptim + Quipper.Libraries.ClassicalOptim.QuipperInterface + Quipper.Libraries.ClassicalOptim.Simplification + + -- Modules included in this library but not exported. + other-modules: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + containers >= 0.5.2.1, + mtl >= 2.1.2, + random >= 1.0.1.1, + newsynth >= 0.3.0.1, + deepseq >= 1.4, + quipper-utils >= 0.9.0.0, + quipper-language >= 0.9.0.0 + +test-suite quickcheck + type: exitcode-stdio-1.0 + main-is: Quipper/Libraries/ClassicalOptim/QuickCheckMain.hs + other-modules: + Quipper.Libraries.Arith + Quipper.Libraries.ClassicalOptim.Circuit + Quipper.Libraries.ClassicalOptim.QuickCheckArith + Quipper.Libraries.ClassicalOptim.QuickCheckAlgExp + Quipper.Libraries.ClassicalOptim.AlgExp + Quipper.Libraries.ClassicalOptim.QuickCheck + Quipper.Libraries.ClassicalOptim.QuipperInterface + Quipper.Libraries.ClassicalOptim.Simplification + Quipper.Libraries.Simulation + Quipper.Libraries.Simulation.ClassicalSimulation + Quipper.Libraries.Simulation.CliffordSimulation + Quipper.Libraries.Simulation.QuantumSimulation + + build-depends: + base, + containers, + mtl, + deepseq, + newsynth, + random, + QuickCheck >= 2.12.5, + quipper-utils >= 0.9.0.0, + quipper-language >= 0.9.0.0 + +custom-setup + setup-depends: base >= 4.5, + superdoc >= 0.1, + Cabal >= 1.24, + quipper-cabal >= 0.9.0.0