quipper (empty) → 0.7
raw patch · 30 files changed
+13499/−0 lines, 30 filesdep +basedep +containersdep +directorysetup-changed
Dependencies added: base, containers, directory, easyrender, mtl, process, random, template-haskell, unix
Files
- COPYRIGHT +66/−0
- README +422/−0
- Setup.hs +2/−0
- quipper.cabal +25/−0
- src/Libraries/Auxiliary.hs +926/−0
- src/Libraries/CommandLine.hs +72/−0
- src/Libraries/PortableSignals.hs +139/−0
- src/Libraries/RandomSource.hs +25/−0
- src/Libraries/Sampling.hs +285/−0
- src/Libraries/ShowAll.hs +32/−0
- src/Libraries/Template.hs +67/−0
- src/Libraries/Template/Auxiliary.hs +88/−0
- src/Libraries/Template/ErrorMsgQ.hs +62/−0
- src/Libraries/Template/LiftQ.hs +288/−0
- src/Libraries/Template/Lifting.hs +636/−0
- src/Libraries/Tuple.hs +103/−0
- src/Libraries/Typeable.hs +58/−0
- src/Quipper.hs +529/−0
- src/Quipper/CircLifting.hs +563/−0
- src/Quipper/Circuit.hs +769/−0
- src/Quipper/Classical.hs +241/−0
- src/Quipper/Control.hs +260/−0
- src/Quipper/Generic.hs +1623/−0
- src/Quipper/Internal.hs +51/−0
- src/Quipper/Labels.hs +534/−0
- src/Quipper/Monad.hs +1819/−0
- src/Quipper/Printing.hs +1692/−0
- src/Quipper/QClasses.hs +140/−0
- src/Quipper/QData.hs +1358/−0
- src/Quipper/Transformer.hs +624/−0
+ COPYRIGHT view
@@ -0,0 +1,66 @@+Contributors are listed here, in alphabetical order by last name.+Unless otherwise noted, the copyright for his or her contributions+rests with each individual author. For contributions by authors whose+name is marked (ACS), the copyright rests with Applied Communication+Sciences.++Copyright (C) 2011-2014. All rights reserved.+Copyright (C) 2012-2013 Applied Communication Sciences. All rights+reserved.++Richard Eisenberg+Alexander S. Green+Peter LeFanu Lumsdaine+Keith Kim (ACS)+Siun-Chuon Mau (ACS)+Baranidharan Mohan+Won Ng (ACS)+Joel Ravelomanantsoa-Ratsimihah+Neil J. Ross+Artur Scherer (ACS)+Peter Selinger+Benoît Valiron+Alexandr Virodov (ACS)+Stephan A. Zdancewic++This research was supported by the Intelligence Advanced Research+Projects Activity (IARPA) via Department of Interior National Business+Center contract numbers D11PC20168 and D12PC00527. The U.S. Government+is authorized to reproduce and distribute reprints for Governmental+purposes notwithstanding any copyright annotation thereon. Disclaimer:+The views and conclusions contained herein are those of the authors+and should not be interpreted as necessarily representing the official+policies or endorsements, either expressed or implied, of IARPA,+DoI/NBC, or the U.S. Government.++----------------------------------------------------------------------+LICENSE++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the+ distribution.++3. The name of the authors and copyright holders may not be used to+ endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING+IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+----------------------------------------------------------------------
+ README view
@@ -0,0 +1,422 @@+This file is part of Quipper. Copyright (C) 2011-2014. 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 v.1.0.1.1+ * mtl v.2.1.2+ * primes v.0.2.1.0+ * Lattices v.0.0.1 (note: "Lattices" must be capitalized)+ * zlib v.0.5.4.1+ * easyrender v.0.1.0.0+ * fixedprec v.0.2.1.0+ * newsynth v.0.1.0.0+ * containers v.0.5.2.1+ * set-monad v.0.1.0.0+ * QuickCheck v.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++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>
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ quipper.cabal view
@@ -0,0 +1,25 @@+-- Initial quipper.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: quipper+version: 0.7+synopsis: Quipper is an embedded, scalable functional programming language for quantum computing.+-- description: +homepage: http://www.mathstat.dal.ca/~selinger/quipper/+license: BSD3+license-file: COPYRIGHT+author: Applied Communication Sciences+maintainer: leonardo.taglialegne@gmail.com+-- copyright: +-- category: +build-type: Simple+extra-source-files: README+cabal-version: >=1.10++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.ShowAll, 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.7, random >=1.0 && <1.1, containers >=0.5 && <0.6, unix >=2.6 && <2.7, template-haskell >=2.8 && <2.9, mtl >=2.1 && <2.2, easyrender >=0.1 && <0.2, process >=1.1 && <1.2, directory >=1.2 && <1.3+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Libraries/Auxiliary.hs view
@@ -0,0 +1,926 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,72 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,139 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,25 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,285 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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/ShowAll.hs view
@@ -0,0 +1,32 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. Please see the+-- file COPYRIGHT for a list of authors, copyright holders, licensing,+-- and other details. All rights reserved.+-- +-- ======================================================================++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverlappingInstances #-}++-- | This module extends the 'show' function to be able to convert any+-- term to a string, even if its type is not an instance of the 'Show'+-- type class. This is useful, e.g., for generating debugging output,+-- where one does not necessarily want to provide 'Show' instances for+-- every auxiliary data structure that needs debugging.+-- +-- Functions are shown as \"fun\", and everything else is shown as+-- \"term\".++module Libraries.ShowAll where++-- * Documentation++-- $ We provide a catch-all 'Show' instance using the GHC language+-- option \"OverlappingInstances\". Since instance declarations don't+-- generate any exported symbols, the documentation is empty. Please+-- see the source code.++instance Show (a -> b) where+ show x = "fun"++instance Show s where+ show x = "term"
+ src/Libraries/Template.hs view
@@ -0,0 +1,67 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,88 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,62 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,288 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,636 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 "case"+ 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) "liste"+ 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 view
@@ -0,0 +1,103 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,58 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,529 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,563 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,769 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,241 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,260 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,1623 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 'measure'. 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 view
@@ -0,0 +1,51 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,534 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. Please see the+-- file COPYRIGHT for a list of authors, copyright holders, licensing,+-- and other details. All rights reserved.+-- +-- ======================================================================++{-# 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 view
@@ -0,0 +1,1819 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,1692 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,140 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,1358 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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 view
@@ -0,0 +1,624 @@+-- This file is part of Quipper. Copyright (C) 2011-2014. 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