diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,66 @@ +Contributors are listed here, in alphabetical order by last name. +Unless otherwise noted, the copyright for his or her contributions +rests with each individual author. For contributions by authors whose +name is marked (ACS), the copyright rests with Applied Communication +Sciences. + +Copyright (C) 2011-2019. All rights reserved. +Copyright (C) 2012-2013 Applied Communication Sciences. All rights +reserved. + +Richard Eisenberg +Alexander S. Green +Peter LeFanu Lumsdaine +Keith Kim (ACS) +Siun-Chuon Mau (ACS) +Baranidharan Mohan +Won Ng (ACS) +Joel Ravelomanantsoa-Ratsimihah +Neil J. Ross +Artur Scherer (ACS) +Peter Selinger +Benoît Valiron +Alexandr Virodov (ACS) +Stephan A. Zdancewic + +This research was supported by the Intelligence Advanced Research +Projects Activity (IARPA) via Department of Interior National Business +Center contract numbers D11PC20168 and D12PC00527. The U.S. Government +is authorized to reproduce and distribute reprints for Governmental +purposes notwithstanding any copyright annotation thereon. Disclaimer: +The views and conclusions contained herein are those of the authors +and should not be interpreted as necessarily representing the official +policies or endorsements, either expressed or implied, of IARPA, +DoI/NBC, or the U.S. Government. + +---------------------------------------------------------------------- +LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. The name of the authors and copyright holders may not be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +---------------------------------------------------------------------- diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,76 @@ +December 29, 2019: Release 0.9.0.0 + + * Overhauled module structure: + + Old: New: + ==== ==== + + Quipper.XYZ Quipper.Internal.XYZ + QuipperLib.XYZ Quipper.Libraries.XYZ + Libraries.XYZ Quipper.Utils.XYZ + Algorithms.XYZ Quipper.Algorithms.XYZ + tests Quipper.Demos + Programs Quipper.Programs + + * Re-packaged Quipper as Cabal packages. Added executables quipper, + quipper-pp, quipperi, quipperdoc in lieu of shell scripts. + * Moved PDF Previewer to a separate library in Quipper.Utils.Preview + * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy + * Use type class synonyms to avoid warnings about simplifiable class. + * Compatibility: removed obsolete functoin Map.insertWith'. + * Added MultiControlledNot demo. + * Removed dependency on set-monad, which is broken upstream. + * Fixed some bugs in the stabilizer simulation. + * Moved QuantumIf from BF to Libraries. + * Added --help option to all Quipper tools. + * Removed Quipper.Utils.ShowAll + * Fixed some compiler errors and removed some unnecessary type class + assumptions. + +July 27, 2016: Release 0.8 + + * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too + broken and will not be supported by Quipper. + * Added tests/SimulationTest + * Added QPrep and QUnPrep to the simulator + +October 14, 2014: Release 0.7 + + * Portability: compatibility fixes for GHC 7.8. + +January 16, 2014: Release 0.6 + + * Minor edits and documentation updates. + * Added a new gate gate_iX_inv + * Added "alternate" version of synthesis algorithm, using only + generators of determinant 1 if possible. + * Synthesis code is now in an external package "newsynth". + * Rendering code is now in an external package "easyrender". + * Updated for use with fixedprec-0.2.1.0. + +September 2, 2013: Release 0.5 + + * Portability: compatibility fixes for GHC 7.6.2. + * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C + may or may not work on Windows, depending on console. + * Added quipperi script, analogous to ghci. + * New library QuipperLib.ClassicalOptim: algebraic optimization of + auto-generated classical circuits. Added "optimized" oracle to BWT + algorithm. + * QuipperLib.Decompose: Added decomposition into a "standard" gate + set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT. + Added KeepPhase flag to some transformers. + * QuipperLib.GateDecompositions: added more gates. + * New library Libraries.Synthesis.RotationDecomposition: implements a + variant of the algorithm from Nielsen and Chuang to decompose an + nxn unitary operator into one- and two-level rotations. + * New library QuipperLib.Unboxing: unboxing transformers. + * Updated ASCII output format; improved circuit parser efficiency. + * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits, + floorlog. + * Fixed handling of iterated subroutines in depth transformer. + * Documentation updates and minor refactoring. + +June 19, 2013: Release 0.4 + + * First public release. diff --git a/Quipper.hs b/Quipper.hs new file mode 100644 --- /dev/null +++ b/Quipper.hs @@ -0,0 +1,529 @@ +-- | This is the main export module for Quipper, collecting everything +-- that Quipper applications need. This is Quipper's \"public\" +-- interface. + +module Quipper ( + -- * The Circ monad + Circ(..), + + -- * Basic types + Qubit, + Bit, + Qulist, + Bitlist, + + -- * Basic gates + -- $BASIC + Timestep, + + -- $FUNCTIONAL_ANCHOR + + -- ** Reversible gates in functional style + -- $FUNCTIONAL + qnot, + hadamard, + gate_H, + gate_X, + gate_Y, + gate_Z, + gate_S, + gate_S_inv, + gate_T, + gate_T_inv, + gate_E, + gate_E_inv, + gate_omega, + gate_V, + gate_V_inv, + expZt, + rGate, + gate_W, + gate_iX, + gate_iX_inv, + global_phase, + global_phase_anchored, + qmultinot, + cnot, + swap, + + -- $IMPERATIVE_ANCHOR + + -- ** Reversible gates in imperative style + -- $IMPERATIVE + qnot_at, + hadamard_at, + gate_H_at, + gate_X_at, + gate_Y_at, + gate_Z_at, + gate_S_at, + gate_S_inv_at, + gate_T_at, + gate_T_inv_at, + gate_E_at, + gate_E_inv_at, + gate_omega_at, + gate_V_at, + gate_V_inv_at, + expZt_at, + rGate_at, + gate_W_at, + gate_iX_at, + gate_iX_inv_at, + qmultinot_at, + cnot_at, + swap_at, + + -- ** Gates for state preparation and termination + qinit, + qterm, + qdiscard, + cinit, + cterm, + cdiscard, + qc_init, + qc_init_with_shape, + qc_term, + qc_discard, + measure, + prepare, + qc_measure, + qc_prepare, + + -- ** Gates for classical circuits + -- $CLASSICAL + cgate_xor, + cgate_eq, + cgate_not, + cgate_and, + cgate_or, + cgate_if, + circ_if, + + -- ** User-defined gates + named_gate, + named_gate_at, + named_rotation, + named_rotation_at, + extended_named_gate, + extended_named_gate_at, + + -- ** Dynamic lifting + dynamic_lift, + + -- * Other circuit-building functions + qinit_plusminus, + qinit_of_char, + qinit_of_string, + map_hadamard, + map_hadamard_at, + controlled_not, + controlled_not_at, + bool_controlled_not, + bool_controlled_not_at, + qc_copy, + qc_uncopy, + qc_copy_fun, + qc_uncopy_fun, + mapUnary, + mapBinary, + mapBinary_c, + qc_mapBinary, + + -- * Notation for controls + -- $CONTROLS + ControlSource(..), + ControlList, + (.&&.), + (.==.), + (./=.), + controlled, + + -- * Signed items + Signed(..), + from_signed, + get_sign, + + -- * Comments and labelling + comment, + label, + comment_with_label, + without_comments, + Labelable, + + -- * Hierarchical circuits + box, + nbox, + box_loopM, + loopM_boxed_if, + + -- * Block structure + -- $BLOCK + + -- ** Ancillas + -- $WITHANCILLA + with_ancilla, + with_ancilla_list, + with_ancilla_init, + -- ** Automatic uncomputing + with_computed_fun, + with_computed, + with_basis_change, + -- ** Controls + with_controls, + with_classical_control, + without_controls, + without_controls_if, + -- ** Loops + for, + endfor, + foreach, + loop, + loop_with_index, + loopM, + loop_with_indexM, + + -- * Operations on circuits + -- ** Reversing + reverse_generic, + reverse_simple, + reverse_generic_endo, + reverse_generic_imp, + reverse_generic_curried, + reverse_simple_curried, + reverse_endo_if, + reverse_imp_if, + + -- ** Printing + Format (..), + FormatStyle(..), + format_enum, + print_unary, + print_generic, + print_simple, + print_of_document, + print_of_document_custom, + + -- ** Classical circuits + classical_to_cnot, + classical_to_quantum, + -- ** Ancilla uncomputation + classical_to_reversible, + + -- * Circuit transformers + -- $TRANSFORMATION + + -- ** User-definable transformers + Transformer, + T_Gate(..), + -- ** Pre-defined transformers + identity_transformer, + -- ** An example transformer + -- $TRANSEXAMPLE + + -- ** Applying transformers to circuits + transform_generic, + transform_generic_shape, + + -- ** Auxiliary type definitions + InverseFlag, + NoControlFlag, + B_Endpoint(..), + Endpoint, + Ctrls, + + -- * Automatic circuit generation from classical code + -- $TEMPLATE + module Quipper.Internal.CircLifting, + module Quipper.Utils.Template, + + -- * Extended quantum data types + -- ** Homogeneous quantum data types + QShape, + QData, + CData, + BData, + + -- ** Heterogeneous quantum data types + QCData, + QCDataPlus, + + -- ** Shape-related operations + -- $SHAPE + bit, + qubit, + qshape, + qc_false, + + -- ** Quantum type classes + -- $QCLASSES + QEq (..), + q_is_equal, + q_is_not_equal, + + QOrd (..), + q_lt, + q_gt, + q_le, + q_ge, + + ) where + + +import Quipper.Internal.Monad +import Quipper.Internal.Generic +import Quipper.Internal.QData +import Quipper.Internal.QClasses +import Quipper.Internal.Control +import Quipper.Internal.CircLifting +import Quipper.Internal.Transformer (T_Gate(..), Transformer, Ctrls, B_Endpoint(..)) +import Quipper.Internal.Circuit (InverseFlag, NoControlFlag, from_signed, get_sign) +import Quipper.Internal.Classical +import Quipper.Internal.Printing +import Quipper.Internal.Labels + +import Quipper.Utils.Template +import Quipper.Utils.Auxiliary + +-- $BASIC +-- +-- This section contains various elementary gates that can be used as +-- building blocks for constructing circuits. + +-- $FUNCTIONAL_ANCHOR #FUNCTIONAL# + +-- $FUNCTIONAL +-- +-- The gates in this section are in \"functional\" style, which means +-- that they return something. For example, the 'qnot' gate consumes a +-- 'Qubit', performs an operation, and outputs a new 'Qubit'. The +-- gates should be used like this: +-- +-- > output <- qnot input +-- +-- or, for a binary gate: +-- +-- > (out0, out1) <- gate_W in0 in1 +-- +-- For each of these gates, we also provide a version in imperative +-- style, see <#IMPERATIVE Reversible gates in imperative style> below. + +-- $IMPERATIVE_ANCHOR #IMPERATIVE# + +-- $IMPERATIVE +-- +-- The gates in this section are in \"imperative\" style, which means +-- that they operate on a qubit \"in place\" and do not return +-- anything. The gates should be used like this: +-- +-- > qnot_at q +-- +-- or, for a binary gate: +-- +-- > gate_W_at q0 q1 +-- +-- For each of these gates, we also provide a version in functional +-- style, see <#FUNCTIONAL Reversible gates in functional style> above. + +-- * Snippets of additional documentation lifted from import modules: + +-- $CLASSICAL +-- +-- The gates in this section are for constructing classical circuits. +-- None of these gates alter or discard their inputs; each gate produces +-- a new wire holding the output of the gate. + +-- $CONTROLS +-- +-- Some gates can be controlled by a condition involving one of more +-- \"control\" qubits and/or classical bits at circuit execution time. +-- Such gates can also be controlled by boolean conditions that are +-- known at circuit generation time (in which case the gate will not +-- be generated when the control condition is false). This section +-- provides a convenient and flexible syntax for specifying controls. +-- +-- In Quipper, controls can be written in a way that is +-- reminiscent of (a restricted set of) ordinary boolean +-- expressions. Here are some examples: +-- +-- > q1 .==. 0 .&&. q2 .==. 1 for Qubits q1, q2 +-- +-- > q .&&. p means q .==. 1 .&&. p .==. 1 +-- +-- > qx .==. 5 for a QDInt qx +-- +-- > q1 .==. 0 .&&. z <= 7 combines quantum and classical controls +-- +-- > q ./=. b the negation of q .==. b; +-- > here b is a boolean. +-- +-- > [p,q,r,s] a list of positive controls +-- +-- > [(p, True), (q, False), (r, False), (s, True)] +-- > a list of positive and negative controls +-- +-- Among these infix operators, @(.&&.)@ binds more weakly than +-- @(.==.)@, @(./=.)@. +-- +-- Controls can be attached to a gate by means of the infix +-- operator 'controlled': +-- +-- > gate `controlled` <> + +-- $BLOCK +-- +-- The following are higher-order functions that provide a way to +-- structure quantum programs into blocks. A block can contain local +-- ancillas or local controls. + +-- $WITHANCILLA The use of the 'with_ancilla' family of operators is +-- preferable to using 'qinit' and 'qterm' directly. In particular, it +-- is possible to add controls to a block created with one of the +-- 'with_ancilla' family of operators, whereas 'qinit' and 'qterm', +-- when used individually, cannot be controlled. + +-- $TEMPLATE +-- +-- The following two modules provide functions that are useful for +-- automatic circuit generation from classical code. Please see +-- "Quipper.Internal.CircLifting" for a more detailed explanation of how to use +-- this feature. + +-- $TRANSFORMATION +-- +-- Transformers are a very general way of defining mappings over +-- circuits. Possible uses of this include: +-- +-- * gate transformations, where a whole circuit is transformed by +-- replacing each kind of gate with another gate or circuit; +-- +-- * error correcting codes, where a whole circuit is transformed +-- replacing each qubit by some fixed number of qubits, and each gate +-- by a circuit; and +-- +-- * simulations, where a whole circuit is mapped to a semantic +-- function by specifying a semantic function for each gate. +-- +-- The interface is designed to allow the programmer to specify new +-- transformers easily. To define a specific transformation, the +-- programmer has to specify only three pieces of information: +-- +-- * Types /a/=⟦Qubit⟧ and /b/=⟦Bit⟧, to serve as semantic domains. +-- +-- * A monad /m/. This is to allow translations to have side effects +-- if desired; one can use the identity monad otherwise. +-- +-- * For every gate /G/, a corresponding semantic function ⟦/G/⟧. The +-- type of this function depends on what kind of gate /G/ is. For example: +-- +-- @ +-- If /G/ :: Qubit -> Circ Qubit, then ⟦/G/⟧ :: /a/ -> /m/ /a/. +-- If /G/ :: (Qubit, Bit) -> Circ (Bit, Bit), then ⟦/G/⟧ :: (/a/, /b/) -> /m/ (/b/, /b/). +-- @ +-- +-- The programmer provides this information by defining a function of +-- type 'Transformer' /m/ /a/ /b/, see below. Once a +-- particular transformer has been defined, it can then be applied to +-- entire circuits. For example, for a circuit with 1 inputs and 2 +-- outputs: +-- +-- @ +-- If /C/ :: Qubit -> (Qubit, Qubit), then ⟦/C/⟧ :: /a/ -> /m/ (/a/, /a/). +-- @ + +-- $TRANSEXAMPLE +-- +-- The following is a short but complete example of how to write and +-- use a simple transformer. As usual, we start by importing Quipper: +-- +-- > import Quipper +-- +-- We will write a transformer called @sample_transformer@, which maps +-- every swap gate to a sequence of three controlled-not gates, and +-- leaves all other gates unchanged. For convenience, Quipper +-- pre-defines an 'identity_transformer', which can be used as a +-- catch-all clause to take care of all the gates that don't need to +-- be rewritten. +-- +-- > mytransformer :: Transformer Circ Qubit Bit +-- > mytransformer (T_QGate "swap" 2 0 _ ncf f) = f $ +-- > \[q0, q1] [] ctrls -> do +-- > without_controls_if ncf $ do +-- > with_controls ctrls $ do +-- > qnot_at q0 `controlled` q1 +-- > qnot_at q1 `controlled` q0 +-- > qnot_at q0 `controlled` q1 +-- > return ([q0, q1], [], ctrls) +-- > mytransformer g = identity_transformer g +-- +-- Note how Quipper syntax has been used to define the replacement +-- circuit @new_swap@, consisting of three controlled-not gates. Also, +-- since the original swap gate may have been controlled, we have +-- added the additional controls with a 'with_controls' +-- operator. Finally, the 'without_controls_if' operator ensures that +-- if the 'NoControlFlag' is set on the original swap gate, then it +-- will also be set on the replacement circuit. +-- +-- To try this out, we define some random circuit using swap gates: +-- +-- > mycirc a b c d = do +-- > swap_at a b +-- > hadamard_at b +-- > swap_at b c `controlled` [a, d] +-- > hadamard_at c +-- > swap_at c d +-- +-- To apply the transformer to this circuit, we use the generic +-- operator 'transform_generic': +-- +-- > mycirc2 = transform_generic mytransformer mycirc +-- +-- Finally, we use a @main@ function to display the original circuit +-- and then the transformed one: +-- +-- > main = do +-- > print_simple Preview mycirc +-- > print_simple Preview mycirc2 + +-- $QCLASSES +-- +-- Haskell provides many convenient type classes: 'Eq', 'Ord', 'Num', etc. +-- Quipper provides quantum analogues of some of these. +-- For instance, Haskell’s @'Eq' a@ has the method +-- +-- > (==) :: a -> a -> Bool. +-- +-- Correspondingly, our @'QEq' a qa ca@ has a method +-- +-- > q_is_equal :: qa -> qa -> Circ (qa,qa,Qubit). +-- +-- Similarly, where Haskell’s 'Num' class has methods '+', '*', +-- 'signum', the class 'Quipper.Libraries.Arith.QNum' has +-- 'Quipper.Libraries.Arith.q_add', 'Quipper.Libraries.Arith.q_mult', +-- 'Quipper.Libraries.Arith.q_signum', and so on. +-- ('Quipper.Libraries.Arith.QNum' is defined in +-- "Quipper.Libraries.Arith".) +-- +-- All quantum type classes assume (a) that their instance types are +-- 'QCData', and (b) that the corresponding classical parameter types +-- are instances of the corresponding Haskell type classes. +-- +-- Quantum type classes are designed to work well with the automatic +-- circuit generation of "Quipper.Internal.CircLifting": the methods of +-- Haskell’s standard type classes are translated into their quantum +-- analogues, where available. + +-- $SHAPE Some Quipper functions, such as 'print_generic', require a +-- /shape parameter/. A shape parameter is a parameter passed to a +-- function for the sole purpose of specifying the type or size of +-- some data structure, without actually specifying any data. +-- Example: given a circuit +-- +-- > circuit :: ([Qubit], Bit) -> Circ Qubit, +-- +-- the command +-- +-- > print_generic Preview circuit ([qubit,qubit,qubit], bit) +-- +-- tells Quipper to preview the circuit for a problem size of 3 qubits +-- and 1 bit. diff --git a/Quipper/Internal.hs b/Quipper/Internal.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal.hs @@ -0,0 +1,45 @@ +-- | This module exposes interfaces that are internal to Quipper, and +-- are not intended for use by user-level code, but may be useful in +-- libraries that extend Quipper's functionality. +-- +-- This module must not be imported directly by user-level code. It +-- may, however, be imported by libraries. A typical use of this +-- module is in a library that defines a new kind of 'QCData'. + +module Quipper.Internal ( + -- * Quantum data + -- $QData + module Quipper.Internal.QData, + -- * Currying + QCurry(..), + -- * Error handlers + ErrMsg, + -- * The Labelable class + Labelable (..), + with_index, + with_dotted_index, + indexed, + dotted_indexed, + -- * Functions for IntMaps + intmap_zip, + intmap_zip_errmsg, + intmap_map, + intmap_mapM, + -- * Identity types + Identity, + reflexivity, + symmetry, + transitivity, + identity, + ) where + +import Quipper.Utils.Auxiliary +import Quipper.Internal.QData +import Quipper.Internal.Labels +import Quipper.Internal.Generic + +-- $QData +-- +-- The module "Quipper.Internal.QData" provides type classes for dealing with +-- various "shaped" quantum and classical data structures. Please see +-- "Quipper.Internal.QData" for documentation. diff --git a/Quipper/Internal/CircLifting.hs b/Quipper/Internal/CircLifting.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/CircLifting.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides a user-friendly interface to building +-- quantum circuits out of classical functions on booleans. It is +-- based on lower-level functionality provided by +-- "Quipper.Utils.Template". +-- +-- Technically, the only functions to be used in this module are +-- @'decToCircMonad'@, a specialized version of @'decToMonad'@, and +-- @'unpack'@. The only useful datatype here is @'BoolParam'@. +-- +-- One should not have to directly use the other things: they are only +-- for the internal use of Template Haskell to build quantum circuits +-- out of classical computation on booleans. +-- +-- Note: in the following, we write circuits in ASCII form. The +-- following conventions are used. They are extended in obvious ways +-- when applicable (e.g. when writing a ternary gate). +-- +-- > ---- : wire +-- > +-- > 0 |-- : initialize an ancilla |0> +-- > +-- > --| 0 : terminate an ancilla, asserting it was |0> +-- > +-- > +--+ +-- > -| |- : a unary gate +-- > +--+ +-- > +-- > +--+ +-- > -| |- +-- > | | : a binary gate +-- > -| |- +-- > +--+ +-- > +-- > -- -- +-- > X : swap gate +-- > -- -- +-- > +-- > --x-- +-- > | : controlled-not, applying NOT on the bottom wire if the top one is |1> +-- > --N-- +-- > +-- > --o-- +-- > | : controlled-not, applying NOT on the bottom wire if the top one is |0> +-- > --N-- + +-- NOTE: They are only available because Template Haskell requires +-- them to be in a separate module and exported. + +module Quipper.Internal.CircLifting ( + -- * Overview + -- $ROLE + + -- * A type of boolean parameters + -- $BOOLPARAM + BoolParam(PTrue,PFalse), + newBool, + template_PFalse, + template_PTrue, + + -- * Lifting classical functions to circuits + -- $TH + decToCircMonad, + +-- $BUILDTEMPLATE_ANCHOR #build_circuit# + + -- * Syntactic sugar + -- $BUILDTEMPLATE + + + -- * Circuits for specific operations + -- ** Boolean parameters + + template_newBool, + + -- ** Boolean constants + template_False, + template_True, + -- ** Unary boolean operations + template_not, + -- ** Binary boolean operations + template_symb_ampersand_symb_ampersand_, + template_symb_vbar_symb_vbar_, + template_bool_xor, + -- ** The if-then-else operation + -- $IF + template_if, + -- ** Equality test + template_symb_equal_symb_equal_, + + -- * Generic unpacking + CircLiftingUnpack(..) + +) where + +import Prelude +import Data.Map as Map +import qualified Data.List + +import Quipper.Internal.Monad +import qualified Quipper.Internal.Monad +import Quipper.Internal.Circuit +import Quipper.Internal.Generic +import Quipper.Internal.QData +import Quipper.Utils.Auxiliary (list_of_blist,blist_empty) +import Quipper.Internal.Control +import Quipper.Internal.QClasses + +import Quipper.Utils.Template + + + +---------------------------------------------------------------------- +-- * Overview + +-- $ROLE Using the tool @'decToMonad'@ designed in "Quipper.Utils.Template", we +-- can easily generate quantum circuits. Indeed, suppose that we are given the classical oracle +-- +-- > toyOracle :: Bool -> Bool +-- > toyOracle a = f (g a) (h a) +-- +-- for some @g,h :: Bool -> Bool@ and @f :: Bool -> Bool -> Bool@. If +-- /g/ and /h/ are given by quantum circuits of the form +-- +-- > +-----+ +-- > input ---| |-- input wire, assumed to be not modified by the box +-- > | | +-- > 0 |-| |--- output (was ancilla wire) +-- > +-----+ +-- +-- and if /f/ is given by +-- +-- > +-----+ +-- > input ---| |-- was input 1, assumed to be not modified +-- > | | +-- > input ---| |-- was input 2, assumed to be not modified +-- > | | +-- > 0 |--| |-- output (was ancilla wire), +-- > +-----+ +-- +-- we can compositionally generate a circuit @C@ for /toyOracle/ as follows. +-- +-- > +---+ +---+ +-- > input ---| |-- -----------------| |-- (output of g) +-- > | g | X +---+ | | +-- > 0 |--| |-- --| |--- ------| f |-- (output of h) +-- > +---+ | h | X | | (I) +-- > 0 |------------| |--- - ----| |-- (output of f) +-- > +---+ X +---+ +-- > 0 |- ----------- (input of g) +-- > +-- +-- Note that the resulting circuit is a classical, reversible circuit +-- (more precisely, the circuit defines a one-to-one function). In +-- order to obtain a reversible quantum circuit, one should then apply +-- the function @'Quipper.Internal.Classical.classical_to_reversible'@ to get the following (we +-- keep the same convention of wires as in the definition of @C@): +-- +-- > +---+ +---+ +-- > input--| |-----| |-- still the input +-- > | | | | +-- > 0 |--| |-----| |--| 0 +-- > | C | | D | (II) +-- > 0 |--| |--x--| |--| 0 +-- > | | | | | +-- > 0 |--| |--|--| |--| 0 +-- > +---+ | +---+ +-- > | +-- > output wire---N--------------. +-- +-- Here @D@ is the inverse of @C@. We now have a circuit of the +-- canonical form, computing and then uncomputing its ancillas: +-- +-- > +-----------+ +-- > a --| |- a +-- > | toyOracle | +-- > z --| |- z + (f (g a) (h a)) +-- > +-----------+ +-- +---------------------------------------------------------------------- +-- * A type of boolean parameters + +-- $BOOLPARAM During the construction of a quantum circuit from +-- classical code, the type 'Bool' is mapped to the type +-- 'Qubit'. However, it is also sometimes useful to specify boolean +-- parameters to be used during circuit generation (for example, in +-- the BWT algorithm, the color is a parameter). For this purpose, we +-- provide a new type 'BoolParam', which is identical to 'Bool' in +-- most respects, except that it is not mapped to 'Qubit' during +-- circuit generation. + +-- | A custom-design boolean type, not modified by circuit generation. +data BoolParam = PTrue | PFalse + deriving (Eq, Show) + +-- | Type-cast from BoolParam to Bool +newBool :: BoolParam -> Bool +newBool PTrue = True +newBool PFalse = False + + +-- | Lifted version of PFalse. +template_PFalse :: Circ BoolParam +template_PFalse = return PFalse + +-- | Lifted version of PTrue. +template_PTrue :: Circ BoolParam +template_PTrue = return PTrue + + +---------------------------------------------------------------------- +-- * Lifting classical functions to circuits + +-- $TH The main tool for transforming a classical computation into a +-- quantum circuit is the function @'decToCircMonad'@. It inputs the +-- syntax tree of a classical function, and outputs the syntax tree of +-- a corresponding quantum circuit. The type 'Bool' is mapped to +-- 'Qubit'; the type 'BoolParam' is unchanged; and each function /f/ : +-- /a/ → /b/ is mapped to a function /f'/ : /a'/ → 'Circ' /b'/, +-- where /a'/ and /b'/ are the translations of the types /a/ and /b/, +-- respectively. +-- +-- Most of the work is done by the lower-level function +-- @'decToMonad'@ from the module "Quipper.Utils.Template". +-- This lower-level function knows how to deal with many usual +-- constructs of the Haskell language, such as function applications, +-- lambda-abstractions, let-assignments, case-distinctions, and so +-- on. However, @'decToMonad'@ does not by default know how to deal +-- with the base cases, i.e., how to extract quantum circuits from +-- specific term constants such as @'&&'@, @'||'@, etc. +-- +-- The purpose of the remainder of this module is to do just that. For +-- every constant or function @XXX@ that one may want to use in a +-- classical program, we provide an implementation @template_XXX@ as a +-- quantum circuit. We refer to @template_XXX@ as the \"lifted\" +-- version of @XXX@. The function @'decToCircMonad'@ is a version of +-- @'decToMonad'@ that knows about these liftings. + + + +-- | Input the syntax tree of a classical function, and output the +-- syntax tree of a corresponding quantum function. The type 'Bool' is +-- mapped to 'Qubit'; the type 'BoolParam' is unchanged; and and each +-- function /f/ : /a/ → /b/ is mapped to a function /f'/ : /a'/ → +-- 'Circ' /b'/, where /a'/ and /b'/ are the translations of the types +-- /a/ and /b/, respectively. The function 'decToCircMonad' knows +-- about many built-in operations such as @'&&'@ and @'||'@, whose +-- circuit translations are defined below. +decToCircMonad :: Q [Dec] -> Q [Dec] +decToCircMonad x = decToMonad "Circ" x + +-- $BUILDTEMPLATE_ANCHOR #build_circuit# + +--------------------------------------------------------------------- +-- * Syntactic sugar + +-- $BUILDTEMPLATE Quipper comes equipped with syntactic sugar to ease +-- the use of the @'decToCircMonad'@ function. +-- +-- Although the code +-- +-- > $( decToCircMonad [d| f x = ... |] ) +-- +-- is valid, it is possible to use the special keyword +-- @build_circuit@, as follows: +-- +-- > build_circuit +-- > f x = ... +-- +-- This code is equivalent to +-- +-- > f x = ... +-- > $( decToCircMonad [d| f x = ... |] ) +-- +-- In other words, it generates both a function @f@ of type @a -> ...@ +-- and an object @template_f@ of type @Circ (a -> Circ ...)@. +-- +-- The following spellings are recognized: +-- +-- > build_circuit f x y z = ... +-- +-- > build_circuit +-- > f x y z = ... +-- +-- > build_circuit +-- > f :: a -> ... +-- > f x y z = ... + +-- ---------------------------------------------------------------------- +-- * Circuits for specific operations + +-- ** Boolean parameters + +-- | Lifted version of 'newBool': +-- +-- > newBool :: BoolParam -> Bool. +-- +-- Depending on the boolean parameter, the circuit is either +-- +-- > 0 |-- +-- +-- or +-- +-- > 1 |-- +template_newBool :: Circ (BoolParam -> Circ Qubit) +template_newBool = return $ \b -> case b of + PTrue -> qinit_qubit True + PFalse -> qinit_qubit False + +---------------------------------------------------------------------- +-- ** Boolean constants + +-- | Lifted version of 'False': +-- +-- > False :: Bool. +-- +-- The circuit is +-- +-- > 0 |-- output: quantum bit in state |0> +template_False :: Circ Qubit +template_False = qinit_qubit False + +-- | Lifted version of 'True': +-- +-- > True :: Bool. +-- +-- The circuit is +-- +-- > 1 |-- output: quantum bit in state |1> +template_True :: Circ Qubit +template_True = qinit_qubit True + + + +---------------------------------------------------------------------- +-- ** Unary boolean operations + +-- | Lifted version of 'not': +-- +-- > not :: Bool -> Bool. +-- +-- The circuit is +-- +-- > a -----x-- +-- > | +-- > 1 |--N------- output: not a. +template_not :: Circ (Qubit -> Circ Qubit) +template_not = return $ \b -> do + r <- qinit_qubit True; + qnot_at r `controlled` b + return r + + +---------------------------------------------------------------------- +-- ** Binary boolean operations + +-- | Lifted version of '&&': +-- +-- > (&&) :: Bool -> Bool -> Bool. +-- +-- The circuit is +-- +-- > a -----x--- +-- > | +-- > b -----x--- +-- > | +-- > 0 |--N------- output: a and b. +template_symb_ampersand_symb_ampersand_ :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) +template_symb_ampersand_symb_ampersand_ = + return $ \b1 -> return $ \b2 -> do + r <- qinit_qubit False; + qnot_at r `controlled` [b1,b2]; + return r + +-- | Lifted version of '||': +-- +-- > (||) :: Bool -> Bool -> Bool. +-- +-- The circuit is +-- +-- > a -----o--- +-- > | +-- > b -----o--- +-- > | +-- > 1 |--N------- output: a or b. +template_symb_vbar_symb_vbar_ :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) +template_symb_vbar_symb_vbar_ = return $ \b1 -> return $ \b2 -> do + r <- qinit_qubit True; + qnot_at r `controlled` b1 .==. 0 .&&. b2 .==. 0; + return r + + +-- | Lifted version of 'Quipper.Utils.Auxiliary.bool_xor': +-- +-- > bool_xor :: Bool -> Bool -> Bool. +-- +-- The circuit is +-- +-- > a -----x------- +-- > | +-- > b -----|---x--- +-- > | | +-- > 0 |--N---N------ output: a xor b. +template_bool_xor :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) +template_bool_xor = return $ \b1 -> return $ \b2 -> do + r <- qinit_qubit False + qnot_at r `controlled` b1 + qnot_at r `controlled` b2 + return r + + +---------------------------------------------------------------------- +-- ** The if-then-else operation + +-- $IF The last term we need to build is @'template_if'@, a term +-- describing the if-then-else construct as a circuit. + +-- | Lifted version of the @if-then-else@ construction: +-- +-- > if-then-else :: Bool -> b -> b -> b +-- +-- We only allow first-order terms in the \"then\" and \"else\" +-- clauses. The circuit is: +-- +-- > q -----x---o--- +-- > | | +-- > a -----x---|--- +-- > | | +-- > b -----|---x--- +-- > | | +-- > 0 |--N---N-------- wire output of the function. +template_if :: (QData b) => Circ Qubit -> Circ b -> Circ b -> Circ b +template_if x a b = do + x' <- x; a' <- a; b' <- b; map2Q (testOnQubit x') (a',b') + where + testOnQubit :: Qubit -> (Qubit,Qubit) -> Circ Qubit + testOnQubit x (a,b) = do + r <- qinit_qubit False + qnot_at r `controlled` x .==. 1 .&&. a .==. 1 + qnot_at r `controlled` x .==. 0 .&&. b .==. 1 + return r + +-- ---------------------------------------------------------------------- +-- * Operations of the Eq class + +-- | Lifted version of the '==' operator: +-- +-- > (==) :: Eq a => a -> a -> Bool +template_symb_equal_symb_equal_ :: (QEq qa) => Circ (qa -> Circ (qa -> Circ Qubit)) +template_symb_equal_symb_equal_ = return $ \qx -> return $ \qy -> do (qx,qy,test) <- q_is_equal qx qy; return test + +-- ---------------------------------------------------------------------- +-- * Generic unpacking + +-- $ The 'decToCircMonad' function produces (and also requires) +-- functions with somewhat unwieldy types. We define generic functions +-- for unpacking these types into a more useable format, and for +-- packing them back. +-- +-- For example, @'Circ' (qa -> 'Circ' (qb -> 'Circ' qd))@ unpacks +-- into the type @qa -> qb -> 'Circ' qd@. +-- +-- The class 'CircLiftingUnpack' keeps track of the unpacked and +-- packed versions of types; so it will have an instance +-- +-- > @'CircLiftingUnpack' ('Circ' (qa -> 'Circ' (qb -> 'Circ' qd))) (qa -> qb -> 'Circ' qd)@, +-- +-- and provide functions 'unpack', 'pack' going back and forth between +-- these. +-- +-- Note that 'pack' and 'unpack' do not in general form an +-- isomorphism, just a retraction of the packed type onto the unpacked +-- type. +-- +-- Unfortunately the class cannot (in the current implementation) be +-- defined in full generality once and for all: whenever a user wishes +-- to use a new type @QFoo@ in circuit-building functions, she must +-- define an additional base case @'CircLiftingUnpack' ('Circ' QFoo) +-- ('Circ' QFoo)@ (with 'pack' and 'unpack' the identity) to use this +-- class with types involving @QFoo@. +-- +-- The crucial case is +-- +-- > instance ('CircLiftingUnpack' ('Circ' b) b') => 'CircLiftingUnpack' ('Circ' (a -> 'Circ' b)) (a -> b')@. +-- +-- Unfortunately, this requires @-XUndecidableInstances@, for somewhat +-- subtle reasons (see +-- , +-- ). +-- +-- The current implementation is fairly restricted, working +-- essentially only for cases like the examples above. One can define +-- the unpacking more generally; but this restriction keeps the +-- definition much simpler, and suffices for most (all?) of the +-- circuit-generation functions we use. + +-- | The 'decToCircMonad' function produces (and also requires) +-- functions with somewhat unwieldy types. The 'CircLiftingUnpack' +-- class defines generic functions for unpacking these types into a +-- more useable format, and for packing them back. +-- +-- For example, @'Circ' (qa -> 'Circ' (qb -> 'Circ' qd))@ unpacks into +-- the type @qa -> qb -> 'Circ' qd@. +-- +-- Note that 'pack' and 'unpack' do not in general form an +-- isomorphism, just a retraction of the packed type onto the unpacked +-- type. +class CircLiftingUnpack packed unpacked | packed -> unpacked, unpacked -> packed where + unpack :: packed -> unpacked + pack :: unpacked -> packed + +instance (CircLiftingUnpack (Circ b) b') => CircLiftingUnpack (Circ (a -> Circ b)) (a -> b') where + unpack cf x = unpack $ do f <- cf; f x + pack f = return $ \x -> pack (f x) + +instance CircLiftingUnpack (Circ Qubit) (Circ Qubit) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ [a]) (Circ [a]) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ ()) (Circ ()) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b)) (Circ (a,b)) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b,c)) (Circ (a,b,c)) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b,c,d)) (Circ (a,b,c,d)) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b,c,d,e)) (Circ (a,b,c,d,e)) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b,c,d,e,f)) (Circ (a,b,c,d,e,f)) where + pack x = x + unpack x = x + +instance CircLiftingUnpack (Circ (a,b,c,d,e,f,g)) (Circ (a,b,c,d,e,f,g)) where + pack x = x + unpack x = x diff --git a/Quipper/Internal/Circuit.hs b/Quipper/Internal/Circuit.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Circuit.hs @@ -0,0 +1,763 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Low-level quantum circuit implementation. This is our backend +-- implementation of quantum circuits. Note: there is no run-time +-- error checking at the moment. +-- +-- At its heart, a circuit is a list of gates. All well-definedness +-- checking (e.g. input arity, output arity, and checking that the +-- intermediate gates are connected to legitimate wires) is done +-- dynamically, at circuit generation time, and is not stored within +-- the circuit itself. This allows circuits to be produced and +-- consumed lazily. +-- +-- Implementation note: this file is in the intermediate stage of a +-- code refactoring, and should be considered \"under renovation\". + +module Quipper.Internal.Circuit where + +-- import other Quipper stuff +import Quipper.Utils.Auxiliary + +-- import other stuff +import Data.List +import Data.Maybe + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import Data.Typeable + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ---------------------------------------------------------------------- +-- * Quantum circuit data type + +-- | Wire identifier. Wires are currently identified by an integer, +-- but the users of this interface should be oblivious to this. +type Wire = Int + +-- | Wire type. A wire is either quantum or classical. +data Wiretype = Qbit -- ^ Quantum wire. + | Cbit -- ^ Classical wire. + deriving (Show, Eq, Typeable) + +-- | An arity, also known as a typing context, is a map from a finite +-- set of wires to wire types. +type Arity = IntMap Wiretype + +-- | A signed item of type /a/. 'Signed' /x/ 'True' represents a +-- positive item, and 'Signed' /x/ 'False' represents a negative item. +-- +-- When used with wires in a circuit, a positive sign is used to +-- represent a positive control, i.e., a filled dot, and a negative +-- sign is used to represent a negative control, i.e., an empty dot. +data Signed a = Signed a Bool + deriving (Show, Typeable) + +-- | Extract the underlying item of a signed item. +from_signed :: Signed a -> a +from_signed (Signed a b) = a + +-- | Extract the sign of a signed item: 'True' is positive, and +-- 'False' is negative. +get_sign :: Signed a -> Bool +get_sign (Signed a b) = b + +-- | A list of controlled wires, possibly empty. +type Controls = [Signed Wire] + +-- | A time step is a small floating point number used as a +-- parameter to certain gates, such as rotation gates or the +-- [exp −/iZt/] gate. +type Timestep = Double + +-- | A flag that, if 'True', indicates that the gate is inverted. +type InverseFlag = Bool + +-- | A flag that, if 'True', indicates that the gate is controllable, +-- but any further controls on the gate should be ignored. This is +-- used, e.g., for circuits consisting of a basis change, some +-- operation, and the inverse basis change. When controlling such a +-- circuit, it is sufficient to control the middle operation, so the +-- gates belonging to the basis change and its inverse will have the +-- NoControlFlag set. +type NoControlFlag = Bool + +-- | A flag, to specify if the corresponding subroutine can be controlled. +-- Either no control allowed, or all controls, or only classical. +data ControllableFlag = NoCtl | AllCtl | OnlyClassicalCtl + deriving (Eq, Ord, Show) + +-- | An identifier for a subroutine. A boxed subroutine is currently +-- identified by a pair of: the user-defined name of the subroutine; +-- and a value uniquely identifying the type and shape of the argument. +-- +-- For now, we represent the shape as a string, because this gives an +-- easy total 'Ord' instance, needed for "Data.Map". However, in +-- principle, one could also use a pair of a type representation and a +-- shape term. The implementation of this may change later. +data BoxId = BoxId String String + deriving (Eq, Ord, Show) + +-- | A flag that indicates how many times a particular subroutine +-- should be repeated. If non-zero, it implies some constraints on +-- the type of the subroutine. +data RepeatFlag = RepeatFlag Integer + deriving (Eq,Ord) + +instance Show RepeatFlag where + show (RepeatFlag n) = show n + +-- When changing the 'Gate' datatype, also remember to update +-- 'gate_arity', 'gate_controls', and 'gate_reverse' below. + +-- | The low-level representation of gates. +data Gate = + -- Named reversible quantum gates. + QGate String InverseFlag [Wire] [Wire] Controls NoControlFlag + -- ^ A named reversible quantum gate: @'Qbit'^(m+n) -> + -- 'Qbit'^(m+n)@. The second @['Wire']@ argument should be + -- \"generalized controls\", i.e. wires not modified by the + -- gate. The gate type is uniquely determined by: the name, the + -- number of inputs, and the number of generalized controls. Gates + -- that differ in one of these respects should be regarded as + -- different gates. + + | QRot String InverseFlag Timestep [Wire] [Wire] Controls NoControlFlag + -- ^ A named reversible quantum gate that also depends on a real + -- parameter. This is typically used for phase and rotation + -- gates. The gate name can contain \'%\' as a place holder for + -- the parameter, e.g., @\"exp(-i%Z)\"@. The remaining arguments + -- are as for 'QGate'. + + -- A nullary quantum gate. + | GPhase Timestep [Wire] Controls NoControlFlag + -- ^ Global phase gate: @'1' -> '1'@. The list of wires is just a hint for graphical rendering. + + -- Some classical gates. + | CNot Wire Controls NoControlFlag + -- ^ Classical not: @'Cbit' -> 'Cbit'@. + | CGate String Wire [Wire] NoControlFlag + -- ^ Generic classical gate @1 -> 'Cbit'@. + | CGateInv String Wire [Wire] NoControlFlag + -- ^ Uncompute classical gate @'Cbit' -> 1@, asserting that the + -- classical bit is in the state specified by the corresponding + -- 'CGate'. + | CSwap Wire Wire Controls NoControlFlag + -- ^ Classical swap gate: @'Cbit' * 'Cbit' -> 'Cbit' * 'Cbit'@. + + -- Initialization and assertive termination. + | QPrep Wire NoControlFlag + -- ^ Initialization: @'Cbit' -> 'Qbit'@. + | QUnprep Wire NoControlFlag + -- ^ Measurement @'Qbit' -> 'Cbit'@ with an assertion that the + -- qubit is already in a computational basis state. This kind of + -- measurement loses no information, and is formally the inverse + -- of 'QPrep'. + | QInit Bool Wire NoControlFlag + -- ^ Initialization: @'Bool' -> 'Qbit'@. + | CInit Bool Wire NoControlFlag + -- ^ Initialization: @'Bool' -> 'Cbit'@. + | QTerm Bool Wire NoControlFlag + -- ^ Termination of a 'Qbit' wire with assertion + -- that the qubit is in the specified state: + -- @'Qbit' * 'Bool' -> 1@. + | CTerm Bool Wire NoControlFlag + -- ^ Termination of a 'Cbit' wire with assertion + -- that the bit is in the specified state: + -- @'Cbit' * 'Bool' -> 1@. + + -- Measurement. + | QMeas Wire + -- ^ Measurement: @'Qbit' -> 'Cbit'@. + | QDiscard Wire + -- ^ Termination of a 'Qbit' wire without + -- assertion: @'Qbit' -> 1@ + | CDiscard Wire + -- ^ Termination of a 'Cbit' wire without + -- assertion: @'Cbit' -> 1@ + + -- Dynamic termination. + | DTerm Bool Wire + -- ^ Termination of a 'Cbit' wire, with a comment indicating what + -- the observed state of that wire was. This is typically inserted + -- in a circuit after a dynamic lifting is performed. Unlike + -- 'CTerm', this is in no way an assertion, but simply a record of + -- observed behavior during a particular run of the algorithm. + + -- Subroutines. + | Subroutine BoxId InverseFlag [Wire] Arity [Wire] Arity Controls NoControlFlag ControllableFlag RepeatFlag + -- ^ Reference to a subroutine, assumed to be bound to another + -- circuit. Arbitrary input and output arities. The domain of /a1/ + -- must include the range of /ws1/, and similarly for /a2/ and /ws2/. + + -- Comments. + | Comment String InverseFlag [(Wire,String)] + -- ^ A comment. Does nothing, but can be useful for marking a + -- location or some wires in a circuit. + + deriving Show + +-- ---------------------------------------------------------------------- +-- * Basic information about gates + +-- The following functions must be updated each time the 'Gate' data +-- type is changed. + +-- | Compute the incoming and outgoing wires of a given gate +-- (excluding controls, comments, and anchors). This essentially +-- encodes the type information of the basic gates. If a wire is used +-- multiple times as an input or output, then 'gate_arity' also +-- returns it multiple times; this enables run-time type checking. +-- +-- Note that 'gate_arity' returns the /logical/ wires, and therefore +-- excludes things like labels, comments, and graphical anchors. This +-- is in contrast to 'wires_of_gate', which returns the /syntactic/ +-- set of wires used by the gate. +gate_arity :: Gate -> ([(Wire, Wiretype)], [(Wire, Wiretype)]) +gate_arity (QGate n inv ws1 ws2 c ncf) = (map (\w -> (w,Qbit)) (ws1 ++ ws2) ,map (\w -> (w,Qbit)) (ws1 ++ ws2)) +gate_arity (QRot n inv t ws1 ws2 c ncf) = (map (\w -> (w,Qbit)) (ws1 ++ ws2) ,map (\w -> (w,Qbit)) (ws1 ++ ws2)) +gate_arity (GPhase t w c ncf) = ([], []) +gate_arity (CNot w c ncf) = ([(w, Cbit)], [(w, Cbit)]) +gate_arity (CGate n w ws ncf) = (cs, (w, Cbit) : cs) + where cs = map (\x -> (x, Cbit)) ws +gate_arity (CGateInv n w ws ncf) = ((w, Cbit) : cs, cs) + where cs = map (\x -> (x, Cbit)) ws +gate_arity (CSwap w1 w2 c ncf) = ([(w1, Cbit), (w2, Cbit)], [(w1, Cbit), (w2, Cbit)]) +gate_arity (QPrep w ncf) = ([(w, Cbit)], [(w, Qbit)]) +gate_arity (QUnprep w ncf) = ([(w, Qbit)], [(w, Cbit)]) +gate_arity (QInit b w ncf) = ([], [(w, Qbit)]) +gate_arity (CInit b w ncf) = ([], [(w, Cbit)]) +gate_arity (QTerm b w ncf) = ([(w, Qbit)], []) +gate_arity (CTerm b w ncf) = ([(w, Cbit)], []) +gate_arity (QMeas w) = ([(w, Qbit)], [(w, Cbit)]) +gate_arity (QDiscard w) = ([(w, Qbit)], []) +gate_arity (CDiscard w) = ([(w, Cbit)], []) +gate_arity (DTerm b w) = ([(w, Cbit)], []) +gate_arity (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = (getTypes ws1 a1, getTypes ws2 a2) + where getTypes ws a = map (\n -> (n, fromJust (IntMap.lookup n a))) ws +gate_arity (Comment s inv ws) = ([], []) + +-- | Return the controls of a gate (or an empty list if the gate has +-- no controls). +gate_controls :: Gate -> Controls +gate_controls (QGate n inv ws1 ws2 c ncf) = c +gate_controls (QRot n inv t ws1 ws2 c ncf) = c +gate_controls (GPhase t w c ncf) = c +gate_controls (CNot w c ncf) = c +gate_controls (CGate n w ws ncf) = [] +gate_controls (CGateInv n w ws ncf) = [] +gate_controls (CSwap w1 w2 c ncf) = c +gate_controls (QPrep w ncf) = [] +gate_controls (QUnprep w ncf) = [] +gate_controls (QInit b w ncf) = [] +gate_controls (CInit b w ncf) = [] +gate_controls (QTerm b w ncf) = [] +gate_controls (CTerm b w ncf) = [] +gate_controls (QMeas w) = [] +gate_controls (QDiscard w) = [] +gate_controls (CDiscard w) = [] +gate_controls (DTerm b w) = [] +gate_controls (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = c +gate_controls (Comment s inv ws) = [] + +-- | Return the 'NoControlFlag' of a gate, or 'False' if it doesn't have one. +gate_ncflag :: Gate -> NoControlFlag +gate_ncflag (QGate n inv ws1 ws2 c ncf) = ncf +gate_ncflag (QRot n inv t ws1 ws2 c ncf) = ncf +gate_ncflag (GPhase t w c ncf) = ncf +gate_ncflag (CNot w c ncf) = ncf +gate_ncflag (CGate n w ws ncf) = ncf +gate_ncflag (CGateInv n w ws ncf) = ncf +gate_ncflag (CSwap w1 w2 c ncf) = ncf +gate_ncflag (QPrep w ncf) = ncf +gate_ncflag (QUnprep w ncf) = ncf +gate_ncflag (QInit b w ncf) = ncf +gate_ncflag (CInit b w ncf) = ncf +gate_ncflag (QTerm b w ncf) = ncf +gate_ncflag (CTerm b w ncf) = ncf +gate_ncflag (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = ncf +-- The remaining gates don't have a 'NoControlFlag'. We list them +-- explicitly, so that the typechecker can warn us about new gates +-- that must be added here. +gate_ncflag (QMeas _) = False +gate_ncflag (QDiscard _) = False +gate_ncflag (CDiscard _) = False +gate_ncflag (DTerm _ _) = False +gate_ncflag (Comment _ _ _) = False + + +-- | Apply the given 'NoControlFlag' to the given 'Gate'. This means, +-- if the first parameter is 'True', set the gate's 'NoControlFlag', +-- otherwise do nothing. Throw an error if attempting to set the +-- 'NoControlFlag' on a gate that can't support this flag. +gate_with_ncflag :: NoControlFlag -> Gate -> Gate +gate_with_ncflag False gate = gate +gate_with_ncflag True (QGate n inv ws1 ws2 c _) = (QGate n inv ws1 ws2 c True) +gate_with_ncflag True (QRot n inv t ws1 ws2 c _) = (QRot n inv t ws1 ws2 c True) +gate_with_ncflag True (GPhase t w c _) = (GPhase t w c True) +gate_with_ncflag True (CNot w c _) = (CNot w c True) +gate_with_ncflag True (CGate n w ws _) = (CGate n w ws True) +gate_with_ncflag True (CGateInv n w ws _) = (CGateInv n w ws True) +gate_with_ncflag True (CSwap w1 w2 c _) = (CSwap w1 w2 c True) +gate_with_ncflag True (QPrep w _) = (QPrep w True) +gate_with_ncflag True (QUnprep w _) = (QUnprep w True) +gate_with_ncflag True (QInit b w _) = (QInit b w True) +gate_with_ncflag True (CInit b w _) = (CInit b w True) +gate_with_ncflag True (QTerm b w _) = (QTerm b w True) +gate_with_ncflag True (CTerm b w _) = (CTerm b w True) +gate_with_ncflag True (Subroutine n inv ws1 a1 ws2 a2 c _ ctrble repeat) = (Subroutine n inv ws1 a1 ws2 a2 c True ctrble repeat) +gate_with_ncflag True (Comment s inv ws) = (Comment s inv ws) +-- The remaining gates can't have their 'NoControlFlag' set. We list +-- them explicitly, so that the typechecker can warn us about new +-- gates that must be added here. +gate_with_ncflag True g@(QMeas _) = + error ("gate " ++ show g ++ " can't be used in a without_controls context") +gate_with_ncflag True g@(QDiscard _) = + error ("gate " ++ show g ++ " can't be used in a without_controls context") +gate_with_ncflag True g@(CDiscard _) = + error ("gate " ++ show g ++ " can't be used in a without_controls context") +gate_with_ncflag True g@(DTerm _ _) = + error ("gate " ++ show g ++ " can't be used in a without_controls context") + +-- | Reverse a gate. Throw an error if the gate is not reversible. +gate_reverse :: Gate -> Gate +gate_reverse (QGate n inv ws1 ws2 c ncf) = QGate n (not inv) ws1 ws2 c ncf +gate_reverse (QRot n inv t ws1 ws2 c ncf) = QRot n (not inv) t ws1 ws2 c ncf +gate_reverse (GPhase t w c ncf) = GPhase (-t) w c ncf +gate_reverse (CNot w c ncf) = CNot w c ncf +gate_reverse (CGate n w ws ncf) = CGateInv n w ws ncf +gate_reverse (CGateInv n w ws ncf) = CGate n w ws ncf +gate_reverse (CSwap w1 w2 c ncf) = CSwap w1 w2 c ncf +gate_reverse (QPrep w ncf) = QUnprep w ncf +gate_reverse (QUnprep w ncf) = QPrep w ncf +gate_reverse (QInit b w ncf) = QTerm b w ncf +gate_reverse (CInit b w ncf) = CTerm b w ncf +gate_reverse (QTerm b w ncf) = QInit b w ncf +gate_reverse (CTerm b w ncf) = CInit b w ncf +gate_reverse (Subroutine name inv ws1 a1 ws2 a2 c ncf ctrble repeat) = Subroutine name (not inv) ws2 a2 ws1 a1 c ncf ctrble repeat +gate_reverse (Comment s inv ws) = Comment s (not inv) ws +-- The remaining gates are not reversible. We list them explicitly, so +-- that the typechecker can warn us about new gates that must be added +-- here. +gate_reverse g@(QMeas _) = error ("gate_reverse: gate not reversible: " ++ show g) +gate_reverse g@(QDiscard _) = error ("gate_reverse: gate not reversible: " ++ show g) +gate_reverse g@(CDiscard _) = error ("gate_reverse: gate not reversible: " ++ show g) +gate_reverse g@(DTerm _ _) = error ("gate_reverse: gate not reversible: " ++ show g) + +-- ---------------------------------------------------------------------- +-- * Auxiliary functions on gates and wires + +-- | Return the set of wires used by a list of controls. +wires_of_controls :: Controls -> IntSet +wires_of_controls c = IntSet.fromList (map from_signed c) + +-- | Return the set of wires used by a gate (including controls, +-- labels, and anchors). +-- +-- Unlike 'gate_arity', the function 'wires_of_gate' is used for +-- printing, and therefore returns all wires that are syntactically +-- used by the gate, irrespective of whether they have a logical +-- meaning. +wires_of_gate :: Gate -> IntSet +wires_of_gate (Comment s inv ws) = + intset_inserts (map fst ws) (IntSet.empty) +wires_of_gate (GPhase t w c ncf) = + intset_inserts w (wires_of_controls c) +wires_of_gate g = intset_inserts w1 (intset_inserts w2 (wires_of_controls c)) + where + (a1, a2) = gate_arity g + c = gate_controls g + w1 = map fst a1 + w2 = map fst a2 + +-- | Like 'wires_of_gate', except return a list of wires. +wirelist_of_gate :: Gate -> [Wire] +wirelist_of_gate g = IntSet.toList (wires_of_gate g) + +-- ---------------------------------------------------------------------- +-- * Dynamic arities + +-- | Recall that an 'Arity' is a set of typed wires, and it determines +-- the external interfaces at which circuits and gates can be +-- connected. The type 'ExtArity' stores the same information as the +-- type 'Arity', but in a format that is more optimized for efficient +-- updating. Additionally, it also stores the set of wires ever used. + +type ExtArity = XIntMap Wiretype + +-- | Check whether the given gate is well-formed and can be legally +-- applied in the context of the given arity. If successful, return +-- the updated arity resulting from the gate application. If +-- unsuccessful, raise an error. Properties checked are: +-- +-- * that each gate has non-overlapping inputs, including controls; +-- +-- * that each gate has non-overlapping outputs, including controls; +-- +-- * that the inputs of the gate (including controls) are actually +-- present in the current arity; +-- +-- * that the types of the inputs (excluding controls) match those of +-- the current arity; +-- +-- * that the outputs of the gate (excluding controls) don't conflict +-- with any wires already existing in the current arity. + +arity_append_safe :: Gate -> ExtArity -> ExtArity +arity_append_safe gate a0 = + case (err0, err1, err2, err3, err4) of + (True, _, _, _, _) -> + error $ "Gate error: duplicate inputs in " ++ show gate + (_, True, _, _, _) -> + error $ "Gate error: duplicate outputs in " ++ show gate + (_, _, Just w, _, _) -> + error $ "Gate application error: no such wire " ++ show w ++ ": " ++ show gate + (_, _, _, Just (w,t), _) -> + error $ "Gate application error: wire " ++ show w ++ ":" ++ show t ++ " has wrong type " ++ show t' ++ ": " ++ show gate + where + Just t' = xintmap_lookup w a0 + (_, _, _, _, Just w) -> + error $ "Gate application error: wire " ++ show w ++ " already exists: " ++ show gate + _ -> a2 + where + (win, wout) = gate_arity gate + c_ids = map from_signed (gate_controls gate) + win_ids = map fst win + wout_ids = map fst wout + err0 = has_duplicates (win_ids ++ c_ids) + err1 = has_duplicates (wout_ids ++ c_ids) + err2 = find (\w -> not $ xintmap_member w a0) (win_ids ++ c_ids) + err3 = find (\(w,t) -> not $ xintmap_lookup w a0 == Just t) win + err4 = find (\w -> xintmap_member w a1) wout_ids + a1 = xintmap_deletes win_ids a0 + a2 = xintmap_inserts wout a1 + +-- | Like 'arity_append', but without type checking. This is +-- potentially faster, but should only used in applications that have +-- already been thoroughly tested or type-checked. +arity_append_unsafe :: Gate -> ExtArity -> ExtArity +arity_append_unsafe gate a0 = a2 + where + (win, wout) = gate_arity gate + a1 = xintmap_deletes (map fst win) a0 + a2 = xintmap_inserts wout a1 + +-- | For now, we disable run-time type checking, because we have not +-- yet implemented run-time types properly. Therefore, we define +-- 'arity_append' to be a synonym for 'arity_append_unsafe'. +arity_append :: Gate -> ExtArity -> ExtArity +arity_append = arity_append_unsafe + +-- | Return an empty arity. +arity_empty :: ExtArity +arity_empty = xintmap_empty + +-- | Return a wire unused in the current arity. +arity_unused_wire :: ExtArity -> Wire +arity_unused_wire = xintmap_freshkey + +-- | Return the next /k/ wires unused in the current arity. +arity_unused_wires :: Int -> ExtArity -> [Wire] +arity_unused_wires = xintmap_freshkeys + +-- | Add a new typed wire to the current arity. This returns a new +-- wire and the updated arity. +arity_alloc :: Wiretype -> ExtArity -> (Wire, ExtArity) +arity_alloc t arity = (w, arity') where + w = xintmap_freshkey arity + arity' = xintmap_insert w t arity + +-- | Convert an extended arity to an ordinary arity. +arity_of_extarity :: ExtArity -> Arity +arity_of_extarity = xintmap_to_intmap + +-- | Return the smallest wire id nowhere used in the circuit. +n_of_extarity :: ExtArity -> Int +n_of_extarity = xintmap_size + +-- ---------------------------------------------------------------------- +-- * Circuit abstraction + +-- | A completed circuit /(a1,gs,a2,n)/ has an input arity /a1/, a +-- list of gates /gs/, and an output arity /a2/. We also record /n/, +-- the total number of wires used by the circuit. Because wires are +-- allocated consecutively, this means that the wire id's used are +-- [0../n/-1]. +type Circuit = (Arity, [Gate], Arity, Int) + +-- | Return the set of all the wires in a circuit. +wirelist_of_circuit :: Circuit -> [Wire] +wirelist_of_circuit (_, _, _, n) = [0..n-1] + +-- ---------------------------------------------------------------------- +-- ** Reversing low-level circuits + +-- | Reverse a gate list. +reverse_gatelist :: [Gate] -> [Gate] +reverse_gatelist gates = reverse (map gate_reverse gates) + +-- | Reverse a circuit. Throw an error if the circuit is not reversible. +reverse_circuit :: Circuit -> Circuit +reverse_circuit (a1, gates, a2, n) = (a2, reverse_gatelist gates, a1, n) + +-- ---------------------------------------------------------------------- +-- ** NoControlFlag on low-level circuits + +-- | Set the 'NoControlFlag' on all gates of a circuit. +circuit_to_nocontrol :: Circuit -> Circuit +circuit_to_nocontrol (a1, gates, a2, n) = (a1, gates', a2, n) where + gates' = map (gate_with_ncflag True) gates + +-- ---------------------------------------------------------------------- +-- ** Ordered circuits + +-- | An ordered circuit is a 'Circuit' together with an ordering on +-- (usually all, but potentially a subset of) the input and output +-- endpoints. +-- +-- This extra information is required when a circuit is used within a +-- larger circuit (e.g. via a 'Subroutine' gate), to identify which wires +-- of the sub-circuit should be bound to which wires of the surrounding +-- circuit. +newtype OCircuit = OCircuit ([Wire], Circuit, [Wire]) + +-- | Reverse an 'OCircuit'. Throw an error if the circuit is not reversible. +reverse_ocircuit :: OCircuit -> OCircuit +reverse_ocircuit (OCircuit (ws_in, circ, ws_out)) = OCircuit (ws_out, reverse_circuit circ, ws_out) + +-- ---------------------------------------------------------------------- +-- ** Annotated circuits + +-- | One often wants to consider the inputs and outputs of a circuit as +-- more structured/typed than just lists of bits/qubits; for instance, +-- a list of six qubits could be structured as a pair of triples, or a +-- triple of pairs, or a six-bit 'Quipper.Libraries.Arith.QDInt'. +-- +-- While for the most part this typing information is not included in +-- low-level circuits, we need to consider it in hierarchical circuits, +-- so that the information stored in a subroutine is sufficient to call +-- the subroutine in a typed context. +-- +-- Specifically, the extra information needed consists of functions to +-- destructure the input/output data as a list of typed wires, and +-- restructure such a list of wires into a piece of data of the appropriate +-- type. +data CircuitTypeStructure a = CircuitTypeStructure (a -> ([Wire],Arity)) (([Wire],Arity) -> a) + deriving (Typeable) + +-- | The trivial 'CircuitTypeStructure' on @(['Wire'],'Arity')@. +id_CircuitTypeStructure :: CircuitTypeStructure ([Wire],Arity) +id_CircuitTypeStructure = CircuitTypeStructure id id + +-- | Use a 'CircuitTypeStructure' to destructure a piece of (suitably +-- typed) data into a list of typed wires. +destructure_with :: CircuitTypeStructure a -> a -> ([Wire],Arity) +destructure_with (CircuitTypeStructure f _) = f + +-- | Use a 'CircuitTypeStructure' to structure a list of typed wires +-- (of the appropriate length/arity) into a piece of structured data. +structure_with :: CircuitTypeStructure a -> ([Wire],Arity) -> a +structure_with (CircuitTypeStructure _ g) = g + +-- ====================================================================== +-- * Boxed circuits + +-- | A typed subroutine consists of: +-- +-- * a low-level circuit, ordered to allow binding of incoming and outgoing wires; +-- +-- * functions for structuring/destructuring the inputs and outputs to and +-- from lists of wires (these functions being dynamically typed, since the +-- input/output type may vary between subroutines); +-- +-- * a 'ControllableFlag', recording whether the circuit is controllable. +data TypedSubroutine = forall a b. (Typeable a, Typeable b) => + TypedSubroutine OCircuit (CircuitTypeStructure a) (CircuitTypeStructure b) ControllableFlag + +-- | Extract just the 'Circuit' from a 'TypedSubroutine'. +circuit_of_typedsubroutine :: TypedSubroutine -> Circuit +circuit_of_typedsubroutine (TypedSubroutine (OCircuit (_,circ,_)) _ _ _) = circ + +-- | A name space is a map from names to subroutine bindings. These +-- subroutines can reference each other; it is the programmer’s +-- responsibility to ensure there is no circular dependency, and no +-- clash of names. +type Namespace = Map BoxId TypedSubroutine + +-- | The empty namespace. +namespace_empty :: Namespace +namespace_empty = Map.empty + +-- | A function to display the names of all the subroutines in a 'Namespace'. +showNames :: Namespace -> String +showNames ns = show (map (\(n,_) -> n) (Map.toList ns)) + +-- | A boxed circuit is a distinguished simple circuit (analogous to a “main” function) together with a namespace. +type BCircuit = (Circuit,Namespace) + +-- ---------------------------------------------------------------------- +-- ** Ordered circuits + +-- | An ordered boxed circuit is a 'BCircuit' together with an +-- ordering on the input and output endpoints, or equivalently, an +-- 'OCircuit' together with a namespace. +type OBCircuit = (OCircuit,Namespace) + +-- | Construct an 'OBCircuit' from a 'BCircuit' and an ordering on the +-- input and output endpoints. +ob_circuit :: [Wire] -> BCircuit -> [Wire] -> OBCircuit +ob_circuit w_in (circ, ns) w_out = (OCircuit (w_in, circ, w_out), ns) + +-- ====================================================================== +-- ** Basic functions lifted to boxed circuits + +-- All the basic functions defined on simple circuits now lift +-- trivially to boxed circuits: + +-- | Reverse a simple boxed circuit, or throw an error if not reversible. +reverse_bcircuit :: BCircuit -> BCircuit +reverse_bcircuit (c,s) = (reverse_circuit c,s) + +-- ---------------------------------------------------------------------- +-- * The ReadWrite monad + +-- $ The 'ReadWrite' monad encapsulates the interaction with a (real +-- or simulated) low-level quantum device. + +-- | The 'ReadWrite' monad describes a standard read-write +-- computation, here specialized to the case where writes are 'Gate's, +-- prompts are 'Quipper.Bit's, and reads are 'Bool's. Thus, a +-- read-write computation can do three things: +-- +-- * terminate with a result. This is the case 'RW_Return'. +-- +-- * write a single 'Gate' and continue. This is the case 'RW_Write'. +-- +-- * issue a prompt, which is a 'Wire', then read a 'Bool', then +-- continue. This is the case 'RW_Read'. +data ReadWrite a = RW_Return a + | RW_Write !Gate (ReadWrite a) + | RW_Read !Wire (Bool -> ReadWrite a) + | RW_Subroutine BoxId TypedSubroutine (ReadWrite a) + +instance Monad ReadWrite where + return a = RW_Return a + f >>= g = case f of + RW_Return a -> g a + RW_Write gate f' -> RW_Write gate (f' >>= g) + RW_Read bit cont -> RW_Read bit (\bool -> cont bool >>= g) + RW_Subroutine name subroutine f' -> RW_Subroutine name subroutine (f' >>= g) + +instance Applicative ReadWrite where + pure = return + (<*>) = ap + +instance Functor ReadWrite where + fmap = liftM + +-- | Transforms a read-write computation into one that behaves identically, +-- but also returns the list of gates generated. +-- +-- This is used as a building block, for example to allow a read-write +-- computation to be run in a simulator while simultaneously using a +-- static backend to print the list of generated gates. +readwrite_wrap :: ReadWrite a -> ReadWrite ([Gate], a) +readwrite_wrap (RW_Return a) = do + RW_Return ([], a) +readwrite_wrap (RW_Write gate comp) = do + ~(gates, a) <- readwrite_wrap comp + RW_Write gate (return (gate:gates, a)) +readwrite_wrap (RW_Read bit cont) = do + RW_Read bit (\bool -> readwrite_wrap (cont bool)) +readwrite_wrap (RW_Subroutine name subroutine comp) = + RW_Subroutine name subroutine (readwrite_wrap comp) + +-- | Extract the contents of a static 'ReadWrite' computation. A +-- 'ReadWrite' computation is said to be static if it contains no +-- 'RW_Read' instructions, or in other words, no dynamic lifting. If +-- an 'RW_Read' instruction is encountered, issue an error message +-- using the given stub. +readwrite_unwind_static :: ErrMsg -> ReadWrite a -> a +readwrite_unwind_static e (RW_Return a) = a +readwrite_unwind_static e (RW_Write gate comp) = readwrite_unwind_static e comp +readwrite_unwind_static e (RW_Read bit cont) = error $ e "dynamic lifting" +readwrite_unwind_static e (RW_Subroutine name subroutine comp) = readwrite_unwind_static e comp + +-- | Turn a static read-write computation into a list of gates, while +-- also updating a namespace. \"Static\" means that the computation +-- may not contain any 'RW_Read' operations. If it does, the message +-- \"dynamic lifting\" is passed to the given error handler. +-- +-- Important usage note: This function returns a triple (/gates/, +-- /ns/, /x/). The list of gates is generated lazily, and can be +-- consumed one gate at a time. However, the values /ns/ and /x/ are +-- only computed at the end of the computation. Any function using +-- them should not apply a strict pattern match to /ns/ or /x/, or +-- else the whole list of gates will be generated in memory. For +-- example, the following will blow up the memory: +-- +-- > (gates, ns, (a, n, x)) = gatelist_of_readwrite errmsg comp +-- +-- whereas the following will work as intended: +-- +-- > (gates, ns, ~(a, n, x)) = gatelist_of_readwrite errmsg comp +gatelist_of_readwrite :: ErrMsg -> ReadWrite a -> Namespace -> ([Gate], Namespace, a) +gatelist_of_readwrite e (RW_Return a) ns = ([], ns, a) +gatelist_of_readwrite e (RW_Write gate comp) ns = (gate : gates, ns', a) where + (gates, ns', a) = gatelist_of_readwrite e comp ns +gatelist_of_readwrite e (RW_Read bit cont) ns = error (e "dynamic lifting") +gatelist_of_readwrite e (RW_Subroutine name subroutine comp) ns = + let ns' = map_provide name subroutine ns in + gatelist_of_readwrite e comp ns' + +{- + -- This version is inefficient. Why? + gatelist_of_readwrite_xxx :: ErrMsg -> ReadWrite a -> ([Gate], a) + gatelist_of_readwrite_xxx e comp = + readwrite_unwind_static e (readwrite_wrap comp) +-} + +-- ---------------------------------------------------------------------- +-- * Dynamic boxed circuits + +-- | The type of dynamic boxed circuits. The type 'DBCircuit' /a/ is +-- the appropriate generalization of ('BCircuit', /a/), in a setting +-- that is dynamic rather than static (i.e., with dynamic lifting or +-- \"interactive measurement\"). +type DBCircuit a = (Arity, ReadWrite (Arity, Int, a)) + +-- | Convert a dynamic boxed circuit to a static boxed circuit. The +-- dynamic boxed circuit may not contain any dynamic liftings, since +-- these cannot be performed in a static setting. In case any output +-- liftings are encountered, try to issue a meaningful error via the +-- given stub error message. +bcircuit_of_static_dbcircuit :: ErrMsg -> DBCircuit a -> (BCircuit, a) +bcircuit_of_static_dbcircuit e dbcirc = (bcirc, x) where + (a0, comp) = dbcirc + bcirc = (circ, ns) + circ = (a0, gates, a1, n) + (gates, ns, ~(a1, n, x)) = gatelist_of_readwrite e comp namespace_empty + +-- | Convert a boxed circuit to a dynamic boxed circuit. The latter, +-- of course, contains no 'RW_Read' instructions. +dbcircuit_of_bcircuit :: BCircuit -> a -> DBCircuit a +dbcircuit_of_bcircuit bcircuit x = (a0, comp (Map.toList ns) gates) where + (circuit, ns) = bcircuit + (a0, gates, a1, n) = circuit + comp ((boxid,subroutine):ns) gs = RW_Subroutine boxid subroutine (comp ns gs) + comp [] [] = RW_Return (a1, n, x) + comp [] (g:gs) = RW_Write g (comp [] gs) diff --git a/Quipper/Internal/Classical.hs b/Quipper/Internal/Classical.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Classical.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | This module provides some operations for low-level manipulation +-- of classical circuits. It is built directly on top of +-- "Quipper.Internal.Circuit". + +module Quipper.Internal.Classical where + +-- import other Quipper stuff +import Quipper.Internal.Generic +import Quipper.Internal.QData +import Quipper.Internal.Monad +import Quipper.Internal.Control +import Quipper.Internal.Transformer + +-- import other stuff +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap + +-- ====================================================================== +-- * Manipulation of classical circuits + +-- ---------------------------------------------------------------------- +-- ** Eliminating CGate + +-- | A 'Transformer' to eliminate all 'Quipper.Internal.Circuit.CGate' +-- style gates, such as \"and\", \"or\", \"not\", \"xor\", \"eq\", and +-- \"if-then-else\" gates, and replace them by equivalent +-- 'Quipper.Internal.Circuit.CInit' and +-- 'Quipper.Internal.Circuit.CNot' gates. +cgate_to_cnot_transformer :: Transformer Circ Qubit Bit +cgate_to_cnot_transformer (T_CGate name ncf f) = f $ + \qs -> without_controls_if ncf $ do + q <- cinit False + translate_cgate name q qs + return (q, qs) +cgate_to_cnot_transformer (T_CGateInv name ncf f) = f $ + \q qs -> without_controls_if ncf $ do + reverse_generic_imp (translate_cgate name) q qs + cterm False q + return qs +cgate_to_cnot_transformer gate = identity_transformer gate + +-- | Auxiliary function: compute the reversible circuit corresponding +-- to a 'Quipper.Internal.Circuit.CGate' of the given name, using only +-- controlled-not gates. +translate_cgate :: String -> Bit -> [Bit] -> Circ () +translate_cgate "if" q [a,b,c] = do + cnot_at q `controlled` a .==. True .&&. b .==. True + cnot_at q `controlled` a .==. False .&&. c .==. True +translate_cgate "if" q list = do + error ("translate_cgate: \"if\" needs 3 arguments, not " ++ show (length list)) +translate_cgate "and" q list = do + cnot_at q `controlled` list +translate_cgate "or" q list = do + cnot_at q `controlled` [ x .==. 0 | x <- list] + cnot_at q +translate_cgate "xor" q list = do + sequence_ [cnot_at q `controlled` c | c <- list] +translate_cgate "eq" q [a,b] = do + cnot_at q `controlled` a .==. True + cnot_at q `controlled` b .==. False +translate_cgate "eq" q list = do + error ("translate_cgate: \"eq\" needs 2 arguments, not " ++ show (length list)) +translate_cgate "not" q [a] = do + cnot_at q `controlled` a .==. False +translate_cgate "not" q list = do + error ("translate_cgate: \"not\" needs 1 argument, not " ++ show (length list)) +translate_cgate name q list = do + error ("translate_cgate: gate \"" ++ name ++ "\" not known") + +-- | Translate all classical gates in a circuit into equivalent +-- controlled-not gates. +-- +-- The type of this overloaded function is difficult to read. In more +-- readable form, it has all of the following types: +-- +-- > classical_to_cnot :: (QCData qa) => Circ qa -> Circ qa +-- > classical_to_cnot :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) +-- > classical_to_cnot :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) +-- +-- and so forth. +classical_to_cnot :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun +classical_to_cnot = transform_generic cgate_to_cnot_transformer + +-- ---------------------------------------------------------------------- +-- ** Classical to quantum + +-- | Map an endpoint to the underlying 'Qubit' in the trivial +-- case. Auxiliary function. +trivial_endpoint :: B_Endpoint Qubit Qubit -> Qubit +trivial_endpoint (Endpoint_Qubit q) = q +trivial_endpoint (Endpoint_Bit q) = q + +-- | A 'Transformer' to replace all classical gates in a circuit by +-- equivalent quantum gates. +classical_to_quantum_transformer :: Transformer Circ Qubit Qubit + +-- Classical gates. + +classical_to_quantum_transformer (T_CNot ncf f) = f $ + \q c -> without_controls_if ncf $ do + q' <- qnot q `controlled` c + return (q', c) +classical_to_quantum_transformer (T_CSwap ncf f) = f $ + \w v c -> without_controls_if ncf $ do + (w',v') <- swap w v `controlled` c + return (w',v',c) +classical_to_quantum_transformer (T_CInit b ncf f) = f $ + without_controls_if ncf $ do + w <- qinit b + return w +classical_to_quantum_transformer (T_CTerm b ncf f) = f $ + \w -> without_controls_if ncf $ do + qterm b w + return () +classical_to_quantum_transformer (T_CDiscard f) = f $ + \w -> do + qdiscard w + return () +classical_to_quantum_transformer (T_DTerm b f) = f $ + \w -> do + qdiscard w + return () +classical_to_quantum_transformer (T_CGate name ncf f) = f $ + -- This case is recursive. The well-foundedness rests on the fact + -- that the output of classical_to_cnot contains no CGate. + classical_to_quantum . classical_to_cnot $ + \ws -> without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) +classical_to_quantum_transformer (T_CGateInv name ncf f) = f $ + -- This case is recursive. The well-foundedness rests on the fact + -- that the output of classical_to_cnot contains no CGate. + classical_to_quantum . classical_to_cnot $ + \v ws -> without_controls_if ncf $ do + cgateinv name v ws + return ws + +-- Preparation, unpreparation, and measurement. These become no-ops. + +classical_to_quantum_transformer (T_QPrep ncf f) = f $ + \w -> return w +classical_to_quantum_transformer (T_QUnprep ncf f) = f $ + \w -> return w +classical_to_quantum_transformer (T_QMeas f) = f $ + \w -> return w + +-- Quantum gates. These are similar to the identity transformer. +-- However, we cannot explicitly call the identity transformer, +-- because its typing does not correctly translate 'Bit' to +-- 'Qubit'. This matters because a pure quantum gate may have +-- classical controls that need to be translated to quantum controls. +classical_to_quantum_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c + return (ws', vs', c) +classical_to_quantum_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c + return (ws', vs', c) +classical_to_quantum_transformer (T_GPhase t ncf f) = f $ + \q c -> without_controls_if ncf $ do + global_phase_anchored_list t (map fix_endpoint q) `controlled` c + return c + where + fix_endpoint (Endpoint_Qubit q) = (Endpoint_Qubit q) + fix_endpoint (Endpoint_Bit q) = (Endpoint_Qubit q) +classical_to_quantum_transformer (T_QInit b ncf f) = f $ + without_controls_if ncf $ do + w <- qinit_qubit b + return w +classical_to_quantum_transformer (T_QTerm b ncf f) = f $ + \w -> without_controls_if ncf $ do + qterm_qubit b w + return () +classical_to_quantum_transformer (T_QDiscard f) = f $ + \w -> do + qdiscard_qubit w + return () +classical_to_quantum_transformer (T_Subroutine n inv ncf scf ws_pat a1_pat vs_pat a2_pat repeat f) = f $ + \namespace ws c -> without_controls_if ncf $ do + provide_subroutines namespace + v <- subroutine n inv scf repeat ws_pat a1_pat vs_pat a2_pat (map fix_endpoint ws) `controlled` c + return (map fix_endpoint v,c) + where + fix_endpoint (Endpoint_Qubit q) = Endpoint_Qubit q + fix_endpoint (Endpoint_Bit q) = + error "classical_to_quantum: classical subroutine not permitted" +classical_to_quantum_transformer (T_Comment s inv f) = f $ + \ws -> do + comment_label s inv [ (fix_endpoint e, s) | (e,s) <- ws ] + return () + where + fix_endpoint (Endpoint_Qubit q) = wire_of_qubit q + fix_endpoint (Endpoint_Bit q) = wire_of_qubit q + +-- | Replace all classical gates in a circuit by equivalent quantum gates. +classical_to_quantum_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (QType qa -> Circ (QType qb)) +classical_to_quantum_unary f x = transform_unary_shape classical_to_quantum_transformer f shape x + where + shape = qcdata_makeshape (dummy :: qa) qubit qubit x + +-- | Replace all classical gates in a circuit by equivalent quantum gates. +-- +-- The type of this overloaded function is difficult to read. In more +-- readable form, it has all of the following types: +-- +-- > classical_to_quantum :: (QCData qa) => Circ qa -> Circ (QType qa) +-- > classical_to_quantum :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (QType qa -> Circ (QType qb)) +-- > classical_to_quantum :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> (QType qa -> QType qb -> Circ (QType qc)) +-- +-- and so forth. +classical_to_quantum :: (QCData qa, QCData qb, QCurry qfun qa qb, QCurry qfun' (QType qa) (QType qb)) => qfun -> qfun' +classical_to_quantum f = g where + f1 = quncurry f + g1 = classical_to_quantum_unary f1 + g = qcurry g1 + +-- ====================================================================== +-- * Classical to reversible + +-- | Generic function for turning a classical (or pseudo-classical) +-- circuit into a reversible circuit. The input is a classical boolean +-- function /x/ ↦ /f/(/x/), given as a not necessarily reversible +-- circuit (however, the circuit should be one-to-one, i.e., no +-- \"garbage\" should be explicitly erased). The output is the +-- corresponding reversible function (/x/,/y/) ↦ (/x/,/y/ ⊕ +-- /f/(/x/)). /qa/ and /qb/ can be any quantum data types. The +-- function 'classical_to_reversible' does not itself change +-- classical bits to qubits; use 'classical_to_quantum' for that. + +classical_to_reversible :: (QCData qa, QCData qb) => (qa -> Circ qb) -> ((qa,qb) -> Circ (qa,qb)) +classical_to_reversible f (input, target) = do + with_computed (f input) $ \output -> do + controlled_not target output + return (input, target) diff --git a/Quipper/Internal/Control.hs b/Quipper/Internal/Control.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Control.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + +-- | Some gates can be controlled by a condition involving one of more +-- \"control\" qubits and/or classical bits at circuit execution time. +-- Such gates can also be controlled by boolean conditions that are +-- known at circuit generation time (in which case the gate will not +-- be generated when the control condition is false). This +-- "Quipper.Internal.Control" module provides some convenient functions for +-- creating and updating such controls. + +module Quipper.Internal.Control where + +import Quipper.Internal.Circuit +import Quipper.Utils.Tuple + +import Data.Map (Map) +import qualified Data.Map as Map + +-- ====================================================================== +-- * The type of controls + +-- $ In the most general case, a \"control\" could be an arbitrary +-- boolean formula built up from assertions of the form /q/ = |0〉 or +-- /q/ = |1〉, where /q/ is either a qubit or a classical bit in a +-- circuit. However, we are here interested in tracking a simpler kind +-- of control. +-- +-- A /control list/ is a conjunction (i.e., an \"and\") of assertions +-- of the form /q/ = |0〉 or /q/ = |1〉. A special case arises when the +-- conjunction involves two mutually exclusive conditions, such as /q/ +-- = |0〉 and /q/ = |1〉. In this case, the control in inconsistent: it +-- can never be active. We use a special representation for the +-- inconsistent control for efficiency reasons. +-- +-- Implementation note: a 'ControlList' is either 'Inconsistent', or +-- else a map from a finite set of wires to booleans. Here, the +-- boolean 'True' represents a positive control, i.e., one that is +-- active when the state is |1〉 (a filled dot in circuit +-- diagrams). The boolean 'False' represents a negative control, i.e., +-- on that is active when the state is |0〉 (an empty dot in circuit +-- diagrams). + +-- | A 'ControlList' is Quipper's internal representation of the type +-- of conjunctive controls, i.e., controls that can be constructed +-- using the 'Quipper..==.', 'Quipper../=.', and 'Quipper..&&.' +-- operators. + +data ControlList = + ControlList (Map Wire Bool) + | Inconsistent + deriving (Show) + +-- ---------------------------------------------------------------------- +-- * Functions for combining control lists + +-- $FUNCTIONS We provide some convenient functions for building +-- control lists from simpler control lists. + +-- | The empty control list, corresponding to a condition that is +-- always true. +clist_empty :: ControlList +clist_empty = ControlList Map.empty + +-- | Add a single signed control to a control list. +clist_add :: Wire -> Bool -> ControlList -> ControlList +clist_add w b Inconsistent = Inconsistent +clist_add w b (ControlList m) = + case Map.lookup w m of + Just b' | b /= b' -> Inconsistent + _ -> ControlList (Map.insert w b m) + +-- | @combine list1 list2@: +-- Take the conjunction of two control lists. This is more efficient +-- if /list1/ is small and /list2/ is large. +combine :: ControlList -> ControlList -> ControlList +combine Inconsistent list2 = Inconsistent +combine (ControlList m) list2 = + Map.foldrWithKey clist_add list2 m + +-- | Like 'combine', but the first argument is of type 'Controls' from +-- the "Quipper.Internal.Circuit" module. +combine_controls :: Controls -> ControlList -> ControlList +combine_controls c list2 = + foldl (\list (Signed w b) -> clist_add w b list) list2 c + +-- | Like 'combine_controls', but also return a value of type +-- 'Controls', or 'Nothing' if the controls are inconsistent. +-- This function is for convenience. +add_to_controls :: Controls -> ControlList -> Maybe Controls +add_to_controls c clist = + case combine_controls c clist of + Inconsistent -> Nothing + ControlList m -> Just [ Signed w b | (w,b) <- Map.toList m ] + +-- ---------------------------------------------------------------------- +-- * Controlling low-level gates + +-- | Modify the given gate by applying the specified controls. If the +-- total set of controls (i.e., those specified in the gate itself and +-- those specified in the control list) is inconsistent, return +-- 'Nothing'. If it is consistent, return the appropriately controlled +-- version of the gate. Throw an error if the gate is of a kind that +-- cannot be controlled. +control_gate :: ControlList -> Gate -> Maybe Gate +control_gate clist (QGate name inv ws1 ws2 c ncf) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (QGate name inv ws1 ws2 c1 ncf) +control_gate clist (QRot name inv t ws1 ws2 c ncf) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (QRot name inv t ws1 ws2 c1 ncf) +control_gate clist (GPhase t w c ncf) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (GPhase t w c1 ncf) +control_gate clist (CNot w c ncf) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (CNot w c1 ncf) +control_gate clist (CSwap w1 w2 c ncf) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (CSwap w1 w2 c1 ncf) +control_gate clist (Subroutine name inv ws1 a1 ws2 a2 c ncf AllCtl repeat) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (Subroutine name inv ws1 a1 ws2 a2 c1 ncf AllCtl repeat) +control_gate clist (Subroutine name inv ws1 a1 ws2 a2 c ncf OnlyClassicalCtl repeat) = + case add_to_controls c clist of + Nothing -> Nothing + Just c1 -> Just (Subroutine name inv ws1 a1 ws2 a2 c1 ncf OnlyClassicalCtl repeat) +control_gate clist (Comment s inv ws) = Just (Comment s inv ws) +-- Implementation note: we list all catch-all cases explicitly, so +-- that the typechecker can warn about new gates that must be added +-- here. +control_gate clist gate@(CGate _ _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(CGateInv _ _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(QPrep _ _) = control_gate_catch_all clist gate +control_gate clist gate@(QUnprep _ _) = control_gate_catch_all clist gate +control_gate clist gate@(QInit _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(CInit _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(QTerm _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(CTerm _ _ _) = control_gate_catch_all clist gate +control_gate clist gate@(QMeas _) = control_gate_catch_all clist gate +control_gate clist gate@(QDiscard _) = control_gate_catch_all clist gate +control_gate clist gate@(CDiscard _) = control_gate_catch_all clist gate +control_gate clist gate@(DTerm _ _) = control_gate_catch_all clist gate +control_gate clist gate@(Subroutine _ _ _ _ _ _ _ _ NoCtl _) = control_gate_catch_all clist gate + +-- | The \"catch all\" clause for 'control_gate'. This handles all +-- gates that are not controllable. If the control condition is known +-- at circuit generation time to be 'clist_empty', then we can just +-- append the gate unconditionally. All other cases are errors. +control_gate_catch_all :: ControlList -> Gate -> Maybe Gate +control_gate_catch_all clist gate = + case clist of + ControlList m | Map.null m -> Just gate + _ -> error ("control_gate: gate can't be controlled: " ++ show gate) + +-- | Define whether a gate can be controlled. +controllable_gate :: Gate -> Bool +controllable_gate (QGate name inv ws1 ws2 c ncf) = True +controllable_gate (QRot name inv t ws1 ws2 c ncf) = True +controllable_gate (GPhase t w c ncf) = True +controllable_gate (CNot w c ncf) = True +controllable_gate (CSwap w1 w2 c ncf) = True +controllable_gate (Subroutine name inv ws1 a1 ws2 a2 c ncf AllCtl _) = True +controllable_gate (Subroutine name inv ws1 a1 ws2 a2 c ncf OnlyClassicalCtl _) = True +controllable_gate (Comment s inv ws) = True +-- Catch-all clauses: The remaining gates are not controllable, unless +-- they have their 'NoControlFlag' set. We list all catch-all cases +-- explicitly, so that the typechecker can warn about new gates that +-- must be added here. +controllable_gate gate@(CGate _ _ _ _) = gate_ncflag gate +controllable_gate gate@(CGateInv _ _ _ _) = gate_ncflag gate +controllable_gate gate@(QPrep _ _) = gate_ncflag gate +controllable_gate gate@(QUnprep _ _) = gate_ncflag gate +controllable_gate gate@(QInit _ _ _) = gate_ncflag gate +controllable_gate gate@(CInit _ _ _) = gate_ncflag gate +controllable_gate gate@(QTerm _ _ _) = gate_ncflag gate +controllable_gate gate@(CTerm _ _ _) = gate_ncflag gate +controllable_gate gate@(QMeas _) = gate_ncflag gate +controllable_gate gate@(QDiscard _) = gate_ncflag gate +controllable_gate gate@(CDiscard _) = gate_ncflag gate +controllable_gate gate@(DTerm _ _) = gate_ncflag gate +controllable_gate gate@(Subroutine _ _ _ _ _ _ _ _ NoCtl _) = gate_ncflag gate + +-- | Define whether an entire low-level circuit can be controlled +controllable_circuit :: Circuit -> Bool +controllable_circuit (_,gs,_,_) = and (map controllable_gate gs) + +-- ---------------------------------------------------------------------- +-- * Specifying control lists + +-- | A \"control source\" is anything that can be used as a control on +-- a gate. The most common way to construct a control source is by +-- using the 'Quipper..==.', 'Quipper../=.', and 'Quipper..&&.' +-- operators. In addition, we provide the following instances: +-- +-- * 'Bool'. A boolean condition that is known at circuit generation +-- time can be used as a control, which is then either trivial (the +-- gate is generated) or inconsistent (the gate is not generated). +-- +-- * 'Wire'. This includes the type 'Quipper.Bit' (for a classical +-- execution-time control) and 'Quipper.Qubit' (for a quantum +-- control). A wire can be used as a shorthand notation for a positive +-- control on that wire. +-- +-- * 'ControlList'. A control list is Quipper's internal +-- representation of a control condition, and is trivially a control +-- source. +-- +-- * A list of control sources can be used as a control source. +class ControlSource a where + -- | Convert a condition to a control. + to_control :: a -> ControlList + +instance ControlSource Bool where + to_control True = clist_empty + to_control False = Inconsistent + +instance ControlSource Wire where + to_control w = ControlList (Map.singleton w True) + +instance ControlSource (Signed Wire) where + to_control (Signed w b) = ControlList (Map.singleton w b) + +instance ControlSource ControlList where + to_control x = x + +instance ControlSource a => ControlSource [a] where + to_control list = foldl combine clist_empty (map to_control list) + +instance ControlSource () where + to_control _ = clist_empty + +instance (ControlSource a, ControlSource b) => ControlSource (a,b) where + to_control (a,b) = combine (to_control a) (to_control b) + +instance (ControlSource a, ControlSource b, ControlSource c) => ControlSource (a,b,c) where + to_control = to_control . untuple + +instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d) => ControlSource (a,b,c,d) where + to_control = to_control . untuple + +instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e) => ControlSource (a,b,c,d,e) where + to_control = to_control . untuple + +instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e, ControlSource f) => ControlSource (a,b,c,d,e,f) where + to_control = to_control . untuple + +instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e, ControlSource f, ControlSource g) => ControlSource (a,b,c,d,e,f,g) where + to_control = to_control . untuple diff --git a/Quipper/Internal/Generic.hs b/Quipper/Internal/Generic.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Generic.hs @@ -0,0 +1,1618 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | This module provides functions and operators that are \"generic\" +-- on quantum data. We say that a function is generic if it works at +-- any quantum data type, rather than just a specific type such as +-- 'Qubit'. For example, the generic function 'qinit' can be used to +-- initialize a qubit from a boolean, or a pair of qubits from a pair +-- of booleans, or a list of qubits from a list of booleans, and so +-- forth. +-- +-- Some functions are also generic in the /number/ of arguments they +-- take, in addition to the type of the arguments. + +module Quipper.Internal.Generic ( + -- * Generic gates + -- ** Initialization and termination + qinit, + qterm, + qdiscard, + cinit, + cterm, + cdiscard, + qc_init, + qc_init_with_shape, + qc_term, + qc_discard, + -- ** Measurement and preparation + measure, + prepare, + qc_measure, + qc_prepare, + -- ** Global phase gate + global_phase_anchored, + -- ** Mapped gates + map_hadamard, + map_hadamard_at, + swap, + swap_at, + controlled_not, + controlled_not_at, + bool_controlled_not, + bool_controlled_not_at, + qmultinot, + qmultinot_at, + -- ** Copying and uncopying + qc_copy_fun, + qc_uncopy_fun, + qc_copy, + qc_uncopy, + -- ** Classical gates + cgate_if, + circ_if, + -- ** Named gates + named_gate, + named_gate_at, + named_rotation, + named_rotation_at, + extended_named_gate, + extended_named_gate_at, + -- ** Dynamic lifting + dynamic_lift, + + -- * Mapping + mapUnary, + mapBinary, + mapBinary_c, + map2Q, + qc_mapBinary, + + -- * Conversion to lists + -- $CONVERSION + qubits_of_qdata, + qdata_of_qubits, + endpoints_of_qcdata, + qcdata_of_endpoints, + + -- * Shape related operations + qc_false, + qshape, + + -- * Bindings + qc_bind, + qc_unbind, + + -- * Generic controls + -- $CONTROL + (.&&.), + (.==.), + (./=.), + -- * Generic encapsulation + -- $encapsulate + encapsulate_generic, + encapsulate_generic_in_namespace, + unencapsulate_generic, + -- $dynamic_encapsulate + encapsulate_dynamic, + unencapsulate_dynamic, + -- * Generic reversing + reverse_generic, + reverse_generic_curried, + reverse_simple, + reverse_simple_curried, + reverse_generic_endo, + reverse_generic_imp, + reverse_endo_if, + reverse_imp_if, + -- * The QCurry type class + QCurry (..), + -- * Generic circuit transformations + transform_unary_dynamic_shape, + transform_unary_dynamic, + transform_unary, + transform_generic, + transform_unary_shape, + transform_generic_shape, + -- * Generic block structure + with_ancilla_init, + with_ancilla_list, + with_computed_fun, + with_computed, + with_basis_change, + with_classical_control, + -- * Boxed subcircuits + provide_subroutine_generic, + box, + nbox, + box_loopM, + loopM_boxed_if, + inline_subroutine + ) where + +-- import other Quipper stuff +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Utils.Auxiliary +import Quipper.Utils.Tuple +import Quipper.Internal.Transformer +import Quipper.Internal.Control +import Quipper.Internal.QData + +-- import other stuff +import Control.Monad +import Prelude +import Data.Typeable +import qualified Control.Monad.State as State + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +-- ====================================================================== +-- * Generic gates + +-- ** Initialization and termination + +-- | Initialize a qubit from a boolean parameter. More generally, +-- initialize a data structure of qubits from a corresponding data +-- structure of boolean parameters. Examples: +-- +-- > q <- qinit False +-- > (q0, q1) <- qinit (True, False) +-- > [q0, q1, q2] <- qinit [True, False, True] +qinit :: (QShape ba qa ca) => ba -> Circ qa +qinit ba = qdata_mapM (shapetype_b ba) qinit_qubit ba + +-- | Terminate a qubit, asserting its state to equal the boolean +-- parameter. More generally, terminate a data structure of qubits, +-- asserting that their state is as given by a data structure of +-- booleans parameters. Examples: +-- +-- > qterm False q +-- > qterm (False, False) (q0, q1) +-- > qterm [False, False, False] [q0, q1, q2] +-- +-- In some cases, it is permissible for some aspect of the parameter's +-- shape to be underspecified, e.g., a longer than necessary list, or +-- an integer of indeterminate length. It is therefore possible, for +-- example, to write: +-- +-- > qterm 17 qa -- when qa :: QDInt, +-- > qterm [False..] qa -- when qa :: [Qubit]. +-- +-- The rules for when a boolean argument can be \"promoted\" in this +-- way are specific to each individual data type. +qterm :: (QShape ba qa ca) => ba -> qa -> Circ () +qterm ba qa = do + let shape = shapetype_b ba -- shape type + let ba' = qdata_promote ba qa errmsg -- shape data + let z = qdata_zip shape bool qubit ba' qa errmsg + qdata_mapM_op shape (\(x,y) -> qterm_qubit x y) z + return () + where + errmsg s = "qterm: shape of parameter does not match data: " ++ s + +-- | Discard a qubit, ignoring its state. This can leave the quantum +-- system in a mixed state, so is not a reversible operation. More +-- generally, discard all the qubits in a quantum data +-- structure. Examples: +-- +-- > qdiscard q +-- > qdiscard (q0, q1) +-- > qdiscard [q0, q1, q2] +qdiscard :: (QData qa) => qa -> Circ () +qdiscard qa = do + qdata_mapM_op (shapetype_q qa) qdiscard_qubit qa + return () + +-- | Initialize a 'Bit' (boolean input) from a 'Bool' (boolean +-- parameter). More generally, initialize the a data structure of Bits +-- from a corresponding data structure of Bools. Examples: +-- +-- > b <- cinit False +-- > (b0, b1) <- cinit (True, False) +-- > [b0, b1, b2] <- cinit [True, False, True] +cinit :: (QShape ba qa ca) => ba -> Circ ca +cinit ba = qdata_mapM (shapetype_b ba) cinit_bit ba + +-- | Terminate a 'Bit', asserting its state to equal the given +-- 'Bool'. More generally, terminate a data structure of Bits, +-- asserting that their state is as given by a data structure of +-- Bools. Examples: +-- +-- > cterm False b +-- > cterm (False, False) (b0, b1) +-- > cterm [False, False, False] [b0, b1, b2] +-- +-- In some cases, it is permissible for some aspect of the parameter's +-- shape to be underspecified, e.g., a longer than necessary list, or +-- an integer of indeterminate length. It is therefore possible, for +-- example, to write: +-- +-- > cterm 17 ca -- when ca :: CInt, +-- > cterm [False..] ca -- when ca :: [Bit]. +-- +-- The rules for when a boolean argument can be \"promoted\" in this +-- way are specific to each individual data type. +cterm :: (QShape ba qa ca) => ba -> ca -> Circ () +cterm ba ca = do + -- shape type + let shape = shapetype_b ba + -- shape data + let ba' = qdata_promote_c ba ca errmsg + let z = qdata_zip shape bool bit ba' ca errmsg + qdata_mapM_op shape (\(x,y) -> cterm_bit x y) z + return () + where + errmsg s = "cterm: shape of parameter does not match data: " ++ s + +-- | Discard a 'Bit', ignoring its state. This can leave the system in +-- a mixed state, so is not a reversible operation. More generally, +-- discard all the Bits in a data structure. Examples: +-- +-- > cdiscard b +-- > cdiscard (b0, b1) +-- > cdiscard [b0, b1, b2] +cdiscard :: (CData ca) => ca -> Circ () +cdiscard ca = do + qdata_mapM_op (shapetype_c ca) cdiscard_bit ca + return () + +-- | Heterogeneous version of 'qinit'. Please note that the type of +-- the result of this function cannot be inferred from the type of the +-- argument. For example, +-- +-- > x <- qc_init False +-- +-- is ambiguous, unless it can be inferred from the context whether +-- /x/ is a 'Bit' or a 'Qubit'. If the type cannot be inferred from +-- the context, it needs to be stated explicitly, like this: +-- +-- > x <- qc_init False :: Circ Qubit +-- +-- Alternatively, 'qc_init_with_shape' can be used to fix a specific +-- type. +qc_init :: (QCData qc) => BType qc -> Circ qc +qc_init bs = qc_init_with_shape (undefined :: qc) bs + +-- | A version of 'qc_init' that uses a shape type parameter. The +-- first argument is the shape type parameter, and the second argument +-- is a data structure containing boolean initializers. The shape type +-- argument determines which booleans are used to initialize qubits, +-- and which ones are used to initialize classical bits. +-- +-- Example: +-- +-- > (x,y) <- qc_init_with_shape (bit,[qubit]) (True, [False,True]) +-- +-- This will assign to /x/ a classical bit initialized to 1, and to +-- /y/ a list of two qubits initialized to |0〉 and |1〉, respectively. +qc_init_with_shape :: (QCData qc) => qc -> BType qc -> Circ qc +qc_init_with_shape shape bs = qcdata_mapM shape qinit_qubit cinit_bit bs + +-- | Heterogeneous version of 'qterm'. +qc_term :: (QCData qc) => BType qc -> qc -> Circ () +qc_term bs qc = do + let bs' = qcdata_promote bs qc errmsg + let z = qcdata_zip qc bool bool qubit bit bs' qc errmsg + qcdata_mapM_op qc map_qubit map_bit z + return () + where + + map_qubit :: (Bool, Qubit) -> Circ () + map_qubit (b,q) = qterm_qubit b q + + map_bit :: (Bool, Bit) -> Circ () + map_bit (b,q) = cterm_bit b q + + errmsg s = "qc_term: shape of parameter does not match data: " ++ s + +-- | Heterogeneous version of 'qdiscard'. +qc_discard :: (QCData qc) => qc -> Circ () +qc_discard qc = do + qcdata_mapM_op qc qdiscard_qubit cdiscard_bit qc + return () + +-- ---------------------------------------------------------------------- +-- ** Measurement and preparation + +-- | Measure a 'Qubit', resulting in a 'Bit'. More generally, measure +-- all the Qubits in a quantum data structure, resulting in a +-- corresponding data structure of Bits. This is not a reversible +-- operation. Examples: +-- +-- > b <- measure q +-- > (b0, b1) <- measure (q0, q1) +-- > [b0, b1, b2] <- measure [q0, q1, q2] +measure :: (QShape ba qa ca) => qa -> Circ ca +measure qa = qdata_mapM_op (shapetype_q qa) measure_qubit qa + +-- | Prepare a 'Qubit' initialized from a 'Bit'. More generally, +-- prepare a data structure of Qubits, initialized from a corresponding +-- data structure of Bits. Examples: +-- +-- > q <- prepare b +-- > (q0, q1) <- prepare (b0, b1) +-- > [q0, q1, q2] <- prepare [b0, b1, b2] +prepare :: (QShape ba qa ca) => ca -> Circ qa +prepare ca = qdata_mapM (shapetype_c ca) prepare_qubit ca + +-- | Heterogeneous version of 'measure'. Given a heterogeneous data +-- structure, measure all of its qubits, and leave any classical bits +-- unchanged. +qc_measure :: (QCData qc) => qc -> Circ (QCType Bit Bit qc) +qc_measure qc = qcdata_mapM_op qc measure_qubit do_bit qc + where + do_bit :: Bit -> Circ Bit + do_bit = return + +-- | Heterogeneous version of 'prepare'. Given a heterogeneous data +-- structure, prepare qubits from all classical bits, and leave any +-- qubits unchanged. +qc_prepare :: (QCData qc) => qc -> Circ (QCType Qubit Qubit qc) +qc_prepare qc = qcdata_mapM qc do_qubit prepare_qubit qc + where + do_qubit :: Qubit -> Circ Qubit + do_qubit = return + +-- ---------------------------------------------------------------------- +-- * Global phase gate + +-- | Like 'global_phase', except the gate is also \"anchored\" at a +-- qubit, a bit, or more generally at some quantum data. The anchor +-- is only used as a hint for graphical display. The gate, which is a +-- zero-qubit gate, will potentially be displayed near the anchor(s). +global_phase_anchored :: (QCData qc) => Double -> qc -> Circ () +global_phase_anchored t qc = global_phase_anchored_list t qs where + qs = endpoints_of_qcdata qc + +-- ---------------------------------------------------------------------- +-- * Mapped gates + +-- | Apply a Hadamard gate to every qubit in a quantum data structure. +map_hadamard :: (QData qa) => qa -> Circ qa +map_hadamard = mapUnary hadamard + +-- | Imperative version of 'map_hadamard'. +map_hadamard_at :: (QData qa) => qa -> Circ () +map_hadamard_at qa = do + map_hadamard qa + return () + +-- | Apply a swap gate to two qubits. More generally, apply swap gates +-- to every corresponding pair of qubits in two pieces of quantum +-- data. +swap :: (QCData qc) => qc -> qc -> Circ (qc,qc) +swap a b = qc_mapBinary swap_qubit swap_bit a b + +-- | Apply a swap gate to two qubits. More generally, apply swap gates +-- to every corresponding pair of qubits in two pieces of quantum +-- data. +swap_at :: (QCData qc) => qc -> qc -> Circ () +swap_at a b = do + swap a b + return () + +-- | Apply a controlled-not gate to every corresponding pair of +-- quantum or classical bits in two pieces of QCData. The first +-- argument is the target and the second the (positive) control. +-- +-- For now, we require both pieces of QCData to have the same type, +-- i.e., classical bits can be controlled only by classical bits and +-- quantum bits can be controlled only by quantum bits. +-- +-- Example: +-- +-- > ((a',b'), (x,y)) <- controlled_not (a,b) (x,y) +-- +-- is equivalent to +-- +-- > a' <- qnot a `controlled` x +-- > b' <- qnot b `controlled` y +controlled_not :: (QCData qc) => qc -> qc -> Circ (qc, qc) +controlled_not qc ctrl = do + let z = qcdata_zip qc qubit bit qubit bit qc ctrl errmsg + z' <- qcdata_mapM qc map_qubit map_bit z + let (qc', ctrl') = qcdata_unzip qc qubit bit qubit bit z' + return (qc', ctrl') + where + + map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit) + map_qubit (q,c) = do + qnot_at q `controlled` c + return (q,c) + + map_bit :: (Bit, Bit) -> Circ (Bit, Bit) + map_bit (b,c) = do + cnot_at b `controlled` c + return (b,c) + + errmsg s = "controlled_not: shapes of control and controlee do not match: " ++ s + +-- | Imperative version of 'controlled_not'. Apply a controlled-not +-- gate to every corresponding pair of quantum or classical bits in +-- two pieces of QCData. The first argument is the target and the +-- second the (positive) control. +controlled_not_at :: (QCData qc) => qc -> qc -> Circ () +controlled_not_at a b = do + controlled_not a b + return () + +-- | A version of 'controlled_not' where the control consists of +-- boolean data. Example: +-- +-- > bool_controlled_not (q, r, s) (True, True, False) +-- +-- negates /q/ and /r/, but not /s/. +bool_controlled_not :: (QCData qc) => qc -> BType qc -> Circ qc +bool_controlled_not qc a = do + bool_controlled_not_at qc a + return qc + +-- | A version of 'controlled_not_at' where the control consists of +-- boolean data. Example: +-- +-- > bool_controlled_not_at (q, r, s) (True, True, False) +-- +-- negates /q/ and /r/, but not /s/. +bool_controlled_not_at :: (QCData qc) => qc -> BType qc -> Circ () +bool_controlled_not_at qc a = do + qmultinot_list_at vq + cmultinot_list_at vc + where + v = Map.toList $ qc_bind qc a + vq = [ (qubit_of_wire q, b) | (q, Endpoint_Qubit b) <- v ] + vc = [ (bit_of_wire c, b) | (c, Endpoint_Bit b) <- v ] + +-- | Negate all qubits in a quantum data structure. +qmultinot :: (QData qa) => qa -> Circ qa +qmultinot qa = do + qmultinot_at qa + return qa + +-- | Negate all qubits in a quantum data structure. +qmultinot_at :: (QData qa) => qa -> Circ () +qmultinot_at qa = + qmultinot_list_at [ (q,True) | q <- qubits_of_qdata qa ] + +-- ---------------------------------------------------------------------- +-- ** Copying and uncopying + +-- | Initialize a new piece of quantum data, as a copy of a given +-- piece. Returns both the original and the copy. +qc_copy_fun :: (QCData qc) => qc -> Circ (qc,qc) +qc_copy_fun orig = do + copy <- qc_init (qc_false orig) + (copy, orig) <- controlled_not copy orig + return (orig, copy) + +-- | Given two pieces of quantum data, assumed equal (w.r.t. the +-- computational basis), terminate the second piece (and return the +-- first, unmodified). This is the inverse of 'qc_copy_fun', in the sense +-- that the following sequence of instructions behaves like the +-- identity function: +-- +-- > (orig, copy) <- qc_copy_fun orig +-- > orig <- qc_uncopy_fun orig copy +qc_uncopy_fun :: (QCData qc) => qc -> qc -> Circ qc +qc_uncopy_fun orig copy = reverse_generic qc_copy_fun orig (orig,copy) + +-- | Create a fresh copy of a piece of quantum data. Note: copying is +-- performed via a controlled-not operation, and is not cloning. This +-- is similar to 'qc_copy_fun', except it returns only the copy, and not +-- the original. +qc_copy :: (QCData qc) => qc -> Circ qc +qc_copy qc = do + (qc, qc1) <- qc_copy_fun qc + return qc1 + +-- | \"Uncopy\" a piece of quantum data; i.e. terminate /copy/, +-- assuming it's a copy of /orig/. This is the inverse of +-- 'qc_copy', in the sense that the following sequence of +-- instructions behaves like the identity function: +-- +-- > b <- qc_copy a +-- > qc_uncopy a b +qc_uncopy :: (QCData qc) => qc -> qc -> Circ () +qc_uncopy orig copy = do + qc_uncopy_fun orig copy + return () + +-- ---------------------------------------------------------------------- +-- ** Classical gates + +-- | If /a/ is 'True', return a copy of /b/, else return a copy of +-- /c/. Here /b/ and /c/ can be any data structures consisting of +-- Bits, but /b/ and /c/ must be of the same type and shape (for +-- example, if they are lists, they must be of equal +-- length). Examples: +-- +-- > output <- cgate_if a b c +-- > (out0, out1) <- cgate_if a (b0, b1) (c0, c1) +-- > [out0, out1, out2] <- cgate_if a [b0, b1, b2] [c0, c1, c2] +cgate_if :: (CData ca) => Bit -> ca -> ca -> Circ ca +cgate_if a b c = do + let shape = shapetype_c b + let z = qdata_zip shape bit bit b c errmsg + d <- qdata_mapM shape (\(x,y) -> cgate_if_bit a x y) z + return d + where + errmsg s = "cgate_if: shapes of 'then' and 'else' part do not match: " ++ s + +-- | 'circ_if' is an if-then-else function for classical circuits. +-- It is a wrapper around 'cgate_if', intended to be used like this: +-- +-- > result <- circ_if <<>> ( +-- > <>> +-- > )( +-- > <<>> +-- > ) +-- +-- Unlike 'cgate_if', this is a meta-operation, i.e., the bodies of +-- the \"then\" and \"else\" parts can be circuit building +-- operations. +-- +-- What makes this different from the usual boolean \"if-then-else\" +-- is that the condition is of type 'Bit', i.e., it is only known at +-- circuit execution time. Therefore the generated circuit contains +-- /both/ the \"then\" and \"else\" parts, suitably +-- controlled. Precondition: the \"then\" and \"else\" parts must be +-- of the same type and shape. +circ_if :: (CData ca) => Bit -> Circ ca -> Circ ca -> Circ ca +circ_if a b c = do + b' <- b + c' <- c + cgate_if a b' c' + +-- ---------------------------------------------------------------------- +-- ** Named gates + +-- | Define a new functional-style gate of the given name. Like +-- 'named_gate', except that the generated gate is extended with +-- \"generalized controls\". The generalized controls are additional +-- inputs to the gate that are guaranteed not to be modified if they +-- are in a computational basis state. They are rendered in a special +-- way in circuit diagrams. Usage: +-- +-- > my_new_gate :: (Qubit,Qubit) -> Qubit -> Circ (Qubit,Qubit) +-- > my_new_gate = extended_named_gate "Q" +-- +-- This defines a new gate with name "Q", two inputs, and one +-- generalized input. +extended_named_gate :: (QData qa, QData qb) => String -> qa -> qb -> Circ qa +extended_named_gate name operands gencontrols = do + named_gate_qulist_at name False (qubits_of_qdata operands) (qubits_of_qdata gencontrols) + return operands + +-- | Like 'extended_named_gate', except defines an imperative style gate. +-- Usage: +-- +-- > my_new_gate_at :: (Qubit,Qubit) -> Qubit -> Circ () +-- > my_new_gate_at = extended_named_gate_at "Q" +-- +-- This defines a new gate with name "Q", two inputs, and one +-- generalized input. +extended_named_gate_at :: (QData qa, QData qb) => String -> qa -> qb -> Circ () +extended_named_gate_at name operands gencontrols = do + extended_named_gate name operands gencontrols + return () + +-- | Define a new functional-style gate of the given name. Usage: +-- +-- > my_unary_gate :: Qubit -> Circ Qubit +-- > my_unary_gate = named_gate "Q" +-- +-- > my_binary_gate :: (Qubit, Qubit) -> Circ (Qubit, Qubit) +-- > my_binary_gate = named_gate "R" +-- +-- This defines a new unary gate and a new binary gate, which will be +-- rendered as "Q" and "R", respectively, in circuit diagrams. + +-- Implementation note: contrary to our usual convention, the binary +-- gate defined above is not in curried form. It would be nice to have +-- a version of this operator that curries the gate. +named_gate :: (QData qa) => String -> qa -> Circ qa +named_gate name operands = do + extended_named_gate name operands () + +-- | Define a new imperative-style gate of the given name. Usage: +-- +-- > my_unary_gate_at :: Qubit -> Circ () +-- > my_unary_gate_at = named_gate_at "Q" +-- +-- > my_binary_gate_at :: (Qubit, Qubit) -> Circ () +-- > my_binary_gate_at = named_gate_at "R" +-- +-- This defines a new unary gate and a new binary gate, which will be +-- rendered as "Q" and "R", respectively, in circuit diagrams. + +named_gate_at :: (QData qa) => String -> qa -> Circ () +named_gate_at name operands = do + named_gate name operands + return () + +-- | Define a new functional-style gate of the given name, and +-- parameterized by a real-valued parameter. This is typically used +-- for rotations or phase gates that are parameterized by an angle. +-- The name can contain \'%\' as a place holder for the parameter. +-- Usage: +-- +-- > my_unary_gate :: Qubit -> Circ Qubit +-- > my_unary_gate = named_rotation "exp(-i%Z)" 0.123 +-- +-- > my_binary_gate :: TimeStep -> (Qubit, Qubit) -> Circ (Qubit, Qubit) +-- > my_binary_gate t = named_rotation "Q(%)" t +named_rotation :: (QData qa) => String -> Timestep -> qa -> Circ qa +named_rotation name theta operands = do + named_rotation_qulist_at name False theta (qubits_of_qdata operands) [] + return operands + +-- | Define a new imperative-style gate of the given name, and +-- parameterized by a real-valued parameter. This is typically used +-- for rotations or phase gates that are parameterized by an angle. +-- The name can contain \'%\' as a place holder for the parameter. +-- Usage: +-- +-- > my_unary_gate_at :: Qubit -> Circ () +-- > my_unary_gate_at = named_rotation "exp(-i%Z)" 0.123 +-- +-- > my_binary_gate_at :: TimeStep -> (Qubit, Qubit) -> Circ () +-- > my_binary_gate_at t = named_rotation "Q(%)" t +named_rotation_at :: (QData qa) => String -> Timestep -> qa -> Circ () +named_rotation_at name theta operands = do + named_rotation name theta operands + return () + +---------------------------------------------------------------------- +-- ** Dynamic lifting + +-- | Convert a 'Bit' (boolean circuit output) to a 'Bool' (boolean +-- parameter). More generally, convert a data structure of Bits to a +-- corresponding data structure of Bools. +-- +-- For use in algorithms that require the output of a measurement to +-- be used as a circuit-generation parameter. This is the case, for +-- example, for sieving methods, and also for some iterative +-- algorithms. +-- +-- Note that this is not a gate, but a meta-operation. The input +-- consists of classical circuit endpoints (whose values are known at +-- circuit execution time), and the output is a boolean parameter +-- (whose value is known at circuit generation time). +-- +-- The use of this operation implies an interleaving between circuit +-- execution and circuit generation. It is therefore a (physically) +-- expensive operation and should be used sparingly. Using the +-- 'dynamic_lift' operation interrupts the batch mode operation of the +-- quantum device (where circuits are generated ahead of time), and +-- forces interactive operation (the quantum device must wait for the +-- next portion of the circuit to be generated). This operation is +-- especially expensive if the current circuit contains unmeasured +-- qubits; in this case, the qubits must be preserved while the +-- quantum device remains on standby. +-- +-- Also note that this operation is not supported in all contexts. It +-- is an error, for example, to use this operation in a circuit that +-- is going to be reversed, or in the body of a boxed subroutine. +-- Also, not all output devices (such as circuit viewers) support this +-- operation. +dynamic_lift :: (QShape ba qa ca) => ca -> Circ ba +dynamic_lift ca = qdata_mapM (shapetype_c ca) dynamic_lift_bit ca + +-- ---------------------------------------------------------------------- +-- * Mapping + +-- | Map a single qubit gate across every qubit in the data structure. +mapUnary :: (QData qa) => (Qubit -> Circ Qubit) -> qa -> Circ qa +mapUnary f qa = qdata_mapM (shapetype_q qa) f qa + +-- | Map a binary gate across every corresponding pair of qubits in +-- two quantum data structures of equal shape. +mapBinary :: (QData qa) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> qa -> qa -> Circ (qa, qa) +mapBinary f q1 q2 = do + let shape = shapetype_q q1 + let z = qdata_zip shape qubit qubit q1 q2 errmsg + z' <- qdata_mapM shape (\(x,y) -> f x y) z + let (q1', q2') = qdata_unzip shape qubit qubit z' + return (q1', q2') + where + errmsg s = "mapBinary: shapes of arguments do not match: " ++ s + +-- | Like 'mapBinary', except the second data structure is classical. +mapBinary_c :: (QShape ba qa ca) => (Qubit -> Bit -> Circ (Qubit, Bit)) -> qa -> ca -> Circ (qa, ca) +mapBinary_c f q1 c2 = do + let shape = shapetype_q q1 + let z = qdata_zip shape qubit bit q1 c2 errmsg + z' <- qdata_mapM shape (\(x,y) -> f x y) z + let (q1', c2') = qdata_unzip shape qubit bit z' + return (q1', c2') + where + errmsg s = "mapBinary_c: shapes of arguments do not match: " ++ s + +-- | Map a binary qubit circuit to every pair of qubits in the quantum +-- data-type. It is a run-time error if the two structures do not have +-- the same size. +map2Q :: (QData qa) => ((Qubit, Qubit) -> Circ Qubit) -> (qa, qa) -> Circ qa +map2Q f (q,p) = do + let shape = shapetype_q q + let z = qdata_zip shape qubit qubit q p errmsg + d <- qdata_mapM shape f z + return d + where + errmsg s = "map2Q: shapes of arguments do not match: " ++ s + +-- | Heterogeneous version of 'mapBinary'. Map a binary gate /f/ +-- across every corresponding pair of qubits, and a binary gate /g/ +-- across every corresponding pair of bits, in two quantum data +-- structures of equal shape. +qc_mapBinary :: (QCData qc) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> (Bit -> Bit -> Circ (Bit, Bit)) -> qc -> qc -> Circ (qc, qc) +qc_mapBinary f g x y = do + let z = qcdata_zip x qubit bit qubit bit x y errmsg + z' <- qcdata_mapM x map_qubit map_bit z + let (x', y') = qcdata_unzip x qubit bit qubit bit z' + return (x', y') + where + + map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit) + map_qubit (x,y) = f x y + + map_bit :: (Bit, Bit) -> Circ (Bit, Bit) + map_bit (x,y) = g x y + + errmsg s = "qc_mapBinary: shapes of arguments do not match: " ++ s + +-- ---------------------------------------------------------------------- +-- * Conversion to lists + +-- $CONVERSION The functions in this section can be used to convert +-- quantum data structures to and from lists. Do not use them! The +-- conversion is unsafe in the same way pointers to void are unsafe in +-- the C programming language. There is almost always a better and +-- more natural way to accomplish what you need to do. + +-- | Return the list of qubits representing the given quantum data. +-- The qubits are ordered in some fixed, but arbitrary way. It is +-- guaranteed that two pieces of qdata of the same given shape will be +-- ordered in the same way. No other property of the order is +-- guaranteed, In particular, the order may change without notice from +-- one version of Quipper to the next. +qubits_of_qdata :: (QData qa) => qa -> [Qubit] +qubits_of_qdata qa = qdata_sequentialize (shapetype_q qa) qa + +-- | Take a specimen piece of quantum data to specify the \"shape\" +-- desired (length of lists, etc); then reads the given list of qubits +-- in as a piece of quantum data of the same shape. The ordering of +-- the input qubits is the same as 'qubits_of_qdata' produces for the +-- given shape. +-- +-- A \"length mismatch\" error occurs if the list does not have +-- exactly the required length. +qdata_of_qubits :: (QData qa) => qa -> [Qubit] -> qa +qdata_of_qubits qa list = qdata_unsequentialize qa list + +-- | Return the list of endpoints that form the leaves of the given +-- 'QCData'. The leaves are ordered in some fixed, but arbitrary +-- way. It is guaranteed that two pieces of data of the same given +-- shape will be ordered in the same way. No other property of the +-- order is guaranteed. In particular, the order may change without notice from +-- one version of Quipper to the next. +endpoints_of_qcdata :: (QCData qc) => qc -> [Endpoint] +endpoints_of_qcdata qc = qcdata_sequentialize qc qc + +-- | Take a specimen piece of 'QCData' to specify the \"shape\" +-- desired (length of lists, etc); then reads the given list of +-- endpoints in as a piece of quantum data of the same shape. The +-- ordering of the input endpoints equals that produced by +-- 'endpoints_of_qcdata' for the given shape. +-- +-- A \"length mismatch\" error occurs if the list does not have +-- exactly the required length. A \"shape mismatch\" error occurs if +-- the list contains a 'Qubit' when a 'Bit' was expected, or vice versa. +qcdata_of_endpoints :: (QCData qc) => qc -> [Endpoint] -> qc +qcdata_of_endpoints qc list = qcdata_unsequentialize qc list where + +-- | Take a specimen piece of 'QCData' to specify a shape; +-- return a 'CircuitTypeStructure' that structures appropriate +-- lists of wires with arities into data of this shape, and conversely +-- destructures data of this shape into wires and an arity. +-- +-- The caveats mentioned in 'endpoints_of_qcdata' apply equally for +-- this function. +circuit_type_structure_of_qcdata :: (QCData qc) => qc -> CircuitTypeStructure qc +circuit_type_structure_of_qcdata qc = CircuitTypeStructure + (wires_with_arity_of_endpoints . endpoints_of_qcdata) + (\(ws,a) -> qcdata_of_endpoints qc $ endpoints_of_wires_in_arity a ws) + +-- ---------------------------------------------------------------------- +-- * Shape related operations + +-- | Return a boolean data structure of the given shape, with every +-- leaf initialized to 'False'. +qc_false :: (QCData qc) => qc -> BType qc +qc_false qc = qcdata_map qc map_qubit map_bit qc + where + map_qubit = const False :: Qubit -> Bool + map_bit = const False :: Bit -> Bool + +-- | Return a quantum data structure of the given boolean shape, with +-- every leaf initialized to the undefined dummy value 'qubit'. +qshape :: (QData qa) => BType qa -> qa +qshape ba = qdata_map (shapetype_b ba) map_qubit ba + where + map_qubit = const qubit :: Bool -> Qubit + +-- ---------------------------------------------------------------------- +-- * Bindings + +-- | Take two pieces of quantum data of the same shape (the first of +-- which consists of wires of a low-level circuit) and create +-- bindings. +qc_bind :: (QCData qc) => qc -> QCType a b qc -> Bindings a b +qc_bind qc as = qc_bind_aux qc as bindings_empty + where + -- This can't be inlined without upsetting the type checker. + qc_bind_aux :: (QCData qc) => qc -> QCType a b qc -> Bindings a b -> Bindings a b + qc_bind_aux qc as (bind_in :: Bindings a b) = bindings where + a = (dummy :: a) -- shape type + b = (dummy :: b) -- shape type + z = qcdata_zip qc qubit bit a b qc as errmsg + bindings = qcdata_fold qc do_qubit do_bit z bind_in + + do_qubit :: (Qubit, a) -> Bindings a b -> Bindings a b + do_qubit (q, binding) = bind_qubit q binding + + do_bit :: (Bit, b) -> Bindings a b -> Bindings a b + do_bit (c, binding) = bind_bit c binding + + errmsg s = "qc_bind: shapes of arguments do not match: " ++ s + +-- | Apply bindings to a piece of quantum and/or classical data +-- holding low-level wires, to get data of the same shape. +qc_unbind :: (QCData qc) => Bindings a b -> qc -> QCType a b qc +qc_unbind (bindings :: Bindings a b) qc = + qcdata_map qc map_qubit map_bit qc + where + map_qubit :: Qubit -> a + map_qubit q = unbind_qubit bindings q + + map_bit :: Bit -> b + map_bit b = unbind_bit bindings b + +-- ====================================================================== +-- * Generic controls + +-- $CONTROL The following functions define a convenient syntax for +-- controls. With this, we can write controls in much the same way as +-- one would write (a restricted class of) boolean +-- expressions. Examples: +-- +-- > q1 .==. 0 .&&. q2 .==. 1 for Qubits q1, q2 +-- +-- > q .&&. p means q .==. 1 .&&. p .==. 1 +-- +-- > qx .==. 5 for a QDInt qx +-- +-- > q1 .==. 0 .&&. z <= 7 we can combine quantum and classical controls +-- +-- > q ./=. b the negation of q .==. b; +-- > here b is a boolean. +-- +-- > [p,q,r,s] a list of positive controls +-- +-- > [(p, True), (q, False), (r, False), (s, True)] +-- > a list of positive and negative controls +-- +-- Among these infix operators, @(.&&.)@ binds more weakly than +-- @(.==.)@, @(./=.)@. + +-- | Given a piece of quantum data and a possible value for it, return +-- a 'ControlList' representing the condition that the quantum data +-- has that value. +-- +-- If some aspect of the value's shape is indeterminate, it is +-- promoted to the same shape as the quantum data; therefore, it is +-- possible, for example, to write: +-- +-- > qc_control qa 17 -- when qa :: QDInt +-- > qc_control qa [False..] -- when qa :: [Qubit] +qc_control :: (QCData qc) => qc -> BType qc -> ControlList +qc_control qc b = clist where + b' = qcdata_promote b qc errmsg + z = qcdata_zip qc qubit bit bool bool qc b' errmsg + clist = qcdata_fold qc do_qubit do_bit z clist_empty + + do_qubit :: (Qubit, Bool) -> ControlList -> ControlList + do_qubit (q, b) = clist_add_qubit q b + + do_bit :: (Bit, Bool) -> ControlList -> ControlList + do_bit (c, b) = clist_add_bit c b + + errmsg s = "qc_control: shape of control value does not match data: " ++ s + +-- | This is an infix operator to concatenate two controls, forming +-- their logical conjunction. +(.&&.) :: (ControlSource a, ControlSource b) => a -> b -> ControlList +exp1 .&&. exp2 = combine (to_control exp1) (to_control exp2) + +-- | @(qx .==. x)@: a control which is true just if quantum data /qx/ is in the specified state /x/. +(.==.) :: (QCData qc) => qc -> BType qc -> ControlList +qx .==. x = qc_control qx x + +-- | The notation @(q ./=. x)@ is shorthand for @(q .==. not x)@, when +-- /x/ is a boolean parameter. +-- +-- Unlike '.==.', which is defined for any shape of quantum data, +-- './=.' is only defined for a single control bit or qubit. +(./=.) :: (QCLeaf q) => q -> Bool -> ControlList +q ./=. b = to_control [Signed q (not b)] + +-- Set the precedence for infix operators '.&&.', '.==.', and './=.'. +infixr 3 .&&. -- same precedence as (&&) +infix 4 .==. -- same precedence as (==) +infix 4 ./=. -- same precedence as (/=) + +-- The following allows us to write 0 and 1 instead of 'False' and +-- 'True' everywhere. +instance Num Bool where + (+) = (/=) + (*) = (&&) + (-) = (/=) + negate = id + signum = id + abs = id + fromInteger n = (n `mod` 2 == 1) + +-- ====================================================================== +-- * Generic encapsulation + +-- $encapsulate +-- +-- An encapsulated circuit is a low-level circuit together with data +-- structures holding the input endpoints and output endpoints. A +-- circuit-generating function, with fully specified parameters, can +-- be turned into an encapsulated circuit; conversely, an encapsulated +-- circuit can be turned into a circuit-generating function. Thus, +-- encapsulation and unencapsulation are the main interface for +-- passing between high- and low-level data structures. + +-- | Allocate new quantum data of the given shape, in the given +-- arity. Returns the quantum data and the updated arity. +qc_alloc :: (QCData qc) => qc -> ExtArity -> (qc, ExtArity) +qc_alloc qc arity = qcdata_fold_map qc do_qubit do_bit qc arity where + + do_qubit :: Qubit -> ExtArity -> (Qubit, ExtArity) + do_qubit q arity = (qubit_of_wire w, a) + where + (w, a) = arity_alloc Qbit arity + + do_bit :: Bit -> ExtArity -> (Bit, ExtArity) + do_bit c arity = (bit_of_wire w, a) + where + (w, a) = arity_alloc Cbit arity + +-- | Extract an encapsulated circuit from a circuit-generating +-- function. This requires a shape parameter. +encapsulate_generic :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> (x, BCircuit, y) +encapsulate_generic e f shape = (x, circ, y) where + (x, arity) = qc_alloc shape arity_empty + (circ, y) = extract_simple e arity (f x) + +-- | As 'encapsulate_generic', but passes the current namespace +-- into the circuit-generating function, to save recomputing +-- shared subroutines +encapsulate_generic_in_namespace :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> Circ (x, BCircuit, y) +encapsulate_generic_in_namespace e f shape = do + let (x, arity) = qc_alloc shape arity_empty + (circ, y) <- extract_in_current_namespace e arity (f x) + return (x, circ, y) + +-- | Turn an encapsulated circuit back into a circuit-generating +-- function. +unencapsulate_generic :: (QCData x, QCData y) => (x, BCircuit, y) -> (x -> Circ y) +unencapsulate_generic (c_in, c, c_out) input = do + let in_bindings = qc_bind c_in input + out_bindings <- apply_bcircuit_with_bindings c in_bindings + let output = qc_unbind out_bindings c_out + return output + +-- $dynamic_encapsulate +-- +-- A dynamic encapsulated circuit is to an encapsulated circuit like a +-- 'DBCircuit' to a 'BCircuit'. The output is not a static circuit, +-- but an interactive computation expressed through the 'ReadWrite' +-- monad, which can be run on a quantum device to get a static circuit +-- out. + +-- | Extract an encapsulated dynamic circuit from a circuit-generating +-- function. This requires a shape parameter. +encapsulate_dynamic :: (QCData x) => (x -> Circ y) -> x -> (x, DBCircuit y) +encapsulate_dynamic f shape = (x, comp) where + (x, arity) = qc_alloc shape arity_empty + comp = extract_general arity (f x) + +-- | Turn an encapsulated dynamic circuit back into a +-- circuit-generating function. +-- +-- This currently fails if the dynamic circuit contains output +-- liftings, because the transformer interface has not yet been +-- updated to work with dynamic circuits. +unencapsulate_dynamic :: (QCData x, QCData y) => (x, DBCircuit y) -> (x -> Circ y) +unencapsulate_dynamic (c_in, comp) input = do + let in_bindings = qc_bind c_in input + (out_bindings, c_out) <- apply_dbcircuit_with_bindings comp in_bindings + let output = qc_unbind out_bindings c_out + return output + +-- ====================================================================== +-- * Generic reversing + +-- | Like 'reverse_unary', but also takes a stub error message. +reverse_errmsg :: (QCData x, QCData y) => ErrMsg -> (x -> Circ y) -> x -> (y -> Circ x) +reverse_errmsg e f shape y = do + circuit <- encapsulate_generic_in_namespace errmsg f shape + let circuit_inv = reverse_encapsulated circuit + f_inv = unencapsulate_generic circuit_inv + f_inv y + where + errmsg x = e ("operation not permitted in reversible circuit: " ++ x) + +-- | Reverse a non-curried circuit-generating function. The second +-- parameter is a shape parameter. +reverse_unary :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x) +reverse_unary = reverse_errmsg errmsg + where + errmsg x = "reverse_unary: " ++ x + +-- | Reverse a circuit-generating function. The reversed function +-- requires a shape parameter, given as the input type of the original +-- function. +-- +-- The type of this highly overloaded function is quite difficult to +-- read. It can have for example the following types: +-- +-- > reverse_generic :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x) +-- > reverse_generic :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> x -> y -> (z -> Circ (x,y)) +reverse_generic :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y, Curry x_y_xt x (y -> Circ xt)) => x_y -> x_y_xt +reverse_generic f = + mcurry $ aux f + where + -- An auxiliary function for defining 'reverse_generic'. (Inlining + -- this causes difficulty with the type inference for 'mcurry'.) + --aux :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> x -> (y -> Circ xt) + aux f shape = + (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) shape) + + errmsg x = "reverse_generic: " ++ x + +-- | Like 'reverse_generic', but takes functions whose output is a +-- tuple, and curries the reversed function. Differs from +-- 'reverse_generic' in an example such as: +-- +-- > f :: (x -> y -> Circ (z,w)) +-- > reverse_generic f :: x -> y -> ((z,w) -> Circ (x,y)) +-- > reverse_generic_curried f :: x -> y -> (z -> w -> Circ (x,y)) +-- +-- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥ +-- 2. Applying this to a circuit whose output is a non-tuple type is a +-- type error; in this case, 'reverse_generic' should be used. +reverse_generic_curried :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt, Curry x_y_xt x y_xt) => x_yt -> x_y_xt +reverse_generic_curried f = + mcurry $ aux f + where + -- An auxiliary function for 'reverse_generic_curried'. (Inlining + -- this causes difficulty with the type inference for 'mcurry'.) + aux :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt) => x_yt -> x -> y_xt + aux f = + (qcurry .) $ \x y -> (fmap weak_tuple) $ (reverse_errmsg errmsg $ (fmap untuple) . (quncurry f)) x y + + errmsg x = "reverse_generic_curried: " ++ x + +-- | Like 'reverse_generic', but only works at simple types, and +-- therefore requires no shape parameters. Typical type instances: +-- +-- > reverse_simple :: (QCData_Simple x, QCData y) => (x -> Circ y) -> (y -> Circ x) +-- > reverse_simple :: (QCData_Simple x, QCData_Simple y, QCData z) => (x -> y -> Circ z) -> (z -> Circ (x,y)) +reverse_simple :: (QCData_Simple x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> y -> Circ xt +reverse_simple f = (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) fs_shape) + where + errmsg x = "reverse_simple: " ++ x + +-- | Like 'reverse_simple', but takes functions whose output is a +-- tuple, and curries the reversed function. Typical type instance: +-- +-- > reverse_simple_curried :: (QCData_Simple x, QCData y, QCData z) => (x -> Circ (y,z)) -> (y -> z -> Circ x) +-- +-- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥ +-- 2. Applying this to a circuit whose output is a non-tuple type is a +-- type error; in this case, 'reverse_generic' should be used. +reverse_simple_curried :: (QCData_Simple x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt) + => x_yt -> y_xt +reverse_simple_curried f = qcurry $ + (fmap weak_tuple) . (reverse_errmsg errmsg ((fmap untuple) . (quncurry f)) fs_shape) + where + errmsg x = "reverse_simple_curried: " ++ x + +-- | Like 'reverse_generic', but specialized to endomorphic circuits, +-- i.e., circuits where the input and output have the same type (modulo +-- possibly currying) and shape. In this case, unlike 'reverse_generic', +-- no additional shape parameter is required, and the reversed function +-- is curried if the original function was. Typical type instances: +-- +-- > reverse_generic_endo :: (QCData x) => (x -> Circ x) -> (x -> Circ x) +-- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ (x,y)) -> (x -> y -> Circ (x,y)) +reverse_generic_endo :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => x_xt -> x_xt +reverse_generic_endo = qcurry . ((fmap weak_tuple) .) . + (\f x -> reverse_errmsg errmsg f x x) + . ((fmap weak_untuple) .) . quncurry + where + errmsg x = "reverse_generic_endo: " ++ x + +-- | Like 'reverse_generic_endo', but applies to endomorphic circuits +-- expressed in \"imperative\" style. Typical type instances: +-- +-- > reverse_generic_endo :: (QCData x) => (x -> Circ ()) -> (x -> Circ ()) +-- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ ()) -> (x -> y -> Circ ()) +reverse_generic_imp :: (QCData x, QCurry x__ x ()) => x__ -> x__ +reverse_generic_imp f = qcurry $ \input -> do + reverse_generic_endo f' input + return () + where + f' x = do + (quncurry f) x + return x + +-- | Conditional version of 'reverse_generic_endo'. Invert the +-- endomorphic quantum circuit if the boolean is true; otherwise, +-- insert the non-inverted circuit. +reverse_endo_if :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => Bool -> x_xt -> x_xt +reverse_endo_if False f = f +reverse_endo_if True f = reverse_generic_endo f + +-- | Conditional version of 'reverse_generic_imp'. Invert the +-- imperative style quantum circuit if the boolean is true; otherwise, +-- insert the non-inverted circuit. +reverse_imp_if :: (QCData qa, QCurry fun qa ()) => Bool -> fun -> fun +reverse_imp_if False f = f +reverse_imp_if True f = reverse_generic_imp f + +-- ====================================================================== +-- * The QCurry type class + +-- | The 'QCurry' type class is similar to the 'Curry' type class, +-- except that the result type is guarded by the 'Circ' monad. It +-- provides a family of type isomorphisms +-- +-- @fun ≅ args -> Circ res,@ +-- +-- where +-- +-- > fun = a1 -> a2 -> ... -> an -> Circ res, +-- > args = (a1, (a2, (..., (an, ())))). +-- +-- The benefit of having @Circ@ in the result type is that it ensures +-- that the result type is not itself a function type, and therefore +-- /fun/ has a /unique/ arity /n/. Then /args/ and /res/ are uniquely +-- determined by /fun/, which can be used to write higher-order +-- operators that consume /fun/ of any arity and \"do the right +-- thing\". + +class QCurry fun args res | fun -> args res, args res -> fun where + qcurry :: (args -> Circ res) -> fun + quncurry :: fun -> (args -> Circ res) + +instance QCurry (Circ b) () b where + qcurry g = g () + quncurry x = const x + +instance QCurry fun args res => QCurry (a -> fun) (a,args) res where + qcurry g x = qcurry (\xs -> g (x,xs)) + quncurry f (x,xs) = quncurry (f x) xs + +-- ====================================================================== +-- * Generic circuit transformations + +-- | Like 'transform_unary_shape', but also takes a stub error message. +transform_errmsg :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => ErrMsg -> Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y') +transform_errmsg e transformer f shape input = do + let (x, circuit, y) = encapsulate_generic errmsg f shape + let in_bind = qc_bind x input + out_bind <- transform_bcircuit_rec transformer circuit in_bind + let output = qc_unbind out_bind y + return output + where + errmsg x = e ("operation not currently permitted in transformed circuit: " ++ x) + +-- | Like 'transform_generic', but applies to arbitrary transformers +-- of type +-- +-- > Transformer m a b +-- +-- instead of the special case +-- +-- > Transformer Circ Qubit Bit. +-- +-- This requires an additional shape argument. +transform_unary_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y') +transform_unary_shape = transform_errmsg errmsg + where + errmsg x = "transform_unary_shape: " ++ x + +-- | Apply the given transformer to a circuit. +transform_unary :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) +transform_unary transformer f x = transform_errmsg errmsg transformer f x x + where + errmsg x = "transform_unary: " ++ x + + +-- | Like transform_unary_shape but for a dynamic transformer +transform_unary_dynamic_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => DynamicTransformer m a b -> (x -> Circ y) -> x -> (x' -> m y') +transform_unary_dynamic_shape dtransformer f shape input = do + let (x, dbcircuit) = encapsulate_dynamic f shape + let in_bind = qc_bind x input + (y,out_bind) <- transform_dbcircuit dtransformer dbcircuit in_bind + let output = qc_unbind out_bind y + return output + +-- | Like transform_unary but for a dynamic transformer +transform_unary_dynamic :: (QCData x, QCData y) => DynamicTransformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) +transform_unary_dynamic dtransformer f x = transform_unary_dynamic_shape dtransformer f x x + + +-- | Like 'transform_generic', but applies to arbitrary transformers +-- of type +-- +-- > Transformer m a b +-- +-- instead of the special case +-- +-- > Transformer Circ Qubit Bit. +-- +-- This requires an additional shape argument. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > transform_generic :: (QCData x) => Transformer m a b -> Circ x -> m (QCData a b x) +-- > transform_generic :: (QCData x, QCData y) => Transformer m a b -> (x -> Circ y) -> x -> (QCData a b x -> m (QCData a b y)) +-- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer m a b -> (x -> y -> Circ z) -> x -> y -> (QCData a b x -> QCData a b y -> m (QCData a b z)) +-- +-- and so forth. + +transform_generic_shape :: (QCData x, QCData y, QCurry qfun x y, Curry qfun' x' (m y'), Curry qfun'' x qfun', x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> qfun -> qfun'' +transform_generic_shape transformer f = g where + f1 = quncurry f + g1 = transform_errmsg errmsg transformer f1 + g2 = \x -> mcurry (g1 x) + g = mcurry g2 + errmsg x = "transform_generic: " ++ x + +-- | Apply the given transformer to a circuit. Unlike +-- 'transform_unary', this function 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: +-- +-- > transform_generic :: (QCData x) => Transformer Circ Qubit Bit -> Circ x -> Circ x +-- > transform_generic :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) +-- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer Circ Qubit Bit -> (x -> y -> Circ z) -> (x -> y -> Circ z) +-- +-- and so forth. + +transform_generic :: (QCData x, QCData y, QCurry qfun x y) => Transformer Circ Qubit Bit -> qfun -> qfun +transform_generic transformer f = g where + f1 = quncurry f + g1 = \x -> transform_errmsg errmsg transformer f1 x x + g = qcurry g1 + errmsg x = "transform_generic: " ++ x + + +-- ====================================================================== +-- * Generic block structure + +-- | Execute a block with local ancillas. Opens a block, initializing an ancilla with a specified classical value, and terminates it with the same value when the block closes. Note: it is the programmer's responsibility to return the ancilla to its original state at the end of the enclosed block. Usage: +-- +-- > with_ancilla_init True $ \a -> do { +-- > <<>> +-- > } +-- +-- > with_ancilla_init [True,False,True] $ \a -> do { +-- > <<>> +-- > } +with_ancilla_init :: (QShape a qa ca) => a -> (qa -> Circ b) -> Circ b +with_ancilla_init x f = do + qx <- without_controls (qinit x) + qy <- f qx + without_controls (qterm x qx) + return qy + +-- | Like 'with_ancilla', but creates a list of /n/ ancillas, all +-- initialized to |0〉. Usage: +-- +-- > with_ancilla_list n $ \a -> do { +-- > <<>> +-- > } +with_ancilla_list :: Int -> (Qulist -> Circ a) -> Circ a +with_ancilla_list n f = + with_ancilla_init (replicate n False) f + +-- | @'with_computed_fun' /x/ /f/ /g/@: computes /x' := f(x)/; then computes /g(x')/, which should be organized as a pair /(x',y)/; then uncomputes /x'/ back to /x/, and returns /(x,y)/. +-- +-- Important subtlety in usage: all quantum data referenced in /f/, even as controls, must be explicitly bound and returned by /f/, or the reversing may rebind it incorrectly. /g/, on the other hand, can safely refer to anything that is in scope outside the 'with_computed_fun'. + +with_computed_fun :: (QCData x, QCData y) => x -> (x -> Circ y) -> (y -> Circ (y,b)) -> Circ (x,b) +with_computed_fun x f g = do + y <- without_controls (f x) + (y,b) <- g y + x <- without_controls (reverse_generic f x y) + return (x,b) + +-- | @'with_computed' /computation/ /code/@: performs /computation/ +-- (with result /x/), then performs /code/ /x/, and finally performs +-- the reverse of /computation/, for example like this: +-- +-- \[image with_computed.png] +-- +-- Both /computation/ and /code/ may refer to any qubits that exist in +-- the current environment, and they may also create new +-- qubits. /computation/ may produce arbitrary garbage in addition to +-- its output. +-- +-- This is a very general but relatively unsafe operation. It is the +-- user's responsibility to ensure that the computation can indeed be +-- undone. In particular, if /computation/ contains any +-- initializations, then /code/ must ensure that the corresponding +-- assertions will be satisfied in /computation/[sup −1]. +-- +-- Related more specialized, but potentially safer, operations are: +-- +-- * 'with_basis_change', which is like 'with_computed', but assumes +-- that /computation/ is unitary, and +-- +-- * 'Quipper.classical_to_reversible', which assumes that /computation/ is +-- classical (or pseudo-classical), and /code/ is a simple +-- copy-by-controlled-not operation. + +with_computed :: (QCData x) => Circ x -> (x -> Circ b) -> Circ b +with_computed computation code = do + (bcirc, dirty, x) <- extract_in_context errmsg computation + without_controls $ do + unextract_in_context bcirc + y <- with_reserve dirty $ do + code x + without_controls $ do + unextract_in_context (reverse_bcircuit bcirc) + return y + where + errmsg x = "with_computed: operation not permitted in pre-computation: " ++ x + +-- | @'with_basis_change' /basischange/ /code/@: performs a basis change, +-- then the /code/, then the inverse of the basis change. Both +-- /basischange/ and /code/ are in imperative style. It is the user's +-- responsibility to ensure that the image of /code/ is contained in +-- the image of /basischange/, or else there will be unmet assertions +-- or runtime errors. Usage: +-- +-- > with_basis_change basischange $ do +-- > <<>> +-- > +-- > where +-- > basischange = do +-- > <<>> + +with_basis_change :: Circ () -> Circ b -> Circ b +with_basis_change basischange code = do + with_computed basischange (\x -> code) + +-- ====================================================================== +-- * Boxed subcircuits + + +-- | Bind a name to a function as a subroutine in the current +-- namespace. This requires a shape argument, as well as complete +-- parameters, so that it is uniquely determined which actual circuit +-- will be the subroutine. It is an error to call that subroutine +-- later with a different shape argument. It is therefore the user's +-- responsibility to ensure that the name is unique to the subroutine, +-- parameters, and shape. +-- +-- This function does nothing if the name +-- already exists in the namespace; in particular, it does /not/ check +-- whether the given function is equal to the stored subroutine. +provide_subroutine_generic :: (QCData x, QCData y) => ErrMsg -> BoxId -> Bool -> (x -> Circ y) -> x -> Circ () +provide_subroutine_generic e name is_classically_controllable f shape = do + main_state <- get_namespace + if (Map.member name main_state) + then return () + else do + (x, bcircuit, y) <- encapsulate_generic_in_namespace errmsg f shape + + -- The 'y' element only corresponds to the output type of the box, + -- not the complete list of wires outputted by the circuit. This + -- information is gathered and stored in forgotten_output_qcdata + -- as ([Qubit],[Bit]). + let ((_,_,aout,_),_) = bcircuit + forgotten_output_arity = strip_qcdata_from_arity y aout + forgotten_output_qcdata = extract_from_arity forgotten_output_arity + + let ein = endpoints_of_qcdata x + eout = endpoints_of_qcdata (y,forgotten_output_qcdata) + win = map wire_of_endpoint ein + wout = map wire_of_endpoint eout + + input_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata + input_structure = (\(ws,a) -> qcdata_of_endpoints x $ endpoints_of_wires_in_arity a ws) + + input_CircTypeStructure = CircuitTypeStructure input_destructure input_structure + + output_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata + output_structure = (\(ws,a) -> qcdata_of_endpoints (y,forgotten_output_qcdata) $ endpoints_of_wires_in_arity a ws) + + output_CircTypeStructure = CircuitTypeStructure output_destructure output_structure + + provide_subroutine name (ob_circuit win bcircuit wout) input_CircTypeStructure output_CircTypeStructure is_classically_controllable + where + errmsg x = e ("operation not permitted in boxed subroutine: " ++ x) + + -- Make a 'QCData' out of an arity. + extract_from_arity :: Arity -> ([Qubit],[Bit]) + extract_from_arity x = + fst $ IntMap.mapAccumWithKey record_wire ([],[]) x + where + record_wire :: ([Qubit],[Bit]) -> Int -> Wiretype -> (([Qubit],[Bit]),Wiretype) + record_wire (qs,bs) wire Qbit = (((qubit_of_wire wire):qs,bs), Qbit) + record_wire (qs,bs) wire Cbit = ((qs,(bit_of_wire wire):bs), Cbit) + + -- Take a 'QCData' /x/ and an 'Arity' /a/ and remove all the wires + -- of /a/ that are already existing in /x/. + strip_qcdata_from_arity :: (QCData x) => x -> Arity -> Arity + strip_qcdata_from_arity x a = + snd $ State.runState (qcdata_mapM x delete_qubit delete_bit x) a + where + + delete_qubit :: Qubit -> State.State Arity () + delete_qubit q = do + s <- State.get + State.put $ flip IntMap.delete s $ wire_of_qubit q + + delete_bit :: Bit -> State.State Arity () + delete_bit b = do + s <- State.get + State.put $ flip IntMap.delete s $ wire_of_bit b + + + + + + +-- | A generic interface for wrapping a circuit-generating function +-- into a boxed and named subroutine. This takes a name and a +-- circuit-generating function, and returns a new circuit-generating +-- function of the same type, but which inserts a boxed subroutine +-- instead of the actual body of the subroutine. +-- +-- It is intended to be used like this: +-- +-- > somefunc :: Qubit -> Circ Qubit +-- > somefunc a = do ... +-- > +-- > somefunc_boxed :: Qubit -> Circ Qubit +-- > somefunc_boxed = box "somefunc" somefunc +-- +-- Here, the type of @somefunc@ is just an example; this could indeed +-- be a function with any number and type of arguments, as long as the +-- arguments and return type are quantum data. +-- +-- It is also possible to inline the 'box' operator directly, in which +-- case it should be done like this: +-- +-- > somefunc :: Qubit -> Circ Qubit +-- > somefunc = box "somefunc" $ \a -> do ... +-- +-- Note: The 'box' operator wraps around a complete function, +-- including all of its arguments. It would be incorrect to apply the +-- 'box' operator after some quantum variables have already been +-- defined. Thus, the following is incorrect: +-- +-- > incorrect_somefunc :: Qubit -> Circ Qubit +-- > incorrect_somefunc a = box "somefunc" $ do ... +-- +-- It is the user's responsibility not to use the same name for +-- different subroutines. If 'box' is called more than once with the +-- same name and shape of input, Quipper assumes, without checking, +-- that they are subsequent calls to the same subroutine. +-- +-- The type of the 'box' operator is overloaded and quite difficult to +-- read. It can have for example the following types: +-- +-- > box :: String -> (Qubit -> Circ Qubit) -> (Qubit -> Circ Qubit) +-- > box :: String -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt)) -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt)) +box :: (QCData qa, QCData qb, QCurry qa_qb qa qb) + => String -> qa_qb -> qa_qb +box n = qcurry . (box_internal err n $ RepeatFlag 1) . quncurry + where + err e = "box: " ++ e + +-- | A version of 'box' with iteration. The second argument is an +-- iteration count. +-- +-- This can only be applied to functions of a single argument, where +-- the input and output types are the same. +nbox :: (QCData qa) => String -> Integer -> (qa -> Circ qa) -> qa -> Circ qa +nbox n rep = qcurry . (box_internal err n (RepeatFlag rep)) . quncurry + where + err e = "nbox: " ++ e + +-- | A version of 'nbox' with same type as 'loopM'. +box_loopM :: (Integral int, QCData qa) + => String -> int -> qa -> (qa -> Circ qa) -> Circ qa +box_loopM n rep = flip (nbox n $ fromIntegral rep) + +-- | A version of 'loopM' that will be boxed conditionally on a +-- boolean condition. Typical usage: +-- +-- > loopM_boxed_if (s > 1) "name" s x $ \x -> do +-- > <<>> +-- > return x +loopM_boxed_if :: (Integral int, QCData qa) => Bool -> String -> int -> qa -> (qa -> Circ qa) -> Circ qa +loopM_boxed_if True name = box_loopM name +loopM_boxed_if False name = loopM + +-- | The underlying implementation of 'box' and 'nbox'. It behaves +-- like 'box', but is restricted to unary functions, and takes an +-- 'ErrMsg' argument. +box_internal :: (QCData qa, QCData qb) + => ErrMsg -> String -> RepeatFlag -> (qa -> Circ qb) -> (qa -> Circ qb) +box_internal e n r f x = do + let boxid = BoxId n (canonical_shape x) + provide_subroutine_generic e boxid False f x -- By default, fall back on the general controlling scheme: + -- set the classical-control flag to False. + call_subroutine boxid r x + + +-- | Classical control on a function with same shape of input and +-- output: if the control bit is true the function is fired, otherwise +-- the identity map is used. +-- Note: the constraint on the types is dynamically checked. +with_classical_control :: QCData qa => Bit -> String -> qa -> (qa -> Circ qa) -> Circ qa +with_classical_control c n x f = do + let boxid = BoxId n (canonical_shape x) + provide_subroutine_generic err boxid True f x + call_subroutine boxid (RepeatFlag 1) x `controlled` c + where + err e = "with_classical_control: " ++ e + +-- | Like 'call_subroutine', except inline the subroutine body from +-- the given namespace, instead of inserting a subroutine call. +-- +-- Implementation note: this currently copies /all/ subroutine +-- definitions from the given namespace into the current namespace, +-- and not just the ones used by the current subroutine. +-- +-- Implementation note: this currently only works on lists of endpoints. +inline_subroutine :: BoxId -> Namespace -> [Endpoint] -> Circ [Endpoint] +inline_subroutine name ns inputs = do + let mc = Map.lookup name ns + case mc of + Nothing -> + error ("inline_subroutine: subroutine " ++ show name ++ " does not exist in the given namespace: " ++ showNames ns) + Just (TypedSubroutine ocircuit _ _ scf) -> do + let OCircuit (win, circuit, wout) = ocircuit + provide_subroutines ns + when (length win /= length inputs) $ do + error ("inline_subroutine: subroutine " ++ show name ++ " 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 diff --git a/Quipper/Internal/Labels.hs b/Quipper/Internal/Labels.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Labels.hs @@ -0,0 +1,533 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# LANGUAGE OverlappingInstances #-} +#endif + +-- | This module provides functionality for labelling endpoints in +-- wires. The goal is to achieve two things: +-- +-- * Label qubits individually. For example, we would like to label +-- three qubits (/a/, /b/, /c/) as \"a\", \"b\", and \"c\", +-- respectively. +-- +-- * Label data structures all at once. For example, if +-- /a/=[/x/,/y/,/z/] is a piece of quantum data, and we label this +-- data structure \"a\", then the individual qubits will be labelled: +-- /x/ = /a/[0], /y/ = /a/[1], /z/ = /a/[2]. +-- +-- We can also combine both methods to arbitrary nesting levels. For +-- example, we can label (([x,y,z], t), [u,v,w]) as (\"a\", [\"u\", +-- \"v\", \"w\"]), to get the labelling /x/ = /a/[0,0], /y/ = +-- /a/[0,1], /z/ = /a/[0,2], /t/ = /a/[1], /u/ = /u/, /v/ = /v/, /w/ = +-- /w/. + +module Quipper.Internal.Labels where + +import Quipper.Internal.Circuit +import Quipper.Internal.Monad +import Quipper.Utils.Auxiliary +import Quipper.Utils.Tuple +import Quipper.Internal.Transformer + +import qualified Data.Map as Map +import Data.Map (Map) + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ---------------------------------------------------------------------- +-- * Helper functions + +-- ** Indices + +-- | An index list is something that can be appended to a string. We +-- consider subscript indices of the form \"[i]\", dotted indices of +-- the form \".i\", and perhaps arbitrary suffixes. A complication is +-- that we want consecutive subscript indices to be combined, as in +-- \"[i,j,k]\". We therefore need a special data structure to hold an +-- index list \"under construction\". +-- +-- An index list consists of a string and a list of current +-- subscripts. For efficiency, the list of subscripts is reversed, +-- i.e., the most recent subscript is at the head of the list. +type IndexList = (String, [String]) + +-- | Convert an index list to a string. +indexlist_format :: IndexList -> String +indexlist_format (s,idx) = + s ++ string_of_list "[" "," "]" "" id (reverse idx) + +-- | The empty index list. +indexlist_empty :: IndexList +indexlist_empty = ("", []) + +-- | Append a subscript to an index list. +indexlist_subscript :: IndexList -> String -> IndexList +indexlist_subscript (s, idx) i = (s, i:idx) + +-- | Append a dotted index to an index list. +indexlist_dotted :: IndexList -> String -> IndexList +indexlist_dotted idxl i = (indexlist_format idxl ++ "." ++ i, []) + +-- ** The LabelMonad monad + +-- | A monad to provide a convenient syntax for specifying 'Labelable' +-- instances. Computations in this monad have access to a read-only +-- \"current index list\", and they output a binding from wires to +-- strings. +newtype LabelMonad a = LabelMonad { + getLabelMonad :: IndexList -> (Map Wire String, a) + } + +instance Monad LabelMonad where + return a = LabelMonad (\idxl -> (Map.empty, a)) + f >>= g = LabelMonad h where + h idxl = (Map.union m1 m2, z) where + (m1, y) = getLabelMonad f idxl + (m2, z) = getLabelMonad (g y) idxl + +instance Applicative LabelMonad where + pure = return + (<*>) = ap + +instance Functor LabelMonad where + fmap = liftM + +-- | Get the current string and index. +labelmonad_get_indexlist :: LabelMonad IndexList +labelmonad_get_indexlist = LabelMonad h where + h idxl = (Map.empty, idxl) + +-- | Output a binding for a label +labelmonad_put_binding :: Wire -> String -> LabelMonad () +labelmonad_put_binding x label = LabelMonad h where + h idxl = (Map.singleton x label, ()) + +-- | Run a subcomputation with a new current index list. +labelmonad_with_indexlist :: IndexList -> LabelMonad a -> LabelMonad a +labelmonad_with_indexlist idxl body = LabelMonad h where + h idxl' = getLabelMonad body idxl + +-- | Extract a labelling from a label monad computation. This is the +-- run function of the label monad. +labelmonad_run :: LabelMonad () -> Map Wire String +labelmonad_run body = bindings where + (bindings, _) = getLabelMonad body indexlist_empty + +-- ---------------------------------------------------------------------- +-- ** Formatting of labels + +-- | Label a wire with the given name, using the current index. +label_wire :: Wire -> String -> LabelMonad () +label_wire x s = do + idxl <- labelmonad_get_indexlist + let label = s ++ indexlist_format idxl + labelmonad_put_binding x label + +-- | Run a subcomputation with a subscript index appended to the +-- current index list. Sample usage: +-- +-- > with_index "0" $ do +-- > <<>> +with_index :: String -> LabelMonad () -> LabelMonad () +with_index i body = do + idxl <- labelmonad_get_indexlist + labelmonad_with_indexlist (indexlist_subscript idxl i) body + +-- | Run a subcomputation with a dotted index appended to the current +-- index list. Sample usage: +-- +-- > with_dotted_index "left" $ do +-- > <<>> + +with_dotted_index :: String -> LabelMonad () -> LabelMonad () +with_dotted_index i body = do + idxl <- labelmonad_get_indexlist + labelmonad_with_indexlist (indexlist_dotted idxl i) body + +-- | Like 'with_index', except the order of the arguments is +-- reversed. This is intended to be used as an infix operator: +-- +-- > <<>> `indexed` "0" +indexed :: LabelMonad () -> String -> LabelMonad () +indexed body i = with_index i body + +-- | Like 'with_dotted_index', except the order of the arguments is +-- reversed. This is intended to be used as an infix operator: +-- +-- > <<>> `dotted_indexed` "left" +dotted_indexed :: LabelMonad () -> String -> LabelMonad () +dotted_indexed body i = with_dotted_index i body + +-- | Do nothing. +label_empty :: LabelMonad () +label_empty = return () + +-- ---------------------------------------------------------------------- +-- * The Labelable type class + +-- | 'Labelable' /a/ /s/ means that /a/ is a data structure that can +-- be labelled with the format /s/. A \"format\" is a string, or a +-- data structure with strings at the leaves. + +class Labelable a s where + -- | Recursively label a data structure with the given format. + label_rec :: a -> s -> LabelMonad () + +-- | Given a data structure and a format, return a list of labelled +-- wires. +mklabel :: (Labelable a s) => a -> s -> [(Wire, String)] +mklabel a s = Map.toList bindings where + bindings = labelmonad_run (label_rec a s) + +instance Labelable Qubit String where + label_rec a s = label_wire (wire_of_qubit a) s + +instance Labelable Bit String where + label_rec a s = label_wire (wire_of_bit a) s + +instance (Labelable a String) => Labelable (Signed a) String where + label_rec (Signed a b) s = + label_rec a s `dotted_indexed` (if b then "+" else "-") + +instance (Labelable a String) => Labelable (Signed a) (Signed String) where + label_rec (Signed a b) (Signed s c) + | b == c = label_rec a s + | otherwise = return () -- fail silently + +instance Labelable () String where + label_rec a s = label_empty + +instance Labelable () () where + label_rec a s = label_empty + +instance (Labelable a String, Labelable b String) => Labelable (a,b) String where + label_rec (a,b) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + +instance (Labelable a String, Labelable b String, Labelable c String) => Labelable (a,b,c) String where + label_rec (a,b,c) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String) => Labelable (a,b,c,d) String where + label_rec (a,b,c,d) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String) => Labelable (a,b,c,d,e) String where + label_rec (a,b,c,d,e) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String) => Labelable (a,b,c,d,e,f) String where + label_rec (a,b,c,d,e,f) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + label_rec f s `indexed` "5" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String) => Labelable (a,b,c,d,e,f,g) String where + label_rec (a,b,c,d,e,f,g) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + label_rec f s `indexed` "5" + label_rec g s `indexed` "6" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String) => Labelable (a,b,c,d,e,f,g,h) String where + label_rec (a,b,c,d,e,f,g,h) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + label_rec f s `indexed` "5" + label_rec g s `indexed` "6" + label_rec h s `indexed` "7" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String) => Labelable (a,b,c,d,e,f,g,h,i) String where + label_rec (a,b,c,d,e,f,g,h,i) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + label_rec f s `indexed` "5" + label_rec g s `indexed` "6" + label_rec h s `indexed` "7" + label_rec i s `indexed` "8" + +instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String, Labelable j String) => Labelable (a,b,c,d,e,f,g,h,i,j) String where + label_rec (a,b,c,d,e,f,g,h,i,j) s = do + label_rec a s `indexed` "0" + label_rec b s `indexed` "1" + label_rec c s `indexed` "2" + label_rec d s `indexed` "3" + label_rec e s `indexed` "4" + label_rec f s `indexed` "5" + label_rec g s `indexed` "6" + label_rec h s `indexed` "7" + label_rec i s `indexed` "8" + label_rec j s `indexed` "9" + +instance (Labelable a sa, Labelable b sb) => Labelable (a,b) (sa,sb) where + label_rec (a,b) (sa,sb) = do + label_rec a sa + label_rec b sb + +instance (Labelable a sa, Labelable b sb, Labelable c sc) => Labelable (a,b,c) (sa, sb, sc) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd) => Labelable (a,b,c,d) (sa, sb, sc, sd) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se) => Labelable (a,b,c,d,e) (sa, sb, sc, sd, se) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf) => Labelable (a,b,c,d,e,f) (sa, sb, sc, sd, se, sf) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg) => Labelable (a,b,c,d,e,f,g) (sa, sb, sc, sd, se, sf, sg) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh) => Labelable (a,b,c,d,e,f,g,h) (sa, sb, sc, sd, se, sf, sg, sh) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si) => Labelable (a,b,c,d,e,f,g,h,i) (sa, sb, sc, sd, se, sf, sg, sh, si) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si, Labelable j sj) => Labelable (a,b,c,d,e,f,g,h,i,j) (sa, sb, sc, sd, se, sf, sg, sh, si, sj) where + label_rec a s = label_rec (untuple a) (untuple s) + +instance {-# OVERLAPPING #-} (Labelable a String) => Labelable [a] String where + label_rec as s = do + sequence_ [ label_rec a s `indexed` show i | (a,i) <- zip as [0..] ] + +instance (Labelable a s) => Labelable [a] [s] where + label_rec as ss = do + sequence_ [ label_rec a s | (a,s) <- zip as ss ] + +instance (Labelable a String, Labelable b String) => Labelable (B_Endpoint a b) String where + label_rec (Endpoint_Qubit a) s = label_rec a s + label_rec (Endpoint_Bit b) s = label_rec b s + +instance (Labelable a s, Labelable b t) => Labelable (B_Endpoint a b) (B_Endpoint s t) where + label_rec (Endpoint_Qubit a) (Endpoint_Qubit s) = label_rec a s + label_rec (Endpoint_Bit b) (Endpoint_Bit t) = label_rec b t + label_rec _ _ = return () -- fail silently + +-- ---------------------------------------------------------------------- +-- Parameters are labellable + +-- Since parameters (such as Integers) are 'Quipper.QCData', they must +-- also be labellable. However, they have no qubits, so the labels are +-- trivial (there are 0 labels on such a type). + +instance Labelable Integer String where + label_rec a s = label_empty + +instance Labelable Int String where + label_rec a s = label_empty + +instance Labelable Double String where + label_rec a s = label_empty + +instance Labelable Float String where + label_rec a s = label_empty + +instance Labelable Char String where + label_rec a s = label_empty + +-- ====================================================================== +-- * High-level functions + +-- | Insert a comment in the circuit. This is not a gate, and has no +-- effect, except to mark a spot in the circuit. How the comment is +-- displayed depends on the printing backend. +comment :: String -> Circ () +comment s = comment_with_label s () () + +-- | Label qubits in the circuit. This is not a gate, and has no +-- effect, except to make the circuit more readable. How the labels +-- are displayed depends on the printing backend. This can take +-- several different forms. Examples: +-- +-- Label /q/ as @q@ and /r/ as @r@: +-- +-- > label (q,r) ("q", "r") +-- +-- Label /a/, /b/, and /c/ as @a@, @b@, and @c@, respectively: +-- +-- > label [a,b,c] ["a", "b", "c"] +-- +-- Label /q/ as @x[0]@ and /r/ as @x[1]@: +-- +-- > label (q,r) "x" +-- +-- Label /a/, /b/, and /c/ as @x[0]@, @x[1]@, @x[2]@: +-- +-- > label [a,b,c] "x" +label :: (Labelable qa labels) => qa -> labels -> Circ () +label qa labels = comment_with_label "" qa labels + +-- | Combine 'comment' and 'label' in a single command. +comment_with_label :: (Labelable qa labels) => String -> qa -> labels -> Circ () +comment_with_label comment qa labels = + comment_label comment False (mklabel qa labels) + +-- ====================================================================== +-- * Defining new Labelable instances + +-- $ A 'Labelable' instance should be defined for each new instance of +-- 'Quipper.QCData'. The general idea is that the structure of the label +-- should exactly follow the structure of the data being labeled, +-- except that at any level the label can be a string (which will then +-- be decorated with appropriate subscripts for each leaf in the +-- data structure). +-- +-- In practice, there are two cases to consider: adding a new +-- 'Quipper.QCData' constructor, and adding a new atomic 'Quipper.QCData'. +-- +-- [New 'Quipper.QCData' constructors] +-- +-- Consider the case of a new 'Quipper.QCData' constructor: +-- +-- > instance (QCData a) => QCData (Constructor a). +-- +-- There are two required 'Labelable' instances. The first instance +-- deals with a label that is a string, and takes the following form: +-- +-- > instance (Labelable a String) => Labelable (Constructor a) String where +-- > label_rec as s = do +-- > label_rec <<>> s `indexed` <<>> +-- > ... +-- > label_rec <<>> s `indexed` <<>> +-- +-- Here, /a/[sub 1].../a/[sub /n/] are the components of the data +-- structure, and /index/[sub 1].../index[sub /n/] are the +-- corresponding subscripts. The function 'indexed' appends a +-- subscript of the form \"[i]\". There is a similar function +-- 'dotted_indexed', which appends a subscript of the form \".i\". +-- +-- The second required instance deals with a label that is a data +-- structure of the same shape as the data being labeled. It takes the +-- form: +-- +-- > instance (Labelable a s) => Labelable (Constructor a) (Constructor s) where +-- > label_rec as ss idx = do +-- > label_rec <<>> <<>> +-- > ... +-- > label_rec <<>> <<>> +-- +-- Here, /a/[sub 1].../a/[sub /n/] are the components of the data +-- structure, and /s/[sub 1].../s/[sub /n/] are the corresponding +-- components of the label. +-- +-- [Example] +-- +-- As a concrete example, consider a constructor +-- +-- > data MaybeTwo a = One a | Two a a +-- > instance (QCData a) => QCData (MaybeTwo a) +-- +-- The following instance declarations would be appropriate: +-- +-- > instance (Labelable a String) => Labelable (MaybeTwo a) String where +-- > label_rec (One x) s = +-- > with_dotted_index "one" $ do +-- > label_rec x s +-- > label_rec (Two x y) s = +-- > with_dotted_index "two" $ do +-- > label_rec x s `indexed` "0" +-- > label_rec y s `indexed` "1" +-- > +-- > instance (Labelable a s) => Labelable (MaybeTwo a) (MaybeTwo s) where +-- > label_rec (One x) (One s) = label_rec x s +-- > label_rec (Two x y) (Two s t) = do +-- > label_rec x s +-- > label_rec y t +-- > label_rec _ _ = return () -- fail silently +-- +-- With this example, the commands +-- +-- > mklabel (One x) "s" +-- > mklabel (Two y z) "s" +-- +-- produce the respective labelings +-- +-- > x -> s.one +-- > y -> s.two[0] +-- > z -> s.two[1] +-- +-- [New atomic QCData] +-- +-- Consider the case of a new atomic 'Quipper.QCData' instance: +-- +-- > instance QCData (Atomic x). +-- +-- We usually need a 'Labelable' instance for the cases /x/='Qubit' +-- and /x/='Bit'. This should be done uniformly, by using the 'Quipper.Internal.QData.QCLeaf' +-- type class. The instance takes the following form: +-- +-- > instance QCLeaf x => Labelable (Atomic x) String where +-- > label_rec a s = do +-- > label_rec <<>> s `indexed` <<>> +-- > ... +-- > label_rec <<>> s `indexed` <<>> +-- +-- Here, /a/[sub 1].../a/[sub /n/] are the components of the data +-- structure, and /index/[sub 1].../index[sub /n/] are the +-- corresponding subscripts. It is up to the designer of the data +-- structure to decide what are \"components\" and how they should be +-- labelled. On or more layers of string or numeric indices can be +-- added as appropriate. +-- +-- [Example] +-- +-- Consider the following sample atomic quantum data. A real number +-- consists of an exponent, a sign, and a list of digits. +-- +-- > data MyReal x = MyReal Int x [x] +-- > instance QCLeaf x => QCData (MyReal x) +-- +-- The following instance declaration would be appropriate: +-- +-- > instance QCLeaf x => Labelable (MyReal x) String where +-- > label_rec (MyReal exp sign digits) s = do +-- > label_rec sign s `dotted_indexed` "sign" +-- > with_dotted_index "digit" $ do +-- > sequence_ [ label_rec d s `indexed` show i | (d,i) <- zip digits [-exp..] ] +-- +-- With this example, the command +-- +-- > mklabel (MyReal 2 x [y0, y1, y2, y3]) "s" +-- +-- produces the labeling +-- +-- > x -> "s.sign" +-- > y0 -> "s.digit[-2]" +-- > y1 -> "s.digit[-1]" +-- > y2 -> "s.digit[0]" +-- > y3 -> "s.digit[1]" +-- +-- Note that we could have also used the default labeling for the +-- members of a list, but in this case, it was convenient to use a +-- custom labeling. diff --git a/Quipper/Internal/Monad.hs b/Quipper/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Monad.hs @@ -0,0 +1,1819 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module provides a high-level circuit building interface +-- intended to look \"functional\". At a given time, there is a +-- circuit being assembled. This circuit has free endpoints (on the +-- left and right) that can be bound to variables. A qubit or bit is +-- simply an endpoint in such a circuit. \"Applying\" an operation to +-- a qubit or bit simply appends the operation to the current +-- circuit. We use the 'Circ' monad to capture the side effect of +-- assembling a circuit. + +module Quipper.Internal.Monad ( + -- * The ReadWrite monad + ReadWrite(..), + + -- * The Circ monad + Circ, + + -- * Some types + Qubit, + Bit, + Endpoint, + Signed(..), -- re-exported from Quipper.Internal.Circuit + Ctrl, + Qulist, + Bitlist, + Timestep, -- re-exported from Quipper.Internal.Circuit + InverseFlag, -- re-exported from Quipper.Internal.Circuit + + -- * Conversions for wires, qubits, bits, endpoints + wire_of_qubit, + wire_of_bit, + wire_of_endpoint, + wires_with_arity_of_endpoints, + qubit_of_wire, + bit_of_wire, + endpoint_of_wire, + endpoints_of_wires_in_arity, + + -- * Bindings for qubits and bits + bind_qubit, + bind_bit, + unbind_qubit, + unbind_bit, + + -- * Controls for qubits and bits + clist_add_qubit, + clist_add_bit, + + -- * Namespace management + provide_simple_subroutine, + provide_subroutine, + provide_subroutines, + call_subroutine, + get_namespace, + set_namespace, + + put_subroutine_definition, + + -- * Basic gates + -- ** Gates in functional style + qnot, + hadamard, + gate_H, + gate_X, + gate_Y, + gate_Z, + gate_S, + gate_S_inv, + gate_T, + gate_T_inv, + gate_E, + gate_E_inv, + gate_omega, + gate_V, + gate_V_inv, + swap_qubit, + expZt, + rGate, + gate_W, + gate_iX, + gate_iX_inv, + global_phase, + global_phase_anchored_list, + qmultinot_list, + cmultinot_list, + named_gate_qulist, + named_rotation_qulist, + cnot, + swap_bit, + -- ** Gates in imperative style + qnot_at, + hadamard_at, + gate_H_at, + gate_X_at, + gate_Y_at, + gate_Z_at, + gate_S_at, + gate_S_inv_at, + gate_T_at, + gate_T_inv_at, + gate_E_at, + gate_E_inv_at, + gate_omega_at, + gate_V_at, + gate_V_inv_at, + swap_qubit_at, + expZt_at, + rGate_at, + gate_W_at, + gate_iX_at, + gate_iX_inv_at, + qmultinot_list_at, + cmultinot_list_at, + named_gate_qulist_at, + named_rotation_qulist_at, + cnot_at, + swap_bit_at, + -- ** Bitwise initialization and termination functions + qinit_qubit, + qterm_qubit, + qdiscard_qubit, + prepare_qubit, + unprepare_qubit, + measure_qubit, + cinit_bit, + cterm_bit, + cdiscard_bit, + dterm_bit, + + -- ** Classical gates + -- $CLASSICAL + cgate_xor, + cgate_eq, + cgate_if_bit, + cgate_not, + cgate_and, + cgate_or, + cgate, + cgateinv, + + -- ** Subroutines + subroutine, + + -- ** Comments + comment_label, + without_comments, + + -- ** Dynamic lifting + dynamic_lift_bit, + + -- * Other circuit-building functions + qinit_plusminus, + qinit_of_char, + qinit_of_string, + qinit_list, + qterm_list, + cinit_list, + + -- * Higher-order functions + with_ancilla, + with_controls, + controlled, + without_controls, + without_controls_if, + + -- ** Deprecated special cases + qinit_qubit_ancilla, + qterm_qubit_ancilla, + + -- * Circuit transformers + identity_transformer, + identity_dynamic_transformer, + apply_circuit_with_bindings, + apply_bcircuit_with_bindings, + apply_dbcircuit_with_bindings, + + -- * Encapsulated circuits + extract_simple, + extract_general, + extract_in_context, + extract_in_current_namespace, + unextract_in_context, + reverse_encapsulated, + with_reserve +) where + +-- import other Quipper stuff +import Quipper.Internal.Circuit +import Quipper.Utils.Auxiliary +import Quipper.Internal.Transformer +import Quipper.Internal.Control + +-- import other stuff +import Control.Monad +import Control.Monad.Fail +import Data.Typeable + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ====================================================================== +-- * The Circ monad + +-- ---------------------------------------------------------------------- +-- ** States + +-- | A flag to indicate whether comments are disabled ('True') or +-- enabled ('False'). +type NoCommentFlag = Bool + +-- | Holds the state during circuit construction. Currently this has +-- four components: the output arity of the circuit currently being +-- assembled, the current 'Namespace', the currently active +-- 'ControlList' and 'NoControlFlag', and a flag to determine whether +-- comments are disabled. All gates that are appended will have the +-- controls from the 'ControlList' added to them. +data State = State { + arity :: !ExtArity, + namespace :: !Namespace, + clist :: !ControlList, + ncflag :: !NoControlFlag, + nocommentflag :: !NoCommentFlag +} + +-- | Return a completely empty state, suitable to be the starting +-- state for circuit construction. +empty_state :: State +empty_state = State { + arity = arity_empty, + namespace = namespace_empty, + clist = clist_empty, + ncflag = False, + nocommentflag = False + } + +-- | Prepare an initial state from the given extended arity. +initial_state :: ExtArity -> State +initial_state arity = empty_state { arity = arity } + +-- ---------------------------------------------------------------------- +-- ** Definition of Circ + +-- $ The 'Circ' monad is a 'ReadWrite' monad, wrapped with an +-- additional state. + +-- | The 'Circ' monad encapsulates the type of quantum operations. For +-- example, a quantum operation that inputs two 'Qubit's and outputs a +-- 'Qubit' and a 'Bit' has the following type: +-- +-- > (Qubit, Qubit) -> Circ (Qubit, Bit) + +-- Implementation note: we could have equivalently defined 'Circ' +-- using Haskell's 'StateT' monad transformer, like this: +-- +-- > Circ = StateT State ReadWrite. +-- +-- But it seems clearer, and certainly more self-contained, to write +-- out the monad laws explicitly. Moreover, 'Circ' will probably look +-- better in error messages than 'StateT' 'State' 'ReadWrite'. + +newtype Circ a = Circ { getCirc :: State -> ReadWrite (a, State) } + +instance Monad Circ where + return a = Circ (\s -> return (a, s)) + f >>= g = Circ h + where + h s0 = do + (a, s1) <- getCirc f s0 + getCirc (g a) s1 + +-- every monad is applicative, and so is this one +instance Applicative Circ where + pure = return + (<*>) = ap + +-- every monad is a functor, and so is this one +instance Functor Circ where + fmap = liftM + +instance MonadFail Circ where + fail s = error s + +-- ====================================================================== +-- ** Monad access primitives + +-- $ Developer note: the 5 functions in this section are the /only/ +-- operations that are permitted to access the monad internals (i.e., +-- 'Circ' and 'getCirc') directly. + +-- | Get the 'Circ' monad's state. +get_state :: Circ State +get_state = Circ $ \s -> return (s, s) + +-- | Set the 'Circ' monad's state. +set_state :: State -> Circ () +set_state s = Circ $ \t -> return ((), s) + +-- | Pass a gate to the 'Circ' monad. Note that this is a low-level +-- monad access function, and does not update other parts of the +-- monad's data. For a higher-level function, see 'apply_gate'. +put_gate :: Gate -> Circ () +put_gate g = Circ $ \s -> RW_Write g (return ((), s)) + +-- | Issue a prompt and receive a reply. +do_read :: Wire -> Circ Bool +do_read w = Circ $ \s -> RW_Read w (\bool -> return (bool, s)) + +-- | Issue a RW_Subroutine primitive +put_subroutine_definition :: BoxId -> TypedSubroutine -> Circ () +put_subroutine_definition name subroutine = Circ $ \s -> RW_Subroutine name subroutine (return ((), s)) + +-- | This is the universal \"run\" function for the 'Circ' monad. It +-- takes as parameters a 'Circ' computation, and an initial state. It +-- outputs 'ReadWrite' computation for the result of the 'Circ' +-- computation and the final state. +run_circ :: Circ a -> State -> ReadWrite (a, State) +run_circ = getCirc + +-- ---------------------------------------------------------------------- +-- ** Low-level state manipulation + +-- $ The functions in this section are the /only/ operations that are +-- permitted to operate on states directly (i.e., to use 'get_state' +-- and 'set_state'). All other code in this module should access the +-- state using these abstractions. Code in other modules can't access +-- the state at all, but should use exported functions (and preferably +-- 'QShape.encapsulate_generic') when it is necessary to extract +-- low-level circuits. + +-- | Get the 'arity' part of the 'Circ' monad's state. +get_arity :: Circ ExtArity +get_arity = do + s <- get_state + return (arity s) + +-- | Set the 'arity' part of the 'Circ' monad's state. +set_arity :: ExtArity -> Circ () +set_arity arity = do + s <- get_state + set_state s { arity = arity } + +-- | Get the 'namespace' part of the 'Circ' monad's state. +get_namespace :: Circ Namespace +get_namespace = do + s <- get_state + return (namespace s) + +-- | Set the 'namespace' part of the 'Circ' monad's state. +set_namespace :: Namespace -> Circ () +set_namespace namespace = do + s <- get_state + set_state s { namespace = namespace } + +-- | Get the 'clist' part of the 'Circ' monad's state. +get_clist :: Circ ControlList +get_clist = do + s <- get_state + return (clist s) + +-- | Set the 'clist' part of the 'Circ' monad's state. +set_clist :: ControlList -> Circ () +set_clist clist = do + s <- get_state + set_state s { clist = clist } + +-- | Get the 'ncflag' part of the 'Circ' monad's state. +get_ncflag :: Circ NoControlFlag +get_ncflag = do + s <- get_state + return (ncflag s) + +-- | Set the 'ncflag' part of the 'Circ' monad's state. +set_ncflag :: NoControlFlag -> Circ () +set_ncflag ncflag = do + s <- get_state + set_state s { ncflag = ncflag } + +-- | Get the 'nocommentflag' part of the 'Circ' monad's state. +get_nocommentflag :: Circ NoCommentFlag +get_nocommentflag = do + s <- get_state + return (nocommentflag s) + +-- | Set the 'nocommentflag' part of the 'Circ' monad's state. +set_nocommentflag :: NoCommentFlag -> Circ () +set_nocommentflag nocommentflag = do + s <- get_state + set_state s { nocommentflag = nocommentflag } + +-- ---------------------------------------------------------------------- +-- ** Circuit extraction + +-- | Extract a circuit from a monadic term, starting from the given +-- arity. This is the \"simple\" extract function, which does not +-- allow dynamic lifting. The 'ErrMsg' argument is a stub error message +-- to be used in case an illegal operation is encountered. +extract_simple :: ErrMsg -> ExtArity -> Circ a -> (BCircuit, a) +extract_simple e arity f = (bcirc, y) where + comp = extract_general arity f + (bcirc, y) = bcircuit_of_static_dbcircuit e comp + + +-- | Run a monadic term in the initial arity, and extract a dynamic +-- boxed circuit. +extract_general :: ExtArity -> Circ a -> DBCircuit a +extract_general arity_in f = (a0, mmap finalize comp) where + a0 = arity_of_extarity arity_in + s0 = initial_state arity_in + comp = run_circ f s0 + finalize (a, s1) = (a1, n, a) where + arity_out = arity s1 + a1 = arity_of_extarity arity_out + n = n_of_extarity arity_out + +-- ====================================================================== +-- * Some types + +-- | The type of qubits. +newtype Qubit = QubitWire Wire + deriving (Show, Eq, Ord, Typeable) + +-- | The type of run-time classical bits (i.e., boolean wires in a +-- circuit). +newtype Bit = BitWire Wire + deriving (Show, Eq, Ord, Typeable) + +-- | An endpoint in a circuit. This is either a 'Qubit' or a 'Bit'. +type Endpoint = B_Endpoint Qubit Bit + +-- | A control consists of an 'Endpoint' and a boolean ('True' = +-- perform gate when control wire is 1; 'False' = perform gate when +-- control wire is 0). Note that gates can be controlled by qubits and +-- classical bits. +type Ctrl = Signed Endpoint + +-- | Synonym for a qubit list, for convenience. +type Qulist = [Qubit] + +-- | Synonym for a bit list, for convenience. +type Bitlist = [Bit] + +-- ---------------------------------------------------------------------- +-- * Conversions for wires, qubits, bits, endpoints + +-- | Extract the underlying low-level wire of a qubit. +wire_of_qubit :: Qubit -> Wire +wire_of_qubit (QubitWire w) = w + +-- | Extract the underlying low-level wire of a bit. +wire_of_bit :: Bit -> Wire +wire_of_bit (BitWire w) = w + +-- | Construct a qubit from a wire. +qubit_of_wire :: Wire -> Qubit +qubit_of_wire w = QubitWire w + +-- | Construct a bit from a wire. +bit_of_wire :: Wire -> Bit +bit_of_wire w = BitWire w + +-- | Extract the underlying low-level 'Wire' of an 'Endpoint'. +wire_of_endpoint :: Endpoint -> Wire +wire_of_endpoint (Endpoint_Qubit q) = wire_of_qubit q +wire_of_endpoint (Endpoint_Bit b) = wire_of_bit b + +-- | Extract the underlying low-level 'Wiretype' of an 'Endpoint'. +wiretype_of_endpoint :: Endpoint -> Wiretype +wiretype_of_endpoint (Endpoint_Qubit _) = Qbit +wiretype_of_endpoint (Endpoint_Bit _) = Cbit + +-- | Break a list of 'Endpoint's down into a list of 'Wire's together with an 'Arity'. +-- (Partial inverse to 'endpoints_of_wires_in_arity'.) +wires_with_arity_of_endpoints :: [Endpoint] -> ([Wire],Arity) +wires_with_arity_of_endpoints es = + let ws_with_ts = map (\e -> (wire_of_endpoint e, wiretype_of_endpoint e)) es + in (map fst ws_with_ts, IntMap.fromList ws_with_ts) + +-- | Create an 'Endpoint' from a low-level 'Wire' and 'Wiretype'. +endpoint_of_wire :: Wire -> Wiretype -> Endpoint +endpoint_of_wire w Qbit = Endpoint_Qubit (qubit_of_wire w) +endpoint_of_wire w Cbit = Endpoint_Bit (bit_of_wire w) + +-- | Create a list of 'Endpoint's from a list of 'Wire's together with an 'Arity', +-- assuming all wires are present in the arity. +endpoints_of_wires_in_arity :: Arity -> [Wire] -> [Endpoint] +endpoints_of_wires_in_arity a = map (\w -> endpoint_of_wire w (a IntMap.! w)) + +-- ---------------------------------------------------------------------- +-- * Bindings for qubits and bits + +-- | Bind a qubit wire to a value, and add it to the given bindings. +bind_qubit :: Qubit -> a -> Bindings a b -> Bindings a b +bind_qubit q x bindings = bind_qubit_wire (wire_of_qubit q) x bindings + +-- | Bind a bit wire to a value, and add it to the given bindings. +bind_bit :: Bit -> b -> Bindings a b -> Bindings a b +bind_bit c x bindings = bind_bit_wire (wire_of_bit c) x bindings + +-- | Retrieve the value of a qubit wire from the given bindings. +-- Throws an error if the wire was bound to a classical bit. +unbind_qubit :: Bindings a b -> Qubit -> a +unbind_qubit bindings q = unbind_qubit_wire bindings (wire_of_qubit q) + +-- | Retrieve the value of a bit wire from the given bindings. Throws +-- an error if the wire was bound to a qubit. +unbind_bit :: Bindings a b -> Bit -> b +unbind_bit bindings c = unbind_bit_wire bindings (wire_of_bit c) + +-- ---------------------------------------------------------------------- +-- * Controls for qubits and bits + +-- | Add a single signed qubit as a control to a control list. +clist_add_qubit :: Qubit -> Bool -> ControlList -> ControlList +clist_add_qubit q b cl = clist_add (wire_of_qubit q) b cl + +-- | Add a single signed bit as a control to a control list. +clist_add_bit :: Bit -> Bool -> ControlList -> ControlList +clist_add_bit c b cl = clist_add (wire_of_bit c) b cl + +instance (ControlSource (Signed a), ControlSource (Signed b)) => ControlSource (Signed (B_Endpoint a b)) where + to_control (Signed (Endpoint_Qubit q) b) = to_control (Signed q b) + to_control (Signed (Endpoint_Bit c) b) = to_control (Signed c b) + +instance (ControlSource a, ControlSource b) => ControlSource (B_Endpoint a b) where + to_control (Endpoint_Qubit q) = to_control q + to_control (Endpoint_Bit c) = to_control c + +instance ControlSource (Signed Qubit) where + to_control (Signed q b) = to_control (Signed (wire_of_qubit q) b) + +instance ControlSource Qubit where + to_control q = to_control (Signed q True) + +instance ControlSource (Signed Bit) where + to_control (Signed q b) = to_control (Signed (wire_of_bit q) b) + +instance ControlSource Bit where + to_control q = to_control (Signed q True) + +-- ====================================================================== +-- * Namespace management + +-- | @'provide_simple_subroutine' name circ in_struct out_struct is_classically_controllable@: +-- if /name/ not already bound, binds it to /circ/. +-- Note: when there’s an existing value, does /not/ check that +-- it’s equal to /circ/. +provide_simple_subroutine :: (Typeable a, Typeable b) => + BoxId -> OCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ () +provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable = do + s <- get_namespace + let OCircuit (win, circ, wout) = ocirc + let c = if controllable_circuit circ then AllCtl else if is_classically_controllable then OnlyClassicalCtl else NoCtl + let typed_subroutine = TypedSubroutine ocirc input_structure output_structure c + let s' = map_provide name typed_subroutine s + set_namespace s' + put_subroutine_definition name typed_subroutine + +-- | @'provide_subroutines' namespace@: +-- Add each subroutine from the /namespace/ to the current circuit, +-- unless a subroutine of that name already exists. +provide_subroutines :: Namespace -> Circ () +provide_subroutines state = do + main_state <- get_namespace + let state1 = Map.union main_state state + set_namespace state1 + let new_subs = Map.difference state main_state -- returns subroutines that are in state, but not main_state + mapM_ (\(n,s) -> put_subroutine_definition n s) (Map.toList new_subs) -- puts a RW_Subroutine for each new subroutine definition + +-- | @'provide_subroutine' name circ@: +-- if /name/ not already bound, binds it to the main circuit of /circ/, +-- and additionally provides any missing subroutines of /circ/. +provide_subroutine :: (Typeable a, Typeable b) => + BoxId -> OBCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ () +provide_subroutine name obcirc input_structure output_structure is_classically_controllable = do + main_state <- get_namespace + let (ocirc,subsubroutines) = obcirc + if Map.member name main_state + then return () + else do + provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable + provide_subroutines subsubroutines + +-- ---------------------------------------------------------------------- +-- * General gate + +-- | Apply the specified low-level gate to the current circuit, using +-- the current controls, and updating the monad state accordingly. +-- This includes run-time well-formedness checks. This is a helper +-- function and is not directly accessible by user code. +apply_gate :: Gate -> Circ () +apply_gate gate = do + arity <- get_arity + clist <- get_clist + ncflag <- get_ncflag + let gate' = gate_with_ncflag ncflag gate + let gate'' = control_gate clist gate' + case gate'' of + Nothing -> return () + Just g -> do + let arity' = arity_append g arity + put_gate g + set_arity arity' + return () + +-- ====================================================================== +-- * Basic gates + +-- ---------------------------------------------------------------------- +-- ** Gates in functional style + +-- | Apply a NOT gate to a qubit. +qnot :: Qubit -> Circ Qubit +qnot q = do + named_gate_qulist "not" False [q] [] + return q + +-- | Apply a Hadamard gate. +hadamard :: Qubit -> Circ Qubit +hadamard q = do + named_gate_qulist "H" False [q] [] + return q + +-- | An alternate name for the Hadamard gate. +gate_H :: Qubit -> Circ Qubit +gate_H = hadamard + +-- | Apply a multiple-not gate, as specified by a list of booleans and +-- qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies +-- a not gate to /q1/ and /q3/, but not to /q2/. +qmultinot_list :: [(Qubit, Bool)] -> Circ [Qubit] +qmultinot_list qbs = do + let qs = map fst $ filter snd qbs + named_gate_qulist "multinot" False qs [] + return (map fst qbs) + +-- | Like 'qmultinot_list', but applies to classical bits instead of +-- qubits. +cmultinot_list :: [(Bit, Bool)] -> Circ [Bit] +cmultinot_list cs = do + let ws = map (wire_of_bit . fst) $ filter snd cs + sequence_ [ apply_gate (CNot w [] False) | w <- ws ] + return (map fst cs) + +-- | Apply a Pauli /X/ gate. +gate_X :: Qubit -> Circ Qubit +gate_X q = do + named_gate_qulist "X" False [q] [] + return q + +-- | Apply a Pauli /Y/ gate. +gate_Y :: Qubit -> Circ Qubit +gate_Y q = do + named_gate_qulist "Y" False [q] [] + return q + +-- | Apply a Pauli /Z/ gate. +gate_Z :: Qubit -> Circ Qubit +gate_Z q = do + named_gate_qulist "Z" False [q] [] + return q + +-- | Apply a Clifford /S/-gate. +gate_S :: Qubit -> Circ Qubit +gate_S q = do + named_gate_qulist "S" False [q] [] + return q + +-- | Apply the inverse of an /S/-gate. +gate_S_inv :: Qubit -> Circ Qubit +gate_S_inv q = do + named_gate_qulist "S" True [q] [] + return q + +-- | Apply a /T/ = √/S/ gate. +gate_T :: Qubit -> Circ Qubit +gate_T q = do + named_gate_qulist "T" False [q] [] + return q + +-- | Apply the inverse of a /T/-gate. +gate_T_inv :: Qubit -> Circ Qubit +gate_T_inv q = do + named_gate_qulist "T" True [q] [] + return q + +-- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. +-- +-- \[image E.png] +-- +-- This gate is the unique Clifford operator with the properties /E/³ +-- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a +-- convenient gate for calculations. For example, every Clifford +-- operator can be uniquely written of the form +-- +-- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/], +-- +-- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8, +-- respectively. +gate_E :: Qubit -> Circ Qubit +gate_E q = do + named_gate_qulist "E" False [q] [] + return q + +-- | Apply the inverse of an /E/-gate. +gate_E_inv :: Qubit -> Circ Qubit +gate_E_inv q = do + named_gate_qulist "E" True [q] [] + return q + +-- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate. +gate_omega :: Qubit -> Circ Qubit +gate_omega q = do + named_gate_qulist "omega" False [q] [] + return q + +-- | Apply a /V/ = √/X/ gate. This is by definition the following gate +-- (see also Nielsen and Chuang, p.182): +-- +-- \[image V.png] +gate_V :: Qubit -> Circ Qubit +gate_V q = do + named_gate_qulist "V" False [q] [] + return q + +-- | Apply the inverse of a /V/-gate. +gate_V_inv :: Qubit -> Circ Qubit +gate_V_inv q = do + named_gate_qulist "V" True [q] [] + return q + +-- | Apply a SWAP gate. +swap_qubit :: Qubit -> Qubit -> Circ (Qubit,Qubit) +swap_qubit q1 q2 = do + named_gate_qulist "swap" False [q1, q2] [] + return (q1,q2) + +-- | Apply a classical SWAP gate. +swap_bit :: Bit -> Bit -> Circ (Bit,Bit) +swap_bit c1 c2 = do + apply_gate (CSwap (wire_of_bit c1) (wire_of_bit c2) [] False) + return (c1,c2) + +-- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter. +expZt :: Timestep -> Qubit -> Circ Qubit +expZt t q = do + named_rotation_qulist "exp(-i%Z)" False t [q] [] + return q + +-- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis. +-- +-- \[image rGate.png] +rGate :: Int -> Qubit -> Circ Qubit +rGate n q = do + named_rotation_qulist "R(2pi/%)" False (2^n) [q] [] + return q + +-- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes +-- the SWAP gate. +-- +-- \[image W.png] +-- +-- The arguments are such that +-- +-- > gate_W |0〉 |0〉 = |00〉 +-- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2 +-- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2 +-- > gate_W |1〉 |1〉 = |11〉. +-- +-- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2] +-- denotes the \"right\" qubit. +gate_W :: Qubit -> Qubit -> Circ (Qubit, Qubit) +gate_W q1 q2 = do + named_gate_qulist "W" False [q1, q2] [] + return (q1, q2) + +-- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/ +-- gate, but with two advantages: +-- +-- * the doubly-controlled /iX/ gate can be implemented in the +-- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/ +-- gate requires /T/-count 7); +-- +-- * the /iX/-gate has determinant 1, and therefore an /n/-times +-- controlled /iX/ gate can be implemented in the Clifford+/T/ gate +-- base with no ancillas. +-- +-- In particular, the /iX/ gate can be used to implement an additional +-- control with /T/-count 8, like this: +-- +-- \[image iX.png] +gate_iX :: Qubit -> Circ Qubit +gate_iX q = do + named_gate_qulist "iX" False [q] [] + return q + +-- | Apply a −/iX/ gate. This is the inverse of 'gate_iX'. +gate_iX_inv :: Qubit -> Circ Qubit +gate_iX_inv q = do + named_gate_qulist "iX" True [q] [] + return q + +-- | Apply a global phase change [exp /i/π/t/], where typically /t/ ∈ +-- [0,2]. This gate is uninteresting if not controlled; however, it +-- has non-trivial effect if it is used as a controlled gate. +global_phase :: Double -> Circ () +global_phase t = do + apply_gate (GPhase t [] [] False) + return () + +-- | Like 'global_phase', except the gate is also \"anchored\" at a +-- particular bit or qubit. This is strictly for graphical +-- presentation purposes, to provide a hint for where the gate should +-- be printed in a circuit diagram. Backends are free to ignore this +-- hint altogether. The anchor is not actually an input to the gate, +-- and it is legal for the anchoring qubit to also be used as a +-- control control. +global_phase_anchored_list :: Double -> [Endpoint] -> Circ () +global_phase_anchored_list t qs = do + apply_gate (GPhase t (map wire_of_endpoint qs) [] False) + return () + +-- | Apply a generic quantum gate to a given list of qubits and a +-- given list of generalized controls. The generalized controls are +-- really inputs to the gate, but are guaranteed not to be modified +-- if they are in a computational basis state. +named_gate_qulist :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +named_gate_qulist name inv operands gencontrols = do + apply_gate (QGate name inv (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False) + return (operands, gencontrols) + +-- | Like 'named_gate_qulist', but produce a named gate that also +-- depends on a real parameter. This is typically used for rotations +-- or phase gates parameterized by an angle. The name can contain +-- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@. +named_rotation_qulist :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) +named_rotation_qulist name inv theta operands gencontrols = do + apply_gate (QRot name inv theta (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False) + return (operands, gencontrols) + +-- | Apply a NOT gate to a classical bit. +cnot :: Bit -> Circ Bit +cnot b = do + apply_gate (CNot (wire_of_bit b) [] False) + return b + +-- ---------------------------------------------------------------------- +-- ** Gates in imperative style + +-- | Apply a NOT gate to a qubit. +qnot_at :: Qubit -> Circ () +qnot_at q = do + qnot q + return () + +-- | Apply a Hadamard gate. +hadamard_at :: Qubit -> Circ () +hadamard_at q = do + hadamard q + return () + +-- | An alternate name for the Hadamard gate. +gate_H_at :: Qubit -> Circ () +gate_H_at = hadamard_at + +-- | Apply a /qmultinot_list/ gate, as specified by a list of booleans and +-- qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies +-- a not gate to /q1/ and /q3/, but not to /q2/. +qmultinot_list_at :: [(Qubit, Bool)] -> Circ () +qmultinot_list_at qs = do + qmultinot_list qs + return () + +-- | Like 'qmultinot_list_at', but applies to classical bits instead of +-- qubits. +cmultinot_list_at :: [(Bit, Bool)] -> Circ () +cmultinot_list_at cs = do + cmultinot_list cs + return () + +-- | Apply a Pauli /X/ gate. +gate_X_at :: Qubit -> Circ () +gate_X_at q = do + gate_X q + return () + +-- | Apply a Pauli /Y/ gate. +gate_Y_at :: Qubit -> Circ () +gate_Y_at q = do + gate_Y q + return () + +-- | Apply a Pauli /Z/ gate. +gate_Z_at :: Qubit -> Circ () +gate_Z_at q = do + gate_Z q + return () + +-- | Apply a Clifford /S/-gate. +gate_S_at :: Qubit -> Circ () +gate_S_at q = do + gate_S q + return () + +-- | Apply the inverse of an /S/-gate. +gate_S_inv_at :: Qubit -> Circ () +gate_S_inv_at q = do + gate_S_inv q + return () + +-- | Apply a /T/ = √/S/ gate. +gate_T_at :: Qubit -> Circ () +gate_T_at q = do + gate_T q + return () + +-- | Apply the inverse of a /T/-gate. +gate_T_inv_at :: Qubit -> Circ () +gate_T_inv_at q = do + gate_T_inv q + return () + +-- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. +-- +-- \[image E.png] +-- +-- This gate is the unique Clifford operator with the properties /E/³ +-- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a +-- convenient gate for calculations. For example, every Clifford +-- operator can be uniquely written of the form +-- +-- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/], +-- +-- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8, +-- respectively. +gate_E_at :: Qubit -> Circ () +gate_E_at q = do + gate_E q + return () + +-- | Apply the inverse of an /E/-gate. +gate_E_inv_at :: Qubit -> Circ () +gate_E_inv_at q = do + gate_E_inv q + return () + +-- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate. +gate_omega_at :: Qubit -> Circ () +gate_omega_at q = do + gate_omega q + return () + +-- | Apply a /V/ = √/X/ gate. This is by definition the following gate +-- (see also Nielsen and Chuang, p.182): +-- +-- \[image V.png] +gate_V_at :: Qubit -> Circ () +gate_V_at q = do + gate_V q + return () + +-- | Apply the inverse of a /V/-gate. +gate_V_inv_at :: Qubit -> Circ () +gate_V_inv_at q = do + gate_V_inv q + return () + +-- | Apply a SWAP gate. +swap_qubit_at :: Qubit -> Qubit -> Circ () +swap_qubit_at q1 q2 = do + swap_qubit q1 q2 + return () + +-- | Apply a classical SWAP gate. +swap_bit_at :: Bit -> Bit -> Circ () +swap_bit_at c1 c2 = do + swap_bit c1 c2 + return () + +-- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter. +expZt_at :: Timestep -> Qubit -> Circ () +expZt_at t q = do + expZt t q + return () + +-- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis. +-- +-- \[image rGate.png] +rGate_at :: Int -> Qubit -> Circ () +rGate_at n q = do + rGate n q + return () + +-- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes +-- the SWAP gate. +-- +-- \[image W.png] +-- +-- The arguments are such that +-- +-- > gate_W |0〉 |0〉 = |00〉 +-- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2 +-- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2 +-- > gate_W |1〉 |1〉 = |11〉. +-- +-- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2] +-- denotes the \"right\" qubit. +gate_W_at :: Qubit -> Qubit -> Circ () +gate_W_at q1 q2 = do + gate_W q1 q2 + return () + +-- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/ +-- gate, but with two advantages: +-- +-- * the doubly-controlled /iX/ gate can be implemented in the +-- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/ +-- gate requires /T/-count 7); +-- +-- * the /iX/-gate has determinant 1, and therefore an /n/-times +-- controlled /iX/ gate can be implemented in the Clifford+/T/ gate +-- base with no ancillas. +-- +-- In particular, the /iX/ gate can be used to implement an additional +-- control with /T/-count 8, like this: +-- +-- \[image iX.png] +gate_iX_at :: Qubit -> Circ () +gate_iX_at q = do + gate_iX q + return () + +-- | Apply a −/iX/ gate. This is the inverse of 'gate_iX_at'. +gate_iX_inv_at :: Qubit -> Circ () +gate_iX_inv_at q = do + gate_iX_inv q + return () + +-- | Apply a generic quantum gate to a given list of qubits and a +-- given list of generalized controls. The generalized controls are +-- really inputs to the gate, but are guaranteed not to be modified +-- if they are in a computational basis state. +named_gate_qulist_at :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ () +named_gate_qulist_at name inv operands gencontrols = do + named_gate_qulist name inv operands gencontrols + return () + +-- | Like 'named_gate_qulist_at', but produce a named gate that also +-- depends on a real parameter. This is typically used for rotations +-- or phase gates parameterized by an angle. The name can contain +-- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@. +named_rotation_qulist_at :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ () +named_rotation_qulist_at name inv t operands gencontrols = do + named_rotation_qulist name inv t operands gencontrols + return () + +-- | Apply a NOT gate to a classical bit. +cnot_at :: Bit -> Circ () +cnot_at b = do + cnot b + return () + +-- ---------------------------------------------------------------------- +-- ** Bitwise initialization and termination functions + +-- | Generate a new qubit, initialized to the parameter 'Bool'. +qinit_qubit :: Bool -> Circ Qubit +qinit_qubit b = do + arity <- get_arity + let w = arity_unused_wire arity + apply_gate (QInit b w False) + return (qubit_of_wire w) + +-- | Terminate a qubit asserted to be in state /b/. +-- +-- We note that the assertion is relative to the precision: when gates +-- in a circuit are implemented up to some precision ε (either due to +-- physical limitations, or due to decomposition into a discrete gate +-- base), the assertion may only hold up to a corresponding precision +-- as well. +qterm_qubit :: Bool -> Qubit -> Circ () +qterm_qubit b q = do + apply_gate (QTerm b (wire_of_qubit q) False) + return () + +-- | Discard a qubit destructively. +qdiscard_qubit :: Qubit -> Circ () +qdiscard_qubit q = do + apply_gate (QDiscard (wire_of_qubit q)) + return () + +-- | Generate a new qubit, initialized from a classical bit. Note that +-- the classical bit is simultaneously terminated. +prepare_qubit :: Bit -> Circ Qubit +prepare_qubit c = do + let w = wire_of_bit c + apply_gate (QPrep w False) + return (qubit_of_wire w) + +-- | Unprepare a qubit asserted to be in a computational basis +-- state. This is the same as a measurement, but must only be applied +-- to qubits that are already known to be in one of the states |0〉 or +-- |1〉, and not in superposition. This operation is rarely (perhaps +-- never?) used in any quantum algorithms, but we include it for +-- consistency reasons, because it is formally the inverse of +-- 'prepare_qubit'. +unprepare_qubit :: Qubit -> Circ Bit +unprepare_qubit q = do + let w = wire_of_qubit q + apply_gate (QUnprep w False) + return (bit_of_wire w) + +-- | Apply a measurement gate (turns a qubit into a bit). +measure_qubit :: Qubit -> Circ Bit +measure_qubit q = do + let w = wire_of_qubit q + apply_gate (QMeas w) + return (bit_of_wire w) + +-- | Generate a new classical bit, initialized to a boolean parameter +-- /b/. +cinit_bit :: Bool -> Circ Bit +cinit_bit b = do + arity <- get_arity + let w = arity_unused_wire arity + apply_gate (CInit b w False) + return (bit_of_wire w) + +-- | Terminate a classical 'Bit' asserted to be in state 'Bool'. +cterm_bit :: Bool -> Bit -> Circ () +cterm_bit b c = do + let w = wire_of_bit c + apply_gate (CTerm b w False) + return () + +-- | Terminate a classical 'Bit' with a comment indicating what the +-- observed state of the 'Bit' was, in this particular dynamic run of +-- the circuit. This is typically used to terminate a wire right after +-- a dynamic lifting has been performed. It is not intended to be a +-- user-level operation. +-- +-- It is important to note that a 'DTerm' gate does not, in any way, +-- represent an assertion. Unlike a 'CTerm' gate, which asserts that +-- the classical bit will have the stated value at /every/ run of the +-- circuit, the 'DTerm' gate simply records that the classical bit had +-- the stated value at some /particular/ run of the circuit. +-- +-- Operationally (e.g., in a simulator), the 'DTerm' gate can be +-- interpreted in multiple ways. In the simplest case, it is just +-- treated like a 'CDiscard' gate, and the boolean comment +-- ignored. Alternatively, it can be treated as a post-selection gate: +-- if the actual value does not equal the stated value, the entire +-- computation is aborted. Normally, 'DTerm' gates should appear in +-- the /output/, not the /input/ of simulators; therefore, the details +-- of the behavior of any particular simulator on a 'DTerm' gate are +-- implementation dependent. +dterm_bit :: Bool -> Bit -> Circ () +dterm_bit b c = do + let w = wire_of_bit c + apply_gate (DTerm b w) + return () + +-- | Discard a classical bit destructively. +cdiscard_bit :: Bit -> Circ () +cdiscard_bit c = do + let w = wire_of_bit c + apply_gate (CDiscard w) + return () + +-- ---------------------------------------------------------------------- +-- ** Classical gates + +-- $CLASSICAL +-- +-- The gates in this section are for constructing classical circuits. +-- None of these gates alter or discard their inputs; each gate produces +-- a new wire holding the output of the gate. + +-- | Return the \"exclusive or\" of a list of bits. +cgate_xor :: [Bit] -> Circ Bit +cgate_xor inputs = + cgate "xor" inputs + +-- | Test equality of two bits, and return 'True' iff they are equal. +cgate_eq :: Bit -> Bit -> Circ Bit +cgate_eq a b = cgate "eq" [a,b] + +-- | If /a/ is 'True', then return /b/, else return /c/. +cgate_if_bit :: Bit -> Bit -> Bit -> Circ Bit +cgate_if_bit a b c = cgate "if" [a,b,c] + +-- | Return the negation of its input. Note that unlike 'cnot' or +-- 'cnot_at', this gate does not alter its input, but returns a newly +-- created bit. +cgate_not :: Bit -> Circ Bit +cgate_not a = cgate "not" [a] + +-- | Return the conjunction of a list of bits. +cgate_and :: [Bit] -> Circ Bit +cgate_and inputs = cgate "and" inputs + +-- | Return the disjunction of a list of bits. +cgate_or :: [Bit] -> Circ Bit +cgate_or inputs = cgate "or" inputs + +-- | Apply a named classical gate. This is used to define all of the +-- above classical gates, but should not usually be directly used by +-- user code. +cgate :: String -> [Bit] -> Circ Bit +cgate name inputs = do + arity <- get_arity + let w = arity_unused_wire arity + apply_gate (CGate name w (map wire_of_bit inputs) False) + return (bit_of_wire w) + +-- | @'cgateinv' name w inputs@: Uncompute a named classical +-- gate. This asserts that /w/ is in the state determined by the gate +-- type and the /inputs/, then uncomputes /w/ in a reversible +-- way. This rarely used gate is formally the inverse of 'cgate'. +cgateinv :: String -> Bit -> [Bit] -> Circ () +cgateinv name c inputs = do + let w = wire_of_bit c + apply_gate (CGateInv name w (map wire_of_bit inputs) False) + return () + +-- ---------------------------------------------------------------------- +-- ** Subroutines + +-- | Insert a subroutine gate with specified name, and input/output +-- output types, and attach it to the given endpoints. Return the new +-- endpoints. +-- +-- Note that the @['Wire']@ and 'Arity' arguments are used as a /pattern/ +-- for the locations/types of wires of the subroutine; the @['Endpoint']@ +-- argument (and output) specify what is attached in the current circuit. +-- The two aspects of this pattern that are respected are: the +-- lingeringness of any inputs; and the number and types of wires. +-- +-- For instance (assuming for simplicity that all wires are qubits), if +-- the patterns given are “inputs [1,3,5], outputs [1,3,4]”, and the +-- actual inputs specified are [20,21,25], then the output wires produced +-- might be e.g. [20,21,23], [20,21,36], or [20,21,8], depending on the +-- next available free wire. +-- +-- More subtly, if +-- the patterns given are “inputs [1,2,3], outputs [3,7,8,1]”, +-- and the inputs given are [10,5,4], then the outputs will be +-- [4,/x/,/y/,10], where /x/, /y/ are two fresh wires. +-- +-- Note that lingering wires may change type, for e.g. subroutines that +-- include measurements. +-- +-- It is currently assumed that all these lists are linear, i.e. contain +-- no duplicates. +subroutine :: BoxId -> InverseFlag -> ControllableFlag + -> RepeatFlag -> [Wire] -> Arity -> [Wire] -> Arity + -> [Endpoint] -> Circ [Endpoint] +subroutine name inv scf rep win_pattern ain_pattern wout_pattern aout_pattern ein = do + let (win,ain) = wires_with_arity_of_endpoints ein + -- Check the given input wires match the pattern: + when (not $ all (\(w_p,w) -> ain_pattern IntMap.! w_p == ain IntMap.! w) $ zip_strict_errmsg win_pattern win e_num_inputs) $ do + error e_input_types + -- Work out which input wires are lingering, and how many new wires are needed: + let partial_wout = map (\w_p -> let maybe_w = lookup w_p (zip win_pattern win) + in (maybe_w, aout_pattern IntMap.! w_p)) + wout_pattern + num_new_wires = length $ filter ((== Nothing) . fst) partial_wout + -- Allocate new wires for the non-lingering outputs: + arity <- get_arity + let new_wires = arity_unused_wires num_new_wires arity + eout = insert_new_wires partial_wout new_wires + (wout,aout) = wires_with_arity_of_endpoints eout + apply_gate (Subroutine name inv win ain wout aout [] False scf rep) + return eout + where + insert_new_wires :: [(Maybe Wire, Wiretype)] -> [Wire] -> [Endpoint] + insert_new_wires ((Just w,t):ws) new_wires = (endpoint_of_wire w t):(insert_new_wires ws new_wires) + insert_new_wires ((Nothing,t):ws) (next_new:new_wires) = (endpoint_of_wire next_new t):(insert_new_wires ws new_wires) + insert_new_wires [] [] = [] + insert_new_wires _ _ = error e_output_allocation + e_num_inputs = "subroutine: subroutine " ++ show name ++ " applied to the wrong number of input wires" + e_input_types = "subroutine: subroutine " ++ show name ++ " applied to input wires of incorrect type" + e_output_allocation = "internal error: Quipper.Internal.Monad.subroutine: output wire allocation" + + +-- | Look up the specified subroutine in the namespace, and apply it +-- to the specified inputs, or throw an error if they are not appropriately +-- typed. +-- +-- The input/output types of this function are determined dynamically +-- by the 'CircuitTypeStructure' stored with the subroutine. +call_subroutine :: (Typeable a, Typeable b) => BoxId -> RepeatFlag -> a -> Circ b +call_subroutine name r x = do + ns <- get_namespace + let mc = Map.lookup name ns + case mc of + Nothing -> + error ("call_subroutine: subroutine " ++ show name ++ " does not exist in current namespace: " ++ showNames ns) + Just (TypedSubroutine ocircuit input_structure output_structure scf) -> do + let OCircuit (win_pattern, circuit, wout_pattern) = ocircuit + let (ain_pattern, gates, aout_pattern, n) = circuit + let (win, ain) = case cast input_structure of + Just suitable_input_structure -> destructure_with suitable_input_structure x + Nothing -> error ("call_subroutine: subroutine " ++ show name ++ " applied to input of incorrect type") + let ein = endpoints_of_wires_in_arity ain win + eout <- subroutine name False scf r win_pattern ain_pattern wout_pattern aout_pattern ein + let (wout, aout) = wires_with_arity_of_endpoints eout + + -- The output structure of the subroutine contains the wires + -- corresponding to the actual output type of the function and + -- the wires that were created but forgotten, in + -- imperative-style. (see comments in 'provide_subroutine_generic'). + let (y,_::([Qubit],[Bit])) = case cast output_structure of + Just suitable_output_structure -> structure_with suitable_output_structure (wout, aout) + Nothing -> error ("call_subroutine: attempt to use outputs of subroutine " ++ show name ++ " as incorrect type") + return y + +-- ---------------------------------------------------------------------- +-- ** Comments + +-- | Insert a comment in the circuit. This is not a gate, and has no +-- effect, except to mark a spot in the circuit. The comment has two +-- parts: a string (possibly empty), and a list of labelled wires +-- (possibly empty). This is a low-level function. Users should use +-- 'Quipper.comment' instead. +comment_label :: String -> InverseFlag -> [(Wire, String)] -> Circ () +comment_label s inv ws = do + b <- get_nocommentflag + when (not b) $ do + apply_gate (Comment s inv ws) + return () + +-- | Disable labels and comments for a block of code. The intended +-- usage is like this: +-- +-- > without_comments $ do { +-- > <<>> +-- > } +-- +-- This is sometimes useful in situations where code is being re-used, +-- for example when one function is implemented in terms of another, +-- but should not inherit comments from it. It is also useful in the +-- definition of recursive function, where a comment should only be +-- applied at the outermost level. Finally, it can be used to suppress +-- comments from parts of circuits for presentation purposes. +without_comments :: Circ a -> Circ a +without_comments body = do + b <- get_nocommentflag + set_nocommentflag True + a <- body + set_nocommentflag b + return a + +-- ---------------------------------------------------------------------- +-- ** Dynamic lifting + +-- | Convert a 'Bit' (boolean circuit output) to a 'Bool' (boolean +-- parameter). +-- +-- For use in algorithms that require the output of a measurement to +-- be used as a circuit-generation parameter. This is the case, for +-- example, for sieving methods, and also for some iterative +-- algorithms. +-- +-- Note that this is not a gate, but a meta-operation. The input +-- consists of classical circuit endpoints (whose values are known at +-- circuit execution time), and the output is a boolean parameter +-- (whose value is known at circuit generation time). +-- +-- The use of this operation implies an interleaving between circuit +-- execution and circuit generation. It is therefore a (physically) +-- expensive operation and should be used sparingly. Using the +-- 'dynamic_lift_bit' operation interrupts the batch mode operation of +-- the quantum device (where circuits are generated ahead of time), +-- and forces interactive operation (the quantum device must wait for +-- the next portion of the circuit to be generated). This operation is +-- especially expensive if the current circuit contains unmeasured +-- qubits; in this case, the qubits must be preserved while the +-- quantum device remains on standby. +-- +-- Also note that this operation is not supported in all contexts. It +-- is an error, for example, to use this operation in a circuit that +-- is going to be reversed, or in the body of a boxed subroutine. +-- Also, not all output devices (such as circuit viewers) support this +-- operation. +dynamic_lift_bit :: Bit -> Circ Bool +dynamic_lift_bit c = do + b <- do_read (wire_of_bit c) + dterm_bit b c + return b + +-- ====================================================================== +-- * Other circuit-building functions + +-- | Generate a new qubit initialized to |+〉 when /b/='False' and +-- |−〉 when /b/='True'. +qinit_plusminus :: Bool -> Circ Qubit +qinit_plusminus b = do + q <- qinit_qubit b + q <- hadamard q + return q + +-- | Generate a new qubit initialized to one of |0〉, |1〉, |+〉, |−〉, +-- depending on a character /c/ which is \'0\', \'1\', \'+\', or \'-\'. +qinit_of_char :: Char -> Circ Qubit +qinit_of_char '0' = qinit_qubit False +qinit_of_char '1' = qinit_qubit True +qinit_of_char '+' = qinit_plusminus False +qinit_of_char '-' = qinit_plusminus True +qinit_of_char c = error ("qinit_of_char: unimplemented initialization: " ++ [c]) + +-- | Generate a list of qubits initialized to a sequence of |0〉, |1〉, +-- |+〉, |−〉, defined by a string argument e.g. \"00+0+++\". +qinit_of_string :: String -> Circ [Qubit] +qinit_of_string s = sequence (map qinit_of_char s) + +-- | A version of 'qinit_qubit' that operates on lists. +qinit_list :: [Bool] -> Circ [Qubit] +qinit_list bs = mapM qinit_qubit bs + + +-- | A version of 'qterm_qubit' that operates on lists. We initialize +-- left-to-right and terminate right-to-left, as this leads to more +-- symmetric and readable circuits, more stable under reversal. +-- +-- Note: if the left argument to 'qterm_list' is longer than the right +-- argument, then it is truncated. So the first argument can be +-- ('repeat' 'False'). It is an error if the left argument is shorter +-- than the right one. +qterm_list :: [Bool] -> [Qubit] -> Circ () +qterm_list bs qs = + zipRightWithRightStrictM_ qterm_qubit bs qs + +-- | A version of 'cinit_bit' for lists. +cinit_list :: [Bool] -> Circ [Bit] +cinit_list bs = mapM cinit_bit bs + +-- ====================================================================== +-- * Higher-order functions + +-- | Convenient wrapper around 'Quipper.qinit' and +-- 'Quipper.qterm'. This can be used to introduce an ancilla with a +-- local scope, like this: +-- +-- > with_ancilla $ \h -> do { +-- > <<>> +-- > } +-- +-- The ancilla will be initialized to |0〉 at the beginning of the +-- block, and it is the programmer's responsibility to ensure that it +-- will be returned to state |0〉 at the end of the block. +-- +-- A block created with 'with_ancilla' is controllable, provided that +-- the body is controllable. +with_ancilla :: (Qubit -> Circ a) -> Circ a +with_ancilla f = do + q <- without_controls (qinit_qubit False) + a <- f q + without_controls (qterm_qubit False q) + return a + +-- | A syntax for \"if\"-style (classical and quantum) controls. +-- This can be used as follows: +-- +-- > gate1 +-- > with_controls <> $ do { +-- > gate2 +-- > gate3 +-- > } +-- > gate4 +-- +-- The specified controls will be applied to gate2 and gate3. It is an +-- error to specify a control for a gate that cannot be controlled +-- (such as measurement). + +with_controls :: ControlSource c => c -> Circ a -> Circ a +with_controls control code = do + clist_old <- get_clist + set_clist (combine (to_control control) clist_old) + a <- code + set_clist clist_old + return a + +-- | An infix operator to apply the given controls to a gate: +-- +-- > gate `controlled` <> +-- +-- It also works with functional-style gates: +-- +-- > result <- gate `controlled` <> +-- +-- The infix operator is left associative, so it can be applied +-- multiple times: +-- +-- > result <- gate `controlled` <> `controlled` <> +-- +-- The latter is equivalent to +-- +-- > result <- gate `controlled` <> .&&. <> + +controlled :: ControlSource c => Circ a -> c -> Circ a +controlled code control = with_controls control code + +infixl 2 `controlled` + +-- | Apply a block of gates while temporarily suspending the +-- application of controls. This can be used to omit controls on +-- gates where they are known to be unnecessary. This is a relatively +-- low-level function and should not normally be called directly by +-- user code. Instead, it is safer to use a higher-level function such +-- as 'Quipper.with_basis_change'. However, the 'without_controls' operator is +-- useful in certain situations, e.g., it can be used to preserve the +-- 'NoControlFlag' when defining transformers. +-- +-- Usage: +-- +-- > without_controls $ do +-- > <> +-- +-- or: +-- +-- > without_controls (gate) +-- +-- Note that all controls specified in the /surrounding/ code are +-- disabled within the 'without_controls' block. This is even true if +-- the 'without_controls' block appears in a subroutine, and the +-- subroutine is later called in a controlled context. On the other +-- hand, it is possible to specify controls /inside/ the +-- 'without_controls' block. Consider this example: +-- +-- > my_subcircuit = do +-- > gate1 +-- > without_controls $ do { +-- > gate2 +-- > gate3 `controlled` <> +-- > } +-- > gate4 +-- > +-- > my_circuit = do +-- > my_subcircuit `controlled` <> +-- +-- In this example, controls 1 will be applied to gate 3, controls 2 +-- will be applied to gates 1 and 4, and no controls will be applied +-- to gate 2. +without_controls :: Circ a -> Circ a +without_controls code = do + clist_old <- get_clist + ncflag_old <- get_ncflag + set_clist clist_empty + set_ncflag True + a <- code + set_clist clist_old + set_ncflag ncflag_old + return a + +-- | Apply 'without_controls' if 'NoControlFlag' is 'True', otherwise +-- do nothing. +without_controls_if :: NoControlFlag -> Circ a -> Circ a +without_controls_if True = without_controls +without_controls_if False = id + +-- ---------------------------------------------------------------------- +-- ** Deprecated special cases of without_controls + +-- | Generate a new qubit, initialized to the parameter 'Bool', that +-- is guaranteed to be used as an ancilla and terminated with +-- 'qterm_qubit_ancilla'. Deprecated. +qinit_qubit_ancilla :: Bool -> Circ Qubit +qinit_qubit_ancilla b = do + without_controls $ do + qinit_qubit b + +-- | Terminate an ancilla asserted to be in state /b/. Deprecated. +qterm_qubit_ancilla :: Bool -> Qubit -> Circ () +qterm_qubit_ancilla b q = do + without_controls $ do + qterm_qubit b q + +-- ====================================================================== +-- * Circuit transformers + +-- | The identity transformer. This just maps a low-level circuits to +-- the corresponding circuit-generating function. It can also be used +-- as a building block in other transformers, to define \"catch-all\" +-- clauses for gates that don't need to be transformed. +identity_transformer :: Transformer Circ Qubit Bit +identity_transformer (T_QGate name _ _ inv ncf f) = f $ + \ws vs c -> without_controls_if ncf $ do + (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c + return (ws', vs', c) +identity_transformer (T_QRot name _ _ inv t ncf f) = f $ + \ws vs c -> without_controls_if ncf $ do + (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c + return (ws', vs', c) +identity_transformer (T_GPhase t ncf f) = f $ + \qs c -> without_controls_if ncf $ do + global_phase_anchored_list t qs `controlled` c + return c +identity_transformer (T_CNot ncf f) = f $ + \q c -> without_controls_if ncf $ do + q' <- cnot q `controlled` c + return (q', c) +identity_transformer (T_CGate name ncf f) = f $ + \ws -> without_controls_if ncf $ do + v <- cgate name ws + return (v, ws) +identity_transformer (T_CGateInv name ncf f) = f $ + \v ws -> without_controls_if ncf $ do + cgateinv name v ws + return ws +identity_transformer (T_CSwap ncf f) = f $ + \w v c -> without_controls_if ncf $ do + (w',v') <- swap_bit w v `controlled` c + return (w',v',c) +identity_transformer (T_QPrep ncf f) = f $ + \w -> without_controls_if ncf $ do + v <- prepare_qubit w + return v +identity_transformer (T_QUnprep ncf f) = f $ + \w -> without_controls_if ncf $ do + v <- unprepare_qubit w + return v +identity_transformer (T_QInit b ncf f) = f $ + without_controls_if ncf $ do + w <- qinit_qubit b + return w +identity_transformer (T_CInit b ncf f) = f $ + without_controls_if ncf $ do + w <- cinit_bit b + return w +identity_transformer (T_QTerm b ncf f) = f $ + \w -> without_controls_if ncf $ do + qterm_qubit b w + return () +identity_transformer (T_CTerm b ncf f) = f $ + \w -> without_controls_if ncf $ do + cterm_bit b w + return () +identity_transformer (T_QMeas f) = f $ + \w -> do + v <- measure_qubit w + return v +identity_transformer (T_QDiscard f) = f $ + \w -> do + qdiscard_qubit w + return () +identity_transformer (T_CDiscard f) = f $ + \w -> do + cdiscard_bit w + return () +identity_transformer (T_DTerm b f) = f $ + \w -> do + dterm_bit b w + return () +identity_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ + \namespace ws c -> without_controls_if ncf $ do + provide_subroutines namespace + vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c + return (vs,c) +identity_transformer (T_Comment s inv f) = f $ + \ws -> do + comment_label s inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] + return () + +-- | The identity transformer can be enriched with a dynamic lifting operation, so +-- as to define a DynamicTransformer +identity_dynamic_transformer_with_lift :: (Bit -> Circ Bool) -> DynamicTransformer Circ Qubit Bit +identity_dynamic_transformer_with_lift f = DT { + transformer = identity_transformer, + define_subroutine = \name typed_subroutine -> do + s <- get_namespace + let s' = map_provide name typed_subroutine s + set_namespace s' + put_subroutine_definition name typed_subroutine, + lifting_function = f + } + +-- | The identity DynamicTransformer uses the built in do_read operation +identity_dynamic_transformer :: DynamicTransformer Circ Qubit Bit +identity_dynamic_transformer = + identity_dynamic_transformer_with_lift (\b -> do_read (wire_of_bit b)) + +-- | We can define a dynamic transformer with a "constant" lifting function +identity_dynamic_transformer_constant :: Bool -> DynamicTransformer Circ Qubit Bit +identity_dynamic_transformer_constant b = identity_dynamic_transformer_with_lift (\_ -> return b) + +-- | Append the entire circuit /c/ to the current circuit, using the +-- given bindings. Return the new bindings. +apply_circuit_with_bindings :: Circuit -> (Bindings Qubit Bit) + -> Circ (Bindings Qubit Bit) +apply_circuit_with_bindings c bindings = + transform_circuit identity_transformer c bindings + +-- | Append the entire circuit /c/ to the current circuit, using the +-- given bindings, and return the new bindings. +-- Also, add to the current namespace state any subroutines of /c/ +-- that are not already provided. +apply_bcircuit_with_bindings :: BCircuit -> (Bindings Qubit Bit) + -> Circ (Bindings Qubit Bit) +apply_bcircuit_with_bindings (c,s) bindings = do + provide_subroutines s + apply_circuit_with_bindings c bindings + +-- | Append the entire dynamic circuit /c/ to the current circuit, +-- using the given bindings, and return the new bindings. Also, add +-- to the current namespace state any subroutines of /c/ that are not +-- already provided. +apply_dbcircuit_with_bindings :: DBCircuit a -> Bindings Qubit Bit + -> Circ (Bindings Qubit Bit, a) +apply_dbcircuit_with_bindings dbcircuit bindings = do + -- until the transformer interface is updated to work with dynamic + -- circuits, we have to go the route of converting to a static + -- circuit first. Unfortunately, this means that any dynamic + -- liftings will given an error. + let (bcircuit, a) = bcircuit_of_static_dbcircuit errmsg dbcircuit + out_bindings <- apply_bcircuit_with_bindings bcircuit bindings + return (out_bindings, a) + where + errmsg x = "apply_dbcircuit_with_bindings: operation unimplemented: " ++ x + +-- ====================================================================== +-- * Encapsulated circuits + +-- | Similar to 'extract_simple', except we take the current output arity +-- of the /current/ circuit and make that the input arity of the +-- extracted circuit. Therefore, endpoints defined in the current +-- context can be used in /f/. This is a low-level operator, intended +-- for the construction of primitives, such as 'Quipper.with_computed' or +-- 'Quipper.with_basis_change', where the inner block can re-use some +-- variables without declaring them explicitly. +-- +-- We also reuse the namespace of the current context, to avoid +-- recomputation of shared subroutines. +-- +-- As a special feature, also return the set of \"dirty\" wires, i.e., +-- wires that were used during the execution of the body, but are free +-- at the end. +extract_in_context :: ErrMsg -> Circ a -> Circ (BCircuit, IntSet, a) +extract_in_context e f = do + arity <- get_arity + cur_namespace <- get_namespace + let arity' = xintmap_makeclean arity + -- f' :: Circ (a, ExtArity) + f' = do + set_namespace cur_namespace + a <- f + extarity <- get_arity + return (a, extarity) + (bcirc, ~(a, extarity)) = extract_simple e arity' f' + return (bcirc, xintmap_dirty extarity, a) + +-- | Intermediate between 'extract_simple' and 'extract_in_context': +-- we build the circuit in the namespace of the current circuit, to +-- avoid recomputing any shared subroutines. +extract_in_current_namespace :: ErrMsg -> ExtArity -> Circ a -> Circ (BCircuit, a) +extract_in_current_namespace e arity f = do + cur_namespace <- get_namespace + return $ extract_simple e arity $ (set_namespace cur_namespace) >> f + +-- | Append the 'BCircuit' to the end of the current circuit, using +-- the identity binding. This means, the input wires of 'BCircuit' +-- /must/ be endpoints in the current circuits. This typically happens +-- when 'BCircuit' was obtained from 'extract_in_context' in the +-- current context, or when 'BCircuit' is the inverse of a circuit +-- that has just been applied using 'unextract_in_context'. +-- +-- Note that this is a low-level function, intended for the +-- construction of user-level primitives such as +-- 'Quipper.with_computed' and 'Quipper.with_basis_change', and +-- 'Quipper.classical_to_reversible'. +-- +-- 'unextract_in_context' uses 'apply_gate' to do the appending, +-- so the current 'ControlList' and 'NoControlFlag' are respected. +-- However, it does not pass through the transformer interface, and +-- therefore low-level wire id's will be exactly preserved. +unextract_in_context :: BCircuit -> Circ () +unextract_in_context (c,s) = do + provide_subroutines s + let (_,gs,_,_) = c + mapM_ apply_gate gs + +-- | Reverse an encapsulated circuit +-- +-- An encapsulated circuit is a circuit together with data structures +-- holding the input endpoints and output endpoints. The type of the +-- encapsulated circuit depends on the type of data in the endpoints, +-- so functions to encapsulate and unencapsulate circuits are provided +-- in "Quipper.Internal.Generic". +reverse_encapsulated :: (i, BCircuit, o) -> (o, BCircuit, i) +reverse_encapsulated (in_bind, c, out_bind) = + (out_bind, reverse_bcircuit c, in_bind) + +-- ---------------------------------------------------------------------- +-- * Temporarily reserving wires + +-- | Perform the computation in the body, but temporarily reserve a +-- set of wires. These wires must be initially free, and they must not +-- be used by the body (i.e., the body must respect reserved wires). +with_reserve :: IntSet -> Circ a -> Circ a +with_reserve ws body = do + arity <- get_arity + let arity1 = xintmap_reserves ws arity + set_arity arity1 + a <- body + arity2 <- get_arity -- they should still be reserved + let arity3 = xintmap_unreserves ws arity2 + set_arity arity3 + return a diff --git a/Quipper/Internal/Printing.hs b/Quipper/Internal/Printing.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Printing.hs @@ -0,0 +1,1640 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DoAndIfThenElse #-} + +-- | Pretty-printing of low-level quantum circuits. + +module Quipper.Internal.Printing where + +-- import other Quipper stuff +import Quipper.Utils.Auxiliary +import Quipper.Utils.Preview +import Quipper.Internal.Circuit +import Quipper.Internal.Generic +import Quipper.Internal.Monad +import Quipper.Internal.QData + +-- import other stuff +import Prelude +import Text.Printf +import Data.Char(isSpace) +import Data.List +import Data.Maybe +import Control.Monad(when) +import Graphics.EasyRender +import System.IO +import System.Directory + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Map.Strict as MapS + +import qualified Data.IntMap as IntMap + +-- ====================================================================== +-- * Auxiliary functions + +-- | Determine whether a named gate is self-inverse. The kind of a +-- gate is uniquely determined by its name, and the number of input +-- wires and generalized controls. +-- +-- For now, we only recognize "X", "Y", "Z", "H", "not", "swap", and +-- "W" as self-inverse; it is not currently possible for user code to +-- extend this list. +self_inverse :: String -> [Wire] -> [Wire] -> Bool +self_inverse "X" [q] [] = True +self_inverse "Y" [q] [] = True +self_inverse "Z" [q] [] = True +self_inverse "H" [q] [] = True +self_inverse "not" [q] [] = True +self_inverse "swap" [q1,q2] [] = True +self_inverse "W" [q1,q2] [] = True +self_inverse _ _ _ = False + +-- ====================================================================== +-- * ASCII representation of circuits + +-- $ Convert a circuit to ASCII: one gate per line. + +type WireTypeMap = IntMap.IntMap Wiretype + +-- | Given a map of wiretypes, and a gate, update the wiretype in the map +-- if the gate changes it. +track_wiretype :: WireTypeMap -> Gate -> WireTypeMap +track_wiretype wtm (QInit _ w _ ) = IntMap.insert w Qbit wtm +track_wiretype wtm (CInit _ w _ ) = IntMap.insert w Cbit wtm +track_wiretype wtm (QMeas w ) = IntMap.insert w Cbit wtm +track_wiretype wtm (CGate _ w _ _) = IntMap.insert w Cbit wtm +track_wiretype wtm (CGateInv _ w _ _) = IntMap.insert w Cbit wtm +track_wiretype wtm (QPrep w _ ) = IntMap.insert w Qbit wtm +track_wiretype wtm (QUnprep w _ ) = IntMap.insert w Cbit wtm +track_wiretype wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = a2 `IntMap.union` wtm +track_wiretype wtm _ = wtm + +-- | Convert a 'BoxId' to the string in the format \"/name/\", shape \"/x/\". +ascii_of_boxid :: BoxId -> String +ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape + +-- | Generate an ASCII representation of a control. +-- As controls are stored as untyped wires, we can lookup the wiretype in +-- the current map and annotate the control if it's classical. +ascii_render_control :: WireTypeMap -> Signed Wire -> String +ascii_render_control wtm (Signed w b) = + (if b then "+" else "-") ++ show w ++ ascii_render_control_type wtype + where + wtype = if (w `IntMap.member` wtm) then (wtm IntMap.! w) else Qbit + ascii_render_control_type Qbit = "" + ascii_render_control_type Cbit = "c" + +-- | Generate an ASCII representation of a list of controls. +ascii_render_controls :: WireTypeMap -> Controls -> String +ascii_render_controls wtm c = + string_of_list " with controls=[" ", " "]" "" (ascii_render_control wtm) c + +-- | Generate an ASCII representation of a NoControlFlag +ascii_render_nocontrolflag :: NoControlFlag -> String +ascii_render_nocontrolflag False = "" +ascii_render_nocontrolflag True = " with nocontrol" + +-- | Generate an ASCII representation of a single gate. +ascii_render_gate :: WireTypeMap -> Gate -> String +ascii_render_gate wtm (QGate "trace" _ _ _ _ _) = "" +ascii_render_gate wtm (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 + where + inv' = inv && not (self_inverse name ws1 ws2) +ascii_render_gate wtm (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 +ascii_render_gate wtm (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 +ascii_render_gate wtm (CNot w c ncf) = + "CNot(" ++ show w ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (CGate n w c ncf) = + -- special case + "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (CGateInv n w c ncf) = + "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c)) + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (CSwap w1 w2 c ncf) = + "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" + ++ ascii_render_controls wtm c + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (QPrep w ncf) = + "QPrep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (QUnprep w ncf) = + "QUnprep(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (QInit b w ncf) = + "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (CInit b w ncf) = + "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (QTerm b w ncf) = + "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (CTerm b w ncf) = + "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" + ++ ascii_render_nocontrolflag ncf +ascii_render_gate wtm (QMeas w) = + "QMeas(" ++ show w ++ ")" +ascii_render_gate wtm (QDiscard w) = + "QDiscard(" ++ show w ++ ")" +ascii_render_gate wtm (CDiscard w) = + "CDiscard(" ++ show w ++ ")" +ascii_render_gate wtm (DTerm b w) = + "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" +ascii_render_gate wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = + "Subroutine" ++ show_rep ++ "[" ++ ascii_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 ++ ")" +ascii_render_gate wtm (Comment s inv ws) = + "Comment[" ++ show s ++ "]" + ++ optional inv "*" + ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws) + +-- | Generate an ASCII representation of a gate list. +ascii_render_gatelist :: WireTypeMap -> [Gate] -> String +ascii_render_gatelist wtm [] = "" +ascii_render_gatelist wtm (g:gs) = + (ascii_render_gate wtm g) ++ "\n" ++ + (ascii_render_gatelist (track_wiretype wtm g) gs) + where + +-- | Generate an ASCII representation of a wiretype. +ascii_render_wiretype :: Wiretype -> String +ascii_render_wiretype Qbit = "Qbit" +ascii_render_wiretype Cbit = "Cbit" + +-- | Generate an ASCII representation of a type assignment. +ascii_render_typeas :: (Wire, Wiretype) -> String +ascii_render_typeas (w, t) = + show w ++ ":" ++ ascii_render_wiretype t + +-- | Generate an ASCII representation of an arity, preceded by a title +-- (input or output). +ascii_render_arity :: String -> Arity -> String +ascii_render_arity title a = + title ++ ": " ++ (string_of_list "" ", " "" "none" ascii_render_typeas (IntMap.toList a)) ++ "\n" + +-- | Generate an ASCII representation of an ordered arity, preceded by +-- a title (input or output). +ascii_render_oarity :: String -> [Wire] -> Arity -> String +ascii_render_oarity title ws a = + title ++ ": " + ++ (string_of_list "" ", " "" "none" ascii_render_typeas tas_list) ++ "\n" + where + tas_list = [ (w, a IntMap.! w) | w <- ws ] + +-- | Generate an ASCII representation of a low-level ordered quantum +-- circuit. +ascii_of_ocircuit :: OCircuit -> String +ascii_of_ocircuit ocircuit = + (ascii_render_oarity "Inputs" win a1) ++ + (ascii_render_gatelist a1 gl) ++ + (ascii_render_oarity "Outputs" wout a2) + where + OCircuit (win, circuit, wout) = ocircuit + (a1, gl, a2, _) = circuit + +-- | Generate an ASCII representation of a low-level quantum circuit. +ascii_of_circuit :: Circuit -> String +ascii_of_circuit circuit = ascii_of_ocircuit ocircuit where + ocircuit = OCircuit (w_in, circuit, w_out) + (a1, _, a2, _) = circuit + w_in = IntMap.keys a1 + w_out = IntMap.keys a2 + +-- | Generate an ASCII representation of a low-level boxed quantum +-- circuit. +ascii_of_bcircuit :: BCircuit -> String +ascii_of_bcircuit (c,s) = + (ascii_of_circuit c) ++ + (concat $ map ascii_of_subroutine (Map.toList s)) ++ + "\n" + +-- | Generate an ASCII representation of a named subroutine. +ascii_of_subroutine :: (BoxId, TypedSubroutine) -> String +ascii_of_subroutine (boxid, TypedSubroutine ocirc input_strux output_strux ctrble) = + "\n" + ++ "Subroutine: " ++ show name ++ "\n" + ++ "Shape: " ++ show shape ++ "\n" + ++ "Controllable: " ++ (case ctrble of {AllCtl -> "yes"; NoCtl -> "no"; OnlyClassicalCtl -> "classically"}) ++ "\n" + ++ ascii_of_ocircuit ocirc + where + BoxId name shape = boxid + +-- ====================================================================== +-- * Dynamic ASCII representation of circuits + +-- $ +-- The dynamic ASCII representation prints a circuit to standard +-- output in ASCII format, just like the static ASCII representation. +-- However, when a 'dynamic_lift' operation is encountered, it prompts +-- the user for the value of the corresponding bit. In effect, the +-- user is asked to act as the quantum device or simulator. + +-- | Write a prompt to get input from the user. Since the prompt +-- doesn't include a newline, the output must be flushed explicitly. +prompt :: String -> IO () +prompt s = do + putStr s + hFlush stdout + +-- | Interactively read a bit (either 0 or 1) from standard input. +-- This is intended for interactive user input, so it skips white +-- space until a 0 or 1 is encountered. In case the first +-- non-whitespace character isn't 0 or 1 or \'#\', the rest of the line +-- is ignored and the user is prompted to try again. +-- +-- However, this also works for non-interactive input, so that the +-- input can be redirected from a file. In this case, the characters 0 +-- and 1 and whitespace, including newlines, can be interspersed +-- freely. \'@#@\' starts a comment that extends until the end of the +-- line. +getBit :: IO Bool +getBit = do + c <- getChar + case c of + '0' -> return False + '1' -> return True + '#' -> do + getLine + getBit + c | isSpace c -> getBit + c -> do + getLine + prompt $ "# Expecting 0 or 1. Please try again: " + getBit + +-- | Embed a read-write computation in the 'IO' monad, by writing +-- gates to the terminal and interactively querying the user (or a +-- file on stdin) for dynamic liftings. We also update a 'Namespace' +-- while doing so, to collect any subroutines that are defined along +-- the way. +run_readwrite_ascii :: WireTypeMap -> ReadWrite a -> Namespace -> IO (a, Namespace) +run_readwrite_ascii wtm (RW_Return a) ns = return (a, ns) +run_readwrite_ascii wtm (RW_Write gate comp) ns = do + putStrLn (ascii_render_gate wtm gate) + run_readwrite_ascii (track_wiretype wtm gate) comp ns +run_readwrite_ascii wtm (RW_Read w cont) ns = do + prompt $ "# Value of wire " ++ show w ++ ": " + bool <- getBit + putStrLn $ "# Value: " ++ show bool + run_readwrite_ascii wtm (cont bool) ns +run_readwrite_ascii wtm (RW_Subroutine name subroutine comp) ns = do + let !ns' = map_provide name subroutine ns + run_readwrite_ascii wtm comp ns' + +-- | Interactively output a 'DBCircuit' to standard output. This +-- supports dynamic lifting by prompting the user for bit values when +-- a dynamic lifting operation is encountered. Effectively the user is +-- asked to behave like a quantum device. +print_dbcircuit_ascii :: ErrMsg -> DBCircuit a -> IO () +print_dbcircuit_ascii _ (a0, comp) = do + hSetBuffering stdout LineBuffering -- flush output after each line + putStr (ascii_render_arity "Inputs" a0) + ((a1, _, _),ns) <- run_readwrite_ascii a0 comp namespace_empty + putStr (ascii_render_arity "Outputs" a1) + sequence_ [ putStr $ ascii_of_subroutine subr | subr <- Map.toList ns ] + putStr "\n" + +-- ---------------------------------------------------------------------- +-- * Graphical representation of circuits + +-- | The color white. +white :: Color +white = Color_Gray 1.0 + +-- | The color black. +black :: Color +black = Color_Gray 0.0 + +-- | A data type that holds all the customizable parameters. +data FormatStyle = FormatStyle { + -- | The RenderFormat to use. + renderformat :: RenderFormat, + -- | The color of the background. + backgroundcolor :: Color, + -- | The color of the foreground (e.g. wires and gates). + foregroundcolor :: Color, + -- | Line width. + linewidth :: Double, + -- | Gap for double line representing classical bit. + coffs :: Double, + -- | Radius of dots for \"controlled\" gates. + dotradius :: Double, + -- | Radius of oplus for \"not\" gate. + oplusradius :: Double, + -- | Horizontal column width. + xoff :: Double, + -- | Difference between width of box and width of label. + gatepad :: Double, + -- | Height of labelled box. + gateheight :: Double, + -- | Width and height of \"cross\" for swap gate. + crossradius :: Double, + -- | Vertical shift for text labels. + stringbase :: Double, + -- | Width of \"bar\" bar. + barwidth :: Double, + -- | Height of \"bar\" bar. + barheight :: Double, + -- | Width of \"D\" symbol. + dwidth :: Double, + -- | Height of \"D\" symbol. + dheight :: Double, + -- | Maximal width of a gate label. + maxgatelabelwidth :: Double, + -- | Maximal width of a wire label. + maxlabelwidth :: Double, + -- | Maximal width of a wire number. + maxnumberwidth :: Double, + -- | Font to use for labels on gates. + gatefont :: Font, + -- | Font to use for comments. + commentfont :: Font, + -- | Color to use for comments. + commentcolor :: Color, + -- | Font to use for labels. + labelfont :: Font, + -- | Color to use for labels. + labelcolor :: Color, + -- | Font to use for numbers. + numberfont :: Font, + -- | Color to use for numbers. + numbercolor :: Color, + -- | Whether to label each subroutine call with shape parameters + subroutineshape :: Bool +} deriving Show + +-- | A RenderFormat consisting of some default parameters, +-- along with the given RenderFormat. +defaultStyle :: RenderFormat -> FormatStyle +defaultStyle rf = FormatStyle { + renderformat = rf, + backgroundcolor = white, + foregroundcolor = black, + linewidth = 0.02, + coffs = 0.03, + dotradius = 0.15, + oplusradius = 0.25, + xoff = 1.5, + gatepad = 0.3, + gateheight = 0.8, + crossradius = 0.2, + stringbase = 0.25, + barwidth = 0.1, + barheight = 0.5, + dwidth = 0.3, + dheight = 0.4, + maxgatelabelwidth = 1.1, + maxlabelwidth = 0.7, + maxnumberwidth = 0.7, + gatefont = Font TimesRoman 0.5, + commentfont = Font TimesRoman 0.3, + commentcolor = Color_RGB 1 0.2 0.2, + labelfont = Font TimesRoman 0.3, + labelcolor = Color_RGB 0 0 1, + numberfont = Font Helvetica 0.5, + numbercolor = Color_RGB 0 0.7 0, + subroutineshape = True +} + +-- | The default PDF Style. +pdf :: FormatStyle +pdf = defaultStyle Format_PDF + +-- | The default EPS Style. +eps :: FormatStyle +eps = defaultStyle (Format_EPS 1) + +-- | The default PS Style. +ps :: FormatStyle +ps = defaultStyle (Format_PS) + +-- ---------------------------------------------------------------------- +-- ** General-purpose PostScript functions + +-- | Escape special characters in a string literal. +ps_escape :: String -> String +ps_escape [] = [] +ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t +ps_escape ('(' : t) = '\\' : '(' : ps_escape t +ps_escape (')' : t) = '\\' : ')' : ps_escape t +ps_escape (h : t) = h : ps_escape t + +-- ---------------------------------------------------------------------- +-- ** String formatting + +-- | Convert a 'BoxId' to the string in the format \"/name/, shape /x/\". +string_of_boxid :: BoxId -> String +string_of_boxid (BoxId name shape) = name ++ ", shape " ++ shape + +-- ---------------------------------------------------------------------- +-- ** Functions for dealing with x-coordinates + +-- | Pre-processing: figure out the /x/-column of each gate. Returns +-- (/n/,/xgs/) where /xgs/ is a list of ('Gate', 'X') pairs, and +-- /n/ is the rightmost /x/-coordinate of the circuit. Here we start +-- from /x0/ and use constant step /xoff/ taken from the 'FormatStyle'. +assign_x_coordinates :: FormatStyle -> [Gate] -> X -> (X, [(Gate, X)]) +assign_x_coordinates fs gs x0 = + let ((x,ws), xgs) = mapAccumL (\ (x, ws) g -> + -- count the wires attached to the gate. If there is precisely + -- one (unary gate), merge it with adjacent unary gates. Do + -- not merge comments. + let merge = case (g, wirelist_of_gate g) of + (Comment _ _ _, _) -> Nothing + (_, [w]) -> Just w + (_, _) -> Nothing + in + case merge of + Just w -> + if not (w `elem` ws) then + ((x, w:ws), (g, x)) + else + ((x + (xoff fs), [w]), (g, x + (xoff fs))) + _ -> + if ws == [] then + ((x + (xoff fs), []), (g, x)) + else + ((x + 2.0 * (xoff fs), []), (g, x + (xoff fs))) + ) (x0, []) gs + in + if ws == [] then + (x, xgs) + else + (x + (xoff fs), xgs) + +-- | A 'Xarity' is a map from wire id's to pairs of a wiretype and a +-- starting /x/-coordinate. +type Xarity = Map Wire (Wiretype, X) + +-- | Figure out how a gate at coordinate /x/ affects the current 'Xarity'. +-- Return a pair (/term/, /new/), where /term/ is the 'Xarity' of wires +-- terminated by this gate, and /new/ is the outgoing 'Xarity' of this +-- gate. +update_xarity :: Xarity -> Gate -> X -> (Xarity, Xarity) +update_xarity xarity gate x = + let (win, wout) = gate_arity gate + safe_lookup xarity w = + case Map.lookup w xarity of + Just x -> x + Nothing -> (Qbit, x) -- error ("update_xarity: the wire " ++ show w ++ " does not exist. In the gate:\n" ++ ascii_render_gate gate) + (win', wout') = (win \\ wout, wout \\ win) + -- extract terminating wires from xarity + xarity_term = foldl (\xar (w,_) -> Map.insert w (xarity `safe_lookup` w) xar) Map.empty win' + -- extract continuing wires from xarity + xarity_cont = foldl (\xar (w,_) -> Map.delete w xar) xarity win' + -- add new wires to xarity_cont + xarity_new = foldl (\xar (w,t) -> Map.insert w (t,x) xar) xarity_cont wout' + in + (xarity_term, xarity_new) + +-- ---------------------------------------------------------------------- +-- ** Low-level drawing functions + +-- | @'render_line' x0 y0 x1 y1@: Draw a line from (/x0/, /y0/) +-- to (/x1/, /y1/). In case of a zero-length line, draw nothing. +render_line :: X -> Y -> X -> Y -> Draw () +render_line x0 y0 x1 y1 | x0 == x1 && y0 == y1 = return () +render_line x0 y0 x1 y1 = draw_subroutine alt $ do + moveto x0 y0 + lineto x1 y1 + stroke + where + alt = [custom_ps $ printf "%f %f %f %f line\n" x0 y0 x1 y1] + +-- | @'render_dot' x y@: Draw a filled control dot at (/x/,/y/). +render_dot :: FormatStyle -> X -> Y -> Draw () +render_dot fs x y = draw_subroutine alt $ do + arc x y (dotradius fs) 0 360 + fill (foregroundcolor fs) + where + alt = [custom_ps $ printf "%f %f dot\n" x y] + +-- | @'render_circle' x y@: Draw an empty control dot at +-- (/x/,/y/). +render_circle :: FormatStyle -> X -> Y -> Draw () +render_circle fs x y = draw_subroutine alt $ do + arc x y (dotradius fs) 0 360 + fillstroke (backgroundcolor fs) + where + alt = [custom_ps $ printf "%f %f circ\n" x y] + +-- | @'render_not' x y@: Draw a \"not\" gate at (/x/,/y/). +render_not :: FormatStyle -> X -> Y -> Draw () +render_not fs x y = draw_subroutine alt $ do + arc x y (oplusradius fs) 0 360 + fillstroke (backgroundcolor fs) + render_line (x-(oplusradius fs)) y (x+(oplusradius fs)) y + render_line x (y-(oplusradius fs)) x (y+(oplusradius fs)) + where + alt = [custom_ps $ printf "%f %f oplus\n" x y] + +-- | @'render_swap' x y@: Draw a cross (swap gate component) at +-- (/x/,/y/). +render_swap :: FormatStyle -> X -> Y -> Draw () +render_swap fs x y = draw_subroutine alt $ do + render_line (x-(crossradius fs)) (y-(crossradius fs)) (x+(crossradius fs)) (y+(crossradius fs)) + render_line (x-(crossradius fs)) (y+(crossradius fs)) (x+(crossradius fs)) (y-(crossradius fs)) + where + alt = [custom_ps $ printf "%f %f cross\n" x y] + +-- | @'render_bar' x y@: Draw an init/term bar at (/x/,/y/). +render_bar :: FormatStyle -> X -> Y -> Draw () +render_bar fs x y = draw_subroutine alt $ do + rectangle (x - (barwidth fs)/2) (y - (barheight fs)/2) (barwidth fs) (barheight fs) + fill (foregroundcolor fs) + where + alt = [custom_ps $ printf "%f %f bar\n" x y] + +-- | @'render_bar' x y@: Draw a dterm bar at (/x/,/y/). +render_dbar :: FormatStyle -> X -> Y -> Draw () +render_dbar fs x y = draw_subroutine alt $ do + block $ do + translate (x+(barwidth fs)/2) y + scale (dwidth fs) (dheight fs) + moveto (-1) (-0.5) + arc_append (-0.5) 0 0.5 (-90) 90 + lineto (-1) 0.5 + closepath + fill (foregroundcolor fs) + where + alt = [custom_ps $ printf "%f %f dbar\n" x y] + +-- | @'render_init' name x y@: Draw an \"init\" gate at +-- (/x/,/y/), with state /name/. +render_init :: FormatStyle -> String -> X -> Y -> Draw () +render_init fs name x y = draw_subroutine alt $ do + render_bar fs x y + textbox align_right (gatefont fs) (foregroundcolor fs) (x-(xoff fs)/2+(gatepad fs)/2) y (x-(gatepad fs)/2) y (stringbase fs) name + where + alt = [custom_ps $ printf "(%s) %f %f init\n" (ps_escape name) x y] + +-- | @'render_term' name x y@: Draw a \"term\" gate at +-- (/x/,/y/), with state /name/. +render_term :: FormatStyle -> String -> X -> Y -> Draw () +render_term fs name x y = draw_subroutine alt $ do + render_bar fs x y + textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name + where + alt = [custom_ps $ printf "(%s) %f %f term\n" (ps_escape name) x y] + +-- | @'render_dterm' name x y@: Draw a \"dterm\" gate at +-- (/x/,/y/), with state /name/. +render_dterm :: FormatStyle -> String -> X -> Y -> Draw () +render_dterm fs name x y = draw_subroutine alt $ do + render_dbar fs x y + textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name + where + alt = [custom_ps $ printf "(%s) %f %f dterm\n" (ps_escape name) x y] + +-- | @'render_namedgate' name inv x y@: draw a named box centered at +-- (/x/,/y/). If /inv/ = 'True', append an \"inverse\" symbol to the +-- end of the name. +render_namedgate :: FormatStyle -> String -> InverseFlag -> X -> Y -> Draw () +render_namedgate fs name inv x y = draw_subroutine alt $ do + rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs) + fillstroke (backgroundcolor fs) + textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name' + where + alt = [custom_ps $ printf "(%s) %f %f gate\n" (ps_escape name') x y] + name' = name ++ optional inv "*" + w = text_width (gatefont fs) name' + labelwidth = min w (maxgatelabelwidth fs) + gatewidth = labelwidth + (gatepad fs) + +-- | @'render_gphasegate' name x y@: draw a global phase gate +-- centered at (/x/,/y/). +render_gphasegate :: FormatStyle -> String -> X -> Y -> Draw () +render_gphasegate fs name x y = draw_subroutine alt $ do + render_circgate fs name x (y-0.5) + where + alt = [custom_ps $ printf "(%s) %f %f gphase\n" (ps_escape name) x y] + +-- | @'render_circgate' name x y@: draw a named oval centered at +-- (/x/,/y/). +render_circgate :: FormatStyle -> String -> X -> Y -> Draw () +render_circgate fs name x y = draw_subroutine alt $ do + oval x y (0.5*gatewidth) (0.4*(gateheight fs)) + fillstroke (backgroundcolor fs) + textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name + where + alt = [custom_ps $ printf "(%s) %f %f circgate\n" (ps_escape name) x y] + w = text_width (gatefont fs) name + labelwidth = min w (maxgatelabelwidth fs) + gatewidth = labelwidth + (gatepad fs) + +-- | @'render_blankgate' name x y@: draw an empty box centered +-- at (/x/,/y/), big enough to hold /name/. +render_blankgate :: FormatStyle -> String -> X -> Y -> Draw () +render_blankgate fs name x y = draw_subroutine alt $ do + rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs) + fillstroke (backgroundcolor fs) + where + alt = [custom_ps $ printf "(%s) %f %f box\n" (ps_escape name) x y] + w = text_width (gatefont fs) name + labelwidth = min w (maxgatelabelwidth fs) + gatewidth = labelwidth + (gatepad fs) + +-- | @'render_comment' center s x y m@: draw the given string +-- vertically, with the top of the string near the given +-- /y/-coordinate. If /center/=='True', center it at the +-- /x/-coordinate, else move it just to the left of the +-- /x/-coordinate. /m/ is the maximum height allowed for the comment. +render_comment :: FormatStyle -> Bool -> String -> X -> Y -> Y -> Draw () +render_comment fs center s x y maxh = draw_subroutine alt $ do + textbox align_right (commentfont fs) (commentcolor fs) x (y-maxh) x (y+0.4) b s + where + alt = [custom_ps $ printf "(%s) %f %f %f %f comment\n" (ps_escape s) x y maxh yshift] + b = if center then 0.15 else -0.25 + yshift = -b * nominalsize (commentfont fs) + +-- | @'render_label' center s x y@: draw the given label just above +-- the given point. If /center/=='True', center it at the +-- /x/-coordinate, else move it just to the right of the +-- /x/-coordinate. +render_label :: FormatStyle -> Bool -> String -> X -> Y -> Draw () +render_label fs True s x y = draw_subroutine alt $ do + textbox align_center (labelfont fs) (labelcolor fs) (x-(maxlabelwidth fs)) y' (x+(maxlabelwidth fs)) y' (-0.5) s + where + alt = [custom_ps $ printf "(%s) %f %f clabel\n" (ps_escape s) x y'] + y' = y + 0.5 * (coffs fs) +render_label fs False s x y = draw_subroutine alt $ do + textbox align_left (labelfont fs) (labelcolor fs) x y' (x+(maxlabelwidth fs)) y' (-0.5) s + where + alt = [custom_ps $ printf "(%s) %f %f rlabel\n" (ps_escape s) x y'] + y' = y + 0.5 * (coffs fs) + +-- | Render the number at the given point (/x/,/y/). If the boolean +-- argument is 'True', put the number to the right of /x/, else to the left. +render_number :: FormatStyle -> Int -> Bool -> X -> Y -> Draw () +render_number fs i True x y = draw_subroutine alt $ do + textbox align_left (numberfont fs) (numbercolor fs) (x+0.2) y (x+0.2+(maxnumberwidth fs)) y (stringbase fs) (show i) + where + alt = [custom_ps $ printf "(%s) %f %f rnumber\n" (ps_escape (show i)) x y] +render_number fs i False x y = draw_subroutine alt $ do + textbox align_right (numberfont fs) (numbercolor fs) (x-0.2-(maxnumberwidth fs)) y (x-0.2) y (stringbase fs) (show i) + where + alt = [custom_ps $ printf "(%s) %f %f lnumber\n" (ps_escape (show i)) x y] + +-- ---------------------------------------------------------------------- +-- ** Higher-level rendering functions + +-- | Render a horizontal wire from /x/-coordinates /oldx/ to /x/, +-- using /t/ as the type and figuring out the /y/-coordinate from /ys/ +-- and /w/. Append to the given string. If the parameters are invalid +-- (/w/ not in /ys/), throw an error. +render_typeas :: FormatStyle -> Map Wire Y -> X -> X -> Wire -> Wiretype -> Draw () +render_typeas fs ys oldx x w t = + let y = ys Map.! w in + case t of + Qbit -> do + render_line oldx y x y + Cbit -> do + render_line oldx (y + (coffs fs)) x (y + (coffs fs)) + render_line oldx (y - (coffs fs)) x (y - (coffs fs)) + +-- | Render a bunch of horizontal wires from their respective starting +-- 'Xarity' to /x/. +render_xarity :: FormatStyle -> Map Wire Y -> Xarity -> X -> Draw () +render_xarity fs ys xarity x = do + sequence_ [ render_typeas fs ys oldx x w t | (w,(t,oldx)) <- Map.toList xarity ] + +-- | Format a floating point number in concise form, with limited +-- accuracy. +dshow :: Double -> String +dshow dbl = + if abs dbl < 0.01 + then + printf "%.1e" dbl + else + (reverse . strip . reverse) (printf "%.3f" dbl) + where + strip [] = [] + strip ('.' : t) = t + strip ('0' : t) = strip t + strip t = t + +-- | @'render_controlwire' /x/ /ys/ /ws/ /c/@: +-- Render the line connecting all the box components and all the +-- control dots of some gate. +-- +-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed +-- array of /y/-coordinates, /ws/ is the set of wires for boxes, and +-- /c/ is a list of controls. +render_controlwire :: X -> Map Wire Y -> [Wire] -> Controls -> Draw () +render_controlwire x ys ws c = + case ws of + [] -> return () + w:ws -> render_line x y0 x y1 + where + ymap w = ys Map.! w + y = ymap w + cy = map (\(Signed w _) -> ymap w) c + yy = map (\w -> ymap w) ws + y0 = foldr min y (cy ++ yy) + y1 = foldr max y (cy ++ yy) + +-- | @'render_controlwire_float' /x/ /ys/ /y/ /c/@: Render the line +-- connecting all control dots of the given controls, as well as a +-- floating \"global phase\" gate located just below (/x/, /y/). +-- +-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed +-- array of /y/-coordinates, /y/ is the /y/-coordinate of the wire +-- where the floating gate is attached, and /c/ is a list of controls. +render_controlwire_float :: X -> Map Wire Y -> Y -> Controls -> Draw () +render_controlwire_float x ys y c = render_line x y0 x y1 + where + y' = y - 0.5 + cy = map (\(Signed w _) -> ys Map.! w) c + y0 = minimum (y':cy) + y1 = maximum (y':cy) + +-- | @'render_controldots' /x/ /ys/ /c/@: Render the control dots +-- for the given controls. +render_controldots :: FormatStyle -> X -> Map Wire Y -> Controls -> Draw () +render_controldots fs x ys c = do + sequence_ [ renderdot x | x <- c ] + where + renderdot (Signed w True) = render_dot fs x (ys Map.! w) + renderdot (Signed w False) = render_circle fs x (ys Map.! w) + +-- | @'render_multi_gate' /x/ /ys/ /name/ /inv/ /wires/@: Render the +-- boxes for an /n/-ary gate of the given /name/, potentially +-- /inv/erted, at the given list of /wires/. The first two arguments +-- are the current /x/-coordinate and an indexed array of +-- /y/-coordinates. +render_multi_gate :: FormatStyle -> X -> Map Wire Y -> String -> InverseFlag -> [Wire] -> Draw () +render_multi_gate fs x ys name inv [w] = + render_namedgate fs name inv x (ys Map.! w) +render_multi_gate fs x ys name inv ws = + sequence_ [ render_namedgate fs (name ++ " " ++ show i) inv x (ys Map.! a) | (a,i) <- zip ws [1..] ] + +-- | @'render_multi_named_ctrl' /x/ /ys/ /wires/ /names/@: Render +-- the boxes for multiple generalized controls at the given /wires/, +-- using the given /names/. We take special care of the fact that +-- generalized controls may be used non-linearly. +render_multi_named_ctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> [String] -> Draw () +render_multi_named_ctrl fs x ys ws names = + sequence_ [ render_circgate fs name x (ys Map.! a) | (a,name) <- IntMap.toList map ] + where + -- Combine the labels for w if w has multiple occurrences. + map = IntMap.fromListWith (\x y -> y ++ "," ++ x) (zip ws names) + +-- | @'render_multi_genctrl' /x/ /ys/ /wires/@: Render the boxes for +-- multiple (numbered) generalized controls at the given /wires/. +render_multi_genctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> Draw () +render_multi_genctrl fs x ys ws = render_multi_named_ctrl fs x ys ws names + where + names = map show [1..] + +-- | Number a list of wires in increasing order, at the given +-- /x/-coordinate. If the boolean argument is 'True', put the numbers +-- to the right of /x/, else to the left. +render_ordering :: FormatStyle -> X -> Map Wire Y -> Bool -> [Wire] -> Draw () +render_ordering fs x ys b ws = + sequence_ [ render_number fs i b x (ys Map.! w) | (w,i) <- numbering ] + where + numbering = zip ws [1..] + +-- | Render gate /g/ at /x/-coordinate /x/ and /y/-coordinates as +-- given by /ys/, which is a map from wires to +-- /y/-coordinates. Returns a pair (/s/,/t/) of draw actions for +-- background and foreground, respectively. +render_gate :: FormatStyle -> Gate -> X -> Map Wire Y -> Y -> (Draw (), Draw ()) +render_gate fs g x ys maxh = + let ymap w = ys Map.! w + in + case g of + -- Certain named gates are recognized for custom rendering. + QGate "not" _ [w] [] c ncf -> (s2, t2 >> t3) + where + y = ymap w + s2 = render_controlwire x ys [w] c + t2 = render_controldots fs x ys c + t3 = (render_not fs x y) + QGate "multinot" _ ws [] c ncf -> (s2, t2 >> t3) + where + s2 = render_controlwire x ys ws c + t2 = render_controldots fs x ys c + t3 = sequence_ (map (\w -> (render_not fs x (ymap w))) ws) + QGate "swap" _ [w1,w2] [] c ncf -> (s2, t2 >> t3) + where + y1 = ymap w1 + y2 = ymap w2 + s2 = render_controlwire x ys [w1,w2] c + t2 = render_controldots fs x ys c + t3 = (render_swap fs x y1) >> (render_swap fs x y2) + QGate "trace" _ _ _ _ _ -> (return (), return ()) + QGate name inv ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4) + where + s2 = render_controlwire x ys (ws1 ++ ws2) c + t2 = render_multi_gate fs x ys name inv' ws1 + t3 = render_controldots fs x ys c + t4 = render_multi_genctrl fs x ys ws2 + inv' = inv && not (self_inverse name ws1 ws2) + QRot name inv theta ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4) + where + s2 = render_controlwire x ys (ws1 ++ ws2) c + t2 = render_multi_gate fs x ys name' inv ws1 + t3 = render_controldots fs x ys c + t4 = render_multi_genctrl fs x ys ws2 + name' = substitute name '%' (dshow theta) + GPhase t ws c ncf -> (s2, t2 >> t3) + where + y = case (ws, c) of + ([], []) -> maximum (0.0 : Map.elems ys) + ([], c) -> minimum [ ymap w | Signed w b <- c ] + (ws, c) -> minimum [ ymap w | w <- ws ] + s2 = render_controlwire_float x ys y c + t2 = render_controldots fs x ys c + t3 = (render_gphasegate fs (dshow t) x y) + CNot w c ncf -> (s2, t2 >> t3) + where + y = ymap w + s2 = render_controlwire x ys [w] c + t2 = render_controldots fs x ys c + t3 = (render_not fs x y) + CGate "if" w [a,b,c] ncf -> (s2, t1 >> t3) -- special case + where + y = ymap w + s2 = render_controlwire x ys [w,a,b,c] [] + t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"] + t3 = render_namedgate fs ">" False x y + CGateInv "if" w [a,b,c] ncf -> (s2, t1 >> t3) -- special case + where + y = ymap w + s2 = render_controlwire x ys [w,a,b,c] [] + t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"] + t3 = render_namedgate fs "<" False x y + CGate name w c ncf -> (s2, t2 >> t3) + where + y = ymap w + s2 = render_controlwire x ys (w:c) [] + t2 = render_multi_named_ctrl fs x ys c [ " " | a <- c ] + t3 = render_namedgate fs name False x y + CGateInv name w c ncf -> (s2, t2 >> t3) + where + y = ymap w + s2 = render_controlwire x ys (w:c) [] + t2 = render_multi_named_ctrl fs x ys c [ " " | a <- c ] + t3 = render_namedgate fs name True x y + CSwap w1 w2 c ncf -> (s2, t2 >> t3) + where + y1 = ymap w1 + y2 = ymap w2 + s2 = render_controlwire x ys [w1,w2] c + t2 = render_controldots fs x ys c + t3 = (render_swap fs x y1) >> (render_swap fs x y2) + QPrep w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_namedgate fs "prep" False x y) + QUnprep w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_namedgate fs "unprep" False x y) + QInit b w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_init fs (if b then "1" else "0") x y) + CInit b w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_init fs (if b then "1" else "0") x y) + QTerm b w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_term fs (if b then "1" else "0") x y) + CTerm b w ncf -> (return (), t3) + where + y = ymap w + t3 = (render_term fs (if b then "1" else "0") x y) + QMeas w -> (return (), t3) + where + y = ymap w + t3 = (render_namedgate fs "meas" False x y) + QDiscard w -> (return (), t3) + where + y = ymap w + t3 = (render_bar fs x y) + CDiscard w -> (return (), t3) + where + y = ymap w + t3 = (render_bar fs x y) + DTerm b w -> (return (), t3) + where + y = ymap w + t3 = (render_dterm fs (if b then "1" else "0") x y) + Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep -> (s2, t2 >> t3) + where + ws = union ws1 ws2 + s2 = render_controlwire x ys ws c + t2 = render_multi_gate fs x ys label inv ws + t3 = render_controldots fs x ys c + show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")" + BoxId name shape = boxid + label = name ++ show_rep ++ if (subroutineshape fs) then (", shape " ++ shape) else "" + Comment s inv ws -> (return (), t1 >> t2) + where + t1 = render_comment fs (null ws) s' x (ymap 0) maxh + t2 = sequence_ [render_label fs (null s) l x (ymap w) | (w,l) <- ws] + s' = s ++ optional inv "*" + +-- | Render the gates in the circuit. The parameters are: /xarity/: +-- the 'Xarity' of the currently pending wires. /xgs/: the list of +-- gates, paired with pre-computed /x/-coordinates. /ys/: a map from +-- wires to pre-computed /y/-coordinates. /x/: the right-most +-- /x/-coordinate where the final wires will be drawn to. /maxh/: the +-- maximal height of comments. +render_gates :: FormatStyle -> Xarity -> [(Gate, X)] -> Map Wire Y -> X -> Y -> (Draw (), Draw ()) +render_gates fs xarity xgs ys x maxh = + case xgs of + [] -> + let s2 = render_xarity fs ys xarity x + in (s2, return ()) + (g,newx):gls -> + let (xarity_term, xarity_new) = update_xarity xarity g newx in + let s1 = render_xarity fs ys xarity_term newx in + let (s2, t2) = render_gate fs g newx ys maxh in + let (sx, tx) = render_gates fs xarity_new gls ys x maxh in + (s1 >> s2 >> sx, t2 >> tx) + +-- | PostScript definitions of various parameters. +ps_parameters :: FormatStyle -> String +ps_parameters fs = + "% some parameters\n" + ++ printf "%f setlinewidth\n" (linewidth fs) + ++ printf "/gatepad %f def\n" (gatepad fs) + ++ printf "/gateheight %f def\n" (gateheight fs) + ++ printf "/stringbase %f def\n" (stringbase fs) + ++ printf "/dotradius %f def\n" (dotradius fs) + ++ printf "/oplusradius %f def\n" (oplusradius fs) + ++ printf "/crossradius %f def\n" (crossradius fs) + ++ printf "/barwidth %f def\n" (barwidth fs) + ++ printf "/barheight %f def\n" (barheight fs) + ++ printf "/dwidth %f def\n" (dwidth fs) + ++ printf "/dheight %f def\n" (dheight fs) + ++ printf "/maxgatelabelwidth %f def\n" (maxgatelabelwidth fs) + ++ printf "/maxlabelwidth %f def\n" (maxlabelwidth fs) + ++ printf "/maxnumberwidth %f def\n" (maxnumberwidth fs) + ++ "/gatefont { /Times-Roman findfont .5 scalefont setfont } def\n" + ++ "/labelfont { /Times-Roman findfont .3 scalefont setfont } def\n" + ++ "/commentfont { /Times-Roman findfont .3 scalefont setfont } def\n" + ++ "/numberfont { /Times-Roman findfont .5 scalefont setfont } def\n" + ++ "/labelcolor { 0 0 1 setrgbcolor } def\n" + ++ "/commentcolor { 1 0.2 0.2 setrgbcolor } def\n" + ++ "/numbercolor { 0 0.7 0 setrgbcolor } def\n" + +-- | PostScript definitions for various drawing subroutines. The +-- subroutines provided are: +-- +-- > x0 y0 x1 y1 line : draw a line from (x0,y0) to (x1,y1) +-- > x0 y0 x1 y1 dashedline : draw a dashed line from (x0,y0) to (x1,y1) +-- > x y h w rect : draw a rectangle of dimensions w x h centered at (x,y) +-- > x y h w oval : draw an oval of dimensions w x h centered at (x,y) +-- > x y dot : draw a filled dot at (x,y) +-- > x y circ : draw an empty dot at (x,y) +-- > x y oplus : draw a "not" gate at (x,y) +-- > x y cross : draw a cross ("swap" gate component) at (x,y) +-- > x y bar : draw an init/term bar at (x,y) +-- > x y dbar : draw a dterm bar at (x,y) +-- > name x y box : draw an empty box at (x,y), big enough to fit name +-- > name x y gate : draw a named box at (x,y) +-- > name x y circgate : draw a named round box at (x,y) +-- > name x y gphase : draw a global phase gate (x,y) +-- > b x y init : draw an "init" gate at (x,y), with state b +-- > b x y term : draw a "term" gate at (x,y), with state b +-- > b x y dterm : draw a "dterm" gate at (x,y), with state b +-- > string x y m b comment : draw a vertical comment at (x,y), with max height m and baseline adjustment b +-- > string x y clabel : draw a wire label at (x,y), x-centered +-- > string x y rlabel : draw a wire label at (x,y), right of x +-- > string x y lnumber : draw a numbered input at (x,y) +-- > string x y rnumber : draw a numbered output at (x,y) + +ps_subroutines :: String +ps_subroutines = + "% subroutine definitions\n" + ++ "/line { moveto lineto stroke } bind def\n" + ++ "/dashedline { moveto gsave [0.3 0.2] .15 setdash lineto stroke grestore } bind def\n" + ++ "/rect { /H exch def /W exch def -.5 W mul .5 H mul moveto W 0 rlineto 0 H neg rlineto W neg 0 rlineto closepath } bind def\n" + ++ "/oval { /H exch def /W exch def gsave .5 W mul .5 H mul scale 0 0 1 0 360 newpath arc gsave 1.0 setgray fill grestore stroke grestore } bind def\n" + ++ "/dot { dotradius 0 360 newpath arc gsave 0 setgray fill grestore newpath } bind def\n" + ++ "/circ { dotradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke } bind def\n" + ++ "/oplus { gsave translate 0 0 oplusradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke 0 oplusradius neg 0 oplusradius line oplusradius neg 0 oplusradius 0 line grestore } bind def\n" + ++ "/cross { gsave translate crossradius dup dup neg dup line crossradius dup neg dup dup neg line grestore } bind def\n" + ++ "/bar { gsave translate barwidth barheight rect fill grestore } bind def\n" + ++ "/dbar { gsave translate barwidth 0.5 mul 0 translate dwidth dheight scale -1 -.5 moveto -.5 0 .5 -90 90 arc -1 .5 lineto closepath fill grestore } bind def\n" + ++ "/box { gsave translate gatefont stringwidth pop /w exch def /w1 w gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke grestore } bind def\n" + ++ "/gate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" + ++ "/circgate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 0.8 gateheight mul oval gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" + ++ "/gphase { gsave translate 0 -0.5 circgate grestore } bind def\n" + ++ "/init { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def -.5 w1 mul 0 translate 0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" + ++ "/term { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" + ++ "/dterm { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 dbar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" + ++ "/comment { gsave /b exch def /maxh exch def /y exch def /x exch def commentfont commentcolor x y maxh sub x y 0.4 add 1.0 b textbox grestore } bind def\n" + ++ "/clabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth 2 mul div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale -0.5 w mul 0 moveto labelcolor show grestore } bind def\n" + ++ "/rlabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale 0 0 moveto labelcolor show grestore } bind def\n" + ++ "/lnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def -0.2 -0.15 translate 1 fontscale div dup scale -1 w mul 0 moveto numbercolor show grestore } bind def\n" + ++ "/rnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0.2 -0.15 translate 1 fontscale div dup scale 0 0 moveto numbercolor show grestore } bind def\n" + +-- | @'page_of_ocircuit' name ocirc@: Render the circuit /ocirc/ on a +-- single page. +-- +-- The rendering takes place in the following user coordinate system: +-- +-- \[image coord.png] +page_of_ocircuit :: FormatStyle -> Maybe BoxId -> OCircuit -> Document () +page_of_ocircuit fs boxid ocirc = do + newpage bboxx bboxy $ do + when (isJust boxid) $ do + comment ("drawing commands for " ++ string_of_boxid (fromJust boxid)) + + -- set up the user coordinate system + scale sc sc + translate ((xoff fs) + 1) 1 + + -- drawing commands + setlinewidth (linewidth fs) + when (isJust boxid) $ do + textbox align_left (gatefont fs) (foregroundcolor fs) (-(xoff fs)) (raw_height-0.25) raw_width (raw_height-0.25) (stringbase fs) ("Subroutine " ++ string_of_boxid (fromJust boxid) ++ ":") + rendered_wires + rendered_gates + render_ordering fs (-(xoff fs)) ys False w_in + render_ordering fs raw_width ys True w_out + where + -- unit scale: distance, in points, between wires + sc = 10 + + -- decompose OCircuit + OCircuit (w_in, circ, w_out) = ocirc + (a1,gs,a2,_) = circ + + -- figure out y-coordinates and height + ws = wirelist_of_circuit circ + raw_height = fromIntegral $ length ws + ys = Map.fromList (zip (reverse ws) [0.0 ..]) + maxh = raw_height + 0.3 + bboxy = sc * (raw_height + 1) + + -- figure out x-coordinates and width + (raw_width,xgs) = assign_x_coordinates fs gs 0.0 + bboxx = sc * (raw_width + (xoff fs) + 2.0) + + xa1 = IntMap.map (\t -> (t, -(xoff fs))) a1 + (rendered_wires, rendered_gates) = render_gates fs (Map.fromList (IntMap.assocs xa1)) xgs ys raw_width maxh + +-- | Render a low-level boxed quantum circuit as a graphical +-- 'Document'. If there are subroutines, each of them is placed on a +-- separate page. +render_bcircuit :: FormatStyle -> BCircuit -> Document () +render_bcircuit fs (circ, namespace) = do + page_of_ocircuit fs Nothing (OCircuit ([], circ, [])) + sequence_ [ page_of_ocircuit fs (Just boxid) ocirc | (boxid, TypedSubroutine ocirc _ _ _) <- Map.toList namespace] + +-- | Render a low-level dynamic quantum circuit as a graphical +-- 'Document'. If there are subroutines, each of them is placed on a +-- separate page. If the circuit uses dynamic lifting, an error is +-- produced. +render_dbcircuit :: FormatStyle -> ErrMsg -> DBCircuit a -> Document () +render_dbcircuit fs e dbcirc = render_bcircuit fs bcirc where + (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc + errmsg x = e ("operation not permitted during graphical rendering: " ++ x) + +-- | Print a representation of a low-level quantum circuit, in the +-- requested graphics format, directly to standard output. If there +-- are boxed subcircuits, each of them is placed on a separate page. +print_bcircuit_format :: FormatStyle -> BCircuit -> IO () +print_bcircuit_format fs bcirc = + render_custom_stdout (renderformat fs) cust (render_bcircuit fs bcirc) + where + cust = custom { + creator = "Quipper", + ps_defs = ps_parameters fs ++ ps_subroutines + } + +-- | Print a representation of a low-level dynamic quantum circuit, in +-- the requested graphics format, directly to standard output. If +-- there are boxed subcircuits, each of them is placed on a separate +-- page. If the circuit uses dynamic lifting, an error is produced. +print_dbcircuit_format :: FormatStyle -> ErrMsg -> DBCircuit a -> IO () +print_dbcircuit_format fs e dbcirc = + render_custom_stdout (renderformat fs) cust (render_dbcircuit fs e dbcirc) + where + cust = custom { + creator = "Quipper", + ps_defs = ps_parameters fs ++ ps_subroutines + } + +-- ---------------------------------------------------------------------- +-- * Previewing + +-- | Display a document directly in Acrobat Reader. This may not be +-- portable. It requires the external program \"acroread\" to be +-- installed. +preview_document :: Document a -> IO a +preview_document = preview_document_custom custom + +-- | Display a document directly in Acrobat Reader. This may not be +-- portable. It requires the external program \"acroread\" to be +-- installed. +preview_document_custom :: Custom -> Document a -> IO a +preview_document_custom custom doc = do + tmpdir <- getTemporaryDirectory + (pdffile, fd) <- openTempFile tmpdir "Quipper.pdf" + a <- render_custom_file fd Format_PDF custom doc + hClose fd + system_pdf_viewer 100 pdffile + removeFile pdffile + return a + +-- | Display the circuit directly in Acrobat Reader. This may not be +-- portable. It requires the external program \"acroread\" to be +-- installed. +preview_bcircuit :: BCircuit -> IO () +preview_bcircuit bcirc = + preview_document doc + where + doc = render_bcircuit pdf bcirc + +-- | Display a low-level dynamic quantum circuit directly in Acrobat +-- Reader. This may not be portable. It requires the external program +-- \"acroread\" to be installed. If the circuit uses dynamic lifting, +-- an error is produced. +preview_dbcircuit :: ErrMsg -> DBCircuit a -> IO () +preview_dbcircuit e dbcirc = preview_bcircuit bcirc where + (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc + errmsg x = e ("operation not permitted for PDF preview: " ++ x) + +-- ---------------------------------------------------------------------- +-- * Gate counts + +-- ** Gate types + +-- $ The type 'Gate' contains too much information to be used as the +-- index for counting gates: all 'CNot' gates, for instance, +-- should be counted together, regardless of what wires they are +-- applied to. +-- +-- We define 'Gatetype' to remedy this, with each value of +-- 'Gatetype' corresponding to an equivalence class of +-- gates as they should appear in gate counts. +-- +-- During gate counting, a little more information needs to be retained, +-- so that operations such as adding controls to subroutine counts can +-- be accurately performed. 'AnnGatetype' supplies this information. + +-- | An abbreviated representation of the controls of a gate: +-- the number of positive and negative controls, respectively. +type ControlType = (Int,Int) + +-- | From a list of controls, extract the number of positive and +-- negative controls. +controltype :: Controls -> ControlType +controltype c = + (length $ filter get_sign c, length $ filter (not . get_sign) c) + +-- | Convenience constant for uncontrolled gates. +nocontrols :: ControlType +nocontrols = (0,0) + +-- | A data type representing equivalence classes of basic gates, +-- for the output of gatecounts. +data Gatetype = + Gatetype String ControlType + | GatetypeSubroutine BoxId InverseFlag ControlType + deriving (Eq, Ord, Show) + +-- | A data type analogous to 'Gatetype', but with extra annotations, +-- e.g. a 'NoControlFlag', for use in the computation of gate counts. +data AnnGatetype = + AnnGatetype String (Maybe String) ControlType NoControlFlag ControllableFlag + | AnnGatetypeSubroutine BoxId InverseFlag ControlType NoControlFlag ControllableFlag + deriving (Eq, Ord, Show) + +-- | Forget the annotations of an 'AnnGatetype' +unannotate_gatetype :: AnnGatetype -> Gatetype +unannotate_gatetype (AnnGatetype n _ cs _ _) = Gatetype n cs +unannotate_gatetype (AnnGatetypeSubroutine n i cs _ _) = GatetypeSubroutine n i cs + +-- | Add controls to an annotated gate type, or throw an error message if it is not controllable; +-- unless its 'NoControlFlag' is set, in which case leave it unchanged. +add_controls_gatetype :: ErrMsg -> ControlType -> AnnGatetype -> AnnGatetype +add_controls_gatetype e (x',y') g@(AnnGatetype n n_inv (x,y) ncf cf) = + if ncf then g + else case cf of + AllCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf + OnlyClassicalCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf + NoCtl -> error $ e "add_controls_gatetype: gate " ++ n ++ " is not controllable." + +add_controls_gatetype e (x',y') g@(AnnGatetypeSubroutine n inv (x,y) ncf cf) = + if ncf then g + else case cf of + AllCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf + OnlyClassicalCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf + NoCtl -> error $ e "add_controls_gatetype: subroutine " ++ show n ++ " is not controllable." + +-- | Reverse an annotated gate type, of throw an error if it is not reversible. +reverse_gatetype :: ErrMsg -> AnnGatetype -> AnnGatetype +reverse_gatetype e g@(AnnGatetype n n_inv cs ncf cf) = + case n_inv of + Just n' -> (AnnGatetype n' (Just n) cs ncf cf) + Nothing -> error $ e "reverse_gatetype: gate " ++ n ++ " is not reversible" +reverse_gatetype e g@(AnnGatetypeSubroutine n inv cs ncf cf) = + (AnnGatetypeSubroutine n (not inv) cs ncf cf) + +-- | Set the 'NoControlFlag' of an annotated gate type to 'True'. +set_ncf_gatetype :: AnnGatetype -> AnnGatetype +set_ncf_gatetype (AnnGatetype n n_inv cs ncf cf) = + (AnnGatetype n n_inv cs True cf) +set_ncf_gatetype (AnnGatetypeSubroutine n inv cs ncf cf) = + (AnnGatetypeSubroutine n inv cs True cf) + +-- | Helper function for 'gatetype': append a formatted arity to a string. +with_arity :: String -> Int -> String +n `with_arity` a = n ++ ", arity " ++ show a + +-- | Convert a given low-level gate to an annotated gate type +gatetype :: Gate -> AnnGatetype +gatetype (QGate n inv ws vs c ncf) = + AnnGatetype (n' inv') (Just $ n' $ notinv') (controltype c) ncf AllCtl + where + n' b = (n ++ optional b "*") `with_arity` (length ws + length vs) + inv' = inv && not (self_inverse n ws vs) + notinv' = not inv && not (self_inverse n ws vs) +gatetype (QRot n inv t ws vs c ncf) = + AnnGatetype (n' inv) (Just $ n' $ not inv) (controltype c) ncf AllCtl + where n' b = (printf "Rot(%s,%f)" (n++ optional b "*") t) `with_arity` (length ws + length vs) +gatetype (GPhase t w c ncf) = + AnnGatetype (phase_name t) (Just $ phase_name (-t)) (controltype c) ncf AllCtl + where phase_name t = (printf "exp^(%f i pi)" t) +gatetype (CNot w c ncf) = + AnnGatetype "CNot" (Just "CNot") (controltype c) ncf AllCtl +gatetype (CGate n w ws ncf) = + AnnGatetype (n' True) (Just $ n' False) nocontrols ncf AllCtl + where n' b = n ++ optional b "*" `with_arity` length ws +gatetype (CGateInv n w ws ncf) = + AnnGatetype (n' False) (Just $ n' True) nocontrols ncf AllCtl + where n' b = n ++ optional b "*" `with_arity` length ws +gatetype (CSwap w v c ncf) = + AnnGatetype "CSwap" (Just "CSwap") (controltype c) ncf AllCtl +gatetype (QPrep w ncf) = + AnnGatetype "Prep" (Just "Unprep") nocontrols ncf NoCtl +gatetype (QUnprep w ncf) = + AnnGatetype "Unprep" (Just "Prep") nocontrols ncf NoCtl +gatetype (QInit b w ncf) = + AnnGatetype ("Init" ++ b') (Just $ "Term" ++ b') nocontrols ncf NoCtl + where b' = show $ if b then 1 else 0 +gatetype (CInit b w ncf) = + AnnGatetype ("CInit" ++ b') (Just $ "CTerm" ++ b') nocontrols ncf NoCtl + where b' = show $ if b then 1 else 0 +gatetype (QTerm b w ncf) = + AnnGatetype ("Term" ++ b') (Just $ "Init" ++ b') nocontrols ncf NoCtl + where b' = show $ if b then 1 else 0 +gatetype (CTerm b w ncf) = + AnnGatetype ("CTerm" ++ b') (Just $ "CInit" ++ b') nocontrols ncf NoCtl + where b' = show $ if b then 1 else 0 +gatetype (QMeas w) = + AnnGatetype "Meas" Nothing nocontrols False NoCtl +gatetype (QDiscard w) = + AnnGatetype "Discard" Nothing nocontrols False NoCtl +gatetype (CDiscard w) = + AnnGatetype "CDiscard" Nothing nocontrols False NoCtl +gatetype (DTerm b w) = + AnnGatetype "CDiscard" Nothing nocontrols False NoCtl +gatetype (Subroutine boxid inv ws1 a1 ws2 a2 c ncf ctrble reps) = + AnnGatetypeSubroutine boxid inv (controltype c) ncf ctrble +gatetype (Comment _ inv ws) = AnnGatetype ("Comment") (Just "Comment") nocontrols True NoCtl + +-- | Convert a gate type to a human-readable string. +string_of_gatetype :: Gatetype -> String +string_of_gatetype (Gatetype s (c1,c2)) = + printf "\"%s\"" s + ++ if c2==0 && c1==0 then "" else + if c2==0 then printf ", controls %d" c1 else + printf " controls %d+%d" c1 c2 +string_of_gatetype (GatetypeSubroutine boxid i (c1,c2)) = + "Subroutine" ++ optional i "*" ++ cs ++ ": " ++ string_of_boxid boxid + where + cs = if c2==0 && c1==0 then "" else + if c2==0 then printf ", controls %d" c1 else + printf " controls %d+%d" c1 c2 + +-- ** Gate counts + +-- | Gate counts of circuits. +type Gatecount = Map Gatetype Integer + +-- | Annotated gate counts of circuits. +type AnnGatecount = Map AnnGatetype Integer + +-- | Given the (annotated) gatecount of a circuit, return the gatecount of +-- the reverse circuit, or throw an error if any component is not reversible. +reverse_gatecount :: ErrMsg -> AnnGatecount -> AnnGatecount +reverse_gatecount e = Map.mapKeysWith (+) (reverse_gatetype e) + +-- | Given the (annotated) gatecount of a circuit, return the gatecount of +-- the same circuit with controls added, or throw an error if any component +-- is not controllable. +add_controls_gatecount :: ErrMsg -> ControlType -> AnnGatecount -> AnnGatecount +add_controls_gatecount e cs = Map.mapKeysWith (+) (add_controls_gatetype e cs) + +-- | Set the ncf of all gates in a gatecount to 'True'. +set_ncf_gatecount :: AnnGatecount -> AnnGatecount +set_ncf_gatecount = Map.mapKeysWith (+) set_ncf_gatetype + +-- | Remove the annotations from a gatecount. +unannotate_gatecount :: AnnGatecount -> Gatecount +unannotate_gatecount = Map.mapKeysWith (+) unannotate_gatetype + +-- | Input a list of items and output a map from items to counts. +-- Example: +-- +-- > count ['a', 'b', 'a'] = Map.fromList [('a',2), ('b',1)] +count :: (Ord a, Num int) => [(int,a)] -> Map a int +count list = + foldl' (\mp (i,x) -> MapS.insertWith (+) x i mp) Map.empty list + +-- | Count the number of gates of each type in a circuit, with annotations, +-- treating subroutine calls as atomic gates. +anngatecount_of_circuit :: Circuit -> AnnGatecount +anngatecount_of_circuit (_,gs,_,_) = count $ map (\x -> (repeated x, gatetype x)) $ filter (not . is_comment) gs + where + is_comment (Comment _ _ _) = True + is_comment _ = False + repeated (Subroutine _ _ _ _ _ _ _ _ _ (RepeatFlag repeat)) = repeat + repeated _ = 1 + +-- | Count the number of gates of each type in a circuit, +-- treating subroutine calls as atomic gates. +gatecount_of_circuit :: Circuit -> Gatecount +gatecount_of_circuit = unannotate_gatecount . anngatecount_of_circuit + +-- | Given an 'AnnGatetype' describing a subroutine call +-- (possibly repeated), +-- and a gate count for the subroutine itself, return the gatecount +-- of the subroutine call. +-- +-- (This may be the reverse of the original subroutine, may have +-- controls added, etc.) +gatecount_of_subroutine_call :: ErrMsg -> AnnGatetype -> RepeatFlag -> AnnGatecount -> AnnGatecount +gatecount_of_subroutine_call e (AnnGatetypeSubroutine boxid inv cs ncf ctrble) (RepeatFlag reps) = + (if inv then reverse_gatecount err_inv else id) + . (if cs == nocontrols then id + else case ctrble of + AllCtl -> add_controls_gatecount err_ctrl cs + OnlyClassicalCtl -> add_controls_gatecount err_ctrl cs + NoCtl -> error $ err_ctrble) + . (if reps == 1 then id else (Map.map (* reps))) + . (if ncf then set_ncf_gatecount else id) + where + err_inv = e . (("gatecount_of_subroutine_call, inverting subroutine " ++ longname ++ ": ") ++) + err_ctrl = e . (("gatecount_of_subroutine_call, controlling subroutine " ++ longname ++ ": ") ++) + err_ctrble = e $ "gatecount_of_subroutine_call: subroutine " ++ longname ++ " not controllable" + longname = string_of_boxid boxid + +gatecount_of_subroutine_call e _ _ = error $ e "internal error (gatecount_of_subroutine_call called on non-subroutine)" + +-- | Given a circuit and gatecounts for its subroutines, +-- give an (aggregated) gatecount for the circuit. +anngatecount_of_circuit_with_sub_cts :: ErrMsg -> Map BoxId AnnGatecount -> Circuit -> AnnGatecount +anngatecount_of_circuit_with_sub_cts e sub_cts (_,gs,_,_) = + foldr action Map.empty gs + where + action (Comment _ _ _) = id + action g@(Subroutine n _ _ _ _ _ _ _ _ reps) = + case Map.lookup n sub_cts of + Nothing -> error $ e $ "subroutine not found: " ++ show n + Just n_ct -> flip (Map.unionWith (+)) $ + gatecount_of_subroutine_call e (gatetype g) reps n_ct + action g = MapS.insertWith (+) (gatetype g) 1 + +-- | Give the aggregate gate count of a 'BCircuit'; that is, the +-- the total count of basic gates once all subroutines are fully inlined. +aggregate_gatecounts_of_bcircuit :: BCircuit -> Gatecount +aggregate_gatecounts_of_bcircuit (main_circ, namespace) + = unannotate_gatecount $ + anngatecount_of_circuit_with_sub_cts e sub_cts main_circ + where + sub_cts = Map.map (anngatecount_of_circuit_with_sub_cts e sub_cts . circuit_of_typedsubroutine) namespace + e = ("aggregate_gatecounts_of_bcircuit: " ++) + +-- ** Wire usage count + +-- | Count by how much a low-level gate changes the number of wires in the arity. + +-- Implementation note: writing this function explicitly case-by-case appears +-- very slightly faster (~0.5%), but more fragile/less maintainable. +gate_wires_change :: Gate -> Integer +gate_wires_change g = + let (a_in,a_out) = gate_arity g + in fromIntegral $ length a_out - length a_in + +-- | Find the maximum number of wires used simultaneously in a 'BCircuit', +-- assuming all subroutines inlined. +aggregate_maxwires_of_bcircuit :: BCircuit -> Integer +aggregate_maxwires_of_bcircuit (main_circ, namespace) + = maxwires_of_circuit_with_sub_maxwires e sub_maxs main_circ + where + e = ("aggregate_maxwires_of_bcircuit: " ++) + sub_maxs = Map.map (maxwires_of_circuit_with_sub_maxwires e sub_maxs . circuit_of_typedsubroutine) namespace + +-- | Given a circuit and gatecounts for its subroutines, +-- give an (aggregated) gatecount for the circuit. +maxwires_of_circuit_with_sub_maxwires :: ErrMsg -> Map BoxId Integer -> Circuit -> Integer +maxwires_of_circuit_with_sub_maxwires e sub_maxs (a1,gs,a2,_) = + snd $ foldl (flip action) (in_wires, in_wires) gs + where + in_wires = fromIntegral $ IntMap.size a1 + update w_change (!w_old, !wmax_old) = +-- Implementation note: strictness in this pattern is to avoid putting the whole +-- tower of “max” applications on the stack. + let w_new = w_old + w_change in (w_new, max wmax_old w_new) + action g@(Subroutine n _ ws1 _ ws2 _ _ _ _ (RepeatFlag r)) = + case Map.lookup n sub_maxs of + Nothing -> error $ "subroutine not found: " ++ show n + Just n_max -> (update $ (fromIntegral $ length ws2) - n_max) + . (update $ n_max - (fromIntegral $ length ws1)) + action g = update $ gate_wires_change g + +-- ** Printing gate counts + +-- | Print a gate count, as a table of integers and gate types. +print_gatecount :: Gatecount -> IO () +print_gatecount cts = mapM_ + (\(gt,k) -> putStr (printf ("%" ++ show max_digits ++ "d: %s\n") k (string_of_gatetype gt))) + (Map.assocs cts) + where + max_digits = maximum $ 5:(map ((1+) . floor . logBase 10 . fromIntegral) (Map.elems cts)) + +-- | Print the simple gate count, plus summary information, for a simple circuit. +print_gatecounts_circuit :: Circuit -> IO () +print_gatecounts_circuit circ@(a1,gs,a2,n) = do + print_gatecount cts + putStrLn $ printf "Total gates: %d" $ sum $ Map.elems cts + putStrLn $ printf "Inputs: %d" $ IntMap.size a1 + putStrLn $ printf "Outputs: %d" $ IntMap.size a2 + putStrLn $ printf "Qubits in circuit: %d" n + where + cts = gatecount_of_circuit circ + +-- | Print gate counts for a boxed circuit: +-- first the simple gate count for each subroutine separately, +-- then the aggregated count for the whole circuit. +print_gatecounts_bcircuit :: BCircuit -> IO () +print_gatecounts_bcircuit bcirc@(circ@(a1,_,a2,_),namespace) = do + print_gatecounts_circuit circ + when (not $ Map.null namespace) $ do + sequence_ [ (putStrLn "") >> (print_gatecounts_subroutine sub) | sub <- Map.toList namespace ] + putStrLn "" + putStrLn "Aggregated gate count:" + let aggregate_cts = aggregate_gatecounts_of_bcircuit bcirc + maxwires = aggregate_maxwires_of_bcircuit bcirc + print_gatecount aggregate_cts + putStrLn $ printf "Total gates: %d" $ sum $ Map.elems aggregate_cts + putStrLn $ printf "Inputs: %d" $ IntMap.size a1 + putStrLn $ printf "Outputs: %d" $ IntMap.size a2 + putStrLn $ printf "Qubits in circuit: %d" maxwires + +-- | Print gate counts for a named subroutine. +print_gatecounts_subroutine :: (BoxId, TypedSubroutine) -> IO () +print_gatecounts_subroutine (boxid, TypedSubroutine ocirc _ _ _) = do + putStrLn ("Subroutine: " ++ show name) + putStrLn ("Shape: " ++ show shape) + print_gatecounts_circuit circ + where + OCircuit (_, circ, _) = ocirc + BoxId name shape = boxid + +-- | Print gate counts for a static 'DBCircuit'. The circuit may not +-- use any dynamic lifting, or else an error will be produced. +print_gatecounts_dbcircuit :: ErrMsg -> DBCircuit a -> IO () +print_gatecounts_dbcircuit e dbcirc = print_gatecounts_bcircuit bcirc where + (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc + errmsg x = e ("operation not permitted during gate count: " ++ x) + +-- ---------------------------------------------------------------------- +-- * Printing to multiple formats + +-- | Available output formats. + +data Format = + EPS -- ^ Encapsulated PostScript graphics. + | PDF -- ^ Portable Document Format. One circuit per page. + | PS -- ^ PostScript. One circuit per page. + | ASCII -- ^ A textual representation of circuits. + | Preview -- ^ Don't print anything, but preview directly on screen (requires the external program /acroread/). + | GateCount -- ^ Print statistics on gate counts. + | CustomStyle FormatStyle + deriving Show + +-- | A mapping from lower-case strings (to be used, e.g., with command +-- line options) to available formats. +format_enum :: [(String, Format)] +format_enum = [ + ("eps", EPS), + ("pdf", PDF), + ("ps", PS), + ("postscript", PS), + ("ascii", ASCII), + ("preview", Preview), + ("gatecount", GateCount) + ] + +-- | Print a low-level quantum circuit directly to the IO monad, using +-- the specified format. +print_dbcircuit :: Format -> ErrMsg -> DBCircuit a -> IO () +print_dbcircuit EPS = print_dbcircuit_format eps +print_dbcircuit PDF = print_dbcircuit_format pdf +print_dbcircuit PS = print_dbcircuit_format ps +print_dbcircuit ASCII = print_dbcircuit_ascii +print_dbcircuit Preview = preview_dbcircuit +print_dbcircuit GateCount = print_gatecounts_dbcircuit +print_dbcircuit (CustomStyle fs) = print_dbcircuit_format fs + +-- | Print a document to the requested format, which must be one of +-- 'PS', 'PDF', 'EPS', or 'Preview'. +print_of_document :: Format -> Document a -> IO a +print_of_document = print_of_document_custom custom + +-- | Like 'print_of_document', but also takes a 'Custom' data +-- structure. +print_of_document_custom :: Custom -> Format -> Document a -> IO a +print_of_document_custom custom PS doc = render_custom_stdout Format_PS custom doc +print_of_document_custom custom PDF doc = render_custom_stdout Format_PDF custom doc +print_of_document_custom custom EPS doc = render_custom_stdout (Format_EPS 1) custom doc +print_of_document_custom custom Preview doc = preview_document_custom custom doc +print_of_document_custom custom format doc = error ("print_of_document: method " ++ show format ++ " can't be used in this context") + +-- ====================================================================== +-- * Generic printing + +-- | Like 'print_unary', but also takes a stub error message. +print_errmsg :: (QCData qa) => ErrMsg -> Format -> (qa -> Circ b) -> qa -> IO () +print_errmsg e format f shape = print_dbcircuit format e dbcircuit + where + (in_bind, dbcircuit) = encapsulate_dynamic f shape + +-- | Print a circuit generating function to the specified format; this +-- requires a shape parameter. +print_unary :: (QCData qa) => Format -> (qa -> Circ b) -> qa -> IO () +print_unary = print_errmsg errmsg + where + errmsg x = "print_unary: " ++ x + +-- | Print a circuit generating function to the specified +-- format. Unlike 'print_unary', this can be applied to a +-- circuit-generating function in curried form with /n/ arguments, for +-- any /n >= 0/. It then requires /n/ shape parameters. +-- +-- The type of this heavily overloaded function is difficult to +-- read. In more readable form, it has all of the following types: +-- +-- > print_generic :: Format -> Circ qa -> IO () +-- > print_generic :: (QCData qa) => Format -> (qa -> Circ qb) -> a -> IO () +-- > print_generic :: (QCData qa, QCData qb) => Format -> (qa -> qb -> Circ qc) -> a -> b -> IO () +-- +-- and so forth. + +print_generic :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO())) => Format -> qfun -> fun +print_generic format f = g where + f1 = quncurry f + g1 = print_errmsg errmsg format f1 + g = mcurry g1 + errmsg x = "print_generic: " ++ x + +-- | Like 'print_generic', but only works at simple types, and +-- therefore requires no shape parameters. +print_simple :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO()), QCData_Simple qa) => Format -> qfun -> IO () +print_simple format f = print_errmsg errmsg format f1 fs_shape where + f1 = quncurry f + errmsg x = "print_simple: " ++ x diff --git a/Quipper/Internal/QClasses.hs b/Quipper/Internal/QClasses.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/QClasses.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} + +-- | This module defines quantum analogues of some Haskell type +-- classes. For instance, Haskell’s @'Eq' a@ has one method +-- +-- > (==) :: a -> a -> Bool. +-- +-- Correspondingly, our @'QEq' a qa ca@ has a method +-- +-- > q_is_equal :: qa -> qa -> Circ (qa,qa,Qubit). +-- +-- All quantum type classes assume that their instance types are +-- 'QData' (or sometimes 'QCData'). +-- +-- Quantum type classes are designed to play nicely with the +-- translation of "Quipper.Internal.CircLifting". + +module Quipper.Internal.QClasses where + +import Quipper.Internal.Generic +import Quipper.Internal.QData +import Quipper.Internal.Monad + +-- ---------------------------------------------------------------------- +-- * The type class QEq + +-- | This is a quantum analogue of Haskell’s 'Eq' type class. Default +-- implementations are provided; by default, equality is bitwise +-- equality of the underlying data structure. However, specific +-- instances can provide custom implementations. In this case, +-- 'q_is_equal' is a minimal complete definition. + +-- Right now we make all QCData an instance of 'QEq', and the equality +-- is always physical equality. In the future we will probably want to +-- replace this by instances for specific types. +type QEq qc = (QCData qc) + +-- | Test for equality. +q_is_equal :: (QEq qc) => qc -> qc -> Circ (qc, qc, Qubit) +q_is_equal qx qy = do + (qx,qy) <- controlled_not qx qy + test <- qinit False + test <- qnot test `controlled` qx .==. qc_false qx + (qx,qy) <- reverse_generic_endo controlled_not qx qy + return (qx,qy,test) + +-- | Test for inequality. +q_is_not_equal :: (QEq qc) => qc -> qc -> Circ (qc, qc, Qubit) +q_is_not_equal qx qy = do + (qx,qy,test) <- q_is_equal qx qy + qnot_at test + return (qx,qy,test) + + +-- ---------------------------------------------------------------------- +-- * The type class QOrd + +-- | This is a quantum analogue of Haskell's 'Ord' type class. Its +-- purpose is to define a total ordering on each of its instances. The +-- functions in this class are assumed dirty in the sense that they do +-- not uncompute ancillas, and some of the inputs may be returned as +-- outputs. The functions are also assumed to be non-linear safe, +-- i.e., they apply no gates to their inputs except as control +-- sources. Minimal complete definition: 'q_less' or 'q_greater'. The default +-- implementations of 'q_max' and 'q_min' assume that both arguments +-- are of the same shape (for example, numbers of the same length). +class (QEq qa, QData qa) => QOrd qa where + -- | Test for less than. + q_less :: qa -> qa -> Circ Qubit + q_less x y = q_greater y x + + -- | Test for greater than. + q_greater :: qa -> qa -> Circ Qubit + q_greater x y = q_less y x + + -- | Test for less than or equal. + q_leq :: qa -> qa -> Circ Qubit + q_leq x y = do + s <- q_greater x y + r <- qinit False + qnot_at r `controlled` s .==. False + return r + + -- | Test for greater than or equal. + q_geq :: qa -> qa -> Circ Qubit + q_geq x y = q_leq y x + + -- | Compute the maximum of two values. + q_max :: qa -> qa -> Circ qa + q_max x y = do + q <- q_greater x y + z <- qinit $ qc_false x + (z,x) <- controlled_not z x `controlled` q .==. True + (z,y) <- controlled_not z y `controlled` q .==. False + return z + + -- | Compute the minimum of two values. + q_min :: qa -> qa -> Circ qa + q_min x y = do + q <- q_less x y + z <- qinit $ qc_false x + (z,x) <- controlled_not z x `controlled` q .==. True + (z,y) <- controlled_not z y `controlled` q .==. False + return z + +-- =========================================== +-- * Functionally-typed wrappers for 'QOrd' methods + +-- | @'q_lt' /qx/ /qy/@: test whether /qx/ < /qy/. A functionally typed wrapper for 'q_less'. +q_lt :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) +q_lt qx qy = do + test <- q_less qx qy + return (qx,qy,test) + +-- | @'q_gt' /qx/ /qy/@: test whether /qx/ > /qy/. A functionally typed wrapper for 'q_greater'. +q_gt :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) +q_gt qx qy = do + test <- q_greater qx qy + return (qx,qy,test) + +-- | @'q_le' /qx/ /qy/@: test whether /qx/ ≤ /qy/. A functionally typed wrapper for 'q_leq'. +q_le :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) +q_le qx qy = do + test <- q_leq qx qy + return (qx,qy,test) + +-- | @'q_ge' /qx/ /qy/@: test whether /qx/ ≥ /qy/. A functionally typed wrapper for 'q_geq'. +q_ge :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) +q_ge qx qy = do + test <- q_geq qx qy + return (qx,qy,test) diff --git a/Quipper/Internal/QData.hs b/Quipper/Internal/QData.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/QData.hs @@ -0,0 +1,1339 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ < 710 + {-# OPTIONS -fcontext-stack=50 #-} +#else + {-# OPTIONS -freduction-depth=50 #-} +#endif + +-- -O0 is needed for this file, because -O1 triggers a compiler bug in +-- ghc 7.2.2 (see http://hackage.haskell.org/trac/ghc/ticket/6168), +-- and -O2 triggers a different compiler bug in ghc 7.2.2 + +{-# OPTIONS_GHC -O0 #-} + +-- | This module provides type classes for dealing with various +-- \"shaped\" quantum and classical data structures. Examples of data +-- structures are tuples, lists, records, registers, arrays, indexed +-- arrays, etc. Is it convenient to extend certain operations to +-- arbitrary quantum data structures; for example, instead of +-- measuring a single qubit and obtaining a bit, one may measure an +-- /n/-tuple of qubits and obtain an /n/-tuple of bits. We call an +-- operation \"generic\" if it can act on arbitrary data structures. +-- +-- This module provides shaped types and low-level combinators, in +-- terms of which higher-level generic quantum operations can be +-- defined. +-- +-- The low-level combinators provided by this module (with names +-- /qcdata_*/ and /qdata_*/) should never be used directly in user +-- code (and for this reason, they are not re-exported by +-- "Quipper"). Instead, they are intended as building blocks for +-- user-level generic functions (in "Quipper.Internal.Generic" and related +-- modules). The only exception is that the functions may be used in +-- libraries or user-level code to define new quantum data +-- constructors. Modules that contain such definitions should import +-- 'Quipper.Internal'. + +module Quipper.Internal.QData where + +-- import other Quipper stuff +import Quipper.Internal.Monad +import Quipper.Utils.Auxiliary +import Quipper.Utils.Tuple +import Quipper.Internal.Labels +import Quipper.Internal.Transformer +import Quipper.Internal.Control + +import Data.Typeable +import Quipper.Utils.Typeable +import Control.Monad.State + +-- ====================================================================== +-- * Introduction + +-- $ The data types we consider here come in two varieties: +-- /homogeneous/ and /heterogeneous/ types. +-- +-- A /homogeneous/ data type describes a data structure that is built +-- up from only one kind of basic data (for example, only qubits, only +-- classical bits, or only boolean parameters). The following are +-- typical examples of homogeneous types: +-- +-- > qa = (Qubit, Qubit, [Qubit]) +-- > ca = (Bit, Bit, [Bit]) +-- > ba = (Bool, Bool, [Bool]). +-- +-- An important feature of homogeneous types is that they can be +-- related to each other by shape. For example, /ca/ above is the +-- \"classical version\" of /qa/. We say that the above types /qa/, +-- /ca/, and /ba/ all share the same /shape type/. On the other hand, +-- they differ in their /leaf types/, which are 'Qubit', 'Bit', and +-- 'Bool', respectively. +-- +-- When naming types, variables, and operations related to homogeneous +-- data structures, we often use letters such as /q/, /c/, and /b/ to +-- denote, respectively, the quantum, classical, and boolean versions +-- of some concept. +-- +-- Homogeneous types are made available to Quipper programs via the +-- 'QData' and 'QShape' type classes. +-- +-- A /heterogeneous/ data type describes a data structure that may +-- contain both classical and quantum bits. A typical example of a +-- heterogeneous type is: +-- +-- > qc = (Qubit, Bit, [Qubit]). +-- +-- Heterogeneous types are often used to represent sets of +-- endpoints of a circuit, or the inputs or outputs to some circuit +-- building function. We often use the letters /qc/ in connection with +-- heterogeneous types. +-- +-- Heterogeneous types are made available to Quipper programs via the +-- 'QCData' and 'QCDataPlus' type classes. + +-- ====================================================================== +-- * Primitive definitions + +-- $ The type classes of this module are all derived from four +-- primitive items, which must be defined by induction on types: +-- +-- * A type class 'QCData' /qc/, representing structured data types +-- made up from classical and quantum leaves. +-- +-- * A type family 'QCType' /x/ /y/ /qc/, representing the type-level +-- substitution operation [nobr /qc/ [/x/ \/ 'Qubit', /y/ \/ 'Bit']]. +-- +-- * A type family 'QTypeB' /ba/, representing the type-level substitution +-- [nobr /ba/ ['Qubit' \/ 'Bool']]. +-- +-- * A type class 'SimpleType' /qc/, representing \"simple\" data +-- types. We say that a data type /t/ is \"simple\" if any two +-- elements of /t/ have the same number of leaves. For example, tuples +-- are simple, but lists are not. +-- +-- An instance of 'QCData', 'QCType' and 'QTypeB' must be defined for +-- each new kind of quantum data. If the quantum data is simple, an +-- instance of 'SimpleType' must also be defined. +-- +-- All other notions in this module are defined in terms of the above +-- four, and therefore need not be defined on a per-type basis. + +-- ---------------------------------------------------------------------- +-- ** The QCType operation + +-- | The type 'QCType' /x/ /y/ /a/ represents the substitution +-- [nobr /a/ [/x/ \/ 'Qubit', /y/ \/ 'Bit']]. For example: +-- +-- > QCType x y (Qubit, Bit, [Qubit]) = (x, y, [x]). +-- +-- An instance of this must be defined for each new kind of quantum +-- data. +type family QCType x y a +type instance QCType x y Qubit = x +type instance QCType x y Bit = y + +type instance QCType x y () = () +type instance QCType x y (a,b) = (QCType x y a, QCType x y b) +type instance QCType x y (a,b,c) = (QCType x y a, QCType x y b, QCType x y c) +type instance QCType x y (a,b,c,d) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d) +type instance QCType x y (a,b,c,d,e) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e) +type instance QCType x y (a,b,c,d,e,f) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f) +type instance QCType x y (a,b,c,d,e,f,g) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g) +type instance QCType x y (a,b,c,d,e,f,g,h) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h) +type instance QCType x y (a,b,c,d,e,f,g,h,i) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h, QCType x y i) +type instance QCType x y (a,b,c,d,e,f,g,h,i,j) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h, QCType x y i, QCType x y j) +type instance QCType x y [a] = [QCType x y a] +type instance QCType x y (B_Endpoint a b) = B_Endpoint (QCType x y a) (QCType x y b) +type instance QCType x y (Signed a) = Signed (QCType x y a) + +-- ---------------------------------------------------------------------- +-- ** The QTypeB operation + +-- | The type 'QTypeB' /ba/ represents the substitution +-- [nobr /ba/ ['Qubit' \/ 'Bool']]. For example: +-- +-- > QTypeB (Bool, Bool, [Bool]) = (Qubit, Qubit, [Qubit]). +-- +-- An instance of this must be defined for each new kind of quantum data. +type family QTypeB a +type instance QTypeB Bool = Qubit +type instance QTypeB () = () +type instance QTypeB (a,b) = (QTypeB a, QTypeB b) +type instance QTypeB (a,b,c) = (QTypeB a, QTypeB b, QTypeB c) +type instance QTypeB (a,b,c,d) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d) +type instance QTypeB (a,b,c,d,e) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e) +type instance QTypeB (a,b,c,d,e,f) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f) +type instance QTypeB (a,b,c,d,e,f,g) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g) +type instance QTypeB (a,b,c,d,e,f,g,h) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h) +type instance QTypeB (a,b,c,d,e,f,g,h,i) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h, QTypeB i) +type instance QTypeB (a,b,c,d,e,f,g,h,i,j) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h, QTypeB i, QTypeB j) +type instance QTypeB [a] = [QTypeB a] +type instance QTypeB (B_Endpoint a b) = B_Endpoint (QTypeB a) (QTypeB b) +type instance QTypeB (Signed a) = Signed (QTypeB a) + +-- ---------------------------------------------------------------------- +-- ** The QCData class + +-- $ The 'QCData' class provides only three primitive combinators: +-- 'qcdata_mapM', 'qcdata_zip', and 'qcdata_promote'. These are +-- sufficient to define all other shape-generic operations. +-- +-- An instance of this must be defined for each new kind of quantum data. +-- +-- The functions 'qcdata_mapM' and 'qcdata_zip' require \"shape type +-- parameters\". These are dummy arguments whose /value/ is ignored, +-- but whose /type/ is used to determine the shape of the data to map +-- over. The dummy terms @'qubit' :: 'Qubit'@ and @'bit' :: 'Bit'@ may +-- be used to represent leaves in shape type arguments. +-- +-- Note to programmers defining new 'QCData' instances: Instances +-- /must/ ensure that the functions 'qcdata_mapM' and 'qcdata_zip' +-- do not evaluate their dummy arguments. These arguments will often +-- be 'undefined'. In particular, if using a pattern match on this +-- argument, only a variable or a /lazy/ pattern can be used. + +-- | The 'QCData' type class contains heterogeneous data types built +-- up from leaves of type 'Qubit' and 'Bit'. It is the basis for +-- several generic operations that apply to classical and quantum +-- data, such as copying, transformers, simulation, and heterogeneous +-- versions of qterm and qdiscard. +-- +-- 'QCData' and 'QData' are interrelated, in the sense that the +-- following implications hold: +-- +-- > QData qa implies QCData qa +-- > CData ca implies QCData ca +-- +-- Implications in the converse direction also hold whenever /qc/ is a +-- fixed known type: +-- +-- > QCData qc implies QData (QType qc) +-- > QCData qc implies CData (CType qc) +-- > QCData qc implies BData (BType qc) +-- +-- However, the type checker cannot prove the above implication in the +-- case where /qc/ is a type variable; for this, the more flexible +-- (but more computationally expensive) 'QCDataPlus' class can be used. + +class (Labelable qc String, + Typeable qc, + Show qc, + Show (LType qc), + qc ~ QCType Qubit Bit qc, + CType (QType qc) ~ CType qc, + BType (CType qc) ~ BType qc, + QCType Int Bool (CType qc) ~ BType qc + ) => QCData qc where + -- | Map two functions /f/ and /g/ over all the leaves of a + -- heterogeneous data structure. Apply /f/ to all the leaves at + -- 'Qubit' positions, and /g/ to all the leaves at 'Bit' positions. + -- The first argument is a shape type parameter. + -- + -- Example (ignoring the monad for the sake of simplicity): + -- + -- > qcdata_mapM (qubit, bit, [qubit]) f g (x,y,[z,w]) = (f x, g y, [f z, f w]). + -- + -- For data types that have a sense of direction, the mapping should + -- preferably be performed from left to right, but this property is + -- not guaranteed and may change without notice. + qcdata_mapM :: (Monad m) => qc -> (q -> m q') -> (c -> m c') -> QCType q c qc -> m (QCType q' c' qc) + + -- | Zip two heterogeneous data structures together, to obtain a new + -- data structure of the same shape, whose elements are pairs of the + -- corresponding elements of the input data structures. The zipping + -- is /strict/, meaning that both input data structure must have + -- exactly the same shape (same length of lists, etc). The first + -- five arguments are shape type parameters, representing the shape + -- of the data structure, the two leaf types of the first data + -- structure, and the two leaf types of the second data structure, + -- respectively. + -- + -- Example: + -- + -- > qcdata_zip (bit, [qubit]) int bool char string (True, [2,3]) ("b", ['c', 'd']) = ((True, "b"), [(2,'c'), (3,'d')]) + -- > where the shape parameters are: + -- > int = dummy :: Int + -- > bool = dummy :: Bool + -- > char = dummy :: Char + -- > string = dummy :: String + -- + -- The 'ErrMsg' argument is a stub error message to be used in + -- case of failure. + qcdata_zip :: qc -> q -> c -> q' -> c' -> QCType q c qc -> QCType q' c' qc -> ErrMsg -> QCType (q, q') (c, c') qc + + -- | It is sometimes convenient to have a boolean parameter with + -- some aspect of its shape indeterminate. The function + -- 'qcdata_promote' takes such a boolean parameter, as well as a + -- piece of 'QCData', and attempts to set the shape of the former to + -- that of the latter. + -- + -- The kinds of promotions that are allowed depend on the data type. + -- For example, for simple types, 'qcdata_promote' has no work to do + -- and should just return the first argument. For types that are not + -- simple, but where no promotion is desired + -- (e.g. 'Quipper.Libraries.Qureg.Qureg'), 'qcdata_promote' should + -- check that the shapes of the first and second argument agree, and + -- throw an error otherwise. For lists, we allow a longer list to be + -- promoted to a shorter one, but not the other way around. For + -- quantum integers, we allow an integer of indeterminate length to + -- be promoted to a determinate length, but we do not allow a + -- determinate length to be changed to another determinate length. + -- + -- The 'ErrMsg' argument is a stub error message to be used in + -- case of failure. + qcdata_promote :: BType qc -> qc -> ErrMsg -> BType qc + +instance QCData Qubit where + qcdata_mapM shape f g = f + qcdata_zip shape q c q' c' x y e = (x, y) + qcdata_promote a x e = a + +instance QCData Bit where + qcdata_mapM shape f g = g + qcdata_zip shape q c q' c' x y e = (x, y) + qcdata_promote a x e = a + +instance QCData () where + qcdata_mapM shape f g x = return () + qcdata_zip shape q c q' c' x y e = () + qcdata_promote a x e = a + +instance (QCData a, QCData b) => QCData (a,b) where + qcdata_mapM ~(a,b) f g (x,y) = do + x' <- qcdata_mapM a f g x + y' <- qcdata_mapM b f g y + return (x', y') + qcdata_zip ~(a,b) q c q' c' (x1, x2) (y1, y2) e = (z1, z2) where + z1 = qcdata_zip a q c q' c' x1 y1 e + z2 = qcdata_zip b q c q' c' x2 y2 e + qcdata_promote (a,b) (x,y) e = (qcdata_promote a x e, qcdata_promote b y e) + +instance (QCData a, QCData b, QCData c) => QCData (a,b,c) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d) => QCData (a,b,c,d) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e) => QCData (a,b,c,d,e) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f) => QCData (a,b,c,d,e,f) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g) => QCData (a,b,c,d,e,f,g) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h) => QCData (a,b,c,d,e,f,g,h) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h, QCData i) => QCData (a,b,c,d,e,f,g,h,i) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h, QCData i, QCData j) => QCData (a,b,c,d,e,f,g,h,i,j) where + qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) + qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e + qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s + +instance (QCData a) => QCData [a] where + qcdata_mapM ~[a] f g xs = do + sequence [ qcdata_mapM a f g x | x <- xs] + qcdata_zip ~[a] q c q' c' xs ys e = zs where + zs = [ qcdata_zip a q c q' c' x y e | (x, y) <- zip_strict_errmsg xs ys errmsg] + errmsg = e ("lists differ in length: " ++ show (length xs) ++ " " ++ show (length ys)) + qcdata_promote as xs e = + [ qcdata_promote a x e | (a,x) <- zip_rightstrict_errmsg as xs errmsg ] + where + errmsg = e "list too short" + +instance (QCData a, QCData b) => QCData (B_Endpoint a b) where + qcdata_mapM ~(Endpoint_Qubit a) f g (Endpoint_Qubit x) = do + x' <- qcdata_mapM a f g x + return (Endpoint_Qubit x') + qcdata_mapM ~(Endpoint_Bit b) f g (Endpoint_Bit y) = do + y' <- qcdata_mapM b f g y + return (Endpoint_Bit y') + qcdata_zip ~(Endpoint_Qubit a) q c q' c' (Endpoint_Qubit x) (Endpoint_Qubit y) e = (Endpoint_Qubit z) where + z = qcdata_zip a q c q' c' x y e + qcdata_zip ~(Endpoint_Bit b) q c q' c' (Endpoint_Bit x) (Endpoint_Bit y) e = (Endpoint_Bit z) where + z = qcdata_zip b q c q' c' x y e + qcdata_zip shape q c q' c' x y e = error errmsg where + errmsg = e "mismatching endpoint" + qcdata_promote ~(Endpoint_Qubit a) (Endpoint_Qubit x) e = Endpoint_Qubit z where + z = qcdata_promote a x e + qcdata_promote ~(Endpoint_Bit b) (Endpoint_Bit y) e = Endpoint_Bit z where + z = qcdata_promote b y e + +instance (QCData a) => QCData (Signed a) where + qcdata_mapM ~(Signed a _) f g ~(Signed x b) = do + x' <- qcdata_mapM a f g x + return (Signed x' b) + qcdata_zip ~(Signed a _) q c q' c' (Signed x1 b1) (Signed x2 b2) e = (Signed z b) where + z = qcdata_zip a q c q' c' x1 x2 e + b = if b1 == b2 then b1 else error (e "signs of controls do not match") + qcdata_promote ~(Signed a _) (Signed x b) e = (Signed x' b) where + x' = qcdata_promote a x e + +-- ---------------------------------------------------------------------- +-- Parameter types + +-- Parameter types (such as Int) are also instances of QCData. +-- These should be regarded as quantum types that are "all shape" and +-- "no qubits". + +-- Integers are parameters + +type instance QCType x y Integer = Integer + +type instance QTypeB Integer = Integer + +instance QCData Integer where + qcdata_mapM shape f g n = return n + qcdata_zip shape q c a' c' n m e + | n == m = n + | otherwise = error errmsg + where + errmsg = e "mismatching Integer parameter" + qcdata_promote a x e + | a == x = a + | otherwise = error errmsg + where + errmsg = e "mismatching Integer parameter" + +-- Ints are parameters + +type instance QCType x y Int = Int + +type instance QTypeB Int = Int + +instance QCData Int where + qcdata_mapM shape f g n = return n + qcdata_zip shape q c a' c' n m e + | n == m = n + | otherwise = error errmsg + where + errmsg = e "mismatching Int parameter" + qcdata_promote a x e + | a == x = a + | otherwise = error errmsg + where + errmsg = e "mismatching Int parameter" + +-- Doubles are parameters + +type instance QCType x y Double = Double + +type instance QTypeB Double = Double + +instance QCData Double where + qcdata_mapM shape f g n = return n + qcdata_zip shape q c a' c' n m e + | n == m = n + | otherwise = error errmsg + where + errmsg = e "mismatching Double parameter" + qcdata_promote a x e + | a == x = a + | otherwise = error errmsg + where + errmsg = e "mismatching Double parameter" + +-- Floats are parameters + +type instance QCType x y Float = Float + +type instance QTypeB Float = Float + +instance QCData Float where + qcdata_mapM shape f g n = return n + qcdata_zip shape q c a' c' n m e + | n == m = n + | otherwise = error errmsg + where + errmsg = e "mismatching Float parameter" + qcdata_promote a x e + | a == x = a + | otherwise = error errmsg + where + errmsg = e "mismatching Float parameter" + +-- Chars are parameters + +type instance QCType x y Char = Char + +type instance QTypeB Char = Char + +instance QCData Char where + qcdata_mapM shape f g n = return n + qcdata_zip shape q c a' c' n m e + | n == m = n + | otherwise = error errmsg + where + errmsg = e "mismatching Char parameter" + qcdata_promote a x e + | a == x = a + | otherwise = error errmsg + where + errmsg = e "mismatching Char parameter" + + +-- ---------------------------------------------------------------------- +-- ** The SimpleType class + +-- | 'SimpleType' is a subclass of 'QCData' consisting of simple +-- types. We say that a data type /t/ is \"simple\" if any two +-- elements of /t/ have the same number of leaves. For example, tuples +-- are simple, but lists are not. + +class QCData qc => SimpleType qc where + -- | Produce a term of the given shape. This term will contain + -- well-defined data constructors, but may be 'undefined' at the + -- leaves. + fs_shape :: qc + +instance SimpleType Qubit where + fs_shape = qubit + +instance SimpleType Bit where + fs_shape = bit + +instance SimpleType () where + fs_shape = () + +instance (SimpleType a, SimpleType b) => SimpleType (a,b) where + fs_shape = (fs_shape, fs_shape) + +instance (SimpleType a, SimpleType b, SimpleType c) => SimpleType (a,b,c) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d) => SimpleType (a,b,c,d) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e) => SimpleType (a,b,c,d,e) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f) => SimpleType (a,b,c,d,e,f) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g) => SimpleType (a,b,c,d,e,f,g) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h) => SimpleType (a,b,c,d,e,f,g,h) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h, SimpleType i) => SimpleType (a,b,c,d,e,f,g,h,i) where + fs_shape = tuple fs_shape + +instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h, SimpleType i, SimpleType j) => SimpleType (a,b,c,d,e,f,g,h,i,j) where + fs_shape = tuple fs_shape + +-- ====================================================================== +-- * Type conversions + +-- $ We define convenient abbreviations for conversions to, or +-- between, homogeneous types. + +-- | The type operator 'QType' converts a classical or heterogeneous +-- type to a homogeneous quantum type. More precisely, the type +-- 'QType' /a/ represents the substitution [nobr /a/ ['Qubit' \/ 'Bit']]. +-- It can be applied to both homogeneous and heterogeneous types, and +-- always yields a homogeneous type. For example: +-- +-- > QType (Bit, [Bit]) = (Qubit, [Qubit]) +-- > QType (Qubit, Bit) = (Qubit, Qubit) +type QType a = QCType Qubit Qubit a + +-- | The type operator 'CType' converts a classical or heterogeneous +-- type to a homogeneous quantum type. More precisely, the type +-- 'CType' /a/ represents the substitution [nobr /a/ ['Bit' \/ 'Qubit']]. It +-- can be applied to both homogeneous and heterogeneous types, and +-- always yields a homogeneous type. For example: +-- +-- > CType (Qubit, [Qubit]) = (Bit, [Bit]) +-- > CType (Qubit, Bit) = (Bit, Bit) +type CType a = QCType Bit Bit a + +-- | The type operator 'BType' converts a classical, quantum, or +-- heterogeneous type to a homogeneous boolean type. More precisely, +-- the type 'BType' /a/ represents the substitution +-- [nobr /a/ ['Bool' \/ 'Qubit', 'Bool' \/ 'Bit']]. It can be applied to +-- both homogeneous and heterogeneous types, and always yields a +-- homogeneous type. For example: +-- +-- > BType (Qubit, [Qubit]) = (Bool, [Bool]) +-- > BType (Qubit, Bit) = (Bool, Bool) +type BType a = QCType Bool Bool a + +-- | The type operator 'HType' /x/ converts a classical, quantum, or +-- boolean type to a homogeneous type with leaves /x/. More precisely, +-- the type 'HType' /x/ /a/ represents the substitution +-- [nobr /a/ [/x/ \/ 'Qubit', /x/ \/ 'Bit']]. +-- For example: +-- +-- > HType x (Qubit, [Qubit]) = (x, [x]) +-- > HType x (Qubit, Bit) = (x, x) +-- +-- There is a very subtle difference between 'HType' /x/ /a/ and +-- 'QCType' /x/ /x/ /a/. Although these two types are equal for all +-- /x/ and /a/, the type checker cannot actually prove that 'QCType' +-- /x/ /x/ /a/ is homogeneous from the assumption 'QCData' /a/. It +-- can, however, prove that 'HType' /x/ /a/ is homogeneous. Therefore +-- 'HType' (or the slightly more efficient special cases 'QType', +-- 'CType', 'BType') should always be used to create a homogeneous +-- type from a heterogeneous one. +type HType leaf qa = QCType leaf leaf (QType qa) + +-- | Construct the shape of a classical type. +--type CShape ca = HShape Bit ca + +-- ====================================================================== +-- * Shape parameters + +-- $ Several operations, such as 'qcdata_mapM' and 'qcdata_zip', +-- require a \"shape type parameter\". The purpose of such a parameter +-- is only to fix a type; its value is completely unused. +-- +-- [Introduction to shape type parameters] +-- +-- $ The need for shape type parameters arises when dealing with a +-- data structure whose leaves are of some arbitrary type, rather than +-- 'Qubit', 'Bit', or 'Bool'. For example, consider the data structure +-- +-- > [(1, 2), (3, 4)] +-- +-- This could be parsed in several different ways: +-- +-- * as a data structure [(/leaf/, /leaf/), (/leaf/, /leaf/)], where each leaf +-- is an integer; +-- +-- * as a data structure [/leaf/, /leaf/], where each leaf is a pair of +-- integers; +-- +-- * as a data structure /leaf/, where each leaf is a list of pairs of +-- integers. +-- +-- The purpose of a shape type is to disambiguate this situation. In +-- shape types, the type 'Qubit' (and sometimes 'Bit', in the case of +-- heterogeneous types) takes the place of a leaf. In the three +-- situations of the above example, the shape type would be [('Qubit', +-- 'Qubit')] in the first case; ['Qubit'] in the second case, the +-- 'Qubit' in the third case. +-- +-- [Difference between shape type parameters and shape term parameters] +-- +-- A shape type parameter exists only to describe a type; its value is +-- irrelevant and often undefined. A shape type parameter describes +-- the location of leaves in a type. On the other hand, the purpose of +-- a shape term parameter is used to fix the number and locations of +-- leaves in a data structure (for example, to fix the length of a +-- list). Shape term parameters are also often just called \"shape +-- parameters\" in Quipper. +-- +-- The distinction is perhaps best illustrated in an example. +-- A typical shape type parameter is +-- +-- > undefined :: (Qubit, [Qubit], [[Bit]]) +-- +-- A typical shape term parameter is +-- +-- > (qubit, [qubit, qubit, qubit], [[bit, bit], []]) :: (Qubit, [Qubit], [[Bit]]) +-- +-- Both of them have the same type. The shape type parameter specifies +-- that the data structure is a triple consisting of a qubit, a list +-- of qubits, and a list of lists of bits. The shape term parameter +-- moreover specifies that the first list consists of exactly three +-- qubits, and the second lists consists of a list of two bits and a +-- list of zero bits. +-- +-- Note that the value of the shape type parameter is undefined (we +-- often use the term 'dummy' instead of 'undefined', to get more +-- meaningful error messages). On the other hand, the value of the +-- shape term parameter is partially defined; only the /leaves/ are +-- of undefined value. +-- +-- [Functions for specifying shape type parameters] +-- +-- Since it is not possible, in Haskell, to pass a type as an argument +-- to a function, we provide some terms whose only purpose is to +-- represent types. All of them have value 'undefined'. Effectively, +-- a shape type parameter is a type \"written as a term\". +-- +-- The following terms can also be combined in data structures to +-- represent composite types. For example: +-- +-- > (qubit, [bit]) :: (Qubit, [Bit]) + +-- | A dummy term of any type. This term is 'undefined' and must never +-- be evaluated. Its only purpose is to hold a type. +dummy :: a +dummy = error "attempted evaluation of dummy term" + +-- | A dummy term of type 'Qubit'. It can be used in shape parameters +-- (e.g., 'Quipper.qc_init'), as well as shape type parameters (e.g., +-- 'qcdata_mapM'). +qubit :: Qubit +qubit = dummy + +-- | A dummy term of type 'Bit'. It can be used in shape parameters +-- (e.g., 'Quipper.qc_init'), as well as shape type parameters (e.g., +-- 'qcdata_mapM'). +bit :: Bit +bit = dummy + +-- | A dummy term of type 'Bool'. +bool :: Bool +bool = dummy + +-- | Convert a piece of homogeneous quantum data to a shape type +-- parameter. This is guaranteed to never evaluate /x/, and returns an +-- undefined value. +shapetype_q :: (QData qa) => QType qa -> qa +shapetype_q x = dummy + +-- | Convert a piece of homogeneous classical data to a shape type +-- parameter. This is guaranteed to never evaluate /x/, and returns an +-- undefined value. +shapetype_c :: (QData qa) => CType qa -> qa +shapetype_c x = dummy + +-- | Convert a piece of homogeneous boolean data to a shape type +-- parameter. This is guaranteed to never evaluate /x/, and returns an +-- undefined value. Do not confuse this with the function +-- 'Quipper.qshape', which creates a shape value. +shapetype_b :: (QData qa) => BType qa -> qa +shapetype_b x = dummy + +-- | A dummy term of the same type as the given term. If /x/ :: /a/, +-- then 'dummy' /x/ :: /a/. This is guaranteed not to evaluate /x/, +-- and returns an undefined value. +shape :: a -> a +shape x = dummy + +-- ====================================================================== +-- * Homogeneous types + +-- ---------------------------------------------------------------------- +-- ** The QData class + +-- $ The 'QData' type class contains homogeneous data types built up +-- from leaves of type 'Qubit'. It contains no methods; all of its +-- functionality is derived from 'QCData'. It does, however, contain +-- a number of equations that help the type checker figure out how to +-- convert heterogeneous type to homogeneous ones and vice versa. + +-- | The 'QData' type class contains homogeneous data types built up +-- from leaves of type 'Qubit'. +type QData qa = (qa ~ QType (CType qa), + qa ~ QTypeB (BType qa), + qa ~ QCType Qubit Bool qa, + qa ~ QType qa, + QCData qa, + QCData (CType qa)) + +-- ---------------------------------------------------------------------- +-- ** Derived combinators on QData + +-- $ This section provides several convenient combinators for the +-- 'QData' class. All of them are definable from those of +-- 'QCData'. + +-- | Map a function /f/ over all the leaves of a data structure. The +-- first argument is a dummy shape parameter: its value is ignored, but +-- its /type/ is used to determine the shape of the data to map over. +-- +-- Example (ignoring the monad for the sake of simplicity): +-- +-- > qdata_mapM (leaf, [leaf]) f (x,[y,z,w]) = (f x, [f y, f z, f w]). +-- +-- For data types that have a sense of direction, the mapping should +-- preferably be performed from left to right, but this property is +-- not guaranteed and may change without notice. +qdata_mapM :: (QData qa, Monad m) => qa -> (x -> m y) -> HType x qa -> m (HType y qa) +qdata_mapM qa f xa = qcdata_mapM qa f f xa where + +-- | Zip two data structures with leaf types /x/ and /y/ together, to +-- obtain a new data structure of the same shape with leaf type (/x/, +-- /y/). The first three arguments are dummy shape type parameters, representing +-- the shape type and the two leaf types, respectively. +-- +-- The 'ErrMsg' argument is a stub error message to be used in case +-- of failure. +qdata_zip :: (QData qa) => qa -> x -> y -> HType x qa -> HType y qa -> ErrMsg -> HType (x, y) qa +qdata_zip qa x y xs ys errmsg = qcdata_zip qa x x y y xs ys errmsg + +-- | Sometimes, it is possible to have a boolean parameter with some +-- aspect of its shape indeterminate. The function 'qdata_promote' +-- takes such a boolean parameter, as well as a piece of quantum data, +-- and sets the shape of the former to that of the latter. +-- +-- Indeterminate shapes can be used with certain operations, such as +-- controlling and terminating, where some aspect of the shape of the +-- parameter can be determined from the context in which it is +-- used. This is useful, e.g., for quantum integers, where one may +-- want to specify a control condition by an integer literal such as +-- 17, without having to specify the number of bits. Thus, we can +-- write, e.g., +-- +-- > gate `controlled` qi .==. 17 +-- +-- instead of the more cumbersome +-- +-- > gate `controlled` qi .==. (intm (qdint_length qi) 17). +-- +-- Another useful application of this arises in the use of infinite +-- lists of booleans (such as @['False'..]@), to specify a control +-- condition for a finite list of qubits. +-- +-- Because this function is used as a building block, we also pass +-- an error message to be used in case of failure. This will +-- hopefully make it clearer to the user which operation caused the +-- error. + +qdata_promote :: (QData qa) => BType qa -> qa -> ErrMsg -> BType qa +qdata_promote ba qa errmsg = qcdata_promote ba qa errmsg + +-- | The inverse of 'qdata_zip': Take a data structure with leaf type +-- (/x/, /y/), and return two data structures of the same shape with +-- leaf types /x/ and /y/, respectively. The first three arguments are +-- dummy shape type parameters, analogous to those of 'qdata_zip'. +qdata_unzip :: (QData s) => s -> x -> y -> HType (x, y) s -> (HType x s, HType y s) +qdata_unzip s (sx :: x) (c :: y) z = (x, y) where + x = qdata_map s (fst :: (x, y) -> x) z + y = qdata_map s (snd :: (x, y) -> y) z + +-- | Map a function over every leaf in a data structure. Non-monadic +-- version of 'qdata_mapM'. +qdata_map :: (QData s) => s -> (x -> y) -> HType x s -> HType y s +qdata_map shape f xs = + getId $ qdata_mapM shape (return . f) xs + +-- | Visit every leaf in a data structure, updating an accumulator. +qdata_fold :: (QData s) => s -> (x -> w -> w) -> HType x s -> w -> w +qdata_fold shape f xs w = + getId $ qdata_foldM shape (\x w -> return $ f x w) xs w + +-- | Map a function over every leaf in a data structure, while also +-- updating an accumulator. This combines the functionality of +-- 'qdata_fold' and 'qdata_map'. +qdata_fold_map :: (QData s) => s -> (x -> w -> (y, w)) -> HType x s -> w -> (HType y s, w) +qdata_fold_map shape f xs w = + getId $ qdata_fold_mapM shape (\x w -> return $ f x w) xs w + +-- | Monadic version of 'qdata_fold': Visit every leaf in a data +-- structure, updating an accumulator. +qdata_foldM :: (QData s, Monad m) => s -> (x -> w -> m w) -> HType x s -> w -> m w +qdata_foldM shape f xs w = do + (ys, w) <- qdata_fold_mapM shape f' xs w + return w + where + f' x w = do + w <- f x w + return ((), w) + +-- | Monadic version of 'qdata_fold_map': Map a function over every +-- leaf in a data structure, while also updating an accumulator. This +-- combines the functionality of 'qdata_foldM' and 'qdata_mapM'. +qdata_fold_mapM :: (QData s, Monad m) => s -> (x -> w -> m (y, w)) -> HType x s -> w -> m (HType y s, w) +qdata_fold_mapM shape f xs w = do + (ys, w) <- runStateT computation w + return (ys, w) + where + -- m' = StateT w m + computation = qdata_mapM shape map_leaf xs + map_leaf x = do + w <- get + (y, w') <- lift $ f x w + put w' + return y + +-- | Return a list of leaves of the given homogeneous data structure. +-- The first argument is a dummy shape type parameter, and is only used +-- for its type. +-- +-- The leaves are ordered in some deterministic, but arbitrary way. It +-- is guaranteed that when two data structures of the same shape type +-- and shape (same length of lists etc) are sequentialized, the leaves +-- will be ordered the same way. No other property of the order is +-- guaranteed, In particular, it might change without notice. +qdata_sequentialize :: (QData s) => s -> HType x s -> [x] +qdata_sequentialize shape xs = xlist where + blist = qdata_fold shape do_leaf xs blist_empty + xlist = list_of_blist blist + + do_leaf :: x -> BList x -> BList x + do_leaf x blist = blist +++ blist_of_list [x] + +-- | Take a specimen homogeneous data structure to specify the \"shape\" +-- desired (length of lists, etc); then reads the given list of leaves +-- in as a piece of homogeneous data of the same shape. The ordering +-- of the leaves is assumed to be the same as that which +-- 'qdata_sequentialize' produces for the given shape. +-- +-- A \"length mismatch\" error occurs if the list does not have +-- exactly the required length. +-- +-- Please note that, by contrast with the function +-- 'qdata_sequentialize', the first argument is a shape term +-- parameter, not a shape type parameter. It is used to decide where +-- the qubits should go in the data structure. +qdata_unsequentialize :: (QData s) => s -> [x] -> HType x s +qdata_unsequentialize shape xlist = xs where + xs = case qdata_fold_map shape do_leaf shape xlist of + (xs, []) -> xs + (xs, _) -> error "qdata_unsequentialize: length mismatch" + + -- first argument of do_leaf is dummy + do_leaf :: Qubit -> [x] -> (x, [x]) + do_leaf x (h:t) = (h, t) + do_leaf x [] = error "qdata_unsequentialize: length mismatch" + +-- | Combine a shape type argument /q/, a leaf type argument /a/, and +-- a shape size argument /x/ into a single shape argument /qx/. Note: +-- +-- * /q/ captures only the type, but not the size of the data. Only +-- the type of /q/ is used; its value can be undefined. This is +-- sufficient to determine the depth of leaves in a data structure, +-- but not their number. +-- +-- * /x/ captures only the size of the data, but not its type. In +-- particular, /x/ may have leaves of non-atomic types. /x/ must +-- consist of well-defined constructors up to the depth of leaves of +-- /q/, but the values at the actual leaves of /x/ may be undefined. +-- +-- * The output /qx/ combines the type of /q/ with the size of /x/, +-- and can therefore be used both as a shape type and a shape value. +-- Note that the actual leaves of /qx/ will be 'qubit' and 'bit', +-- which are synonyms for 'undefined'. +-- +-- Example: +-- +-- > q = undefined :: ([Qubit], [[Qubit]]) +-- > x = ([undefined, 0], [[undefined], [0, 1]]) +-- > qdata_makeshape qc a x = ([qubit, qubit], [[qubit], [qubit, qubit]]) +-- +-- where /a/ :: @Int@. +qdata_makeshape :: (QData qa) => qa -> a -> HType a qa -> qa +qdata_makeshape q (a::a) x = qdata_map q map_qubit x where + map_qubit = const qubit :: a -> Qubit + +-- | Like 'qdata_mapM', except the leaves are visited in exactly the +-- opposite order. This is used primarily for cosmetic reasons: For +-- example, when initializing a bunch of ancillas, and then +-- terminating them, the circuit will look more symmetric if they are +-- terminated in the opposite order. +qdata_mapM_op :: (QData s, Monad m) => s -> (x -> m y) -> HType x s -> m (HType y s) +qdata_mapM_op shapetype (f :: x -> m y) xs = do + let shapeterm = qdata_makeshape shapetype (dummy :: x) xs + let xlist = qdata_sequentialize shapeterm xs + ylist <- sequence_right [ f x | x <- xlist ] + let ys = qdata_unsequentialize shapeterm ylist + return ys + +-- | Like 'qdata_promote', except take a piece of classical data. +qdata_promote_c :: (QData s) => BType s -> CType s -> ErrMsg -> BType s +qdata_promote_c b c s = qdata_promote b q s where + q = qdata_map (shapetype_c c) map_qubit c + + map_qubit :: Bit -> Qubit + map_qubit = const qubit + +-- ---------------------------------------------------------------------- +-- ** The CData and BData classes + +-- | The 'CData' type class contains homogeneous data types built up +-- from leaves of type 'Bit'. +type CData ca = (QData (QType ca), CType (QType ca) ~ ca) + +-- | The 'BData' type class contains homogeneous data types built up +-- from leaves of type 'Bool'. +type BData ba = (QData (QTypeB ba), BType (QTypeB ba) ~ ba) + +-- ---------------------------------------------------------------------- +-- ** The QShape class + +-- $ By definition, 'QShape' /ba/ /qa/ /ca/ means that /ba/, /qa/, and +-- /ca/ are, respectively, boolean, quantum, and classical homogeneous +-- data types of the same common shape. The 'QShape' class directly +-- defined in terms of the 'QData' class. In fact, the two classes are +-- interchangeable in the following sense: +-- +-- > QShape ba qa ca implies QData qa, +-- +-- and conversely, +-- +-- > QData qa implies QShape (BType qa) qa (CType qa). +-- +-- Moreover, the functional dependencies @/ba/ -> /qa/, /qa/ -> /ca/, +-- /ca/ -> /ba/@ ensure that each of the three types determines the +-- other two. Therefore, in many ways, 'QShape' is just a convenient +-- notation for functionality already present in 'QData'. + +-- | The 'QShape' class allows the definition of generic functions that +-- can operate on quantum data of any \"shape\", for example, nested +-- tuples or lists of qubits. +-- +-- In general, there are three kinds of data: quantum inputs (such as +-- 'Qubit'), classical inputs (such as 'Bit'), and classical +-- parameters (such as 'Bool'). For example, a 'Qubit' can be +-- initialized from a 'Bool'; a 'Qubit' can be measured, resulting in +-- a 'Bit', etc. For this reason, the type class 'QShape' establishes a +-- relation between three types: +-- +-- [@qa@] A data structure having 'Qubit' at the leaves. +-- +-- [@ca@] A data structure of the same shape as @qa@, having 'Bit' at +-- the leaves. +-- +-- [@ba@] A data structure of the same shape as @qa@, having 'Bool' at +-- the leaves. +-- +-- Some functions input a classical parameter for the sole purpose of +-- establishing the \"shape\" of a piece of data. The shape refers to +-- qualities of a data structure, such as the length of a list, which +-- are not uniquely determined by the type. For example, two different +-- lists of length 5 have the same shape. When performing a generic +-- operation, such as reversing a circuit, it is often necessary to +-- specify the shape of the inputs, but not the actual inputs. +-- +-- In the common case where one only needs to declare one of the types +-- /qa/, /ca/, or /ba/, one of the simpler type classes 'QData', +-- 'CData', or 'BData' can be used. +type QShape ba qa ca = (QData qa, BType qa ~ ba, CType qa ~ ca) + +-- ====================================================================== +-- * Heterogeneous types + +-- $ A heterogeneous type describes a data structure built up from +-- leaves of type 'Qubit' and 'Bit'. Such types are used, for example, +-- to represent sets of endpoints in circuits, parameters to +-- subroutines and circuit building functions. A typical example is: +-- +-- > (Bit, Qubit, [Qubit]). + +-- ---------------------------------------------------------------------- +-- ** Derived combinators on QCData + +-- $ The 'QCData' type class only contains the three primitive +-- combinators 'qcdata_mapM', 'qcdata_zip', and 'qcdata_promote'. +-- Many other useful combinators are definable in terms of these, and +-- we provide several of them here. + +-- | The inverse of 'qcdata_zip': Take a data structure whose leaves +-- are pairs, and return two data structures of the same shape, +-- collecting all the left components and all the right components, +-- respectively. The first five arguments are shape type parameters, +-- analogous to those of 'qcdata_zip'. +qcdata_unzip :: (QCData qc) => qc -> q -> c -> q' -> c' -> QCType (q, q') (c, c') qc -> (QCType q c qc, QCType q' c' qc) +qcdata_unzip s (q :: q) (c :: c) (q' :: q') (c' :: c') z = (x, y) where + x = qcdata_map s (fst :: (q, q') -> q) (fst :: (c, c') -> c) z + y = qcdata_map s (snd :: (q, q') -> q') (snd :: (c, c') -> c') z + +-- | Map two functions /f/ and /g/ over the leaves of a heterogeneous +-- data structure. Apply /f/ to all the leaves at 'Qubit' positions, +-- and /g/ to all the leaves at 'Bit' positions. Non-monadic version +-- of 'qcdata_mapM'. +qcdata_map :: (QCData qc) => qc -> (q -> q') -> (c -> c') -> QCType q c qc -> QCType q' c' qc +qcdata_map shape f g xs = + getId $ qcdata_mapM shape (return . f) (return . g) xs + +-- | Visit every leaf in a data structure, updating an +-- accumulator. This function requires two accumulator functions /f/ +-- and /g/, to be used at 'Qubit' positions and 'Bit' positions, +-- respectively. +qcdata_fold :: (QCData qc) => qc -> (q -> w -> w) -> (c -> w -> w) -> QCType q c qc -> w -> w +qcdata_fold shape f g xs w = + getId $ qcdata_foldM shape (\x w -> return $ f x w) (\y w -> return $ g y w) xs w + +-- | Map a function over every leaf in a data structure, while also +-- updating an accumulator. This combines the functionality of +-- 'qcdata_fold' and 'qcdata_map'. +qcdata_fold_map :: (QCData qc) => qc -> (q -> w -> (q', w)) -> (c -> w -> (c', w)) -> QCType q c qc -> w -> (QCType q' c' qc, w) +qcdata_fold_map shape f g xs w = + getId $ qcdata_fold_mapM shape (\x w -> return $ f x w) (\x w -> return $ g x w) xs w + +-- | Monadic version of 'qcdata_fold': Visit every leaf in a data +-- structure, updating an accumulator. This function requires two +-- accumulator functions /f/ and /g/, to be used at 'Qubit' positions +-- and 'Bit' positions, respectively. +qcdata_foldM :: (QCData qc, Monad m) => qc -> (q -> w -> m w) -> (c -> w -> m w) -> QCType q c qc -> w -> m w +qcdata_foldM shape f g xs w = do + (ys, w) <- qcdata_fold_mapM shape (map_leaf f) (map_leaf g) xs w + return w + where + map_leaf :: (Monad m) => (x -> w -> m w) -> (x -> w -> m ((), w)) + map_leaf f x w = do + w <- f x w + return ((), w) + +-- | Monadic version of 'qcdata_fold_map': Map a function over every +-- leaf in a data structure, while also updating an accumulator. This +-- combines the functionality of 'qcdata_foldM' and 'qcdata_mapM'. +qcdata_fold_mapM :: (QCData qc, Monad m) => qc -> (q -> w -> m (q', w)) -> (c -> w -> m (c', w)) -> QCType q c qc -> w -> m (QCType q' c' qc, w) +qcdata_fold_mapM shape f g xs w = do + (ys, w) <- runStateT computation w + return (ys, w) + where + -- m' = StateT w m + computation = qcdata_mapM shape (map_leaf f) (map_leaf g) xs + + map_leaf :: (Monad m) => (a -> s -> m (b, s)) -> a -> StateT s m b + map_leaf f a = StateT (f a) + +-- | Return a list of leaves of the given heterogeneous data +-- structure. The first argument is a dummy shape type parameter, and +-- is only used for its type. Leaves in qubit positions and bit +-- positions are returned, respectively, as the left or right +-- components of a disjoint union. +-- +-- The leaves are ordered in some deterministic, but arbitrary way. It +-- is guaranteed that when two data structures of the same shape type +-- and shape (same length of lists etc) are sequentialized, the leaves +-- will be ordered the same way. No other property of the order is +-- guaranteed, In particular, it might change without notice. +qcdata_sequentialize :: (QCData qc) => qc -> QCType q c qc -> [B_Endpoint q c] +qcdata_sequentialize shape xs = xlist where + blist = qcdata_fold shape do_qubit do_bit xs blist_empty + xlist = list_of_blist blist + + do_qubit :: q -> BList (B_Endpoint q c) -> BList (B_Endpoint q c) + do_qubit q blist = blist +++ blist_of_list [Endpoint_Qubit q] + + do_bit :: c -> BList (B_Endpoint q c) -> BList (B_Endpoint q c) + do_bit c blist = blist +++ blist_of_list [Endpoint_Bit c] + +-- | Take a specimen heterogeneous data structure to specify the +-- \"shape\" desired (length of lists, etc); then reads the given list +-- of leaves in as a piece of heterogeneous data of the same +-- shape. The ordering of the leaves, and the division of the leaves +-- into qubit and bit positions, is assumed to be the same as that +-- which 'qcdata_sequentialize' produces for the given shape. +-- +-- A \"length mismatch\" error occurs if the list does not have +-- exactly the required length. A \"shape mismatch\" error occurs if +-- the list contains an 'Endpoint_Bit' entry corresponding to a +-- 'Qubit' position in the shape, or an 'Endpoint_Qubit' entry +-- corresponding to a 'Bit' position. +-- +-- Please note that, by contrast with the function +-- 'qcdata_sequentialize', the first argument is a shape term +-- parameter, not a shape type parameter. It is used to decide where +-- the qubits and bits should go in the data structure. +qcdata_unsequentialize :: (QCData qc) => qc -> [B_Endpoint q c] -> QCType q c qc +qcdata_unsequentialize shape xlist = xs where + xs = case qcdata_fold_map shape do_qubit do_bit shape xlist of + (xs, []) -> xs + (xs, _) -> error "qcdata_unsequentialize: length mismatch" + + -- first argument of do_qubit and do_bit is dummy + do_qubit :: Qubit -> [B_Endpoint q c] -> (q, [B_Endpoint q c]) + do_qubit x (Endpoint_Qubit h : t) = (h, t) + do_qubit x (Endpoint_Bit h : t) = error "qcdata_unsequentialize: shape mismatch" + do_qubit x [] = error "qcdata_unsequentialize: length mismatch" + + do_bit :: Bit -> [B_Endpoint q c] -> (c, [B_Endpoint q c]) + do_bit x (Endpoint_Bit h : t) = (h, t) + do_bit x (Endpoint_Qubit h : t) = error "qcdata_unsequentialize: shape mismatch" + do_bit x [] = error "qcdata_unsequentialize: length mismatch" + +-- | Combine a shape type argument /q/, two leaf type arguments /a/ +-- and /b/, and a shape size argument /x/ into a single shape argument +-- /qx/. Note: +-- +-- * /q/ captures only the type, but not the size of the data. Only +-- the type of /q/ is used; its value can be undefined. This is +-- sufficient to determine the depth of leaves in a data structure, +-- but not their number. +-- +-- * /x/ captures only the size of the data, but not its type. In +-- particular, /x/ may have leaves of non-atomic types. /x/ must +-- consist of well-defined constructors up to the depth of leaves of +-- /q/, but the values at the actual leaves of /x/ may be undefined. +-- +-- * The output /qx/ combines the type of /q/ with the size of /x/, +-- and can therefore be used both as a shape type and a shape value. +-- Note that the actual leaves of /qx/ will be 'qubit' and 'bit', +-- which are synonyms for 'undefined'. +-- +-- Example: +-- +-- > qc = undefined :: ([Qubit], [[Bit]]) +-- > x = ([undefined, (0,False)], [[undefined], [Just 2, Nothing]]) +-- > qcdata_makeshape qc a b x = ([qubit, qubit], [[bit], [bit, bit]]) +-- +-- where /a/ :: @(Int,Bool)@, /b/ :: @(Maybe Int)@. +qcdata_makeshape :: (QCData qc) => qc -> a -> b -> QCType a b qc -> qc +qcdata_makeshape q (a::a) (b::b) x = qcdata_map q map_qubit map_bit x where + map_qubit = const qubit :: a -> Qubit + map_bit = const bit :: b -> Bit + +-- | Like 'qcdata_mapM', except the leaves are visited in exactly the +-- opposite order. This is used primarily for cosmetic reasons: For +-- example, when initializing a bunch of ancillas, and then +-- terminating them, the circuit will look more symmetric if they are +-- terminated in the opposite order. +qcdata_mapM_op :: (QCData qc, Monad m) => qc -> (q -> m q') -> (c -> m c') -> QCType q c qc -> m (QCType q' c' qc) +qcdata_mapM_op shapetype (f :: q -> m q') (g :: c -> m c') xs = do + let shapeterm = qcdata_makeshape shapetype (dummy::q) (dummy::c) xs + let xlist = qcdata_sequentialize shapeterm xs + ylist <- sequence_right [ map_endpointM f g x | x <- xlist ] + let ys = qcdata_unsequentialize shapeterm ylist + return ys + where + map_endpointM f g (Endpoint_Qubit x) = do + x' <- f x + return (Endpoint_Qubit x') + map_endpointM f g (Endpoint_Bit y) = do + y' <- g y + return (Endpoint_Bit y') + +-- ---------------------------------------------------------------------- +-- ** The QCDataPlus class + +-- Implementation note: Since Haskell does not allow cyclic +-- dependencies in the definition of type classes, it was a +-- non-trivial problem to define 'QShape' and 'QCDataPlus' so that the +-- implications go both ways. We solved this problem by basing both +-- classes on QCData, together with a generous application of +-- equational reasoning. + +-- | The 'QCDataPlus' type class is almost identical to 'QCData', +-- except that it contains one additional piece of information that +-- allows the type checker to prove the implications +-- +-- > QCDataPlus qc implies QShape (BType qc) (QType qc) (CType qc) +-- > QCDataPlus qc implies QData (QType qc) +-- > QCDataPlus qc implies CData (CType qc) +-- > QCDataPlus qc implies BData (BType qc) +-- +-- This is sometimes useful, for example, in the context of a function +-- that inputs a 'QCData', measures all the qubits, and returns a +-- 'CData'. However, the additional information for the type checker +-- comes at a price, which is drastically increased compilation time. +-- Therefore 'QCDataPlus' should only be used when 'QCData' is +-- insufficient. + +type QCDataPlus qc = (QCData qc, QData (QType qc)) + +-- ---------------------------------------------------------------------- +-- ** Fixed size QCDataPlus + +-- | 'QCDataPlus_Simple' is a convenience type class that combines +-- 'QCDataPlus' and 'SimpleType'. +type QCData_Simple qc = (QCData qc, SimpleType qc) + +-- | 'QCDataPlus_Simple' is a convenience type class that combines +-- 'QCDataPlus' and 'SimpleType'. +type QCDataPlus_Simple qc = (QCDataPlus qc, SimpleType qc) + +-- Implementation note: We could just have made 'SimpleType' a +-- subclass of 'QCData' directly, but this would require the +-- type-checker to do lots of additional theorem proving, to the point +-- of overflowing the context stack and significantly slowing down +-- compilation. + +-- ---------------------------------------------------------------------- +-- ** The QCLeaf class + +-- | The class 'QCLeaf' consists of the two types 'Qubit' and 'Bit'. +-- It is primarily used for convenience, in those cases (such as the +-- arithmetic library) where some class instance should be defined for +-- the cases 'Qubit' and 'Bit', but not for general 'QCData'. It is +-- also used, e.g., in the definition of the 'Quipper.(./=.)' operator. +class (QCData q, + SimpleType q, + ControlSource q, + ControlSource (Signed q), + Labelable q String, + QCType Qubit Bit q ~ q, + QCType Bool Bool q ~ Bool) => QCLeaf q + +instance QCLeaf Qubit +instance QCLeaf Bit + +-- ---------------------------------------------------------------------- +-- ** Canonical string representation + +-- $ For the purpose of storing boxed subroutines, it is useful to +-- have a unique representation of 'QCData' shapes as strings. The +-- currently implementation relies on 'show' to give unique +-- representations. Therefore, when defining 'Show' instances for +-- 'QCData', one should make sure that the generated strings contain +-- enough information to recover both the type and the shape uniquely. + +-- | A type to represent a 'Qubit' leaf, for the sole purpose that +-- 'show' will show it as \"Q\". +data Qubit_Leaf = Qubit_Leaf +instance Show Qubit_Leaf where + show _ = "Q" + +-- | A type to represent a 'Bit' leaf, for the sole purpose that +-- 'show' will show it as \"C\". +data Bit_Leaf = Bit_Leaf +instance Show Bit_Leaf where + show _ = "C" + +-- | Turn any 'QCData' into a string uniquely identifying its type and +-- shape. The current implementation assumes that appropriately unique +-- 'Show' instances are defined for all 'QCData'. +canonical_shape :: (QCData qc) => qc -> String +canonical_shape qc = show $ qcdata_map qc do_qubit do_bit qc + where + do_qubit :: Qubit -> Qubit_Leaf + do_qubit q = Qubit_Leaf + + do_bit :: Bit -> Bit_Leaf + do_bit c = Bit_Leaf + +-- | The type operator 'LType' converts 'Qubit' to 'Qubit_Leaf' and +-- 'Bit' to 'Bit_Leaf'. +type LType a = QCType Qubit_Leaf Bit_Leaf a + +-- ====================================================================== +-- * Defining new QCData instances + +-- $ To define a new kind of quantum data, the following must be +-- defined: +-- +-- * A class instance of 'QCData', +-- +-- * a type instance of 'QCType', and +-- +-- * a type instance of 'QTypeB'. +-- +-- If the new type is simple, an class instance of 'SimpleType' should +-- also be defined. +-- +-- If the new type may be integrated with Template Haskell, a class +-- instance of 'Quipper.Internal.CircLifting.CircLiftingUnpack' should +-- also be defined. +-- +-- To ensure that circuit labeling will work for the new type, a class +-- instance of 'Labelable' must also be defined for every member of +-- 'QCData'. See "Quipper.Internal.Labels" for detailed instructions on how to +-- do so. +-- +-- Modules that define new kinds of quantum data should import +-- "Quipper.Internal". diff --git a/Quipper/Internal/Transformer.hs b/Quipper/Internal/Transformer.hs new file mode 100644 --- /dev/null +++ b/Quipper/Internal/Transformer.hs @@ -0,0 +1,618 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module provides functions for defining general-purpose +-- transformations on low-level circuits. The uses of this include: +-- +-- * gate transformations, where a whole circuit is transformed by +-- replacing each kind of gate with another gate or circuit; +-- +-- * error correcting codes, where a whole circuit is transformed +-- replacing each qubit by some fixed number of qubits, and each gate +-- by a circuit; and +-- +-- * simulations, where a whole circuit is mapped to a semantic +-- function by specifying a semantic function for each gate. +-- +-- The interface is designed to allow the programmer to specify new +-- transformers easily. To define a specific transformation, the +-- programmer has to specify only four pieces of information: +-- +-- * A type /a/=⟦Qubit⟧, to serve as a semantic domain for qubits. +-- +-- * A type /b/=⟦Bit⟧, to serve as a semantic domain for bits. +-- +-- * A monad /m/. This is to allow translations to have side effects +-- if desired; one can use the identity monad otherwise. +-- +-- * For every gate /G/, a corresponding semantic function ⟦/G/⟧. The +-- type of this function depends on what kind of gate /G/ is. For example: +-- +-- @ +-- If /G/ :: Qubit -> Circ Qubit, then ⟦/G/⟧ :: /a/ -> /m/ /a/. +-- If /G/ :: (Qubit, Bit) -> Circ (Bit, Bit), then ⟦/G/⟧ :: (/a/, /b/) -> /m/ (/b/, /b/). +-- @ +-- +-- The programmer provides this information by defining a function of +-- type 'Transformer' /m/ /a/ /b/. See <#Transformers> below. Once a +-- particular transformer has been defined, it can then be applied to +-- entire circuits. For example, for a circuit with 1 inputs and 2 +-- outputs: +-- +-- @ +-- If /C/ :: Qubit -> (Bit, Qubit), then ⟦/C/⟧ :: /a/ -> /m/ (/b/, /a/). +-- @ + +-- ---------------------------------------------------------------------- +-- Grammar note for developers: a "transformer" does a +-- "transformation" by "transforming" gates. We use "transform" as a +-- verb, "transformation" to describe the process of transforming, and +-- "transformer" for the code that describes or does the transformation. +-- +-- I had initially used the words "iteration", "translation", +-- "transform", "transformation", "interpretation", and "semantics" +-- interchangeably, which was a huge linguistic mess. + +module Quipper.Internal.Transformer where + +-- import other Quipper stuff +import Quipper.Internal.Circuit +import Quipper.Utils.Auxiliary + +-- import other stuff +import Control.Monad +import Control.Monad.State +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.IntMap as IntMap +import Data.Typeable + +-- ====================================================================== +-- * An example transformer +-- +-- $EXAMPLE +-- +-- The following is a short but complete example of how to write and +-- use a simple transformer. As usual, we start by importing Quipper: +-- +-- > import Quipper +-- +-- We will write a transformer called @sample_transformer@, which maps +-- every swap gate to a sequence of three controlled-not gates, and +-- leaves all other gates unchanged. For convenience, Quipper +-- pre-defines an 'Quipper.identity_transformer', which can be used as +-- a catch-all clause to take care of all the gates that don't need to +-- be rewritten. +-- +-- > mytransformer :: Transformer Circ Qubit Bit +-- > mytransformer (T_QGate "swap" 2 0 _ ncf f) = f $ +-- > \[q0, q1] [] ctrls -> do +-- > without_controls_if ncf $ do +-- > with_controls ctrls $ do +-- > qnot_at q0 `controlled` q1 +-- > qnot_at q1 `controlled` q0 +-- > qnot_at q0 `controlled` q1 +-- > return ([q0, q1], [], ctrls) +-- > mytransformer g = identity_transformer g +-- +-- Note how Quipper syntax has been used to define the replacement +-- circuit, consisting of three controlled-not gates. Also, since the +-- original swap gate may have been controlled, we have added the +-- additional controls with a 'Quipper.with_controls' operator. +-- +-- To try this out, we define some random circuit using swap gates: +-- +-- > mycirc a b c d = do +-- > swap_at a b +-- > hadamard_at b +-- > swap_at b c `controlled` [a, d] +-- > hadamard_at c +-- > swap_at c d +-- +-- To apply the transformer to this circuit, we use the generic +-- operator 'Quipper.transform_generic': +-- +-- > mycirc2 = transform_generic mytransformer mycirc +-- +-- Finally, we use a @main@ function to display the original circuit +-- and then the transformed one: +-- +-- > main = do +-- > print_simple Preview mycirc +-- > print_simple Preview mycirc2 + +-- ====================================================================== +-- * Bindings + +-- $bindings +-- +-- We introduce the notion of a /binding/ as a low-level way to +-- describe functions of varying arities. A binding assigns a value to +-- a wire in a circuit (much like a \"valuation\" in logic or semantics +-- assigns values to variables). +-- +-- To iterate through a circuit, one will typically specify initial +-- bindings for the input wires. This encodes the input of the function +-- ⟦/C/⟧ mentioned in the introduction. The bindings are updated as +-- one passes through each gate. When the iteration is finished, the +-- final bindings assign a value to each output wire of the +-- circuit. This encodes the output of the function ⟦/C/⟧. Therefore, +-- the interpretation of a circuit is representable as a function from +-- bindings (of input wires) to bindings (of output wires), i.e., it +-- has the type ⟦/C/⟧ :: 'Bindings' /a/ /b/ -> 'Bindings' /a/ /b/. + +-- | An /endpoint/ is either a /qubit/ or a /bit/. In a transformer, +-- we have ⟦B_Endpoint Qubit Bit⟧ = ⟦Qubit⟧ + ⟦Bit⟧. The type 'B_Endpoint' +-- /a/ /b/ is the same as 'Either' /a/ /b/, but we use more suggestive +-- field names. +data B_Endpoint a b = + Endpoint_Qubit a + | Endpoint_Bit b + deriving (Eq, Ord, Typeable, Show) + +-- | A binding is a map from a set of wires to the disjoint union of +-- /a/ and /b/. +type Bindings a b = Map Wire (B_Endpoint a b) + +-- | Return the list of bound wires from a binding. +wires_of_bindings :: Bindings a b -> [Wire] +wires_of_bindings = Map.keys + +-- | The empty binding. +bindings_empty :: Bindings a b +bindings_empty = Map.empty + +-- | Bind a wire to a value, and add it to the given bindings. +bind :: Wire -> B_Endpoint a b -> Bindings a b -> Bindings a b +bind r x bindings = Map.insert r x bindings + +-- | Bind a qubit wire to a value, and add it to the given bindings. +bind_qubit_wire :: Wire -> a -> Bindings a b -> Bindings a b +bind_qubit_wire r x bindings = bind r (Endpoint_Qubit x) bindings + +-- | Bind a bit wire to a value, and add it to the given bindings. +bind_bit_wire :: Wire -> b -> Bindings a b -> Bindings a b +bind_bit_wire r x bindings = bind r (Endpoint_Bit x) bindings + +-- | Retrieve the value of a wire from the given bindings. +unbind :: Bindings a b -> Wire -> B_Endpoint a b +unbind bindings w = case Map.lookup w bindings of + Nothing -> error ("unbind: wire (" ++ show w ++ ") not in bindings: " ++ show (wires_of_bindings bindings)) + Just a -> a + +-- | Retrieve the value of a qubit wire from the given bindings. +-- Throws an error if the wire was bound to a classical bit. +unbind_qubit_wire :: Bindings a b -> Wire -> a +unbind_qubit_wire bindings w = + case unbind bindings w of + Endpoint_Qubit x -> x + Endpoint_Bit x -> error "Transformer error: expected a qubit, got a bit" + +-- | Retrieve the value of a bit wire from the given bindings. +-- Throws an error if the wire was bound to a qubit. +unbind_bit_wire :: Bindings a b -> Wire -> b +unbind_bit_wire bindings w = + case unbind bindings w of + Endpoint_Bit x -> x + Endpoint_Qubit x -> error "Transformer error: expected a bit, got a qubit" + +-- | Delete a wire from the given bindings. +bind_delete :: Wire -> Bindings a b -> Bindings a b +bind_delete r bindings = Map.delete r bindings + +-- | Like 'bind', except bind a list of wires to a list of values. The +-- lists must be of the same length. +bind_list :: [Wire] -> [B_Endpoint a b] -> Bindings a b -> Bindings a b +bind_list ws xs bindings = + foldr (\ (w, x) -> bind w x) bindings (zip ws xs) + +-- | Like 'bind_qubit_wire', except bind a list of qubit wires to a list of +-- values. The lists must be of the same length. +bind_qubit_wire_list :: [Wire] -> [a] -> Bindings a b -> Bindings a b +bind_qubit_wire_list ws xs bindings = + foldr (\ (w, x) -> bind_qubit_wire w x) bindings (zip ws xs) + +-- | Like 'bind_bit_wire', except bind a list of bit wires to a list of +-- values. The lists must be of the same length. +bind_bit_wire_list :: [Wire] -> [b] -> Bindings a b -> Bindings a b +bind_bit_wire_list ws xs bindings = + foldr (\ (w, x) -> bind_bit_wire w x) bindings (zip ws xs) + +-- | Like 'unbind', except retrieve a list of values. +unbind_list :: Bindings a b -> [Wire] -> [B_Endpoint a b] +unbind_list bindings ws = + map (unbind bindings) ws + +-- | Like 'unbind_qubit_wire', except retrieve a list of values. +unbind_qubit_wire_list :: Bindings a b -> [Wire] -> [a] +unbind_qubit_wire_list bindings ws = + map (unbind_qubit_wire bindings) ws + +-- | Like 'unbind_bit_wire', except retrieve a list of values. +unbind_bit_wire_list :: Bindings a b -> [Wire] -> [b] +unbind_bit_wire_list bindings ws = + map (unbind_bit_wire bindings) ws + +-- | A list of signed values of type ⟦B_Endpoint⟧. This type is an +-- abbreviation defined for convenience. +type Ctrls a b = [Signed (B_Endpoint a b)] + +-- | Given a list of signed wires (controls), and a list of signed +-- values, make a bindings from the wires to the values. Ignore the signs. +bind_controls :: Controls -> Ctrls a b -> Bindings a b -> Bindings a b +bind_controls controls xs bindings = + bind_list (map from_signed controls) (map from_signed xs) bindings + +-- | Like 'unbind', but retrieve binding for all wires in a list of +-- controls. +unbind_controls :: Bindings a b -> Controls -> Ctrls a b +unbind_controls bindings c = + [Signed (unbind bindings w) b | Signed w b <- c ] + +-- $transformers_anchor #Transformers# + +-- ---------------------------------------------------------------------- +-- * Transformers + +-- $transformers +-- +-- The types 'T_Gate' and 'Transformer' are at the heart of the +-- circuit transformer functionality. Their purpose is to give a +-- concise syntax in which to express semantic functions for gates. As +-- mentioned in the introduction, the programmer needs to specify two +-- type /a/ and /b/, a monad /m/, and a semantic function for each +-- gate. With the T_Gate' and 'Transformer' types, the definition +-- takes the following form: +-- +-- > my_transformer :: Transformer m a b +-- > my_transformer (T_Gate1 f) = f $ +-- > my_transformer (T_Gate2 f) = f $ +-- > my_transformer (T_Gate3 f) = f $ +-- > ... +-- +-- The type 'T_Gate' is very higher-order, involving a function /f/ +-- that consumes the semantic function for each gate. The reason for +-- this higher-orderness is that the semantic functions for different +-- gates may have different types. +-- +-- This higher-orderness makes the 'T_Gate' mechanism hard to read, +-- but easy to use. Effectively we only have to write lengthy and +-- messy code once and for all, rather than once for each transformer. +-- In particular, all the required low-level bindings and unbindings +-- can be handled by general-purpose code, and do not need to clutter +-- each transformer. + +-- | The type 'T_Gate' is used to define case distinctions over gates +-- in the definition of transformers. For each kind of gate /X/, it +-- contains a constructor of the form @(T_X f)@. Here, /X/ identifies +-- the gate, and /f/ is a higher-order function to pass the +-- translation of /X/ to. + +-- Implementation note: in the future, perhaps we can also add two +-- variants of this type: one that is specialized to the "simple" +-- case, where the semantics functions are assumed not to modify the +-- controls; another that is specialized to m = Id. This would make +-- the definition of most circuit transformers look less cluttered. + +data T_Gate m a b x = + T_QGate String Int Int InverseFlag NoControlFlag (([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> x) + | T_QRot String Int Int InverseFlag Timestep NoControlFlag (([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> x) + | T_GPhase Double NoControlFlag (([B_Endpoint a b] -> Ctrls a b -> m (Ctrls a b)) -> x) + | T_CNot NoControlFlag ((b -> Ctrls a b -> m (b, Ctrls a b)) -> x) + | T_CGate String NoControlFlag (([b] -> m (b, [b])) -> x) + | T_CGateInv String NoControlFlag ((b -> [b] -> m [b]) -> x) + | T_CSwap NoControlFlag ((b -> b -> Ctrls a b -> m (b, b, Ctrls a b)) -> x) + | T_QPrep NoControlFlag ((b -> m a) -> x) + | T_QUnprep NoControlFlag ((a -> m b) -> x) + | T_QInit Bool NoControlFlag (m a -> x) + | T_CInit Bool NoControlFlag (m b -> x) + | T_QTerm Bool NoControlFlag ((a -> m ()) -> x) + | T_CTerm Bool NoControlFlag ((b -> m ()) -> x) + | T_QMeas ((a -> m b) -> x) + | T_QDiscard ((a -> m ()) -> x) + | T_CDiscard ((b -> m ()) -> x) + | T_DTerm Bool ((b -> m ()) -> x) + | T_Subroutine BoxId InverseFlag NoControlFlag ControllableFlag [Wire] Arity [Wire] Arity RepeatFlag ((Namespace -> [B_Endpoint a b] -> Ctrls a b -> m ([B_Endpoint a b], Ctrls a b)) -> x) + | T_Comment String InverseFlag (([(B_Endpoint a b, String)] -> m ()) -> x) + +-- Make 'T_Gate' an instance of 'Show', to enable transformers to +-- produce better error messages about unimplemented gates etc. +instance Show (T_Gate m a b x) where + show (T_QGate name n m inv ncf f) = "QGate[" ++ name ++ "," ++ show n ++ "," ++ show m ++ "]" ++ optional inv "*" + show (T_QRot name n m inv t ncf f) = "QRot[" ++ name ++ "," ++ show t ++ "," ++ show n ++ "," ++ show m ++ "]" ++ optional inv "*" + show (T_GPhase t ncf f) = "GPhase[" ++ show t ++ "]" + show (T_CNot ncf f) = "CNot" + show (T_CGate n ncf f) = "CGate[" ++ n ++ "]" + show (T_CGateInv n ncf f) = "CGate[" ++ n ++ "]*" + show (T_CSwap ncf f) = "CSwap" + show (T_QPrep ncf f) = "QPrep" + show (T_QUnprep ncf f) = "QUnprep" + show (T_QInit b ncf f) = "QInit" ++ if b then "1" else "0" + show (T_CInit b ncf f) = "CInit" ++ if b then "1" else "0" + show (T_QTerm b ncf f) = "QTerm" ++ if b then "1" else "0" + show (T_CTerm b ncf f) = "CTerm" ++ if b then "1" else "0" + show (T_QMeas f) = "QMeas" + show (T_QDiscard f) = "QDiscard" + show (T_CDiscard f) = "CDiscard" + show (T_DTerm b f) = "DTerm" ++ if b then "1" else "0" + show (T_Subroutine n inv ncf scf ws a1 vs a2 rep f) = "Subroutine(x" ++ (show rep) ++ ")[" ++ show n ++ "]" ++ optional inv "*" + show (T_Comment n inv f) = "Comment[" ++ n ++ "]" ++ optional inv "*" + +-- | A circuit transformer is specified by defining a function of type +-- 'Transformer' /m/ /a/ /b/. This involves specifying a monad /m/, +-- semantic domains /a/=⟦Qubit⟧ and /b/=⟦Bit⟧, and a semantic function +-- for each gate, like this: +-- +-- > my_transformer :: Transformer m a b +-- > my_transformer (T_Gate1 f) = f $ +-- > my_transformer (T_Gate2 f) = f $ +-- > my_transformer (T_Gate3 f) = f $ +-- > ... + +-- Implementation note: the use of \"forall\" in this type is to allow +-- some freedom in the return type of the continuation 'f' in the +-- definition of 'T_Gate'. This makes it easier, for example, to +-- compose transformers with other transformers. The use of \"forall\" +-- implies that any module that uses the 'Transformer' type may have +-- to declare the @Rank2Types@ language extension. This was not +-- required in GHC 7.4, but seems to be required in GHC 7.6. +type Transformer m a b = forall x . T_Gate m a b x -> x + +-- | A \"binding transformer\" is a function from bindings to +-- bindings. The semantics of any gate or circuit is ultimately a +-- binding transformer, for some types /a/, /b/ and some monad /m/. We +-- introduce an abbreviation for this type primarily as a convenience +-- for the definition of 'bind_gate', but also because this type can +-- be completely hidden from user code. +type BT m a b = Bindings a b -> m (Bindings a b) + +-- | Turn a 'Gate' into a 'T_Gate'. This is the function that actually +-- handles the explicit bindings/unbindings required for the inputs +-- and outputs of each gate. Effectively it gives a way, for each +-- gate, of turning a semantic function into a binding transformer. +-- Additionally, this function is passed a Namespace, so that the +-- semantic function for T_Subroutine can use it. +bind_gate :: Monad m => Namespace -> Gate -> T_Gate m a b (BT m a b) +bind_gate namespace gate = case gate of + QGate name inv ws vs c ncf -> T_QGate name n m inv ncf (list_binary ws vs c) + where + n = length ws + m = length vs + QRot name inv t ws vs c ncf -> T_QRot name n m inv t ncf (list_binary ws vs c) + where + n = length ws + m = length vs + GPhase t w c ncf -> T_GPhase t ncf (phase_ary w c) + CNot w c ncf -> T_CNot ncf (cunary w c) + CGate n w vs ncf -> T_CGate n ncf (cgate_ary w vs) + CGateInv n w vs ncf -> T_CGateInv n ncf (cgateinv_ary w vs) + CSwap w v c ncf -> T_CSwap ncf (binary_c w v c) + QPrep w ncf -> T_QPrep ncf (qprep_ary w) + QUnprep w ncf -> T_QUnprep ncf (qunprep_ary w) + QInit b w ncf -> T_QInit b ncf (qinit_ary w) + CInit b w ncf -> T_CInit b ncf (cinit_ary w) + QTerm b w ncf -> T_QTerm b ncf (qterm_ary w) + CTerm b w ncf -> T_CTerm b ncf (cterm_ary w) + QMeas w -> T_QMeas (qunprep_ary w) + QDiscard w -> T_QDiscard (qterm_ary w) + CDiscard w -> T_CDiscard (cterm_ary w) + DTerm b w -> T_DTerm b (cterm_ary w) + Subroutine n inv ws a1 vs a2 c ncf scf rep + -> T_Subroutine n inv ncf scf ws a1 vs a2 rep + (\f -> subroutine_ary ws vs c (f namespace)) + Comment s inv ws -> T_Comment s inv (comment_ary ws) + where + unary :: Monad m => Wire -> Controls -> (a -> Ctrls a b -> m (a, Ctrls a b)) -> BT m a b + unary w c f bindings = do + let w' = unbind_qubit_wire bindings w + let c' = unbind_controls bindings c + (w'', c'') <- f w' c' + let bindings1 = bind_qubit_wire w w'' bindings + let bindings2 = bind_controls c c'' bindings1 + return bindings2 + + binary :: Monad m => Wire -> Wire -> Controls -> (a -> a -> Ctrls a b -> m (a, a, Ctrls a b)) -> BT m a b + binary w v c f bindings = do + let w' = unbind_qubit_wire bindings w + let v' = unbind_qubit_wire bindings v + let c' = unbind_controls bindings c + (w'', v'', c'') <- f w' v' c' + let bindings1 = bind_qubit_wire w w'' bindings + let bindings2 = bind_qubit_wire v v'' bindings1 + let bindings3 = bind_controls c c'' bindings2 + return bindings3 + + binary_c :: Monad m => Wire -> Wire -> Controls -> (b -> b -> Ctrls a b -> m (b, b, Ctrls a b)) -> BT m a b + binary_c w v c f bindings = do + let w' = unbind_bit_wire bindings w + let v' = unbind_bit_wire bindings v + let c' = unbind_controls bindings c + (w'', v'', c'') <- f w' v' c' + let bindings1 = bind_bit_wire w w'' bindings + let bindings2 = bind_bit_wire v v'' bindings1 + let bindings3 = bind_controls c c'' bindings2 + return bindings3 + + list_unary :: Monad m => [Wire] -> Controls -> ([a] -> Ctrls a b -> m ([a], Ctrls a b)) -> BT m a b + list_unary ws c f bindings = do + let ws' = unbind_qubit_wire_list bindings ws + let c' = unbind_controls bindings c + (ws'', c'') <- f ws' c' + let bindings1 = bind_qubit_wire_list ws ws'' bindings + let bindings2 = bind_controls c c'' bindings1 + return bindings2 + + list_binary :: Monad m => [Wire] -> [Wire] -> Controls -> ([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> BT m a b + list_binary ws vs c f bindings = do + let ws' = unbind_qubit_wire_list bindings ws + let vs' = unbind_qubit_wire_list bindings vs + let c' = unbind_controls bindings c + (ws'', vs'', c'') <- f ws' vs' c' + let bindings1 = bind_qubit_wire_list ws ws'' bindings + let bindings2 = bind_qubit_wire_list vs vs'' bindings1 + let bindings3 = bind_controls c c'' bindings2 + return bindings3 + + qprep_ary :: Monad m => Wire -> (b -> m a) -> BT m a b + qprep_ary w f bindings = do + let w' = unbind_bit_wire bindings w + w'' <- f w' + let bindings1 = bind_qubit_wire w w'' bindings + return bindings1 + + qunprep_ary :: Monad m => Wire -> (a -> m b) -> BT m a b + qunprep_ary w f bindings = do + let w' = unbind_qubit_wire bindings w + w'' <- f w' + let bindings1 = bind_bit_wire w w'' bindings + return bindings1 + + cunary :: Monad m => Wire -> Controls -> (b -> Ctrls a b -> m (b, Ctrls a b)) -> BT m a b + cunary w c f bindings = do + let w' = unbind_bit_wire bindings w + let c' = unbind_controls bindings c + (w'', c'') <- f w' c' + let bindings1 = bind_bit_wire w w'' bindings + let bindings2 = bind_controls c c'' bindings1 + return bindings2 + + qinit_ary :: Monad m => Wire -> m a -> BT m a b + qinit_ary w f bindings = do + w'' <- f + let bindings1 = bind_qubit_wire w w'' bindings + return bindings1 + + cinit_ary :: Monad m => Wire -> m b -> BT m a b + cinit_ary w f bindings = do + w'' <- f + let bindings1 = bind_bit_wire w w'' bindings + return bindings1 + + qterm_ary :: Monad m => Wire -> (a -> m ()) -> BT m a b + qterm_ary w f bindings = do + let w' = unbind_qubit_wire bindings w + () <- f w' + let bindings1 = bind_delete w bindings + return bindings1 + + cterm_ary :: Monad m => Wire -> (b -> m ()) -> BT m a b + cterm_ary w f bindings = do + let w' = unbind_bit_wire bindings w + () <- f w' + let bindings1 = bind_delete w bindings + return bindings1 + + cgate_ary :: Monad m => Wire -> [Wire] -> ([b] -> m (b, [b])) -> BT m a b + cgate_ary w vs f bindings = do + let vs' = unbind_bit_wire_list bindings vs + (w'', vs'') <- f vs' + let bindings1 = bind_bit_wire w w'' bindings + let bindings2 = bind_bit_wire_list vs vs'' bindings1 + return bindings2 + + cgateinv_ary :: Monad m => Wire -> [Wire] -> (b -> [b] -> m [b]) -> BT m a b + cgateinv_ary w vs f bindings = do + let vs' = unbind_bit_wire_list bindings vs + let w' = unbind_bit_wire bindings w + vs'' <- f w' vs' + let bindings1 = bind_bit_wire_list vs vs'' bindings + return bindings1 + + subroutine_ary :: Monad m => [Wire] -> [Wire] -> Controls + -> ([B_Endpoint a b] -> Ctrls a b -> m ([B_Endpoint a b], Ctrls a b)) + -> BT m a b + subroutine_ary ws vs c f bindings = do + let c' = unbind_controls bindings c + let ws' = unbind_list bindings ws + (vs'',c'') <- f ws' c' + let bindings1 = bind_list vs vs'' bindings + let bindings2 = bind_controls c c'' bindings1 + return bindings2 + + phase_ary :: Monad m => [Wire] -> Controls -> ([B_Endpoint a b] -> Ctrls a b -> m (Ctrls a b)) -> BT m a b + phase_ary w c f bindings = do + let w' = map (unbind bindings) w + let c' = unbind_controls bindings c + c'' <- f w' c' + let bindings1 = bind_controls c c'' bindings + return bindings1 + + comment_ary :: Monad m => [(Wire, String)] -> (([(B_Endpoint a b, String)] -> m ()) -> BT m a b) + comment_ary ws f bindings = do + let ws' = zip (unbind_list bindings $ map fst ws) (map snd ws) + f ws' + return bindings + +-- ---------------------------------------------------------------------- +-- * Applying transformers to circuits + +-- | Apply a 'Transformer' ⟦-⟧ to a 'Circuit' /C/, and output the +-- semantic function ⟦/C/⟧ :: bindings -> bindings. +transform_circuit :: Monad m => Transformer m a b -> Circuit -> Bindings a b -> m (Bindings a b) +transform_circuit transformer c bindings = + foldM apply bindings gs + where + (_,gs,_,_) = c + apply bindings g = transformer (bind_gate namespace_empty g) bindings + +-- | Like 'transform_circuit', but for boxed circuits. +-- +-- The handling of subroutines will depend on the transformer. +-- For \"gate transformation\" types of applications, one typically +-- would like to leave the boxed structure intact. +-- For \"simulation\" types of applications, one would generally +-- recurse through the boxed structure. +-- +-- The difference is specified in the definition of the transformer +-- within the semantic function of the Subroutine gate, whether to +-- create another boxed gate or open the box. +transform_bcircuit_rec :: Monad m => Transformer m a b -> BCircuit -> Bindings a b -> m (Bindings a b) +transform_bcircuit_rec transformer (c,namespace) bindings = + foldM apply bindings gs + where + (_,gs,_,_) = c + apply bindings g = transformer (bind_gate namespace g) bindings + +-- | Same as 'transform_bcircuit_rec', but specialized to when /m/ is +-- the identity operation. +transform_bcircuit_id :: Transformer Id a b -> BCircuit -> Bindings a b -> Bindings a b +transform_bcircuit_id t c b = getId (transform_bcircuit_rec t c b) + +-- | To transform Dynamic Boxed circuits, we require a Transformer to define the +-- behavior on static gates, but we also require functions for what to do when +-- a subroutine is defined, and for when a dynamic_lift operation occurs. This is +-- all wrapped in the DynamicTransformer data type. +data DynamicTransformer m a b = DT { + transformer :: Transformer m a b, + define_subroutine :: BoxId -> TypedSubroutine -> m (), + lifting_function :: b -> m Bool + } + +-- | Like 'transform_bcircuit_rec', but for dynamic-boxed circuits. +-- +-- \"Write\" operations can be thought of as gates, and so they are passed to +-- the given transformer. The handling of \"Read\" operations is taken care of +-- by the \"lifting_function\" of the DynamicTransformer. \"Subroutine\" operations +-- call the 'define_subroutine' function of the DynamicTransformer. +transform_dbcircuit :: Monad m => DynamicTransformer m a b -> DBCircuit x -> Bindings a b -> m (x,Bindings a b) +transform_dbcircuit dt (a0,rw) bindings = evalStateT (inner_transform dt (a0,rw) bindings) namespace_empty where + inner_transform :: Monad m => DynamicTransformer m a b -> DBCircuit x -> Bindings a b -> (StateT Namespace m) (x,Bindings a b) + inner_transform dt (a0,rw) bindings = + case rw of + (RW_Return (_,_,x)) -> return (x,bindings) + (RW_Write gate rw') -> do + namespace <- get + bindings' <- lift $ (transformer dt) (bind_gate namespace gate) bindings + inner_transform dt (a0,rw') bindings' + (RW_Read wire rw_cont) -> do + let bit = unbind_bit_wire bindings wire + bool <- lift $ (lifting_function dt) bit + let rw' = rw_cont bool + inner_transform dt (a0,rw') bindings + (RW_Subroutine name subroutine rw') -> do + lift $ (define_subroutine dt) name subroutine + namespace <- get + let namespace' = map_provide name subroutine namespace + put namespace' + inner_transform dt (a0,rw') bindings diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Superdoc +main = superdocMain diff --git a/images/CosetState.png b/images/CosetState.png new file mode 100644 Binary files /dev/null and b/images/CosetState.png differ diff --git a/images/E.png b/images/E.png new file mode 100644 Binary files /dev/null and b/images/E.png differ diff --git a/images/ERot_phase.png b/images/ERot_phase.png new file mode 100644 Binary files /dev/null and b/images/ERot_phase.png differ diff --git a/images/ERot_zx.png b/images/ERot_zx.png new file mode 100644 Binary files /dev/null and b/images/ERot_zx.png differ diff --git a/images/G.png b/images/G.png new file mode 100644 Binary files /dev/null and b/images/G.png differ diff --git a/images/GateR.png b/images/GateR.png new file mode 100644 Binary files /dev/null and b/images/GateR.png differ diff --git a/images/Rz.png b/images/Rz.png new file mode 100644 Binary files /dev/null and b/images/Rz.png differ diff --git a/images/T.png b/images/T.png new file mode 100644 Binary files /dev/null and b/images/T.png differ diff --git a/images/V.png b/images/V.png new file mode 100644 Binary files /dev/null and b/images/V.png differ diff --git a/images/W.png b/images/W.png new file mode 100644 Binary files /dev/null and b/images/W.png differ diff --git a/images/Y.png b/images/Y.png new file mode 100644 Binary files /dev/null and b/images/Y.png differ diff --git a/images/adder-optimized.png b/images/adder-optimized.png new file mode 100644 Binary files /dev/null and b/images/adder-optimized.png differ diff --git a/images/adder-unoptimized.png b/images/adder-unoptimized.png new file mode 100644 Binary files /dev/null and b/images/adder-unoptimized.png differ diff --git a/images/b0-template.png b/images/b0-template.png new file mode 100644 Binary files /dev/null and b/images/b0-template.png differ diff --git a/images/b1-template.png b/images/b1-template.png new file mode 100644 Binary files /dev/null and b/images/b1-template.png differ diff --git a/images/b2-orthodox.png b/images/b2-orthodox.png new file mode 100644 Binary files /dev/null and b/images/b2-orthodox.png differ diff --git a/images/b2-template.png b/images/b2-template.png new file mode 100644 Binary files /dev/null and b/images/b2-template.png differ diff --git a/images/b3-template.png b/images/b3-template.png new file mode 100644 Binary files /dev/null and b/images/b3-template.png differ diff --git a/images/b4-template.png b/images/b4-template.png new file mode 100644 Binary files /dev/null and b/images/b4-template.png differ diff --git a/images/cH_AMMR.png b/images/cH_AMMR.png new file mode 100644 Binary files /dev/null and b/images/cH_AMMR.png differ diff --git a/images/ccZ_AMMR.png b/images/ccZ_AMMR.png new file mode 100644 Binary files /dev/null and b/images/ccZ_AMMR.png differ diff --git a/images/ccZ_S.png b/images/ccZ_S.png new file mode 100644 Binary files /dev/null and b/images/ccZ_S.png differ diff --git a/images/cc_iX.png b/images/cc_iX.png new file mode 100644 Binary files /dev/null and b/images/cc_iX.png differ diff --git a/images/cc_iX_S.png b/images/cc_iX_S.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_S.png differ diff --git a/images/cc_iX_simple.png b/images/cc_iX_simple.png new file mode 100644 Binary files /dev/null and b/images/cc_iX_simple.png differ diff --git a/images/contfrac.png b/images/contfrac.png new file mode 100644 Binary files /dev/null and b/images/contfrac.png differ diff --git a/images/controlled-phase-decomp.png b/images/controlled-phase-decomp.png new file mode 100644 Binary files /dev/null and b/images/controlled-phase-decomp.png differ diff --git a/images/controlled-zrot.png b/images/controlled-zrot.png new file mode 100644 Binary files /dev/null and b/images/controlled-zrot.png differ diff --git a/images/controlled_E.png b/images/controlled_E.png new file mode 100644 Binary files /dev/null and b/images/controlled_E.png differ diff --git a/images/controlled_S.png b/images/controlled_S.png new file mode 100644 Binary files /dev/null and b/images/controlled_S.png differ diff --git a/images/controlled_T.png b/images/controlled_T.png new file mode 100644 Binary files /dev/null and b/images/controlled_T.png differ diff --git a/images/controlled_V.png b/images/controlled_V.png new file mode 100644 Binary files /dev/null and b/images/controlled_V.png differ diff --git a/images/controlled_W.png b/images/controlled_W.png new file mode 100644 Binary files /dev/null and b/images/controlled_W.png differ diff --git a/images/controlled_YY.png b/images/controlled_YY.png new file mode 100644 Binary files /dev/null and b/images/controlled_YY.png differ diff --git a/images/controlled_iX.png b/images/controlled_iX.png new file mode 100644 Binary files /dev/null and b/images/controlled_iX.png differ diff --git a/images/controlled_phase.png b/images/controlled_phase.png new file mode 100644 Binary files /dev/null and b/images/controlled_phase.png differ diff --git a/images/coord.png b/images/coord.png new file mode 100644 Binary files /dev/null and b/images/coord.png differ diff --git a/images/dashed-cnot-bwd.png b/images/dashed-cnot-bwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-bwd.png differ diff --git a/images/dashed-cnot-fwd.png b/images/dashed-cnot-fwd.png new file mode 100644 Binary files /dev/null and b/images/dashed-cnot-fwd.png differ diff --git a/images/decompose2Controls.png b/images/decompose2Controls.png new file mode 100644 Binary files /dev/null and b/images/decompose2Controls.png differ diff --git a/images/decomposeControls.png b/images/decomposeControls.png new file mode 100644 Binary files /dev/null and b/images/decomposeControls.png differ diff --git a/images/def_f.png b/images/def_f.png new file mode 100644 Binary files /dev/null and b/images/def_f.png differ diff --git a/images/def_g.png b/images/def_g.png new file mode 100644 Binary files /dev/null and b/images/def_g.png differ diff --git a/images/def_g1.png b/images/def_g1.png new file mode 100644 Binary files /dev/null and b/images/def_g1.png differ diff --git a/images/def_h.png b/images/def_h.png new file mode 100644 Binary files /dev/null and b/images/def_h.png differ diff --git a/images/expDA.png b/images/expDA.png new file mode 100644 Binary files /dev/null and b/images/expDA.png differ diff --git a/images/floor.png b/images/floor.png new file mode 100644 Binary files /dev/null and b/images/floor.png differ diff --git a/images/floor2.png b/images/floor2.png new file mode 100644 Binary files /dev/null and b/images/floor2.png differ diff --git a/images/fredkin.png b/images/fredkin.png new file mode 100644 Binary files /dev/null and b/images/fredkin.png differ diff --git a/images/gate_W_CliffordT.png b/images/gate_W_CliffordT.png new file mode 100644 Binary files /dev/null and b/images/gate_W_CliffordT.png differ diff --git a/images/hex-coord.png b/images/hex-coord.png new file mode 100644 Binary files /dev/null and b/images/hex-coord.png differ diff --git a/images/hex1.png b/images/hex1.png new file mode 100644 Binary files /dev/null and b/images/hex1.png differ diff --git a/images/hex2.png b/images/hex2.png new file mode 100644 Binary files /dev/null and b/images/hex2.png differ diff --git a/images/iX.png b/images/iX.png new file mode 100644 Binary files /dev/null and b/images/iX.png differ diff --git a/images/multi_ciX_noancilla.png b/images/multi_ciX_noancilla.png new file mode 100644 Binary files /dev/null and b/images/multi_ciX_noancilla.png differ diff --git a/images/multi_cnot_barenco.png b/images/multi_cnot_barenco.png new file mode 100644 Binary files /dev/null and b/images/multi_cnot_barenco.png differ diff --git a/images/phase.png b/images/phase.png new file mode 100644 Binary files /dev/null and b/images/phase.png differ diff --git a/images/quantum_and.png b/images/quantum_and.png new file mode 100644 Binary files /dev/null and b/images/quantum_and.png differ diff --git a/images/quantum_and_iX.png b/images/quantum_and_iX.png new file mode 100644 Binary files /dev/null and b/images/quantum_and_iX.png differ diff --git a/images/rGate.png b/images/rGate.png new file mode 100644 Binary files /dev/null and b/images/rGate.png differ diff --git a/images/spin1.png b/images/spin1.png new file mode 100644 Binary files /dev/null and b/images/spin1.png differ diff --git a/images/spin2.png b/images/spin2.png new file mode 100644 Binary files /dev/null and b/images/spin2.png differ diff --git a/images/toffoli_AMMR.png b/images/toffoli_AMMR.png new file mode 100644 Binary files /dev/null and b/images/toffoli_AMMR.png differ diff --git a/images/toffoli_NC.png b/images/toffoli_NC.png new file mode 100644 Binary files /dev/null and b/images/toffoli_NC.png differ diff --git a/images/toffoli_S.png b/images/toffoli_S.png new file mode 100644 Binary files /dev/null and b/images/toffoli_S.png differ diff --git a/images/toffoli_V.png b/images/toffoli_V.png new file mode 100644 Binary files /dev/null and b/images/toffoli_V.png differ diff --git a/images/weldedtree.png b/images/weldedtree.png new file mode 100644 Binary files /dev/null and b/images/weldedtree.png differ diff --git a/images/with_combined_controls1.png b/images/with_combined_controls1.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls1.png differ diff --git a/images/with_combined_controls2.png b/images/with_combined_controls2.png new file mode 100644 Binary files /dev/null and b/images/with_combined_controls2.png differ diff --git a/images/with_computed.png b/images/with_computed.png new file mode 100644 Binary files /dev/null and b/images/with_computed.png differ diff --git a/images/with_signed_qubit.png b/images/with_signed_qubit.png new file mode 100644 Binary files /dev/null and b/images/with_signed_qubit.png differ diff --git a/programs/quipper-pp.hs b/programs/quipper-pp.hs new file mode 100644 --- /dev/null +++ b/programs/quipper-pp.hs @@ -0,0 +1,100 @@ +-- | The Quipper preprocessor. This is just a wrapper around an awk +-- script. + +import System.Environment +import System.Exit +import System.Process +import System.IO +import System.IO.Error + +-- The Paths_quipper_language module is automatically generated by Cabal. +import Paths_quipper_language + +-- | Print usage information. +usage :: String -> IO () +usage myname = do + putStrLn $ myname ++ ": the Quipper preprocessor" + putStrLn $ "" + putStrLn $ "Usage: " ++ myname ++ " " + putStrLn $ " " ++ myname ++ " -f" + putStrLn $ "" + putStrLn $ "Arguments and options:" + putStrLn $ " - the name of the original source file" + putStrLn $ " - the name of the file holding the input" + putStrLn $ " - the name of the file to write the output to" + putStrLn $ " -f - act as a filter (for testing)" + +-- | Escape backslash characters in a string. +escape :: String -> String +escape [] = [] +escape ('\\' : t) = "\\\\" ++ escape t +escape (h : t) = h : escape t + +-- | Run awk with the given arguments on the given input string. +runAWK :: [String] -> String -> IO (ExitCode, String, String) +runAWK args input = catchIOError body handler + where + body = do + readProcessWithExitCode "awk" args input + handler e = do + name <- getProgName + hPutStrLn stderr $ name ++ ": unable to run awk. Please ensure that awk is installed and on your PATH." + exitFailure + +-- | Check whether awk needs one or two rounds of character escaping. +-- For unknown reasons, the behavior of awk in Windows is different +-- from that in Linux. Maybe it differs from implementation to +-- implementation, so we better check it at runtime. +awk_needs_two_escapes :: IO Bool +awk_needs_two_escapes = do + (r, out, err) <- runAWK ["-v", "var=x\\\\\\\\y", "--", "BEGIN { print var }"] "" + case out of + "x\\\\y\n" -> return False + "x\\y\n" -> return True + otherwise -> return False + +-- | Run the Quipper preprocessor on the given input string. +runPP :: String -> String -> IO (ExitCode, String, String) +runPP filename input = do + b <- awk_needs_two_escapes + let esc = if b then escape . escape else escape + script <- getDataFileName "scripts/convert_template.awk" + let args = ["-f", script, "-v", "haskell_filename=\"" ++ esc filename ++ "\""] + runAWK args input + +-- | Run the Quipper preprocessor on the given pair of files. +runPP_filter :: String -> Handle -> Handle -> IO ExitCode +runPP_filter filename fin fout = do + input <- hGetContents fin + (r, out, err) <- runPP filename input + hPutStr fout out + hPutStr stderr err + hFlush fout + hFlush stderr + return r + +main :: IO () +main = do + args <- getArgs + myname <- getProgName + case args of + "-h" : _ -> do + usage myname + exitSuccess + "--help" : _ -> do + usage myname + exitSuccess + ["-f"] -> do + r <- runPP_filter "stdin" stdin stdout + exitWith r + [filename, infile, outfile] -> do + fin <- openFile infile ReadMode + fout <- openFile outfile WriteMode + r <- runPP_filter filename fin fout + hClose fin + hClose fout + exitWith r + _ -> do + putStrLn $ myname ++ ": illegal command line" + putStrLn $ "For usage information, try the `--help' option." + exitFailure diff --git a/programs/quipper.hs b/programs/quipper.hs new file mode 100644 --- /dev/null +++ b/programs/quipper.hs @@ -0,0 +1,51 @@ +-- | The Quipper executable. This is just a wrapper around GHC +-- with a custom preprocessor. + +import System.Environment +import System.Exit +import System.Process + +usage :: String -> IO () +usage myname = do + putStrLn $ myname ++ ": the Quipper compiler" + putStrLn $ "" + putStrLn $ "Usage: " ++ myname ++ " [--help|-h]" + putStrLn $ " " ++ myname ++ " [anything-other-than-the-above]" + putStrLn $ "" + putStrLn $ "Options:" + putStrLn $ " (no parameters) : bitterly complain" + putStrLn $ " --help, -h : print this message" + putStrLn $ " any-other-than-the-above : passed on to ghc" + putStrLn $ "" + putStrLn $ "This compiler is a wrapper around ghc." + putStrLn $ "Its usage is therefore exactly the same as that of ghc." + putStrLn $ "Try `ghc --help' for more information." + +-- | Run GHC with the given command line options. +runGHC :: [String] -> IO ExitCode +runGHC args = do + rawSystem "ghc" args + +-- | Run Quipper with the given command line options. +runQuipper :: [String] -> IO ExitCode +runQuipper args = do + runGHC ("-F" : "-pgmF" : "quipper-pp" : args) + +main :: IO () +main = do + args <- getArgs + myname <- getProgName + case args of + [] -> do + putStrLn $ myname ++ ": no input files" + putStrLn $ "For usage information, try the `--help' option." + exitWith (ExitFailure 1) + "-h" : _ -> do + usage myname + exitSuccess + "--help" : _ -> do + usage myname + exitSuccess + _ -> do + r <- runQuipper args + exitWith r diff --git a/programs/quipperdoc.hs b/programs/quipperdoc.hs new file mode 100644 --- /dev/null +++ b/programs/quipperdoc.hs @@ -0,0 +1,51 @@ +-- | The QuipperDoc executable. This is just a wrapper around Haddock +-- with a custom preprocessor. + +import System.Environment +import System.Exit +import System.Process + +usage :: String -> IO () +usage myname = do + putStrLn $ myname ++ ": documentation generator for the Quipper language" + putStrLn $ "" + putStrLn $ "Usage: " ++ myname ++ " [--help|-h]" + putStrLn $ " " ++ myname ++ " [anything-other-than-the-above]" + putStrLn $ "" + putStrLn $ "Options:" + putStrLn $ " (no parameters) : bitterly complain" + putStrLn $ " --help, -h : print this message" + putStrLn $ " any-other-than-the-above : passed on to haddock" + putStrLn $ "" + putStrLn $ "This program is a wrapper around haddock." + putStrLn $ "Its usage is therefore exactly the same as that of haddock." + putStrLn $ "Try `haddock --help' for more information." + +-- | Run Haddock with the given command line options. +runHaddock :: [String] -> IO ExitCode +runHaddock args = do + rawSystem "haddock" args + +-- | Run QuipperDoc with the given command line options. +runQuipperDoc :: [String] -> IO ExitCode +runQuipperDoc args = do + runHaddock ("--optghc=-F" : "--optghc=-pgmF" : "--optghc=quipper-pp" : args) + +main :: IO () +main = do + args <- getArgs + myname <- getProgName + case args of + [] -> do + putStrLn $ myname ++ ": no input files" + putStrLn $ "For usage information, try the `--help' option." + exitWith (ExitFailure 1) + "-h" : _ -> do + usage myname + exitSuccess + "--help" : _ -> do + usage myname + exitSuccess + _ -> do + r <- runQuipperDoc args + exitWith r diff --git a/programs/quipperi.hs b/programs/quipperi.hs new file mode 100644 --- /dev/null +++ b/programs/quipperi.hs @@ -0,0 +1,47 @@ +-- | The Quipper Interpreter executable. This is just a wrapper around +-- GHC with a custom preprocessor. + +import System.Environment +import System.Exit +import System.Process + +usage :: String -> IO () +usage myname = do + putStrLn $ myname ++ ": interactive interface to the Quipper compiler" + putStrLn $ "" + putStrLn $ "Usage: " ++ myname ++ " [--help|-h]" + putStrLn $ " " ++ myname ++ " [anything-other-than-the-above]" + putStrLn $ "" + putStrLn $ "Options:" + putStrLn $ " (no parameters) : bitterly complain" + putStrLn $ " --help, -h : print this message" + putStrLn $ " any-other-than-the-above : passed on to ghci" + putStrLn $ "" + putStrLn $ "This compiler is a wrapper around ghci." + putStrLn $ "Its usage is therefore exactly the same as that of ghci." + putStrLn $ "Try `ghci --help' for more information." + +-- | Run GHCI with the given command line options. +runGHCI :: [String] -> IO ExitCode +runGHCI args = do + rawSystem "ghci" args + +-- | Run QuipperI with the given command line options. +runQuipperI :: [String] -> IO ExitCode +runQuipperI args = do + runGHCI ("-F" : "-pgmF" : "quipper-pp" : args) + +main :: IO () +main = do + args <- getArgs + myname <- getProgName + case args of + "-h" : _ -> do + usage myname + exitSuccess + "--help" : _ -> do + usage myname + exitSuccess + _ -> do + r <- runQuipperI args + exitWith r diff --git a/quipper-language.cabal b/quipper-language.cabal new file mode 100644 --- /dev/null +++ b/quipper-language.cabal @@ -0,0 +1,151 @@ +-- The name of the package. +name: quipper-language + +-- 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: + + Quipper, an embedded functional programming language for quantum + computation. + +-- A longer description of the package. +description: + + Quipper is an embedded functional programming language for quantum + computation. The quipper-language package provides the Quipper + language. You might also want quipper-libraries to get the Quipper + libraries, quipper-tools to get some standalone tools, and + quipper-algorithms to get a collection of pre-implemented quantum + algorithms. + +-- 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 + +data-files: scripts/convert_template.awk + +library + -- Modules exported by the library. + exposed-modules: Quipper, + Quipper.Internal, + Quipper.Internal.CircLifting, + Quipper.Internal.Circuit, + Quipper.Internal.Classical, + Quipper.Internal.Control, + Quipper.Internal.Generic, + Quipper.Internal.Labels, + Quipper.Internal.Monad, + Quipper.Internal.Printing, + Quipper.Internal.QClasses, + Quipper.Internal.QData, + Quipper.Internal.Transformer + + -- 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, + easyrender >= 0.1.0.0, + directory >= 1.2.6.2, + quipper-utils >= 0.9.0.0, + fail >= 4.9.0.0 + +executable quipper + -- .hs or .lhs file containing the Main module. + main-is: quipper.hs + + -- Root directories for the module hierarchy. + hs-source-dirs: programs + + -- Modules included in this executable, other than Main. + other-modules: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + process >= 1.4.2.0, + quipper-language + +executable quipperi + -- .hs or .lhs file containing the Main module. + main-is: quipperi.hs + + -- Root directories for the module hierarchy. + hs-source-dirs: programs + + -- Modules included in this executable, other than Main. + other-modules: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + process >= 1.4.2.0, + quipper-language + +executable quipperdoc + -- .hs or .lhs file containing the Main module. + main-is: quipperdoc.hs + + -- Root directories for the module hierarchy. + hs-source-dirs: programs + + -- Modules included in this executable, other than Main. + other-modules: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + process >= 1.4.2.0, + quipper-language + +executable quipper-pp + main-is: quipper-pp.hs + + -- The Paths_quipper_language module is automatically generated by + -- Cabal, but we still need to declare it as a dependency. + other-modules: Paths_quipper_language + + hs-source-dirs: programs + + build-depends: base >= 4.5 && < 5, + process >= 1.4.2.0 + +custom-setup + setup-depends: base >= 4.5, superdoc >= 0.1 diff --git a/scripts/convert_template.awk b/scripts/convert_template.awk new file mode 100644 --- /dev/null +++ b/scripts/convert_template.awk @@ -0,0 +1,120 @@ +BEGIN{ + LOOK_FOR_ENTRY="LOOK FOR ENTRY"; + LOOK_FOR_NAME="LOOK FOR NAME"; + LOOK_FOR_END="LOOK FOR END"; + LINE_NBER=0; + + hasfoundentry = 0; + + state=LOOK_FOR_ENTRY; + print_log( "-- state is " state); + + print "{-# LANGUAGE TemplateHaskell #-}"; + print "{-# LANGUAGE FlexibleContexts #-}"; + print "{-# LANGUAGE TypeFamilies #-}"; + print "{-# LINE 1 " haskell_filename " #-}"; +} + +//{++LINE_NBER;} + +/^[^ \t]/{ + print_log( "-- found non-empty line"); + if ( state == LOOK_FOR_NAME ) { + print_log( "-- state is " state); + state = LOOK_FOR_END; + print_log( "-- state changed to LOOK_FOR_END"); + name_def = $0; + sub(/ .*/,"",name_def); + print_log( "-- name_def = " name_def); + } + else if ( state == LOOK_FOR_END ){ + print_log( "-- state is " state); + first_word = $0; + sub(/ .*/,"", first_word); + print_log( "-- first word is " first_word); + if (first_word != name_def) { + print_log( "-- first word is not name_def"); + print_log( "-- v1 : normal") + print text_build_circuit; + print_log( "-- v2 : lifted") + gsub(/\n/, "\n ", text_build_circuit); + gsub(/--[^\n]*/, "", text_build_circuit); # filter comments out + # The following line is somehow necessary for haddock of + # ghc 7.4.2 to correctly match documentations with + # declarations. + print "{-# LINE " (LINE_NBER-1) " " haskell_filename " #-}"; + print "$( decToCircMonad [d| " text_build_circuit; + print " |] ) "; + print "{-# LINE " LINE_NBER " " haskell_filename " #-}"; + state = LOOK_FOR_ENTRY; + } + } +} + +($0 !~ /^build_circuit/){ + if ( state == LOOK_FOR_ENTRY ) { + print; + } else if (state == LOOK_FOR_END) { + print_log( "-- storing line : " $0) + text_build_circuit = text_build_circuit $0 "\n"; + } +} + +/^build_circuit/{ + print_log( "-- found a build_circuit"); + if ( state == LOOK_FOR_ENTRY) { + print_log( "-- state is " state) + state = LOOK_FOR_NAME; + print_log( "-- state changed to LOOK_FOR_NAME") + text_build_circuit = ""; + if ($0 ~ /[ \t][^ \t]/) { # the definition starts right after + print_log( "-- found a name on the same line as build_circuit!") + text_build_circuit = $0 + sub(/[^ \t]*[ \t]*/,"",text_build_circuit); + text_build_circuit = text_build_circuit "\n"; + name_def = text_build_circuit; + sub(/ .*/,"",name_def); + print_log( "-- name_def = " name_def); + state = LOOK_FOR_END + } else { + # pad a newline for the removed build_circuit. + print "" + } + } else { + print_log( "-- state is " state " : inconsistent state?") + print_log( "-- change to LOOK_FOR_NAME anyway") + state = LOOK_FOR_NAME; + print_log( "-- state changed to LOOK_FOR_NAME") + text_build_circuit = ""; + } +} + + + + + +END{ + if (state == LOOK_FOR_END){ + print_log( "-- state is " state); + first_word = $0; + sub(/ .*/,"", first_word); + print_log( "-- first word is " first_word); +# if (first_word != name_def) { +# print_log( "-- first word is not name_def") + print_log( "-- v1 : normal") + print text_build_circuit; + gsub(/--[^\n]*/, "", text_build_circuit); # filter comments out + print_log( "-- v2 : lifted") + gsub(/\n/, "\n ", text_build_circuit); + print "$( decToCircMonad [d| " text_build_circuit; + print " |] ) "; + state = LOOK_FOR_ENTRY; +# } + } +} + +# if n = 0, do not log. If n = 1, do log. +function print_log(s) { + if ( LOG_LEVEL == 1 ) { print s; } +} +