packages feed

quipper-libraries (empty) → 0.9.0.0

raw patch · 135 files changed

+22007/−0 lines, 135 filesdep +QuickCheckdep +basedep +containersbuild-type:Customsetup-changedbinary-added

Dependencies added: QuickCheck, base, containers, deepseq, mtl, newsynth, quipper-language, quipper-utils, random

Files

@@ -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.+----------------------------------------------------------------------
+ ChangeLog view
@@ -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.
+ Quipper/Libraries/Arith.hs view
@@ -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.+
+ Quipper/Libraries/ClassicalOptim.hs view
@@ -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+
+ Quipper/Libraries/ClassicalOptim/AlgExp.hs view
@@ -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+
+ Quipper/Libraries/ClassicalOptim/Circuit.hs view
@@ -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) ++ "\"")
+ Quipper/Libraries/ClassicalOptim/QuickCheck.hs view
@@ -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+
+ Quipper/Libraries/ClassicalOptim/QuickCheckAlgExp.hs view
@@ -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)++
+ Quipper/Libraries/ClassicalOptim/QuickCheckArith.hs view
@@ -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'+
+ Quipper/Libraries/ClassicalOptim/QuickCheckMain.hs view
@@ -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
+ Quipper/Libraries/ClassicalOptim/QuipperInterface.hs view
@@ -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)+
+ Quipper/Libraries/ClassicalOptim/Simplification.hs view
@@ -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)
+ Quipper/Libraries/Decompose.hs view
@@ -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
+ Quipper/Libraries/Decompose/CliffordT.hs view
@@ -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+-- >   <<<code using qs>>>+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+-- <http://arxiv.org/abs/1212.6253>. 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+-- <http://arxiv.org/abs/1212.6253>.  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
+ Quipper/Libraries/Decompose/GateBase.hs view
@@ -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++
+ Quipper/Libraries/Decompose/Legacy.hs view
@@ -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+
+ Quipper/Libraries/DynamicLiftings.hs view
@@ -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 ())+
+ Quipper/Libraries/FPReal.hs view
@@ -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
+ Quipper/Libraries/GateDecompositions.hs view
@@ -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 <http://arxiv.org/abs/1206.0758>.+-- +-- * 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 <http://arxiv.org/abs/quantph/9503016>.+-- +-- * P. Selinger, Quantum circuits of T-depth one,+-- /Physical Review A/ 87, 042302 (4 pages), 2013.+-- Also available from <http://arxiv.org/abs/1210.0974>.+-- +-- * B. Giles and P. Selinger, Exact synthesis of multiqubit+-- Clifford+T circuits, /Physical Review A/ 87, 032332 (7 pages),+-- 2013.  Also available from <http://arxiv.org/abs/1212.0506>.++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. (<http://arxiv.org/abs/1206.0758v3>, 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+-- <http://arxiv.org/abs/1210.0974> (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+-- (<http://arxiv.org/abs/1210.0974>, 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+-- (<http://arxiv.org/abs/1210.0974>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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 (<http://arxiv.org/abs/1210.0974>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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. (<http://arxiv.org/abs/1206.0758v3>,+-- 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.+-- (<http://arxiv.org/abs/quantph/9503016>, 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+-- (<http://arxiv.org/abs/1212.0506>, 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+-- >   <<<code using q>>>+-- +-- \[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
+ Quipper/Libraries/QFT.hs view
@@ -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)
+ Quipper/Libraries/QFTAdd.hs view
@@ -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)
+ Quipper/Libraries/Qram.hs view
@@ -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+-- >   <<<operate on x>>>+-- +-- 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
+ Quipper/Libraries/QuantumIf.hs view
@@ -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
+ Quipper/Libraries/QuipperASCIIParser.hs view
@@ -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
+ Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs view
@@ -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)
+ Quipper/Libraries/QuipperASCIIParser/CircInfo.hs view
@@ -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+
+ Quipper/Libraries/QuipperASCIIParser/Parse.hs view
@@ -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      +      +
+ Quipper/Libraries/Qureg.hs view
@@ -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 {+-- >   <<<code block using ancilla register r>>>+-- > }+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 ]
+ Quipper/Libraries/Simulation.hs view
@@ -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+
+ Quipper/Libraries/Simulation/ClassicalSimulation.hs view
@@ -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+
+ Quipper/Libraries/Simulation/CliffordSimulation.hs view
@@ -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
+ Quipper/Libraries/Simulation/QuantumSimulation.hs view
@@ -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         +
+ Quipper/Libraries/Synthesis.hs view
@@ -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
+ Quipper/Libraries/Unboxing.hs view
@@ -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)
+ Setup.hs view
@@ -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)]+  }
+ dist/build/Quipper/Libraries/Arith.hs view
@@ -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.+
+ dist/build/Quipper/Libraries/ClassicalOptim.hs view
@@ -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+
+ dist/build/Quipper/Libraries/ClassicalOptim/AlgExp.hs view
@@ -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+
+ dist/build/Quipper/Libraries/ClassicalOptim/Circuit.hs view
@@ -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) ++ "\"")
+ dist/build/Quipper/Libraries/ClassicalOptim/QuipperInterface.hs view
@@ -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)+
+ dist/build/Quipper/Libraries/ClassicalOptim/Simplification.hs view
@@ -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)
+ dist/build/Quipper/Libraries/Decompose.hs view
@@ -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
+ dist/build/Quipper/Libraries/Decompose/CliffordT.hs view
@@ -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+-- >   <<<code using qs>>>+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+-- <http://arxiv.org/abs/1212.6253>. 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+-- <http://arxiv.org/abs/1212.6253>.  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
+ dist/build/Quipper/Libraries/Decompose/GateBase.hs view
@@ -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++
+ dist/build/Quipper/Libraries/Decompose/Legacy.hs view
@@ -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+
+ dist/build/Quipper/Libraries/DynamicLiftings.hs view
@@ -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 ())+
+ dist/build/Quipper/Libraries/FPReal.hs view
@@ -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
+ dist/build/Quipper/Libraries/GateDecompositions.hs view
@@ -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 <http://arxiv.org/abs/1206.0758>.+-- +-- * 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 <http://arxiv.org/abs/quantph/9503016>.+-- +-- * P. Selinger, Quantum circuits of T-depth one,+-- /Physical Review A/ 87, 042302 (4 pages), 2013.+-- Also available from <http://arxiv.org/abs/1210.0974>.+-- +-- * B. Giles and P. Selinger, Exact synthesis of multiqubit+-- Clifford+T circuits, /Physical Review A/ 87, 032332 (7 pages),+-- 2013.  Also available from <http://arxiv.org/abs/1212.0506>.++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. (<http://arxiv.org/abs/1206.0758v3>, 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+-- <http://arxiv.org/abs/1210.0974> (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+-- (<http://arxiv.org/abs/1210.0974>, 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+-- (<http://arxiv.org/abs/1210.0974>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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 (<http://arxiv.org/abs/1210.0974>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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. (<http://arxiv.org/abs/1206.0758v3>, 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. (<http://arxiv.org/abs/1206.0758v3>,+-- 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.+-- (<http://arxiv.org/abs/quantph/9503016>, 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+-- (<http://arxiv.org/abs/1212.0506>, 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+-- >   <<<code using q>>>+-- +-- \[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
+ dist/build/Quipper/Libraries/QFT.hs view
@@ -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)
+ dist/build/Quipper/Libraries/QFTAdd.hs view
@@ -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)
+ dist/build/Quipper/Libraries/Qram.hs view
@@ -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+-- >   <<<operate on x>>>+-- +-- 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
+ dist/build/Quipper/Libraries/QuantumIf.hs view
@@ -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
+ dist/build/Quipper/Libraries/QuipperASCIIParser.hs view
@@ -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
+ dist/build/Quipper/Libraries/QuipperASCIIParser/ASCIICirc.hs view
@@ -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)
+ dist/build/Quipper/Libraries/QuipperASCIIParser/CircInfo.hs view
@@ -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+
+ dist/build/Quipper/Libraries/QuipperASCIIParser/Parse.hs view
@@ -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      +      +
+ dist/build/Quipper/Libraries/Qureg.hs view
@@ -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 {+-- >   <<<code block using ancilla register r>>>+-- > }+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 ]
+ dist/build/Quipper/Libraries/Simulation.hs view
@@ -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+
+ dist/build/Quipper/Libraries/Simulation/ClassicalSimulation.hs view
@@ -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+
+ dist/build/Quipper/Libraries/Simulation/CliffordSimulation.hs view
@@ -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
+ dist/build/Quipper/Libraries/Simulation/QuantumSimulation.hs view
@@ -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         +
+ dist/build/Quipper/Libraries/Synthesis.hs view
@@ -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
+ dist/build/Quipper/Libraries/Unboxing.hs view
@@ -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)
+ images/CosetState.png view

binary file changed (absent → 3311 bytes)

+ images/E.png view

binary file changed (absent → 1496 bytes)

+ images/ERot_phase.png view

binary file changed (absent → 1572 bytes)

+ images/ERot_zx.png view

binary file changed (absent → 3957 bytes)

+ images/G.png view

binary file changed (absent → 1738 bytes)

+ images/GateR.png view

binary file changed (absent → 3363 bytes)

+ images/Rz.png view

binary file changed (absent → 1963 bytes)

+ images/T.png view

binary file changed (absent → 1561 bytes)

+ images/V.png view

binary file changed (absent → 1804 bytes)

+ images/W.png view

binary file changed (absent → 2532 bytes)

+ images/Y.png view

binary file changed (absent → 1360 bytes)

+ images/adder-optimized.png view

binary file changed (absent → 4858 bytes)

+ images/adder-unoptimized.png view

binary file changed (absent → 8371 bytes)

+ images/b0-template.png view

binary file changed (absent → 887 bytes)

+ images/b1-template.png view

binary file changed (absent → 5013 bytes)

+ images/b2-orthodox.png view

binary file changed (absent → 5628 bytes)

+ images/b2-template.png view

binary file changed (absent → 1304 bytes)

+ images/b3-template.png view

binary file changed (absent → 7265 bytes)

+ images/b4-template.png view

binary file changed (absent → 13792 bytes)

+ images/cH_AMMR.png view

binary file changed (absent → 1544 bytes)

+ images/ccZ_AMMR.png view

binary file changed (absent → 2929 bytes)

+ images/ccZ_S.png view

binary file changed (absent → 7580 bytes)

+ images/cc_iX.png view

binary file changed (absent → 3038 bytes)

+ images/cc_iX_S.png view

binary file changed (absent → 3642 bytes)

+ images/cc_iX_simple.png view

binary file changed (absent → 2484 bytes)

+ images/contfrac.png view

binary file changed (absent → 1151 bytes)

+ images/controlled-phase-decomp.png view

binary file changed (absent → 1433 bytes)

+ images/controlled-zrot.png view

binary file changed (absent → 1940 bytes)

+ images/controlled_E.png view

binary file changed (absent → 2085 bytes)

+ images/controlled_S.png view

binary file changed (absent → 1308 bytes)

+ images/controlled_T.png view

binary file changed (absent → 4450 bytes)

+ images/controlled_V.png view

binary file changed (absent → 1716 bytes)

+ images/controlled_W.png view

binary file changed (absent → 4991 bytes)

+ images/controlled_YY.png view

binary file changed (absent → 1878 bytes)

+ images/controlled_iX.png view

binary file changed (absent → 963 bytes)

+ images/controlled_phase.png view

binary file changed (absent → 1551 bytes)

+ images/coord.png view

binary file changed (absent → 14953 bytes)

+ images/dashed-cnot-bwd.png view

binary file changed (absent → 2436 bytes)

+ images/dashed-cnot-fwd.png view

binary file changed (absent → 2433 bytes)

+ images/decompose2Controls.png view

binary file changed (absent → 3058 bytes)

+ images/decomposeControls.png view

binary file changed (absent → 4290 bytes)

+ images/def_f.png view

binary file changed (absent → 4864 bytes)

+ images/def_g.png view

binary file changed (absent → 3545 bytes)

+ images/def_g1.png view

binary file changed (absent → 1268 bytes)

+ images/def_h.png view

binary file changed (absent → 2669 bytes)

+ images/expDA.png view

binary file changed (absent → 2247 bytes)

+ images/floor.png view

binary file changed (absent → 1738 bytes)

+ images/floor2.png view

binary file changed (absent → 1002 bytes)

+ images/fredkin.png view

binary file changed (absent → 3523 bytes)

+ images/gate_W_CliffordT.png view

binary file changed (absent → 2403 bytes)

+ images/hex-coord.png view

binary file changed (absent → 12639 bytes)

+ images/hex1.png view

binary file changed (absent → 19618 bytes)

+ images/hex2.png view

binary file changed (absent → 6734 bytes)

+ images/iX.png view

binary file changed (absent → 1318 bytes)

+ images/multi_ciX_noancilla.png view

binary file changed (absent → 4358 bytes)

+ images/multi_cnot_barenco.png view

binary file changed (absent → 5276 bytes)

+ images/phase.png view

binary file changed (absent → 1167 bytes)

+ images/quantum_and.png view

binary file changed (absent → 1152 bytes)

+ images/quantum_and_iX.png view

binary file changed (absent → 913 bytes)

+ images/rGate.png view

binary file changed (absent → 1664 bytes)

+ images/spin1.png view

binary file changed (absent → 2436 bytes)

+ images/spin2.png view

binary file changed (absent → 3399 bytes)

+ images/toffoli_AMMR.png view

binary file changed (absent → 3310 bytes)

+ images/toffoli_NC.png view

binary file changed (absent → 3209 bytes)

+ images/toffoli_S.png view

binary file changed (absent → 7982 bytes)

+ images/toffoli_V.png view

binary file changed (absent → 1768 bytes)

+ images/weldedtree.png view

binary file changed (absent → 8963 bytes)

+ images/with_combined_controls1.png view

binary file changed (absent → 4107 bytes)

+ images/with_combined_controls2.png view

binary file changed (absent → 3598 bytes)

+ images/with_computed.png view

binary file changed (absent → 5029 bytes)

+ images/with_signed_qubit.png view

binary file changed (absent → 1052 bytes)

+ quipper-libraries.cabal view
@@ -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