quipper 0.8.2 → 0.9.0.0
raw patch · 29 files changed
+141/−13400 lines, 29 filesdep +quipper-languagedep +quipper-librariesdep +quipper-toolsdep −containersdep −directorydep −easyrenderdep ~basenew-uploader
Dependencies added: quipper-language, quipper-libraries, quipper-tools
Dependencies removed: containers, directory, easyrender, mtl, primes, process, random, template-haskell, unix
Dependency ranges changed: base
Files
- COPYRIGHT +1/−1
- ChangeLog +76/−0
- README +0/−428
- quipper.cabal +64/−18
- src/Libraries/Auxiliary.hs +0/−926
- src/Libraries/CommandLine.hs +0/−72
- src/Libraries/PortableSignals.hs +0/−139
- src/Libraries/RandomSource.hs +0/−25
- src/Libraries/Sampling.hs +0/−285
- src/Libraries/Template.hs +0/−67
- src/Libraries/Template/Auxiliary.hs +0/−88
- src/Libraries/Template/ErrorMsgQ.hs +0/−62
- src/Libraries/Template/LiftQ.hs +0/−288
- src/Libraries/Template/Lifting.hs +0/−636
- src/Libraries/Tuple.hs +0/−103
- src/Libraries/Typeable.hs +0/−58
- src/Quipper.hs +0/−529
- src/Quipper/CircLifting.hs +0/−563
- src/Quipper/Circuit.hs +0/−769
- src/Quipper/Classical.hs +0/−241
- src/Quipper/Control.hs +0/−260
- src/Quipper/Generic.hs +0/−1623
- src/Quipper/Internal.hs +0/−51
- src/Quipper/Labels.hs +0/−535
- src/Quipper/Monad.hs +0/−1819
- src/Quipper/Printing.hs +0/−1692
- src/Quipper/QClasses.hs +0/−140
- src/Quipper/QData.hs +0/−1358
- src/Quipper/Transformer.hs +0/−624
COPYRIGHT view
@@ -4,7 +4,7 @@ name is marked (ACS), the copyright rests with Applied Communication Sciences. -Copyright (C) 2011-2016. All rights reserved.+Copyright (C) 2011-2019. All rights reserved. Copyright (C) 2012-2013 Applied Communication Sciences. All rights reserved.
+ ChangeLog view
@@ -0,0 +1,76 @@+December 29, 2019: Release 0.9.0.0++ * Overhauled module structure:+ + Old: New:+ ==== ====+ + Quipper.XYZ Quipper.Internal.XYZ+ QuipperLib.XYZ Quipper.Libraries.XYZ+ Libraries.XYZ Quipper.Utils.XYZ+ Algorithms.XYZ Quipper.Algorithms.XYZ+ tests Quipper.Demos+ Programs Quipper.Programs++ * Re-packaged Quipper as Cabal packages. Added executables quipper,+ quipper-pp, quipperi, quipperdoc in lieu of shell scripts.+ * Moved PDF Previewer to a separate library in Quipper.Utils.Preview+ * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy+ * Use type class synonyms to avoid warnings about simplifiable class.+ * Compatibility: removed obsolete functoin Map.insertWith'.+ * Added MultiControlledNot demo.+ * Removed dependency on set-monad, which is broken upstream.+ * Fixed some bugs in the stabilizer simulation.+ * Moved QuantumIf from BF to Libraries.+ * Added --help option to all Quipper tools.+ * Removed Quipper.Utils.ShowAll+ * Fixed some compiler errors and removed some unnecessary type class+ assumptions.++July 27, 2016: Release 0.8++ * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too+ broken and will not be supported by Quipper.+ * Added tests/SimulationTest+ * Added QPrep and QUnPrep to the simulator++October 14, 2014: Release 0.7++ * Portability: compatibility fixes for GHC 7.8.++January 16, 2014: Release 0.6++ * Minor edits and documentation updates.+ * Added a new gate gate_iX_inv+ * Added "alternate" version of synthesis algorithm, using only+ generators of determinant 1 if possible.+ * Synthesis code is now in an external package "newsynth".+ * Rendering code is now in an external package "easyrender".+ * Updated for use with fixedprec-0.2.1.0.++September 2, 2013: Release 0.5++ * Portability: compatibility fixes for GHC 7.6.2.+ * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C+ may or may not work on Windows, depending on console.+ * Added quipperi script, analogous to ghci.+ * New library QuipperLib.ClassicalOptim: algebraic optimization of+ auto-generated classical circuits. Added "optimized" oracle to BWT+ algorithm.+ * QuipperLib.Decompose: Added decomposition into a "standard" gate+ set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT.+ Added KeepPhase flag to some transformers.+ * QuipperLib.GateDecompositions: added more gates.+ * New library Libraries.Synthesis.RotationDecomposition: implements a+ variant of the algorithm from Nielsen and Chuang to decompose an+ nxn unitary operator into one- and two-level rotations.+ * New library QuipperLib.Unboxing: unboxing transformers.+ * Updated ASCII output format; improved circuit parser efficiency.+ * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits,+ floorlog.+ * Fixed handling of iterated subroutines in depth transformer.+ * Documentation updates and minor refactoring.++June 19, 2013: Release 0.4++ * First public release.
− README
@@ -1,428 +0,0 @@-This file is part of Quipper. Copyright (C) 2011-2016. Please see the-file COPYRIGHT for a list of authors, copyright holders, licensing,-and other details. All rights reserved.--======================================================================--This is Quipper.--Copyright, License, and Disclaimers-===================================--See the file COPYRIGHT.--Installing the necessary components -===================================--For installing on Linux, Mac OS X, and other Unix-like systems: please-first see the instructions in INSTALLING, then continue to read below.--For installing on Windows: please first see the instructions in-INSTALLING.windows, then continue to read below.--Configuring the software environment-=====================================--Before you can compile Quipper, you have to install some Haskell-libraries:-- * random >= 1.0.1.1- * mtl >= 2.1.2- * primes >= 0.2.1.0- * Lattices >= 0.0.1 (note: "Lattices" must be capitalized)- * zlib >= 0.5.4.1- * easyrender >= 0.1.0.0- * fixedprec >= 0.2.1.0- * newsynth >= 0.3.0.1- * containers >= 0.5.2.1- * set-monad >= 0.1.0.0- * QuickCheck >= 2.6--This can be done using Cabal. On the command line, use the-following commands:--cabal update--then:--cabal install random-cabal install mtl-cabal install primes-cabal install Lattices-cabal install zlib-cabal install easyrender-cabal install fixedprec-cabal install newsynth-cabal install containers-cabal install set-monad-cabal install QuickCheck--Note: When upgrading from a previous version of Quipper, please ensure-that the fixedprec library is version 0.2.1.0 or newer; Quipper 0.6-will not work with earlier versions of fixedprec. Also ensure that the-newsynth library has been compiled against the same version of-fixedprec as Quipper. If you get strange error messages related to-fixedprec, try--cabal install fixedprec -cabal install newsynth --reinstall--You now have all the necessary Haskell libraries.--Special note for GHC 7.4.2:-===========================--The combination of GHC 7.4.2 and Template Haskell 2.8.0.0 is not-possible, because it triggers a GHC bug. If you get a compilation-error of the form: "ghc: panic! (the 'impossible' happened)", follow-these steps:--# Remove Template Haskell 2.8.0.0:--ghc-pkg unregister --force template-haskell-2.8.0.0--# Reinstall QuickCheck (because of a broken dependency). This will-# also install template-haskell-2.7.0.0:--cabal install QuickCheck--Special note for GHC 7.10.*:-============================--Quipper will not work with ghc 7.10. Please use ghc 7.8 or earlier, or-ghc 8.0 or later.--Browsing the documentation and source code-==========================================--While it is possible the browse the Quipper source code in a text-editor, it is much nicer to browse the documented source by pointing-your web browser to doc/frames.html in this Quipper distribution. The-documented source is fully cross-referenced and indexed, with links to-color-coded raw source files.---Building the documentation-==========================--Please note: our documentation uses special mark-up and requires-custom tools to be built. Therefore it is not currently possible for-users to re-build the documentation.---Building the included algorithms and programs-=============================================--Compilation, and execution of generated code, are done from the command-line interface.--The code can be built with "make" from the main directory. This will-build an executable file in each Algorithm subdirectory, which can be-run with various command line parameters to do different things. Run-each command with option --help to see a summary of the usage-information.--In the following, we describe the set of options for the algorithms-that were implemented.---Running the bwt program-=======================--Usage for Binary Welded Tree algorithm:------------------------------------------Usage: bwt [OPTION...]- -h --help print usage info and exit- -C --circuit output the whole circuit (default)- -O --oracle output only the oracle- -K --oraclec output the "classical" oracle as a classical circuit- -G --graph print colored graph computed from oracle- -S --simulate run simulations of some circuit fragments for tree height n- -f <format> --format=<format> output format for circuits (default: preview)- -g <gatebase> --gatebase=<gatebase> type of gates to decompose into (default: logical)- -o <oracle> select oracle to use (default: orthodox)- -n <n> --height=<n> set tree height (positive; default 5)- -c <c> --color=<c> color to use with --oracle (0..3, default 0)- -s <s> --repeats=<s> set parameter s (iteration count; default 1)- -l --large set large problem size: n=300, s=336960- -t <dt> --dt=<dt> set parameter dt (simulation time step; default pi/180)-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.-Possible values for oracle are: orthodox, simple, blackbox, classical, template, optimized.--Examples of command line options:------------------------------------* Show the complete circuit for the BWT algorithm using the- "orthodox" (official GFI) oracle, with n=5 and s=1:-- ./bwt -C -o orthodox -n 5 -s 1-- (One can point out the different parts of the algorithm: 8 oracle- calls, and 4 very short diffusion steps).--* Show the same, using the "Template Haskell" oracle: this oracle is- much larger, but automatically generated from classical code (and- completely unoptimized):-- ./bwt -C -o template -n 5 -s 1-- The "template oracle" is defined in BWT/Template.hs. See the- documentation of the module Quipper/CircLifting for how it works.--* Show the graph of the BWT algorithm, which is obtained by- simulating the orthodox oracle (and therefore offers some evidence- for the correctness of the oracle implementation):-- ./bwt -G -o orthodox -n 5--* Show the orthodox oracle for n=300. Note that this will result in a- big file. One has to zoom in substantially to see gates. -- ./bwt -O -o orthodox -n 300--* Show the complete circuit for the BWT algorithm, but decompose- everything into binary gates:-- ./bwt -C -o orthodox -n 5 -s 1 -g binary --* Show the oracle from Figure 1a (alternate oracle).-- ./bwt -C -o figure1a--* The same, decomposed into binary+Toffoli gates, or binary gates- only, respectively:-- ./bwt -C -o figure1a -g toffoli- ./bwt -C -o figure1a -g binary--* Show gate counts for BWT algorithm with n=300 and s=1, using- "orthodox" oracle:-- ./bwt -C -o orthodox -n 300 -s 1 -f gatecount--* Show gate counts for same, after decomposition to binary gates:-- ./bwt -C -o orthodox -n 300 -s 1 -f gatecount -g binary --Obviously, most other combinations of command line options are also-possible, for example: decompose to toffoli gates and then simulate-and show the graph. Some other combinations are not legal: for-example, decomposing to binary gates and then simulating. (The-classical simulator will complain that the circuit is not boolean; it-contains "V" gates).--* Similarly, one can run demos for the triangle finding- algorithm using various command line options. --Note that the triangle finding algorithm is not a deliverable; it is a-work in progress. The only implemented algorithm that is officially a-deliverable is the "orthodox" BWT implementation in BWT.BWT.--Running the bf program-======================--Usage for the Boolean Formula algorithm:-------------------------------------------Usage: bf [OPTION...]- -C --circuit output the whole circuit (default)- -D --demo run a demo of the circuit- -H --hexboard output a representation of the initial state of the given oracle, i.e. the game played so far- -p <part> --part=<part> which part of the circuit to use (default: whole)- -o <oracle> --oracle=<oracle> which oracle to use (default: small)- -m <moves> --moves=<moves> which moves have already been made (default: [])- -f <format> --format=<format> output format for circuits (default: _preview)- -d --dummy set to only use a dummy HEX gate instead of the full hex circuit- -h --help print usage info and exit- -g <gatebase> --gatebase=<gatebase> type of gates to decompose the output circuit into (default: logical)-Possible values for part are: whole, u, oracle, hex, checkwin_red, diffuse, walk, undo_oracle.-Possible values for oracle are: 9by7, small, custom x y t.-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.--Running the cl program-======================--Usage for the Class Number algorithm:----------------------------------------Usage: cl [OPTION...]- -h --help print usage info and exit- -f <format> --format=<format> output format for circuits (default: ASCII)- -g <gatebase> --gatebase=<gatebase> gates to decompose into (default: Logical)- -1 output the circuit for stage 1 of the algorithm (default)- -4 output the circuit for stage 4 of the algorithm- -S <subroutine> --sub=<subroutine> output the circuit for a specific subroutine- -R --regulator classically, find the regulator, given Δ- -F classically, find the fundamental unit, given Δ- -P classically, find the fundamental solution of Pell’s equation, given Δ- -d <N> --delta=<N> discriminant Δ (a.k.a. D) (default: 28)- -s <N> --ss=<N> estimated bound on period S, for stage 1 (default: 2)- -i <N> estimated bound on log_2 S, for stage 1 (default: 1)- -r <N> --rr=<N> approximate regulator R, for stage 4 (default: 12.345)- -q <N> The parameter q, for stage 4 (default: 4)- -k <N> The parameter k, for stage 4 (default: 3)- -n <N> The parameter n, for stage 4 (default: 3)- -m <N> The parameter m, for stage 4 (default: 5)- --seed=<N> Random seed (0 for seed from time)(default: 1)-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.-Possible values for subroutine are: rho, rhoinv, normalize, dotprod, starprod, fn.--Running the gse program-=======================--Usage for Ground State Estimation algorithm:-----------------------------------------------Usage: gse [OPTION...]- -h --help print usage info and exit- -C --circuit output the whole circuit (default)- -T <indices> --template=<indices> output a particular circuit template- -f <format> --format=<format> output format for circuits (default: Preview)- -g <gatebase> --gatebase=<gatebase> gates to decompose into (default: Logical)- -m <N> --orbitals=<N> number of orbitals (default: 4)- -o <N> --occupied=<N> number of occupied orbitals (default: 2)- -b <N> --precision=<N> number of precision qubits (default: 3)- -D <energy> --delta_e=<energy> energy range (default: 6.5536)- -E <energy> --e_max=<energy> maximum energy (default: -3876.941)- --n0=<N> use N_k = n0 * 2^k (default: N_k = 1)- -l --large set large problem size (m=208, o=84, b=12, n0=100)- -x --orthodox use the Coulomb operator of Whitman et al.- --h1=<file> filename for one-electron data (default: "h_1e_ascii")- --h2=<file> filename for two-electron data (default: "h_2e_ascii")- -d <file> --datadir=<file> directory for one- and two-electron data (default: current)-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.-Indices can be specified as p,q or p,q,r,s (with no spaces)--Running the qls program-=======================--Usage for Quantum Linear Systems algorithm:----------------------------------------------Usage: qls [OPTION...]- -h --help print usage info and exit- -C --circuit output the whole circuit (default)- -O <name> --oracle=<name> output only the oracle <name> (default: r) - -f <format> --format=<format> output format for circuits (default: gatecount)- -g <gatebase> --gatebase=<gatebase> type of gates to decompose into (default: logical)- -o <oracle> select oracle implementation to use (default: blackbox)- -p <param> --param=<param> choose a set of parameters (default: dummy).- -P <n> --peel=<n> peel <n> layers of boxed subroutines (default: 0).-Possible values for format are: ascii, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.-Possible values for oracle implementation are: matlab, blackbox.-Possible values for param are: dummy, small, large.-Possible values for oracle are: r, b, A[band][t|f]. E.g. "-OA1t" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0.--Running the tf program-======================--Usage for Triangle Finding algorithm:----------------------------------------Usage: tf [OPTION...]- -h --help print usage info and exit- -f <format> --format=<format> output format for circuits (default: preview)- -g <gatebase> --gatebase=<gatebase> type of gates to decompose into (default: logical)- -l <l> --l=<l> parameter l (default: 4)- -n <n> --n=<n> parameter n (default: 3)- -r <r> --r=<r> parameter r (default: 2)- -C --QWTFP output the whole circuit (default)- -O --oracle output only the oracle- -s <subroutine> --subroutine=<subroutine> output the chosen subroutine (default: adder)- -Q use alternative qRAM implementation- -o <oracle> select oracle to use (default: blackbox)- -A --arith test/simulate the arithmetic routines- -T --oracletest test/simulate the oracle-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.-Possible values for oracle are: orthodox, blackbox.-Possible values for subroutine are: zero, initialize, hadamard, setup, qwsh, diffuse, fetcht, storet, fetchstoret, fetche, fetchstoree, update, swap, a15, a16, a17, a18, gcqwalk, gcqwstep, convertnode, testequal, pow17, mod3, sub, add, mult.--Running the usv program-=======================--Usage for Unique Shortest Vector algorithm:----------------------------------------------Usage: usv [OPTION...]- -h --help print usage info and exit- -f <format> --format=<format> output format for circuits (default: eps)- -g <gatebase> --gatebase=<gatebase> type of gates to decompose into (default: logical)- -n <n> --n=<n> parameter n (default: 5)- -b <b> --b=<b> parameter b (default: 5X5 with entries = 1)- -s <s> --s=<s> Random number generator seed s (default: 1)- -F output subroutine f (depends on b).- -G output subroutine g (depends on b).- -H output subroutine h (depends on n).- -U output algorithm 1 (depends on b).- -Q output algorithm 2 (depends on b).- -R output algorithm 3 (depends on b).- -T output algorithm 4 (depends on n).- -S output sieving subroutine (depends on n).- -D output algorithm 5 (depends on n).- -t test subroutine h (depends on n).-Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.-Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.---Invoking the Quipper compiler-=============================--The Quipper compiler is called "quipper", and is located in the-directory quipper/scripts. The easiest way to use it is to add the-"scripts" directory to the environment variable PATH. If you move the-quipper script around, make sure to keep the other scripts in the same-directory as the quipper script, and to update QUIPPER_BASE in the-"quipper" and "quipperi" scripts to point to the directory where the-Quipper sources are located. On the Windows operating system, you-should use "quipper.bat"; on all other operating systems, just-"quipper" will do. --In reality, the "quipper" script is a wrapper around the GHC Haskell-compiler, providing some pre-processing and setting required-compilation options. There is also a "quipperi" script for an-interactive version of the compiler, which is akin to "ghci".--To try this out, the directory "tests" contains various small-stand-alone programs that can be compiled with Quipper, and are useful-for demonstrating the basic Quipper idiom. Each program can be-compiled and run like this:--For example:--# to compile and run on Unix (or on Unix with the MSYS/bash):-quipper And_gate.hs-./And_gate--# to compile and run on Windows with cmd.exe:-quipper.bat And_gate.hs-And_gate--Note that there is also a Makefile, so "make" can be used to build the-programs as well.--If the previewer is working properly, the circuit should show up in-Acrobat Reader. If not, either change "Preview" to "EPS" in the file-(for PostScript output), or trouble-shoot the previewer installation-(if you are on Windows, see INSTALLING) and/or contact Benoit Valiron-<benoit.valiron@monoidal.net> or Peter Selinger-<selinger@mathstat.dal.ca> for help.--The naming of built-in gates and many operators can be found out by-looking at the documentation of the "Quipper" module (the main public-interface of the Quipper system).---Troubleshooting Guidelines-==========================--In case of problems, please contact-- * Benoit Valiron <benoit.valiron@monoidal.net>- * Peter Selinger <selinger@mathstat.dal.ca>
quipper.cabal view
@@ -1,25 +1,71 @@--- Initial quipper.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/-+-- The name of the package. name: quipper-version: 0.8.2-synopsis: An embedded, scalable functional programming language for quantum computing.--- description: ++-- 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:++ Meta-package for Quipper.++-- A longer description of the package.+description: ++ This is a meta-package for Quipper, the embedded functional+ programming language for quantum computing. Installing this package+ automatically installs everything you need for Quipper, including+ the quipper-language, quipper-libraries, and quipper-tools.++-- 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-author: Applied Communication Sciences-maintainer: leonardo.taglialegne@gmail.com--- copyright: --- category: ++-- 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: Simple-extra-source-files: README-cabal-version: >=1.10 +-- 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: ChangeLog+ library- exposed-modules: Quipper, Quipper.Generic, Quipper.CircLifting, Quipper.Printing, Quipper.Classical, Quipper.QData, Quipper.Internal, Quipper.Monad, Quipper.Control, Quipper.Circuit, Quipper.QClasses, Quipper.Labels, Quipper.Transformer- other-modules: Libraries.Template, Libraries.RandomSource, Libraries.CommandLine, Libraries.Auxiliary, Libraries.Typeable, Libraries.PortableSignals, Libraries.Sampling, Libraries.Tuple, Libraries.Template.LiftQ, Libraries.Template.Auxiliary, Libraries.Template.ErrorMsgQ, Libraries.Template.Lifting- other-extensions: GADTs, RankNTypes, FlexibleInstances, OverlappingInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, CPP, StandaloneDeriving, DeriveDataTypeable, ScopedTypeVariables, TypeSynonymInstances, TemplateHaskell, BangPatterns, FlexibleContexts, TypeFamilies, Rank2Types, ExistentialQuantification- build-depends: base >=4.6 && <4.10, random >=1.0 && <1.2, containers >=0.5 && <0.6, unix >=2.6 && <2.8, template-haskell >=2.8 && <2.12, mtl >=2.1 && <2.3, easyrender >=0.1 && <0.2, process >=1.1 && <1.5, directory >=1.2 && <1.3, primes >=0.2 && <0.3- hs-source-dirs: src- default-language: Haskell2010+ -- Modules exported by the library.+ exposed-modules: + + -- Modules included in this library but not exported.+ other-modules: + + -- Other library packages from which modules are imported.+ build-depends: base >= 4.5 && < 5,+ quipper-language >= 0.9.0.0,+ quipper-libraries >= 0.9.0.0,+ quipper-tools >= 0.9.0.0
− src/Libraries/Auxiliary.hs
@@ -1,926 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- | This module provides miscellaneous general-purpose auxiliary--- functions.--module Libraries.Auxiliary (- -- * List operations- applyAt,- overwriteAt,- has_duplicates,- substitute,- - -- * Set and Map related operations- map_provide,- intset_inserts,- intmap_zip,- intmap_zip_errmsg,- intmap_map,- intmap_mapM,- - -- * XIntMaps- XIntMap,- xintmap_delete,- xintmap_deletes,- xintmap_insert,- xintmap_inserts,- xintmap_lookup,- xintmap_member,- xintmap_empty,- xintmap_freshkey,- xintmap_freshkeys,- xintmap_to_intmap,- xintmap_size,- xintmap_dirty,- xintmap_reserves,- xintmap_unreserves, - xintmap_makeclean,- - -- * Various map- and fold-like list combinators- loop,- loop_with_index,- fold_right_zip,- zip_strict,- zip_strict_errmsg,- zip_rightstrict,- zip_rightstrict_errmsg,- zipWith_strict,- zipWith_rightstrict,- - -- * Monadic versions of list combinators- loopM,- loop_with_indexM,- zipRightWithRightStrictM,- zipRightWithRightStrictM_,- fold_right_zipM,- foldRightPairM,- foldRightPairM_,- sequence_right,- sequence_right_,- - -- * Loops- -- $LOOPS- for,- endfor,- foreach,- - -- * Operations for monads- mmap,- monad_join1,- - -- * Operations for disjoint unions- map_either,- map_eitherM,- - -- * Operations for tuples- map_pair,- map_pairM,- - -- * Arithmetic operations- int_ceiling,- - -- * Bit vectors- Boollist(..),- boollist_of_int_bh,- boollist_of_int_lh,- int_of_boollist_unsigned_bh,- int_of_boollist_signed_bh,- bool_xor,- boollist_xor,- - -- * Formatting of lists and strings- string_of_list,- optional,- - -- * Lists optimized for fast concatenation- BList,- blist_of_list,- list_of_blist,- (+++),- blist_empty,- blist_concat,- - -- * Strings optimized for fast concatenation- Strbuf,- strbuf_of_string,- string_of_strbuf,- strbuf_empty,- strbuf_concat,- - -- * The identity monad- Id(..),- - -- * Identity types- Identity,- reflexivity,- symmetry,- transitivity,- identity,- - -- * Error messages- ErrMsg,- - -- * The Curry type class- Curry (..)- ) where---- import other stuff-import Data.List (foldl')--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 qualified Data.Traversable as Traversable--import Control.Applicative (Applicative(..))-import Control.Monad (liftM, ap)---- ------------------------------------------------------------------------- * List operations---- | Apply a function to a specified position in a list.-applyAt :: Int -> (a -> a) -> [a] -> [a]-applyAt _ _ [] = []-applyAt 0 f (x:xs) = (f x):xs-applyAt n f (x:xs) = x:(applyAt (n-1) f xs)---- | Overwrite an element at a specified position in a list.-overwriteAt :: Int -> a -> [a] -> [a]-overwriteAt n a = applyAt n (const a)---- | Check whether a list has duplicates.-has_duplicates :: Ord a => [a] -> Bool-has_duplicates list = aux list (Set.empty) where- aux [] _ = False- aux (h:t) set = if Set.member h set then True else aux t (Set.insert h set)---- | @'substitute' string character replacement@: --- Replace the first occurrence of /character/ in /string/ by /replacement/.-substitute :: (Eq a) => [a] -> a -> [a] -> [a]-substitute string character replacement = - case break (== character) string of- (x, []) -> x- (x, h:y) -> x ++ replacement ++ y---- ------------------------------------------------------------------------- * Set related operations---- | Insert the elements of a list in an 'IntSet' (cf. 'IntSet.insert').-intset_inserts :: [Int] -> IntSet -> IntSet-intset_inserts list set =- foldl' (\t x -> IntSet.insert x t) set list----- ------------------------------------------------------------------------- * Map related operations---- | Insert the given key-value pair in a 'Map', but only if the given--- key is not already present. If the key is present, keep the old--- value.-map_provide :: Ord k => k -> a -> Map k a -> Map k a-map_provide = Map.insertWith (\x y -> y)---- | Take two 'IntMap's /m/[sub 1] and /m/[sub 2], and form a new--- 'IntMap' whose domain is that of /m/[sub 2], and whose value at /k/--- is the pair (/m/[sub 1] ! /k/, /m/[sub 2] ! /k/). It is an error if--- the domain of /m/[sub 2] is not a subset of the domain of /m/[sub 1].-intmap_zipright :: IntMap x -> IntMap y -> IntMap (x, y)-intmap_zipright m1 m2 = m where- m = IntMap.mapWithKey f m2- f k y = case IntMap.lookup k m1 of- Just x -> (x, y)- Nothing -> error "intmap_zipright: shape mismatch"- --- | Take two 'IntMap's with the same domain, and form a new 'IntMap'--- whose values are pairs. It is an error if the two inputs don't have--- identical domains.-intmap_zip :: IntMap x -> IntMap y -> IntMap (x, y)-intmap_zip m1 m2 = intmap_zip_errmsg m1 m2 "intmap_zip: shape mismatch"- --- | Like 'intmap_zip', but also takes an error message to use in case of--- domain mismatch.-intmap_zip_errmsg :: IntMap x -> IntMap y -> String -> IntMap (x, y)-intmap_zip_errmsg m1 m2 errmsg = - if all (\k -> IntMap.member k m2) (IntMap.keys m1) - then intmap_zipright m1 m2- else error errmsg- --- | Map a function over all values in an 'IntMap'.-intmap_map :: (x -> y) -> IntMap x -> IntMap y-intmap_map = IntMap.map---- | Monadic version of 'intmap_map'. Map a function over all values--- in an 'IntMap'.-intmap_mapM :: (Monad m) => (x -> m y) -> IntMap x -> m (IntMap y)-intmap_mapM = Traversable.mapM---- ------------------------------------------------------------------------- * XIntMaps. ---- | A 'XIntMap' is just like an 'IntMap', except that it supports--- some additional efficient operations: to find the smallest unused--- key, to find the set of all keys ever used in the past, and to--- reserve a set of keys so that they will not be allocated. Moreover,--- it keeps track of the highest key ever used (whether or not it is--- still used in the current map).---- This is implemented as a tuple (/m/, /n/, /free/, /h/), where /m/ is an--- 'IntMap', /n/ is an integer such that dom /m/ ⊆ [0../n/-1], /free/--- ⊆ [0../n/-1] \\ dom /m/ is a set of integers not currently reserved--- or used, and /h/ is the set of all integers used in the past (the--- set of /touched/ wires).--data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet--instance (Show a) => Show (XIntMap a) where- show = show . xintmap_to_intmap- --- | Delete a key from the 'XIntMap'.-xintmap_delete :: Int -> XIntMap a -> XIntMap a-xintmap_delete k (XIntMap m n free h) = (XIntMap m' n free' h) where- m' = IntMap.delete k m- free' = IntSet.insert k free- --- | Delete a list of keys from a 'XIntMap'.-xintmap_deletes :: [Int] -> XIntMap a -> XIntMap a-xintmap_deletes list map =- foldl' (\map k -> xintmap_delete k map) map list---- | Insert a new key-value pair in the 'XIntMap'. -xintmap_insert :: Int -> a -> XIntMap a -> XIntMap a-xintmap_insert k v (XIntMap m n free h) = (XIntMap m' n' free' h') where- m' = IntMap.insert k v m- h' = IntSet.insert k h- n' = max n (k+1)- free' = IntSet.delete k (intset_inserts [n..n'-1] free)---- | Insert a list of key-value pairs in the 'XIntMap'.-xintmap_inserts :: [(Int,a)] -> XIntMap a -> XIntMap a-xintmap_inserts list map =- foldl' (\map (k,v) -> xintmap_insert k v map) map list---- | Look up the value at a key in the 'XIntMap'. Return 'Nothing' if--- not found.-xintmap_lookup :: Int -> XIntMap a -> Maybe a-xintmap_lookup k (XIntMap m n free h) =- IntMap.lookup k m---- | Check whether the given key is in the 'XIntMap'.-xintmap_member :: Int -> XIntMap a -> Bool-xintmap_member k (XIntMap m n free h) =- IntMap.member k m---- | The empty 'XIntMap'.-xintmap_empty :: XIntMap a-xintmap_empty = (XIntMap m n free h) where- m = IntMap.empty- n = 0- free = IntSet.empty- h = IntSet.empty---- | Return the first free key in the 'XIntMap', but without actually--- using it yet.-xintmap_freshkey :: XIntMap a -> Int-xintmap_freshkey (XIntMap m n free h) = - if IntSet.null free then n else IntSet.findMin free---- | Return the next /k/ unused keys in the 'XIntMap', but without--- actually using them yet.-xintmap_freshkeys :: Int -> XIntMap a -> [Int]-xintmap_freshkeys k (XIntMap m n free h) = ks1 ++ ks2 where- ks1 = take k (IntSet.elems free)- delta = k - (length ks1)- ks2 = [n .. n+delta-1]---- | Convert a 'XIntMap' to an 'IntMap'.-xintmap_to_intmap :: XIntMap a -> IntMap a-xintmap_to_intmap (XIntMap m n free h) = m---- | Return the smallest key never used in the 'XIntMap'.-xintmap_size :: XIntMap a -> Int-xintmap_size (XIntMap m n free k) = n---- | Return the set of all keys ever used in the 'XIntMap'.-xintmap_touched :: XIntMap a -> IntSet-xintmap_touched (XIntMap m n free h) = h ---- | A wire is /dirty/ if it is touched but currently free. -xintmap_dirty :: XIntMap a -> IntSet-xintmap_dirty (XIntMap m n free h) = h `IntSet.intersection` free---- | Reserve a key in the 'XIntMap'. If the key is not free, do--- nothing. The key must have been used before; for example, this is--- the case if it was returned by 'xintmap_dirty'.-xintmap_reserve :: Int -> XIntMap a -> XIntMap a-xintmap_reserve k (XIntMap m n free h) = (XIntMap m n free' h) where- free' = IntSet.delete k free- --- | Reserve a set of keys in the 'XIntMap'. For any keys that are not--- free, do nothing. All keys must have been used before; for example,--- this is the case if they were returned by 'xintmap_dirty'.-xintmap_reserves :: IntSet -> XIntMap a -> XIntMap a-xintmap_reserves ks (XIntMap m n free h) = (XIntMap m n free' h) where- free' = free `IntSet.difference` ks---- | Unreserve a key in the 'XIntMap'. If the key is currently used,--- do nothing. The key must have been reserved before, and (therefore)--- must have been used before.-xintmap_unreserve :: Int -> XIntMap a -> XIntMap a-xintmap_unreserve k (XIntMap m n free h) - | IntMap.member k m = (XIntMap m n free h)- | otherwise = (XIntMap m n free' h)- where- free' = IntSet.insert k free---- | Unreserve a list of keys in the 'XIntMap'. If any key is--- currently used, do nothing. All keys must have been reserved--- before, and (therefore) must have been used before.-xintmap_unreserves :: IntSet -> XIntMap a -> XIntMap a-xintmap_unreserves ks map = - IntSet.fold (\k map -> xintmap_unreserve k map) map ks---- | Make an exact copy of the 'XIntMap', except that the set of--- touched wires is initially set to the set of used wires. In other--- words, we mark all free and reserved wires as untouched.-xintmap_makeclean :: XIntMap a -> XIntMap a-xintmap_makeclean (XIntMap m n free h) = (XIntMap m n free h') where- h' = IntMap.keysSet m---- ------------------------------------------------------------------------- * Map- and fold-like list combinators---- ** Combinators for looping---- | Like 'loop', but also pass a loop counter to the function being--- iterated. Example:--- --- > loop_with_index 3 x f = f 2 (f 1 (f 0 x))-loop_with_index :: (Eq int, Num int) => int -> t -> (int -> t -> t) -> t-loop_with_index n x f = aux 0 x- where- aux i x = if i == n then x else aux (i+1) (f i x)---- | Monadic version of 'loop_with_index'. Thus, --- --- > loop_with_indexM 3 x0 f--- --- will do the following:--- --- > do--- > x1 <- f 0 x0--- > x2 <- f 1 x1--- > x3 <- f 2 x2 --- > return x3-loop_with_indexM :: (Eq int, Num int, Monad m) => int -> t -> (int -> t -> m t) -> m t-loop_with_indexM n x f = aux 0 x- where- aux i x =- if i == n then return x else do- x <- f i x- aux (i+1) x---- | Iterate a function /n/ times. Example: --- --- > loop 3 x f = f (f (f x))-loop :: (Eq int, Num int) => int -> t -> (t -> t) -> t-loop n x f = loop_with_index n x (\_ -> f)---- | Monadic version of 'loop'.-loopM :: (Eq int, Num int, Monad m) => int -> t -> (t -> m t) -> m t-loopM n x f = loop_with_indexM n x (\_ -> f)---- ** Combinators for sequencing---- | A right-to-left version of 'sequence': Evaluate each action in the--- sequence from right to left, and collect the results.-sequence_right :: Monad m => [m a] -> m [a]-sequence_right [] = return []-sequence_right (x:xs) = do- ys <- sequence_right xs- y <- x- return (y:ys)---- | Same as 'sequence_right', but ignore the result.-sequence_right_ :: Monad m => [m a] -> m ()-sequence_right_ [] = return ()-sequence_right_ (x:xs) = do- ys <- sequence_right_ xs- y <- x- return ()---- ** Combinators for zipping---- | A \"strict\" version of 'zip', i.e., raises an error when the--- lists are not of the same length.-zip_strict :: [a] -> [b] -> [(a, b)]-zip_strict a b = zip_strict_errmsg a b "zip_strict: lists are not of the same length"---- | Like 'zip_strict', but also takes an explicit error message to--- use in case of failure.-zip_strict_errmsg :: [a] -> [b] -> String -> [(a, b)]-zip_strict_errmsg [] [] e = []-zip_strict_errmsg (h:t) (h':t') e = (h,h') : zip_strict_errmsg t t' e-zip_strict_errmsg _ _ e = error e---- | A \"right strict\" version of 'zip', i.e., raises an error when the--- left list is shorter than the right one. -zip_rightstrict :: [a] -> [b] -> [(a, b)]-zip_rightstrict a b = zip_rightstrict_errmsg a b "zip_rightstrict: list too short"---- | A version of 'zip_rightstrict' that also takes an explicit error--- message to use in case of failure.-zip_rightstrict_errmsg :: [a] -> [b] -> String -> [(a, b)]-zip_rightstrict_errmsg _ [] s = []-zip_rightstrict_errmsg (h:t) (h':t') s = (h,h') : zip_rightstrict_errmsg t t' s-zip_rightstrict_errmsg _ _ s = error s---- | A \"strict\" version of 'zipWith', i.e., raises an error when the--- lists are not of the same length.-zipWith_strict :: (a -> b -> c) -> [a] -> [b] -> [c]-zipWith_strict f [] [] = []-zipWith_strict f (h:t) (h':t') = f h h' : zipWith_strict f t t'-zipWith_strict f _ _ = error "zipWith_strict: lists are not of the same length"---- | A \"right strict\" version of 'zipWith', i.e., raises an error when the--- right list is shorter than the left one.-zipWith_rightstrict :: (a -> b -> c) -> [a] -> [b] -> [c]-zipWith_rightstrict f _ [] = []-zipWith_rightstrict f (h:t) (h':t') = f h h' : zipWith_rightstrict f t t'-zipWith_rightstrict f _ _ = error "zipWith_rightstrict: list too short"---- | A right-to-left version of 'zipWithM', which is also \"right--- strict\", i.e., raises an error when the right list is shorter than--- the left one. Example:--- --- > zipRightWithM f [a,b] [x,y] = [f a x, f b y],--- --- computed right-to-left.-zipRightWithRightStrictM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]-zipRightWithRightStrictM f l1 l2 =- sequence_right $ zipWith_rightstrict f l1 l2---- | Same as 'zipRightWithM', but ignore the result.-zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()-zipRightWithRightStrictM_ f l1 l2 =- sequence_right_ $ zipWith_rightstrict f l1 l2---- ** Combinators combining mapping with folding---- | Fold over two lists with state, and do it right-to-left. For example,--- --- > foldRightPairM (w0, [1,2,3], [a,b,c]) f--- --- will do the following:--- --- > do--- > w1 <- f (w0, 3, c)--- > w2 <- f (w1, 2, b)--- > w3 <- f (w2, 1, a)--- > return w3-foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w-foldRightPairM (w, [], _) f = return w-foldRightPairM (w, _, []) f = return w-foldRightPairM (w, a:as, b:bs) f = do- w <- foldRightPairM (w, as, bs) f- w <- f (w, a, b)- return w---- | Like 'foldRightPairM', but ignore the final result.-foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m ()-foldRightPairM_ x f = do- foldRightPairM x f- return ()---- | Combine right-to-left zipping and folding. Example:--- --- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c'])--- > where f (w0,c,z) = (w1,c')--- > f (w1,b,y) = (w2,b')--- > f (w2,a,x) = (w3,a')-fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c])-fold_right_zip f (w, [], []) = (w, [])-fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb')- where- (w1, bb') = fold_right_zip f (w, bb, yy)- (w2, a') = f (w1, a, x)-fold_right_zip f _ = error "fold_right_zip"---- | Monadic version of 'fold_right_zip'.-fold_right_zipM ::- (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c])-fold_right_zipM f (w, [], []) = return (w, [])-fold_right_zipM f (w, a:bb, x:yy) = do- (w1, bb') <- fold_right_zipM f (w, bb, yy)- (w2, a') <- f (w1, a, x)- return (w2, a':bb')-fold_right_zipM f _ = error "fold_right_zipM"---- ------------------------------------------------------------------------- * Loops.---- $LOOPS We provide a syntax for \"for\"-style loops.---- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/.--- --- Standard notation: --- --- > for i = a to b by s do--- > commands --- > end for--- --- Our notation: --- --- > for a b s $ \i -> do--- > commands--- > endfor--for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m()-for a b s f = if s > 0 then aux a (<= b) else aux a (>= b)- where- aux i cond = - if cond i then do- f i- aux (i+s) cond- else- return ()---- | Mark the end of a \"for\"-loop. This command actually does--- nothing, but can be used to make the loop look prettier.-endfor :: Monad m => m()-endfor = return ()---- | Iterate a parameter over a list of values. It can be used as--- follows:--- --- > foreach [1,2,3,4] $ \n -> do--- > <<<loop body depending on the parameter n>>>--- > endfor--- --- The loop body will get executed once for each /n/ ∈ {1,2,3,4}.--foreach :: Monad m => [a] -> (a -> m b) -> m ()-foreach l f = mapM_ f l---- ------------------------------------------------------------------------- * Operations for monads---- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output--- /m/ /f/ : /m/ /a/ → /m/ /b/.-mmap :: (Monad m) => (a -> b) -> m a -> m b-mmap f a = a >>= (return . f)---- | Remove an outer application of a monad from a monadic function.-monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b-monad_join1 mf a = do- f <- mf- f a---- ------------------------------------------------------------------------- * Operations for disjoint unions---- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return--- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/.-map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d-map_either f g (Left x) = Left (f x)-map_either f g (Right x) = Right (g x)---- | Monadic version of 'map_either'.-map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)-map_eitherM f g (Left x) = mmap Left (f x)-map_eitherM f g (Right x) = mmap Right (g x)---- ------------------------------------------------------------------------- * Operations for tuples---- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return--- /f/ × /g/ : /a/ × /c/ → /c/ × /d/.-map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)-map_pair f g (x, y) = (f x, g y)---- | Monadic version of 'mappair'.-map_pairM :: (Monad m) => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d)-map_pairM f g (a, c) = do- b <- f a- d <- g c- return (b, d)---- ------------------------------------------------------------------------- * Arithmetic operations- --- | A version of the 'ceiling' function that returns an 'Integer'.-int_ceiling :: RealFrac a => a -> Integer-int_ceiling = toInteger . ceiling---- ------------------------------------------------------------------------- * Bit vectors---- | The type of bit vectors. True = 1, False = 0.-type Boollist = [Bool]---- | Convert an integer to a bit vector. The first argument is the--- length in bits, and the second argument the integer to be--- converted. The conversion is big-headian (or equivalently,--- little-tailian), i.e., the head of the list holds the integer's most--- significant digit.-boollist_of_int_bh :: Integral a => Int -> a -> Boollist-boollist_of_int_bh m = reverse . boollist_of_int_lh m---- | Convert an integer to a bit vector. The first argument is the--- length in bits, and the second argument the integer to be--- converted. The conversion is little-headian (or equivalently,--- big-tailian), i.e., the head of the list holds the integer's least--- significant digit.-boollist_of_int_lh :: Integral a => Int -> a -> Boollist-boollist_of_int_lh m x | m <= 0 = []-boollist_of_int_lh m x = digit : boollist_of_int_lh (m-1) tail where- digit = (x `mod` 2 == 1)- tail = x `div` 2---- | Convert a bit vector to an integer. The conversion is big-headian--- (or equivalently, little-tailian), i.e., the head of the list holds--- the integer's most significant digit. This function is unsigned,--- i.e., the integer returned is ≥ 0.-int_of_boollist_unsigned_bh :: Integral a => Boollist -> a-int_of_boollist_unsigned_bh v = aux v 0- where- aux v acc =- case v of- [] -> acc- digit : vs -> aux vs (2*acc+(if digit then 1 else 0))---- | Convert a bit vector to an integer, signed.-int_of_boollist_signed_bh :: Integral a => Boollist -> a-int_of_boollist_signed_bh [] = 0-int_of_boollist_signed_bh (False:v) = int_of_boollist_unsigned_bh v-int_of_boollist_signed_bh (True:v) = -1 - int_of_boollist_unsigned_bh (map not v)---- | Exclusive or operation on booleans.-bool_xor :: Bool -> Bool -> Bool-bool_xor a b = (a /= b)---- | Exclusive or operation on bit vectors.-boollist_xor :: Boollist -> Boollist -> Boollist-boollist_xor = zipWith bool_xor---- ------------------------------------------------------------------------- * Formatting of lists and strings---- | A general list-to-string function. Example:--- --- > string_of_list "{" ", " "}" "{}" show [1,2,3] = "{1, 2, 3}"-string_of_list :: String -> String -> String -> String -> (t -> String) -> [t] -> String-string_of_list lpar comma rpar nil string_of_elt lst =- let string_of_tail lst =- case lst of- [] -> ""- h:t -> comma ++ string_of_elt h ++ string_of_tail t- in- case lst of- [] -> nil- h:t -> lpar ++ string_of_elt h ++ string_of_tail t ++ rpar---- | @'optional' b s@: if /b/ = 'True', return /s/, else the empty--- string. This function is for convenience.-optional :: Bool -> String -> String-optional True s = s-optional False s = ""---- ------------------------------------------------------------------------- * Lists optimized for fast concatenation---- | The type of bidirectional lists. This is similar to [a], but--- optimized for fast concatenation and appending on both sides.-newtype BList a = BList { getBList :: [a] -> [a] }---- | Convert a List to a 'BList'.-blist_of_list :: [a] -> BList a-blist_of_list s = BList (\x -> s ++ x)---- | Convert a 'BList' to a List.-list_of_blist :: BList a -> [a]-list_of_blist buf = getBList buf []---- | Fast concatenation of 'BList's or string buffers.-(+++) :: BList a -> BList a -> BList a-(+++) buf1 buf2 = BList ((getBList buf1) . (getBList buf2))---- | The empty 'BList'.-blist_empty :: BList a-blist_empty = BList id---- | Concatenate a list of 'Blist's.-blist_concat :: [BList a] -> BList a-blist_concat l = foldr (+++) blist_empty l--instance (Show a) => Show (BList a) where- show bl = show (list_of_blist bl) ---- ------------------------------------------------------------------------- * Strings optimized for fast concatenation---- | A string buffer holds a string that is optimized for fast--- concatenation. Note that this is an instance of 'BList', and hence--- 'BList' operations (in particular '+++') can be applied to string--- buffers. The following functions are synonyms of the respective--- 'BList' functions, and are provided for convenience.-type Strbuf = BList Char---- | Convert a string to a string buffer.-strbuf_of_string :: String -> Strbuf-strbuf_of_string = blist_of_list---- | Convert a string buffer to a string.-string_of_strbuf :: Strbuf -> String-string_of_strbuf = list_of_blist---- | The empty string buffer.-strbuf_empty :: Strbuf-strbuf_empty = blist_empty---- | Concatenate a list of string buffers.-strbuf_concat :: [Strbuf] -> Strbuf-strbuf_concat = blist_concat---- ------------------------------------------------------------------------- * The identity monad- --- | The identity monad. Using /m/ = 'Id' gives useful special cases--- of monadic functions.-newtype Id a = Id { getId :: a }--instance Monad Id where- return a = Id a- (Id a) >>= b = b a--instance Applicative Id where- pure = return- (<*>) = ap--instance Functor Id where- fmap = liftM---- ------------------------------------------------------------------------- * Identity types- --- | The type 'Identity' /a/ /b/ witnesses the fact that /a/ and /b/--- are the same type. In other words, this type is non-empty if and--- only if /a/ = /b/. This property is not guaranteed by the type--- system, but by the API, via the fact that the operators--- 'relexivity', 'symmetry', and 'transitivity' are the only exposed--- constructors for this type. The implementation of this type is--- deliberately hidden, as this is the only way to guarantee its--- defining property.--- --- Identity types are useful in certain situations. For example, they--- can be used to define a data type which is polymorphic in some type--- variable /x/, and which has certain constructors that are only--- available when /x/ is a particular type. For example, in the--- declaration--- --- > data ExampleType x = Constructor1 x | Constructor2 x (Identity x Bool),--- --- @Constructor1@ is available for all /x/, but @Constructor2@ is only--- available when /x/ = 'Bool'.-newtype Identity a b = Identity (a -> b, b -> a)---- | Witness the fact that /a/=/a/.-reflexivity :: Identity a a-reflexivity = Identity (id, id)---- | Witness the fact that /a/=/b/ implies /b/=/a/.-symmetry :: Identity a b -> Identity b a-symmetry (Identity (f,g)) = Identity (g,f)---- | Witness the fact that /a/=/b/ and /b/=/c/ implies /a/=/c/.-transitivity :: Identity a b -> Identity b c -> Identity a c-transitivity (Identity (f,g)) (Identity (f',g')) = Identity (f'',g'') where- f'' = f' . f- g'' = g . g'---- | The identity function 'id' : /a/ → /b/, provided that /a/ and /b/--- are the same type.-identity :: Identity a b -> a -> b-identity (Identity (f,g)) = f--instance Show (Identity a b) where- show x = "id"---- ------------------------------------------------------------------------- * Isomorphism types---- | The type 'Isomorphism' /a/ /b/ consists of isomorphisms between--- /a/ and /b/, i.e. pairs (/f/,/g/) such that /g/./f/ == id :: /a/ -> /a/,--- /f/./g/ == id :: /b/ -> /b/. ------ As with e.g. Haskell’s 'Monad' class, it is not possible in general--- to guarantee that the intended laws hold; it is the programmer’s--- responsibility to ensure this.------ Under the hood, 'Isomorphism' and 'Identity' are in fact the same;--- they differ just in the API exposed. -newtype Isomorphism a b = Isomorphism (a -> b, b -> a)---- | Map forwards along an isomorphism.-iso_forwards :: Isomorphism a b -> a -> b-iso_forwards (Isomorphism (f,g)) = f---- | Map backwards along an isomorphism.-iso_backwards :: Isomorphism a b -> b -> a-iso_backwards (Isomorphism (f,g)) = g---- ======================================================================--- * Error messages---- | Often a low-level function, such as 'qcdata_zip' and--- 'qcdata_promote', throws an error because of a failure of some--- low-level condition, such as \"list too short\". To produce error--- messages that are meaningful to user-level code, these functions do--- not have a hard-coded error message. Instead, they input a stub--- error message.--- --- A meaningful error message typically consists of at least three parts:--- --- * the name of the user-level function where the error occurred, for--- example: \"reverse_generic\";--- --- * what the function was doing when the error occurred, for example:--- \"operation not permitted in reversible circuit\";--- --- * a specific low-level reason for the error, for example: \"dynamic--- lifting\".--- --- Thus, a meaningful error message may be: \"reverse_generic:--- operation not permitted in reversible circuit: dynamic lifting\".--- --- The problem is that the three pieces of information are not usually--- present in the same place. The user-level function is often a--- wrapper function that performs several different mid-level--- operations (e.g., transforming, reversing). The mid-level function--- knows what operation was being performed when the error occurred,--- but often calls a lower-level function to do the actual work (e.g.,--- encapsulating).--- --- Therefore, a stub error message is a function that inputs some--- lower-level reason for a failure (example: \"list too short\") and--- translates this into a higher-level error message (example:--- \"qterm: shape of parameter does not data: list too short\").--- --- Sometimes, the stub error message may also ignore the low-level--- message and completely replace it by a higher-level one. For--- example, a function that implements integers as bit lists may wish--- to report a problem with integers, rather than a problem with the--- underlying lists.-type ErrMsg = String -> String---- ======================================================================--- * The Curry type class---- | The 'Curry' type class is used to implement functions that have a--- variable number of arguments. It provides a family of type--- isomorphisms--- --- @fun ≅ args -> res,@--- --- where--- --- > fun = a1 -> a2 -> ... -> an -> res,--- > args = (a1, (a2, (..., (an, ())))).--class Curry fun args res | args res -> fun where- -- | Multiple curry: map a function - -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ - -- to its curried form - -- /a/[sub 1] → /a/[sub 2] → … → /b/.- mcurry :: (args -> res) -> fun- -- | Multiple uncurry: map a function- -- /a/[sub 1] → /a/[sub 2] → … → /b/- -- to its uncurried form - -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/.- muncurry :: fun -> (args -> res)- -instance Curry b () b where- mcurry g = g ()- muncurry x = const x--instance Curry fun args res => Curry (a -> fun) (a,args) res where- mcurry g x = mcurry (\xs -> g (x,xs))- muncurry f (x,xs) = muncurry (f x) xs-
− src/Libraries/CommandLine.hs
@@ -1,72 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | This module provides some functions that are useful in the--- processing of command line options, and that are shared between--- several algorithms.--module Libraries.CommandLine where--import Libraries.Auxiliary (string_of_list)---- import other stuff-import System.Exit-import System.IO-import Data.List-import Data.Char---- ------------------------------------------------------------------------- * Option processing- --- | Exit with an error message after a command line error. This also--- outputs information on where to find command line help.-optfail :: String -> IO a-optfail msg = do- hPutStr stderr msg- hPutStrLn stderr "Try --help for more info."- exitFailure---- | Parse a string to an integer, or return 'Nothing' on failure.-parse_int :: (Integral r) => String -> Maybe r-parse_int s = case reads s of- [(n, "")] -> Just (fromInteger n)- _ -> Nothing---- | Parse a string to a list of integers, or return 'Nothing' on failure.-parse_list_int :: String -> Maybe [Int] -parse_list_int s = case reads s of- [(ns, "")] -> Just ns- _ -> Nothing---- | Parse a string to a 'Double', or return 'Nothing' on failure.-parse_double :: String -> Maybe Double-parse_double s = case reads s of- [(n, "")] -> Just n- _ -> Nothing---- | In an association list, find the key that best matches the given--- string. If one key matches exactly, return the corresponding--- key-value pair. Otherwise, return a list of all key-value pairs--- whose key have the given string as a prefix. This list could be of--- length 0 (no match), 1 (unique match), or greater (ambiguous key).--- Note: the keys in the association list must be lower case. The--- input string is converted to lower case as well, resulting in--- case-insensitive matching.-match_enum :: [(String, a)] -> String -> [(String, a)]-match_enum list key =- case lookup s list of- Just v -> [(s,v)]- Nothing -> filter (\(k,v) -> isPrefixOf s k) list- where- s = map toLower key- --- | Pretty-print a list of possible values for a parameter. The--- first argument is the name of the parameter, and the second--- argument is its enumeration.-show_enum :: String -> [(String, a)] -> String -show_enum param list =- "Possible values for " ++ param ++ " are: " ++- string_of_list "" ", " "" "no possible values" fst list ++ ".\n"
− src/Libraries/PortableSignals.hs
@@ -1,139 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE CPP #-}---- | This module provides a thin portability layer for handling user--- interrupts.--- --- The reason is that in the standard Haskell library, this--- functionality is only available in operating system specific--- modules, namely "System.Posix.Signals" (for POSIX systems,--- including Linux) and "GHC.ConsoleHandler" (for Windows).--- --- Note that despite this compatibility layer, there are some--- operating system specific quirks:--- --- * In Windows, console events (such as Control-C) can only be--- received by an application running in a Windows console. Certain--- environments that look like consoles do not support console events,--- such as xterm and rxvt windows, and Cygwin shells with @CYGWIN=tty@--- set.--- --- * In Windows, setting a handler for any one signal automatically--- overrides the handlers for all signals (effectively ignoring them).--- Also, if the 'Default' or 'Ignore' handler is specified, it--- applies to all signals. We do not currently provide a way to--- specify handlers for multiple signals.--module Libraries.PortableSignals (- Signal(..),- Handler(Default,Ignore,Catch,CatchOnce),- installHandler,- with_handler- ) where--#ifdef mingw32_HOST_OS-import qualified GHC.ConsoleHandler as OS-#else-import qualified System.Posix.Signals as OS-#endif- --- ------------------------------------------------------------------------- * Common interface---- | A data type for signals. This can be extended as needed.-data Signal =- Interrupt -- ^ Control-C event.- | Close -- ^ TERM signal (POSIX) or Close event (Windows).---- | A data type for handlers.-data Handler =- Default -- ^ Default action.- | Ignore -- ^ Ignore the signal.- | Catch (IO ()) -- ^ Handle the signal in a new thread when the signal is received.- | CatchOnce (IO ()) -- ^ Like 'Catch', but only handle the first such signal.- | OSHandler OS.Handler -- ^ An operating system specific handler.---- | Install a handler for the given signal. The old handler is--- returned. -installHandler :: Signal -> Handler -> IO Handler-#ifdef mingw32_HOST_OS-installHandler = installHandler_windows-#else-installHandler = installHandler_posix-#endif---- | Run a block of code with a given signal handler. The previous--- handler is restored when the block terminates.-with_handler :: Signal -> Handler -> IO a -> IO a-with_handler signal handler body = do- oldhandler <- installHandler signal handler- a <- body- installHandler signal oldhandler- return a---- ------------------------------------------------------------------------- * Windows specific code--#ifdef mingw32_HOST_OS---- | Check if the Windows 'ConsoleEvent' matches the given abstract--- 'Signal'. We implement this as a relation, rather than a function,--- to allow for more than one 'ConsoleEvent' to match the same--- 'Signal', or for more than one 'Signal' to match the same--- 'ConsoleEvent'.-signal_matches :: OS.ConsoleEvent -> Signal -> Bool-signal_matches OS.ControlC Interrupt = True-signal_matches OS.Close Close = True-signal_matches _ _ = False---- | Windows implementation of 'installHandler'.-installHandler_windows :: Signal -> Handler -> IO Handler-installHandler_windows signal handler = do- oldhandler <- OS.installHandler (oshandler handler)- return (OSHandler oldhandler)- where- oshandler Default = OS.Default- oshandler Ignore = OS.Ignore- oshandler (Catch body) = OS.Catch $ \event -> do- if signal_matches event signal- then body - else return ()- oshandler (CatchOnce body) = OS.Catch $ \event -> do- if signal_matches event signal - then do- -- uninstall the handler- OS.installHandler OS.Default- body- else return ()- oshandler (OSHandler h) = h- --- ------------------------------------------------------------------------- * POSIX specific code--#else---- | Map an abstract 'Signal' to a POSIX specific 'OS.Signal'.-ossignal :: Signal -> OS.Signal-ossignal Interrupt = OS.keyboardSignal-ossignal Close = OS.softwareTermination---- | Map a 'Handler' to a POSIX specific handler.-oshandler :: Handler -> OS.Handler-oshandler Default = OS.Default-oshandler Ignore = OS.Ignore-oshandler (Catch body) = OS.Catch body-oshandler (CatchOnce body) = OS.CatchOnce body-oshandler (OSHandler h) = h---- | POSIX implementation of 'installHandler'.-installHandler_posix :: Signal -> Handler -> IO Handler-installHandler_posix signal handler = do- oldhandler <- OS.installHandler (ossignal signal) (oshandler handler) Nothing- return (OSHandler oldhandler)--#endif
− src/Libraries/RandomSource.hs
@@ -1,25 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}---- | This module provides a container type for sources of--- randomness. This makes it possible for a source of randomness (any--- instance of the 'RandomGen' class) to be stored in a data structure--- without having to specify its type explicitly.--module Libraries.RandomSource where--import System.Random---- | A container type to hold a source of randomness. This can hold--- any instance of the 'RandomGen' class.-data RandomSource where- RandomSource :: forall g.(RandomGen g) => g -> RandomSource--instance Show RandomSource where- show x = "g"
− src/Libraries/Sampling.hs
@@ -1,285 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}---- ----------------------------------------------------------------------- | This module provides functions for generating lists of samples--- from a range of input values. This is primarily useful for--- generating test cases. Ranges can be specified for types that are--- members of the 'Interval' class. Each sampling procedure generates--- a (finite or infinite) list of values from the range. We provide--- sampling procedures for--- --- * generating the range in its entirety ('sample_all')--- --- * sampling every /n/th element from a range ('sample_step')--- --- * generating a random sample from the range ('sample_random')--module Libraries.Sampling (- - -- * Interval class- Interval(..),- - -- * Zero class- Zero(..),- - -- * Random class- -- $Random- Random,- - -- * Functions- sample_all,- sample_step,- sample_random,- sample_all0,- sample_step0,- sample_random0 - ) where--import Libraries.Tuple--import System.Random-import Data.Tuple-import Data.List---- ----------------------------------------------------------------------- | The 'Interval' class contains types for which an interval of--- values can be specified by giving a lower bound and an upper--- bound. Intervals are specified as @'interval' min max@, for--- example: --- --- > interval (0,0) (1,2) = [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)].--class Interval a where- -- | Takes a range (/min/,/max/) and returns a list of all values with- -- lower bound /min/ and upper bound /max/.- interval :: a -> a -> [a]--instance Interval Int where- interval x y = [x..y]- -instance Interval Integer where- interval x y = [x..y]--instance Interval Double where- interval x y = [x..y]- -instance Interval Bool where- interval x y = [x..y]--instance Interval () where- interval () () = [()]- -instance (Interval a, Interval b) => Interval (a,b) where- interval (x0,y0) (x1,y1) = [ (x,y) | x <- interval x0 x1, y <- interval y0 y1 ]--instance (Interval a, Interval b, Interval c) => Interval (a,b,c) where- interval x y = map tuple (interval (untuple x) (untuple y))- -instance (Interval a, Interval b, Interval c, Interval d) => Interval (a,b,c,d) where- interval x y = map tuple (interval (untuple x) (untuple y))- -instance (Interval a, Interval b, Interval c, Interval d, Interval e) => Interval (a,b,c,d,e) where- interval x y = map tuple (interval (untuple x) (untuple y))- -instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f) => Interval (a,b,c,d,e,f) where- interval x y = map tuple (interval (untuple x) (untuple y))- -instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f, Interval g) => Interval (a,b,c,d,e,f,g) where- interval x y = map tuple (interval (untuple x) (untuple y))- -instance Interval a => Interval [a] where- interval x y = l where- xy = safe_zip x y "interval: upper and lower bound contain lists of non-matching lengths"- l = aux xy- aux [] = [[]]- aux ((x,y):t) = [ h:t' | h <- interval x y, t' <- aux t ]---- ----------------------------------------------------------------------- | Types in the 'Zero' class have an \"origin\", i.e., an element--- that can conveniently serve as the starting point for intervals.--class Zero a where- -- | Inputs any element of the type and outputs the corresponding- -- \"zero\" element, for example:- -- - -- > zero ([1,2],3,True) = ([0,0],0,False)- zero :: a -> a- -instance Zero Int where- zero _ = 0- -instance Zero Integer where- zero _ = 0--instance Zero Double where- zero _ = 0--instance Zero Bool where- zero _ = False--instance Zero () where- zero () = ()--instance (Zero a, Zero b) => Zero (a,b) where- zero (a,b) = (zero a, zero b)- -instance (Zero a, Zero b, Zero c) => Zero (a,b,c) where- zero x = tuple (zero (untuple x))- -instance (Zero a, Zero b, Zero c, Zero d) => Zero (a,b,c,d) where- zero x = tuple (zero (untuple x))- -instance (Zero a, Zero b, Zero c, Zero d, Zero e) => Zero (a,b,c,d,e) where- zero x = tuple (zero (untuple x))- -instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f) => Zero (a,b,c,d,e,f) where- zero x = tuple (zero (untuple x))- -instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f, Zero g) => Zero (a,b,c,d,e,f,g) where- zero x = tuple (zero (untuple x))- -instance Zero a => Zero [a] where- zero l = map zero l- --- ----------------------------------------------------------------------- $Random --- We extend the class 'System.Random' with tuples and lists.---- | 0-tuples-instance Random () where- randomR ((),()) g = ((), g)- random g = ((), g)---- | Pairs-instance (Random a, Random b) => Random (a,b) where- randomR ((a0,b0),(a1,b1)) g = ((a,b), g'') where- (a,g') = randomR (a0,a1) g- (b,g'') = randomR (b0,b1) g'- random g = ((a,b), g'') where- (a,g') = random g- (b,g'') = random g'---- | Triples-instance (Random a, Random b, Random c) => Random (a,b,c) where- randomR (a,b) g = (t, g') where- a1 = untuple a- b1 = untuple b- (t1,g') = randomR (a1,b1) g- t = tuple t1- random g = (t, g') where- (t1,g') = random g- t = tuple t1---- | 4-Tuples-instance (Random a, Random b, Random c, Random d) => Random (a,b,c,d) where- randomR (a,b) g = (t, g') where- a1 = untuple a- b1 = untuple b- (t1,g') = randomR (a1,b1) g- t = tuple t1- random g = (t, g') where- (t1,g') = random g- t = tuple t1---- | 5-Tuples-instance (Random a, Random b, Random c, Random d, Random e) => Random (a,b,c,d,e) where- randomR (a,b) g = (t, g') where- a1 = untuple a- b1 = untuple b- (t1,g') = randomR (a1,b1) g- t = tuple t1- random g = (t, g') where- (t1,g') = random g- t = tuple t1---- | 6-Tuples-instance (Random a, Random b, Random c, Random d, Random e, Random f) => Random (a,b,c,d,e,f) where- randomR (a,b) g = (t, g') where- a1 = untuple a- b1 = untuple b- (t1,g') = randomR (a1,b1) g- t = tuple t1- random g = (t, g') where- (t1,g') = random g- t = tuple t1---- | 7-Tuples-instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) => Random (a,b,c,d,e,f,g) where- randomR (a,b) g = (t, g') where- a1 = untuple a- b1 = untuple b- (t1,g') = randomR (a1,b1) g- t = tuple t1- random g = (t, g') where- (t1,g') = random g- t = tuple t1---- | Lists-instance Random a => Random [a] where- randomR (a,b) g = (l, g') where- ab = safe_zip a b "randomR: upper and lower bound contain lists of non-matching lengths"- (g', l) = mapAccumL (\g r -> swap $ randomR r g) g ab- random g = ([a], g') where- (a, g') = random g---- ----------------------------------------------------------------------- Functions:---- | @'sample_all' min max@: --- returns a list of all elements from the range (/min/,/max/). This--- is actually just a synonym of 'interval'.-sample_all :: Interval a => a -> a -> [a]-sample_all = interval---- | @'sample_step' n k min max@: --- returns every /n/th element from the range (/min/,/max/), starting--- with the /k/th element.-sample_step :: (Integral a, Integral b, Interval c) => a -> b -> c -> c -> [c]-sample_step n k x y = list_step n k (interval x y)---- | @'sample_random' g min max@: --- returns an infinite list of random samples from the range--- (/min/,/max/), using the random number generator /g/.-sample_random :: (Random a, RandomGen g) => g -> a -> a -> [a]-sample_random g x y = randomRs (x,y) g---- | A variant of 'sample_all' that omits the /min/ argument, and uses--- the 'zero' element of the type instead.-sample_all0 :: (Zero a, Interval a) => a -> [a]-sample_all0 a = sample_all (zero a) a---- | A variant of 'sample_step' that omits the /min/ argument, and uses--- the 'zero' element of the type instead.-sample_step0 :: (Integral a, Integral b, Zero c, Interval c) => a -> b -> c -> [c]-sample_step0 n k a = sample_step n k (zero a) a---- | A variant of 'sample_random' that omits the /min/ argument, and uses--- the 'zero' element of the type instead.-sample_random0 :: (Random a, Zero a, RandomGen g) => g -> a -> [a]-sample_random0 g a = sample_random g (zero a) a---- ----------------------------------------------------------------------- Local functions:---- | samples every /n/th element from the list, starting with element /k/-list_step :: (Integral a, Integral b) => a -> b -> [c] -> [c]-list_step n k [] = []-list_step n k (h:t) =- if k==0 then - h:(list_step n (n-1) t) - else- list_step n (k-1) t- --- | same as 'zip', but throw an error if length don't match-safe_zip :: [a] -> [b] -> String -> [(a,b)]-safe_zip l1 l2 msg = - if length l1 == length l2 - then zip l1 l2- else error msg
− src/Libraries/Template.hs
@@ -1,67 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | This module provides the public interface to the template lifting--- library. It provides functions that input a Haskell declaration or--- expression (in the form of a Haskell abstract syntax tree), and--- lift this to another declaration or expression, with all functions--- lifted into a specified monad.--- --- This can be combined with Template Haskell to convert source code--- to Haskell abstract syntax trees and vice versa.--module Libraries.Template (- -- * Example- -- $EXAMPLE- - -- * General lifting functions- decToMonad,- expToMonad,- - -- * Liftings of specific constants- module Libraries.Template.Auxiliary- ) where--import Libraries.Template.Lifting-import Libraries.Template.Auxiliary---- $EXAMPLE --- --- We give an example to illustrate what is meant by \"lifting\" a--- term to a monad. Consider the expression--- --- > f = \g x -> g x x,--- --- which has type--- --- > f :: (a -> a -> b) -> (a -> b).--- --- We can lift this to the 'IO' monad by --- --- * converting the expression to an abstract syntax tree, using the--- special Template Haskell notation [nobr @[| ... |]@];--- --- * applying the 'expToMonad' function;--- --- * converting the resulting abstract syntax tree back to a term,--- using the special Template Haskell notation [nobr @$( ... )@].--- --- This allows us to write the following:--- --- > f' = $( expToMonad "IO" [| \g x -> g x x |] ),--- --- which has type--- --- > f' :: IO ((a -> IO (a -> IO b)) -> IO (a -> IO b)),--- --- and is in fact equivalent to--- --- > f'' = return $ \g ->--- > return $ \x -> do--- > h <- g x--- > y <- h x--- > return y-
− src/Libraries/Template/Auxiliary.hs
@@ -1,88 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}---- | This module is for use with "Libraries.Template.Lifting". --- It contains various lifted functions of general use. They are not--- intended to be used directly (although this would not break--- anything).--module Libraries.Template.Auxiliary where--import Libraries.Auxiliary (fold_right_zip,fold_right_zipM)-import Data.List-import Control.Monad---- ------------------------------------------------------------------------- * List operations---- | Lifted version of @'(:)' :: a -> [a] -> [a]@.-template_symb_colon_ :: Monad m => m (a -> m ([a] -> m [a]))-template_symb_colon_ = return $ \h -> return $ \t -> return (h:t)---- | Lifted version of @'[]' :: [a]@.-template_symb_obracket_symb_cbracket_ :: Monad m => m [a]-template_symb_obracket_symb_cbracket_ = return []---- | Lifted version of @'init' :: [a] -> [a]@.-template_init :: Monad m => m ([a] -> m [a])-template_init = return $ \l -> return (init l)---- | Lifted version of @'last' :: [a] -> [a]@.-template_last :: Monad m => m ([a] -> m a)-template_last = return $ \l -> return (last l)---- | Lifted version of @'(++)' :: [a] -> [a] -> [a]@.-template_symb_plus_symb_plus_ :: Monad m => m ([a] -> m ([a] -> m [a]))-template_symb_plus_symb_plus_ = return $ \l1 -> return $ \l2-> return (l1 ++ l2)---- | Lifted version of 'zip3'.-template_zip3 :: Monad m => m ([a] -> m ([b] -> m ([c] -> m [(a,b,c)])))-template_zip3 = return $ \x -> return $ \y -> return $ \z -> return (zip3 x y z)---- | lifted version of @'foldl'@-template_foldl :: Monad m => m ((a -> m (b -> m a)) -> m (a -> m ([b] -> m a)))-template_foldl = return $ \f -> return $ \a -> return $ \lb -> foldM (auxf f) a lb- where auxf f a b = do- g <- f a- g b---- | lifted version of @'reverse'@-template_reverse :: Monad m => m ([a] -> m [a])-template_reverse = return $ \x -> return (reverse x)----- | lifted version of @'zipWith'@-template_zipWith :: Monad m => m ((a -> m (b -> m c)) -> m ([a] -> m ([b] -> m [c])))-template_zipWith = return $ \f -> return $ \a -> return $ \b -> zipWithM (auxf f) a b- where auxf f a b = do- g <- f a- g b---- | Lifted version of @'fold_right_zip'@-template_fold_right_zip :: - Monad m => m (((a,b,c) -> m (a,d)) -> m ((a,[b],[c]) -> m (a,[d])))-template_fold_right_zip = return $ \f -> return $ \x -> (fold_right_zipM f x)---- ------------------------------------------------------------------------- * Other operations---- | Lifted version of the combinator '$'.-template_symb_dollar_ :: Monad m => m ((a -> m b) -> m (a -> m b))-template_symb_dollar_ = return $ \f -> return $ \x -> f x---- | Lifted version of @'error' :: String -> a@. Using it will make the--- circuit generation fail with the error described in 'String'.-template_error :: Monad m => m (String -> m a)-template_error = return $ error---- | Lifted version of @'snd' :: (a,b) -> b@-template_snd :: Monad m => m ((a,b) -> m b)-template_snd = return $ \(a,b) -> return b--
− src/Libraries/Template/ErrorMsgQ.hs
@@ -1,62 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | This module provides a simple monad to encapsulate error--- messages within the 'Q' monad.--module Libraries.Template.ErrorMsgQ where--import Language.Haskell.TH--import Control.Applicative (Applicative(..))-import Control.Monad (liftM, ap)---- | Shortcut for 'Either String a'.-type ErrMsg a = Either String a---- | Type for the monad encapsulating error messages.-data ErrMsgQ a = ErrMsgQ (Q (ErrMsg a))--instance Monad ErrMsgQ where- return x = ErrMsgQ $ return $ return x- (>>=) (ErrMsgQ x) f = ErrMsgQ $ do- x' <- x- case x' of - Left s -> return (Left s)- Right r -> let (ErrMsgQ y) = f r in y--instance Applicative ErrMsgQ where- pure = return- (<*>) = ap--instance Functor ErrMsgQ where- fmap = liftM---- | Set an error message, to be thrown.--- Usage: --- --- > errorMsg "an error happened" -errorMsg :: String -> ErrMsgQ a-errorMsg s = ErrMsgQ (return (Left s))---- | Make a 'Q' computation error-message aware.-embedQ :: Q a -> ErrMsgQ a-embedQ x = ErrMsgQ $ do x' <- x; return (return x')---- | Throw the error that has been created, using the given string as--- a prefix. Usage:--- --- > extractQ "name of function: " $ do--- > <<commands that may thow an error>>-extractQ :: String -> ErrMsgQ a -> Q a-extractQ prefix (ErrMsgQ x) = - do- x' <- x- case x' of- Left s -> error (prefix ++ s)- Right x -> return x--
− src/Libraries/Template/LiftQ.hs
@@ -1,288 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | This module defines the state monad used in--- 'Libraries.Template.Lifting' for Template Haskell --- term manipulation.-module Libraries.Template.LiftQ where--import qualified Language.Haskell.TH as TH-import qualified Data.Map as Map-import qualified Data.Set as Set-import qualified Data.List as List--import Language.Haskell.TH (Name)-import Control.Monad.State-import Data.Map (Map)-import Data.Set (Set)--import Control.Applicative (Applicative(..))-import Control.Monad (liftM, ap)--import qualified Libraries.Template.ErrorMsgQ as Err-import Libraries.Template.ErrorMsgQ (ErrMsgQ)---- | State of the monad.-data LiftState = LiftState {- boundVar :: Map Name Int, -- ^ How many times each name is bound.- prefix :: Maybe String, -- ^ The template prefix .- monadName :: Maybe String -- ^ The name of the monad.-}---- | An empty state.-emptyLiftState :: LiftState-emptyLiftState = LiftState { - boundVar = Map.empty, - prefix = Nothing,- monadName = Nothing-}---- | Shortcut to @StateT LiftState ErrMsgQ@.-type LiftQState = StateT LiftState ErrMsgQ---- | The monad.-data LiftQ a = LiftQ (LiftQState a)--instance Monad LiftQ where- return x = LiftQ $ return x- (>>=) (LiftQ x) f = LiftQ $ do- x' <- x- let (LiftQ y) = f x'- y--instance Applicative LiftQ where- pure = return- (<*>) = ap--instance Functor LiftQ where- fmap = liftM---- | Retrieve the state from the monad.-getState :: LiftQ LiftState-getState = LiftQ $ mapStateT (\x -> do ((),s) <- x; return (s,s))- (return ())---- | Set the state of the monad.-setState :: LiftState -> LiftQ ()-setState s = LiftQ $ mapStateT (\_ -> return ((),s))- ((return ()) :: LiftQState ())---- * Various functions to go back and forth between monads.---- | From 'ErrMsgQ' to 'LiftQ'.-embedErrMsgQ :: ErrMsgQ a -> LiftQ a-embedErrMsgQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- q; return (y,s))- (return ())---- | From 'TH.Q' to 'LiftQ'.-embedQ :: TH.Q a -> LiftQ a-embedQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- Err.embedQ q; return (y,s))- (return ())---- | Get 'TH.Q' out of 'LiftQ'-extractQ :: String -> LiftQ a -> TH.Q a-extractQ s (LiftQ x) = Err.extractQ s $ evalStateT x emptyLiftState---- | Set an error message.-errorMsg :: String -> LiftQ a-errorMsg s = embedErrMsgQ $ Err.errorMsg s----- * Working with variable names.---- | Increase the number of binds of a variable name.-addToBoundVar :: Name -> LiftQ ()-addToBoundVar n = do- s <- getState- let new_value = - if (Map.member n $ boundVar s)- then 1 + ((boundVar s) Map.! n) - else 0- setState $ s { boundVar = Map.insert n new_value $ boundVar s }---- | Decrease the number of binds of a variable name.-removeFromBoundVar :: Name -> LiftQ ()-removeFromBoundVar n = do- s <- getState- if (not $ Map.member n $ boundVar s) - then errorMsg ((show n) ++ " is not a bound value")- else let old_value = (boundVar s) Map.! n in- if old_value == 0- then setState $ s { boundVar = Map.delete n $ boundVar s }- else setState $ s { boundVar = Map.insert n (old_value - 1) $ boundVar s }---- | Run a computation with a particular name being bound.-withBoundVar :: Name -> LiftQ a -> LiftQ a-withBoundVar n comp = do- addToBoundVar n- a <- comp- removeFromBoundVar n- return a---- | Run a computation with a particular list of names being bound.-withBoundVars :: [Name] -> LiftQ a -> LiftQ a-withBoundVars names comp = foldl (flip withBoundVar) comp names---- | Say whether a given name is bound.-isBoundVar :: Name -> LiftQ Bool-isBoundVar n = do- s <- getState- return $ Map.member n $ boundVar s----- * Other operations on monad state.---- | Set the template prefix.-setPrefix :: String -> LiftQ ()-setPrefix p = do- s <- getState- case (prefix s) of- Just p' -> errorMsg ("cannot set the prefix to " ++ - (show p) ++ - ": prefix already defined as " ++ - p') - Nothing -> setState $ s { prefix = Just p }----- | Get the template prefix.-getPrefix :: LiftQ String-getPrefix = do- s <- getState- case (prefix s) of- Nothing -> errorMsg "undefined prefix"- Just p -> return p---- | Set the monad name.-setMonadName :: String -> LiftQ ()-setMonadName m = do- s <- getState- case (monadName s) of- Just m' -> errorMsg ("cannot set the monad to " ++ - (show m) ++ - ": monad already defined as " ++ - m') - Nothing -> setState $ s { monadName = Just m }---- | Get the monad name.-getMonadName :: LiftQ String-getMonadName = do- s <- getState- case (monadName s) of- Nothing -> errorMsg "undefined monad"- Just m -> return m------- * Functions dealing with variable names.---- | Make a name out of a string.-mkName :: String -> Name-mkName s = TH.mkName s---- | Make a name out of a string, monadic-style.-newName :: String -> LiftQ Name-newName st = embedQ $ TH.newName st------- | Make any string into a string containing only @[0-9a-zA-Z_.]@.--- For example, it replaces any occurrence of @\"+\"@ with--- @\"symb_plus_\"@.-sanitizeString :: String -> String-sanitizeString name = - List.concat (List.map - (\c -> - Map.findWithDefault c c - (Map.map (\s -> "symb_" ++ s ++ "_")- unicodeNames))- (List.map (\x -> [x]) name))- where- unicodeNames :: Map.Map String String- unicodeNames = Map.fromList- [("!","exclamation"),- ("\"","doublequote"),- ("#","sharp"),- ("$","dollar"),- ("%","percent"),- ("&","ampersand"),- ("'","quote"),- ("(","oparent"),- (")","cparent"),- ("*","star"),- ("+","plus"),- (",","comma"),- ("-","minus"),- -- we keep dots- ("/","slash"),- (":","colon"),- (";","semicolon"),- ("<","oangle"),- ("=","equal"),- (">","cangle"),- ("?","question"),- ("@","at"),- ("[","obracket"),- ("\\","backslash"),- ("]","cbracket"),- ("^","caret"),- -- we keep _- ("`","graveaccent"),- ("{","obrace"),- ("|","vbar"),- ("}","cbrace"),- ("~","tilde")]----- | Take a string and make it into a valid Haskell name starting with--- @\"template_\"@.-templateString :: String -> LiftQ String-templateString s = do- p <- getPrefix- return (p ++ (sanitizeString s))---- | Look for the corresponding "template" name.-lookForTemplate :: Name -> LiftQ (Maybe Name)-lookForTemplate n = do- t_string <- templateString $ TH.nameBase n- embedQ $ TH.lookupValueName t_string---- | Make a the template version of a given name.-makeTemplateName :: Name -> LiftQ Name-makeTemplateName n = do- t_string <- templateString $ TH.nameBase n- return $ TH.mkName t_string----- * Other functions.---- | Print on the terminal a monadic, printable object.-prettyPrint :: TH.Ppr a => LiftQ a -> IO ()-prettyPrint x = (TH.runQ $ extractQ "prettyPrint: " x) >>= (putStrLn . TH.pprint)----- | Project patterns out of a clause.-clauseGetPats :: TH.Clause -> [TH.Pat]-clauseGetPats (TH.Clause pats _ _) = pats----- | Check that the list is a non-empty repetition of the same--- element.-equalNEListElts :: Eq a => [a] -> Bool-equalNEListElts [] = True-equalNEListElts (h:list) = foldl (&&) True $ map (== h) list----- | Returns the length of the patterns in a list of clauses. Throw an--- error if the patterns do not have all the same size.-clausesLengthPats :: [TH.Clause] -> LiftQ Int-clausesLengthPats [] = errorMsg "empty clause"-clausesLengthPats clauses - | (equalNEListElts $ map length $ map clauseGetPats clauses) = - return $ length $ clauseGetPats $ head clauses -clausesLengthPats _ = errorMsg "patterns in clause are not of equal size"-
− src/Libraries/Template/Lifting.hs
@@ -1,636 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RankNTypes #-}---- | This module describes stripped-down Template Haskell abstract--- syntax trees (ASTs) for a subset of Haskell.--module Libraries.Template.Lifting where--import Control.Monad.State--import qualified Data.Map as Map-import Data.Map (Map)--import qualified Data.List as List--import Data.Maybe (catMaybes)--import qualified Data.Set as Set-import Data.Set (Set)--import qualified Language.Haskell.TH as TH-import Language.Haskell.TH (Name)---- Get the monad to build the lifting.-import Libraries.Template.LiftQ----- * Abstract syntax trees of a simplified language---- | There are no \"guarded bodies\". One net effect is to make the--- \"where\" construct equivalent to a simple \"let\".-type Body = Exp---- | Literals.-data Lit =- CharL Char -- ^ Characters.- | IntegerL Integer -- ^ Integers.- | RationalL Rational -- ^ Reals.- deriving (Show)----- | Patterns.-data Pat = - LitP Lit -- ^ Literal.- | VarP Name -- ^ Variable name.- | TupP [Pat] -- ^ Tuple.- | WildP -- ^ Wildchar.- | ListP [Pat] -- ^ List as @[...]@.- | ConP Name [Pat] -- ^ Cons: @h:t@.- deriving (Show)---- | Match term construct.-data Match =- Match Pat Body- deriving (Show)---- | First-level declaration.-data Dec = - ValD Name Body- deriving (Show)---- | Expression-data Exp = - VarE Name -- ^ Variable name.- | ConE Name -- ^ Constant name.- | LitE Lit -- ^ Literal.- | AppE Exp Exp -- ^ Application.- | LamE Name Exp -- ^ Lambda abstraction.- | TupE [Exp] -- ^ Tuple.- | CondE Exp Exp Exp -- ^ If-then-else.- | LetE [Dec] Exp -- ^ Let-construct.- | CaseE Exp [Match] -- ^ Case distinction- | ListE [Exp] -- ^ List: @[...]@.- | ReturnE -- ^ hardcoded constant for @'return'@.- | MAppE -- ^ hardcoded constant for @'>>='@.- deriving (Show)----- $ Syntactic sugar to recover do-notation.---- | Datatype to encode the notation @x <- expr@.-data BindS = BindS Name Exp---- | A simple @do@: list of monadic @let@ followed by a computation.-doE :: [BindS] -> Exp -> Exp -doE binds exp = foldr doOne exp binds- where- doOne :: BindS -> Exp -> Exp- doOne (BindS n value) computation = AppE (AppE MAppE value) (LamE n computation)----- * Variable substitution- ---- | Get the set of variable names in a pattern.-getVarNames :: Pat -> Set Name-getVarNames (VarP n) = Set.singleton n-getVarNames (TupP pats) = Set.unions $ map getVarNames pats-getVarNames (ListP pats) = Set.unions $ map getVarNames pats-getVarNames _ = Set.empty---- | Substitution in a @'Match'@.-substMatch :: Name -> Exp -> Match -> Match-substMatch n s (Match p e) | Set.member n (getVarNames p) = Match p e- | True = Match p (substExp n s e)----- | Substitution in a @'Dec'@.-substDec :: Name -> Exp -> Dec -> Dec-substDec n s (ValD m e) | n == m = ValD m e- | True = ValD m (substExp n s e)---- | Substitution in an @'Exp'@.-substExp :: Name -> Exp -> Exp -> Exp-substExp n s (VarE m) | n == m = s- | True = (VarE m)-substExp n s (ConE m) = ConE m-substExp n s (LitE l) = LitE l-substExp n s (AppE e1 e2) = AppE (substExp n s e1) (substExp n s e2)-substExp n s (LamE m exp) | n == m = LamE m exp- | True = LamE m $ substExp n s exp-substExp n s (TupE exps) = TupE $ map (substExp n s) exps-substExp n s (CondE e1 e2 e3) = CondE (substExp n s e1) (substExp n s e2) (substExp n s e3)-substExp n s (LetE decs exp) = LetE (map (substDec n s) decs) (substExp n s exp)-substExp n s (CaseE exp matches) = CaseE (substExp n s exp) $ map (substMatch n s) matches-substExp n s (ListE exps) = ListE $ map (substExp n s) exps-substExp n s ReturnE = ReturnE-substExp n s MAppE = MAppE----- | Substitution of several variables in one go.-mapSubstExp :: (Map Name Exp) -> Exp -> Exp-mapSubstExp map exp = List.foldl (\exp (x,y) -> substExp x y exp) exp $ Map.toList map----- * Downgrading Template Haskell to AST---- | Downgrading TH literals to @'Exp'@.-litTHtoExpAST :: TH.Lit -> LiftQ Exp-litTHtoExpAST (TH.CharL c) = return $ LitE $ CharL c-litTHtoExpAST (TH.StringL s) = return $ ListE $ map (LitE . CharL) s-litTHtoExpAST (TH.IntegerL i) = return $ LitE $ IntegerL i -litTHtoExpAST (TH.RationalL r) = return $ LitE $ RationalL r-litTHtoExpAST x = errorMsg ("lifting not handled for " ++ (show x))---- | Downgrading TH literals to @'Pat'@.-litTHtoPatAST :: TH.Lit -> LiftQ Pat-litTHtoPatAST (TH.CharL c) = return $ LitP $ CharL c-litTHtoPatAST (TH.StringL s) = return $ ListP $ map (LitP . CharL) s-litTHtoPatAST (TH.IntegerL i) = return $ LitP $ IntegerL i -litTHtoPatAST (TH.RationalL r) = return $ LitP $ RationalL r-litTHtoPatAST x = errorMsg ("lifting not handled for " ++ (show x))----- | Take a list of patterns coming from a @where@ section and output--- a list of fresh names for normalized @let@s. Also gives a mapping--- for substituting inside the expressions. Assume all names in the--- list of patterns are distinct.-normalizePatInExp :: [Pat] -> LiftQ ([Name], Map Name Exp)-normalizePatInExp pats = do- fresh_names <- mapM newName $ replicate (length pats) "normalizePat"- let sets_of_old_names = List.map getVarNames pats- let old_to_fresh old_name =- List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) fresh_names- let old_to_pat old_name =- List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) pats- let list_of_old_names = List.concat $ List.map Set.toList sets_of_old_names- let maybe_list_map = mapM- (\x -> do- fresh <- old_to_fresh x- pat <- old_to_pat x- return (x, CaseE (VarE fresh) [Match pat (VarE x)]))- list_of_old_names- case maybe_list_map of- Nothing -> errorMsg "error in patterns..."- Just l -> return $ (fresh_names, Map.fromList l)- ---- | Build a @let@-expression out of pieces.-whereToLet :: Exp -> [(Pat,Exp)] -> LiftQ Exp-whereToLet exp [] = return exp-whereToLet exp list = do- (fresh_names, pmap) <- normalizePatInExp $ map fst list- let decs'' = map (uncurry ValD) $ zip fresh_names $ map snd list- let decs' = map (\(ValD n e) -> ValD n $ mapSubstExp pmap e) decs''- return $ - LetE decs' $ - CaseE (TupE $ map VarE fresh_names) [Match (TupP $ map fst list) exp]---- | Build a @'Match'@ out of a TH clause-clauseToMatch :: TH.Clause -> LiftQ Match-clauseToMatch (TH.Clause pats body decs) = do- pats' <- mapM patTHtoAST pats - body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs- exp <- whereToLet body' decs'- return $ Match (TupP pats') exp---- | From a list of TH clauses, make a case-distinction wrapped in a--- lambda abstraction.-clausesToLambda :: [TH.Clause] -> LiftQ Exp-clausesToLambda clauses = do- -- get length of patterns- pats_length <- clausesLengthPats clauses- -- make a list of new names from the function name- fresh_names <- mapM newName $ replicate pats_length "x"- -- make matches out of the clauses.- matches <- mapM clauseToMatch clauses- -- return a simple function with a case-distinction- return $ foldr LamE - (CaseE (TupE $ map VarE fresh_names) matches)- fresh_names----- | Downgrade expressions.-expTHtoAST :: TH.Exp -> LiftQ Exp--expTHtoAST (TH.VarE v) = return $ VarE v-expTHtoAST (TH.ConE n) = return $ ConE n-expTHtoAST (TH.LitE l) = litTHtoExpAST l--expTHtoAST (TH.AppE e1 e2) = do - e1' <- expTHtoAST e1- e2' <- expTHtoAST e2- return $ AppE e1' e2'--expTHtoAST (TH.InfixE (Just e1) e2 (Just e3)) = do- e1' <- expTHtoAST e1- e2' <- expTHtoAST e2- e3' <- expTHtoAST e3- return $ AppE (AppE e2' e1') e3'--expTHtoAST (TH.InfixE Nothing e2 (Just e3)) = do- e2' <- expTHtoAST e2- e3' <- expTHtoAST e3- n <- newName "x"- return $ LamE n $ AppE (AppE e2' (VarE n)) e3'--expTHtoAST (TH.InfixE (Just e1) e2 Nothing) = do- e1' <- expTHtoAST e1- e2' <- expTHtoAST e2- return $ AppE e2' e1'--expTHtoAST (TH.InfixE Nothing e2 Nothing) = do- e2' <- expTHtoAST e2- return e2'--expTHtoAST (TH.LamE pats exp) = - clausesToLambda [TH.Clause pats (TH.NormalB exp) []]--expTHtoAST (TH.TupE exps) = do- exps' <- mapM expTHtoAST exps- return (TupE exps')--expTHtoAST (TH.CondE e1 e2 e3) = do- e1' <- expTHtoAST e1- e2' <- expTHtoAST e2- e3' <- expTHtoAST e3- return $ CondE e1' e2' e3'--expTHtoAST (TH.LetE decs exp) = do- decs' <- mapM decTHtoAST decs- exp' <- expTHtoAST exp- whereToLet exp' decs' --expTHtoAST (TH.CaseE exp matches) = do- exp' <- expTHtoAST exp- matches' <- mapM matchTHtoAST matches- return $ CaseE exp' matches'- -expTHtoAST (TH.ListE exps) = do- exps' <- mapM expTHtoAST exps- return $ ListE exps'- --expTHtoAST (TH.SigE e _) = expTHtoAST e--expTHtoAST x = errorMsg ("lifting not handled for " ++ (show x))----- | Downgrade match-constructs.-matchTHtoAST :: TH.Match -> LiftQ Match-matchTHtoAST (TH.Match pat body decs) = do- pat' <- patTHtoAST pat- body' <- bodyTHtoAST body- decs' <- mapM decTHtoAST decs- exp <- whereToLet body' decs'- return $ Match pat' exp---- | Downgrade bodies into expressions.-bodyTHtoAST :: TH.Body -> LiftQ Exp-bodyTHtoAST (TH.NormalB exp) = expTHtoAST exp-bodyTHtoAST (TH.GuardedB x) = errorMsg ("guarded body not allowed in lifting: " ++ (show x))---- | Downgrade patterns.-patTHtoAST :: TH.Pat -> LiftQ Pat-patTHtoAST (TH.LitP l) = litTHtoPatAST l-patTHtoAST (TH.VarP n) = return $ VarP n-patTHtoAST (TH.TupP pats) = do pats' <- mapM patTHtoAST pats; return $ TupP pats'-patTHtoAST (TH.WildP) = return WildP-patTHtoAST (TH.ListP pats) = do pats' <- mapM patTHtoAST pats; return $ ListP pats'-patTHtoAST (TH.ConP n pats) = do pats' <- mapM patTHtoAST pats; return $ ConP n pats'-patTHtoAST (TH.InfixP p1 n p2) = do- p1' <- patTHtoAST p1- p2' <- patTHtoAST p2- return $ ConP n [p1',p2']-patTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x))------- | Downgrade first-level declarations.-firstLevelDecTHtoAST :: TH.Dec -> Maybe (LiftQ Dec)-firstLevelDecTHtoAST (TH.FunD name clauses) = Just $ do- exp <- clausesToLambda clauses- name' <- makeTemplateName name- return $ ValD name' $ substExp name (VarE name') exp--firstLevelDecTHtoAST (TH.ValD (TH.VarP name) body decs) = Just $ do- body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs- exp <- whereToLet body' decs' - name' <- makeTemplateName name- return $ ValD name' $ substExp name (VarE name') exp--firstLevelDecTHtoAST (TH.ValD _ _ _) = Just $- errorMsg ("only variables and functions can be lifted as first-level declarations")--firstLevelDecTHtoAST (TH.SigD _ _) = Nothing--firstLevelDecTHtoAST x = Just $ errorMsg ("non-implemented lifting: " ++ (show x))----- | Downgrade any declarations (including the ones in @where@-constructs).-decTHtoAST :: TH.Dec -> LiftQ (Pat,Exp)--decTHtoAST (TH.FunD name clauses) = do- exp <- clausesToLambda clauses- return $ (VarP name, exp)--decTHtoAST (TH.ValD pat body decs) = do- pat' <- patTHtoAST pat- body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs- exp <- whereToLet body' decs'- return $ (pat', exp)--decTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x))------- * Upgrade AST to Template Haskell---- | Abstract syntax tree of the type of the function 'return'.-typReturnE :: LiftQ TH.Type-typReturnE = do- m_string <- getMonadName- let m = TH.conT (mkName m_string)- embedQ [t| forall x. x -> $(m) x |]---- | Abstract syntax tree of the type of the function '>>='.-typMAppE :: LiftQ TH.Type-typMAppE = do- m_string <- getMonadName- let m = TH.conT (mkName m_string)- embedQ [t| forall x y. $(m) x -> (x -> $(m) y) -> $(m) y |]----- | Upgrade literals-litASTtoTH :: Lit -> TH.Lit-litASTtoTH (CharL c) = TH.CharL c-litASTtoTH (IntegerL i) = TH.IntegerL i-litASTtoTH (RationalL r) = TH.RationalL r---- | Upgrade patterns.-patASTtoTH :: Pat -> TH.Pat-patASTtoTH (LitP l) = TH.LitP $ litASTtoTH l-patASTtoTH (VarP n) = TH.VarP n-patASTtoTH (TupP pats) = TH.TupP $ map patASTtoTH pats-patASTtoTH WildP = TH.WildP-patASTtoTH (ListP pats) = TH.ListP $ map patASTtoTH pats-patASTtoTH (ConP n pats) = TH.ConP n $ map patASTtoTH pats---- | Upgrade match-constructs.-matchASTtoTH :: Match -> LiftQ TH.Match-matchASTtoTH (Match p b) = do- exp <- expASTtoTH b- return $ TH.Match (patASTtoTH p) (TH.NormalB exp) []---- | Upgrade declarations.-decASTtoTH :: Dec -> LiftQ TH.Dec--decASTtoTH (ValD n b) = do- exp <- expASTtoTH b- return $ TH.ValD (TH.VarP n) (TH.NormalB exp) []----- | Upgrade expressions.-expASTtoTH :: Exp -> LiftQ TH.Exp--expASTtoTH (VarE n) = return $ TH.VarE n-expASTtoTH (ConE n) = return $ TH.ConE n-expASTtoTH (LitE l) = return $ TH.LitE $ litASTtoTH l--expASTtoTH (AppE e1 e2) = do- e1' <- expASTtoTH e1- e2' <- expASTtoTH e2- return $ TH.AppE e1' e2'--expASTtoTH (LamE n e) = do- e' <- expASTtoTH e- return $ TH.LamE [TH.VarP n] e'--expASTtoTH (TupE exps) = do- exps' <- mapM expASTtoTH exps- return $ TH.TupE exps'--expASTtoTH (CondE e1 e2 e3) = do- e1' <- expASTtoTH e1- e2' <- expASTtoTH e2- e3' <- expASTtoTH e3- return $ TH.CondE e1' e2' e3'--expASTtoTH (LetE decs e) = do- decs' <- mapM decASTtoTH decs- e' <- expASTtoTH e- return $ TH.LetE decs' e'--expASTtoTH (CaseE e matches) = do- e' <- expASTtoTH e- m' <- mapM matchASTtoTH matches- return $ TH.CaseE e' m'--expASTtoTH (ListE exps) = do- exps' <- mapM expASTtoTH exps- return $ TH.ListE exps'--expASTtoTH ReturnE = do- t <- typReturnE- maybe_r <- embedQ $ TH.lookupValueName "return"- case maybe_r of- Just r -> return $ TH.SigE (TH.VarE r) t- Nothing -> errorMsg "\'return\' undefined"- -expASTtoTH MAppE = do- t <- typMAppE- maybe_a <- embedQ $ TH.lookupValueName ">>="- case maybe_a of- Just a -> return $ TH.SigE (TH.VarE a) t- Nothing -> errorMsg "\'>>=\' undefined"------- * Lifting AST terms (into AST terms)---- | Variable referring to the lifting function for integers.-liftIntegerL :: Exp-liftIntegerL = VarE $ mkName "template_integer"---- | Variable referring to the lifting function for reals.-liftRationalL :: Exp-liftRationalL = VarE $ mkName "template_rational"---- | Lifting literals.-liftLitAST :: Lit -> LiftQ Exp-liftLitAST (CharL c) = return (AppE ReturnE (LitE $ CharL c))-liftLitAST (IntegerL i) = return $ AppE liftIntegerL (LitE $ IntegerL i)-liftLitAST (RationalL r) = return $ AppE liftRationalL (LitE $ RationalL r)---- | Lifting patterns.-liftPatAST :: Pat -> LiftQ Pat-liftPatAST pat = return pat---- | Lifting match-constructs.-liftMatchAST :: Match -> LiftQ Match-liftMatchAST (Match pat exp) = do- exp' <- liftExpAST exp- return $ Match pat exp' ---- | Lifting declarations.-liftDecAST :: Dec -> LiftQ Dec-liftDecAST (ValD name exp) = do- exp' <- liftExpAST exp- return $ ValD name exp'---- | Lifting first-level declarations.-liftFirstLevelDecAST :: Dec -> LiftQ Dec-liftFirstLevelDecAST (ValD name exp) = withBoundVar name $ do- exp' <- liftExpAST exp- return $ ValD name exp'---- | Lifting expressions.-liftExpAST :: Exp -> LiftQ Exp--liftExpAST (VarE x) = do- template_name <- lookForTemplate x- case template_name of- Nothing -> do- b <- isBoundVar x- if b - then return $ VarE x- else return $ AppE ReturnE $ VarE x- Just t -> return $ VarE t--liftExpAST (ConE n) = do- template_name <- lookForTemplate n- case template_name of- Nothing -> do - t <- templateString $ TH.nameBase n- errorMsg ("variable " ++ t ++ " undefined")- Just t -> return $ VarE t--liftExpAST (LitE l) = liftLitAST l--liftExpAST (AppE e1 e2) = do- e1' <- liftExpAST e1- e2' <- liftExpAST e2- n1 <- newName "app1"- n2 <- newName "app2"- return $ doE [BindS n1 e1', BindS n2 e2'] $ AppE (VarE n1) (VarE n2)--liftExpAST (LamE n exp) = do- exp' <- liftExpAST exp- return $ AppE ReturnE $ LamE n exp'--liftExpAST (TupE exps) = do- exps' <- mapM liftExpAST exps- fresh_names <- mapM newName $ replicate (length exps) "tupe"- return $ - doE (map (uncurry BindS) $ zip fresh_names exps')- (AppE ReturnE $ TupE $ map VarE fresh_names)--liftExpAST (CondE e1 e2 e3) = do- e1' <- liftExpAST e1- e2' <- liftExpAST e2- e3' <- liftExpAST e3- return $ AppE (AppE (AppE (VarE (mkName "template_if")) (e1')) (e2')) (e3')---liftExpAST (LetE decs exp) = - let existing_names = map (\(ValD n _) -> n) decs- in- withBoundVars existing_names $ do- decs' <- mapM liftDecAST decs- exp' <- liftExpAST exp- return $ - LetE decs' exp'---liftExpAST (CaseE exp matches) = do- exp' <- liftExpAST exp- matches' <- mapM liftMatchAST matches- fresh_name <- newName "varfromcase"- return $ doE [BindS fresh_name exp']- $ CaseE (VarE fresh_name) matches'- -liftExpAST (ListE exps) = do- exps' <- mapM liftExpAST exps- fresh_names <- mapM newName $ replicate (length exps) "varfromlist"- return $ - doE (map (uncurry BindS) $ zip fresh_names exps')- $ AppE ReturnE $ ListE $ map VarE fresh_names---- These two are not supposed to be there!-liftExpAST ReturnE = undefined-liftExpAST MAppE = undefined----- | make a declaration into a template-declaration (by renaming with--- the template-prefix).-makeDecTemplate :: Dec -> LiftQ Dec-makeDecTemplate (ValD name exp) = do- name' <- makeTemplateName name- return $ ValD name' $ substExp name (VarE name') exp----- * Various pretty printing functions----- | pretty-printing Template Haskell declarations.-prettyPrintAST :: TH.Q [TH.Dec] -> IO ()-prettyPrintAST x = prettyPrint $ do- x' <- embedQ x- y <- sequence $ catMaybes $ map firstLevelDecTHtoAST x'- mapM decASTtoTH y---- | Pretty-printing Template Haskell expressions.-prettyPrintLiftExpTH :: TH.Q (TH.Exp) -> IO ()-prettyPrintLiftExpTH x = prettyPrint $ do- x' <- embedQ x- y <- expTHtoAST x'- z <- liftExpAST y- expASTtoTH z---- | Pretty-printing expressions.-prettyPrintLiftExpAST :: LiftQ (Exp) -> IO ()-prettyPrintLiftExpAST x = prettyPrint $ do- z <- x- z' <- liftExpAST z- expASTtoTH z'----- * The main lifting functions.----- | Lift a list of declarations. The first argument is the name of--- the monad to lift into.-decToMonad :: String -> TH.Q [TH.Dec] -> TH.Q [TH.Dec]-decToMonad s x = extractQ "decToMonad: " $ do- setMonadName s- setPrefix "template_"- dec <- embedQ x- decAST <- sequence $ catMaybes $ map firstLevelDecTHtoAST dec- liftedAST <- mapM liftFirstLevelDecAST decAST- mapM decASTtoTH liftedAST---- | Lift an expression. The first argument is the name of the monad--- to lift into.-expToMonad :: String -> TH.Q TH.Exp -> TH.Q TH.Exp-expToMonad s x = extractQ "expToMonad: " $ do- setMonadName s- setPrefix "template_"- dec <- embedQ x- decAST <- expTHtoAST dec- liftedAST <- liftExpAST decAST- expASTtoTH liftedAST--
− src/Libraries/Tuple.hs
@@ -1,103 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}---- | This module provides isomorphisms between /n/-tuples and repeated--- pairs. It is used to be able to write type classes for /n/-tuples--- more generically. Essentially we want to be able to write code for--- 17-tuples once and for all, rather than once for each type class we--- define. Ideally there would be a standard Haskell library for this.------ Two type classes are provided: 'Tuple', and 'TupleOrUnary'.--- 'Tuple' is recommended for most uses.--module Libraries.Tuple where---- I only want to write code involving explicit 7-tuples once in my life---- | This type class relates types of the form @t = (a,b,c,d)@ (“tupled form”) to--- types of the form @s = (a,(b,(c,(d,()))))@ (“standard form”), and provides a way to--- convert between the two representations.------ The tupled form can always be deduced from the standard form.--class TupleOrUnary t s | s -> t where- -- | For example, maps @(a,(b,(c,(d,()))))@ to @(a,b,c,d)@.- weak_tuple :: s -> t- -- | For example, maps @(a,b,c,d)@ to @(a,(b,(c,(d,()))))@.- weak_untuple :: t -> s--instance TupleOrUnary () () where- weak_tuple () = ()- weak_untuple () = ()--instance TupleOrUnary a (a,()) where- weak_tuple (a,()) = a- weak_untuple a = (a,())--instance TupleOrUnary (a,b) (a,(b,())) where- weak_tuple (a,(b,())) = (a,b)- weak_untuple (a,b) = (a,(b,()))- -instance TupleOrUnary (a,b,c) (a,(b,(c,()))) where- weak_tuple (a,(b,(c,()))) = (a,b,c)- weak_untuple (a,b,c) = (a,(b,(c,())))- -instance TupleOrUnary (a,b,c,d) (a,(b,(c,(d,())))) where- weak_tuple (a,(b,(c,(d,())))) = (a,b,c,d)- weak_untuple (a,b,c,d) = (a,(b,(c,(d,()))))--instance TupleOrUnary (a,b,c,d,e) (a,(b,(c,(d,(e,()))))) where- weak_tuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)- weak_untuple (a,b,c,d,e) = (a,(b,(c,(d,(e,())))))--instance TupleOrUnary (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,())))))) where- weak_tuple (a,(b,(c,(d,(e,(f,())))))) = (a,b,c,d,e,f)- weak_untuple (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,()))))))--instance TupleOrUnary (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,()))))))) where- weak_tuple (a,(b,(c,(d,(e,(f,(g,()))))))) = (a,b,c,d,e,f,g)- weak_untuple (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,())))))))--instance TupleOrUnary (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where- weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (a,b,c,d,e,f,g,h)- weak_untuple (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,()))))))))--instance TupleOrUnary (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where- weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i)- weak_untuple (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))--instance TupleOrUnary (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where- weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j)- weak_untuple (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))---- | In almost all instances, the standard form can also be deduced from the tupled form; --- the only exception is the unary case. The 'Tuple' class includes no new methods, --- adding just this functional dependency.------ While the methods of 'Tuple' are always copied from those of 'TupleOrUnary', --- they are renamed, so that use of these methods tells the type checker it--- can use the extra functional dependency.-class (TupleOrUnary t s) => Tuple t s | s -> t, t -> s where- tuple :: s -> t- tuple = weak_tuple-- untuple :: t -> s- untuple = weak_untuple- -instance Tuple () ()-instance Tuple (a,b) (a,(b,()))-instance Tuple (a,b,c) (a,(b,(c,())))-instance Tuple (a,b,c,d) (a,(b,(c,(d,()))))-instance Tuple (a,b,c,d,e) (a,(b,(c,(d,(e,())))))-instance Tuple (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,()))))))-instance Tuple (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,())))))))-instance Tuple (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,()))))))))-instance Tuple (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))-instance Tuple (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))
− src/Libraries/Typeable.hs
@@ -1,58 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE CPP #-}--{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}--#if __GLASGOW_HASKELL__ < 780-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-#endif---- | The standard Haskell module "Data.Typeable" only provides--- instances for tuples up to length 7. Since we need larger tuples,--- we provide the missing instances here. --- --- Unfortunately, there is no easy way to do this portably; once the--- instances get added to "Data.Typeable", we must remove them here.--- --- Please note: type instances do not generate documentation, so there--- is nothing here to document. Please click on \"Source\" above to--- see the source code.--module Libraries.Typeable where--import Data.Typeable--#if __GLASGOW_HASKELL__ >= 708--deriving instance Typeable (,,,,,,,)-deriving instance Typeable (,,,,,,,,)-deriving instance Typeable (,,,,,,,,,)--#else---- Note: we use scoped type variables so that the typerep is constant;--- it can be computed at compile time. Same trick as in--- Data.Typeable.Internal.-instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h) => Typeable (a,b,c,d,e,f,g,h) where- typeOf _ = typerep- where- typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h) ]--instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i) => Typeable (a,b,c,d,e,f,g,h,i) where- typeOf _ = typerep- where- typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i) ]--instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j) => Typeable (a,b,c,d,e,f,g,h,i,j) where- typeOf _ = typerep- where- typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i), typeOf (undefined :: j) ]--#endif
− src/Quipper.hs
@@ -1,529 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | 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.CircLifting,- module Libraries.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 (..),- QOrd (..),- q_lt,- q_gt,- q_le,- q_ge,- - ) where---import Quipper.Monad-import Quipper.Generic-import Quipper.QData-import Quipper.QClasses-import Quipper.Control-import Quipper.CircLifting-import Quipper.Transformer (T_Gate(..), Transformer, Ctrls, B_Endpoint(..))-import Quipper.Circuit (InverseFlag, NoControlFlag, from_signed, get_sign)-import Quipper.Classical-import Quipper.Printing-import Quipper.Labels--import Libraries.Template-import Libraries.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` <<controls>> ---- $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.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 'QNum' has 'q_add', 'q_mult', 'q_signum', and so on. --- ('QNum' is defined in "QuipperLib.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.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.
− src/Quipper/CircLifting.hs
@@ -1,563 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}---- | 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--- "Libraries.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.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 Language.Haskell.TH as TH-import Data.Map as Map-import qualified Data.List--import Quipper.Monad-import qualified Quipper.Monad-import Quipper.Circuit-import Quipper.Generic-import Quipper.QData-import Libraries.Auxiliary (list_of_blist,blist_empty)-import Quipper.Control-import Quipper.QClasses--import Libraries.Template----------------------------------------------------------------------------- * Overview---- $ROLE Using the tool @'decToMonad'@ designed in "Libraries.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.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 "Libraries.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 '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--- <http://hackage.haskell.org/trac/haskell-prime/wiki/FunctionalDependencies#Restrictionsoninstances>,--- <http://hackage.haskell.org/trac/haskell-prime/wiki/FunctionalDependencies#Modifiedcoveragecondition>).--- --- 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
− src/Quipper/Circuit.hs
@@ -1,769 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# 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.Circuit where---- import other Quipper stuff-import Libraries.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 '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--- '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)
− src/Quipper/Classical.hs
@@ -1,241 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE FlexibleContexts #-}---- | This module provides some operations for low-level manipulation--- of classical circuits. It is built directly on top of--- "Quipper.Circuit".--module Quipper.Classical where---- import other Quipper stuff-import Quipper.Generic-import Quipper.QData-import Quipper.Monad-import Quipper.Control-import Quipper.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 'CGate' style gates, such as--- \"and\", \"or\", \"not\", \"xor\", \"eq\", and \"if-then-else\"--- gates, and replace them by equivalent 'CInit' and '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 '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)
− src/Quipper/Control.hs
@@ -1,260 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# 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.Control" module provides some convenient functions for--- creating and updating such controls.--module Quipper.Control where--import Quipper.Circuit-import Libraries.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 '.==.', './=.', and '.&&.' 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.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 '.==.', './=.', and '.&&.' 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 'Bit' (for a classical--- execution-time control) and '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
− src/Quipper/Generic.hs
@@ -1,1623 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE Rank2Types #-} ---- | 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.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.Circuit-import Quipper.Monad-import Libraries.Auxiliary-import Libraries.Tuple-import Quipper.Transformer-import Quipper.Control-import Quipper.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 <<<condition>>> (--- > <<then-part>>>--- > )(--- > <<<else-part>>>--- > )--- --- 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 {--- > <<<code block using ancilla a initialized to True>>>--- > }--- --- > with_ancilla_init [True,False,True] $ \a -> do {--- > <<<code block using list of ancillas a initialized to [True,False,True]>>>--- > }-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 {--- > <<<code block using list of ancillas a>>>--- > }-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--- --- * '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--- > <<<code>>>--- >--- > where--- > basischange = do--- > <<<gates>>>--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--- > <<<body>>>--- > 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
− src/Quipper/Internal.hs
@@ -1,51 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================---- | 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.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 Libraries.Auxiliary-import Quipper.QData-import Quipper.Labels-import Quipper.Generic---- $QData--- --- The module "Quipper.QData" provides type classes for dealing with--- various "shaped" quantum and classical data structures. Please see--- "Quipper.QData" for documentation.
− src/Quipper/Labels.hs
@@ -1,535 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE Unsafe #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverlappingInstances #-}---- | 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.Labels where--import Quipper.Circuit-import Quipper.Monad-import Libraries.Auxiliary-import Libraries.Tuple-import Quipper.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--- > <<<labelings>>>-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--- > <<<labelings>>>--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:--- --- > <<<labeling>>> `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:--- --- > <<<labeling>>> `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 (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 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--- '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--- 'QCData' constructor, and adding a new atomic 'QCData'.--- --- [New 'QCshape' constructors]--- --- Consider the case of a new '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 <<<a1>>> s `indexed` <<<index1>>>--- > ...--- > label_rec <<<an>>> s `indexed` <<<indexn>>>--- --- 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 <<<a1>>> <<<s1>>>--- > ...--- > label_rec <<<an>>> <<<sn>>>--- --- 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 QCShape]--- --- Consider the case of a new atomic '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 'QCLeaf'--- type class. The instance takes the following form:--- --- > instance QCLeaf x => Labelable (Atomic x) String where--- > label_rec a s = do--- > label_rec <<<a1>>> s `indexed` <<<index1>>>--- > ...--- > label_rec <<<an>>> s `indexed` <<<indexn>>>--- --- 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.
− src/Quipper/Monad.hs
@@ -1,1819 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# 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.Monad (- -- * The ReadWrite monad- ReadWrite(..),- - -- * The Circ monad - Circ,-- -- * Some types- Qubit,- Bit,- Endpoint,- Signed(..), -- re-exported from Quipper.Circuit- Ctrl,- Qulist,- Bitlist,- Timestep, -- re-exported from Quipper.Circuit- InverseFlag, -- re-exported from Quipper.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.Circuit-import Libraries.Auxiliary-import Quipper.Transformer-import Quipper.Control---- import other stuff-import Control.Monad-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---- ======================================================================--- ** 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---- | @'provideSimpleSubroutine' 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---- | @'provideSubroutines' 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---- | @'provideSubroutine' 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.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--- '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 {--- > <<<code block>>>--- > }--- --- 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 'qinit' and 'qterm'. This can be used--- to introduce an ancilla with a local scope, like this:--- --- > with_ancilla $ \h -> do {--- > <<<code block using ancilla h>>>--- > }--- --- 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 <<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` <<controls>>--- --- It also works with functional-style gates:--- --- > result <- gate `controlled` <<controls>>--- --- The infix operator is left associative, so it can be applied--- multiple times:--- --- > result <- gate `controlled` <<controls1>> `controlled` <<controls2>>--- --- The latter is equivalent to--- --- > result <- gate `controlled` <<controls1>> .&&. <<controls2>>--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 '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 --- > <<code block>>--- --- 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` <<controls1>>--- > }--- > gate4--- >--- > my_circuit = do--- > my_subcircuit `controlled` <<controls2>>--- --- 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 'with_computed' or--- '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 'with_computed' and--- 'with_basis_change', and '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.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
− src/Quipper/Printing.hs
@@ -1,1692 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE BangPatterns #-}---- | Pretty-printing of low-level quantum circuits.--module Quipper.Printing (- -- * ASCII representation of circuits- ascii_of_bcircuit,- print_dbcircuit_ascii,- getBit,- -- * Gate counts- print_gatecounts_bcircuit,- -- * Graphical representation of circuits- render_dbcircuit,- -- * Previewing- preview_bcircuit,- -- * Printing to multiple formats- Format(..),- FormatStyle(..),- pdf,- eps,- ps,- format_enum,- print_dbcircuit,- print_of_document,- print_of_document_custom,- -- * Generic printing- print_unary,- print_generic,- print_simple,- ) where---- import other Quipper stuff-import Libraries.Auxiliary-import Quipper.Circuit-import Quipper.Generic-import Quipper.Monad-import Quipper.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.Process-import System.Directory-import System.Environment-import System.Info--import Data.Set (Set)-import qualified Data.Set as Set--import Data.Map (Map)-import qualified Data.Map as Map--import qualified Data.IntMap as IntMap-import qualified Data.List as List---- ======================================================================--- * 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 repective 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- }---- ------------------------------------------------------------------------- * Interface to external programs---- | @'system_pdf_viewer' zoom pdffile@: Call a system-specific PDF--- viewer on /pdffile/ file. The /zoom/ argument is out of 100 and may--- or may not be ignored by the viewer.-system_pdf_viewer :: Double -> String -> IO ()-system_pdf_viewer zoom pdffile = do- envList <- getEnvironment- if (List.elem ("OS", "Windows_NT") envList)- then do- rawSystem "acroread.bat" [pdffile]- else if (os == "darwin")- then do- rawSystem "open" [pdffile]- rawSystem "sleep" ["1"] -- required or the file may be deleted too soon- else do- rawSystem "acroread" ["/a", "zoom=100", pdffile]- return ()---- ------------------------------------------------------------------------- * 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) -> Map.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 = Map.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
− src/Quipper/QClasses.hs
@@ -1,140 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE FlexibleContexts #-}---- | 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.CircLifting". --module Quipper.QClasses where--import Quipper.Generic-import Quipper.QData-import Quipper.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.-class (QCData qc) => QEq qc where- - -- | Test for equality. - q_is_equal :: 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 :: 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)---- 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. -instance (QCData qc) => QEq qc---- ------------------------------------------------------------------------- * 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)
− src/Quipper/QData.hs
@@ -1,1358 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS -fcontext-stack=50 #-}---- -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.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.QData where---- import other Quipper stuff-import Quipper.Monad-import Libraries.Auxiliary-import Libraries.Tuple-import Quipper.Labels-import Quipper.Transformer-import Quipper.Control--import Data.Typeable-import Libraries.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. '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., '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., '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 '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'.-class (qa ~ QType (CType qa),- qa ~ QTypeB (BType qa), - qa ~ QCType Qubit Bool qa,- qa ~ QType qa,- QCData qa,- QCData (CType qa)- ) => QData qa- -instance (qa ~ QType (CType qa),- qa ~ QTypeB (BType qa), - qa ~ QCType Qubit Bool qa,- qa ~ QType qa, - QCData qa,- QCData (CType qa)- ) => QData 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'.-class (QData (QType ca), CType (QType ca) ~ ca) => CData ca-instance (QData (QType ca), CType (QType ca) ~ ca) => CData ca---- | The 'BData' type class contains homogeneous data types built up--- from leaves of type 'Bool'.-class (QData (QTypeB ba), BType (QTypeB ba) ~ ba) => BData ba-instance (QData (QTypeB ba), BType (QTypeB ba) ~ ba) => BData 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.--class (QData qa, - CType qa ~ ca,- BType qa ~ ba- ) => QShape ba qa ca | ba -> qa, qa -> ca, ca -> ba--instance (QData qa, BType qa ~ ba, CType qa ~ ca) => QShape ba 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.--class (QCData qc, QData (QType qc)) => QCDataPlus qc-instance (QCData qc, QData (QType qc)) => QCDataPlus qc---- ------------------------------------------------------------------------- ** Fixed size QCDataPlus---- | 'QCDataPlus_Simple' is a convenience type class that combines--- 'QCDataPlus' and 'SimpleType'.-class (QCData qc, SimpleType qc) => QCData_Simple qc-instance (QCData qc, SimpleType qc) => QCData_Simple qc---- | 'QCDataPlus_Simple' is a convenience type class that combines--- 'QCDataPlus' and 'SimpleType'.-class (QCDataPlus qc, SimpleType qc) => QCDataPlus_Simple qc-instance (QCDataPlus qc, SimpleType qc) => QCDataPlus_Simple 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 './=.' 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 '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.Labels" for detailed instructions on how to--- do so.--- --- Modules that define new kinds of quantum data should import--- "Quipper.Internal".
− src/Quipper/Transformer.hs
@@ -1,624 +0,0 @@--- This file is part of Quipper. Copyright (C) 2011-2016. Please see the--- file COPYRIGHT for a list of authors, copyright holders, licensing,--- and other details. All rights reserved.--- --- ======================================================================--{-# 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.Transformer where---- import other Quipper stuff-import Quipper.Circuit-import Libraries.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 '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 '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 '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 ⟦Endpoint Qubit Bit⟧ = ⟦Qubit⟧ + ⟦Bit⟧. The type '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 ⟦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 <parameters> f) = f $ <semantic function for gate 1>--- > my_transformer (T_Gate2 <parameters> f) = f $ <semantic function for gate 2>--- > my_transformer (T_Gate3 <parameters> f) = f $ <semantic function for gate 3>--- > ...--- --- 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 <parameters> f) = f $ <semantic function for gate 1>--- > my_transformer (T_Gate2 <parameters> f) = f $ <semantic function for gate 2>--- > my_transformer (T_Gate3 <parameters> f) = f $ <semantic function for gate 3>--- > ...---- 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