diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -4,7 +4,7 @@ name is marked (ACS), the copyright rests with Applied Communication Sciences. -Copyright (C) 2011-2016. All rights reserved. +Copyright (C) 2011-2019. All rights reserved. Copyright (C) 2012-2013 Applied Communication Sciences. All rights reserved. diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,76 @@ +December 29, 2019: Release 0.9.0.0 + + * Overhauled module structure: + + Old: New: + ==== ==== + + Quipper.XYZ Quipper.Internal.XYZ + QuipperLib.XYZ Quipper.Libraries.XYZ + Libraries.XYZ Quipper.Utils.XYZ + Algorithms.XYZ Quipper.Algorithms.XYZ + tests Quipper.Demos + Programs Quipper.Programs + + * Re-packaged Quipper as Cabal packages. Added executables quipper, + quipper-pp, quipperi, quipperdoc in lieu of shell scripts. + * Moved PDF Previewer to a separate library in Quipper.Utils.Preview + * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy + * Use type class synonyms to avoid warnings about simplifiable class. + * Compatibility: removed obsolete functoin Map.insertWith'. + * Added MultiControlledNot demo. + * Removed dependency on set-monad, which is broken upstream. + * Fixed some bugs in the stabilizer simulation. + * Moved QuantumIf from BF to Libraries. + * Added --help option to all Quipper tools. + * Removed Quipper.Utils.ShowAll + * Fixed some compiler errors and removed some unnecessary type class + assumptions. + +July 27, 2016: Release 0.8 + + * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too + broken and will not be supported by Quipper. + * Added tests/SimulationTest + * Added QPrep and QUnPrep to the simulator + +October 14, 2014: Release 0.7 + + * Portability: compatibility fixes for GHC 7.8. + +January 16, 2014: Release 0.6 + + * Minor edits and documentation updates. + * Added a new gate gate_iX_inv + * Added "alternate" version of synthesis algorithm, using only + generators of determinant 1 if possible. + * Synthesis code is now in an external package "newsynth". + * Rendering code is now in an external package "easyrender". + * Updated for use with fixedprec-0.2.1.0. + +September 2, 2013: Release 0.5 + + * Portability: compatibility fixes for GHC 7.6.2. + * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C + may or may not work on Windows, depending on console. + * Added quipperi script, analogous to ghci. + * New library QuipperLib.ClassicalOptim: algebraic optimization of + auto-generated classical circuits. Added "optimized" oracle to BWT + algorithm. + * QuipperLib.Decompose: Added decomposition into a "standard" gate + set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT. + Added KeepPhase flag to some transformers. + * QuipperLib.GateDecompositions: added more gates. + * New library Libraries.Synthesis.RotationDecomposition: implements a + variant of the algorithm from Nielsen and Chuang to decompose an + nxn unitary operator into one- and two-level rotations. + * New library QuipperLib.Unboxing: unboxing transformers. + * Updated ASCII output format; improved circuit parser efficiency. + * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits, + floorlog. + * Fixed handling of iterated subroutines in depth transformer. + * Documentation updates and minor refactoring. + +June 19, 2013: Release 0.4 + + * First public release. diff --git a/README b/README deleted file mode 100644 --- a/README +++ /dev/null @@ -1,428 +0,0 @@ -This file is part of Quipper. Copyright (C) 2011-2016. Please see the -file COPYRIGHT for a list of authors, copyright holders, licensing, -and other details. All rights reserved. - -====================================================================== - -This is Quipper. - -Copyright, License, and Disclaimers -=================================== - -See the file COPYRIGHT. - -Installing the necessary components -=================================== - -For installing on Linux, Mac OS X, and other Unix-like systems: please -first see the instructions in INSTALLING, then continue to read below. - -For installing on Windows: please first see the instructions in -INSTALLING.windows, then continue to read below. - -Configuring the software environment -===================================== - -Before you can compile Quipper, you have to install some Haskell -libraries: - - * random >= 1.0.1.1 - * mtl >= 2.1.2 - * primes >= 0.2.1.0 - * Lattices >= 0.0.1 (note: "Lattices" must be capitalized) - * zlib >= 0.5.4.1 - * easyrender >= 0.1.0.0 - * fixedprec >= 0.2.1.0 - * newsynth >= 0.3.0.1 - * containers >= 0.5.2.1 - * set-monad >= 0.1.0.0 - * QuickCheck >= 2.6 - -This can be done using Cabal. On the command line, use the -following commands: - -cabal update - -then: - -cabal install random -cabal install mtl -cabal install primes -cabal install Lattices -cabal install zlib -cabal install easyrender -cabal install fixedprec -cabal install newsynth -cabal install containers -cabal install set-monad -cabal install QuickCheck - -Note: When upgrading from a previous version of Quipper, please ensure -that the fixedprec library is version 0.2.1.0 or newer; Quipper 0.6 -will not work with earlier versions of fixedprec. Also ensure that the -newsynth library has been compiled against the same version of -fixedprec as Quipper. If you get strange error messages related to -fixedprec, try - -cabal install fixedprec -cabal install newsynth --reinstall - -You now have all the necessary Haskell libraries. - -Special note for GHC 7.4.2: -=========================== - -The combination of GHC 7.4.2 and Template Haskell 2.8.0.0 is not -possible, because it triggers a GHC bug. If you get a compilation -error of the form: "ghc: panic! (the 'impossible' happened)", follow -these steps: - -# Remove Template Haskell 2.8.0.0: - -ghc-pkg unregister --force template-haskell-2.8.0.0 - -# Reinstall QuickCheck (because of a broken dependency). This will -# also install template-haskell-2.7.0.0: - -cabal install QuickCheck - -Special note for GHC 7.10.*: -============================ - -Quipper will not work with ghc 7.10. Please use ghc 7.8 or earlier, or -ghc 8.0 or later. - -Browsing the documentation and source code -========================================== - -While it is possible the browse the Quipper source code in a text -editor, it is much nicer to browse the documented source by pointing -your web browser to doc/frames.html in this Quipper distribution. The -documented source is fully cross-referenced and indexed, with links to -color-coded raw source files. - - -Building the documentation -========================== - -Please note: our documentation uses special mark-up and requires -custom tools to be built. Therefore it is not currently possible for -users to re-build the documentation. - - -Building the included algorithms and programs -============================================= - -Compilation, and execution of generated code, are done from the command -line interface. - -The code can be built with "make" from the main directory. This will -build an executable file in each Algorithm subdirectory, which can be -run with various command line parameters to do different things. Run -each command with option --help to see a summary of the usage -information. - -In the following, we describe the set of options for the algorithms -that were implemented. - - -Running the bwt program -======================= - -Usage for Binary Welded Tree algorithm: ---------------------------------------- - -Usage: bwt [OPTION...] - -h --help print usage info and exit - -C --circuit output the whole circuit (default) - -O --oracle output only the oracle - -K --oraclec output the "classical" oracle as a classical circuit - -G --graph print colored graph computed from oracle - -S --simulate run simulations of some circuit fragments for tree height n - -f --format= output format for circuits (default: preview) - -g --gatebase= type of gates to decompose into (default: logical) - -o select oracle to use (default: orthodox) - -n --height= set tree height (positive; default 5) - -c --color= color to use with --oracle (0..3, default 0) - -s --repeats= set parameter s (iteration count; default 1) - -l --large set large problem size: n=300, s=336960 - -t
--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= which part of the circuit to use (default: whole) - -o --oracle= which oracle to use (default: small) - -m --moves= which moves have already been made (default: []) - -f --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= 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= output format for circuits (default: ASCII) - -g --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 --sub= 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 --delta= discriminant Δ (a.k.a. D) (default: 28) - -s --ss= estimated bound on period S, for stage 1 (default: 2) - -i estimated bound on log_2 S, for stage 1 (default: 1) - -r --rr= approximate regulator R, for stage 4 (default: 12.345) - -q The parameter q, for stage 4 (default: 4) - -k The parameter k, for stage 4 (default: 3) - -n The parameter n, for stage 4 (default: 3) - -m The parameter m, for stage 4 (default: 5) - --seed= 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 --template= output a particular circuit template - -f --format= output format for circuits (default: Preview) - -g --gatebase= gates to decompose into (default: Logical) - -m --orbitals= number of orbitals (default: 4) - -o --occupied= number of occupied orbitals (default: 2) - -b --precision= number of precision qubits (default: 3) - -D --delta_e= energy range (default: 6.5536) - -E --e_max= maximum energy (default: -3876.941) - --n0= 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= filename for one-electron data (default: "h_1e_ascii") - --h2= filename for two-electron data (default: "h_2e_ascii") - -d --datadir= 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 --oracle= output only the oracle (default: r) - -f --format= output format for circuits (default: gatecount) - -g --gatebase= type of gates to decompose into (default: logical) - -o select oracle implementation to use (default: blackbox) - -p --param= choose a set of parameters (default: dummy). - -P --peel= peel 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= output format for circuits (default: preview) - -g --gatebase= type of gates to decompose into (default: logical) - -l --l= parameter l (default: 4) - -n --n= parameter n (default: 3) - -r --r= parameter r (default: 2) - -C --QWTFP output the whole circuit (default) - -O --oracle output only the oracle - -s --subroutine= output the chosen subroutine (default: adder) - -Q use alternative qRAM implementation - -o 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= output format for circuits (default: eps) - -g --gatebase= type of gates to decompose into (default: logical) - -n --n= parameter n (default: 5) - -b --b= parameter b (default: 5X5 with entries = 1) - -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 - or Peter Selinger - 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 - * Peter Selinger diff --git a/quipper.cabal b/quipper.cabal --- a/quipper.cabal +++ b/quipper.cabal @@ -1,25 +1,71 @@ --- Initial quipper.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - +-- The name of the package. name: quipper -version: 0.8.2 -synopsis: An embedded, scalable functional programming language for quantum computing. --- description: + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.9.0.0 + +-- A short (one-line) description of the package. +synopsis: + + Meta-package for Quipper. + +-- A longer description of the package. +description: + + This is a meta-package for Quipper, the embedded functional + programming language for quantum computing. Installing this package + automatically installs everything you need for Quipper, including + the quipper-language, quipper-libraries, and quipper-tools. + +-- URL for the project homepage or repository. homepage: http://www.mathstat.dal.ca/~selinger/quipper/ + +-- The license under which the package is released. license: BSD3 + +-- The file containing the license text. license-file: COPYRIGHT -author: Applied Communication Sciences -maintainer: leonardo.taglialegne@gmail.com --- copyright: --- category: + +-- The package author(s). +author: Alexander S. Green, Peter LeFanu Lumsdaine, + Neil J. Ross, Peter Selinger, Benoît Valiron + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: selinger@mathstat.dal.ca + +-- A copyright notice. +copyright: Copyright (c) 2011-2019. All rights reserved. + +-- A classification category for future use by the package catalogue +-- Hackage. These categories have not yet been specified, but the +-- upper levels of the module hierarchy make a good start. +category: Quipper + +-- The type of build used by this package. build-type: Simple -extra-source-files: README -cabal-version: >=1.10 +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >= 1.8 + +-- A list of additional files to be included in source distributions +-- built with setup sdist. +extra-source-files: ChangeLog + library - exposed-modules: Quipper, Quipper.Generic, Quipper.CircLifting, Quipper.Printing, Quipper.Classical, Quipper.QData, Quipper.Internal, Quipper.Monad, Quipper.Control, Quipper.Circuit, Quipper.QClasses, Quipper.Labels, Quipper.Transformer - other-modules: Libraries.Template, Libraries.RandomSource, Libraries.CommandLine, Libraries.Auxiliary, Libraries.Typeable, Libraries.PortableSignals, Libraries.Sampling, Libraries.Tuple, Libraries.Template.LiftQ, Libraries.Template.Auxiliary, Libraries.Template.ErrorMsgQ, Libraries.Template.Lifting - other-extensions: GADTs, RankNTypes, FlexibleInstances, OverlappingInstances, MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances, CPP, StandaloneDeriving, DeriveDataTypeable, ScopedTypeVariables, TypeSynonymInstances, TemplateHaskell, BangPatterns, FlexibleContexts, TypeFamilies, Rank2Types, ExistentialQuantification - build-depends: base >=4.6 && <4.10, random >=1.0 && <1.2, containers >=0.5 && <0.6, unix >=2.6 && <2.8, template-haskell >=2.8 && <2.12, mtl >=2.1 && <2.3, easyrender >=0.1 && <0.2, process >=1.1 && <1.5, directory >=1.2 && <1.3, primes >=0.2 && <0.3 - hs-source-dirs: src - default-language: Haskell2010 + -- Modules exported by the library. + exposed-modules: + + -- Modules included in this library but not exported. + other-modules: + + -- Other library packages from which modules are imported. + build-depends: base >= 4.5 && < 5, + quipper-language >= 0.9.0.0, + quipper-libraries >= 0.9.0.0, + quipper-tools >= 0.9.0.0 diff --git a/src/Libraries/Auxiliary.hs b/src/Libraries/Auxiliary.hs deleted file mode 100644 --- a/src/Libraries/Auxiliary.hs +++ /dev/null @@ -1,926 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module provides miscellaneous general-purpose auxiliary --- functions. - -module Libraries.Auxiliary ( - -- * List operations - applyAt, - overwriteAt, - has_duplicates, - substitute, - - -- * Set and Map related operations - map_provide, - intset_inserts, - intmap_zip, - intmap_zip_errmsg, - intmap_map, - intmap_mapM, - - -- * XIntMaps - XIntMap, - xintmap_delete, - xintmap_deletes, - xintmap_insert, - xintmap_inserts, - xintmap_lookup, - xintmap_member, - xintmap_empty, - xintmap_freshkey, - xintmap_freshkeys, - xintmap_to_intmap, - xintmap_size, - xintmap_dirty, - xintmap_reserves, - xintmap_unreserves, - xintmap_makeclean, - - -- * Various map- and fold-like list combinators - loop, - loop_with_index, - fold_right_zip, - zip_strict, - zip_strict_errmsg, - zip_rightstrict, - zip_rightstrict_errmsg, - zipWith_strict, - zipWith_rightstrict, - - -- * Monadic versions of list combinators - loopM, - loop_with_indexM, - zipRightWithRightStrictM, - zipRightWithRightStrictM_, - fold_right_zipM, - foldRightPairM, - foldRightPairM_, - sequence_right, - sequence_right_, - - -- * Loops - -- $LOOPS - for, - endfor, - foreach, - - -- * Operations for monads - mmap, - monad_join1, - - -- * Operations for disjoint unions - map_either, - map_eitherM, - - -- * Operations for tuples - map_pair, - map_pairM, - - -- * Arithmetic operations - int_ceiling, - - -- * Bit vectors - Boollist(..), - boollist_of_int_bh, - boollist_of_int_lh, - int_of_boollist_unsigned_bh, - int_of_boollist_signed_bh, - bool_xor, - boollist_xor, - - -- * Formatting of lists and strings - string_of_list, - optional, - - -- * Lists optimized for fast concatenation - BList, - blist_of_list, - list_of_blist, - (+++), - blist_empty, - blist_concat, - - -- * Strings optimized for fast concatenation - Strbuf, - strbuf_of_string, - string_of_strbuf, - strbuf_empty, - strbuf_concat, - - -- * The identity monad - Id(..), - - -- * Identity types - Identity, - reflexivity, - symmetry, - transitivity, - identity, - - -- * Error messages - ErrMsg, - - -- * The Curry type class - Curry (..) - ) where - --- import other stuff -import Data.List (foldl') - -import Data.Set (Set) -import qualified Data.Set as Set - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -import qualified Data.Traversable as Traversable - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - --- ---------------------------------------------------------------------- --- * List operations - --- | Apply a function to a specified position in a list. -applyAt :: Int -> (a -> a) -> [a] -> [a] -applyAt _ _ [] = [] -applyAt 0 f (x:xs) = (f x):xs -applyAt n f (x:xs) = x:(applyAt (n-1) f xs) - --- | Overwrite an element at a specified position in a list. -overwriteAt :: Int -> a -> [a] -> [a] -overwriteAt n a = applyAt n (const a) - --- | Check whether a list has duplicates. -has_duplicates :: Ord a => [a] -> Bool -has_duplicates list = aux list (Set.empty) where - aux [] _ = False - aux (h:t) set = if Set.member h set then True else aux t (Set.insert h set) - --- | @'substitute' string character replacement@: --- Replace the first occurrence of /character/ in /string/ by /replacement/. -substitute :: (Eq a) => [a] -> a -> [a] -> [a] -substitute string character replacement = - case break (== character) string of - (x, []) -> x - (x, h:y) -> x ++ replacement ++ y - --- ---------------------------------------------------------------------- --- * Set related operations - --- | Insert the elements of a list in an 'IntSet' (cf. 'IntSet.insert'). -intset_inserts :: [Int] -> IntSet -> IntSet -intset_inserts list set = - foldl' (\t x -> IntSet.insert x t) set list - - --- ---------------------------------------------------------------------- --- * Map related operations - --- | Insert the given key-value pair in a 'Map', but only if the given --- key is not already present. If the key is present, keep the old --- value. -map_provide :: Ord k => k -> a -> Map k a -> Map k a -map_provide = Map.insertWith (\x y -> y) - --- | Take two 'IntMap's /m/[sub 1] and /m/[sub 2], and form a new --- 'IntMap' whose domain is that of /m/[sub 2], and whose value at /k/ --- is the pair (/m/[sub 1] ! /k/, /m/[sub 2] ! /k/). It is an error if --- the domain of /m/[sub 2] is not a subset of the domain of /m/[sub 1]. -intmap_zipright :: IntMap x -> IntMap y -> IntMap (x, y) -intmap_zipright m1 m2 = m where - m = IntMap.mapWithKey f m2 - f k y = case IntMap.lookup k m1 of - Just x -> (x, y) - Nothing -> error "intmap_zipright: shape mismatch" - --- | Take two 'IntMap's with the same domain, and form a new 'IntMap' --- whose values are pairs. It is an error if the two inputs don't have --- identical domains. -intmap_zip :: IntMap x -> IntMap y -> IntMap (x, y) -intmap_zip m1 m2 = intmap_zip_errmsg m1 m2 "intmap_zip: shape mismatch" - --- | Like 'intmap_zip', but also takes an error message to use in case of --- domain mismatch. -intmap_zip_errmsg :: IntMap x -> IntMap y -> String -> IntMap (x, y) -intmap_zip_errmsg m1 m2 errmsg = - if all (\k -> IntMap.member k m2) (IntMap.keys m1) - then intmap_zipright m1 m2 - else error errmsg - --- | Map a function over all values in an 'IntMap'. -intmap_map :: (x -> y) -> IntMap x -> IntMap y -intmap_map = IntMap.map - --- | Monadic version of 'intmap_map'. Map a function over all values --- in an 'IntMap'. -intmap_mapM :: (Monad m) => (x -> m y) -> IntMap x -> m (IntMap y) -intmap_mapM = Traversable.mapM - --- ---------------------------------------------------------------------- --- * XIntMaps. - --- | A 'XIntMap' is just like an 'IntMap', except that it supports --- some additional efficient operations: to find the smallest unused --- key, to find the set of all keys ever used in the past, and to --- reserve a set of keys so that they will not be allocated. Moreover, --- it keeps track of the highest key ever used (whether or not it is --- still used in the current map). - --- This is implemented as a tuple (/m/, /n/, /free/, /h/), where /m/ is an --- 'IntMap', /n/ is an integer such that dom /m/ ⊆ [0../n/-1], /free/ --- ⊆ [0../n/-1] \\ dom /m/ is a set of integers not currently reserved --- or used, and /h/ is the set of all integers used in the past (the --- set of /touched/ wires). - -data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet - -instance (Show a) => Show (XIntMap a) where - show = show . xintmap_to_intmap - --- | Delete a key from the 'XIntMap'. -xintmap_delete :: Int -> XIntMap a -> XIntMap a -xintmap_delete k (XIntMap m n free h) = (XIntMap m' n free' h) where - m' = IntMap.delete k m - free' = IntSet.insert k free - --- | Delete a list of keys from a 'XIntMap'. -xintmap_deletes :: [Int] -> XIntMap a -> XIntMap a -xintmap_deletes list map = - foldl' (\map k -> xintmap_delete k map) map list - --- | Insert a new key-value pair in the 'XIntMap'. -xintmap_insert :: Int -> a -> XIntMap a -> XIntMap a -xintmap_insert k v (XIntMap m n free h) = (XIntMap m' n' free' h') where - m' = IntMap.insert k v m - h' = IntSet.insert k h - n' = max n (k+1) - free' = IntSet.delete k (intset_inserts [n..n'-1] free) - --- | Insert a list of key-value pairs in the 'XIntMap'. -xintmap_inserts :: [(Int,a)] -> XIntMap a -> XIntMap a -xintmap_inserts list map = - foldl' (\map (k,v) -> xintmap_insert k v map) map list - --- | Look up the value at a key in the 'XIntMap'. Return 'Nothing' if --- not found. -xintmap_lookup :: Int -> XIntMap a -> Maybe a -xintmap_lookup k (XIntMap m n free h) = - IntMap.lookup k m - --- | Check whether the given key is in the 'XIntMap'. -xintmap_member :: Int -> XIntMap a -> Bool -xintmap_member k (XIntMap m n free h) = - IntMap.member k m - --- | The empty 'XIntMap'. -xintmap_empty :: XIntMap a -xintmap_empty = (XIntMap m n free h) where - m = IntMap.empty - n = 0 - free = IntSet.empty - h = IntSet.empty - --- | Return the first free key in the 'XIntMap', but without actually --- using it yet. -xintmap_freshkey :: XIntMap a -> Int -xintmap_freshkey (XIntMap m n free h) = - if IntSet.null free then n else IntSet.findMin free - --- | Return the next /k/ unused keys in the 'XIntMap', but without --- actually using them yet. -xintmap_freshkeys :: Int -> XIntMap a -> [Int] -xintmap_freshkeys k (XIntMap m n free h) = ks1 ++ ks2 where - ks1 = take k (IntSet.elems free) - delta = k - (length ks1) - ks2 = [n .. n+delta-1] - --- | Convert a 'XIntMap' to an 'IntMap'. -xintmap_to_intmap :: XIntMap a -> IntMap a -xintmap_to_intmap (XIntMap m n free h) = m - --- | Return the smallest key never used in the 'XIntMap'. -xintmap_size :: XIntMap a -> Int -xintmap_size (XIntMap m n free k) = n - --- | Return the set of all keys ever used in the 'XIntMap'. -xintmap_touched :: XIntMap a -> IntSet -xintmap_touched (XIntMap m n free h) = h - --- | A wire is /dirty/ if it is touched but currently free. -xintmap_dirty :: XIntMap a -> IntSet -xintmap_dirty (XIntMap m n free h) = h `IntSet.intersection` free - --- | Reserve a key in the 'XIntMap'. If the key is not free, do --- nothing. The key must have been used before; for example, this is --- the case if it was returned by 'xintmap_dirty'. -xintmap_reserve :: Int -> XIntMap a -> XIntMap a -xintmap_reserve k (XIntMap m n free h) = (XIntMap m n free' h) where - free' = IntSet.delete k free - --- | Reserve a set of keys in the 'XIntMap'. For any keys that are not --- free, do nothing. All keys must have been used before; for example, --- this is the case if they were returned by 'xintmap_dirty'. -xintmap_reserves :: IntSet -> XIntMap a -> XIntMap a -xintmap_reserves ks (XIntMap m n free h) = (XIntMap m n free' h) where - free' = free `IntSet.difference` ks - --- | Unreserve a key in the 'XIntMap'. If the key is currently used, --- do nothing. The key must have been reserved before, and (therefore) --- must have been used before. -xintmap_unreserve :: Int -> XIntMap a -> XIntMap a -xintmap_unreserve k (XIntMap m n free h) - | IntMap.member k m = (XIntMap m n free h) - | otherwise = (XIntMap m n free' h) - where - free' = IntSet.insert k free - --- | Unreserve a list of keys in the 'XIntMap'. If any key is --- currently used, do nothing. All keys must have been reserved --- before, and (therefore) must have been used before. -xintmap_unreserves :: IntSet -> XIntMap a -> XIntMap a -xintmap_unreserves ks map = - IntSet.fold (\k map -> xintmap_unreserve k map) map ks - --- | Make an exact copy of the 'XIntMap', except that the set of --- touched wires is initially set to the set of used wires. In other --- words, we mark all free and reserved wires as untouched. -xintmap_makeclean :: XIntMap a -> XIntMap a -xintmap_makeclean (XIntMap m n free h) = (XIntMap m n free h') where - h' = IntMap.keysSet m - --- ---------------------------------------------------------------------- --- * Map- and fold-like list combinators - --- ** Combinators for looping - --- | Like 'loop', but also pass a loop counter to the function being --- iterated. Example: --- --- > loop_with_index 3 x f = f 2 (f 1 (f 0 x)) -loop_with_index :: (Eq int, Num int) => int -> t -> (int -> t -> t) -> t -loop_with_index n x f = aux 0 x - where - aux i x = if i == n then x else aux (i+1) (f i x) - --- | Monadic version of 'loop_with_index'. Thus, --- --- > loop_with_indexM 3 x0 f --- --- will do the following: --- --- > do --- > x1 <- f 0 x0 --- > x2 <- f 1 x1 --- > x3 <- f 2 x2 --- > return x3 -loop_with_indexM :: (Eq int, Num int, Monad m) => int -> t -> (int -> t -> m t) -> m t -loop_with_indexM n x f = aux 0 x - where - aux i x = - if i == n then return x else do - x <- f i x - aux (i+1) x - --- | Iterate a function /n/ times. Example: --- --- > loop 3 x f = f (f (f x)) -loop :: (Eq int, Num int) => int -> t -> (t -> t) -> t -loop n x f = loop_with_index n x (\_ -> f) - --- | Monadic version of 'loop'. -loopM :: (Eq int, Num int, Monad m) => int -> t -> (t -> m t) -> m t -loopM n x f = loop_with_indexM n x (\_ -> f) - --- ** Combinators for sequencing - --- | A right-to-left version of 'sequence': Evaluate each action in the --- sequence from right to left, and collect the results. -sequence_right :: Monad m => [m a] -> m [a] -sequence_right [] = return [] -sequence_right (x:xs) = do - ys <- sequence_right xs - y <- x - return (y:ys) - --- | Same as 'sequence_right', but ignore the result. -sequence_right_ :: Monad m => [m a] -> m () -sequence_right_ [] = return () -sequence_right_ (x:xs) = do - ys <- sequence_right_ xs - y <- x - return () - --- ** Combinators for zipping - --- | A \"strict\" version of 'zip', i.e., raises an error when the --- lists are not of the same length. -zip_strict :: [a] -> [b] -> [(a, b)] -zip_strict a b = zip_strict_errmsg a b "zip_strict: lists are not of the same length" - --- | Like 'zip_strict', but also takes an explicit error message to --- use in case of failure. -zip_strict_errmsg :: [a] -> [b] -> String -> [(a, b)] -zip_strict_errmsg [] [] e = [] -zip_strict_errmsg (h:t) (h':t') e = (h,h') : zip_strict_errmsg t t' e -zip_strict_errmsg _ _ e = error e - --- | A \"right strict\" version of 'zip', i.e., raises an error when the --- left list is shorter than the right one. -zip_rightstrict :: [a] -> [b] -> [(a, b)] -zip_rightstrict a b = zip_rightstrict_errmsg a b "zip_rightstrict: list too short" - --- | A version of 'zip_rightstrict' that also takes an explicit error --- message to use in case of failure. -zip_rightstrict_errmsg :: [a] -> [b] -> String -> [(a, b)] -zip_rightstrict_errmsg _ [] s = [] -zip_rightstrict_errmsg (h:t) (h':t') s = (h,h') : zip_rightstrict_errmsg t t' s -zip_rightstrict_errmsg _ _ s = error s - --- | A \"strict\" version of 'zipWith', i.e., raises an error when the --- lists are not of the same length. -zipWith_strict :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWith_strict f [] [] = [] -zipWith_strict f (h:t) (h':t') = f h h' : zipWith_strict f t t' -zipWith_strict f _ _ = error "zipWith_strict: lists are not of the same length" - --- | A \"right strict\" version of 'zipWith', i.e., raises an error when the --- right list is shorter than the left one. -zipWith_rightstrict :: (a -> b -> c) -> [a] -> [b] -> [c] -zipWith_rightstrict f _ [] = [] -zipWith_rightstrict f (h:t) (h':t') = f h h' : zipWith_rightstrict f t t' -zipWith_rightstrict f _ _ = error "zipWith_rightstrict: list too short" - --- | A right-to-left version of 'zipWithM', which is also \"right --- strict\", i.e., raises an error when the right list is shorter than --- the left one. Example: --- --- > zipRightWithM f [a,b] [x,y] = [f a x, f b y], --- --- computed right-to-left. -zipRightWithRightStrictM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipRightWithRightStrictM f l1 l2 = - sequence_right $ zipWith_rightstrict f l1 l2 - --- | Same as 'zipRightWithM', but ignore the result. -zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () -zipRightWithRightStrictM_ f l1 l2 = - sequence_right_ $ zipWith_rightstrict f l1 l2 - --- ** Combinators combining mapping with folding - --- | Fold over two lists with state, and do it right-to-left. For example, --- --- > foldRightPairM (w0, [1,2,3], [a,b,c]) f --- --- will do the following: --- --- > do --- > w1 <- f (w0, 3, c) --- > w2 <- f (w1, 2, b) --- > w3 <- f (w2, 1, a) --- > return w3 -foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w -foldRightPairM (w, [], _) f = return w -foldRightPairM (w, _, []) f = return w -foldRightPairM (w, a:as, b:bs) f = do - w <- foldRightPairM (w, as, bs) f - w <- f (w, a, b) - return w - --- | Like 'foldRightPairM', but ignore the final result. -foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m () -foldRightPairM_ x f = do - foldRightPairM x f - return () - --- | Combine right-to-left zipping and folding. Example: --- --- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c']) --- > where f (w0,c,z) = (w1,c') --- > f (w1,b,y) = (w2,b') --- > f (w2,a,x) = (w3,a') -fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c]) -fold_right_zip f (w, [], []) = (w, []) -fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb') - where - (w1, bb') = fold_right_zip f (w, bb, yy) - (w2, a') = f (w1, a, x) -fold_right_zip f _ = error "fold_right_zip" - --- | Monadic version of 'fold_right_zip'. -fold_right_zipM :: - (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c]) -fold_right_zipM f (w, [], []) = return (w, []) -fold_right_zipM f (w, a:bb, x:yy) = do - (w1, bb') <- fold_right_zipM f (w, bb, yy) - (w2, a') <- f (w1, a, x) - return (w2, a':bb') -fold_right_zipM f _ = error "fold_right_zipM" - --- ---------------------------------------------------------------------- --- * Loops. - --- $LOOPS We provide a syntax for \"for\"-style loops. - --- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/. --- --- Standard notation: --- --- > for i = a to b by s do --- > commands --- > end for --- --- Our notation: --- --- > for a b s $ \i -> do --- > commands --- > endfor - -for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m() -for a b s f = if s > 0 then aux a (<= b) else aux a (>= b) - where - aux i cond = - if cond i then do - f i - aux (i+s) cond - else - return () - --- | Mark the end of a \"for\"-loop. This command actually does --- nothing, but can be used to make the loop look prettier. -endfor :: Monad m => m() -endfor = return () - --- | Iterate a parameter over a list of values. It can be used as --- follows: --- --- > foreach [1,2,3,4] $ \n -> do --- > <<>> --- > 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 - diff --git a/src/Libraries/CommandLine.hs b/src/Libraries/CommandLine.hs deleted file mode 100644 --- a/src/Libraries/CommandLine.hs +++ /dev/null @@ -1,72 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This module provides some functions that are useful in the --- processing of command line options, and that are shared between --- several algorithms. - -module Libraries.CommandLine where - -import Libraries.Auxiliary (string_of_list) - --- import other stuff -import System.Exit -import System.IO -import Data.List -import Data.Char - --- ---------------------------------------------------------------------- --- * Option processing - --- | Exit with an error message after a command line error. This also --- outputs information on where to find command line help. -optfail :: String -> IO a -optfail msg = do - hPutStr stderr msg - hPutStrLn stderr "Try --help for more info." - exitFailure - --- | Parse a string to an integer, or return 'Nothing' on failure. -parse_int :: (Integral r) => String -> Maybe r -parse_int s = case reads s of - [(n, "")] -> Just (fromInteger n) - _ -> Nothing - --- | Parse a string to a list of integers, or return 'Nothing' on failure. -parse_list_int :: String -> Maybe [Int] -parse_list_int s = case reads s of - [(ns, "")] -> Just ns - _ -> Nothing - --- | Parse a string to a 'Double', or return 'Nothing' on failure. -parse_double :: String -> Maybe Double -parse_double s = case reads s of - [(n, "")] -> Just n - _ -> Nothing - --- | In an association list, find the key that best matches the given --- string. If one key matches exactly, return the corresponding --- key-value pair. Otherwise, return a list of all key-value pairs --- whose key have the given string as a prefix. This list could be of --- length 0 (no match), 1 (unique match), or greater (ambiguous key). --- Note: the keys in the association list must be lower case. The --- input string is converted to lower case as well, resulting in --- case-insensitive matching. -match_enum :: [(String, a)] -> String -> [(String, a)] -match_enum list key = - case lookup s list of - Just v -> [(s,v)] - Nothing -> filter (\(k,v) -> isPrefixOf s k) list - where - s = map toLower key - --- | Pretty-print a list of possible values for a parameter. The --- first argument is the name of the parameter, and the second --- argument is its enumeration. -show_enum :: String -> [(String, a)] -> String -show_enum param list = - "Possible values for " ++ param ++ " are: " ++ - string_of_list "" ", " "" "no possible values" fst list ++ ".\n" diff --git a/src/Libraries/PortableSignals.hs b/src/Libraries/PortableSignals.hs deleted file mode 100644 --- a/src/Libraries/PortableSignals.hs +++ /dev/null @@ -1,139 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE CPP #-} - --- | This module provides a thin portability layer for handling user --- interrupts. --- --- The reason is that in the standard Haskell library, this --- functionality is only available in operating system specific --- modules, namely "System.Posix.Signals" (for POSIX systems, --- including Linux) and "GHC.ConsoleHandler" (for Windows). --- --- Note that despite this compatibility layer, there are some --- operating system specific quirks: --- --- * In Windows, console events (such as Control-C) can only be --- received by an application running in a Windows console. Certain --- environments that look like consoles do not support console events, --- such as xterm and rxvt windows, and Cygwin shells with @CYGWIN=tty@ --- set. --- --- * In Windows, setting a handler for any one signal automatically --- overrides the handlers for all signals (effectively ignoring them). --- Also, if the 'Default' or 'Ignore' handler is specified, it --- applies to all signals. We do not currently provide a way to --- specify handlers for multiple signals. - -module Libraries.PortableSignals ( - Signal(..), - Handler(Default,Ignore,Catch,CatchOnce), - installHandler, - with_handler - ) where - -#ifdef mingw32_HOST_OS -import qualified GHC.ConsoleHandler as OS -#else -import qualified System.Posix.Signals as OS -#endif - --- ---------------------------------------------------------------------- --- * Common interface - --- | A data type for signals. This can be extended as needed. -data Signal = - Interrupt -- ^ Control-C event. - | Close -- ^ TERM signal (POSIX) or Close event (Windows). - --- | A data type for handlers. -data Handler = - Default -- ^ Default action. - | Ignore -- ^ Ignore the signal. - | Catch (IO ()) -- ^ Handle the signal in a new thread when the signal is received. - | CatchOnce (IO ()) -- ^ Like 'Catch', but only handle the first such signal. - | OSHandler OS.Handler -- ^ An operating system specific handler. - --- | Install a handler for the given signal. The old handler is --- returned. -installHandler :: Signal -> Handler -> IO Handler -#ifdef mingw32_HOST_OS -installHandler = installHandler_windows -#else -installHandler = installHandler_posix -#endif - --- | Run a block of code with a given signal handler. The previous --- handler is restored when the block terminates. -with_handler :: Signal -> Handler -> IO a -> IO a -with_handler signal handler body = do - oldhandler <- installHandler signal handler - a <- body - installHandler signal oldhandler - return a - --- ---------------------------------------------------------------------- --- * Windows specific code - -#ifdef mingw32_HOST_OS - --- | Check if the Windows 'ConsoleEvent' matches the given abstract --- 'Signal'. We implement this as a relation, rather than a function, --- to allow for more than one 'ConsoleEvent' to match the same --- 'Signal', or for more than one 'Signal' to match the same --- 'ConsoleEvent'. -signal_matches :: OS.ConsoleEvent -> Signal -> Bool -signal_matches OS.ControlC Interrupt = True -signal_matches OS.Close Close = True -signal_matches _ _ = False - --- | Windows implementation of 'installHandler'. -installHandler_windows :: Signal -> Handler -> IO Handler -installHandler_windows signal handler = do - oldhandler <- OS.installHandler (oshandler handler) - return (OSHandler oldhandler) - where - oshandler Default = OS.Default - oshandler Ignore = OS.Ignore - oshandler (Catch body) = OS.Catch $ \event -> do - if signal_matches event signal - then body - else return () - oshandler (CatchOnce body) = OS.Catch $ \event -> do - if signal_matches event signal - then do - -- uninstall the handler - OS.installHandler OS.Default - body - else return () - oshandler (OSHandler h) = h - --- ---------------------------------------------------------------------- --- * POSIX specific code - -#else - --- | Map an abstract 'Signal' to a POSIX specific 'OS.Signal'. -ossignal :: Signal -> OS.Signal -ossignal Interrupt = OS.keyboardSignal -ossignal Close = OS.softwareTermination - --- | Map a 'Handler' to a POSIX specific handler. -oshandler :: Handler -> OS.Handler -oshandler Default = OS.Default -oshandler Ignore = OS.Ignore -oshandler (Catch body) = OS.Catch body -oshandler (CatchOnce body) = OS.CatchOnce body -oshandler (OSHandler h) = h - --- | POSIX implementation of 'installHandler'. -installHandler_posix :: Signal -> Handler -> IO Handler -installHandler_posix signal handler = do - oldhandler <- OS.installHandler (ossignal signal) (oshandler handler) Nothing - return (OSHandler oldhandler) - -#endif diff --git a/src/Libraries/RandomSource.hs b/src/Libraries/RandomSource.hs deleted file mode 100644 --- a/src/Libraries/RandomSource.hs +++ /dev/null @@ -1,25 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} - --- | This module provides a container type for sources of --- randomness. This makes it possible for a source of randomness (any --- instance of the 'RandomGen' class) to be stored in a data structure --- without having to specify its type explicitly. - -module Libraries.RandomSource where - -import System.Random - --- | A container type to hold a source of randomness. This can hold --- any instance of the 'RandomGen' class. -data RandomSource where - RandomSource :: forall g.(RandomGen g) => g -> RandomSource - -instance Show RandomSource where - show x = "g" diff --git a/src/Libraries/Sampling.hs b/src/Libraries/Sampling.hs deleted file mode 100644 --- a/src/Libraries/Sampling.hs +++ /dev/null @@ -1,285 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- -------------------------------------------------------------------- --- | This module provides functions for generating lists of samples --- from a range of input values. This is primarily useful for --- generating test cases. Ranges can be specified for types that are --- members of the 'Interval' class. Each sampling procedure generates --- a (finite or infinite) list of values from the range. We provide --- sampling procedures for --- --- * generating the range in its entirety ('sample_all') --- --- * sampling every /n/th element from a range ('sample_step') --- --- * generating a random sample from the range ('sample_random') - -module Libraries.Sampling ( - - -- * Interval class - Interval(..), - - -- * Zero class - Zero(..), - - -- * Random class - -- $Random - Random, - - -- * Functions - sample_all, - sample_step, - sample_random, - sample_all0, - sample_step0, - sample_random0 - ) where - -import Libraries.Tuple - -import System.Random -import Data.Tuple -import Data.List - --- -------------------------------------------------------------------- --- | The 'Interval' class contains types for which an interval of --- values can be specified by giving a lower bound and an upper --- bound. Intervals are specified as @'interval' min max@, for --- example: --- --- > interval (0,0) (1,2) = [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)]. - -class Interval a where - -- | Takes a range (/min/,/max/) and returns a list of all values with - -- lower bound /min/ and upper bound /max/. - interval :: a -> a -> [a] - -instance Interval Int where - interval x y = [x..y] - -instance Interval Integer where - interval x y = [x..y] - -instance Interval Double where - interval x y = [x..y] - -instance Interval Bool where - interval x y = [x..y] - -instance Interval () where - interval () () = [()] - -instance (Interval a, Interval b) => Interval (a,b) where - interval (x0,y0) (x1,y1) = [ (x,y) | x <- interval x0 x1, y <- interval y0 y1 ] - -instance (Interval a, Interval b, Interval c) => Interval (a,b,c) where - interval x y = map tuple (interval (untuple x) (untuple y)) - -instance (Interval a, Interval b, Interval c, Interval d) => Interval (a,b,c,d) where - interval x y = map tuple (interval (untuple x) (untuple y)) - -instance (Interval a, Interval b, Interval c, Interval d, Interval e) => Interval (a,b,c,d,e) where - interval x y = map tuple (interval (untuple x) (untuple y)) - -instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f) => Interval (a,b,c,d,e,f) where - interval x y = map tuple (interval (untuple x) (untuple y)) - -instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f, Interval g) => Interval (a,b,c,d,e,f,g) where - interval x y = map tuple (interval (untuple x) (untuple y)) - -instance Interval a => Interval [a] where - interval x y = l where - xy = safe_zip x y "interval: upper and lower bound contain lists of non-matching lengths" - l = aux xy - aux [] = [[]] - aux ((x,y):t) = [ h:t' | h <- interval x y, t' <- aux t ] - --- -------------------------------------------------------------------- --- | Types in the 'Zero' class have an \"origin\", i.e., an element --- that can conveniently serve as the starting point for intervals. - -class Zero a where - -- | Inputs any element of the type and outputs the corresponding - -- \"zero\" element, for example: - -- - -- > zero ([1,2],3,True) = ([0,0],0,False) - zero :: a -> a - -instance Zero Int where - zero _ = 0 - -instance Zero Integer where - zero _ = 0 - -instance Zero Double where - zero _ = 0 - -instance Zero Bool where - zero _ = False - -instance Zero () where - zero () = () - -instance (Zero a, Zero b) => Zero (a,b) where - zero (a,b) = (zero a, zero b) - -instance (Zero a, Zero b, Zero c) => Zero (a,b,c) where - zero x = tuple (zero (untuple x)) - -instance (Zero a, Zero b, Zero c, Zero d) => Zero (a,b,c,d) where - zero x = tuple (zero (untuple x)) - -instance (Zero a, Zero b, Zero c, Zero d, Zero e) => Zero (a,b,c,d,e) where - zero x = tuple (zero (untuple x)) - -instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f) => Zero (a,b,c,d,e,f) where - zero x = tuple (zero (untuple x)) - -instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f, Zero g) => Zero (a,b,c,d,e,f,g) where - zero x = tuple (zero (untuple x)) - -instance Zero a => Zero [a] where - zero l = map zero l - --- -------------------------------------------------------------------- --- $Random --- We extend the class 'System.Random' with tuples and lists. - --- | 0-tuples -instance Random () where - randomR ((),()) g = ((), g) - random g = ((), g) - --- | Pairs -instance (Random a, Random b) => Random (a,b) where - randomR ((a0,b0),(a1,b1)) g = ((a,b), g'') where - (a,g') = randomR (a0,a1) g - (b,g'') = randomR (b0,b1) g' - random g = ((a,b), g'') where - (a,g') = random g - (b,g'') = random g' - --- | Triples -instance (Random a, Random b, Random c) => Random (a,b,c) where - randomR (a,b) g = (t, g') where - a1 = untuple a - b1 = untuple b - (t1,g') = randomR (a1,b1) g - t = tuple t1 - random g = (t, g') where - (t1,g') = random g - t = tuple t1 - --- | 4-Tuples -instance (Random a, Random b, Random c, Random d) => Random (a,b,c,d) where - randomR (a,b) g = (t, g') where - a1 = untuple a - b1 = untuple b - (t1,g') = randomR (a1,b1) g - t = tuple t1 - random g = (t, g') where - (t1,g') = random g - t = tuple t1 - --- | 5-Tuples -instance (Random a, Random b, Random c, Random d, Random e) => Random (a,b,c,d,e) where - randomR (a,b) g = (t, g') where - a1 = untuple a - b1 = untuple b - (t1,g') = randomR (a1,b1) g - t = tuple t1 - random g = (t, g') where - (t1,g') = random g - t = tuple t1 - --- | 6-Tuples -instance (Random a, Random b, Random c, Random d, Random e, Random f) => Random (a,b,c,d,e,f) where - randomR (a,b) g = (t, g') where - a1 = untuple a - b1 = untuple b - (t1,g') = randomR (a1,b1) g - t = tuple t1 - random g = (t, g') where - (t1,g') = random g - t = tuple t1 - --- | 7-Tuples -instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) => Random (a,b,c,d,e,f,g) where - randomR (a,b) g = (t, g') where - a1 = untuple a - b1 = untuple b - (t1,g') = randomR (a1,b1) g - t = tuple t1 - random g = (t, g') where - (t1,g') = random g - t = tuple t1 - --- | Lists -instance Random a => Random [a] where - randomR (a,b) g = (l, g') where - ab = safe_zip a b "randomR: upper and lower bound contain lists of non-matching lengths" - (g', l) = mapAccumL (\g r -> swap $ randomR r g) g ab - random g = ([a], g') where - (a, g') = random g - --- -------------------------------------------------------------------- --- Functions: - --- | @'sample_all' min max@: --- returns a list of all elements from the range (/min/,/max/). This --- is actually just a synonym of 'interval'. -sample_all :: Interval a => a -> a -> [a] -sample_all = interval - --- | @'sample_step' n k min max@: --- returns every /n/th element from the range (/min/,/max/), starting --- with the /k/th element. -sample_step :: (Integral a, Integral b, Interval c) => a -> b -> c -> c -> [c] -sample_step n k x y = list_step n k (interval x y) - --- | @'sample_random' g min max@: --- returns an infinite list of random samples from the range --- (/min/,/max/), using the random number generator /g/. -sample_random :: (Random a, RandomGen g) => g -> a -> a -> [a] -sample_random g x y = randomRs (x,y) g - --- | A variant of 'sample_all' that omits the /min/ argument, and uses --- the 'zero' element of the type instead. -sample_all0 :: (Zero a, Interval a) => a -> [a] -sample_all0 a = sample_all (zero a) a - --- | A variant of 'sample_step' that omits the /min/ argument, and uses --- the 'zero' element of the type instead. -sample_step0 :: (Integral a, Integral b, Zero c, Interval c) => a -> b -> c -> [c] -sample_step0 n k a = sample_step n k (zero a) a - --- | A variant of 'sample_random' that omits the /min/ argument, and uses --- the 'zero' element of the type instead. -sample_random0 :: (Random a, Zero a, RandomGen g) => g -> a -> [a] -sample_random0 g a = sample_random g (zero a) a - --- -------------------------------------------------------------------- --- Local functions: - --- | samples every /n/th element from the list, starting with element /k/ -list_step :: (Integral a, Integral b) => a -> b -> [c] -> [c] -list_step n k [] = [] -list_step n k (h:t) = - if k==0 then - h:(list_step n (n-1) t) - else - list_step n (k-1) t - --- | same as 'zip', but throw an error if length don't match -safe_zip :: [a] -> [b] -> String -> [(a,b)] -safe_zip l1 l2 msg = - if length l1 == length l2 - then zip l1 l2 - else error msg diff --git a/src/Libraries/Template.hs b/src/Libraries/Template.hs deleted file mode 100644 --- a/src/Libraries/Template.hs +++ /dev/null @@ -1,67 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This module provides the public interface to the template lifting --- library. It provides functions that input a Haskell declaration or --- expression (in the form of a Haskell abstract syntax tree), and --- lift this to another declaration or expression, with all functions --- lifted into a specified monad. --- --- This can be combined with Template Haskell to convert source code --- to Haskell abstract syntax trees and vice versa. - -module Libraries.Template ( - -- * Example - -- $EXAMPLE - - -- * General lifting functions - decToMonad, - expToMonad, - - -- * Liftings of specific constants - module Libraries.Template.Auxiliary - ) where - -import Libraries.Template.Lifting -import Libraries.Template.Auxiliary - --- $EXAMPLE --- --- We give an example to illustrate what is meant by \"lifting\" a --- term to a monad. Consider the expression --- --- > f = \g x -> g x x, --- --- which has type --- --- > f :: (a -> a -> b) -> (a -> b). --- --- We can lift this to the 'IO' monad by --- --- * converting the expression to an abstract syntax tree, using the --- special Template Haskell notation [nobr @[| ... |]@]; --- --- * applying the 'expToMonad' function; --- --- * converting the resulting abstract syntax tree back to a term, --- using the special Template Haskell notation [nobr @$( ... )@]. --- --- This allows us to write the following: --- --- > f' = $( expToMonad "IO" [| \g x -> g x x |] ), --- --- which has type --- --- > f' :: IO ((a -> IO (a -> IO b)) -> IO (a -> IO b)), --- --- and is in fact equivalent to --- --- > f'' = return $ \g -> --- > return $ \x -> do --- > h <- g x --- > y <- h x --- > return y - diff --git a/src/Libraries/Template/Auxiliary.hs b/src/Libraries/Template/Auxiliary.hs deleted file mode 100644 --- a/src/Libraries/Template/Auxiliary.hs +++ /dev/null @@ -1,88 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} - --- | This module is for use with "Libraries.Template.Lifting". --- It contains various lifted functions of general use. They are not --- intended to be used directly (although this would not break --- anything). - -module Libraries.Template.Auxiliary where - -import Libraries.Auxiliary (fold_right_zip,fold_right_zipM) -import Data.List -import Control.Monad - --- ---------------------------------------------------------------------- --- * List operations - --- | Lifted version of @'(:)' :: a -> [a] -> [a]@. -template_symb_colon_ :: Monad m => m (a -> m ([a] -> m [a])) -template_symb_colon_ = return $ \h -> return $ \t -> return (h:t) - --- | Lifted version of @'[]' :: [a]@. -template_symb_obracket_symb_cbracket_ :: Monad m => m [a] -template_symb_obracket_symb_cbracket_ = return [] - --- | Lifted version of @'init' :: [a] -> [a]@. -template_init :: Monad m => m ([a] -> m [a]) -template_init = return $ \l -> return (init l) - --- | Lifted version of @'last' :: [a] -> [a]@. -template_last :: Monad m => m ([a] -> m a) -template_last = return $ \l -> return (last l) - --- | Lifted version of @'(++)' :: [a] -> [a] -> [a]@. -template_symb_plus_symb_plus_ :: Monad m => m ([a] -> m ([a] -> m [a])) -template_symb_plus_symb_plus_ = return $ \l1 -> return $ \l2-> return (l1 ++ l2) - --- | Lifted version of 'zip3'. -template_zip3 :: Monad m => m ([a] -> m ([b] -> m ([c] -> m [(a,b,c)]))) -template_zip3 = return $ \x -> return $ \y -> return $ \z -> return (zip3 x y z) - --- | lifted version of @'foldl'@ -template_foldl :: Monad m => m ((a -> m (b -> m a)) -> m (a -> m ([b] -> m a))) -template_foldl = return $ \f -> return $ \a -> return $ \lb -> foldM (auxf f) a lb - where auxf f a b = do - g <- f a - g b - --- | lifted version of @'reverse'@ -template_reverse :: Monad m => m ([a] -> m [a]) -template_reverse = return $ \x -> return (reverse x) - - --- | lifted version of @'zipWith'@ -template_zipWith :: Monad m => m ((a -> m (b -> m c)) -> m ([a] -> m ([b] -> m [c]))) -template_zipWith = return $ \f -> return $ \a -> return $ \b -> zipWithM (auxf f) a b - where auxf f a b = do - g <- f a - g b - --- | Lifted version of @'fold_right_zip'@ -template_fold_right_zip :: - Monad m => m (((a,b,c) -> m (a,d)) -> m ((a,[b],[c]) -> m (a,[d]))) -template_fold_right_zip = return $ \f -> return $ \x -> (fold_right_zipM f x) - --- ---------------------------------------------------------------------- --- * Other operations - --- | Lifted version of the combinator '$'. -template_symb_dollar_ :: Monad m => m ((a -> m b) -> m (a -> m b)) -template_symb_dollar_ = return $ \f -> return $ \x -> f x - --- | Lifted version of @'error' :: String -> a@. Using it will make the --- circuit generation fail with the error described in 'String'. -template_error :: Monad m => m (String -> m a) -template_error = return $ error - --- | Lifted version of @'snd' :: (a,b) -> b@ -template_snd :: Monad m => m ((a,b) -> m b) -template_snd = return $ \(a,b) -> return b - - diff --git a/src/Libraries/Template/ErrorMsgQ.hs b/src/Libraries/Template/ErrorMsgQ.hs deleted file mode 100644 --- a/src/Libraries/Template/ErrorMsgQ.hs +++ /dev/null @@ -1,62 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This module provides a simple monad to encapsulate error --- messages within the 'Q' monad. - -module Libraries.Template.ErrorMsgQ where - -import Language.Haskell.TH - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - --- | Shortcut for 'Either String a'. -type ErrMsg a = Either String a - --- | Type for the monad encapsulating error messages. -data ErrMsgQ a = ErrMsgQ (Q (ErrMsg a)) - -instance Monad ErrMsgQ where - return x = ErrMsgQ $ return $ return x - (>>=) (ErrMsgQ x) f = ErrMsgQ $ do - x' <- x - case x' of - Left s -> return (Left s) - Right r -> let (ErrMsgQ y) = f r in y - -instance Applicative ErrMsgQ where - pure = return - (<*>) = ap - -instance Functor ErrMsgQ where - fmap = liftM - --- | Set an error message, to be thrown. --- Usage: --- --- > errorMsg "an error happened" -errorMsg :: String -> ErrMsgQ a -errorMsg s = ErrMsgQ (return (Left s)) - --- | Make a 'Q' computation error-message aware. -embedQ :: Q a -> ErrMsgQ a -embedQ x = ErrMsgQ $ do x' <- x; return (return x') - --- | Throw the error that has been created, using the given string as --- a prefix. Usage: --- --- > extractQ "name of function: " $ do --- > <> -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 - - diff --git a/src/Libraries/Template/LiftQ.hs b/src/Libraries/Template/LiftQ.hs deleted file mode 100644 --- a/src/Libraries/Template/LiftQ.hs +++ /dev/null @@ -1,288 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This module defines the state monad used in --- 'Libraries.Template.Lifting' for Template Haskell --- term manipulation. -module Libraries.Template.LiftQ where - -import qualified Language.Haskell.TH as TH -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.List as List - -import Language.Haskell.TH (Name) -import Control.Monad.State -import Data.Map (Map) -import Data.Set (Set) - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - -import qualified Libraries.Template.ErrorMsgQ as Err -import Libraries.Template.ErrorMsgQ (ErrMsgQ) - --- | State of the monad. -data LiftState = LiftState { - boundVar :: Map Name Int, -- ^ How many times each name is bound. - prefix :: Maybe String, -- ^ The template prefix . - monadName :: Maybe String -- ^ The name of the monad. -} - --- | An empty state. -emptyLiftState :: LiftState -emptyLiftState = LiftState { - boundVar = Map.empty, - prefix = Nothing, - monadName = Nothing -} - --- | Shortcut to @StateT LiftState ErrMsgQ@. -type LiftQState = StateT LiftState ErrMsgQ - --- | The monad. -data LiftQ a = LiftQ (LiftQState a) - -instance Monad LiftQ where - return x = LiftQ $ return x - (>>=) (LiftQ x) f = LiftQ $ do - x' <- x - let (LiftQ y) = f x' - y - -instance Applicative LiftQ where - pure = return - (<*>) = ap - -instance Functor LiftQ where - fmap = liftM - --- | Retrieve the state from the monad. -getState :: LiftQ LiftState -getState = LiftQ $ mapStateT (\x -> do ((),s) <- x; return (s,s)) - (return ()) - --- | Set the state of the monad. -setState :: LiftState -> LiftQ () -setState s = LiftQ $ mapStateT (\_ -> return ((),s)) - ((return ()) :: LiftQState ()) - --- * Various functions to go back and forth between monads. - --- | From 'ErrMsgQ' to 'LiftQ'. -embedErrMsgQ :: ErrMsgQ a -> LiftQ a -embedErrMsgQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- q; return (y,s)) - (return ()) - --- | From 'TH.Q' to 'LiftQ'. -embedQ :: TH.Q a -> LiftQ a -embedQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- Err.embedQ q; return (y,s)) - (return ()) - --- | Get 'TH.Q' out of 'LiftQ' -extractQ :: String -> LiftQ a -> TH.Q a -extractQ s (LiftQ x) = Err.extractQ s $ evalStateT x emptyLiftState - --- | Set an error message. -errorMsg :: String -> LiftQ a -errorMsg s = embedErrMsgQ $ Err.errorMsg s - - --- * Working with variable names. - --- | Increase the number of binds of a variable name. -addToBoundVar :: Name -> LiftQ () -addToBoundVar n = do - s <- getState - let new_value = - if (Map.member n $ boundVar s) - then 1 + ((boundVar s) Map.! n) - else 0 - setState $ s { boundVar = Map.insert n new_value $ boundVar s } - --- | Decrease the number of binds of a variable name. -removeFromBoundVar :: Name -> LiftQ () -removeFromBoundVar n = do - s <- getState - if (not $ Map.member n $ boundVar s) - then errorMsg ((show n) ++ " is not a bound value") - else let old_value = (boundVar s) Map.! n in - if old_value == 0 - then setState $ s { boundVar = Map.delete n $ boundVar s } - else setState $ s { boundVar = Map.insert n (old_value - 1) $ boundVar s } - --- | Run a computation with a particular name being bound. -withBoundVar :: Name -> LiftQ a -> LiftQ a -withBoundVar n comp = do - addToBoundVar n - a <- comp - removeFromBoundVar n - return a - --- | Run a computation with a particular list of names being bound. -withBoundVars :: [Name] -> LiftQ a -> LiftQ a -withBoundVars names comp = foldl (flip withBoundVar) comp names - --- | Say whether a given name is bound. -isBoundVar :: Name -> LiftQ Bool -isBoundVar n = do - s <- getState - return $ Map.member n $ boundVar s - - --- * Other operations on monad state. - --- | Set the template prefix. -setPrefix :: String -> LiftQ () -setPrefix p = do - s <- getState - case (prefix s) of - Just p' -> errorMsg ("cannot set the prefix to " ++ - (show p) ++ - ": prefix already defined as " ++ - p') - Nothing -> setState $ s { prefix = Just p } - - --- | Get the template prefix. -getPrefix :: LiftQ String -getPrefix = do - s <- getState - case (prefix s) of - Nothing -> errorMsg "undefined prefix" - Just p -> return p - --- | Set the monad name. -setMonadName :: String -> LiftQ () -setMonadName m = do - s <- getState - case (monadName s) of - Just m' -> errorMsg ("cannot set the monad to " ++ - (show m) ++ - ": monad already defined as " ++ - m') - Nothing -> setState $ s { monadName = Just m } - --- | Get the monad name. -getMonadName :: LiftQ String -getMonadName = do - s <- getState - case (monadName s) of - Nothing -> errorMsg "undefined monad" - Just m -> return m - - - - --- * Functions dealing with variable names. - --- | Make a name out of a string. -mkName :: String -> Name -mkName s = TH.mkName s - --- | Make a name out of a string, monadic-style. -newName :: String -> LiftQ Name -newName st = embedQ $ TH.newName st - - - - --- | Make any string into a string containing only @[0-9a-zA-Z_.]@. --- For example, it replaces any occurrence of @\"+\"@ with --- @\"symb_plus_\"@. -sanitizeString :: String -> String -sanitizeString name = - List.concat (List.map - (\c -> - Map.findWithDefault c c - (Map.map (\s -> "symb_" ++ s ++ "_") - unicodeNames)) - (List.map (\x -> [x]) name)) - where - unicodeNames :: Map.Map String String - unicodeNames = Map.fromList - [("!","exclamation"), - ("\"","doublequote"), - ("#","sharp"), - ("$","dollar"), - ("%","percent"), - ("&","ampersand"), - ("'","quote"), - ("(","oparent"), - (")","cparent"), - ("*","star"), - ("+","plus"), - (",","comma"), - ("-","minus"), - -- we keep dots - ("/","slash"), - (":","colon"), - (";","semicolon"), - ("<","oangle"), - ("=","equal"), - (">","cangle"), - ("?","question"), - ("@","at"), - ("[","obracket"), - ("\\","backslash"), - ("]","cbracket"), - ("^","caret"), - -- we keep _ - ("`","graveaccent"), - ("{","obrace"), - ("|","vbar"), - ("}","cbrace"), - ("~","tilde")] - - --- | Take a string and make it into a valid Haskell name starting with --- @\"template_\"@. -templateString :: String -> LiftQ String -templateString s = do - p <- getPrefix - return (p ++ (sanitizeString s)) - --- | Look for the corresponding "template" name. -lookForTemplate :: Name -> LiftQ (Maybe Name) -lookForTemplate n = do - t_string <- templateString $ TH.nameBase n - embedQ $ TH.lookupValueName t_string - --- | Make a the template version of a given name. -makeTemplateName :: Name -> LiftQ Name -makeTemplateName n = do - t_string <- templateString $ TH.nameBase n - return $ TH.mkName t_string - - --- * Other functions. - --- | Print on the terminal a monadic, printable object. -prettyPrint :: TH.Ppr a => LiftQ a -> IO () -prettyPrint x = (TH.runQ $ extractQ "prettyPrint: " x) >>= (putStrLn . TH.pprint) - - --- | Project patterns out of a clause. -clauseGetPats :: TH.Clause -> [TH.Pat] -clauseGetPats (TH.Clause pats _ _) = pats - - --- | Check that the list is a non-empty repetition of the same --- element. -equalNEListElts :: Eq a => [a] -> Bool -equalNEListElts [] = True -equalNEListElts (h:list) = foldl (&&) True $ map (== h) list - - --- | Returns the length of the patterns in a list of clauses. Throw an --- error if the patterns do not have all the same size. -clausesLengthPats :: [TH.Clause] -> LiftQ Int -clausesLengthPats [] = errorMsg "empty clause" -clausesLengthPats clauses - | (equalNEListElts $ map length $ map clauseGetPats clauses) = - return $ length $ clauseGetPats $ head clauses -clausesLengthPats _ = errorMsg "patterns in clause are not of equal size" - diff --git a/src/Libraries/Template/Lifting.hs b/src/Libraries/Template/Lifting.hs deleted file mode 100644 --- a/src/Libraries/Template/Lifting.hs +++ /dev/null @@ -1,636 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE RankNTypes #-} - --- | This module describes stripped-down Template Haskell abstract --- syntax trees (ASTs) for a subset of Haskell. - -module Libraries.Template.Lifting where - -import Control.Monad.State - -import qualified Data.Map as Map -import Data.Map (Map) - -import qualified Data.List as List - -import Data.Maybe (catMaybes) - -import qualified Data.Set as Set -import Data.Set (Set) - -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH (Name) - --- Get the monad to build the lifting. -import Libraries.Template.LiftQ - - --- * Abstract syntax trees of a simplified language - --- | There are no \"guarded bodies\". One net effect is to make the --- \"where\" construct equivalent to a simple \"let\". -type Body = Exp - --- | Literals. -data Lit = - CharL Char -- ^ Characters. - | IntegerL Integer -- ^ Integers. - | RationalL Rational -- ^ Reals. - deriving (Show) - - --- | Patterns. -data Pat = - LitP Lit -- ^ Literal. - | VarP Name -- ^ Variable name. - | TupP [Pat] -- ^ Tuple. - | WildP -- ^ Wildchar. - | ListP [Pat] -- ^ List as @[...]@. - | ConP Name [Pat] -- ^ Cons: @h:t@. - deriving (Show) - --- | Match term construct. -data Match = - Match Pat Body - deriving (Show) - --- | First-level declaration. -data Dec = - ValD Name Body - deriving (Show) - --- | Expression -data Exp = - VarE Name -- ^ Variable name. - | ConE Name -- ^ Constant name. - | LitE Lit -- ^ Literal. - | AppE Exp Exp -- ^ Application. - | LamE Name Exp -- ^ Lambda abstraction. - | TupE [Exp] -- ^ Tuple. - | CondE Exp Exp Exp -- ^ If-then-else. - | LetE [Dec] Exp -- ^ Let-construct. - | CaseE Exp [Match] -- ^ Case distinction - | ListE [Exp] -- ^ List: @[...]@. - | ReturnE -- ^ hardcoded constant for @'return'@. - | MAppE -- ^ hardcoded constant for @'>>='@. - deriving (Show) - - --- $ Syntactic sugar to recover do-notation. - --- | Datatype to encode the notation @x <- expr@. -data BindS = BindS Name Exp - --- | A simple @do@: list of monadic @let@ followed by a computation. -doE :: [BindS] -> Exp -> Exp -doE binds exp = foldr doOne exp binds - where - doOne :: BindS -> Exp -> Exp - doOne (BindS n value) computation = AppE (AppE MAppE value) (LamE n computation) - - --- * Variable substitution - - --- | Get the set of variable names in a pattern. -getVarNames :: Pat -> Set Name -getVarNames (VarP n) = Set.singleton n -getVarNames (TupP pats) = Set.unions $ map getVarNames pats -getVarNames (ListP pats) = Set.unions $ map getVarNames pats -getVarNames _ = Set.empty - --- | Substitution in a @'Match'@. -substMatch :: Name -> Exp -> Match -> Match -substMatch n s (Match p e) | Set.member n (getVarNames p) = Match p e - | True = Match p (substExp n s e) - - --- | Substitution in a @'Dec'@. -substDec :: Name -> Exp -> Dec -> Dec -substDec n s (ValD m e) | n == m = ValD m e - | True = ValD m (substExp n s e) - --- | Substitution in an @'Exp'@. -substExp :: Name -> Exp -> Exp -> Exp -substExp n s (VarE m) | n == m = s - | True = (VarE m) -substExp n s (ConE m) = ConE m -substExp n s (LitE l) = LitE l -substExp n s (AppE e1 e2) = AppE (substExp n s e1) (substExp n s e2) -substExp n s (LamE m exp) | n == m = LamE m exp - | True = LamE m $ substExp n s exp -substExp n s (TupE exps) = TupE $ map (substExp n s) exps -substExp n s (CondE e1 e2 e3) = CondE (substExp n s e1) (substExp n s e2) (substExp n s e3) -substExp n s (LetE decs exp) = LetE (map (substDec n s) decs) (substExp n s exp) -substExp n s (CaseE exp matches) = CaseE (substExp n s exp) $ map (substMatch n s) matches -substExp n s (ListE exps) = ListE $ map (substExp n s) exps -substExp n s ReturnE = ReturnE -substExp n s MAppE = MAppE - - --- | Substitution of several variables in one go. -mapSubstExp :: (Map Name Exp) -> Exp -> Exp -mapSubstExp map exp = List.foldl (\exp (x,y) -> substExp x y exp) exp $ Map.toList map - - --- * Downgrading Template Haskell to AST - --- | Downgrading TH literals to @'Exp'@. -litTHtoExpAST :: TH.Lit -> LiftQ Exp -litTHtoExpAST (TH.CharL c) = return $ LitE $ CharL c -litTHtoExpAST (TH.StringL s) = return $ ListE $ map (LitE . CharL) s -litTHtoExpAST (TH.IntegerL i) = return $ LitE $ IntegerL i -litTHtoExpAST (TH.RationalL r) = return $ LitE $ RationalL r -litTHtoExpAST x = errorMsg ("lifting not handled for " ++ (show x)) - --- | Downgrading TH literals to @'Pat'@. -litTHtoPatAST :: TH.Lit -> LiftQ Pat -litTHtoPatAST (TH.CharL c) = return $ LitP $ CharL c -litTHtoPatAST (TH.StringL s) = return $ ListP $ map (LitP . CharL) s -litTHtoPatAST (TH.IntegerL i) = return $ LitP $ IntegerL i -litTHtoPatAST (TH.RationalL r) = return $ LitP $ RationalL r -litTHtoPatAST x = errorMsg ("lifting not handled for " ++ (show x)) - - --- | Take a list of patterns coming from a @where@ section and output --- a list of fresh names for normalized @let@s. Also gives a mapping --- for substituting inside the expressions. Assume all names in the --- list of patterns are distinct. -normalizePatInExp :: [Pat] -> LiftQ ([Name], Map Name Exp) -normalizePatInExp pats = do - fresh_names <- mapM newName $ replicate (length pats) "normalizePat" - let sets_of_old_names = List.map getVarNames pats - let old_to_fresh old_name = - List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) fresh_names - let old_to_pat old_name = - List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) pats - let list_of_old_names = List.concat $ List.map Set.toList sets_of_old_names - let maybe_list_map = mapM - (\x -> do - fresh <- old_to_fresh x - pat <- old_to_pat x - return (x, CaseE (VarE fresh) [Match pat (VarE x)])) - list_of_old_names - case maybe_list_map of - Nothing -> errorMsg "error in patterns..." - Just l -> return $ (fresh_names, Map.fromList l) - - --- | Build a @let@-expression out of pieces. -whereToLet :: Exp -> [(Pat,Exp)] -> LiftQ Exp -whereToLet exp [] = return exp -whereToLet exp list = do - (fresh_names, pmap) <- normalizePatInExp $ map fst list - let decs'' = map (uncurry ValD) $ zip fresh_names $ map snd list - let decs' = map (\(ValD n e) -> ValD n $ mapSubstExp pmap e) decs'' - return $ - LetE decs' $ - CaseE (TupE $ map VarE fresh_names) [Match (TupP $ map fst list) exp] - --- | Build a @'Match'@ out of a TH clause -clauseToMatch :: TH.Clause -> LiftQ Match -clauseToMatch (TH.Clause pats body decs) = do - pats' <- mapM patTHtoAST pats - body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs - exp <- whereToLet body' decs' - return $ Match (TupP pats') exp - --- | From a list of TH clauses, make a case-distinction wrapped in a --- lambda abstraction. -clausesToLambda :: [TH.Clause] -> LiftQ Exp -clausesToLambda clauses = do - -- get length of patterns - pats_length <- clausesLengthPats clauses - -- make a list of new names from the function name - fresh_names <- mapM newName $ replicate pats_length "x" - -- make matches out of the clauses. - matches <- mapM clauseToMatch clauses - -- return a simple function with a case-distinction - return $ foldr LamE - (CaseE (TupE $ map VarE fresh_names) matches) - fresh_names - - --- | Downgrade expressions. -expTHtoAST :: TH.Exp -> LiftQ Exp - -expTHtoAST (TH.VarE v) = return $ VarE v -expTHtoAST (TH.ConE n) = return $ ConE n -expTHtoAST (TH.LitE l) = litTHtoExpAST l - -expTHtoAST (TH.AppE e1 e2) = do - e1' <- expTHtoAST e1 - e2' <- expTHtoAST e2 - return $ AppE e1' e2' - -expTHtoAST (TH.InfixE (Just e1) e2 (Just e3)) = do - e1' <- expTHtoAST e1 - e2' <- expTHtoAST e2 - e3' <- expTHtoAST e3 - return $ AppE (AppE e2' e1') e3' - -expTHtoAST (TH.InfixE Nothing e2 (Just e3)) = do - e2' <- expTHtoAST e2 - e3' <- expTHtoAST e3 - n <- newName "x" - return $ LamE n $ AppE (AppE e2' (VarE n)) e3' - -expTHtoAST (TH.InfixE (Just e1) e2 Nothing) = do - e1' <- expTHtoAST e1 - e2' <- expTHtoAST e2 - return $ AppE e2' e1' - -expTHtoAST (TH.InfixE Nothing e2 Nothing) = do - e2' <- expTHtoAST e2 - return e2' - -expTHtoAST (TH.LamE pats exp) = - clausesToLambda [TH.Clause pats (TH.NormalB exp) []] - -expTHtoAST (TH.TupE exps) = do - exps' <- mapM expTHtoAST exps - return (TupE exps') - -expTHtoAST (TH.CondE e1 e2 e3) = do - e1' <- expTHtoAST e1 - e2' <- expTHtoAST e2 - e3' <- expTHtoAST e3 - return $ CondE e1' e2' e3' - -expTHtoAST (TH.LetE decs exp) = do - decs' <- mapM decTHtoAST decs - exp' <- expTHtoAST exp - whereToLet exp' decs' - -expTHtoAST (TH.CaseE exp matches) = do - exp' <- expTHtoAST exp - matches' <- mapM matchTHtoAST matches - return $ CaseE exp' matches' - -expTHtoAST (TH.ListE exps) = do - exps' <- mapM expTHtoAST exps - return $ ListE exps' - - -expTHtoAST (TH.SigE e _) = expTHtoAST e - -expTHtoAST x = errorMsg ("lifting not handled for " ++ (show x)) - - --- | Downgrade match-constructs. -matchTHtoAST :: TH.Match -> LiftQ Match -matchTHtoAST (TH.Match pat body decs) = do - pat' <- patTHtoAST pat - body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs - exp <- whereToLet body' decs' - return $ Match pat' exp - --- | Downgrade bodies into expressions. -bodyTHtoAST :: TH.Body -> LiftQ Exp -bodyTHtoAST (TH.NormalB exp) = expTHtoAST exp -bodyTHtoAST (TH.GuardedB x) = errorMsg ("guarded body not allowed in lifting: " ++ (show x)) - --- | Downgrade patterns. -patTHtoAST :: TH.Pat -> LiftQ Pat -patTHtoAST (TH.LitP l) = litTHtoPatAST l -patTHtoAST (TH.VarP n) = return $ VarP n -patTHtoAST (TH.TupP pats) = do pats' <- mapM patTHtoAST pats; return $ TupP pats' -patTHtoAST (TH.WildP) = return WildP -patTHtoAST (TH.ListP pats) = do pats' <- mapM patTHtoAST pats; return $ ListP pats' -patTHtoAST (TH.ConP n pats) = do pats' <- mapM patTHtoAST pats; return $ ConP n pats' -patTHtoAST (TH.InfixP p1 n p2) = do - p1' <- patTHtoAST p1 - p2' <- patTHtoAST p2 - return $ ConP n [p1',p2'] -patTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x)) - - - - --- | Downgrade first-level declarations. -firstLevelDecTHtoAST :: TH.Dec -> Maybe (LiftQ Dec) -firstLevelDecTHtoAST (TH.FunD name clauses) = Just $ do - exp <- clausesToLambda clauses - name' <- makeTemplateName name - return $ ValD name' $ substExp name (VarE name') exp - -firstLevelDecTHtoAST (TH.ValD (TH.VarP name) body decs) = Just $ do - body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs - exp <- whereToLet body' decs' - name' <- makeTemplateName name - return $ ValD name' $ substExp name (VarE name') exp - -firstLevelDecTHtoAST (TH.ValD _ _ _) = Just $ - errorMsg ("only variables and functions can be lifted as first-level declarations") - -firstLevelDecTHtoAST (TH.SigD _ _) = Nothing - -firstLevelDecTHtoAST x = Just $ errorMsg ("non-implemented lifting: " ++ (show x)) - - --- | Downgrade any declarations (including the ones in @where@-constructs). -decTHtoAST :: TH.Dec -> LiftQ (Pat,Exp) - -decTHtoAST (TH.FunD name clauses) = do - exp <- clausesToLambda clauses - return $ (VarP name, exp) - -decTHtoAST (TH.ValD pat body decs) = do - pat' <- patTHtoAST pat - body' <- bodyTHtoAST body - decs' <- mapM decTHtoAST decs - exp <- whereToLet body' decs' - return $ (pat', exp) - -decTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x)) - - - - --- * Upgrade AST to Template Haskell - --- | Abstract syntax tree of the type of the function 'return'. -typReturnE :: LiftQ TH.Type -typReturnE = do - m_string <- getMonadName - let m = TH.conT (mkName m_string) - embedQ [t| forall x. x -> $(m) x |] - --- | Abstract syntax tree of the type of the function '>>='. -typMAppE :: LiftQ TH.Type -typMAppE = do - m_string <- getMonadName - let m = TH.conT (mkName m_string) - embedQ [t| forall x y. $(m) x -> (x -> $(m) y) -> $(m) y |] - - --- | Upgrade literals -litASTtoTH :: Lit -> TH.Lit -litASTtoTH (CharL c) = TH.CharL c -litASTtoTH (IntegerL i) = TH.IntegerL i -litASTtoTH (RationalL r) = TH.RationalL r - --- | Upgrade patterns. -patASTtoTH :: Pat -> TH.Pat -patASTtoTH (LitP l) = TH.LitP $ litASTtoTH l -patASTtoTH (VarP n) = TH.VarP n -patASTtoTH (TupP pats) = TH.TupP $ map patASTtoTH pats -patASTtoTH WildP = TH.WildP -patASTtoTH (ListP pats) = TH.ListP $ map patASTtoTH pats -patASTtoTH (ConP n pats) = TH.ConP n $ map patASTtoTH pats - --- | Upgrade match-constructs. -matchASTtoTH :: Match -> LiftQ TH.Match -matchASTtoTH (Match p b) = do - exp <- expASTtoTH b - return $ TH.Match (patASTtoTH p) (TH.NormalB exp) [] - --- | Upgrade declarations. -decASTtoTH :: Dec -> LiftQ TH.Dec - -decASTtoTH (ValD n b) = do - exp <- expASTtoTH b - return $ TH.ValD (TH.VarP n) (TH.NormalB exp) [] - - --- | Upgrade expressions. -expASTtoTH :: Exp -> LiftQ TH.Exp - -expASTtoTH (VarE n) = return $ TH.VarE n -expASTtoTH (ConE n) = return $ TH.ConE n -expASTtoTH (LitE l) = return $ TH.LitE $ litASTtoTH l - -expASTtoTH (AppE e1 e2) = do - e1' <- expASTtoTH e1 - e2' <- expASTtoTH e2 - return $ TH.AppE e1' e2' - -expASTtoTH (LamE n e) = do - e' <- expASTtoTH e - return $ TH.LamE [TH.VarP n] e' - -expASTtoTH (TupE exps) = do - exps' <- mapM expASTtoTH exps - return $ TH.TupE exps' - -expASTtoTH (CondE e1 e2 e3) = do - e1' <- expASTtoTH e1 - e2' <- expASTtoTH e2 - e3' <- expASTtoTH e3 - return $ TH.CondE e1' e2' e3' - -expASTtoTH (LetE decs e) = do - decs' <- mapM decASTtoTH decs - e' <- expASTtoTH e - return $ TH.LetE decs' e' - -expASTtoTH (CaseE e matches) = do - e' <- expASTtoTH e - m' <- mapM matchASTtoTH matches - return $ TH.CaseE e' m' - -expASTtoTH (ListE exps) = do - exps' <- mapM expASTtoTH exps - return $ TH.ListE exps' - -expASTtoTH ReturnE = do - t <- typReturnE - maybe_r <- embedQ $ TH.lookupValueName "return" - case maybe_r of - Just r -> return $ TH.SigE (TH.VarE r) t - Nothing -> errorMsg "\'return\' undefined" - -expASTtoTH MAppE = do - t <- typMAppE - maybe_a <- embedQ $ TH.lookupValueName ">>=" - case maybe_a of - Just a -> return $ TH.SigE (TH.VarE a) t - Nothing -> errorMsg "\'>>=\' undefined" - - - - --- * Lifting AST terms (into AST terms) - --- | Variable referring to the lifting function for integers. -liftIntegerL :: Exp -liftIntegerL = VarE $ mkName "template_integer" - --- | Variable referring to the lifting function for reals. -liftRationalL :: Exp -liftRationalL = VarE $ mkName "template_rational" - --- | Lifting literals. -liftLitAST :: Lit -> LiftQ Exp -liftLitAST (CharL c) = return (AppE ReturnE (LitE $ CharL c)) -liftLitAST (IntegerL i) = return $ AppE liftIntegerL (LitE $ IntegerL i) -liftLitAST (RationalL r) = return $ AppE liftRationalL (LitE $ RationalL r) - --- | Lifting patterns. -liftPatAST :: Pat -> LiftQ Pat -liftPatAST pat = return pat - --- | Lifting match-constructs. -liftMatchAST :: Match -> LiftQ Match -liftMatchAST (Match pat exp) = do - exp' <- liftExpAST exp - return $ Match pat exp' - --- | Lifting declarations. -liftDecAST :: Dec -> LiftQ Dec -liftDecAST (ValD name exp) = do - exp' <- liftExpAST exp - return $ ValD name exp' - --- | Lifting first-level declarations. -liftFirstLevelDecAST :: Dec -> LiftQ Dec -liftFirstLevelDecAST (ValD name exp) = withBoundVar name $ do - exp' <- liftExpAST exp - return $ ValD name exp' - --- | Lifting expressions. -liftExpAST :: Exp -> LiftQ Exp - -liftExpAST (VarE x) = do - template_name <- lookForTemplate x - case template_name of - Nothing -> do - b <- isBoundVar x - if b - then return $ VarE x - else return $ AppE ReturnE $ VarE x - Just t -> return $ VarE t - -liftExpAST (ConE n) = do - template_name <- lookForTemplate n - case template_name of - Nothing -> do - t <- templateString $ TH.nameBase n - errorMsg ("variable " ++ t ++ " undefined") - Just t -> return $ VarE t - -liftExpAST (LitE l) = liftLitAST l - -liftExpAST (AppE e1 e2) = do - e1' <- liftExpAST e1 - e2' <- liftExpAST e2 - n1 <- newName "app1" - n2 <- newName "app2" - return $ doE [BindS n1 e1', BindS n2 e2'] $ AppE (VarE n1) (VarE n2) - -liftExpAST (LamE n exp) = do - exp' <- liftExpAST exp - return $ AppE ReturnE $ LamE n exp' - -liftExpAST (TupE exps) = do - exps' <- mapM liftExpAST exps - fresh_names <- mapM newName $ replicate (length exps) "tupe" - return $ - doE (map (uncurry BindS) $ zip fresh_names exps') - (AppE ReturnE $ TupE $ map VarE fresh_names) - -liftExpAST (CondE e1 e2 e3) = do - e1' <- liftExpAST e1 - e2' <- liftExpAST e2 - e3' <- liftExpAST e3 - return $ AppE (AppE (AppE (VarE (mkName "template_if")) (e1')) (e2')) (e3') - - -liftExpAST (LetE decs exp) = - let existing_names = map (\(ValD n _) -> n) decs - in - withBoundVars existing_names $ do - decs' <- mapM liftDecAST decs - exp' <- liftExpAST exp - return $ - LetE decs' exp' - - -liftExpAST (CaseE exp matches) = do - exp' <- liftExpAST exp - matches' <- mapM liftMatchAST matches - fresh_name <- newName "varfromcase" - return $ doE [BindS fresh_name exp'] - $ CaseE (VarE fresh_name) matches' - -liftExpAST (ListE exps) = do - exps' <- mapM liftExpAST exps - fresh_names <- mapM newName $ replicate (length exps) "varfromlist" - return $ - doE (map (uncurry BindS) $ zip fresh_names exps') - $ AppE ReturnE $ ListE $ map VarE fresh_names - --- These two are not supposed to be there! -liftExpAST ReturnE = undefined -liftExpAST MAppE = undefined - - --- | make a declaration into a template-declaration (by renaming with --- the template-prefix). -makeDecTemplate :: Dec -> LiftQ Dec -makeDecTemplate (ValD name exp) = do - name' <- makeTemplateName name - return $ ValD name' $ substExp name (VarE name') exp - - --- * Various pretty printing functions - - --- | pretty-printing Template Haskell declarations. -prettyPrintAST :: TH.Q [TH.Dec] -> IO () -prettyPrintAST x = prettyPrint $ do - x' <- embedQ x - y <- sequence $ catMaybes $ map firstLevelDecTHtoAST x' - mapM decASTtoTH y - --- | Pretty-printing Template Haskell expressions. -prettyPrintLiftExpTH :: TH.Q (TH.Exp) -> IO () -prettyPrintLiftExpTH x = prettyPrint $ do - x' <- embedQ x - y <- expTHtoAST x' - z <- liftExpAST y - expASTtoTH z - --- | Pretty-printing expressions. -prettyPrintLiftExpAST :: LiftQ (Exp) -> IO () -prettyPrintLiftExpAST x = prettyPrint $ do - z <- x - z' <- liftExpAST z - expASTtoTH z' - - --- * The main lifting functions. - - --- | Lift a list of declarations. The first argument is the name of --- the monad to lift into. -decToMonad :: String -> TH.Q [TH.Dec] -> TH.Q [TH.Dec] -decToMonad s x = extractQ "decToMonad: " $ do - setMonadName s - setPrefix "template_" - dec <- embedQ x - decAST <- sequence $ catMaybes $ map firstLevelDecTHtoAST dec - liftedAST <- mapM liftFirstLevelDecAST decAST - mapM decASTtoTH liftedAST - --- | Lift an expression. The first argument is the name of the monad --- to lift into. -expToMonad :: String -> TH.Q TH.Exp -> TH.Q TH.Exp -expToMonad s x = extractQ "expToMonad: " $ do - setMonadName s - setPrefix "template_" - dec <- embedQ x - decAST <- expTHtoAST dec - liftedAST <- liftExpAST decAST - expASTtoTH liftedAST - - diff --git a/src/Libraries/Tuple.hs b/src/Libraries/Tuple.hs deleted file mode 100644 --- a/src/Libraries/Tuple.hs +++ /dev/null @@ -1,103 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} - --- | This module provides isomorphisms between /n/-tuples and repeated --- pairs. It is used to be able to write type classes for /n/-tuples --- more generically. Essentially we want to be able to write code for --- 17-tuples once and for all, rather than once for each type class we --- define. Ideally there would be a standard Haskell library for this. --- --- Two type classes are provided: 'Tuple', and 'TupleOrUnary'. --- 'Tuple' is recommended for most uses. - -module Libraries.Tuple where - --- I only want to write code involving explicit 7-tuples once in my life - --- | This type class relates types of the form @t = (a,b,c,d)@ (“tupled form”) to --- types of the form @s = (a,(b,(c,(d,()))))@ (“standard form”), and provides a way to --- convert between the two representations. --- --- The tupled form can always be deduced from the standard form. - -class TupleOrUnary t s | s -> t where - -- | For example, maps @(a,(b,(c,(d,()))))@ to @(a,b,c,d)@. - weak_tuple :: s -> t - -- | For example, maps @(a,b,c,d)@ to @(a,(b,(c,(d,()))))@. - weak_untuple :: t -> s - -instance TupleOrUnary () () where - weak_tuple () = () - weak_untuple () = () - -instance TupleOrUnary a (a,()) where - weak_tuple (a,()) = a - weak_untuple a = (a,()) - -instance TupleOrUnary (a,b) (a,(b,())) where - weak_tuple (a,(b,())) = (a,b) - weak_untuple (a,b) = (a,(b,())) - -instance TupleOrUnary (a,b,c) (a,(b,(c,()))) where - weak_tuple (a,(b,(c,()))) = (a,b,c) - weak_untuple (a,b,c) = (a,(b,(c,()))) - -instance TupleOrUnary (a,b,c,d) (a,(b,(c,(d,())))) where - weak_tuple (a,(b,(c,(d,())))) = (a,b,c,d) - weak_untuple (a,b,c,d) = (a,(b,(c,(d,())))) - -instance TupleOrUnary (a,b,c,d,e) (a,(b,(c,(d,(e,()))))) where - weak_tuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e) - weak_untuple (a,b,c,d,e) = (a,(b,(c,(d,(e,()))))) - -instance TupleOrUnary (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,())))))) where - weak_tuple (a,(b,(c,(d,(e,(f,())))))) = (a,b,c,d,e,f) - weak_untuple (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,())))))) - -instance TupleOrUnary (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,()))))))) where - weak_tuple (a,(b,(c,(d,(e,(f,(g,()))))))) = (a,b,c,d,e,f,g) - weak_untuple (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,()))))))) - -instance TupleOrUnary (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where - weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (a,b,c,d,e,f,g,h) - weak_untuple (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,())))))))) - -instance TupleOrUnary (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where - weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i) - weak_untuple (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) - -instance TupleOrUnary (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where - weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j) - weak_untuple (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) - --- | In almost all instances, the standard form can also be deduced from the tupled form; --- the only exception is the unary case. The 'Tuple' class includes no new methods, --- adding just this functional dependency. --- --- While the methods of 'Tuple' are always copied from those of 'TupleOrUnary', --- they are renamed, so that use of these methods tells the type checker it --- can use the extra functional dependency. -class (TupleOrUnary t s) => Tuple t s | s -> t, t -> s where - tuple :: s -> t - tuple = weak_tuple - - untuple :: t -> s - untuple = weak_untuple - -instance Tuple () () -instance Tuple (a,b) (a,(b,())) -instance Tuple (a,b,c) (a,(b,(c,()))) -instance Tuple (a,b,c,d) (a,(b,(c,(d,())))) -instance Tuple (a,b,c,d,e) (a,(b,(c,(d,(e,()))))) -instance Tuple (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,())))))) -instance Tuple (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,()))))))) -instance Tuple (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,())))))))) -instance Tuple (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) -instance Tuple (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) diff --git a/src/Libraries/Typeable.hs b/src/Libraries/Typeable.hs deleted file mode 100644 --- a/src/Libraries/Typeable.hs +++ /dev/null @@ -1,58 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE CPP #-} - -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveDataTypeable #-} - -#if __GLASGOW_HASKELL__ < 780 -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -#endif - --- | The standard Haskell module "Data.Typeable" only provides --- instances for tuples up to length 7. Since we need larger tuples, --- we provide the missing instances here. --- --- Unfortunately, there is no easy way to do this portably; once the --- instances get added to "Data.Typeable", we must remove them here. --- --- Please note: type instances do not generate documentation, so there --- is nothing here to document. Please click on \"Source\" above to --- see the source code. - -module Libraries.Typeable where - -import Data.Typeable - -#if __GLASGOW_HASKELL__ >= 708 - -deriving instance Typeable (,,,,,,,) -deriving instance Typeable (,,,,,,,,) -deriving instance Typeable (,,,,,,,,,) - -#else - --- Note: we use scoped type variables so that the typerep is constant; --- it can be computed at compile time. Same trick as in --- Data.Typeable.Internal. -instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h) => Typeable (a,b,c,d,e,f,g,h) where - typeOf _ = typerep - where - typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h) ] - -instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i) => Typeable (a,b,c,d,e,f,g,h,i) where - typeOf _ = typerep - where - typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i) ] - -instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j) => Typeable (a,b,c,d,e,f,g,h,i,j) where - typeOf _ = typerep - where - typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i), typeOf (undefined :: j) ] - -#endif diff --git a/src/Quipper.hs b/src/Quipper.hs deleted file mode 100644 --- a/src/Quipper.hs +++ /dev/null @@ -1,529 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This is the main export module for Quipper, collecting everything --- that Quipper applications need. This is Quipper's \"public\" --- interface. - -module Quipper ( - -- * The Circ monad - Circ(..), - - -- * Basic types - Qubit, - Bit, - Qulist, - Bitlist, - - -- * Basic gates - -- $BASIC - Timestep, - - -- $FUNCTIONAL_ANCHOR - - -- ** Reversible gates in functional style - -- $FUNCTIONAL - qnot, - hadamard, - gate_H, - gate_X, - gate_Y, - gate_Z, - gate_S, - gate_S_inv, - gate_T, - gate_T_inv, - gate_E, - gate_E_inv, - gate_omega, - gate_V, - gate_V_inv, - expZt, - rGate, - gate_W, - gate_iX, - gate_iX_inv, - global_phase, - global_phase_anchored, - qmultinot, - cnot, - swap, - - -- $IMPERATIVE_ANCHOR - - -- ** Reversible gates in imperative style - -- $IMPERATIVE - qnot_at, - hadamard_at, - gate_H_at, - gate_X_at, - gate_Y_at, - gate_Z_at, - gate_S_at, - gate_S_inv_at, - gate_T_at, - gate_T_inv_at, - gate_E_at, - gate_E_inv_at, - gate_omega_at, - gate_V_at, - gate_V_inv_at, - expZt_at, - rGate_at, - gate_W_at, - gate_iX_at, - gate_iX_inv_at, - qmultinot_at, - cnot_at, - swap_at, - - -- ** Gates for state preparation and termination - qinit, - qterm, - qdiscard, - cinit, - cterm, - cdiscard, - qc_init, - qc_init_with_shape, - qc_term, - qc_discard, - measure, - prepare, - qc_measure, - qc_prepare, - - -- ** Gates for classical circuits - -- $CLASSICAL - cgate_xor, - cgate_eq, - cgate_not, - cgate_and, - cgate_or, - cgate_if, - circ_if, - - -- ** User-defined gates - named_gate, - named_gate_at, - named_rotation, - named_rotation_at, - extended_named_gate, - extended_named_gate_at, - - -- ** Dynamic lifting - dynamic_lift, - - -- * Other circuit-building functions - qinit_plusminus, - qinit_of_char, - qinit_of_string, - map_hadamard, - map_hadamard_at, - controlled_not, - controlled_not_at, - bool_controlled_not, - bool_controlled_not_at, - qc_copy, - qc_uncopy, - qc_copy_fun, - qc_uncopy_fun, - mapUnary, - mapBinary, - mapBinary_c, - qc_mapBinary, - - -- * Notation for controls - -- $CONTROLS - ControlSource(..), - ControlList, - (.&&.), - (.==.), - (./=.), - controlled, - - -- * Signed items - Signed(..), - from_signed, - get_sign, - - -- * Comments and labelling - comment, - label, - comment_with_label, - without_comments, - Labelable, - - -- * Hierarchical circuits - box, - nbox, - box_loopM, - loopM_boxed_if, - - -- * Block structure - -- $BLOCK - - -- ** Ancillas - -- $WITHANCILLA - with_ancilla, - with_ancilla_list, - with_ancilla_init, - -- ** Automatic uncomputing - with_computed_fun, - with_computed, - with_basis_change, - -- ** Controls - with_controls, - with_classical_control, - without_controls, - without_controls_if, - -- ** Loops - for, - endfor, - foreach, - loop, - loop_with_index, - loopM, - loop_with_indexM, - - -- * Operations on circuits - -- ** Reversing - reverse_generic, - reverse_simple, - reverse_generic_endo, - reverse_generic_imp, - reverse_generic_curried, - reverse_simple_curried, - reverse_endo_if, - reverse_imp_if, - - -- ** Printing - Format (..), - FormatStyle(..), - format_enum, - print_unary, - print_generic, - print_simple, - print_of_document, - print_of_document_custom, - - -- ** Classical circuits - classical_to_cnot, - classical_to_quantum, - -- ** Ancilla uncomputation - classical_to_reversible, - - -- * Circuit transformers - -- $TRANSFORMATION - - -- ** User-definable transformers - Transformer, - T_Gate(..), - -- ** Pre-defined transformers - identity_transformer, - -- ** An example transformer - -- $TRANSEXAMPLE - - -- ** Applying transformers to circuits - transform_generic, - transform_generic_shape, - - -- ** Auxiliary type definitions - InverseFlag, - NoControlFlag, - B_Endpoint(..), - Endpoint, - Ctrls, - - -- * Automatic circuit generation from classical code - -- $TEMPLATE - module Quipper.CircLifting, - module Libraries.Template, - - -- * Extended quantum data types - -- ** Homogeneous quantum data types - QShape, - QData, - CData, - BData, - - -- ** Heterogeneous quantum data types - QCData, - QCDataPlus, - - -- ** Shape-related operations - -- $SHAPE - bit, - qubit, - qshape, - qc_false, - - -- ** Quantum type classes - -- $QCLASSES - QEq (..), - QOrd (..), - q_lt, - q_gt, - q_le, - q_ge, - - ) where - - -import Quipper.Monad -import Quipper.Generic -import Quipper.QData -import Quipper.QClasses -import Quipper.Control -import Quipper.CircLifting -import Quipper.Transformer (T_Gate(..), Transformer, Ctrls, B_Endpoint(..)) -import Quipper.Circuit (InverseFlag, NoControlFlag, from_signed, get_sign) -import Quipper.Classical -import Quipper.Printing -import Quipper.Labels - -import Libraries.Template -import Libraries.Auxiliary - --- $BASIC --- --- This section contains various elementary gates that can be used as --- building blocks for constructing circuits. - --- $FUNCTIONAL_ANCHOR #FUNCTIONAL# - --- $FUNCTIONAL --- --- The gates in this section are in \"functional\" style, which means --- that they return something. For example, the 'qnot' gate consumes a --- 'Qubit', performs an operation, and outputs a new 'Qubit'. The --- gates should be used like this: --- --- > output <- qnot input --- --- or, for a binary gate: --- --- > (out0, out1) <- gate_W in0 in1 --- --- For each of these gates, we also provide a version in imperative --- style, see <#IMPERATIVE Reversible gates in imperative style> below. - --- $IMPERATIVE_ANCHOR #IMPERATIVE# - --- $IMPERATIVE --- --- The gates in this section are in \"imperative\" style, which means --- that they operate on a qubit \"in place\" and do not return --- anything. The gates should be used like this: --- --- > qnot_at q --- --- or, for a binary gate: --- --- > gate_W_at q0 q1 --- --- For each of these gates, we also provide a version in functional --- style, see <#FUNCTIONAL Reversible gates in functional style> above. - --- * Snippets of additional documentation lifted from import modules: - --- $CLASSICAL --- --- The gates in this section are for constructing classical circuits. --- None of these gates alter or discard their inputs; each gate produces --- a new wire holding the output of the gate. - --- $CONTROLS --- --- Some gates can be controlled by a condition involving one of more --- \"control\" qubits and/or classical bits at circuit execution time. --- Such gates can also be controlled by boolean conditions that are --- known at circuit generation time (in which case the gate will not --- be generated when the control condition is false). This section --- provides a convenient and flexible syntax for specifying controls. --- --- In Quipper, controls can be written in a way that is --- reminiscent of (a restricted set of) ordinary boolean --- expressions. Here are some examples: --- --- > q1 .==. 0 .&&. q2 .==. 1 for Qubits q1, q2 --- --- > q .&&. p means q .==. 1 .&&. p .==. 1 --- --- > qx .==. 5 for a QDInt qx --- --- > q1 .==. 0 .&&. z <= 7 combines quantum and classical controls --- --- > q ./=. b the negation of q .==. b; --- > here b is a boolean. --- --- > [p,q,r,s] a list of positive controls --- --- > [(p, True), (q, False), (r, False), (s, True)] --- > a list of positive and negative controls --- --- Among these infix operators, @(.&&.)@ binds more weakly than --- @(.==.)@, @(./=.)@. --- --- Controls can be attached to a gate by means of the infix --- operator 'controlled': --- --- > gate `controlled` <> - --- $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. diff --git a/src/Quipper/CircLifting.hs b/src/Quipper/CircLifting.hs deleted file mode 100644 --- a/src/Quipper/CircLifting.hs +++ /dev/null @@ -1,563 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - --- | This module provides a user-friendly interface to building --- quantum circuits out of classical functions on booleans. It is --- based on lower-level functionality provided by --- "Libraries.Template". --- --- Technically, the only functions to be used in this module are --- @'decToCircMonad'@, a specialized version of @'decToMonad'@, and --- @'unpack'@. The only useful datatype here is @'BoolParam'@. --- --- One should not have to directly use the other things: they are only --- for the internal use of Template Haskell to build quantum circuits --- out of classical computation on booleans. --- --- Note: in the following, we write circuits in ASCII form. The --- following conventions are used. They are extended in obvious ways --- when applicable (e.g. when writing a ternary gate). --- --- > ---- : wire --- > --- > 0 |-- : initialize an ancilla |0> --- > --- > --| 0 : terminate an ancilla, asserting it was |0> --- > --- > +--+ --- > -| |- : a unary gate --- > +--+ --- > --- > +--+ --- > -| |- --- > | | : a binary gate --- > -| |- --- > +--+ --- > --- > -- -- --- > X : swap gate --- > -- -- --- > --- > --x-- --- > | : controlled-not, applying NOT on the bottom wire if the top one is |1> --- > --N-- --- > --- > --o-- --- > | : controlled-not, applying NOT on the bottom wire if the top one is |0> --- > --N-- - --- NOTE: They are only available because Template Haskell requires --- them to be in a separate module and exported. - -module Quipper.CircLifting ( - -- * Overview - -- $ROLE - - -- * A type of boolean parameters - -- $BOOLPARAM - BoolParam(PTrue,PFalse), - newBool, - template_PFalse, - template_PTrue, - - -- * Lifting classical functions to circuits - -- $TH - decToCircMonad, - --- $BUILDTEMPLATE_ANCHOR #build_circuit# - - -- * Syntactic sugar - -- $BUILDTEMPLATE - - - -- * Circuits for specific operations - -- ** Boolean parameters - - template_newBool, - - -- ** Boolean constants - template_False, - template_True, - -- ** Unary boolean operations - template_not, - -- ** Binary boolean operations - template_symb_ampersand_symb_ampersand_, - template_symb_vbar_symb_vbar_, - template_bool_xor, - -- ** The if-then-else operation - -- $IF - template_if, - -- ** Equality test - template_symb_equal_symb_equal_, - - -- * Generic unpacking - CircLiftingUnpack(..) - -) where - -import Prelude -import Language.Haskell.TH as TH -import Data.Map as Map -import qualified Data.List - -import Quipper.Monad -import qualified Quipper.Monad -import Quipper.Circuit -import Quipper.Generic -import Quipper.QData -import Libraries.Auxiliary (list_of_blist,blist_empty) -import Quipper.Control -import Quipper.QClasses - -import Libraries.Template - - - ----------------------------------------------------------------------- --- * Overview - --- $ROLE Using the tool @'decToMonad'@ designed in "Libraries.Template", we --- can easily generate quantum circuits. Indeed, suppose that we are given the classical oracle --- --- > toyOracle :: Bool -> Bool --- > toyOracle a = f (g a) (h a) --- --- for some @g,h :: Bool -> Bool@ and @f :: Bool -> Bool -> Bool@. If --- /g/ and /h/ are given by quantum circuits of the form --- --- > +-----+ --- > input ---| |-- input wire, assumed to be not modified by the box --- > | | --- > 0 |-| |--- output (was ancilla wire) --- > +-----+ --- --- and if /f/ is given by --- --- > +-----+ --- > input ---| |-- was input 1, assumed to be not modified --- > | | --- > input ---| |-- was input 2, assumed to be not modified --- > | | --- > 0 |--| |-- output (was ancilla wire), --- > +-----+ --- --- we can compositionally generate a circuit @C@ for /toyOracle/ as follows. --- --- > +---+ +---+ --- > input ---| |-- -----------------| |-- (output of g) --- > | g | X +---+ | | --- > 0 |--| |-- --| |--- ------| f |-- (output of h) --- > +---+ | h | X | | (I) --- > 0 |------------| |--- - ----| |-- (output of f) --- > +---+ X +---+ --- > 0 |- ----------- (input of g) --- > --- --- Note that the resulting circuit is a classical, reversible circuit --- (more precisely, the circuit defines a one-to-one function). In --- order to obtain a reversible quantum circuit, one should then apply --- the function @'Quipper.Classical.classical_to_reversible'@ to get the following (we --- keep the same convention of wires as in the definition of @C@): --- --- > +---+ +---+ --- > input--| |-----| |-- still the input --- > | | | | --- > 0 |--| |-----| |--| 0 --- > | C | | D | (II) --- > 0 |--| |--x--| |--| 0 --- > | | | | | --- > 0 |--| |--|--| |--| 0 --- > +---+ | +---+ --- > | --- > output wire---N--------------. --- --- Here @D@ is the inverse of @C@. We now have a circuit of the --- canonical form, computing and then uncomputing its ancillas: --- --- > +-----------+ --- > a --| |- a --- > | toyOracle | --- > z --| |- z + (f (g a) (h a)) --- > +-----------+ --- ----------------------------------------------------------------------- --- * A type of boolean parameters - --- $BOOLPARAM During the construction of a quantum circuit from --- classical code, the type 'Bool' is mapped to the type --- 'Qubit'. However, it is also sometimes useful to specify boolean --- parameters to be used during circuit generation (for example, in --- the BWT algorithm, the color is a parameter). For this purpose, we --- provide a new type 'BoolParam', which is identical to 'Bool' in --- most respects, except that it is not mapped to 'Qubit' during --- circuit generation. - --- | A custom-design boolean type, not modified by circuit generation. -data BoolParam = PTrue | PFalse - deriving (Eq, Show) - --- | Type-cast from BoolParam to Bool -newBool :: BoolParam -> Bool -newBool PTrue = True -newBool PFalse = False - - --- | Lifted version of PFalse. -template_PFalse :: Circ BoolParam -template_PFalse = return PFalse - --- | Lifted version of PTrue. -template_PTrue :: Circ BoolParam -template_PTrue = return PTrue - - ----------------------------------------------------------------------- --- * Lifting classical functions to circuits - --- $TH The main tool for transforming a classical computation into a --- quantum circuit is the function @'decToCircMonad'@. It inputs the --- syntax tree of a classical function, and outputs the syntax tree of --- a corresponding quantum circuit. The type 'Bool' is mapped to --- 'Qubit'; the type 'BoolParam' is unchanged; and each function /f/ : --- /a/ → /b/ is mapped to a function /f'/ : /a'/ → 'Circ' /b'/, --- where /a'/ and /b'/ are the translations of the types /a/ and /b/, --- respectively. --- --- Most of the work is done by the lower-level function --- @'decToMonad'@ from the module "Libraries.Template". --- This lower-level function knows how to deal with many usual --- constructs of the Haskell language, such as function applications, --- lambda-abstractions, let-assignments, case-distinctions, and so --- on. However, @'decToMonad'@ does not by default know how to deal --- with the base cases, i.e., how to extract quantum circuits from --- specific term constants such as @'&&'@, @'||'@, etc. --- --- The purpose of the remainder of this module is to do just that. For --- every constant or function @XXX@ that one may want to use in a --- classical program, we provide an implementation @template_XXX@ as a --- quantum circuit. We refer to @template_XXX@ as the \"lifted\" --- version of @XXX@. The function @'decToCircMonad'@ is a version of --- @'decToMonad'@ that knows about these liftings. - - - --- | Input the syntax tree of a classical function, and output the --- syntax tree of a corresponding quantum function. The type 'Bool' is --- mapped to 'Qubit'; the type 'BoolParam' is unchanged; and and each --- function /f/ : /a/ → /b/ is mapped to a function /f'/ : /a'/ → --- 'Circ' /b'/, where /a'/ and /b'/ are the translations of the types --- /a/ and /b/, respectively. The function 'decToCircMonad' knows --- about many built-in operations such as @'&&'@ and @'||'@, whose --- circuit translations are defined below. -decToCircMonad :: Q [Dec] -> Q [Dec] -decToCircMonad x = decToMonad "Circ" x - --- $BUILDTEMPLATE_ANCHOR #build_circuit# - ---------------------------------------------------------------------- --- * Syntactic sugar - --- $BUILDTEMPLATE Quipper comes equipped with syntactic sugar to ease --- the use of the @'decToCircMonad'@ function. --- --- Although the code --- --- > $( decToCircMonad [d| f x = ... |] ) --- --- is valid, it is possible to use the special keyword --- @build_circuit@, as follows: --- --- > build_circuit --- > f x = ... --- --- This code is equivalent to --- --- > f x = ... --- > $( decToCircMonad [d| f x = ... |] ) --- --- In other words, it generates both a function @f@ of type @a -> ...@ --- and an object @template_f@ of type @Circ (a -> Circ ...)@. --- --- The following spellings are recognized: --- --- > build_circuit f x y z = ... --- --- > build_circuit --- > f x y z = ... --- --- > build_circuit --- > f :: a -> ... --- > f x y z = ... - --- ---------------------------------------------------------------------- --- * Circuits for specific operations - --- ** Boolean parameters - --- | Lifted version of 'newBool': --- --- > newBool :: BoolParam -> Bool. --- --- Depending on the boolean parameter, the circuit is either --- --- > 0 |-- --- --- or --- --- > 1 |-- -template_newBool :: Circ (BoolParam -> Circ Qubit) -template_newBool = return $ \b -> case b of - PTrue -> qinit_qubit True - PFalse -> qinit_qubit False - ----------------------------------------------------------------------- --- ** Boolean constants - --- | Lifted version of 'False': --- --- > False :: Bool. --- --- The circuit is --- --- > 0 |-- output: quantum bit in state |0> -template_False :: Circ Qubit -template_False = qinit_qubit False - --- | Lifted version of 'True': --- --- > True :: Bool. --- --- The circuit is --- --- > 1 |-- output: quantum bit in state |1> -template_True :: Circ Qubit -template_True = qinit_qubit True - - - ----------------------------------------------------------------------- --- ** Unary boolean operations - --- | Lifted version of 'not': --- --- > not :: Bool -> Bool. --- --- The circuit is --- --- > a -----x-- --- > | --- > 1 |--N------- output: not a. -template_not :: Circ (Qubit -> Circ Qubit) -template_not = return $ \b -> do - r <- qinit_qubit True; - qnot_at r `controlled` b - return r - - ----------------------------------------------------------------------- --- ** Binary boolean operations - --- | Lifted version of '&&': --- --- > (&&) :: Bool -> Bool -> Bool. --- --- The circuit is --- --- > a -----x--- --- > | --- > b -----x--- --- > | --- > 0 |--N------- output: a and b. -template_symb_ampersand_symb_ampersand_ :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) -template_symb_ampersand_symb_ampersand_ = - return $ \b1 -> return $ \b2 -> do - r <- qinit_qubit False; - qnot_at r `controlled` [b1,b2]; - return r - --- | Lifted version of '||': --- --- > (||) :: Bool -> Bool -> Bool. --- --- The circuit is --- --- > a -----o--- --- > | --- > b -----o--- --- > | --- > 1 |--N------- output: a or b. -template_symb_vbar_symb_vbar_ :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) -template_symb_vbar_symb_vbar_ = return $ \b1 -> return $ \b2 -> do - r <- qinit_qubit True; - qnot_at r `controlled` b1 .==. 0 .&&. b2 .==. 0; - return r - - --- | Lifted version of 'bool_xor': --- --- > bool_xor :: Bool -> Bool -> Bool. --- --- The circuit is --- --- > a -----x------- --- > | --- > b -----|---x--- --- > | | --- > 0 |--N---N------ output: a xor b. -template_bool_xor :: Circ (Qubit -> Circ (Qubit -> Circ Qubit)) -template_bool_xor = return $ \b1 -> return $ \b2 -> do - r <- qinit_qubit False - qnot_at r `controlled` b1 - qnot_at r `controlled` b2 - return r - - ----------------------------------------------------------------------- --- ** The if-then-else operation - --- $IF The last term we need to build is @'template_if'@, a term --- describing the if-then-else construct as a circuit. - --- | Lifted version of the @if-then-else@ construction: --- --- > if-then-else :: Bool -> b -> b -> b --- --- We only allow first-order terms in the \"then\" and \"else\" --- clauses. The circuit is: --- --- > q -----x---o--- --- > | | --- > a -----x---|--- --- > | | --- > b -----|---x--- --- > | | --- > 0 |--N---N-------- wire output of the function. -template_if :: (QData b) => Circ Qubit -> Circ b -> Circ b -> Circ b -template_if x a b = do - x' <- x; a' <- a; b' <- b; map2Q (testOnQubit x') (a',b') - where - testOnQubit :: Qubit -> (Qubit,Qubit) -> Circ Qubit - testOnQubit x (a,b) = do - r <- qinit_qubit False - qnot_at r `controlled` x .==. 1 .&&. a .==. 1 - qnot_at r `controlled` x .==. 0 .&&. b .==. 1 - return r - --- ---------------------------------------------------------------------- --- * Operations of the Eq class - --- | Lifted version of the '==' operator: --- --- > (==) :: Eq a => a -> a -> Bool -template_symb_equal_symb_equal_ :: (QEq qa) => Circ (qa -> Circ (qa -> Circ Qubit)) -template_symb_equal_symb_equal_ = return $ \qx -> return $ \qy -> do (qx,qy,test) <- q_is_equal qx qy; return test - --- ---------------------------------------------------------------------- --- * Generic unpacking - --- $ The 'decToCircMonad' function produces (and also requires) --- functions with somewhat unwieldy types. We define generic functions --- for unpacking these types into a more useable format, and for --- packing them back. --- --- For example, @'Circ' (qa -> 'Circ' (qb -> 'Circ' qd))@ unpacks --- into the type @qa -> qb -> 'Circ' qd@. --- --- The class 'CircLiftingUnpack' keeps track of the unpacked and --- packed versions of types; so it will have an instance --- --- > @'CircLiftingUnpack' ('Circ' (qa -> 'Circ' (qb -> 'Circ' qd))) (qa -> qb -> 'Circ' qd)@, --- --- and provide functions 'unpack', 'pack' going back and forth between --- these. --- --- Note that 'pack' and 'unpack' do not in general form an --- isomorphism, just a retraction of the packed type onto the unpacked --- type. --- --- Unfortunately the class cannot (in the current implementation) be --- defined in full generality once and for all: whenever a user wishes --- to use a new type @QFoo@ in circuit-building functions, she must --- define an additional base case @'CircLiftingUnpack' ('Circ' QFoo) --- ('Circ' QFoo)@ (with 'pack' and 'unpack' the identity) to use this --- class with types involving @QFoo@. --- --- The crucial case is --- --- > instance ('CircLiftingUnpack' ('Circ' b) b') => 'CircLiftingUnpack' ('Circ' (a -> 'Circ' b)) (a -> b')@. --- --- Unfortunately, this requires @-XUndecidableInstances@, for somewhat --- subtle reasons (see --- , --- ). --- --- The current implementation is fairly restricted, working --- essentially only for cases like the examples above. One can define --- the unpacking more generally; but this restriction keeps the --- definition much simpler, and suffices for most (all?) of the --- circuit-generation functions we use. - --- | The 'decToCircMonad' function produces (and also requires) --- functions with somewhat unwieldy types. The 'CircLiftingUnpack' --- class defines generic functions for unpacking these types into a --- more useable format, and for packing them back. --- --- For example, @'Circ' (qa -> 'Circ' (qb -> 'Circ' qd))@ unpacks into --- the type @qa -> qb -> 'Circ' qd@. --- --- Note that 'pack' and 'unpack' do not in general form an --- isomorphism, just a retraction of the packed type onto the unpacked --- type. -class CircLiftingUnpack packed unpacked | packed -> unpacked, unpacked -> packed where - unpack :: packed -> unpacked - pack :: unpacked -> packed - -instance (CircLiftingUnpack (Circ b) b') => CircLiftingUnpack (Circ (a -> Circ b)) (a -> b') where - unpack cf x = unpack $ do f <- cf; f x - pack f = return $ \x -> pack (f x) - -instance CircLiftingUnpack (Circ Qubit) (Circ Qubit) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ [a]) (Circ [a]) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ ()) (Circ ()) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b)) (Circ (a,b)) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b,c)) (Circ (a,b,c)) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b,c,d)) (Circ (a,b,c,d)) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b,c,d,e)) (Circ (a,b,c,d,e)) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b,c,d,e,f)) (Circ (a,b,c,d,e,f)) where - pack x = x - unpack x = x - -instance CircLiftingUnpack (Circ (a,b,c,d,e,f,g)) (Circ (a,b,c,d,e,f,g)) where - pack x = x - unpack x = x diff --git a/src/Quipper/Circuit.hs b/src/Quipper/Circuit.hs deleted file mode 100644 --- a/src/Quipper/Circuit.hs +++ /dev/null @@ -1,769 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DeriveDataTypeable #-} - --- | Low-level quantum circuit implementation. This is our backend --- implementation of quantum circuits. Note: there is no run-time --- error checking at the moment. --- --- At its heart, a circuit is a list of gates. All well-definedness --- checking (e.g. input arity, output arity, and checking that the --- intermediate gates are connected to legitimate wires) is done --- dynamically, at circuit generation time, and is not stored within --- the circuit itself. This allows circuits to be produced and --- consumed lazily. --- --- Implementation note: this file is in the intermediate stage of a --- code refactoring, and should be considered \"under renovation\". - -module Quipper.Circuit where - --- import other Quipper stuff -import Libraries.Auxiliary - --- import other stuff -import Data.List -import Data.Maybe - -import Data.Set (Set) -import qualified Data.Set as Set - -import Data.Map (Map) -import qualified Data.Map as Map - -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - -import Data.Typeable - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - --- ---------------------------------------------------------------------- --- * Quantum circuit data type - --- | Wire identifier. Wires are currently identified by an integer, --- but the users of this interface should be oblivious to this. -type Wire = Int - --- | Wire type. A wire is either quantum or classical. -data Wiretype = Qbit -- ^ Quantum wire. - | Cbit -- ^ Classical wire. - deriving (Show, Eq, Typeable) - --- | An arity, also known as a typing context, is a map from a finite --- set of wires to wire types. -type Arity = IntMap Wiretype - --- | A signed item of type /a/. 'Signed' /x/ 'True' represents a --- positive item, and 'Signed' /x/ 'False' represents a negative item. --- --- When used with wires in a circuit, a positive sign is used to --- represent a positive control, i.e., a filled dot, and a negative --- sign is used to represent a negative control, i.e., an empty dot. -data Signed a = Signed a Bool - deriving (Show, Typeable) - --- | Extract the underlying item of a signed item. -from_signed :: Signed a -> a -from_signed (Signed a b) = a - --- | Extract the sign of a signed item: 'True' is positive, and --- 'False' is negative. -get_sign :: Signed a -> Bool -get_sign (Signed a b) = b - --- | A list of controlled wires, possibly empty. -type Controls = [Signed Wire] - --- | A time step is a small floating point number used as a --- parameter to certain gates, such as rotation gates or the --- [exp −/iZt/] gate. -type Timestep = Double - --- | A flag that, if 'True', indicates that the gate is inverted. -type InverseFlag = Bool - --- | A flag that, if 'True', indicates that the gate is controllable, --- but any further controls on the gate should be ignored. This is --- used, e.g., for circuits consisting of a basis change, some --- operation, and the inverse basis change. When controlling such a --- circuit, it is sufficient to control the middle operation, so the --- gates belonging to the basis change and its inverse will have the --- NoControlFlag set. -type NoControlFlag = Bool - --- | A flag, to specify if the corresponding subroutine can be controlled. --- Either no control allowed, or all controls, or only classical. -data ControllableFlag = NoCtl | AllCtl | OnlyClassicalCtl - deriving (Eq, Ord, Show) - --- | An identifier for a subroutine. A boxed subroutine is currently --- identified by a pair of: the user-defined name of the subroutine; --- and a value uniquely identifying the type and shape of the argument. --- --- For now, we represent the shape as a string, because this gives an --- easy total 'Ord' instance, needed for "Data.Map". However, in --- principle, one could also use a pair of a type representation and a --- shape term. The implementation of this may change later. -data BoxId = BoxId String String - deriving (Eq, Ord, Show) - --- | A flag that indicates how many times a particular subroutine --- should be repeated. If non-zero, it implies some constraints on --- the type of the subroutine. -data RepeatFlag = RepeatFlag Integer - deriving (Eq,Ord) - -instance Show RepeatFlag where - show (RepeatFlag n) = show n - --- When changing the 'Gate' datatype, also remember to update --- 'gate_arity', 'gate_controls', and 'gate_reverse' below. - --- | The low-level representation of gates. -data Gate = - -- Named reversible quantum gates. - QGate String InverseFlag [Wire] [Wire] Controls NoControlFlag - -- ^ A named reversible quantum gate: @'Qbit'^(m+n) -> - -- 'Qbit'^(m+n)@. The second @['Wire']@ argument should be - -- \"generalized controls\", i.e. wires not modified by the - -- gate. The gate type is uniquely determined by: the name, the - -- number of inputs, and the number of generalized controls. Gates - -- that differ in one of these respects should be regarded as - -- different gates. - - | QRot String InverseFlag Timestep [Wire] [Wire] Controls NoControlFlag - -- ^ A named reversible quantum gate that also depends on a real - -- parameter. This is typically used for phase and rotation - -- gates. The gate name can contain \'%\' as a place holder for - -- the parameter, e.g., @\"exp(-i%Z)\"@. The remaining arguments - -- are as for 'QGate'. - - -- A nullary quantum gate. - | GPhase Timestep [Wire] Controls NoControlFlag - -- ^ Global phase gate: @'1' -> '1'@. The list of wires is just a hint for graphical rendering. - - -- Some classical gates. - | CNot Wire Controls NoControlFlag - -- ^ Classical not: @'Cbit' -> 'Cbit'@. - | CGate String Wire [Wire] NoControlFlag - -- ^ Generic classical gate @1 -> 'Cbit'@. - | CGateInv String Wire [Wire] NoControlFlag - -- ^ Uncompute classical gate @'Cbit' -> 1@, asserting that the - -- classical bit is in the state specified by the corresponding - -- 'CGate'. - | CSwap Wire Wire Controls NoControlFlag - -- ^ Classical swap gate: @'Cbit' * 'Cbit' -> 'Cbit' * 'Cbit'@. - - -- Initialization and assertive termination. - | QPrep Wire NoControlFlag - -- ^ Initialization: @'Cbit' -> 'Qbit'@. - | QUnprep Wire NoControlFlag - -- ^ Measurement @'Qbit' -> 'Cbit'@ with an assertion that the - -- qubit is already in a computational basis state. This kind of - -- measurement loses no information, and is formally the inverse - -- of 'QPrep'. - | QInit Bool Wire NoControlFlag - -- ^ Initialization: @'Bool' -> 'Qbit'@. - | CInit Bool Wire NoControlFlag - -- ^ Initialization: @'Bool' -> 'Cbit'@. - | QTerm Bool Wire NoControlFlag - -- ^ Termination of a 'Qbit' wire with assertion - -- that the qubit is in the specified state: - -- @'Qbit' * 'Bool' -> 1@. - | CTerm Bool Wire NoControlFlag - -- ^ Termination of a 'Cbit' wire with assertion - -- that the bit is in the specified state: - -- @'Cbit' * 'Bool' -> 1@. - - -- Measurement. - | QMeas Wire - -- ^ Measurement: @'Qbit' -> 'Cbit'@. - | QDiscard Wire - -- ^ Termination of a 'Qbit' wire without - -- assertion: @'Qbit' -> 1@ - | CDiscard Wire - -- ^ Termination of a 'Cbit' wire without - -- assertion: @'Cbit' -> 1@ - - -- Dynamic termination. - | DTerm Bool Wire - -- ^ Termination of a 'Cbit' wire, with a comment indicating what - -- the observed state of that wire was. This is typically inserted - -- in a circuit after a dynamic lifting is performed. Unlike - -- 'CTerm', this is in no way an assertion, but simply a record of - -- observed behavior during a particular run of the algorithm. - - -- Subroutines. - | Subroutine BoxId InverseFlag [Wire] Arity [Wire] Arity Controls NoControlFlag ControllableFlag RepeatFlag - -- ^ Reference to a subroutine, assumed to be bound to another - -- circuit. Arbitrary input and output arities. The domain of /a1/ - -- must include the range of /ws1/, and similarly for /a2/ and /ws2/. - - -- Comments. - | Comment String InverseFlag [(Wire,String)] - -- ^ A comment. Does nothing, but can be useful for marking a - -- location or some wires in a circuit. - - deriving Show - --- ---------------------------------------------------------------------- --- * Basic information about gates - --- The following functions must be updated each time the 'Gate' data --- type is changed. - --- | Compute the incoming and outgoing wires of a given gate --- (excluding controls, comments, and anchors). This essentially --- encodes the type information of the basic gates. If a wire is used --- multiple times as an input or output, then 'gate_arity' also --- returns it multiple times; this enables run-time type checking. --- --- Note that 'gate_arity' returns the /logical/ wires, and therefore --- excludes things like labels, comments, and graphical anchors. This --- is in contrast to 'wires_of_gate', which returns the /syntactic/ --- set of wires used by the gate. -gate_arity :: Gate -> ([(Wire, Wiretype)], [(Wire, Wiretype)]) -gate_arity (QGate n inv ws1 ws2 c ncf) = (map (\w -> (w,Qbit)) (ws1 ++ ws2) ,map (\w -> (w,Qbit)) (ws1 ++ ws2)) -gate_arity (QRot n inv t ws1 ws2 c ncf) = (map (\w -> (w,Qbit)) (ws1 ++ ws2) ,map (\w -> (w,Qbit)) (ws1 ++ ws2)) -gate_arity (GPhase t w c ncf) = ([], []) -gate_arity (CNot w c ncf) = ([(w, Cbit)], [(w, Cbit)]) -gate_arity (CGate n w ws ncf) = (cs, (w, Cbit) : cs) - where cs = map (\x -> (x, Cbit)) ws -gate_arity (CGateInv n w ws ncf) = ((w, Cbit) : cs, cs) - where cs = map (\x -> (x, Cbit)) ws -gate_arity (CSwap w1 w2 c ncf) = ([(w1, Cbit), (w2, Cbit)], [(w1, Cbit), (w2, Cbit)]) -gate_arity (QPrep w ncf) = ([(w, Cbit)], [(w, Qbit)]) -gate_arity (QUnprep w ncf) = ([(w, Qbit)], [(w, Cbit)]) -gate_arity (QInit b w ncf) = ([], [(w, Qbit)]) -gate_arity (CInit b w ncf) = ([], [(w, Cbit)]) -gate_arity (QTerm b w ncf) = ([(w, Qbit)], []) -gate_arity (CTerm b w ncf) = ([(w, Cbit)], []) -gate_arity (QMeas w) = ([(w, Qbit)], [(w, Cbit)]) -gate_arity (QDiscard w) = ([(w, Qbit)], []) -gate_arity (CDiscard w) = ([(w, Cbit)], []) -gate_arity (DTerm b w) = ([(w, Cbit)], []) -gate_arity (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = (getTypes ws1 a1, getTypes ws2 a2) - where getTypes ws a = map (\n -> (n, fromJust (IntMap.lookup n a))) ws -gate_arity (Comment s inv ws) = ([], []) - --- | Return the controls of a gate (or an empty list if the gate has --- no controls). -gate_controls :: Gate -> Controls -gate_controls (QGate n inv ws1 ws2 c ncf) = c -gate_controls (QRot n inv t ws1 ws2 c ncf) = c -gate_controls (GPhase t w c ncf) = c -gate_controls (CNot w c ncf) = c -gate_controls (CGate n w ws ncf) = [] -gate_controls (CGateInv n w ws ncf) = [] -gate_controls (CSwap w1 w2 c ncf) = c -gate_controls (QPrep w ncf) = [] -gate_controls (QUnprep w ncf) = [] -gate_controls (QInit b w ncf) = [] -gate_controls (CInit b w ncf) = [] -gate_controls (QTerm b w ncf) = [] -gate_controls (CTerm b w ncf) = [] -gate_controls (QMeas w) = [] -gate_controls (QDiscard w) = [] -gate_controls (CDiscard w) = [] -gate_controls (DTerm b w) = [] -gate_controls (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = c -gate_controls (Comment s inv ws) = [] - --- | Return the 'NoControlFlag' of a gate, or 'False' if it doesn't have one. -gate_ncflag :: Gate -> NoControlFlag -gate_ncflag (QGate n inv ws1 ws2 c ncf) = ncf -gate_ncflag (QRot n inv t ws1 ws2 c ncf) = ncf -gate_ncflag (GPhase t w c ncf) = ncf -gate_ncflag (CNot w c ncf) = ncf -gate_ncflag (CGate n w ws ncf) = ncf -gate_ncflag (CGateInv n w ws ncf) = ncf -gate_ncflag (CSwap w1 w2 c ncf) = ncf -gate_ncflag (QPrep w ncf) = ncf -gate_ncflag (QUnprep w ncf) = ncf -gate_ncflag (QInit b w ncf) = ncf -gate_ncflag (CInit b w ncf) = ncf -gate_ncflag (QTerm b w ncf) = ncf -gate_ncflag (CTerm b w ncf) = ncf -gate_ncflag (Subroutine n inv ws1 a1 ws2 a2 c ncf ctrble _) = ncf --- The remaining gates don't have a 'NoControlFlag'. We list them --- explicitly, so that the typechecker can warn us about new gates --- that must be added here. -gate_ncflag (QMeas _) = False -gate_ncflag (QDiscard _) = False -gate_ncflag (CDiscard _) = False -gate_ncflag (DTerm _ _) = False -gate_ncflag (Comment _ _ _) = False - - --- | Apply the given 'NoControlFlag' to the given 'Gate'. This means, --- if the first parameter is 'True', set the gate's 'NoControlFlag', --- otherwise do nothing. Throw an error if attempting to set the --- 'NoControlFlag' on a gate that can't support this flag. -gate_with_ncflag :: NoControlFlag -> Gate -> Gate -gate_with_ncflag False gate = gate -gate_with_ncflag True (QGate n inv ws1 ws2 c _) = (QGate n inv ws1 ws2 c True) -gate_with_ncflag True (QRot n inv t ws1 ws2 c _) = (QRot n inv t ws1 ws2 c True) -gate_with_ncflag True (GPhase t w c _) = (GPhase t w c True) -gate_with_ncflag True (CNot w c _) = (CNot w c True) -gate_with_ncflag True (CGate n w ws _) = (CGate n w ws True) -gate_with_ncflag True (CGateInv n w ws _) = (CGateInv n w ws True) -gate_with_ncflag True (CSwap w1 w2 c _) = (CSwap w1 w2 c True) -gate_with_ncflag True (QPrep w _) = (QPrep w True) -gate_with_ncflag True (QUnprep w _) = (QUnprep w True) -gate_with_ncflag True (QInit b w _) = (QInit b w True) -gate_with_ncflag True (CInit b w _) = (CInit b w True) -gate_with_ncflag True (QTerm b w _) = (QTerm b w True) -gate_with_ncflag True (CTerm b w _) = (CTerm b w True) -gate_with_ncflag True (Subroutine n inv ws1 a1 ws2 a2 c _ ctrble repeat) = (Subroutine n inv ws1 a1 ws2 a2 c True ctrble repeat) -gate_with_ncflag True (Comment s inv ws) = (Comment s inv ws) --- The remaining gates can't have their 'NoControlFlag' set. We list --- them explicitly, so that the typechecker can warn us about new --- gates that must be added here. -gate_with_ncflag True g@(QMeas _) = - error ("gate " ++ show g ++ " can't be used in a without_controls context") -gate_with_ncflag True g@(QDiscard _) = - error ("gate " ++ show g ++ " can't be used in a without_controls context") -gate_with_ncflag True g@(CDiscard _) = - error ("gate " ++ show g ++ " can't be used in a without_controls context") -gate_with_ncflag True g@(DTerm _ _) = - error ("gate " ++ show g ++ " can't be used in a without_controls context") - --- | Reverse a gate. Throw an error if the gate is not reversible. -gate_reverse :: Gate -> Gate -gate_reverse (QGate n inv ws1 ws2 c ncf) = QGate n (not inv) ws1 ws2 c ncf -gate_reverse (QRot n inv t ws1 ws2 c ncf) = QRot n (not inv) t ws1 ws2 c ncf -gate_reverse (GPhase t w c ncf) = GPhase (-t) w c ncf -gate_reverse (CNot w c ncf) = CNot w c ncf -gate_reverse (CGate n w ws ncf) = CGateInv n w ws ncf -gate_reverse (CGateInv n w ws ncf) = CGate n w ws ncf -gate_reverse (CSwap w1 w2 c ncf) = CSwap w1 w2 c ncf -gate_reverse (QPrep w ncf) = QUnprep w ncf -gate_reverse (QUnprep w ncf) = QPrep w ncf -gate_reverse (QInit b w ncf) = QTerm b w ncf -gate_reverse (CInit b w ncf) = CTerm b w ncf -gate_reverse (QTerm b w ncf) = QInit b w ncf -gate_reverse (CTerm b w ncf) = CInit b w ncf -gate_reverse (Subroutine name inv ws1 a1 ws2 a2 c ncf ctrble repeat) = Subroutine name (not inv) ws2 a2 ws1 a1 c ncf ctrble repeat -gate_reverse (Comment s inv ws) = Comment s (not inv) ws --- The remaining gates are not reversible. We list them explicitly, so --- that the typechecker can warn us about new gates that must be added --- here. -gate_reverse g@(QMeas _) = error ("gate_reverse: gate not reversible: " ++ show g) -gate_reverse g@(QDiscard _) = error ("gate_reverse: gate not reversible: " ++ show g) -gate_reverse g@(CDiscard _) = error ("gate_reverse: gate not reversible: " ++ show g) -gate_reverse g@(DTerm _ _) = error ("gate_reverse: gate not reversible: " ++ show g) - --- ---------------------------------------------------------------------- --- * Auxiliary functions on gates and wires - --- | Return the set of wires used by a list of controls. -wires_of_controls :: Controls -> IntSet -wires_of_controls c = IntSet.fromList (map from_signed c) - --- | Return the set of wires used by a gate (including controls, --- labels, and anchors). --- --- Unlike 'gate_arity', the function 'wires_of_gate' is used for --- printing, and therefore returns all wires that are syntactically --- used by the gate, irrespective of whether they have a logical --- meaning. -wires_of_gate :: Gate -> IntSet -wires_of_gate (Comment s inv ws) = - intset_inserts (map fst ws) (IntSet.empty) -wires_of_gate (GPhase t w c ncf) = - intset_inserts w (wires_of_controls c) -wires_of_gate g = intset_inserts w1 (intset_inserts w2 (wires_of_controls c)) - where - (a1, a2) = gate_arity g - c = gate_controls g - w1 = map fst a1 - w2 = map fst a2 - --- | Like 'wires_of_gate', except return a list of wires. -wirelist_of_gate :: Gate -> [Wire] -wirelist_of_gate g = IntSet.toList (wires_of_gate g) - --- ---------------------------------------------------------------------- --- * Dynamic arities - --- | Recall that an 'Arity' is a set of typed wires, and it determines --- the external interfaces at which circuits and gates can be --- connected. The type 'ExtArity' stores the same information as the --- type 'Arity', but in a format that is more optimized for efficient --- updating. Additionally, it also stores the set of wires ever used. - -type ExtArity = XIntMap Wiretype - --- | Check whether the given gate is well-formed and can be legally --- applied in the context of the given arity. If successful, return --- the updated arity resulting from the gate application. If --- unsuccessful, raise an error. Properties checked are: --- --- * that each gate has non-overlapping inputs, including controls; --- --- * that each gate has non-overlapping outputs, including controls; --- --- * that the inputs of the gate (including controls) are actually --- present in the current arity; --- --- * that the types of the inputs (excluding controls) match those of --- the current arity; --- --- * that the outputs of the gate (excluding controls) don't conflict --- with any wires already existing in the current arity. - -arity_append_safe :: Gate -> ExtArity -> ExtArity -arity_append_safe gate a0 = - case (err0, err1, err2, err3, err4) of - (True, _, _, _, _) -> - error $ "Gate error: duplicate inputs in " ++ show gate - (_, True, _, _, _) -> - error $ "Gate error: duplicate outputs in " ++ show gate - (_, _, Just w, _, _) -> - error $ "Gate application error: no such wire " ++ show w ++ ": " ++ show gate - (_, _, _, Just (w,t), _) -> - error $ "Gate application error: wire " ++ show w ++ ":" ++ show t ++ " has wrong type " ++ show t' ++ ": " ++ show gate - where - Just t' = xintmap_lookup w a0 - (_, _, _, _, Just w) -> - error $ "Gate application error: wire " ++ show w ++ " already exists: " ++ show gate - _ -> a2 - where - (win, wout) = gate_arity gate - c_ids = map from_signed (gate_controls gate) - win_ids = map fst win - wout_ids = map fst wout - err0 = has_duplicates (win_ids ++ c_ids) - err1 = has_duplicates (wout_ids ++ c_ids) - err2 = find (\w -> not $ xintmap_member w a0) (win_ids ++ c_ids) - err3 = find (\(w,t) -> not $ xintmap_lookup w a0 == Just t) win - err4 = find (\w -> xintmap_member w a1) wout_ids - a1 = xintmap_deletes win_ids a0 - a2 = xintmap_inserts wout a1 - --- | Like 'arity_append', but without type checking. This is --- potentially faster, but should only used in applications that have --- already been thoroughly tested or type-checked. -arity_append_unsafe :: Gate -> ExtArity -> ExtArity -arity_append_unsafe gate a0 = a2 - where - (win, wout) = gate_arity gate - a1 = xintmap_deletes (map fst win) a0 - a2 = xintmap_inserts wout a1 - --- | For now, we disable run-time type checking, because we have not --- yet implemented run-time types properly. Therefore, we define --- 'arity_append' to be a synonym for 'arity_append_unsafe'. -arity_append :: Gate -> ExtArity -> ExtArity -arity_append = arity_append_unsafe - --- | Return an empty arity. -arity_empty :: ExtArity -arity_empty = xintmap_empty - --- | Return a wire unused in the current arity. -arity_unused_wire :: ExtArity -> Wire -arity_unused_wire = xintmap_freshkey - --- | Return the next /k/ wires unused in the current arity. -arity_unused_wires :: Int -> ExtArity -> [Wire] -arity_unused_wires = xintmap_freshkeys - --- | Add a new typed wire to the current arity. This returns a new --- wire and the updated arity. -arity_alloc :: Wiretype -> ExtArity -> (Wire, ExtArity) -arity_alloc t arity = (w, arity') where - w = xintmap_freshkey arity - arity' = xintmap_insert w t arity - --- | Convert an extended arity to an ordinary arity. -arity_of_extarity :: ExtArity -> Arity -arity_of_extarity = xintmap_to_intmap - --- | Return the smallest wire id nowhere used in the circuit. -n_of_extarity :: ExtArity -> Int -n_of_extarity = xintmap_size - --- ---------------------------------------------------------------------- --- * Circuit abstraction - --- | A completed circuit /(a1,gs,a2,n)/ has an input arity /a1/, a --- list of gates /gs/, and an output arity /a2/. We also record /n/, --- the total number of wires used by the circuit. Because wires are --- allocated consecutively, this means that the wire id's used are --- [0../n/-1]. -type Circuit = (Arity, [Gate], Arity, Int) - --- | Return the set of all the wires in a circuit. -wirelist_of_circuit :: Circuit -> [Wire] -wirelist_of_circuit (_, _, _, n) = [0..n-1] - --- ---------------------------------------------------------------------- --- ** Reversing low-level circuits - --- | Reverse a gate list. -reverse_gatelist :: [Gate] -> [Gate] -reverse_gatelist gates = reverse (map gate_reverse gates) - --- | Reverse a circuit. Throw an error if the circuit is not reversible. -reverse_circuit :: Circuit -> Circuit -reverse_circuit (a1, gates, a2, n) = (a2, reverse_gatelist gates, a1, n) - --- ---------------------------------------------------------------------- --- ** NoControlFlag on low-level circuits - --- | Set the 'NoControlFlag' on all gates of a circuit. -circuit_to_nocontrol :: Circuit -> Circuit -circuit_to_nocontrol (a1, gates, a2, n) = (a1, gates', a2, n) where - gates' = map (gate_with_ncflag True) gates - --- ---------------------------------------------------------------------- --- ** Ordered circuits - --- | An ordered circuit is a 'Circuit' together with an ordering on --- (usually all, but potentially a subset of) the input and output --- endpoints. --- --- This extra information is required when a circuit is used within a --- larger circuit (e.g. via a 'Subroutine' gate), to identify which wires --- of the sub-circuit should be bound to which wires of the surrounding --- circuit. -newtype OCircuit = OCircuit ([Wire], Circuit, [Wire]) - --- | Reverse an 'OCircuit'. Throw an error if the circuit is not reversible. -reverse_ocircuit :: OCircuit -> OCircuit -reverse_ocircuit (OCircuit (ws_in, circ, ws_out)) = OCircuit (ws_out, reverse_circuit circ, ws_out) - --- ---------------------------------------------------------------------- --- ** Annotated circuits - --- | One often wants to consider the inputs and outputs of a circuit as --- more structured/typed than just lists of bits/qubits; for instance, --- a list of six qubits could be structured as a pair of triples, or a --- triple of pairs, or a six-bit 'QDInt'. --- --- While for the most part this typing information is not included in --- low-level circuits, we need to consider it in hierarchical circuits, --- so that the information stored in a subroutine is sufficient to call --- the subroutine in a typed context. --- --- Specifically, the extra information needed consists of functions to --- destructure the input/output data as a list of typed wires, and --- restructure such a list of wires into a piece of data of the appropriate --- type. -data CircuitTypeStructure a = CircuitTypeStructure (a -> ([Wire],Arity)) (([Wire],Arity) -> a) - deriving (Typeable) - --- | The trivial 'CircuitTypeStructure' on @(['Wire'],'Arity')@. -id_CircuitTypeStructure :: CircuitTypeStructure ([Wire],Arity) -id_CircuitTypeStructure = CircuitTypeStructure id id - --- | Use a 'CircuitTypeStructure' to destructure a piece of (suitably --- typed) data into a list of typed wires. -destructure_with :: CircuitTypeStructure a -> a -> ([Wire],Arity) -destructure_with (CircuitTypeStructure f _) = f - --- | Use a 'CircuitTypeStructure' to structure a list of typed wires --- (of the appropriate length/arity) into a piece of structured data. -structure_with :: CircuitTypeStructure a -> ([Wire],Arity) -> a -structure_with (CircuitTypeStructure _ g) = g - --- ====================================================================== --- * Boxed circuits - --- | A typed subroutine consists of: --- --- * a low-level circuit, ordered to allow binding of incoming and outgoing wires; --- --- * functions for structuring/destructuring the inputs and outputs to and --- from lists of wires (these functions being dynamically typed, since the --- input/output type may vary between subroutines); --- --- * a 'ControllableFlag', recording whether the circuit is controllable. -data TypedSubroutine = forall a b. (Typeable a, Typeable b) => - TypedSubroutine OCircuit (CircuitTypeStructure a) (CircuitTypeStructure b) ControllableFlag - --- | Extract just the 'Circuit' from a 'TypedSubroutine'. -circuit_of_typedsubroutine :: TypedSubroutine -> Circuit -circuit_of_typedsubroutine (TypedSubroutine (OCircuit (_,circ,_)) _ _ _) = circ - --- | A name space is a map from names to subroutine bindings. These --- subroutines can reference each other; it is the programmer’s --- responsibility to ensure there is no circular dependency, and no --- clash of names. -type Namespace = Map BoxId TypedSubroutine - --- | The empty namespace. -namespace_empty :: Namespace -namespace_empty = Map.empty - --- | A function to display the names of all the subroutines in a 'Namespace'. -showNames :: Namespace -> String -showNames ns = show (map (\(n,_) -> n) (Map.toList ns)) - --- | A boxed circuit is a distinguished simple circuit (analogous to a “main” function) together with a namespace. -type BCircuit = (Circuit,Namespace) - --- ---------------------------------------------------------------------- --- ** Ordered circuits - --- | An ordered boxed circuit is a 'BCircuit' together with an --- ordering on the input and output endpoints, or equivalently, an --- 'OCircuit' together with a namespace. -type OBCircuit = (OCircuit,Namespace) - --- | Construct an 'OBCircuit' from a 'BCircuit' and an ordering on the --- input and output endpoints. -ob_circuit :: [Wire] -> BCircuit -> [Wire] -> OBCircuit -ob_circuit w_in (circ, ns) w_out = (OCircuit (w_in, circ, w_out), ns) - --- ====================================================================== --- ** Basic functions lifted to boxed circuits - --- All the basic functions defined on simple circuits now lift --- trivially to boxed circuits: - --- | Reverse a simple boxed circuit, or throw an error if not reversible. -reverse_bcircuit :: BCircuit -> BCircuit -reverse_bcircuit (c,s) = (reverse_circuit c,s) - --- ---------------------------------------------------------------------- --- * The ReadWrite monad - --- $ The 'ReadWrite' monad encapsulates the interaction with a (real --- or simulated) low-level quantum device. - --- | The 'ReadWrite' monad describes a standard read-write computation, --- here specialized to the case where writes are 'Gate's, prompts are --- 'Bit's, and reads are 'Bool's. Thus, a read-write computation can --- do three things: --- --- * terminate with a result. This is the case 'RW_Return'. --- --- * write a single 'Gate' and continue. This is the case 'RW_Write'. --- --- * issue a prompt, which is a 'Wire', then read a 'Bool', then --- continue. This is the case 'RW_Read'. -data ReadWrite a = RW_Return a - | RW_Write !Gate (ReadWrite a) - | RW_Read !Wire (Bool -> ReadWrite a) - | RW_Subroutine BoxId TypedSubroutine (ReadWrite a) - -instance Monad ReadWrite where - return a = RW_Return a - f >>= g = case f of - RW_Return a -> g a - RW_Write gate f' -> RW_Write gate (f' >>= g) - RW_Read bit cont -> RW_Read bit (\bool -> cont bool >>= g) - RW_Subroutine name subroutine f' -> RW_Subroutine name subroutine (f' >>= g) - -instance Applicative ReadWrite where - pure = return - (<*>) = ap - -instance Functor ReadWrite where - fmap = liftM - --- | Transforms a read-write computation into one that behaves identically, --- but also returns the list of gates generated. --- --- This is used as a building block, for example to allow a read-write --- computation to be run in a simulator while simultaneously using a --- static backend to print the list of generated gates. -readwrite_wrap :: ReadWrite a -> ReadWrite ([Gate], a) -readwrite_wrap (RW_Return a) = do - RW_Return ([], a) -readwrite_wrap (RW_Write gate comp) = do - ~(gates, a) <- readwrite_wrap comp - RW_Write gate (return (gate:gates, a)) -readwrite_wrap (RW_Read bit cont) = do - RW_Read bit (\bool -> readwrite_wrap (cont bool)) -readwrite_wrap (RW_Subroutine name subroutine comp) = - RW_Subroutine name subroutine (readwrite_wrap comp) - --- | Extract the contents of a static 'ReadWrite' computation. A --- 'ReadWrite' computation is said to be static if it contains no --- 'RW_Read' instructions, or in other words, no dynamic lifting. If --- an 'RW_Read' instruction is encountered, issue an error message --- using the given stub. -readwrite_unwind_static :: ErrMsg -> ReadWrite a -> a -readwrite_unwind_static e (RW_Return a) = a -readwrite_unwind_static e (RW_Write gate comp) = readwrite_unwind_static e comp -readwrite_unwind_static e (RW_Read bit cont) = error $ e "dynamic lifting" -readwrite_unwind_static e (RW_Subroutine name subroutine comp) = readwrite_unwind_static e comp - --- | Turn a static read-write computation into a list of gates, while --- also updating a namespace. \"Static\" means that the computation --- may not contain any 'RW_Read' operations. If it does, the message --- \"dynamic lifting\" is passed to the given error handler. --- --- Important usage note: This function returns a triple (/gates/, --- /ns/, /x/). The list of gates is generated lazily, and can be --- consumed one gate at a time. However, the values /ns/ and /x/ are --- only computed at the end of the computation. Any function using --- them should not apply a strict pattern match to /ns/ or /x/, or --- else the whole list of gates will be generated in memory. For --- example, the following will blow up the memory: --- --- > (gates, ns, (a, n, x)) = gatelist_of_readwrite errmsg comp --- --- whereas the following will work as intended: --- --- > (gates, ns, ~(a, n, x)) = gatelist_of_readwrite errmsg comp -gatelist_of_readwrite :: ErrMsg -> ReadWrite a -> Namespace -> ([Gate], Namespace, a) -gatelist_of_readwrite e (RW_Return a) ns = ([], ns, a) -gatelist_of_readwrite e (RW_Write gate comp) ns = (gate : gates, ns', a) where - (gates, ns', a) = gatelist_of_readwrite e comp ns -gatelist_of_readwrite e (RW_Read bit cont) ns = error (e "dynamic lifting") -gatelist_of_readwrite e (RW_Subroutine name subroutine comp) ns = - let ns' = map_provide name subroutine ns in - gatelist_of_readwrite e comp ns' - -{- - -- This version is inefficient. Why? - gatelist_of_readwrite_xxx :: ErrMsg -> ReadWrite a -> ([Gate], a) - gatelist_of_readwrite_xxx e comp = - readwrite_unwind_static e (readwrite_wrap comp) --} - --- ---------------------------------------------------------------------- --- * Dynamic boxed circuits - --- | The type of dynamic boxed circuits. The type 'DBCircuit' /a/ is --- the appropriate generalization of ('BCircuit', /a/), in a setting --- that is dynamic rather than static (i.e., with dynamic lifting or --- \"interactive measurement\"). -type DBCircuit a = (Arity, ReadWrite (Arity, Int, a)) - --- | Convert a dynamic boxed circuit to a static boxed circuit. The --- dynamic boxed circuit may not contain any dynamic liftings, since --- these cannot be performed in a static setting. In case any output --- liftings are encountered, try to issue a meaningful error via the --- given stub error message. -bcircuit_of_static_dbcircuit :: ErrMsg -> DBCircuit a -> (BCircuit, a) -bcircuit_of_static_dbcircuit e dbcirc = (bcirc, x) where - (a0, comp) = dbcirc - bcirc = (circ, ns) - circ = (a0, gates, a1, n) - (gates, ns, ~(a1, n, x)) = gatelist_of_readwrite e comp namespace_empty - --- | Convert a boxed circuit to a dynamic boxed circuit. The latter, --- of course, contains no 'RW_Read' instructions. -dbcircuit_of_bcircuit :: BCircuit -> a -> DBCircuit a -dbcircuit_of_bcircuit bcircuit x = (a0, comp (Map.toList ns) gates) where - (circuit, ns) = bcircuit - (a0, gates, a1, n) = circuit - comp ((boxid,subroutine):ns) gs = RW_Subroutine boxid subroutine (comp ns gs) - comp [] [] = RW_Return (a1, n, x) - comp [] (g:gs) = RW_Write g (comp [] gs) diff --git a/src/Quipper/Classical.hs b/src/Quipper/Classical.hs deleted file mode 100644 --- a/src/Quipper/Classical.hs +++ /dev/null @@ -1,241 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE FlexibleContexts #-} - --- | This module provides some operations for low-level manipulation --- of classical circuits. It is built directly on top of --- "Quipper.Circuit". - -module Quipper.Classical where - --- import other Quipper stuff -import Quipper.Generic -import Quipper.QData -import Quipper.Monad -import Quipper.Control -import Quipper.Transformer - --- import other stuff -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap - --- ====================================================================== --- * Manipulation of classical circuits - --- ---------------------------------------------------------------------- --- ** Eliminating CGate - --- | A 'Transformer' to eliminate all 'CGate' style gates, such as --- \"and\", \"or\", \"not\", \"xor\", \"eq\", and \"if-then-else\" --- gates, and replace them by equivalent 'CInit' and 'CNot' gates. -cgate_to_cnot_transformer :: Transformer Circ Qubit Bit -cgate_to_cnot_transformer (T_CGate name ncf f) = f $ - \qs -> without_controls_if ncf $ do - q <- cinit False - translate_cgate name q qs - return (q, qs) -cgate_to_cnot_transformer (T_CGateInv name ncf f) = f $ - \q qs -> without_controls_if ncf $ do - reverse_generic_imp (translate_cgate name) q qs - cterm False q - return qs -cgate_to_cnot_transformer gate = identity_transformer gate - --- | Auxiliary function: compute the reversible circuit corresponding --- to a 'CGate' of the given name, using only controlled-not gates. -translate_cgate :: String -> Bit -> [Bit] -> Circ () -translate_cgate "if" q [a,b,c] = do - cnot_at q `controlled` a .==. True .&&. b .==. True - cnot_at q `controlled` a .==. False .&&. c .==. True -translate_cgate "if" q list = do - error ("translate_cgate: \"if\" needs 3 arguments, not " ++ show (length list)) -translate_cgate "and" q list = do - cnot_at q `controlled` list -translate_cgate "or" q list = do - cnot_at q `controlled` [ x .==. 0 | x <- list] - cnot_at q -translate_cgate "xor" q list = do - sequence_ [cnot_at q `controlled` c | c <- list] -translate_cgate "eq" q [a,b] = do - cnot_at q `controlled` a .==. True - cnot_at q `controlled` b .==. False -translate_cgate "eq" q list = do - error ("translate_cgate: \"eq\" needs 2 arguments, not " ++ show (length list)) -translate_cgate "not" q [a] = do - cnot_at q `controlled` a .==. False -translate_cgate "not" q list = do - error ("translate_cgate: \"not\" needs 1 argument, not " ++ show (length list)) -translate_cgate name q list = do - error ("translate_cgate: gate \"" ++ name ++ "\" not known") - --- | Translate all classical gates in a circuit into equivalent --- controlled-not gates. --- --- The type of this overloaded function is difficult to read. In more --- readable form, it has all of the following types: --- --- > classical_to_cnot :: (QCData qa) => Circ qa -> Circ qa --- > classical_to_cnot :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (qa -> Circ qb) --- > classical_to_cnot :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> (qa -> qb -> Circ qc) --- --- and so forth. -classical_to_cnot :: (QCData qa, QCData qb, QCurry qfun qa qb) => qfun -> qfun -classical_to_cnot = transform_generic cgate_to_cnot_transformer - --- ---------------------------------------------------------------------- --- ** Classical to quantum - --- | Map an endpoint to the underlying 'Qubit' in the trivial --- case. Auxiliary function. -trivial_endpoint :: B_Endpoint Qubit Qubit -> Qubit -trivial_endpoint (Endpoint_Qubit q) = q -trivial_endpoint (Endpoint_Bit q) = q - --- | A 'Transformer' to replace all classical gates in a circuit by --- equivalent quantum gates. -classical_to_quantum_transformer :: Transformer Circ Qubit Qubit - --- Classical gates. - -classical_to_quantum_transformer (T_CNot ncf f) = f $ - \q c -> without_controls_if ncf $ do - q' <- qnot q `controlled` c - return (q', c) -classical_to_quantum_transformer (T_CSwap ncf f) = f $ - \w v c -> without_controls_if ncf $ do - (w',v') <- swap w v `controlled` c - return (w',v',c) -classical_to_quantum_transformer (T_CInit b ncf f) = f $ - without_controls_if ncf $ do - w <- qinit b - return w -classical_to_quantum_transformer (T_CTerm b ncf f) = f $ - \w -> without_controls_if ncf $ do - qterm b w - return () -classical_to_quantum_transformer (T_CDiscard f) = f $ - \w -> do - qdiscard w - return () -classical_to_quantum_transformer (T_DTerm b f) = f $ - \w -> do - qdiscard w - return () -classical_to_quantum_transformer (T_CGate name ncf f) = f $ - -- This case is recursive. The well-foundedness rests on the fact - -- that the output of classical_to_cnot contains no CGate. - classical_to_quantum . classical_to_cnot $ - \ws -> without_controls_if ncf $ do - v <- cgate name ws - return (v, ws) -classical_to_quantum_transformer (T_CGateInv name ncf f) = f $ - -- This case is recursive. The well-foundedness rests on the fact - -- that the output of classical_to_cnot contains no CGate. - classical_to_quantum . classical_to_cnot $ - \v ws -> without_controls_if ncf $ do - cgateinv name v ws - return ws - --- Preparation, unpreparation, and measurement. These become no-ops. - -classical_to_quantum_transformer (T_QPrep ncf f) = f $ - \w -> return w -classical_to_quantum_transformer (T_QUnprep ncf f) = f $ - \w -> return w -classical_to_quantum_transformer (T_QMeas f) = f $ - \w -> return w - --- Quantum gates. These are similar to the identity transformer. --- However, we cannot explicitly call the identity transformer, --- because its typing does not correctly translate 'Bit' to --- 'Qubit'. This matters because a pure quantum gate may have --- classical controls that need to be translated to quantum controls. -classical_to_quantum_transformer (T_QGate name _ _ inv ncf f) = f $ - \ws vs c -> without_controls_if ncf $ do - (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c - return (ws', vs', c) -classical_to_quantum_transformer (T_QRot name _ _ inv t ncf f) = f $ - \ws vs c -> without_controls_if ncf $ do - (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c - return (ws', vs', c) -classical_to_quantum_transformer (T_GPhase t ncf f) = f $ - \q c -> without_controls_if ncf $ do - global_phase_anchored_list t (map fix_endpoint q) `controlled` c - return c - where - fix_endpoint (Endpoint_Qubit q) = (Endpoint_Qubit q) - fix_endpoint (Endpoint_Bit q) = (Endpoint_Qubit q) -classical_to_quantum_transformer (T_QInit b ncf f) = f $ - without_controls_if ncf $ do - w <- qinit_qubit b - return w -classical_to_quantum_transformer (T_QTerm b ncf f) = f $ - \w -> without_controls_if ncf $ do - qterm_qubit b w - return () -classical_to_quantum_transformer (T_QDiscard f) = f $ - \w -> do - qdiscard_qubit w - return () -classical_to_quantum_transformer (T_Subroutine n inv ncf scf ws_pat a1_pat vs_pat a2_pat repeat f) = f $ - \namespace ws c -> without_controls_if ncf $ do - provide_subroutines namespace - v <- subroutine n inv scf repeat ws_pat a1_pat vs_pat a2_pat (map fix_endpoint ws) `controlled` c - return (map fix_endpoint v,c) - where - fix_endpoint (Endpoint_Qubit q) = Endpoint_Qubit q - fix_endpoint (Endpoint_Bit q) = - error "classical_to_quantum: classical subroutine not permitted" -classical_to_quantum_transformer (T_Comment s inv f) = f $ - \ws -> do - comment_label s inv [ (fix_endpoint e, s) | (e,s) <- ws ] - return () - where - fix_endpoint (Endpoint_Qubit q) = wire_of_qubit q - fix_endpoint (Endpoint_Bit q) = wire_of_qubit q - --- | Replace all classical gates in a circuit by equivalent quantum gates. -classical_to_quantum_unary :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (QType qa -> Circ (QType qb)) -classical_to_quantum_unary f x = transform_unary_shape classical_to_quantum_transformer f shape x - where - shape = qcdata_makeshape (dummy :: qa) qubit qubit x - --- | Replace all classical gates in a circuit by equivalent quantum gates. --- --- The type of this overloaded function is difficult to read. In more --- readable form, it has all of the following types: --- --- > classical_to_quantum :: (QCData qa) => Circ qa -> Circ (QType qa) --- > classical_to_quantum :: (QCData qa, QCData qb) => (qa -> Circ qb) -> (QType qa -> Circ (QType qb)) --- > classical_to_quantum :: (QCData qa, QCData qb, QCData qc) => (qa -> qb -> Circ qc) -> (QType qa -> QType qb -> Circ (QType qc)) --- --- and so forth. -classical_to_quantum :: (QCData qa, QCData qb, QCurry qfun qa qb, QCurry qfun' (QType qa) (QType qb)) => qfun -> qfun' -classical_to_quantum f = g where - f1 = quncurry f - g1 = classical_to_quantum_unary f1 - g = qcurry g1 - --- ====================================================================== --- * Classical to reversible - --- | Generic function for turning a classical (or pseudo-classical) --- circuit into a reversible circuit. The input is a classical boolean --- function /x/ ↦ /f/(/x/), given as a not necessarily reversible --- circuit (however, the circuit should be one-to-one, i.e., no --- \"garbage\" should be explicitly erased). The output is the --- corresponding reversible function (/x/,/y/) ↦ (/x/,/y/ ⊕ --- /f/(/x/)). /qa/ and /qb/ can be any quantum data types. The --- function 'classical_to_reversible' does not itself change --- classical bits to qubits; use 'classical_to_quantum' for that. - -classical_to_reversible :: (QCData qa, QCData qb) => (qa -> Circ qb) -> ((qa,qb) -> Circ (qa,qb)) -classical_to_reversible f (input, target) = do - with_computed (f input) $ \output -> do - controlled_not target output - return (input, target) diff --git a/src/Quipper/Control.hs b/src/Quipper/Control.hs deleted file mode 100644 --- a/src/Quipper/Control.hs +++ /dev/null @@ -1,260 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} - --- | Some gates can be controlled by a condition involving one of more --- \"control\" qubits and/or classical bits at circuit execution time. --- Such gates can also be controlled by boolean conditions that are --- known at circuit generation time (in which case the gate will not --- be generated when the control condition is false). This --- "Quipper.Control" module provides some convenient functions for --- creating and updating such controls. - -module Quipper.Control where - -import Quipper.Circuit -import Libraries.Tuple - -import Data.Map (Map) -import qualified Data.Map as Map - --- ====================================================================== --- * The type of controls - --- $ In the most general case, a \"control\" could be an arbitrary --- boolean formula built up from assertions of the form /q/ = |0〉 or --- /q/ = |1〉, where /q/ is either a qubit or a classical bit in a --- circuit. However, we are here interested in tracking a simpler kind --- of control. --- --- A /control list/ is a conjunction (i.e., an \"and\") of assertions --- of the form /q/ = |0〉 or /q/ = |1〉. A special case arises when the --- conjunction involves two mutually exclusive conditions, such as /q/ --- = |0〉 and /q/ = |1〉. In this case, the control in inconsistent: it --- can never be active. We use a special representation for the --- inconsistent control for efficiency reasons. --- --- Implementation note: a 'ControlList' is either 'Inconsistent', or --- else a map from a finite set of wires to booleans. Here, the --- boolean 'True' represents a positive control, i.e., one that is --- active when the state is |1〉 (a filled dot in circuit --- diagrams). The boolean 'False' represents a negative control, i.e., --- on that is active when the state is |0〉 (an empty dot in circuit --- diagrams). - --- | A 'ControlList' is Quipper's internal representation of the type --- of conjunctive controls, i.e., controls that can be constructed --- using the '.==.', './=.', and '.&&.' operators. - -data ControlList = - ControlList (Map Wire Bool) - | Inconsistent - deriving (Show) - --- ---------------------------------------------------------------------- --- * Functions for combining control lists - --- $FUNCTIONS We provide some convenient functions for building --- control lists from simpler control lists. - --- | The empty control list, corresponding to a condition that is --- always true. -clist_empty :: ControlList -clist_empty = ControlList Map.empty - --- | Add a single signed control to a control list. -clist_add :: Wire -> Bool -> ControlList -> ControlList -clist_add w b Inconsistent = Inconsistent -clist_add w b (ControlList m) = - case Map.lookup w m of - Just b' | b /= b' -> Inconsistent - _ -> ControlList (Map.insert w b m) - --- | @combine list1 list2@: --- Take the conjunction of two control lists. This is more efficient --- if /list1/ is small and /list2/ is large. -combine :: ControlList -> ControlList -> ControlList -combine Inconsistent list2 = Inconsistent -combine (ControlList m) list2 = - Map.foldrWithKey clist_add list2 m - --- | Like 'combine', but the first argument is of type 'Controls' from --- the "Quipper.Circuit" module. -combine_controls :: Controls -> ControlList -> ControlList -combine_controls c list2 = - foldl (\list (Signed w b) -> clist_add w b list) list2 c - --- | Like 'combine_controls', but also return a value of type --- 'Controls', or 'Nothing' if the controls are inconsistent. --- This function is for convenience. -add_to_controls :: Controls -> ControlList -> Maybe Controls -add_to_controls c clist = - case combine_controls c clist of - Inconsistent -> Nothing - ControlList m -> Just [ Signed w b | (w,b) <- Map.toList m ] - --- ---------------------------------------------------------------------- --- * Controlling low-level gates - --- | Modify the given gate by applying the specified controls. If the --- total set of controls (i.e., those specified in the gate itself and --- those specified in the control list) is inconsistent, return --- 'Nothing'. If it is consistent, return the appropriately controlled --- version of the gate. Throw an error if the gate is of a kind that --- cannot be controlled. -control_gate :: ControlList -> Gate -> Maybe Gate -control_gate clist (QGate name inv ws1 ws2 c ncf) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (QGate name inv ws1 ws2 c1 ncf) -control_gate clist (QRot name inv t ws1 ws2 c ncf) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (QRot name inv t ws1 ws2 c1 ncf) -control_gate clist (GPhase t w c ncf) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (GPhase t w c1 ncf) -control_gate clist (CNot w c ncf) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (CNot w c1 ncf) -control_gate clist (CSwap w1 w2 c ncf) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (CSwap w1 w2 c1 ncf) -control_gate clist (Subroutine name inv ws1 a1 ws2 a2 c ncf AllCtl repeat) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (Subroutine name inv ws1 a1 ws2 a2 c1 ncf AllCtl repeat) -control_gate clist (Subroutine name inv ws1 a1 ws2 a2 c ncf OnlyClassicalCtl repeat) = - case add_to_controls c clist of - Nothing -> Nothing - Just c1 -> Just (Subroutine name inv ws1 a1 ws2 a2 c1 ncf OnlyClassicalCtl repeat) -control_gate clist (Comment s inv ws) = Just (Comment s inv ws) --- Implementation note: we list all catch-all cases explicitly, so --- that the typechecker can warn about new gates that must be added --- here. -control_gate clist gate@(CGate _ _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(CGateInv _ _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(QPrep _ _) = control_gate_catch_all clist gate -control_gate clist gate@(QUnprep _ _) = control_gate_catch_all clist gate -control_gate clist gate@(QInit _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(CInit _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(QTerm _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(CTerm _ _ _) = control_gate_catch_all clist gate -control_gate clist gate@(QMeas _) = control_gate_catch_all clist gate -control_gate clist gate@(QDiscard _) = control_gate_catch_all clist gate -control_gate clist gate@(CDiscard _) = control_gate_catch_all clist gate -control_gate clist gate@(DTerm _ _) = control_gate_catch_all clist gate -control_gate clist gate@(Subroutine _ _ _ _ _ _ _ _ NoCtl _) = control_gate_catch_all clist gate - --- | The \"catch all\" clause for 'control_gate'. This handles all --- gates that are not controllable. If the control condition is known --- at circuit generation time to be 'clist_empty', then we can just --- append the gate unconditionally. All other cases are errors. -control_gate_catch_all :: ControlList -> Gate -> Maybe Gate -control_gate_catch_all clist gate = - case clist of - ControlList m | Map.null m -> Just gate - _ -> error ("control_gate: gate can't be controlled: " ++ show gate) - --- | Define whether a gate can be controlled. -controllable_gate :: Gate -> Bool -controllable_gate (QGate name inv ws1 ws2 c ncf) = True -controllable_gate (QRot name inv t ws1 ws2 c ncf) = True -controllable_gate (GPhase t w c ncf) = True -controllable_gate (CNot w c ncf) = True -controllable_gate (CSwap w1 w2 c ncf) = True -controllable_gate (Subroutine name inv ws1 a1 ws2 a2 c ncf AllCtl _) = True -controllable_gate (Subroutine name inv ws1 a1 ws2 a2 c ncf OnlyClassicalCtl _) = True -controllable_gate (Comment s inv ws) = True --- Catch-all clauses: The remaining gates are not controllable, unless --- they have their 'NoControlFlag' set. We list all catch-all cases --- explicitly, so that the typechecker can warn about new gates that --- must be added here. -controllable_gate gate@(CGate _ _ _ _) = gate_ncflag gate -controllable_gate gate@(CGateInv _ _ _ _) = gate_ncflag gate -controllable_gate gate@(QPrep _ _) = gate_ncflag gate -controllable_gate gate@(QUnprep _ _) = gate_ncflag gate -controllable_gate gate@(QInit _ _ _) = gate_ncflag gate -controllable_gate gate@(CInit _ _ _) = gate_ncflag gate -controllable_gate gate@(QTerm _ _ _) = gate_ncflag gate -controllable_gate gate@(CTerm _ _ _) = gate_ncflag gate -controllable_gate gate@(QMeas _) = gate_ncflag gate -controllable_gate gate@(QDiscard _) = gate_ncflag gate -controllable_gate gate@(CDiscard _) = gate_ncflag gate -controllable_gate gate@(DTerm _ _) = gate_ncflag gate -controllable_gate gate@(Subroutine _ _ _ _ _ _ _ _ NoCtl _) = gate_ncflag gate - --- | Define whether an entire low-level circuit can be controlled -controllable_circuit :: Circuit -> Bool -controllable_circuit (_,gs,_,_) = and (map controllable_gate gs) - --- ---------------------------------------------------------------------- --- * Specifying control lists - --- | A \"control source\" is anything that can be used as a control on --- a gate. The most common way to construct a control source is by --- using the '.==.', './=.', and '.&&.' operators. In addition, --- we provide the following instances: --- --- * 'Bool'. A boolean condition that is known at circuit generation --- time can be used as a control, which is then either trivial (the --- gate is generated) or inconsistent (the gate is not generated). --- --- * 'Wire'. This includes the type 'Bit' (for a classical --- execution-time control) and 'Qubit' (for a quantum control). A wire --- can be used as a shorthand notation for a positive control on that --- wire. --- --- * 'ControlList'. A control list is Quipper's internal --- representation of a control condition, and is trivially a control --- source. --- --- * A list of control sources can be used as a control source. -class ControlSource a where - -- | Convert a condition to a control. - to_control :: a -> ControlList - -instance ControlSource Bool where - to_control True = clist_empty - to_control False = Inconsistent - -instance ControlSource Wire where - to_control w = ControlList (Map.singleton w True) - -instance ControlSource (Signed Wire) where - to_control (Signed w b) = ControlList (Map.singleton w b) - -instance ControlSource ControlList where - to_control x = x - -instance ControlSource a => ControlSource [a] where - to_control list = foldl combine clist_empty (map to_control list) - -instance ControlSource () where - to_control _ = clist_empty - -instance (ControlSource a, ControlSource b) => ControlSource (a,b) where - to_control (a,b) = combine (to_control a) (to_control b) - -instance (ControlSource a, ControlSource b, ControlSource c) => ControlSource (a,b,c) where - to_control = to_control . untuple - -instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d) => ControlSource (a,b,c,d) where - to_control = to_control . untuple - -instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e) => ControlSource (a,b,c,d,e) where - to_control = to_control . untuple - -instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e, ControlSource f) => ControlSource (a,b,c,d,e,f) where - to_control = to_control . untuple - -instance (ControlSource a, ControlSource b, ControlSource c, ControlSource d, ControlSource e, ControlSource f, ControlSource g) => ControlSource (a,b,c,d,e,f,g) where - to_control = to_control . untuple diff --git a/src/Quipper/Generic.hs b/src/Quipper/Generic.hs deleted file mode 100644 --- a/src/Quipper/Generic.hs +++ /dev/null @@ -1,1623 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE Rank2Types #-} - --- | This module provides functions and operators that are \"generic\" --- on quantum data. We say that a function is generic if it works at --- any quantum data type, rather than just a specific type such as --- 'Qubit'. For example, the generic function 'qinit' can be used to --- initialize a qubit from a boolean, or a pair of qubits from a pair --- of booleans, or a list of qubits from a list of booleans, and so --- forth. --- --- Some functions are also generic in the /number/ of arguments they --- take, in addition to the type of the arguments. - -module Quipper.Generic ( - -- * Generic gates - -- ** Initialization and termination - qinit, - qterm, - qdiscard, - cinit, - cterm, - cdiscard, - qc_init, - qc_init_with_shape, - qc_term, - qc_discard, - -- ** Measurement and preparation - measure, - prepare, - qc_measure, - qc_prepare, - -- ** Global phase gate - global_phase_anchored, - -- ** Mapped gates - map_hadamard, - map_hadamard_at, - swap, - swap_at, - controlled_not, - controlled_not_at, - bool_controlled_not, - bool_controlled_not_at, - qmultinot, - qmultinot_at, - -- ** Copying and uncopying - qc_copy_fun, - qc_uncopy_fun, - qc_copy, - qc_uncopy, - -- ** Classical gates - cgate_if, - circ_if, - -- ** Named gates - named_gate, - named_gate_at, - named_rotation, - named_rotation_at, - extended_named_gate, - extended_named_gate_at, - -- ** Dynamic lifting - dynamic_lift, - - -- * Mapping - mapUnary, - mapBinary, - mapBinary_c, - map2Q, - qc_mapBinary, - - -- * Conversion to lists - -- $CONVERSION - qubits_of_qdata, - qdata_of_qubits, - endpoints_of_qcdata, - qcdata_of_endpoints, - - -- * Shape related operations - qc_false, - qshape, - - -- * Bindings - qc_bind, - qc_unbind, - - -- * Generic controls - -- $CONTROL - (.&&.), - (.==.), - (./=.), - -- * Generic encapsulation - -- $encapsulate - encapsulate_generic, - encapsulate_generic_in_namespace, - unencapsulate_generic, - -- $dynamic_encapsulate - encapsulate_dynamic, - unencapsulate_dynamic, - -- * Generic reversing - reverse_generic, - reverse_generic_curried, - reverse_simple, - reverse_simple_curried, - reverse_generic_endo, - reverse_generic_imp, - reverse_endo_if, - reverse_imp_if, - -- * The QCurry type class - QCurry (..), - -- * Generic circuit transformations - transform_unary_dynamic_shape, - transform_unary_dynamic, - transform_unary, - transform_generic, - transform_unary_shape, - transform_generic_shape, - -- * Generic block structure - with_ancilla_init, - with_ancilla_list, - with_computed_fun, - with_computed, - with_basis_change, - with_classical_control, - -- * Boxed subcircuits - provide_subroutine_generic, - box, - nbox, - box_loopM, - loopM_boxed_if, - inline_subroutine - ) where - --- import other Quipper stuff -import Quipper.Circuit -import Quipper.Monad -import Libraries.Auxiliary -import Libraries.Tuple -import Quipper.Transformer -import Quipper.Control -import Quipper.QData - --- import other stuff -import Control.Monad -import Prelude -import Data.Typeable -import qualified Control.Monad.State as State - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap - --- ====================================================================== --- * Generic gates - --- ** Initialization and termination - --- | Initialize a qubit from a boolean parameter. More generally, --- initialize a data structure of qubits from a corresponding data --- structure of boolean parameters. Examples: --- --- > q <- qinit False --- > (q0, q1) <- qinit (True, False) --- > [q0, q1, q2] <- qinit [True, False, True] -qinit :: (QShape ba qa ca) => ba -> Circ qa -qinit ba = qdata_mapM (shapetype_b ba) qinit_qubit ba - --- | Terminate a qubit, asserting its state to equal the boolean --- parameter. More generally, terminate a data structure of qubits, --- asserting that their state is as given by a data structure of --- booleans parameters. Examples: --- --- > qterm False q --- > qterm (False, False) (q0, q1) --- > qterm [False, False, False] [q0, q1, q2] --- --- In some cases, it is permissible for some aspect of the parameter's --- shape to be underspecified, e.g., a longer than necessary list, or --- an integer of indeterminate length. It is therefore possible, for --- example, to write: --- --- > qterm 17 qa -- when qa :: QDInt, --- > qterm [False..] qa -- when qa :: [Qubit]. --- --- The rules for when a boolean argument can be \"promoted\" in this --- way are specific to each individual data type. -qterm :: (QShape ba qa ca) => ba -> qa -> Circ () -qterm ba qa = do - let shape = shapetype_b ba -- shape type - let ba' = qdata_promote ba qa errmsg -- shape data - let z = qdata_zip shape bool qubit ba' qa errmsg - qdata_mapM_op shape (\(x,y) -> qterm_qubit x y) z - return () - where - errmsg s = "qterm: shape of parameter does not match data: " ++ s - --- | Discard a qubit, ignoring its state. This can leave the quantum --- system in a mixed state, so is not a reversible operation. More --- generally, discard all the qubits in a quantum data --- structure. Examples: --- --- > qdiscard q --- > qdiscard (q0, q1) --- > qdiscard [q0, q1, q2] -qdiscard :: (QData qa) => qa -> Circ () -qdiscard qa = do - qdata_mapM_op (shapetype_q qa) qdiscard_qubit qa - return () - --- | Initialize a 'Bit' (boolean input) from a 'Bool' (boolean --- parameter). More generally, initialize the a data structure of Bits --- from a corresponding data structure of Bools. Examples: --- --- > b <- cinit False --- > (b0, b1) <- cinit (True, False) --- > [b0, b1, b2] <- cinit [True, False, True] -cinit :: (QShape ba qa ca) => ba -> Circ ca -cinit ba = qdata_mapM (shapetype_b ba) cinit_bit ba - --- | Terminate a 'Bit', asserting its state to equal the given --- 'Bool'. More generally, terminate a data structure of Bits, --- asserting that their state is as given by a data structure of --- Bools. Examples: --- --- > cterm False b --- > cterm (False, False) (b0, b1) --- > cterm [False, False, False] [b0, b1, b2] --- --- In some cases, it is permissible for some aspect of the parameter's --- shape to be underspecified, e.g., a longer than necessary list, or --- an integer of indeterminate length. It is therefore possible, for --- example, to write: --- --- > cterm 17 ca -- when ca :: CInt, --- > cterm [False..] ca -- when ca :: [Bit]. --- --- The rules for when a boolean argument can be \"promoted\" in this --- way are specific to each individual data type. -cterm :: (QShape ba qa ca) => ba -> ca -> Circ () -cterm ba ca = do - -- shape type - let shape = shapetype_b ba - -- shape data - let ba' = qdata_promote_c ba ca errmsg - let z = qdata_zip shape bool bit ba' ca errmsg - qdata_mapM_op shape (\(x,y) -> cterm_bit x y) z - return () - where - errmsg s = "cterm: shape of parameter does not match data: " ++ s - --- | Discard a 'Bit', ignoring its state. This can leave the system in --- a mixed state, so is not a reversible operation. More generally, --- discard all the Bits in a data structure. Examples: --- --- > cdiscard b --- > cdiscard (b0, b1) --- > cdiscard [b0, b1, b2] -cdiscard :: (CData ca) => ca -> Circ () -cdiscard ca = do - qdata_mapM_op (shapetype_c ca) cdiscard_bit ca - return () - --- | Heterogeneous version of 'qinit'. Please note that the type of --- the result of this function cannot be inferred from the type of the --- argument. For example, --- --- > x <- qc_init False --- --- is ambiguous, unless it can be inferred from the context whether --- /x/ is a 'Bit' or a 'Qubit'. If the type cannot be inferred from --- the context, it needs to be stated explicitly, like this: --- --- > x <- qc_init False :: Circ Qubit --- --- Alternatively, 'qc_init_with_shape' can be used to fix a specific --- type. -qc_init :: (QCData qc) => BType qc -> Circ qc -qc_init bs = qc_init_with_shape (undefined :: qc) bs - --- | A version of 'qc_init' that uses a shape type parameter. The --- first argument is the shape type parameter, and the second argument --- is a data structure containing boolean initializers. The shape type --- argument determines which booleans are used to initialize qubits, --- and which ones are used to initialize classical bits. --- --- Example: --- --- > (x,y) <- qc_init_with_shape (bit,[qubit]) (True, [False,True]) --- --- This will assign to /x/ a classical bit initialized to 1, and to --- /y/ a list of two qubits initialized to |0〉 and |1〉, respectively. -qc_init_with_shape :: (QCData qc) => qc -> BType qc -> Circ qc -qc_init_with_shape shape bs = qcdata_mapM shape qinit_qubit cinit_bit bs - --- | Heterogeneous version of 'qterm'. -qc_term :: (QCData qc) => BType qc -> qc -> Circ () -qc_term bs qc = do - let bs' = qcdata_promote bs qc errmsg - let z = qcdata_zip qc bool bool qubit bit bs' qc errmsg - qcdata_mapM_op qc map_qubit map_bit z - return () - where - - map_qubit :: (Bool, Qubit) -> Circ () - map_qubit (b,q) = qterm_qubit b q - - map_bit :: (Bool, Bit) -> Circ () - map_bit (b,q) = cterm_bit b q - - errmsg s = "qc_term: shape of parameter does not match data: " ++ s - --- | Heterogeneous version of 'qdiscard'. -qc_discard :: (QCData qc) => qc -> Circ () -qc_discard qc = do - qcdata_mapM_op qc qdiscard_qubit cdiscard_bit qc - return () - --- ---------------------------------------------------------------------- --- ** Measurement and preparation - --- | Measure a 'Qubit', resulting in a 'Bit'. More generally, measure --- all the Qubits in a quantum data structure, resulting in a --- corresponding data structure of Bits. This is not a reversible --- operation. Examples: --- --- > b <- measure q --- > (b0, b1) <- measure (q0, q1) --- > [b0, b1, b2] <- measure [q0, q1, q2] -measure :: (QShape ba qa ca) => qa -> Circ ca -measure qa = qdata_mapM_op (shapetype_q qa) measure_qubit qa - --- | Prepare a 'Qubit' initialized from a 'Bit'. More generally, --- prepare a data structure of Qubits, initialized from a corresponding --- data structure of Bits. Examples: --- --- > q <- prepare b --- > (q0, q1) <- prepare (b0, b1) --- > [q0, q1, q2] <- prepare [b0, b1, b2] -prepare :: (QShape ba qa ca) => ca -> Circ qa -prepare ca = qdata_mapM (shapetype_c ca) prepare_qubit ca - --- | Heterogeneous version of 'measure'. Given a heterogeneous data --- structure, measure all of its qubits, and leave any classical bits --- unchanged. -qc_measure :: (QCData qc) => qc -> Circ (QCType Bit Bit qc) -qc_measure qc = qcdata_mapM_op qc measure_qubit do_bit qc - where - do_bit :: Bit -> Circ Bit - do_bit = return - --- | Heterogeneous version of 'prepare'. Given a heterogeneous data --- structure, prepare qubits from all classical bits, and leave any --- qubits unchanged. -qc_prepare :: (QCData qc) => qc -> Circ (QCType Qubit Qubit qc) -qc_prepare qc = qcdata_mapM qc do_qubit prepare_qubit qc - where - do_qubit :: Qubit -> Circ Qubit - do_qubit = return - --- ---------------------------------------------------------------------- --- * Global phase gate - --- | Like 'global_phase', except the gate is also \"anchored\" at a --- qubit, a bit, or more generally at some quantum data. The anchor --- is only used as a hint for graphical display. The gate, which is a --- zero-qubit gate, will potentially be displayed near the anchor(s). -global_phase_anchored :: (QCData qc) => Double -> qc -> Circ () -global_phase_anchored t qc = global_phase_anchored_list t qs where - qs = endpoints_of_qcdata qc - --- ---------------------------------------------------------------------- --- * Mapped gates - --- | Apply a Hadamard gate to every qubit in a quantum data structure. -map_hadamard :: (QData qa) => qa -> Circ qa -map_hadamard = mapUnary hadamard - --- | Imperative version of 'map_hadamard'. -map_hadamard_at :: (QData qa) => qa -> Circ () -map_hadamard_at qa = do - map_hadamard qa - return () - --- | Apply a swap gate to two qubits. More generally, apply swap gates --- to every corresponding pair of qubits in two pieces of quantum --- data. -swap :: (QCData qc) => qc -> qc -> Circ (qc,qc) -swap a b = qc_mapBinary swap_qubit swap_bit a b - --- | Apply a swap gate to two qubits. More generally, apply swap gates --- to every corresponding pair of qubits in two pieces of quantum --- data. -swap_at :: (QCData qc) => qc -> qc -> Circ () -swap_at a b = do - swap a b - return () - --- | Apply a controlled-not gate to every corresponding pair of --- quantum or classical bits in two pieces of QCData. The first --- argument is the target and the second the (positive) control. --- --- For now, we require both pieces of QCData to have the same type, --- i.e., classical bits can be controlled only by classical bits and --- quantum bits can be controlled only by quantum bits. --- --- Example: --- --- > ((a',b'), (x,y)) <- controlled_not (a,b) (x,y) --- --- is equivalent to --- --- > a' <- qnot a `controlled` x --- > b' <- qnot b `controlled` y -controlled_not :: (QCData qc) => qc -> qc -> Circ (qc, qc) -controlled_not qc ctrl = do - let z = qcdata_zip qc qubit bit qubit bit qc ctrl errmsg - z' <- qcdata_mapM qc map_qubit map_bit z - let (qc', ctrl') = qcdata_unzip qc qubit bit qubit bit z' - return (qc', ctrl') - where - - map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit) - map_qubit (q,c) = do - qnot_at q `controlled` c - return (q,c) - - map_bit :: (Bit, Bit) -> Circ (Bit, Bit) - map_bit (b,c) = do - cnot_at b `controlled` c - return (b,c) - - errmsg s = "controlled_not: shapes of control and controlee do not match: " ++ s - --- | Imperative version of 'controlled_not'. Apply a controlled-not --- gate to every corresponding pair of quantum or classical bits in --- two pieces of QCData. The first argument is the target and the --- second the (positive) control. -controlled_not_at :: (QCData qc) => qc -> qc -> Circ () -controlled_not_at a b = do - controlled_not a b - return () - --- | A version of 'controlled_not' where the control consists of --- boolean data. Example: --- --- > bool_controlled_not (q, r, s) (True, True, False) --- --- negates /q/ and /r/, but not /s/. -bool_controlled_not :: (QCData qc) => qc -> BType qc -> Circ qc -bool_controlled_not qc a = do - bool_controlled_not_at qc a - return qc - --- | A version of 'controlled_not_at' where the control consists of --- boolean data. Example: --- --- > bool_controlled_not_at (q, r, s) (True, True, False) --- --- negates /q/ and /r/, but not /s/. -bool_controlled_not_at :: (QCData qc) => qc -> BType qc -> Circ () -bool_controlled_not_at qc a = do - qmultinot_list_at vq - cmultinot_list_at vc - where - v = Map.toList $ qc_bind qc a - vq = [ (qubit_of_wire q, b) | (q, Endpoint_Qubit b) <- v ] - vc = [ (bit_of_wire c, b) | (c, Endpoint_Bit b) <- v ] - --- | Negate all qubits in a quantum data structure. -qmultinot :: (QData qa) => qa -> Circ qa -qmultinot qa = do - qmultinot_at qa - return qa - --- | Negate all qubits in a quantum data structure. -qmultinot_at :: (QData qa) => qa -> Circ () -qmultinot_at qa = - qmultinot_list_at [ (q,True) | q <- qubits_of_qdata qa ] - --- ---------------------------------------------------------------------- --- ** Copying and uncopying - --- | Initialize a new piece of quantum data, as a copy of a given --- piece. Returns both the original and the copy. -qc_copy_fun :: (QCData qc) => qc -> Circ (qc,qc) -qc_copy_fun orig = do - copy <- qc_init (qc_false orig) - (copy, orig) <- controlled_not copy orig - return (orig, copy) - --- | Given two pieces of quantum data, assumed equal (w.r.t. the --- computational basis), terminate the second piece (and return the --- first, unmodified). This is the inverse of 'qc_copy_fun', in the sense --- that the following sequence of instructions behaves like the --- identity function: --- --- > (orig, copy) <- qc_copy_fun orig --- > orig <- qc_uncopy_fun orig copy -qc_uncopy_fun :: (QCData qc) => qc -> qc -> Circ qc -qc_uncopy_fun orig copy = reverse_generic qc_copy_fun orig (orig,copy) - --- | Create a fresh copy of a piece of quantum data. Note: copying is --- performed via a controlled-not operation, and is not cloning. This --- is similar to 'qc_copy_fun', except it returns only the copy, and not --- the original. -qc_copy :: (QCData qc) => qc -> Circ qc -qc_copy qc = do - (qc, qc1) <- qc_copy_fun qc - return qc1 - --- | \"Uncopy\" a piece of quantum data; i.e. terminate /copy/, --- assuming it's a copy of /orig/. This is the inverse of --- 'qc_copy', in the sense that the following sequence of --- instructions behaves like the identity function: --- --- > b <- qc_copy a --- > qc_uncopy a b -qc_uncopy :: (QCData qc) => qc -> qc -> Circ () -qc_uncopy orig copy = do - qc_uncopy_fun orig copy - return () - --- ---------------------------------------------------------------------- --- ** Classical gates - --- | If /a/ is 'True', return a copy of /b/, else return a copy of --- /c/. Here /b/ and /c/ can be any data structures consisting of --- Bits, but /b/ and /c/ must be of the same type and shape (for --- example, if they are lists, they must be of equal --- length). Examples: --- --- > output <- cgate_if a b c --- > (out0, out1) <- cgate_if a (b0, b1) (c0, c1) --- > [out0, out1, out2] <- cgate_if a [b0, b1, b2] [c0, c1, c2] -cgate_if :: (CData ca) => Bit -> ca -> ca -> Circ ca -cgate_if a b c = do - let shape = shapetype_c b - let z = qdata_zip shape bit bit b c errmsg - d <- qdata_mapM shape (\(x,y) -> cgate_if_bit a x y) z - return d - where - errmsg s = "cgate_if: shapes of 'then' and 'else' part do not match: " ++ s - --- | 'circ_if' is an if-then-else function for classical circuits. --- It is a wrapper around 'cgate_if', intended to be used like this: --- --- > result <- circ_if <<>> ( --- > <>> --- > )( --- > <<>> --- > ) --- --- Unlike 'cgate_if', this is a meta-operation, i.e., the bodies of --- the \"then\" and \"else\" parts can be circuit building --- operations. --- --- What makes this different from the usual boolean \"if-then-else\" --- is that the condition is of type 'Bit', i.e., it is only known at --- circuit execution time. Therefore the generated circuit contains --- /both/ the \"then\" and \"else\" parts, suitably --- controlled. Precondition: the \"then\" and \"else\" parts must be --- of the same type and shape. -circ_if :: (CData ca) => Bit -> Circ ca -> Circ ca -> Circ ca -circ_if a b c = do - b' <- b - c' <- c - cgate_if a b' c' - --- ---------------------------------------------------------------------- --- ** Named gates - --- | Define a new functional-style gate of the given name. Like --- 'named_gate', except that the generated gate is extended with --- \"generalized controls\". The generalized controls are additional --- inputs to the gate that are guaranteed not to be modified if they --- are in a computational basis state. They are rendered in a special --- way in circuit diagrams. Usage: --- --- > my_new_gate :: (Qubit,Qubit) -> Qubit -> Circ (Qubit,Qubit) --- > my_new_gate = extended_named_gate "Q" --- --- This defines a new gate with name "Q", two inputs, and one --- generalized input. -extended_named_gate :: (QData qa, QData qb) => String -> qa -> qb -> Circ qa -extended_named_gate name operands gencontrols = do - named_gate_qulist_at name False (qubits_of_qdata operands) (qubits_of_qdata gencontrols) - return operands - --- | Like 'extended_named_gate', except defines an imperative style gate. --- Usage: --- --- > my_new_gate_at :: (Qubit,Qubit) -> Qubit -> Circ () --- > my_new_gate_at = extended_named_gate_at "Q" --- --- This defines a new gate with name "Q", two inputs, and one --- generalized input. -extended_named_gate_at :: (QData qa, QData qb) => String -> qa -> qb -> Circ () -extended_named_gate_at name operands gencontrols = do - extended_named_gate name operands gencontrols - return () - --- | Define a new functional-style gate of the given name. Usage: --- --- > my_unary_gate :: Qubit -> Circ Qubit --- > my_unary_gate = named_gate "Q" --- --- > my_binary_gate :: (Qubit, Qubit) -> Circ (Qubit, Qubit) --- > my_binary_gate = named_gate "R" --- --- This defines a new unary gate and a new binary gate, which will be --- rendered as "Q" and "R", respectively, in circuit diagrams. - --- Implementation note: contrary to our usual convention, the binary --- gate defined above is not in curried form. It would be nice to have --- a version of this operator that curries the gate. -named_gate :: (QData qa) => String -> qa -> Circ qa -named_gate name operands = do - extended_named_gate name operands () - --- | Define a new imperative-style gate of the given name. Usage: --- --- > my_unary_gate_at :: Qubit -> Circ () --- > my_unary_gate_at = named_gate_at "Q" --- --- > my_binary_gate_at :: (Qubit, Qubit) -> Circ () --- > my_binary_gate_at = named_gate_at "R" --- --- This defines a new unary gate and a new binary gate, which will be --- rendered as "Q" and "R", respectively, in circuit diagrams. - -named_gate_at :: (QData qa) => String -> qa -> Circ () -named_gate_at name operands = do - named_gate name operands - return () - --- | Define a new functional-style gate of the given name, and --- parameterized by a real-valued parameter. This is typically used --- for rotations or phase gates that are parameterized by an angle. --- The name can contain \'%\' as a place holder for the parameter. --- Usage: --- --- > my_unary_gate :: Qubit -> Circ Qubit --- > my_unary_gate = named_rotation "exp(-i%Z)" 0.123 --- --- > my_binary_gate :: TimeStep -> (Qubit, Qubit) -> Circ (Qubit, Qubit) --- > my_binary_gate t = named_rotation "Q(%)" t -named_rotation :: (QData qa) => String -> Timestep -> qa -> Circ qa -named_rotation name theta operands = do - named_rotation_qulist_at name False theta (qubits_of_qdata operands) [] - return operands - --- | Define a new imperative-style gate of the given name, and --- parameterized by a real-valued parameter. This is typically used --- for rotations or phase gates that are parameterized by an angle. --- The name can contain \'%\' as a place holder for the parameter. --- Usage: --- --- > my_unary_gate_at :: Qubit -> Circ () --- > my_unary_gate_at = named_rotation "exp(-i%Z)" 0.123 --- --- > my_binary_gate_at :: TimeStep -> (Qubit, Qubit) -> Circ () --- > my_binary_gate_at t = named_rotation "Q(%)" t -named_rotation_at :: (QData qa) => String -> Timestep -> qa -> Circ () -named_rotation_at name theta operands = do - named_rotation name theta operands - return () - ----------------------------------------------------------------------- --- ** Dynamic lifting - --- | Convert a 'Bit' (boolean circuit output) to a 'Bool' (boolean --- parameter). More generally, convert a data structure of Bits to a --- corresponding data structure of Bools. --- --- For use in algorithms that require the output of a measurement to --- be used as a circuit-generation parameter. This is the case, for --- example, for sieving methods, and also for some iterative --- algorithms. --- --- Note that this is not a gate, but a meta-operation. The input --- consists of classical circuit endpoints (whose values are known at --- circuit execution time), and the output is a boolean parameter --- (whose value is known at circuit generation time). --- --- The use of this operation implies an interleaving between circuit --- execution and circuit generation. It is therefore a (physically) --- expensive operation and should be used sparingly. Using the --- 'dynamic_lift' operation interrupts the batch mode operation of the --- quantum device (where circuits are generated ahead of time), and --- forces interactive operation (the quantum device must wait for the --- next portion of the circuit to be generated). This operation is --- especially expensive if the current circuit contains unmeasured --- qubits; in this case, the qubits must be preserved while the --- quantum device remains on standby. --- --- Also note that this operation is not supported in all contexts. It --- is an error, for example, to use this operation in a circuit that --- is going to be reversed, or in the body of a boxed subroutine. --- Also, not all output devices (such as circuit viewers) support this --- operation. -dynamic_lift :: (QShape ba qa ca) => ca -> Circ ba -dynamic_lift ca = qdata_mapM (shapetype_c ca) dynamic_lift_bit ca - --- ---------------------------------------------------------------------- --- * Mapping - --- | Map a single qubit gate across every qubit in the data structure. -mapUnary :: (QData qa) => (Qubit -> Circ Qubit) -> qa -> Circ qa -mapUnary f qa = qdata_mapM (shapetype_q qa) f qa - --- | Map a binary gate across every corresponding pair of qubits in --- two quantum data structures of equal shape. -mapBinary :: (QData qa) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> qa -> qa -> Circ (qa, qa) -mapBinary f q1 q2 = do - let shape = shapetype_q q1 - let z = qdata_zip shape qubit qubit q1 q2 errmsg - z' <- qdata_mapM shape (\(x,y) -> f x y) z - let (q1', q2') = qdata_unzip shape qubit qubit z' - return (q1', q2') - where - errmsg s = "mapBinary: shapes of arguments do not match: " ++ s - --- | Like 'mapBinary', except the second data structure is classical. -mapBinary_c :: (QShape ba qa ca) => (Qubit -> Bit -> Circ (Qubit, Bit)) -> qa -> ca -> Circ (qa, ca) -mapBinary_c f q1 c2 = do - let shape = shapetype_q q1 - let z = qdata_zip shape qubit bit q1 c2 errmsg - z' <- qdata_mapM shape (\(x,y) -> f x y) z - let (q1', c2') = qdata_unzip shape qubit bit z' - return (q1', c2') - where - errmsg s = "mapBinary_c: shapes of arguments do not match: " ++ s - --- | Map a binary qubit circuit to every pair of qubits in the quantum --- data-type. It is a run-time error if the two structures do not have --- the same size. -map2Q :: (QData qa) => ((Qubit, Qubit) -> Circ Qubit) -> (qa, qa) -> Circ qa -map2Q f (q,p) = do - let shape = shapetype_q q - let z = qdata_zip shape qubit qubit q p errmsg - d <- qdata_mapM shape f z - return d - where - errmsg s = "map2Q: shapes of arguments do not match: " ++ s - --- | Heterogeneous version of 'mapBinary'. Map a binary gate /f/ --- across every corresponding pair of qubits, and a binary gate /g/ --- across every corresponding pair of bits, in two quantum data --- structures of equal shape. -qc_mapBinary :: (QCData qc) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> (Bit -> Bit -> Circ (Bit, Bit)) -> qc -> qc -> Circ (qc, qc) -qc_mapBinary f g x y = do - let z = qcdata_zip x qubit bit qubit bit x y errmsg - z' <- qcdata_mapM x map_qubit map_bit z - let (x', y') = qcdata_unzip x qubit bit qubit bit z' - return (x', y') - where - - map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit) - map_qubit (x,y) = f x y - - map_bit :: (Bit, Bit) -> Circ (Bit, Bit) - map_bit (x,y) = g x y - - errmsg s = "qc_mapBinary: shapes of arguments do not match: " ++ s - --- ---------------------------------------------------------------------- --- * Conversion to lists - --- $CONVERSION The functions in this section can be used to convert --- quantum data structures to and from lists. Do not use them! The --- conversion is unsafe in the same way pointers to void are unsafe in --- the C programming language. There is almost always a better and --- more natural way to accomplish what you need to do. - --- | Return the list of qubits representing the given quantum data. --- The qubits are ordered in some fixed, but arbitrary way. It is --- guaranteed that two pieces of qdata of the same given shape will be --- ordered in the same way. No other property of the order is --- guaranteed, In particular, the order may change without notice from --- one version of Quipper to the next. -qubits_of_qdata :: (QData qa) => qa -> [Qubit] -qubits_of_qdata qa = qdata_sequentialize (shapetype_q qa) qa - --- | Take a specimen piece of quantum data to specify the \"shape\" --- desired (length of lists, etc); then reads the given list of qubits --- in as a piece of quantum data of the same shape. The ordering of --- the input qubits is the same as 'qubits_of_qdata' produces for the --- given shape. --- --- A \"length mismatch\" error occurs if the list does not have --- exactly the required length. -qdata_of_qubits :: (QData qa) => qa -> [Qubit] -> qa -qdata_of_qubits qa list = qdata_unsequentialize qa list - --- | Return the list of endpoints that form the leaves of the given --- 'QCData'. The leaves are ordered in some fixed, but arbitrary --- way. It is guaranteed that two pieces of data of the same given --- shape will be ordered in the same way. No other property of the --- order is guaranteed. In particular, the order may change without notice from --- one version of Quipper to the next. -endpoints_of_qcdata :: (QCData qc) => qc -> [Endpoint] -endpoints_of_qcdata qc = qcdata_sequentialize qc qc - --- | Take a specimen piece of 'QCData' to specify the \"shape\" --- desired (length of lists, etc); then reads the given list of --- endpoints in as a piece of quantum data of the same shape. The --- ordering of the input endpoints equals that produced by --- 'endpoints_of_qcdata' for the given shape. --- --- A \"length mismatch\" error occurs if the list does not have --- exactly the required length. A \"shape mismatch\" error occurs if --- the list contains a 'Qubit' when a 'Bit' was expected, or vice versa. -qcdata_of_endpoints :: (QCData qc) => qc -> [Endpoint] -> qc -qcdata_of_endpoints qc list = qcdata_unsequentialize qc list where - --- | Take a specimen piece of 'QCData' to specify a shape; --- return a 'CircuitTypeStructure' that structures appropriate --- lists of wires with arities into data of this shape, and conversely --- destructures data of this shape into wires and an arity. --- --- The caveats mentioned in 'endpoints_of_qcdata' apply equally for --- this function. -circuit_type_structure_of_qcdata :: (QCData qc) => qc -> CircuitTypeStructure qc -circuit_type_structure_of_qcdata qc = CircuitTypeStructure - (wires_with_arity_of_endpoints . endpoints_of_qcdata) - (\(ws,a) -> qcdata_of_endpoints qc $ endpoints_of_wires_in_arity a ws) - --- ---------------------------------------------------------------------- --- * Shape related operations - --- | Return a boolean data structure of the given shape, with every --- leaf initialized to 'False'. -qc_false :: (QCData qc) => qc -> BType qc -qc_false qc = qcdata_map qc map_qubit map_bit qc - where - map_qubit = const False :: Qubit -> Bool - map_bit = const False :: Bit -> Bool - --- | Return a quantum data structure of the given boolean shape, with --- every leaf initialized to the undefined dummy value 'qubit'. -qshape :: (QData qa) => BType qa -> qa -qshape ba = qdata_map (shapetype_b ba) map_qubit ba - where - map_qubit = const qubit :: Bool -> Qubit - --- ---------------------------------------------------------------------- --- * Bindings - --- | Take two pieces of quantum data of the same shape (the first of --- which consists of wires of a low-level circuit) and create --- bindings. -qc_bind :: (QCData qc) => qc -> QCType a b qc -> Bindings a b -qc_bind qc as = qc_bind_aux qc as bindings_empty - where - -- This can't be inlined without upsetting the type checker. - qc_bind_aux :: (QCData qc) => qc -> QCType a b qc -> Bindings a b -> Bindings a b - qc_bind_aux qc as (bind_in :: Bindings a b) = bindings where - a = (dummy :: a) -- shape type - b = (dummy :: b) -- shape type - z = qcdata_zip qc qubit bit a b qc as errmsg - bindings = qcdata_fold qc do_qubit do_bit z bind_in - - do_qubit :: (Qubit, a) -> Bindings a b -> Bindings a b - do_qubit (q, binding) = bind_qubit q binding - - do_bit :: (Bit, b) -> Bindings a b -> Bindings a b - do_bit (c, binding) = bind_bit c binding - - errmsg s = "qc_bind: shapes of arguments do not match: " ++ s - --- | Apply bindings to a piece of quantum and/or classical data --- holding low-level wires, to get data of the same shape. -qc_unbind :: (QCData qc) => Bindings a b -> qc -> QCType a b qc -qc_unbind (bindings :: Bindings a b) qc = - qcdata_map qc map_qubit map_bit qc - where - map_qubit :: Qubit -> a - map_qubit q = unbind_qubit bindings q - - map_bit :: Bit -> b - map_bit b = unbind_bit bindings b - --- ====================================================================== --- * Generic controls - --- $CONTROL The following functions define a convenient syntax for --- controls. With this, we can write controls in much the same way as --- one would write (a restricted class of) boolean --- expressions. Examples: --- --- > q1 .==. 0 .&&. q2 .==. 1 for Qubits q1, q2 --- --- > q .&&. p means q .==. 1 .&&. p .==. 1 --- --- > qx .==. 5 for a QDInt qx --- --- > q1 .==. 0 .&&. z <= 7 we can combine quantum and classical controls --- --- > q ./=. b the negation of q .==. b; --- > here b is a boolean. --- --- > [p,q,r,s] a list of positive controls --- --- > [(p, True), (q, False), (r, False), (s, True)] --- > a list of positive and negative controls --- --- Among these infix operators, @(.&&.)@ binds more weakly than --- @(.==.)@, @(./=.)@. - --- | Given a piece of quantum data and a possible value for it, return --- a 'ControlList' representing the condition that the quantum data --- has that value. --- --- If some aspect of the value's shape is indeterminate, it is --- promoted to the same shape as the quantum data; therefore, it is --- possible, for example, to write: --- --- > qc_control qa 17 -- when qa :: QDInt --- > qc_control qa [False..] -- when qa :: [Qubit] -qc_control :: (QCData qc) => qc -> BType qc -> ControlList -qc_control qc b = clist where - b' = qcdata_promote b qc errmsg - z = qcdata_zip qc qubit bit bool bool qc b' errmsg - clist = qcdata_fold qc do_qubit do_bit z clist_empty - - do_qubit :: (Qubit, Bool) -> ControlList -> ControlList - do_qubit (q, b) = clist_add_qubit q b - - do_bit :: (Bit, Bool) -> ControlList -> ControlList - do_bit (c, b) = clist_add_bit c b - - errmsg s = "qc_control: shape of control value does not match data: " ++ s - --- | This is an infix operator to concatenate two controls, forming --- their logical conjunction. -(.&&.) :: (ControlSource a, ControlSource b) => a -> b -> ControlList -exp1 .&&. exp2 = combine (to_control exp1) (to_control exp2) - --- | @(qx .==. x)@: a control which is true just if quantum data /qx/ is in the specified state /x/. -(.==.) :: (QCData qc) => qc -> BType qc -> ControlList -qx .==. x = qc_control qx x - --- | The notation @(q ./=. x)@ is shorthand for @(q .==. not x)@, when --- /x/ is a boolean parameter. --- --- Unlike '.==.', which is defined for any shape of quantum data, --- './=.' is only defined for a single control bit or qubit. -(./=.) :: (QCLeaf q) => q -> Bool -> ControlList -q ./=. b = to_control [Signed q (not b)] - --- Set the precedence for infix operators '.&&.', '.==.', and './=.'. -infixr 3 .&&. -- same precedence as (&&) -infix 4 .==. -- same precedence as (==) -infix 4 ./=. -- same precedence as (/=) - --- The following allows us to write 0 and 1 instead of 'False' and --- 'True' everywhere. -instance Num Bool where - (+) = (/=) - (*) = (&&) - (-) = (/=) - negate = id - signum = id - abs = id - fromInteger n = (n `mod` 2 == 1) - --- ====================================================================== --- * Generic encapsulation - --- $encapsulate --- --- An encapsulated circuit is a low-level circuit together with data --- structures holding the input endpoints and output endpoints. A --- circuit-generating function, with fully specified parameters, can --- be turned into an encapsulated circuit; conversely, an encapsulated --- circuit can be turned into a circuit-generating function. Thus, --- encapsulation and unencapsulation are the main interface for --- passing between high- and low-level data structures. - --- | Allocate new quantum data of the given shape, in the given --- arity. Returns the quantum data and the updated arity. -qc_alloc :: (QCData qc) => qc -> ExtArity -> (qc, ExtArity) -qc_alloc qc arity = qcdata_fold_map qc do_qubit do_bit qc arity where - - do_qubit :: Qubit -> ExtArity -> (Qubit, ExtArity) - do_qubit q arity = (qubit_of_wire w, a) - where - (w, a) = arity_alloc Qbit arity - - do_bit :: Bit -> ExtArity -> (Bit, ExtArity) - do_bit c arity = (bit_of_wire w, a) - where - (w, a) = arity_alloc Cbit arity - --- | Extract an encapsulated circuit from a circuit-generating --- function. This requires a shape parameter. -encapsulate_generic :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> (x, BCircuit, y) -encapsulate_generic e f shape = (x, circ, y) where - (x, arity) = qc_alloc shape arity_empty - (circ, y) = extract_simple e arity (f x) - --- | As 'encapsulate_generic', but passes the current namespace --- into the circuit-generating function, to save recomputing --- shared subroutines -encapsulate_generic_in_namespace :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> Circ (x, BCircuit, y) -encapsulate_generic_in_namespace e f shape = do - let (x, arity) = qc_alloc shape arity_empty - (circ, y) <- extract_in_current_namespace e arity (f x) - return (x, circ, y) - --- | Turn an encapsulated circuit back into a circuit-generating --- function. -unencapsulate_generic :: (QCData x, QCData y) => (x, BCircuit, y) -> (x -> Circ y) -unencapsulate_generic (c_in, c, c_out) input = do - let in_bindings = qc_bind c_in input - out_bindings <- apply_bcircuit_with_bindings c in_bindings - let output = qc_unbind out_bindings c_out - return output - --- $dynamic_encapsulate --- --- A dynamic encapsulated circuit is to an encapsulated circuit like a --- 'DBCircuit' to a 'BCircuit'. The output is not a static circuit, --- but an interactive computation expressed through the 'ReadWrite' --- monad, which can be run on a quantum device to get a static circuit --- out. - --- | Extract an encapsulated dynamic circuit from a circuit-generating --- function. This requires a shape parameter. -encapsulate_dynamic :: (QCData x) => (x -> Circ y) -> x -> (x, DBCircuit y) -encapsulate_dynamic f shape = (x, comp) where - (x, arity) = qc_alloc shape arity_empty - comp = extract_general arity (f x) - --- | Turn an encapsulated dynamic circuit back into a --- circuit-generating function. --- --- This currently fails if the dynamic circuit contains output --- liftings, because the transformer interface has not yet been --- updated to work with dynamic circuits. -unencapsulate_dynamic :: (QCData x, QCData y) => (x, DBCircuit y) -> (x -> Circ y) -unencapsulate_dynamic (c_in, comp) input = do - let in_bindings = qc_bind c_in input - (out_bindings, c_out) <- apply_dbcircuit_with_bindings comp in_bindings - let output = qc_unbind out_bindings c_out - return output - --- ====================================================================== --- * Generic reversing - --- | Like 'reverse_unary', but also takes a stub error message. -reverse_errmsg :: (QCData x, QCData y) => ErrMsg -> (x -> Circ y) -> x -> (y -> Circ x) -reverse_errmsg e f shape y = do - circuit <- encapsulate_generic_in_namespace errmsg f shape - let circuit_inv = reverse_encapsulated circuit - f_inv = unencapsulate_generic circuit_inv - f_inv y - where - errmsg x = e ("operation not permitted in reversible circuit: " ++ x) - --- | Reverse a non-curried circuit-generating function. The second --- parameter is a shape parameter. -reverse_unary :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x) -reverse_unary = reverse_errmsg errmsg - where - errmsg x = "reverse_unary: " ++ x - --- | Reverse a circuit-generating function. The reversed function --- requires a shape parameter, given as the input type of the original --- function. --- --- The type of this highly overloaded function is quite difficult to --- read. It can have for example the following types: --- --- > reverse_generic :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x) --- > reverse_generic :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> x -> y -> (z -> Circ (x,y)) -reverse_generic :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y, Curry x_y_xt x (y -> Circ xt)) => x_y -> x_y_xt -reverse_generic f = - mcurry $ aux f - where - -- An auxiliary function for defining 'reverse_generic'. (Inlining - -- this causes difficulty with the type inference for 'mcurry'.) - --aux :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> x -> (y -> Circ xt) - aux f shape = - (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) shape) - - errmsg x = "reverse_generic: " ++ x - --- | Like 'reverse_generic', but takes functions whose output is a --- tuple, and curries the reversed function. Differs from --- 'reverse_generic' in an example such as: --- --- > f :: (x -> y -> Circ (z,w)) --- > reverse_generic f :: x -> y -> ((z,w) -> Circ (x,y)) --- > reverse_generic_curried f :: x -> y -> (z -> w -> Circ (x,y)) --- --- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥ --- 2. Applying this to a circuit whose output is a non-tuple type is a --- type error; in this case, 'reverse_generic' should be used. -reverse_generic_curried :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt, Curry x_y_xt x y_xt) => x_yt -> x_y_xt -reverse_generic_curried f = - mcurry $ aux f - where - -- An auxiliary function for 'reverse_generic_curried'. (Inlining - -- this causes difficulty with the type inference for 'mcurry'.) - aux :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt) => x_yt -> x -> y_xt - aux f = - (qcurry .) $ \x y -> (fmap weak_tuple) $ (reverse_errmsg errmsg $ (fmap untuple) . (quncurry f)) x y - - errmsg x = "reverse_generic_curried: " ++ x - --- | Like 'reverse_generic', but only works at simple types, and --- therefore requires no shape parameters. Typical type instances: --- --- > reverse_simple :: (QCData_Simple x, QCData y) => (x -> Circ y) -> (y -> Circ x) --- > reverse_simple :: (QCData_Simple x, QCData_Simple y, QCData z) => (x -> y -> Circ z) -> (z -> Circ (x,y)) -reverse_simple :: (QCData_Simple x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> y -> Circ xt -reverse_simple f = (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) fs_shape) - where - errmsg x = "reverse_simple: " ++ x - --- | Like 'reverse_simple', but takes functions whose output is a --- tuple, and curries the reversed function. Typical type instance: --- --- > reverse_simple_curried :: (QCData_Simple x, QCData y, QCData z) => (x -> Circ (y,z)) -> (y -> z -> Circ x) --- --- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥ --- 2. Applying this to a circuit whose output is a non-tuple type is a --- type error; in this case, 'reverse_generic' should be used. -reverse_simple_curried :: (QCData_Simple x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt) - => x_yt -> y_xt -reverse_simple_curried f = qcurry $ - (fmap weak_tuple) . (reverse_errmsg errmsg ((fmap untuple) . (quncurry f)) fs_shape) - where - errmsg x = "reverse_simple_curried: " ++ x - --- | Like 'reverse_generic', but specialized to endomorphic circuits, --- i.e., circuits where the input and output have the same type (modulo --- possibly currying) and shape. In this case, unlike 'reverse_generic', --- no additional shape parameter is required, and the reversed function --- is curried if the original function was. Typical type instances: --- --- > reverse_generic_endo :: (QCData x) => (x -> Circ x) -> (x -> Circ x) --- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ (x,y)) -> (x -> y -> Circ (x,y)) -reverse_generic_endo :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => x_xt -> x_xt -reverse_generic_endo = qcurry . ((fmap weak_tuple) .) . - (\f x -> reverse_errmsg errmsg f x x) - . ((fmap weak_untuple) .) . quncurry - where - errmsg x = "reverse_generic_endo: " ++ x - --- | Like 'reverse_generic_endo', but applies to endomorphic circuits --- expressed in \"imperative\" style. Typical type instances: --- --- > reverse_generic_endo :: (QCData x) => (x -> Circ ()) -> (x -> Circ ()) --- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ ()) -> (x -> y -> Circ ()) -reverse_generic_imp :: (QCData x, QCurry x__ x ()) => x__ -> x__ -reverse_generic_imp f = qcurry $ \input -> do - reverse_generic_endo f' input - return () - where - f' x = do - (quncurry f) x - return x - --- | Conditional version of 'reverse_generic_endo'. Invert the --- endomorphic quantum circuit if the boolean is true; otherwise, --- insert the non-inverted circuit. -reverse_endo_if :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => Bool -> x_xt -> x_xt -reverse_endo_if False f = f -reverse_endo_if True f = reverse_generic_endo f - --- | Conditional version of 'reverse_generic_imp'. Invert the --- imperative style quantum circuit if the boolean is true; otherwise, --- insert the non-inverted circuit. -reverse_imp_if :: (QCData qa, QCurry fun qa ()) => Bool -> fun -> fun -reverse_imp_if False f = f -reverse_imp_if True f = reverse_generic_imp f - --- ====================================================================== --- * The QCurry type class - --- | The 'QCurry' type class is similar to the 'Curry' type class, --- except that the result type is guarded by the 'Circ' monad. It --- provides a family of type isomorphisms --- --- @fun ≅ args -> Circ res,@ --- --- where --- --- > fun = a1 -> a2 -> ... -> an -> Circ res, --- > args = (a1, (a2, (..., (an, ())))). --- --- The benefit of having @Circ@ in the result type is that it ensures --- that the result type is not itself a function type, and therefore --- /fun/ has a /unique/ arity /n/. Then /args/ and /res/ are uniquely --- determined by /fun/, which can be used to write higher-order --- operators that consume /fun/ of any arity and \"do the right --- thing\". - -class QCurry fun args res | fun -> args res, args res -> fun where - qcurry :: (args -> Circ res) -> fun - quncurry :: fun -> (args -> Circ res) - -instance QCurry (Circ b) () b where - qcurry g = g () - quncurry x = const x - -instance QCurry fun args res => QCurry (a -> fun) (a,args) res where - qcurry g x = qcurry (\xs -> g (x,xs)) - quncurry f (x,xs) = quncurry (f x) xs - --- ====================================================================== --- * Generic circuit transformations - --- | Like 'transform_unary_shape', but also takes a stub error message. -transform_errmsg :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => ErrMsg -> Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y') -transform_errmsg e transformer f shape input = do - let (x, circuit, y) = encapsulate_generic errmsg f shape - let in_bind = qc_bind x input - out_bind <- transform_bcircuit_rec transformer circuit in_bind - let output = qc_unbind out_bind y - return output - where - errmsg x = e ("operation not currently permitted in transformed circuit: " ++ x) - --- | Like 'transform_generic', but applies to arbitrary transformers --- of type --- --- > Transformer m a b --- --- instead of the special case --- --- > Transformer Circ Qubit Bit. --- --- This requires an additional shape argument. -transform_unary_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y') -transform_unary_shape = transform_errmsg errmsg - where - errmsg x = "transform_unary_shape: " ++ x - --- | Apply the given transformer to a circuit. -transform_unary :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) -transform_unary transformer f x = transform_errmsg errmsg transformer f x x - where - errmsg x = "transform_unary: " ++ x - - --- | Like transform_unary_shape but for a dynamic transformer -transform_unary_dynamic_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => DynamicTransformer m a b -> (x -> Circ y) -> x -> (x' -> m y') -transform_unary_dynamic_shape dtransformer f shape input = do - let (x, dbcircuit) = encapsulate_dynamic f shape - let in_bind = qc_bind x input - (y,out_bind) <- transform_dbcircuit dtransformer dbcircuit in_bind - let output = qc_unbind out_bind y - return output - --- | Like transform_unary but for a dynamic transformer -transform_unary_dynamic :: (QCData x, QCData y) => DynamicTransformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) -transform_unary_dynamic dtransformer f x = transform_unary_dynamic_shape dtransformer f x x - - --- | Like 'transform_generic', but applies to arbitrary transformers --- of type --- --- > Transformer m a b --- --- instead of the special case --- --- > Transformer Circ Qubit Bit. --- --- This requires an additional shape argument. --- --- The type of this heavily overloaded function is difficult to --- read. In more readable form, it has all of the following types: --- --- > transform_generic :: (QCData x) => Transformer m a b -> Circ x -> m (QCData a b x) --- > transform_generic :: (QCData x, QCData y) => Transformer m a b -> (x -> Circ y) -> x -> (QCData a b x -> m (QCData a b y)) --- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer m a b -> (x -> y -> Circ z) -> x -> y -> (QCData a b x -> QCData a b y -> m (QCData a b z)) --- --- and so forth. - -transform_generic_shape :: (QCData x, QCData y, QCurry qfun x y, Curry qfun' x' (m y'), Curry qfun'' x qfun', x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> qfun -> qfun'' -transform_generic_shape transformer f = g where - f1 = quncurry f - g1 = transform_errmsg errmsg transformer f1 - g2 = \x -> mcurry (g1 x) - g = mcurry g2 - errmsg x = "transform_generic: " ++ x - --- | Apply the given transformer to a circuit. Unlike --- 'transform_unary', this function can be applied to a --- circuit-generating function in curried form with /n/ arguments, for --- any /n/ ≥ 0. --- --- The type of this heavily overloaded function is difficult to --- read. In more readable form, it has all of the following types: --- --- > transform_generic :: (QCData x) => Transformer Circ Qubit Bit -> Circ x -> Circ x --- > transform_generic :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y) --- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer Circ Qubit Bit -> (x -> y -> Circ z) -> (x -> y -> Circ z) --- --- and so forth. - -transform_generic :: (QCData x, QCData y, QCurry qfun x y) => Transformer Circ Qubit Bit -> qfun -> qfun -transform_generic transformer f = g where - f1 = quncurry f - g1 = \x -> transform_errmsg errmsg transformer f1 x x - g = qcurry g1 - errmsg x = "transform_generic: " ++ x - - --- ====================================================================== --- * Generic block structure - --- | Execute a block with local ancillas. Opens a block, initializing an ancilla with a specified classical value, and terminates it with the same value when the block closes. Note: it is the programmer's responsibility to return the ancilla to its original state at the end of the enclosed block. Usage: --- --- > with_ancilla_init True $ \a -> do { --- > <<>> --- > } --- --- > with_ancilla_init [True,False,True] $ \a -> do { --- > <<>> --- > } -with_ancilla_init :: (QShape a qa ca) => a -> (qa -> Circ b) -> Circ b -with_ancilla_init x f = do - qx <- without_controls (qinit x) - qy <- f qx - without_controls (qterm x qx) - return qy - --- | Like 'with_ancilla', but creates a list of /n/ ancillas, all --- initialized to |0〉. Usage: --- --- > with_ancilla_list n $ \a -> do { --- > <<>> --- > } -with_ancilla_list :: Int -> (Qulist -> Circ a) -> Circ a -with_ancilla_list n f = - with_ancilla_init (replicate n False) f - --- | @'with_computed_fun' /x/ /f/ /g/@: computes /x' := f(x)/; then computes /g(x')/, which should be organized as a pair /(x',y)/; then uncomputes /x'/ back to /x/, and returns /(x,y)/. --- --- Important subtlety in usage: all quantum data referenced in /f/, even as controls, must be explicitly bound and returned by /f/, or the reversing may rebind it incorrectly. /g/, on the other hand, can safely refer to anything that is in scope outside the 'with_computed_fun'. - -with_computed_fun :: (QCData x, QCData y) => x -> (x -> Circ y) -> (y -> Circ (y,b)) -> Circ (x,b) -with_computed_fun x f g = do - y <- without_controls (f x) - (y,b) <- g y - x <- without_controls (reverse_generic f x y) - return (x,b) - --- | @'with_computed' /computation/ /code/@: performs /computation/ --- (with result /x/), then performs /code/ /x/, and finally performs --- the reverse of /computation/, for example like this: --- --- \[image with_computed.png] --- --- Both /computation/ and /code/ may refer to any qubits that exist in --- the current environment, and they may also create new --- qubits. /computation/ may produce arbitrary garbage in addition to --- its output. --- --- This is a very general but relatively unsafe operation. It is the --- user's responsibility to ensure that the computation can indeed be --- undone. In particular, if /computation/ contains any --- initializations, then /code/ must ensure that the corresponding --- assertions will be satisfied in /computation/[sup −1]. --- --- Related more specialized, but potentially safer, operations are: --- --- * 'with_basis_change', which is like 'with_computed', but assumes --- that /computation/ is unitary, and --- --- * 'classical_to_reversible', which assumes that /computation/ is --- classical (or pseudo-classical), and /code/ is a simple --- copy-by-controlled-not operation. - -with_computed :: (QCData x) => Circ x -> (x -> Circ b) -> Circ b -with_computed computation code = do - (bcirc, dirty, x) <- extract_in_context errmsg computation - without_controls $ do - unextract_in_context bcirc - y <- with_reserve dirty $ do - code x - without_controls $ do - unextract_in_context (reverse_bcircuit bcirc) - return y - where - errmsg x = "with_computed: operation not permitted in pre-computation: " ++ x - --- | @'with_basis_change' /basischange/ /code/@: performs a basis change, --- then the /code/, then the inverse of the basis change. Both --- /basischange/ and /code/ are in imperative style. It is the user's --- responsibility to ensure that the image of /code/ is contained in --- the image of /basischange/, or else there will be unmet assertions --- or runtime errors. Usage: --- --- > with_basis_change basischange $ do --- > <<>> --- > --- > where --- > basischange = do --- > <<>> - -with_basis_change :: Circ () -> Circ b -> Circ b -with_basis_change basischange code = do - with_computed basischange (\x -> code) - --- ====================================================================== --- * Boxed subcircuits - - --- | Bind a name to a function as a subroutine in the current --- namespace. This requires a shape argument, as well as complete --- parameters, so that it is uniquely determined which actual circuit --- will be the subroutine. It is an error to call that subroutine --- later with a different shape argument. It is therefore the user's --- responsibility to ensure that the name is unique to the subroutine, --- parameters, and shape. --- --- This function does nothing if the name --- already exists in the namespace; in particular, it does /not/ check --- whether the given function is equal to the stored subroutine. -provide_subroutine_generic :: (QCData x, QCData y) => ErrMsg -> BoxId -> Bool -> (x -> Circ y) -> x -> Circ () -provide_subroutine_generic e name is_classically_controllable f shape = do - main_state <- get_namespace - if (Map.member name main_state) - then return () - else do - (x, bcircuit, y) <- encapsulate_generic_in_namespace errmsg f shape - - -- The 'y' element only corresponds to the output type of the box, - -- not the complete list of wires outputted by the circuit. This - -- information is gathered and stored in forgotten_output_qcdata - -- as ([Qubit],[Bit]). - let ((_,_,aout,_),_) = bcircuit - forgotten_output_arity = strip_qcdata_from_arity y aout - forgotten_output_qcdata = extract_from_arity forgotten_output_arity - - let ein = endpoints_of_qcdata x - eout = endpoints_of_qcdata (y,forgotten_output_qcdata) - win = map wire_of_endpoint ein - wout = map wire_of_endpoint eout - - input_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata - input_structure = (\(ws,a) -> qcdata_of_endpoints x $ endpoints_of_wires_in_arity a ws) - - input_CircTypeStructure = CircuitTypeStructure input_destructure input_structure - - output_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata - output_structure = (\(ws,a) -> qcdata_of_endpoints (y,forgotten_output_qcdata) $ endpoints_of_wires_in_arity a ws) - - output_CircTypeStructure = CircuitTypeStructure output_destructure output_structure - - provide_subroutine name (ob_circuit win bcircuit wout) input_CircTypeStructure output_CircTypeStructure is_classically_controllable - where - errmsg x = e ("operation not permitted in boxed subroutine: " ++ x) - - -- Make a 'QCData' out of an arity. - extract_from_arity :: Arity -> ([Qubit],[Bit]) - extract_from_arity x = - fst $ IntMap.mapAccumWithKey record_wire ([],[]) x - where - record_wire :: ([Qubit],[Bit]) -> Int -> Wiretype -> (([Qubit],[Bit]),Wiretype) - record_wire (qs,bs) wire Qbit = (((qubit_of_wire wire):qs,bs), Qbit) - record_wire (qs,bs) wire Cbit = ((qs,(bit_of_wire wire):bs), Cbit) - - -- Take a 'QCData' /x/ and an 'Arity' /a/ and remove all the wires - -- of /a/ that are already existing in /x/. - strip_qcdata_from_arity :: (QCData x) => x -> Arity -> Arity - strip_qcdata_from_arity x a = - snd $ State.runState (qcdata_mapM x delete_qubit delete_bit x) a - where - - delete_qubit :: Qubit -> State.State Arity () - delete_qubit q = do - s <- State.get - State.put $ flip IntMap.delete s $ wire_of_qubit q - - delete_bit :: Bit -> State.State Arity () - delete_bit b = do - s <- State.get - State.put $ flip IntMap.delete s $ wire_of_bit b - - - - - - --- | A generic interface for wrapping a circuit-generating function --- into a boxed and named subroutine. This takes a name and a --- circuit-generating function, and returns a new circuit-generating --- function of the same type, but which inserts a boxed subroutine --- instead of the actual body of the subroutine. --- --- It is intended to be used like this: --- --- > somefunc :: Qubit -> Circ Qubit --- > somefunc a = do ... --- > --- > somefunc_boxed :: Qubit -> Circ Qubit --- > somefunc_boxed = box "somefunc" somefunc --- --- Here, the type of @somefunc@ is just an example; this could indeed --- be a function with any number and type of arguments, as long as the --- arguments and return type are quantum data. --- --- It is also possible to inline the 'box' operator directly, in which --- case it should be done like this: --- --- > somefunc :: Qubit -> Circ Qubit --- > somefunc = box "somefunc" $ \a -> do ... --- --- Note: The 'box' operator wraps around a complete function, --- including all of its arguments. It would be incorrect to apply the --- 'box' operator after some quantum variables have already been --- defined. Thus, the following is incorrect: --- --- > incorrect_somefunc :: Qubit -> Circ Qubit --- > incorrect_somefunc a = box "somefunc" $ do ... --- --- It is the user's responsibility not to use the same name for --- different subroutines. If 'box' is called more than once with the --- same name and shape of input, Quipper assumes, without checking, --- that they are subsequent calls to the same subroutine. --- --- The type of the 'box' operator is overloaded and quite difficult to --- read. It can have for example the following types: --- --- > box :: String -> (Qubit -> Circ Qubit) -> (Qubit -> Circ Qubit) --- > box :: String -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt)) -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt)) -box :: (QCData qa, QCData qb, QCurry qa_qb qa qb) - => String -> qa_qb -> qa_qb -box n = qcurry . (box_internal err n $ RepeatFlag 1) . quncurry - where - err e = "box: " ++ e - --- | A version of 'box' with iteration. The second argument is an --- iteration count. --- --- This can only be applied to functions of a single argument, where --- the input and output types are the same. -nbox :: (QCData qa) => String -> Integer -> (qa -> Circ qa) -> qa -> Circ qa -nbox n rep = qcurry . (box_internal err n (RepeatFlag rep)) . quncurry - where - err e = "nbox: " ++ e - --- | A version of 'nbox' with same type as 'loopM'. -box_loopM :: (Integral int, QCData qa) - => String -> int -> qa -> (qa -> Circ qa) -> Circ qa -box_loopM n rep = flip (nbox n $ fromIntegral rep) - --- | A version of 'loopM' that will be boxed conditionally on a --- boolean condition. Typical usage: --- --- > loopM_boxed_if (s > 1) "name" s x $ \x -> do --- > <<>> --- > return x -loopM_boxed_if :: (Integral int, QCData qa) => Bool -> String -> int -> qa -> (qa -> Circ qa) -> Circ qa -loopM_boxed_if True name = box_loopM name -loopM_boxed_if False name = loopM - --- | The underlying implementation of 'box' and 'nbox'. It behaves --- like 'box', but is restricted to unary functions, and takes an --- 'ErrMsg' argument. -box_internal :: (QCData qa, QCData qb) - => ErrMsg -> String -> RepeatFlag -> (qa -> Circ qb) -> (qa -> Circ qb) -box_internal e n r f x = do - let boxid = BoxId n (canonical_shape x) - provide_subroutine_generic e boxid False f x -- By default, fall back on the general controlling scheme: - -- set the classical-control flag to False. - call_subroutine boxid r x - - --- | Classical control on a function with same shape of input and --- output: if the control bit is true the function is fired, otherwise --- the identity map is used. --- Note: the constraint on the types is dynamically checked. -with_classical_control :: QCData qa => Bit -> String -> qa -> (qa -> Circ qa) -> Circ qa -with_classical_control c n x f = do - let boxid = BoxId n (canonical_shape x) - provide_subroutine_generic err boxid True f x - call_subroutine boxid (RepeatFlag 1) x `controlled` c - where - err e = "with_classical_control: " ++ e - --- | Like 'call_subroutine', except inline the subroutine body from --- the given namespace, instead of inserting a subroutine call. --- --- Implementation note: this currently copies /all/ subroutine --- definitions from the given namespace into the current namespace, --- and not just the ones used by the current subroutine. --- --- Implementation note: this currently only works on lists of endpoints. -inline_subroutine :: BoxId -> Namespace -> [Endpoint] -> Circ [Endpoint] -inline_subroutine name ns inputs = do - let mc = Map.lookup name ns - case mc of - Nothing -> - error ("inline_subroutine: subroutine " ++ show name ++ " does not exist in the given namespace: " ++ showNames ns) - Just (TypedSubroutine ocircuit _ _ scf) -> do - let OCircuit (win, circuit, wout) = ocircuit - provide_subroutines ns - when (length win /= length inputs) $ do - error ("inline_subroutine: subroutine " ++ show name ++ " has been applied to incorrect size of QCData") - let in_bind = bind_list win inputs bindings_empty - out_bind <- apply_circuit_with_bindings circuit in_bind - let outputs = unbind_list out_bind wout - return outputs diff --git a/src/Quipper/Internal.hs b/src/Quipper/Internal.hs deleted file mode 100644 --- a/src/Quipper/Internal.hs +++ /dev/null @@ -1,51 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - --- | This module exposes interfaces that are internal to Quipper, and --- are not intended for use by user-level code, but may be useful in --- libraries that extend Quipper's functionality. --- --- This module must not be imported directly by user-level code. It --- may, however, be imported by libraries. A typical use of this --- module is in a library that defines a new kind of 'QCData'. - -module Quipper.Internal ( - -- * Quantum data - -- $QData - module Quipper.QData, - -- * Currying - QCurry(..), - -- * Error handlers - ErrMsg, - -- * The Labelable class - Labelable (..), - with_index, - with_dotted_index, - indexed, - dotted_indexed, - -- * Functions for IntMaps - intmap_zip, - intmap_zip_errmsg, - intmap_map, - intmap_mapM, - -- * Identity types - Identity, - reflexivity, - symmetry, - transitivity, - identity, - ) where - -import Libraries.Auxiliary -import Quipper.QData -import Quipper.Labels -import Quipper.Generic - --- $QData --- --- The module "Quipper.QData" provides type classes for dealing with --- various "shaped" quantum and classical data structures. Please see --- "Quipper.QData" for documentation. diff --git a/src/Quipper/Labels.hs b/src/Quipper/Labels.hs deleted file mode 100644 --- a/src/Quipper/Labels.hs +++ /dev/null @@ -1,535 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE Unsafe #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverlappingInstances #-} - --- | This module provides functionality for labelling endpoints in --- wires. The goal is to achieve two things: --- --- * Label qubits individually. For example, we would like to label --- three qubits (/a/, /b/, /c/) as \"a\", \"b\", and \"c\", --- respectively. --- --- * Label data structures all at once. For example, if --- /a/=[/x/,/y/,/z/] is a piece of quantum data, and we label this --- data structure \"a\", then the individual qubits will be labelled: --- /x/ = /a/[0], /y/ = /a/[1], /z/ = /a/[2]. --- --- We can also combine both methods to arbitrary nesting levels. For --- example, we can label (([x,y,z], t), [u,v,w]) as (\"a\", [\"u\", --- \"v\", \"w\"]), to get the labelling /x/ = /a/[0,0], /y/ = --- /a/[0,1], /z/ = /a/[0,2], /t/ = /a/[1], /u/ = /u/, /v/ = /v/, /w/ = --- /w/. - -module Quipper.Labels where - -import Quipper.Circuit -import Quipper.Monad -import Libraries.Auxiliary -import Libraries.Tuple -import Quipper.Transformer - -import qualified Data.Map as Map -import Data.Map (Map) - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - --- ---------------------------------------------------------------------- --- * Helper functions - --- ** Indices - --- | An index list is something that can be appended to a string. We --- consider subscript indices of the form \"[i]\", dotted indices of --- the form \".i\", and perhaps arbitrary suffixes. A complication is --- that we want consecutive subscript indices to be combined, as in --- \"[i,j,k]\". We therefore need a special data structure to hold an --- index list \"under construction\". --- --- An index list consists of a string and a list of current --- subscripts. For efficiency, the list of subscripts is reversed, --- i.e., the most recent subscript is at the head of the list. -type IndexList = (String, [String]) - --- | Convert an index list to a string. -indexlist_format :: IndexList -> String -indexlist_format (s,idx) = - s ++ string_of_list "[" "," "]" "" id (reverse idx) - --- | The empty index list. -indexlist_empty :: IndexList -indexlist_empty = ("", []) - --- | Append a subscript to an index list. -indexlist_subscript :: IndexList -> String -> IndexList -indexlist_subscript (s, idx) i = (s, i:idx) - --- | Append a dotted index to an index list. -indexlist_dotted :: IndexList -> String -> IndexList -indexlist_dotted idxl i = (indexlist_format idxl ++ "." ++ i, []) - --- ** The LabelMonad monad - --- | A monad to provide a convenient syntax for specifying 'Labelable' --- instances. Computations in this monad have access to a read-only --- \"current index list\", and they output a binding from wires to --- strings. -newtype LabelMonad a = LabelMonad { - getLabelMonad :: IndexList -> (Map Wire String, a) - } - -instance Monad LabelMonad where - return a = LabelMonad (\idxl -> (Map.empty, a)) - f >>= g = LabelMonad h where - h idxl = (Map.union m1 m2, z) where - (m1, y) = getLabelMonad f idxl - (m2, z) = getLabelMonad (g y) idxl - -instance Applicative LabelMonad where - pure = return - (<*>) = ap - -instance Functor LabelMonad where - fmap = liftM - --- | Get the current string and index. -labelmonad_get_indexlist :: LabelMonad IndexList -labelmonad_get_indexlist = LabelMonad h where - h idxl = (Map.empty, idxl) - --- | Output a binding for a label -labelmonad_put_binding :: Wire -> String -> LabelMonad () -labelmonad_put_binding x label = LabelMonad h where - h idxl = (Map.singleton x label, ()) - --- | Run a subcomputation with a new current index list. -labelmonad_with_indexlist :: IndexList -> LabelMonad a -> LabelMonad a -labelmonad_with_indexlist idxl body = LabelMonad h where - h idxl' = getLabelMonad body idxl - --- | Extract a labelling from a label monad computation. This is the --- run function of the label monad. -labelmonad_run :: LabelMonad () -> Map Wire String -labelmonad_run body = bindings where - (bindings, _) = getLabelMonad body indexlist_empty - --- ---------------------------------------------------------------------- --- ** Formatting of labels - --- | Label a wire with the given name, using the current index. -label_wire :: Wire -> String -> LabelMonad () -label_wire x s = do - idxl <- labelmonad_get_indexlist - let label = s ++ indexlist_format idxl - labelmonad_put_binding x label - --- | Run a subcomputation with a subscript index appended to the --- current index list. Sample usage: --- --- > with_index "0" $ do --- > <<>> -with_index :: String -> LabelMonad () -> LabelMonad () -with_index i body = do - idxl <- labelmonad_get_indexlist - labelmonad_with_indexlist (indexlist_subscript idxl i) body - --- | Run a subcomputation with a dotted index appended to the current --- index list. Sample usage: --- --- > with_dotted_index "left" $ do --- > <<>> - -with_dotted_index :: String -> LabelMonad () -> LabelMonad () -with_dotted_index i body = do - idxl <- labelmonad_get_indexlist - labelmonad_with_indexlist (indexlist_dotted idxl i) body - --- | Like 'with_index', except the order of the arguments is --- reversed. This is intended to be used as an infix operator: --- --- > <<>> `indexed` "0" -indexed :: LabelMonad () -> String -> LabelMonad () -indexed body i = with_index i body - --- | Like 'with_dotted_index', except the order of the arguments is --- reversed. This is intended to be used as an infix operator: --- --- > <<>> `dotted_indexed` "left" -dotted_indexed :: LabelMonad () -> String -> LabelMonad () -dotted_indexed body i = with_dotted_index i body - --- | Do nothing. -label_empty :: LabelMonad () -label_empty = return () - --- ---------------------------------------------------------------------- --- * The Labelable type class - --- | 'Labelable' /a/ /s/ means that /a/ is a data structure that can --- be labelled with the format /s/. A \"format\" is a string, or a --- data structure with strings at the leaves. - -class Labelable a s where - -- | Recursively label a data structure with the given format. - label_rec :: a -> s -> LabelMonad () - --- | Given a data structure and a format, return a list of labelled --- wires. -mklabel :: (Labelable a s) => a -> s -> [(Wire, String)] -mklabel a s = Map.toList bindings where - bindings = labelmonad_run (label_rec a s) - -instance Labelable Qubit String where - label_rec a s = label_wire (wire_of_qubit a) s - -instance Labelable Bit String where - label_rec a s = label_wire (wire_of_bit a) s - -instance (Labelable a String) => Labelable (Signed a) String where - label_rec (Signed a b) s = - label_rec a s `dotted_indexed` (if b then "+" else "-") - -instance (Labelable a String) => Labelable (Signed a) (Signed String) where - label_rec (Signed a b) (Signed s c) - | b == c = label_rec a s - | otherwise = return () -- fail silently - -instance Labelable () String where - label_rec a s = label_empty - -instance Labelable () () where - label_rec a s = label_empty - -instance (Labelable a String, Labelable b String) => Labelable (a,b) String where - label_rec (a,b) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - -instance (Labelable a String, Labelable b String, Labelable c String) => Labelable (a,b,c) String where - label_rec (a,b,c) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String) => Labelable (a,b,c,d) String where - label_rec (a,b,c,d) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String) => Labelable (a,b,c,d,e) String where - label_rec (a,b,c,d,e) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String) => Labelable (a,b,c,d,e,f) String where - label_rec (a,b,c,d,e,f) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - label_rec f s `indexed` "5" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String) => Labelable (a,b,c,d,e,f,g) String where - label_rec (a,b,c,d,e,f,g) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - label_rec f s `indexed` "5" - label_rec g s `indexed` "6" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String) => Labelable (a,b,c,d,e,f,g,h) String where - label_rec (a,b,c,d,e,f,g,h) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - label_rec f s `indexed` "5" - label_rec g s `indexed` "6" - label_rec h s `indexed` "7" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String) => Labelable (a,b,c,d,e,f,g,h,i) String where - label_rec (a,b,c,d,e,f,g,h,i) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - label_rec f s `indexed` "5" - label_rec g s `indexed` "6" - label_rec h s `indexed` "7" - label_rec i s `indexed` "8" - -instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String, Labelable j String) => Labelable (a,b,c,d,e,f,g,h,i,j) String where - label_rec (a,b,c,d,e,f,g,h,i,j) s = do - label_rec a s `indexed` "0" - label_rec b s `indexed` "1" - label_rec c s `indexed` "2" - label_rec d s `indexed` "3" - label_rec e s `indexed` "4" - label_rec f s `indexed` "5" - label_rec g s `indexed` "6" - label_rec h s `indexed` "7" - label_rec i s `indexed` "8" - label_rec j s `indexed` "9" - -instance (Labelable a sa, Labelable b sb) => Labelable (a,b) (sa,sb) where - label_rec (a,b) (sa,sb) = do - label_rec a sa - label_rec b sb - -instance (Labelable a sa, Labelable b sb, Labelable c sc) => Labelable (a,b,c) (sa, sb, sc) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd) => Labelable (a,b,c,d) (sa, sb, sc, sd) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se) => Labelable (a,b,c,d,e) (sa, sb, sc, sd, se) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf) => Labelable (a,b,c,d,e,f) (sa, sb, sc, sd, se, sf) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg) => Labelable (a,b,c,d,e,f,g) (sa, sb, sc, sd, se, sf, sg) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh) => Labelable (a,b,c,d,e,f,g,h) (sa, sb, sc, sd, se, sf, sg, sh) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si) => Labelable (a,b,c,d,e,f,g,h,i) (sa, sb, sc, sd, se, sf, sg, sh, si) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si, Labelable j sj) => Labelable (a,b,c,d,e,f,g,h,i,j) (sa, sb, sc, sd, se, sf, sg, sh, si, sj) where - label_rec a s = label_rec (untuple a) (untuple s) - -instance (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 <<>> s `indexed` <<>> --- > ... --- > label_rec <<>> s `indexed` <<>> --- --- Here, /a/[sub 1].../a/[sub /n/] are the components of the data --- structure, and /index/[sub 1].../index[sub /n/] are the --- corresponding subscripts. The function 'indexed' appends a --- subscript of the form \"[i]\". There is a similar function --- 'dotted_indexed', which appends a subscript of the form \".i\". --- --- The second required instance deals with a label that is a data --- structure of the same shape as the data being labeled. It takes the --- form: --- --- > instance (Labelable a s) => Labelable (Constructor a) (Constructor s) where --- > label_rec as ss idx = do --- > label_rec <<>> <<>> --- > ... --- > label_rec <<>> <<>> --- --- Here, /a/[sub 1].../a/[sub /n/] are the components of the data --- structure, and /s/[sub 1].../s/[sub /n/] are the corresponding --- components of the label. --- --- [Example] --- --- As a concrete example, consider a constructor --- --- > data MaybeTwo a = One a | Two a a --- > instance (QCData a) => QCData (MaybeTwo a) --- --- The following instance declarations would be appropriate: --- --- > instance (Labelable a String) => Labelable (MaybeTwo a) String where --- > label_rec (One x) s = --- > with_dotted_index "one" $ do --- > label_rec x s --- > label_rec (Two x y) s = --- > with_dotted_index "two" $ do --- > label_rec x s `indexed` "0" --- > label_rec y s `indexed` "1" --- > --- > instance (Labelable a s) => Labelable (MaybeTwo a) (MaybeTwo s) where --- > label_rec (One x) (One s) = label_rec x s --- > label_rec (Two x y) (Two s t) = do --- > label_rec x s --- > label_rec y t --- > label_rec _ _ = return () -- fail silently --- --- With this example, the commands --- --- > mklabel (One x) "s" --- > mklabel (Two y z) "s" --- --- produce the respective labelings --- --- > x -> s.one --- > y -> s.two[0] --- > z -> s.two[1] --- --- [New atomic 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 <<>> s `indexed` <<>> --- > ... --- > label_rec <<>> s `indexed` <<>> --- --- Here, /a/[sub 1].../a/[sub /n/] are the components of the data --- structure, and /index/[sub 1].../index[sub /n/] are the --- corresponding subscripts. It is up to the designer of the data --- structure to decide what are \"components\" and how they should be --- labelled. On or more layers of string or numeric indices can be --- added as appropriate. --- --- [Example] --- --- Consider the following sample atomic quantum data. A real number --- consists of an exponent, a sign, and a list of digits. --- --- > data MyReal x = MyReal Int x [x] --- > instance QCLeaf x => QCData (MyReal x) --- --- The following instance declaration would be appropriate: --- --- > instance QCLeaf x => Labelable (MyReal x) String where --- > label_rec (MyReal exp sign digits) s = do --- > label_rec sign s `dotted_indexed` "sign" --- > with_dotted_index "digit" $ do --- > sequence_ [ label_rec d s `indexed` show i | (d,i) <- zip digits [-exp..] ] --- --- With this example, the command --- --- > mklabel (MyReal 2 x [y0, y1, y2, y3]) "s" --- --- produces the labeling --- --- > x -> "s.sign" --- > y0 -> "s.digit[-2]" --- > y1 -> "s.digit[-1]" --- > y2 -> "s.digit[0]" --- > y3 -> "s.digit[1]" --- --- Note that we could have also used the default labeling for the --- members of a list, but in this case, it was convenient to use a --- custom labeling. diff --git a/src/Quipper/Monad.hs b/src/Quipper/Monad.hs deleted file mode 100644 --- a/src/Quipper/Monad.hs +++ /dev/null @@ -1,1819 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module provides a high-level circuit building interface --- intended to look \"functional\". At a given time, there is a --- circuit being assembled. This circuit has free endpoints (on the --- left and right) that can be bound to variables. A qubit or bit is --- simply an endpoint in such a circuit. \"Applying\" an operation to --- a qubit or bit simply appends the operation to the current --- circuit. We use the 'Circ' monad to capture the side effect of --- assembling a circuit. - -module Quipper.Monad ( - -- * The ReadWrite monad - ReadWrite(..), - - -- * The Circ monad - Circ, - - -- * Some types - Qubit, - Bit, - Endpoint, - Signed(..), -- re-exported from Quipper.Circuit - Ctrl, - Qulist, - Bitlist, - Timestep, -- re-exported from Quipper.Circuit - InverseFlag, -- re-exported from Quipper.Circuit - - -- * Conversions for wires, qubits, bits, endpoints - wire_of_qubit, - wire_of_bit, - wire_of_endpoint, - wires_with_arity_of_endpoints, - qubit_of_wire, - bit_of_wire, - endpoint_of_wire, - endpoints_of_wires_in_arity, - - -- * Bindings for qubits and bits - bind_qubit, - bind_bit, - unbind_qubit, - unbind_bit, - - -- * Controls for qubits and bits - clist_add_qubit, - clist_add_bit, - - -- * Namespace management - provide_simple_subroutine, - provide_subroutine, - provide_subroutines, - call_subroutine, - get_namespace, - set_namespace, - - put_subroutine_definition, - - -- * Basic gates - -- ** Gates in functional style - qnot, - hadamard, - gate_H, - gate_X, - gate_Y, - gate_Z, - gate_S, - gate_S_inv, - gate_T, - gate_T_inv, - gate_E, - gate_E_inv, - gate_omega, - gate_V, - gate_V_inv, - swap_qubit, - expZt, - rGate, - gate_W, - gate_iX, - gate_iX_inv, - global_phase, - global_phase_anchored_list, - qmultinot_list, - cmultinot_list, - named_gate_qulist, - named_rotation_qulist, - cnot, - swap_bit, - -- ** Gates in imperative style - qnot_at, - hadamard_at, - gate_H_at, - gate_X_at, - gate_Y_at, - gate_Z_at, - gate_S_at, - gate_S_inv_at, - gate_T_at, - gate_T_inv_at, - gate_E_at, - gate_E_inv_at, - gate_omega_at, - gate_V_at, - gate_V_inv_at, - swap_qubit_at, - expZt_at, - rGate_at, - gate_W_at, - gate_iX_at, - gate_iX_inv_at, - qmultinot_list_at, - cmultinot_list_at, - named_gate_qulist_at, - named_rotation_qulist_at, - cnot_at, - swap_bit_at, - -- ** Bitwise initialization and termination functions - qinit_qubit, - qterm_qubit, - qdiscard_qubit, - prepare_qubit, - unprepare_qubit, - measure_qubit, - cinit_bit, - cterm_bit, - cdiscard_bit, - dterm_bit, - - -- ** Classical gates - -- $CLASSICAL - cgate_xor, - cgate_eq, - cgate_if_bit, - cgate_not, - cgate_and, - cgate_or, - cgate, - cgateinv, - - -- ** Subroutines - subroutine, - - -- ** Comments - comment_label, - without_comments, - - -- ** Dynamic lifting - dynamic_lift_bit, - - -- * Other circuit-building functions - qinit_plusminus, - qinit_of_char, - qinit_of_string, - qinit_list, - qterm_list, - cinit_list, - - -- * Higher-order functions - with_ancilla, - with_controls, - controlled, - without_controls, - without_controls_if, - - -- ** Deprecated special cases - qinit_qubit_ancilla, - qterm_qubit_ancilla, - - -- * Circuit transformers - identity_transformer, - identity_dynamic_transformer, - apply_circuit_with_bindings, - apply_bcircuit_with_bindings, - apply_dbcircuit_with_bindings, - - -- * Encapsulated circuits - extract_simple, - extract_general, - extract_in_context, - extract_in_current_namespace, - unextract_in_context, - reverse_encapsulated, - with_reserve -) where - --- import other Quipper stuff -import Quipper.Circuit -import Libraries.Auxiliary -import Quipper.Transformer -import Quipper.Control - --- import other stuff -import Control.Monad -import Data.Typeable - -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet - -import Control.Applicative (Applicative(..)) -import Control.Monad (liftM, ap) - --- ====================================================================== --- * The Circ monad - --- ---------------------------------------------------------------------- --- ** States - --- | A flag to indicate whether comments are disabled ('True') or --- enabled ('False'). -type NoCommentFlag = Bool - --- | Holds the state during circuit construction. Currently this has --- four components: the output arity of the circuit currently being --- assembled, the current 'Namespace', the currently active --- 'ControlList' and 'NoControlFlag', and a flag to determine whether --- comments are disabled. All gates that are appended will have the --- controls from the 'ControlList' added to them. -data State = State { - arity :: !ExtArity, - namespace :: !Namespace, - clist :: !ControlList, - ncflag :: !NoControlFlag, - nocommentflag :: !NoCommentFlag -} - --- | Return a completely empty state, suitable to be the starting --- state for circuit construction. -empty_state :: State -empty_state = State { - arity = arity_empty, - namespace = namespace_empty, - clist = clist_empty, - ncflag = False, - nocommentflag = False - } - --- | Prepare an initial state from the given extended arity. -initial_state :: ExtArity -> State -initial_state arity = empty_state { arity = arity } - --- ---------------------------------------------------------------------- --- ** Definition of Circ - --- $ The 'Circ' monad is a 'ReadWrite' monad, wrapped with an --- additional state. - --- | The 'Circ' monad encapsulates the type of quantum operations. For --- example, a quantum operation that inputs two 'Qubit's and outputs a --- 'Qubit' and a 'Bit' has the following type: --- --- > (Qubit, Qubit) -> Circ (Qubit, Bit) - --- Implementation note: we could have equivalently defined 'Circ' --- using Haskell's 'StateT' monad transformer, like this: --- --- > Circ = StateT State ReadWrite. --- --- But it seems clearer, and certainly more self-contained, to write --- out the monad laws explicitly. Moreover, 'Circ' will probably look --- better in error messages than 'StateT' 'State' 'ReadWrite'. - -newtype Circ a = Circ { getCirc :: State -> ReadWrite (a, State) } - -instance Monad Circ where - return a = Circ (\s -> return (a, s)) - f >>= g = Circ h - where - h s0 = do - (a, s1) <- getCirc f s0 - getCirc (g a) s1 - --- every monad is applicative, and so is this one -instance Applicative Circ where - pure = return - (<*>) = ap - --- every monad is a functor, and so is this one -instance Functor Circ where - fmap = liftM - --- ====================================================================== --- ** Monad access primitives - --- $ Developer note: the 5 functions in this section are the /only/ --- operations that are permitted to access the monad internals (i.e., --- 'Circ' and 'getCirc') directly. - --- | Get the 'Circ' monad's state. -get_state :: Circ State -get_state = Circ $ \s -> return (s, s) - --- | Set the 'Circ' monad's state. -set_state :: State -> Circ () -set_state s = Circ $ \t -> return ((), s) - --- | Pass a gate to the 'Circ' monad. Note that this is a low-level --- monad access function, and does not update other parts of the --- monad's data. For a higher-level function, see 'apply_gate'. -put_gate :: Gate -> Circ () -put_gate g = Circ $ \s -> RW_Write g (return ((), s)) - --- | Issue a prompt and receive a reply. -do_read :: Wire -> Circ Bool -do_read w = Circ $ \s -> RW_Read w (\bool -> return (bool, s)) - --- | Issue a RW_Subroutine primitive -put_subroutine_definition :: BoxId -> TypedSubroutine -> Circ () -put_subroutine_definition name subroutine = Circ $ \s -> RW_Subroutine name subroutine (return ((), s)) - --- | This is the universal \"run\" function for the 'Circ' monad. It --- takes as parameters a 'Circ' computation, and an initial state. It --- outputs 'ReadWrite' computation for the result of the 'Circ' --- computation and the final state. -run_circ :: Circ a -> State -> ReadWrite (a, State) -run_circ = getCirc - --- ---------------------------------------------------------------------- --- ** Low-level state manipulation - --- $ The functions in this section are the /only/ operations that are --- permitted to operate on states directly (i.e., to use 'get_state' --- and 'set_state'). All other code in this module should access the --- state using these abstractions. Code in other modules can't access --- the state at all, but should use exported functions (and preferably --- 'QShape.encapsulate_generic') when it is necessary to extract --- low-level circuits. - --- | Get the 'arity' part of the 'Circ' monad's state. -get_arity :: Circ ExtArity -get_arity = do - s <- get_state - return (arity s) - --- | Set the 'arity' part of the 'Circ' monad's state. -set_arity :: ExtArity -> Circ () -set_arity arity = do - s <- get_state - set_state s { arity = arity } - --- | Get the 'namespace' part of the 'Circ' monad's state. -get_namespace :: Circ Namespace -get_namespace = do - s <- get_state - return (namespace s) - --- | Set the 'namespace' part of the 'Circ' monad's state. -set_namespace :: Namespace -> Circ () -set_namespace namespace = do - s <- get_state - set_state s { namespace = namespace } - --- | Get the 'clist' part of the 'Circ' monad's state. -get_clist :: Circ ControlList -get_clist = do - s <- get_state - return (clist s) - --- | Set the 'clist' part of the 'Circ' monad's state. -set_clist :: ControlList -> Circ () -set_clist clist = do - s <- get_state - set_state s { clist = clist } - --- | Get the 'ncflag' part of the 'Circ' monad's state. -get_ncflag :: Circ NoControlFlag -get_ncflag = do - s <- get_state - return (ncflag s) - --- | Set the 'ncflag' part of the 'Circ' monad's state. -set_ncflag :: NoControlFlag -> Circ () -set_ncflag ncflag = do - s <- get_state - set_state s { ncflag = ncflag } - --- | Get the 'nocommentflag' part of the 'Circ' monad's state. -get_nocommentflag :: Circ NoCommentFlag -get_nocommentflag = do - s <- get_state - return (nocommentflag s) - --- | Set the 'nocommentflag' part of the 'Circ' monad's state. -set_nocommentflag :: NoCommentFlag -> Circ () -set_nocommentflag nocommentflag = do - s <- get_state - set_state s { nocommentflag = nocommentflag } - --- ---------------------------------------------------------------------- --- ** Circuit extraction - --- | Extract a circuit from a monadic term, starting from the given --- arity. This is the \"simple\" extract function, which does not --- allow dynamic lifting. The 'ErrMsg' argument is a stub error message --- to be used in case an illegal operation is encountered. -extract_simple :: ErrMsg -> ExtArity -> Circ a -> (BCircuit, a) -extract_simple e arity f = (bcirc, y) where - comp = extract_general arity f - (bcirc, y) = bcircuit_of_static_dbcircuit e comp - - --- | Run a monadic term in the initial arity, and extract a dynamic --- boxed circuit. -extract_general :: ExtArity -> Circ a -> DBCircuit a -extract_general arity_in f = (a0, mmap finalize comp) where - a0 = arity_of_extarity arity_in - s0 = initial_state arity_in - comp = run_circ f s0 - finalize (a, s1) = (a1, n, a) where - arity_out = arity s1 - a1 = arity_of_extarity arity_out - n = n_of_extarity arity_out - --- ====================================================================== --- * Some types - --- | The type of qubits. -newtype Qubit = QubitWire Wire - deriving (Show, Eq, Ord, Typeable) - --- | The type of run-time classical bits (i.e., boolean wires in a --- circuit). -newtype Bit = BitWire Wire - deriving (Show, Eq, Ord, Typeable) - --- | An endpoint in a circuit. This is either a 'Qubit' or a 'Bit'. -type Endpoint = B_Endpoint Qubit Bit - --- | A control consists of an 'Endpoint' and a boolean ('True' = --- perform gate when control wire is 1; 'False' = perform gate when --- control wire is 0). Note that gates can be controlled by qubits and --- classical bits. -type Ctrl = Signed Endpoint - --- | Synonym for a qubit list, for convenience. -type Qulist = [Qubit] - --- | Synonym for a bit list, for convenience. -type Bitlist = [Bit] - --- ---------------------------------------------------------------------- --- * Conversions for wires, qubits, bits, endpoints - --- | Extract the underlying low-level wire of a qubit. -wire_of_qubit :: Qubit -> Wire -wire_of_qubit (QubitWire w) = w - --- | Extract the underlying low-level wire of a bit. -wire_of_bit :: Bit -> Wire -wire_of_bit (BitWire w) = w - --- | Construct a qubit from a wire. -qubit_of_wire :: Wire -> Qubit -qubit_of_wire w = QubitWire w - --- | Construct a bit from a wire. -bit_of_wire :: Wire -> Bit -bit_of_wire w = BitWire w - --- | Extract the underlying low-level 'Wire' of an 'Endpoint'. -wire_of_endpoint :: Endpoint -> Wire -wire_of_endpoint (Endpoint_Qubit q) = wire_of_qubit q -wire_of_endpoint (Endpoint_Bit b) = wire_of_bit b - --- | Extract the underlying low-level 'Wiretype' of an 'Endpoint'. -wiretype_of_endpoint :: Endpoint -> Wiretype -wiretype_of_endpoint (Endpoint_Qubit _) = Qbit -wiretype_of_endpoint (Endpoint_Bit _) = Cbit - --- | Break a list of 'Endpoint's down into a list of 'Wire's together with an 'Arity'. --- (Partial inverse to 'endpoints_of_wires_in_arity'.) -wires_with_arity_of_endpoints :: [Endpoint] -> ([Wire],Arity) -wires_with_arity_of_endpoints es = - let ws_with_ts = map (\e -> (wire_of_endpoint e, wiretype_of_endpoint e)) es - in (map fst ws_with_ts, IntMap.fromList ws_with_ts) - --- | Create an 'Endpoint' from a low-level 'Wire' and 'Wiretype'. -endpoint_of_wire :: Wire -> Wiretype -> Endpoint -endpoint_of_wire w Qbit = Endpoint_Qubit (qubit_of_wire w) -endpoint_of_wire w Cbit = Endpoint_Bit (bit_of_wire w) - --- | Create a list of 'Endpoint's from a list of 'Wire's together with an 'Arity', --- assuming all wires are present in the arity. -endpoints_of_wires_in_arity :: Arity -> [Wire] -> [Endpoint] -endpoints_of_wires_in_arity a = map (\w -> endpoint_of_wire w (a IntMap.! w)) - --- ---------------------------------------------------------------------- --- * Bindings for qubits and bits - --- | Bind a qubit wire to a value, and add it to the given bindings. -bind_qubit :: Qubit -> a -> Bindings a b -> Bindings a b -bind_qubit q x bindings = bind_qubit_wire (wire_of_qubit q) x bindings - --- | Bind a bit wire to a value, and add it to the given bindings. -bind_bit :: Bit -> b -> Bindings a b -> Bindings a b -bind_bit c x bindings = bind_bit_wire (wire_of_bit c) x bindings - --- | Retrieve the value of a qubit wire from the given bindings. --- Throws an error if the wire was bound to a classical bit. -unbind_qubit :: Bindings a b -> Qubit -> a -unbind_qubit bindings q = unbind_qubit_wire bindings (wire_of_qubit q) - --- | Retrieve the value of a bit wire from the given bindings. Throws --- an error if the wire was bound to a qubit. -unbind_bit :: Bindings a b -> Bit -> b -unbind_bit bindings c = unbind_bit_wire bindings (wire_of_bit c) - --- ---------------------------------------------------------------------- --- * Controls for qubits and bits - --- | Add a single signed qubit as a control to a control list. -clist_add_qubit :: Qubit -> Bool -> ControlList -> ControlList -clist_add_qubit q b cl = clist_add (wire_of_qubit q) b cl - --- | Add a single signed bit as a control to a control list. -clist_add_bit :: Bit -> Bool -> ControlList -> ControlList -clist_add_bit c b cl = clist_add (wire_of_bit c) b cl - -instance (ControlSource (Signed a), ControlSource (Signed b)) => ControlSource (Signed (B_Endpoint a b)) where - to_control (Signed (Endpoint_Qubit q) b) = to_control (Signed q b) - to_control (Signed (Endpoint_Bit c) b) = to_control (Signed c b) - -instance (ControlSource a, ControlSource b) => ControlSource (B_Endpoint a b) where - to_control (Endpoint_Qubit q) = to_control q - to_control (Endpoint_Bit c) = to_control c - -instance ControlSource (Signed Qubit) where - to_control (Signed q b) = to_control (Signed (wire_of_qubit q) b) - -instance ControlSource Qubit where - to_control q = to_control (Signed q True) - -instance ControlSource (Signed Bit) where - to_control (Signed q b) = to_control (Signed (wire_of_bit q) b) - -instance ControlSource Bit where - to_control q = to_control (Signed q True) - --- ====================================================================== --- * Namespace management - --- | @'provideSimpleSubroutine' name circ in_struct out_struct is_classically_controllable@: --- if /name/ not already bound, binds it to /circ/. --- Note: when there’s an existing value, does /not/ check that --- it’s equal to /circ/. -provide_simple_subroutine :: (Typeable a, Typeable b) => - BoxId -> OCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ () -provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable = do - s <- get_namespace - let OCircuit (win, circ, wout) = ocirc - let c = if controllable_circuit circ then AllCtl else if is_classically_controllable then OnlyClassicalCtl else NoCtl - let typed_subroutine = TypedSubroutine ocirc input_structure output_structure c - let s' = map_provide name typed_subroutine s - set_namespace s' - put_subroutine_definition name typed_subroutine - --- | @'provideSubroutines' namespace@: --- Add each subroutine from the /namespace/ to the current circuit, --- unless a subroutine of that name already exists. -provide_subroutines :: Namespace -> Circ () -provide_subroutines state = do - main_state <- get_namespace - let state1 = Map.union main_state state - set_namespace state1 - let new_subs = Map.difference state main_state -- returns subroutines that are in state, but not main_state - mapM_ (\(n,s) -> put_subroutine_definition n s) (Map.toList new_subs) -- puts a RW_Subroutine for each new subroutine definition - --- | @'provideSubroutine' name circ@: --- if /name/ not already bound, binds it to the main circuit of /circ/, --- and additionally provides any missing subroutines of /circ/. -provide_subroutine :: (Typeable a, Typeable b) => - BoxId -> OBCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ () -provide_subroutine name obcirc input_structure output_structure is_classically_controllable = do - main_state <- get_namespace - let (ocirc,subsubroutines) = obcirc - if Map.member name main_state - then return () - else do - provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable - provide_subroutines subsubroutines - --- ---------------------------------------------------------------------- --- * General gate - --- | Apply the specified low-level gate to the current circuit, using --- the current controls, and updating the monad state accordingly. --- This includes run-time well-formedness checks. This is a helper --- function and is not directly accessible by user code. -apply_gate :: Gate -> Circ () -apply_gate gate = do - arity <- get_arity - clist <- get_clist - ncflag <- get_ncflag - let gate' = gate_with_ncflag ncflag gate - let gate'' = control_gate clist gate' - case gate'' of - Nothing -> return () - Just g -> do - let arity' = arity_append g arity - put_gate g - set_arity arity' - return () - --- ====================================================================== --- * Basic gates - --- ---------------------------------------------------------------------- --- ** Gates in functional style - --- | Apply a NOT gate to a qubit. -qnot :: Qubit -> Circ Qubit -qnot q = do - named_gate_qulist "not" False [q] [] - return q - --- | Apply a Hadamard gate. -hadamard :: Qubit -> Circ Qubit -hadamard q = do - named_gate_qulist "H" False [q] [] - return q - --- | An alternate name for the Hadamard gate. -gate_H :: Qubit -> Circ Qubit -gate_H = hadamard - --- | Apply a multiple-not gate, as specified by a list of booleans and --- qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies --- a not gate to /q1/ and /q3/, but not to /q2/. -qmultinot_list :: [(Qubit, Bool)] -> Circ [Qubit] -qmultinot_list qbs = do - let qs = map fst $ filter snd qbs - named_gate_qulist "multinot" False qs [] - return (map fst qbs) - --- | Like 'qmultinot_list', but applies to classical bits instead of --- qubits. -cmultinot_list :: [(Bit, Bool)] -> Circ [Bit] -cmultinot_list cs = do - let ws = map (wire_of_bit . fst) $ filter snd cs - sequence_ [ apply_gate (CNot w [] False) | w <- ws ] - return (map fst cs) - --- | Apply a Pauli /X/ gate. -gate_X :: Qubit -> Circ Qubit -gate_X q = do - named_gate_qulist "X" False [q] [] - return q - --- | Apply a Pauli /Y/ gate. -gate_Y :: Qubit -> Circ Qubit -gate_Y q = do - named_gate_qulist "Y" False [q] [] - return q - --- | Apply a Pauli /Z/ gate. -gate_Z :: Qubit -> Circ Qubit -gate_Z q = do - named_gate_qulist "Z" False [q] [] - return q - --- | Apply a Clifford /S/-gate. -gate_S :: Qubit -> Circ Qubit -gate_S q = do - named_gate_qulist "S" False [q] [] - return q - --- | Apply the inverse of an /S/-gate. -gate_S_inv :: Qubit -> Circ Qubit -gate_S_inv q = do - named_gate_qulist "S" True [q] [] - return q - --- | Apply a /T/ = √/S/ gate. -gate_T :: Qubit -> Circ Qubit -gate_T q = do - named_gate_qulist "T" False [q] [] - return q - --- | Apply the inverse of a /T/-gate. -gate_T_inv :: Qubit -> Circ Qubit -gate_T_inv q = do - named_gate_qulist "T" True [q] [] - return q - --- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. --- --- \[image E.png] --- --- This gate is the unique Clifford operator with the properties /E/³ --- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a --- convenient gate for calculations. For example, every Clifford --- operator can be uniquely written of the form --- --- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/], --- --- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8, --- respectively. -gate_E :: Qubit -> Circ Qubit -gate_E q = do - named_gate_qulist "E" False [q] [] - return q - --- | Apply the inverse of an /E/-gate. -gate_E_inv :: Qubit -> Circ Qubit -gate_E_inv q = do - named_gate_qulist "E" True [q] [] - return q - --- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate. -gate_omega :: Qubit -> Circ Qubit -gate_omega q = do - named_gate_qulist "omega" False [q] [] - return q - --- | Apply a /V/ = √/X/ gate. This is by definition the following gate --- (see also Nielsen and Chuang, p.182): --- --- \[image V.png] -gate_V :: Qubit -> Circ Qubit -gate_V q = do - named_gate_qulist "V" False [q] [] - return q - --- | Apply the inverse of a /V/-gate. -gate_V_inv :: Qubit -> Circ Qubit -gate_V_inv q = do - named_gate_qulist "V" True [q] [] - return q - --- | Apply a SWAP gate. -swap_qubit :: Qubit -> Qubit -> Circ (Qubit,Qubit) -swap_qubit q1 q2 = do - named_gate_qulist "swap" False [q1, q2] [] - return (q1,q2) - --- | Apply a classical SWAP gate. -swap_bit :: Bit -> Bit -> Circ (Bit,Bit) -swap_bit c1 c2 = do - apply_gate (CSwap (wire_of_bit c1) (wire_of_bit c2) [] False) - return (c1,c2) - --- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter. -expZt :: Timestep -> Qubit -> Circ Qubit -expZt t q = do - named_rotation_qulist "exp(-i%Z)" False t [q] [] - return q - --- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis. --- --- \[image rGate.png] -rGate :: Int -> Qubit -> Circ Qubit -rGate n q = do - named_rotation_qulist "R(2pi/%)" False (2^n) [q] [] - return q - --- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes --- the SWAP gate. --- --- \[image W.png] --- --- The arguments are such that --- --- > gate_W |0〉 |0〉 = |00〉 --- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2 --- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2 --- > gate_W |1〉 |1〉 = |11〉. --- --- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2] --- denotes the \"right\" qubit. -gate_W :: Qubit -> Qubit -> Circ (Qubit, Qubit) -gate_W q1 q2 = do - named_gate_qulist "W" False [q1, q2] [] - return (q1, q2) - --- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/ --- gate, but with two advantages: --- --- * the doubly-controlled /iX/ gate can be implemented in the --- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/ --- gate requires /T/-count 7); --- --- * the /iX/-gate has determinant 1, and therefore an /n/-times --- controlled /iX/ gate can be implemented in the Clifford+/T/ gate --- base with no ancillas. --- --- In particular, the /iX/ gate can be used to implement an additional --- control with /T/-count 8, like this: --- --- \[image iX.png] -gate_iX :: Qubit -> Circ Qubit -gate_iX q = do - named_gate_qulist "iX" False [q] [] - return q - --- | Apply a −/iX/ gate. This is the inverse of 'gate_iX'. -gate_iX_inv :: Qubit -> Circ Qubit -gate_iX_inv q = do - named_gate_qulist "iX" True [q] [] - return q - --- | Apply a global phase change [exp /i/π/t/], where typically /t/ ∈ --- [0,2]. This gate is uninteresting if not controlled; however, it --- has non-trivial effect if it is used as a controlled gate. -global_phase :: Double -> Circ () -global_phase t = do - apply_gate (GPhase t [] [] False) - return () - --- | Like 'global_phase', except the gate is also \"anchored\" at a --- particular bit or qubit. This is strictly for graphical --- presentation purposes, to provide a hint for where the gate should --- be printed in a circuit diagram. Backends are free to ignore this --- hint altogether. The anchor is not actually an input to the gate, --- and it is legal for the anchoring qubit to also be used as a --- control control. -global_phase_anchored_list :: Double -> [Endpoint] -> Circ () -global_phase_anchored_list t qs = do - apply_gate (GPhase t (map wire_of_endpoint qs) [] False) - return () - --- | Apply a generic quantum gate to a given list of qubits and a --- given list of generalized controls. The generalized controls are --- really inputs to the gate, but are guaranteed not to be modified --- if they are in a computational basis state. -named_gate_qulist :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) -named_gate_qulist name inv operands gencontrols = do - apply_gate (QGate name inv (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False) - return (operands, gencontrols) - --- | Like 'named_gate_qulist', but produce a named gate that also --- depends on a real parameter. This is typically used for rotations --- or phase gates parameterized by an angle. The name can contain --- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@. -named_rotation_qulist :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit]) -named_rotation_qulist name inv theta operands gencontrols = do - apply_gate (QRot name inv theta (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False) - return (operands, gencontrols) - --- | Apply a NOT gate to a classical bit. -cnot :: Bit -> Circ Bit -cnot b = do - apply_gate (CNot (wire_of_bit b) [] False) - return b - --- ---------------------------------------------------------------------- --- ** Gates in imperative style - --- | Apply a NOT gate to a qubit. -qnot_at :: Qubit -> Circ () -qnot_at q = do - qnot q - return () - --- | Apply a Hadamard gate. -hadamard_at :: Qubit -> Circ () -hadamard_at q = do - hadamard q - return () - --- | An alternate name for the Hadamard gate. -gate_H_at :: Qubit -> Circ () -gate_H_at = hadamard_at - --- | Apply a /qmultinot_list/ gate, as specified by a list of booleans and --- qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies --- a not gate to /q1/ and /q3/, but not to /q2/. -qmultinot_list_at :: [(Qubit, Bool)] -> Circ () -qmultinot_list_at qs = do - qmultinot_list qs - return () - --- | Like 'qmultinot_list_at', but applies to classical bits instead of --- qubits. -cmultinot_list_at :: [(Bit, Bool)] -> Circ () -cmultinot_list_at cs = do - cmultinot_list cs - return () - --- | Apply a Pauli /X/ gate. -gate_X_at :: Qubit -> Circ () -gate_X_at q = do - gate_X q - return () - --- | Apply a Pauli /Y/ gate. -gate_Y_at :: Qubit -> Circ () -gate_Y_at q = do - gate_Y q - return () - --- | Apply a Pauli /Z/ gate. -gate_Z_at :: Qubit -> Circ () -gate_Z_at q = do - gate_Z q - return () - --- | Apply a Clifford /S/-gate. -gate_S_at :: Qubit -> Circ () -gate_S_at q = do - gate_S q - return () - --- | Apply the inverse of an /S/-gate. -gate_S_inv_at :: Qubit -> Circ () -gate_S_inv_at q = do - gate_S_inv q - return () - --- | Apply a /T/ = √/S/ gate. -gate_T_at :: Qubit -> Circ () -gate_T_at q = do - gate_T q - return () - --- | Apply the inverse of a /T/-gate. -gate_T_inv_at :: Qubit -> Circ () -gate_T_inv_at q = do - gate_T_inv q - return () - --- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. --- --- \[image E.png] --- --- This gate is the unique Clifford operator with the properties /E/³ --- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a --- convenient gate for calculations. For example, every Clifford --- operator can be uniquely written of the form --- --- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/], --- --- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8, --- respectively. -gate_E_at :: Qubit -> Circ () -gate_E_at q = do - gate_E q - return () - --- | Apply the inverse of an /E/-gate. -gate_E_inv_at :: Qubit -> Circ () -gate_E_inv_at q = do - gate_E_inv q - return () - --- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate. -gate_omega_at :: Qubit -> Circ () -gate_omega_at q = do - gate_omega q - return () - --- | Apply a /V/ = √/X/ gate. This is by definition the following gate --- (see also Nielsen and Chuang, p.182): --- --- \[image V.png] -gate_V_at :: Qubit -> Circ () -gate_V_at q = do - gate_V q - return () - --- | Apply the inverse of a /V/-gate. -gate_V_inv_at :: Qubit -> Circ () -gate_V_inv_at q = do - gate_V_inv q - return () - --- | Apply a SWAP gate. -swap_qubit_at :: Qubit -> Qubit -> Circ () -swap_qubit_at q1 q2 = do - swap_qubit q1 q2 - return () - --- | Apply a classical SWAP gate. -swap_bit_at :: Bit -> Bit -> Circ () -swap_bit_at c1 c2 = do - swap_bit c1 c2 - return () - --- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter. -expZt_at :: Timestep -> Qubit -> Circ () -expZt_at t q = do - expZt t q - return () - --- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis. --- --- \[image rGate.png] -rGate_at :: Int -> Qubit -> Circ () -rGate_at n q = do - rGate n q - return () - --- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes --- the SWAP gate. --- --- \[image W.png] --- --- The arguments are such that --- --- > gate_W |0〉 |0〉 = |00〉 --- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2 --- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2 --- > gate_W |1〉 |1〉 = |11〉. --- --- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2] --- denotes the \"right\" qubit. -gate_W_at :: Qubit -> Qubit -> Circ () -gate_W_at q1 q2 = do - gate_W q1 q2 - return () - --- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/ --- gate, but with two advantages: --- --- * the doubly-controlled /iX/ gate can be implemented in the --- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/ --- gate requires /T/-count 7); --- --- * the /iX/-gate has determinant 1, and therefore an /n/-times --- controlled /iX/ gate can be implemented in the Clifford+/T/ gate --- base with no ancillas. --- --- In particular, the /iX/ gate can be used to implement an additional --- control with /T/-count 8, like this: --- --- \[image iX.png] -gate_iX_at :: Qubit -> Circ () -gate_iX_at q = do - gate_iX q - return () - --- | Apply a −/iX/ gate. This is the inverse of 'gate_iX_at'. -gate_iX_inv_at :: Qubit -> Circ () -gate_iX_inv_at q = do - gate_iX_inv q - return () - --- | Apply a generic quantum gate to a given list of qubits and a --- given list of generalized controls. The generalized controls are --- really inputs to the gate, but are guaranteed not to be modified --- if they are in a computational basis state. -named_gate_qulist_at :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ () -named_gate_qulist_at name inv operands gencontrols = do - named_gate_qulist name inv operands gencontrols - return () - --- | Like 'named_gate_qulist_at', but produce a named gate that also --- depends on a real parameter. This is typically used for rotations --- or phase gates parameterized by an angle. The name can contain --- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@. -named_rotation_qulist_at :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ () -named_rotation_qulist_at name inv t operands gencontrols = do - named_rotation_qulist name inv t operands gencontrols - return () - --- | Apply a NOT gate to a classical bit. -cnot_at :: Bit -> Circ () -cnot_at b = do - cnot b - return () - --- ---------------------------------------------------------------------- --- ** Bitwise initialization and termination functions - --- | Generate a new qubit, initialized to the parameter 'Bool'. -qinit_qubit :: Bool -> Circ Qubit -qinit_qubit b = do - arity <- get_arity - let w = arity_unused_wire arity - apply_gate (QInit b w False) - return (qubit_of_wire w) - --- | Terminate a qubit asserted to be in state /b/. --- --- We note that the assertion is relative to the precision: when gates --- in a circuit are implemented up to some precision ε (either due to --- physical limitations, or due to decomposition into a discrete gate --- base), the assertion may only hold up to a corresponding precision --- as well. -qterm_qubit :: Bool -> Qubit -> Circ () -qterm_qubit b q = do - apply_gate (QTerm b (wire_of_qubit q) False) - return () - --- | Discard a qubit destructively. -qdiscard_qubit :: Qubit -> Circ () -qdiscard_qubit q = do - apply_gate (QDiscard (wire_of_qubit q)) - return () - --- | Generate a new qubit, initialized from a classical bit. Note that --- the classical bit is simultaneously terminated. -prepare_qubit :: Bit -> Circ Qubit -prepare_qubit c = do - let w = wire_of_bit c - apply_gate (QPrep w False) - return (qubit_of_wire w) - --- | Unprepare a qubit asserted to be in a computational basis --- state. This is the same as a measurement, but must only be applied --- to qubits that are already known to be in one of the states |0〉 or --- |1〉, and not in superposition. This operation is rarely (perhaps --- never?) used in any quantum algorithms, but we include it for --- consistency reasons, because it is formally the inverse of --- 'prepare_qubit'. -unprepare_qubit :: Qubit -> Circ Bit -unprepare_qubit q = do - let w = wire_of_qubit q - apply_gate (QUnprep w False) - return (bit_of_wire w) - --- | Apply a measurement gate (turns a qubit into a bit). -measure_qubit :: Qubit -> Circ Bit -measure_qubit q = do - let w = wire_of_qubit q - apply_gate (QMeas w) - return (bit_of_wire w) - --- | Generate a new classical bit, initialized to a boolean parameter --- /b/. -cinit_bit :: Bool -> Circ Bit -cinit_bit b = do - arity <- get_arity - let w = arity_unused_wire arity - apply_gate (CInit b w False) - return (bit_of_wire w) - --- | Terminate a classical 'Bit' asserted to be in state 'Bool'. -cterm_bit :: Bool -> Bit -> Circ () -cterm_bit b c = do - let w = wire_of_bit c - apply_gate (CTerm b w False) - return () - --- | Terminate a classical 'Bit' with a comment indicating what the --- observed state of the 'Bit' was, in this particular dynamic run of --- the circuit. This is typically used to terminate a wire right after --- a dynamic lifting has been performed. It is not intended to be a --- user-level operation. --- --- It is important to note that a 'DTerm' gate does not, in any way, --- represent an assertion. Unlike a 'CTerm' gate, which asserts that --- the classical bit will have the stated value at /every/ run of the --- circuit, the 'DTerm' gate simply records that the classical bit had --- the stated value at some /particular/ run of the circuit. --- --- Operationally (e.g., in a simulator), the 'DTerm' gate can be --- interpreted in multiple ways. In the simplest case, it is just --- treated like a 'CDiscard' gate, and the boolean comment --- ignored. Alternatively, it can be treated as a post-selection gate: --- if the actual value does not equal the stated value, the entire --- computation is aborted. Normally, 'DTerm' gates should appear in --- the /output/, not the /input/ of simulators; therefore, the details --- of the behavior of any particular simulator on a 'DTerm' gate are --- implementation dependent. -dterm_bit :: Bool -> Bit -> Circ () -dterm_bit b c = do - let w = wire_of_bit c - apply_gate (DTerm b w) - return () - --- | Discard a classical bit destructively. -cdiscard_bit :: Bit -> Circ () -cdiscard_bit c = do - let w = wire_of_bit c - apply_gate (CDiscard w) - return () - --- ---------------------------------------------------------------------- --- ** Classical gates - --- $CLASSICAL --- --- The gates in this section are for constructing classical circuits. --- None of these gates alter or discard their inputs; each gate produces --- a new wire holding the output of the gate. - --- | Return the \"exclusive or\" of a list of bits. -cgate_xor :: [Bit] -> Circ Bit -cgate_xor inputs = - cgate "xor" inputs - --- | Test equality of two bits, and return 'True' iff they are equal. -cgate_eq :: Bit -> Bit -> Circ Bit -cgate_eq a b = cgate "eq" [a,b] - --- | If /a/ is 'True', then return /b/, else return /c/. -cgate_if_bit :: Bit -> Bit -> Bit -> Circ Bit -cgate_if_bit a b c = cgate "if" [a,b,c] - --- | Return the negation of its input. Note that unlike 'cnot' or --- 'cnot_at', this gate does not alter its input, but returns a newly --- created bit. -cgate_not :: Bit -> Circ Bit -cgate_not a = cgate "not" [a] - --- | Return the conjunction of a list of bits. -cgate_and :: [Bit] -> Circ Bit -cgate_and inputs = cgate "and" inputs - --- | Return the disjunction of a list of bits. -cgate_or :: [Bit] -> Circ Bit -cgate_or inputs = cgate "or" inputs - --- | Apply a named classical gate. This is used to define all of the --- above classical gates, but should not usually be directly used by --- user code. -cgate :: String -> [Bit] -> Circ Bit -cgate name inputs = do - arity <- get_arity - let w = arity_unused_wire arity - apply_gate (CGate name w (map wire_of_bit inputs) False) - return (bit_of_wire w) - --- | @'cgateinv' name w inputs@: Uncompute a named classical --- gate. This asserts that /w/ is in the state determined by the gate --- type and the /inputs/, then uncomputes /w/ in a reversible --- way. This rarely used gate is formally the inverse of 'cgate'. -cgateinv :: String -> Bit -> [Bit] -> Circ () -cgateinv name c inputs = do - let w = wire_of_bit c - apply_gate (CGateInv name w (map wire_of_bit inputs) False) - return () - --- ---------------------------------------------------------------------- --- ** Subroutines - --- | Insert a subroutine gate with specified name, and input/output --- output types, and attach it to the given endpoints. Return the new --- endpoints. --- --- Note that the @['Wire']@ and 'Arity' arguments are used as a /pattern/ --- for the locations/types of wires of the subroutine; the @['Endpoint']@ --- argument (and output) specify what is attached in the current circuit. --- The two aspects of this pattern that are respected are: the --- lingeringness of any inputs; and the number and types of wires. --- --- For instance (assuming for simplicity that all wires are qubits), if --- the patterns given are “inputs [1,3,5], outputs [1,3,4]”, and the --- actual inputs specified are [20,21,25], then the output wires produced --- might be e.g. [20,21,23], [20,21,36], or [20,21,8], depending on the --- next available free wire. --- --- More subtly, if --- the patterns given are “inputs [1,2,3], outputs [3,7,8,1]”, --- and the inputs given are [10,5,4], then the outputs will be --- [4,/x/,/y/,10], where /x/, /y/ are two fresh wires. --- --- Note that lingering wires may change type, for e.g. subroutines that --- include measurements. --- --- It is currently assumed that all these lists are linear, i.e. contain --- no duplicates. -subroutine :: BoxId -> InverseFlag -> ControllableFlag - -> RepeatFlag -> [Wire] -> Arity -> [Wire] -> Arity - -> [Endpoint] -> Circ [Endpoint] -subroutine name inv scf rep win_pattern ain_pattern wout_pattern aout_pattern ein = do - let (win,ain) = wires_with_arity_of_endpoints ein - -- Check the given input wires match the pattern: - when (not $ all (\(w_p,w) -> ain_pattern IntMap.! w_p == ain IntMap.! w) $ zip_strict_errmsg win_pattern win e_num_inputs) $ do - error e_input_types - -- Work out which input wires are lingering, and how many new wires are needed: - let partial_wout = map (\w_p -> let maybe_w = lookup w_p (zip win_pattern win) - in (maybe_w, aout_pattern IntMap.! w_p)) - wout_pattern - num_new_wires = length $ filter ((== Nothing) . fst) partial_wout - -- Allocate new wires for the non-lingering outputs: - arity <- get_arity - let new_wires = arity_unused_wires num_new_wires arity - eout = insert_new_wires partial_wout new_wires - (wout,aout) = wires_with_arity_of_endpoints eout - apply_gate (Subroutine name inv win ain wout aout [] False scf rep) - return eout - where - insert_new_wires :: [(Maybe Wire, Wiretype)] -> [Wire] -> [Endpoint] - insert_new_wires ((Just w,t):ws) new_wires = (endpoint_of_wire w t):(insert_new_wires ws new_wires) - insert_new_wires ((Nothing,t):ws) (next_new:new_wires) = (endpoint_of_wire next_new t):(insert_new_wires ws new_wires) - insert_new_wires [] [] = [] - insert_new_wires _ _ = error e_output_allocation - e_num_inputs = "subroutine: subroutine " ++ show name ++ " applied to the wrong number of input wires" - e_input_types = "subroutine: subroutine " ++ show name ++ " applied to input wires of incorrect type" - e_output_allocation = "internal error: Quipper.Monad.subroutine: output wire allocation" - - --- | Look up the specified subroutine in the namespace, and apply it --- to the specified inputs, or throw an error if they are not appropriately --- typed. --- --- The input/output types of this function are determined dynamically --- by the 'CircuitTypeStructure' stored with the subroutine. -call_subroutine :: (Typeable a, Typeable b) => BoxId -> RepeatFlag -> a -> Circ b -call_subroutine name r x = do - ns <- get_namespace - let mc = Map.lookup name ns - case mc of - Nothing -> - error ("call_subroutine: subroutine " ++ show name ++ " does not exist in current namespace: " ++ showNames ns) - Just (TypedSubroutine ocircuit input_structure output_structure scf) -> do - let OCircuit (win_pattern, circuit, wout_pattern) = ocircuit - let (ain_pattern, gates, aout_pattern, n) = circuit - let (win, ain) = case cast input_structure of - Just suitable_input_structure -> destructure_with suitable_input_structure x - Nothing -> error ("call_subroutine: subroutine " ++ show name ++ " applied to input of incorrect type") - let ein = endpoints_of_wires_in_arity ain win - eout <- subroutine name False scf r win_pattern ain_pattern wout_pattern aout_pattern ein - let (wout, aout) = wires_with_arity_of_endpoints eout - - -- The output structure of the subroutine contains the wires - -- corresponding to the actual output type of the function and - -- the wires that were created but forgotten, in - -- imperative-style. (see comments in 'provide_subroutine_generic'). - let (y,_::([Qubit],[Bit])) = case cast output_structure of - Just suitable_output_structure -> structure_with suitable_output_structure (wout, aout) - Nothing -> error ("call_subroutine: attempt to use outputs of subroutine " ++ show name ++ " as incorrect type") - return y - --- ---------------------------------------------------------------------- --- ** Comments - --- | Insert a comment in the circuit. This is not a gate, and has no --- effect, except to mark a spot in the circuit. The comment has two --- parts: a string (possibly empty), and a list of labelled wires --- (possibly empty). This is a low-level function. Users should use --- 'comment' instead. -comment_label :: String -> InverseFlag -> [(Wire, String)] -> Circ () -comment_label s inv ws = do - b <- get_nocommentflag - when (not b) $ do - apply_gate (Comment s inv ws) - return () - --- | Disable labels and comments for a block of code. The intended --- usage is like this: --- --- > without_comments $ do { --- > <<>> --- > } --- --- 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 { --- > <<>> --- > } --- --- The ancilla will be initialized to |0〉 at the beginning of the --- block, and it is the programmer's responsibility to ensure that it --- will be returned to state |0〉 at the end of the block. --- --- A block created with 'with_ancilla' is controllable, provided that --- the body is controllable. -with_ancilla :: (Qubit -> Circ a) -> Circ a -with_ancilla f = do - q <- without_controls (qinit_qubit False) - a <- f q - without_controls (qterm_qubit False q) - return a - --- | A syntax for \"if\"-style (classical and quantum) controls. --- This can be used as follows: --- --- > gate1 --- > with_controls <> $ do { --- > gate2 --- > gate3 --- > } --- > gate4 --- --- The specified controls will be applied to gate2 and gate3. It is an --- error to specify a control for a gate that cannot be controlled --- (such as measurement). - -with_controls :: ControlSource c => c -> Circ a -> Circ a -with_controls control code = do - clist_old <- get_clist - set_clist (combine (to_control control) clist_old) - a <- code - set_clist clist_old - return a - --- | An infix operator to apply the given controls to a gate: --- --- > gate `controlled` <> --- --- It also works with functional-style gates: --- --- > result <- gate `controlled` <> --- --- The infix operator is left associative, so it can be applied --- multiple times: --- --- > result <- gate `controlled` <> `controlled` <> --- --- The latter is equivalent to --- --- > result <- gate `controlled` <> .&&. <> - -controlled :: ControlSource c => Circ a -> c -> Circ a -controlled code control = with_controls control code - -infixl 2 `controlled` - --- | Apply a block of gates while temporarily suspending the --- application of controls. This can be used to omit controls on --- gates where they are known to be unnecessary. This is a relatively --- low-level function and should not normally be called directly by --- user code. Instead, it is safer to use a higher-level function such --- as 'with_basis_change'. However, the 'without_controls' operator is --- useful in certain situations, e.g., it can be used to preserve the --- 'NoControlFlag' when defining transformers. --- --- Usage: --- --- > without_controls $ do --- > <> --- --- or: --- --- > without_controls (gate) --- --- Note that all controls specified in the /surrounding/ code are --- disabled within the 'without_controls' block. This is even true if --- the 'without_controls' block appears in a subroutine, and the --- subroutine is later called in a controlled context. On the other --- hand, it is possible to specify controls /inside/ the --- 'without_controls' block. Consider this example: --- --- > my_subcircuit = do --- > gate1 --- > without_controls $ do { --- > gate2 --- > gate3 `controlled` <> --- > } --- > gate4 --- > --- > my_circuit = do --- > my_subcircuit `controlled` <> --- --- In this example, controls 1 will be applied to gate 3, controls 2 --- will be applied to gates 1 and 4, and no controls will be applied --- to gate 2. -without_controls :: Circ a -> Circ a -without_controls code = do - clist_old <- get_clist - ncflag_old <- get_ncflag - set_clist clist_empty - set_ncflag True - a <- code - set_clist clist_old - set_ncflag ncflag_old - return a - --- | Apply 'without_controls' if 'NoControlFlag' is 'True', otherwise --- do nothing. -without_controls_if :: NoControlFlag -> Circ a -> Circ a -without_controls_if True = without_controls -without_controls_if False = id - --- ---------------------------------------------------------------------- --- ** Deprecated special cases of without_controls - --- | Generate a new qubit, initialized to the parameter 'Bool', that --- is guaranteed to be used as an ancilla and terminated with --- 'qterm_qubit_ancilla'. Deprecated. -qinit_qubit_ancilla :: Bool -> Circ Qubit -qinit_qubit_ancilla b = do - without_controls $ do - qinit_qubit b - --- | Terminate an ancilla asserted to be in state /b/. Deprecated. -qterm_qubit_ancilla :: Bool -> Qubit -> Circ () -qterm_qubit_ancilla b q = do - without_controls $ do - qterm_qubit b q - --- ====================================================================== --- * Circuit transformers - --- | The identity transformer. This just maps a low-level circuits to --- the corresponding circuit-generating function. It can also be used --- as a building block in other transformers, to define \"catch-all\" --- clauses for gates that don't need to be transformed. -identity_transformer :: Transformer Circ Qubit Bit -identity_transformer (T_QGate name _ _ inv ncf f) = f $ - \ws vs c -> without_controls_if ncf $ do - (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c - return (ws', vs', c) -identity_transformer (T_QRot name _ _ inv t ncf f) = f $ - \ws vs c -> without_controls_if ncf $ do - (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c - return (ws', vs', c) -identity_transformer (T_GPhase t ncf f) = f $ - \qs c -> without_controls_if ncf $ do - global_phase_anchored_list t qs `controlled` c - return c -identity_transformer (T_CNot ncf f) = f $ - \q c -> without_controls_if ncf $ do - q' <- cnot q `controlled` c - return (q', c) -identity_transformer (T_CGate name ncf f) = f $ - \ws -> without_controls_if ncf $ do - v <- cgate name ws - return (v, ws) -identity_transformer (T_CGateInv name ncf f) = f $ - \v ws -> without_controls_if ncf $ do - cgateinv name v ws - return ws -identity_transformer (T_CSwap ncf f) = f $ - \w v c -> without_controls_if ncf $ do - (w',v') <- swap_bit w v `controlled` c - return (w',v',c) -identity_transformer (T_QPrep ncf f) = f $ - \w -> without_controls_if ncf $ do - v <- prepare_qubit w - return v -identity_transformer (T_QUnprep ncf f) = f $ - \w -> without_controls_if ncf $ do - v <- unprepare_qubit w - return v -identity_transformer (T_QInit b ncf f) = f $ - without_controls_if ncf $ do - w <- qinit_qubit b - return w -identity_transformer (T_CInit b ncf f) = f $ - without_controls_if ncf $ do - w <- cinit_bit b - return w -identity_transformer (T_QTerm b ncf f) = f $ - \w -> without_controls_if ncf $ do - qterm_qubit b w - return () -identity_transformer (T_CTerm b ncf f) = f $ - \w -> without_controls_if ncf $ do - cterm_bit b w - return () -identity_transformer (T_QMeas f) = f $ - \w -> do - v <- measure_qubit w - return v -identity_transformer (T_QDiscard f) = f $ - \w -> do - qdiscard_qubit w - return () -identity_transformer (T_CDiscard f) = f $ - \w -> do - cdiscard_bit w - return () -identity_transformer (T_DTerm b f) = f $ - \w -> do - dterm_bit b w - return () -identity_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $ - \namespace ws c -> without_controls_if ncf $ do - provide_subroutines namespace - vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c - return (vs,c) -identity_transformer (T_Comment s inv f) = f $ - \ws -> do - comment_label s inv [ (wire_of_endpoint e, s) | (e,s) <- ws ] - return () - --- | The identity transformer can be enriched with a dynamic lifting operation, so --- as to define a DynamicTransformer -identity_dynamic_transformer_with_lift :: (Bit -> Circ Bool) -> DynamicTransformer Circ Qubit Bit -identity_dynamic_transformer_with_lift f = DT { - transformer = identity_transformer, - define_subroutine = \name typed_subroutine -> do - s <- get_namespace - let s' = map_provide name typed_subroutine s - set_namespace s' - put_subroutine_definition name typed_subroutine, - lifting_function = f - } - --- | The identity DynamicTransformer uses the built in do_read operation -identity_dynamic_transformer :: DynamicTransformer Circ Qubit Bit -identity_dynamic_transformer = - identity_dynamic_transformer_with_lift (\b -> do_read (wire_of_bit b)) - --- | We can define a dynamic transformer with a "constant" lifting function -identity_dynamic_transformer_constant :: Bool -> DynamicTransformer Circ Qubit Bit -identity_dynamic_transformer_constant b = identity_dynamic_transformer_with_lift (\_ -> return b) - --- | Append the entire circuit /c/ to the current circuit, using the --- given bindings. Return the new bindings. -apply_circuit_with_bindings :: Circuit -> (Bindings Qubit Bit) - -> Circ (Bindings Qubit Bit) -apply_circuit_with_bindings c bindings = - transform_circuit identity_transformer c bindings - --- | Append the entire circuit /c/ to the current circuit, using the --- given bindings, and return the new bindings. --- Also, add to the current namespace state any subroutines of /c/ --- that are not already provided. -apply_bcircuit_with_bindings :: BCircuit -> (Bindings Qubit Bit) - -> Circ (Bindings Qubit Bit) -apply_bcircuit_with_bindings (c,s) bindings = do - provide_subroutines s - apply_circuit_with_bindings c bindings - --- | Append the entire dynamic circuit /c/ to the current circuit, --- using the given bindings, and return the new bindings. Also, add --- to the current namespace state any subroutines of /c/ that are not --- already provided. -apply_dbcircuit_with_bindings :: DBCircuit a -> Bindings Qubit Bit - -> Circ (Bindings Qubit Bit, a) -apply_dbcircuit_with_bindings dbcircuit bindings = do - -- until the transformer interface is updated to work with dynamic - -- circuits, we have to go the route of converting to a static - -- circuit first. Unfortunately, this means that any dynamic - -- liftings will given an error. - let (bcircuit, a) = bcircuit_of_static_dbcircuit errmsg dbcircuit - out_bindings <- apply_bcircuit_with_bindings bcircuit bindings - return (out_bindings, a) - where - errmsg x = "apply_dbcircuit_with_bindings: operation unimplemented: " ++ x - --- ====================================================================== --- * Encapsulated circuits - --- | Similar to 'extract_simple', except we take the current output arity --- of the /current/ circuit and make that the input arity of the --- extracted circuit. Therefore, endpoints defined in the current --- context can be used in /f/. This is a low-level operator, intended --- for the construction of primitives, such as '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 diff --git a/src/Quipper/Printing.hs b/src/Quipper/Printing.hs deleted file mode 100644 --- a/src/Quipper/Printing.hs +++ /dev/null @@ -1,1692 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE BangPatterns #-} - --- | Pretty-printing of low-level quantum circuits. - -module Quipper.Printing ( - -- * ASCII representation of circuits - ascii_of_bcircuit, - print_dbcircuit_ascii, - getBit, - -- * Gate counts - print_gatecounts_bcircuit, - -- * Graphical representation of circuits - render_dbcircuit, - -- * Previewing - preview_bcircuit, - -- * Printing to multiple formats - Format(..), - FormatStyle(..), - pdf, - eps, - ps, - format_enum, - print_dbcircuit, - print_of_document, - print_of_document_custom, - -- * Generic printing - print_unary, - print_generic, - print_simple, - ) where - --- import other Quipper stuff -import Libraries.Auxiliary -import Quipper.Circuit -import Quipper.Generic -import Quipper.Monad -import Quipper.QData - --- import other stuff -import Prelude -import Text.Printf -import Data.Char(isSpace) -import Data.List -import Data.Maybe -import Control.Monad(when) -import Graphics.EasyRender -import System.IO -import System.Process -import System.Directory -import System.Environment -import System.Info - -import Data.Set (Set) -import qualified Data.Set as Set - -import Data.Map (Map) -import qualified Data.Map as Map - -import qualified Data.IntMap as IntMap -import qualified Data.List as List - --- ====================================================================== --- * Auxiliary functions - --- | Determine whether a named gate is self-inverse. The kind of a --- gate is uniquely determined by its name, and the number of input --- wires and generalized controls. --- --- For now, we only recognize "X", "Y", "Z", "H", "not", "swap", and --- "W" as self-inverse; it is not currently possible for user code to --- extend this list. -self_inverse :: String -> [Wire] -> [Wire] -> Bool -self_inverse "X" [q] [] = True -self_inverse "Y" [q] [] = True -self_inverse "Z" [q] [] = True -self_inverse "H" [q] [] = True -self_inverse "not" [q] [] = True -self_inverse "swap" [q1,q2] [] = True -self_inverse "W" [q1,q2] [] = True -self_inverse _ _ _ = False - --- ====================================================================== --- * ASCII representation of circuits - --- $ Convert a circuit to ASCII: one gate per line. - -type WireTypeMap = IntMap.IntMap Wiretype - --- | Given a map of wiretypes, and a gate, update the wiretype in the map --- if the gate changes it. -track_wiretype :: WireTypeMap -> Gate -> WireTypeMap -track_wiretype wtm (QInit _ w _ ) = IntMap.insert w Qbit wtm -track_wiretype wtm (CInit _ w _ ) = IntMap.insert w Cbit wtm -track_wiretype wtm (QMeas w ) = IntMap.insert w Cbit wtm -track_wiretype wtm (CGate _ w _ _) = IntMap.insert w Cbit wtm -track_wiretype wtm (CGateInv _ w _ _) = IntMap.insert w Cbit wtm -track_wiretype wtm (QPrep w _ ) = IntMap.insert w Qbit wtm -track_wiretype wtm (QUnprep w _ ) = IntMap.insert w Cbit wtm -track_wiretype wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = a2 `IntMap.union` wtm -track_wiretype wtm _ = wtm - --- | Convert a 'BoxId' to the string in the format \"/name/\", shape \"/x/\". -ascii_of_boxid :: BoxId -> String -ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape - --- | Generate an ASCII representation of a control. --- As controls are stored as untyped wires, we can lookup the wiretype in --- the current map and annotate the control if it's classical. -ascii_render_control :: WireTypeMap -> Signed Wire -> String -ascii_render_control wtm (Signed w b) = - (if b then "+" else "-") ++ show w ++ ascii_render_control_type wtype - where - wtype = if (w `IntMap.member` wtm) then (wtm IntMap.! w) else Qbit - ascii_render_control_type Qbit = "" - ascii_render_control_type Cbit = "c" - --- | Generate an ASCII representation of a list of controls. -ascii_render_controls :: WireTypeMap -> Controls -> String -ascii_render_controls wtm c = - string_of_list " with controls=[" ", " "]" "" (ascii_render_control wtm) c - --- | Generate an ASCII representation of a NoControlFlag -ascii_render_nocontrolflag :: NoControlFlag -> String -ascii_render_nocontrolflag False = "" -ascii_render_nocontrolflag True = " with nocontrol" - --- | Generate an ASCII representation of a single gate. -ascii_render_gate :: WireTypeMap -> Gate -> String -ascii_render_gate wtm (QGate "trace" _ _ _ _ _) = "" -ascii_render_gate wtm (QGate name inv ws1 ws2 c ncf) = - "QGate[" ++ show name ++ "]" - ++ optional inv' "*" - ++ (string_of_list "(" "," ")" "()" show ws1) - ++ (string_of_list "; [" "," "]" "" show ws2) - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf - where - inv' = inv && not (self_inverse name ws1 ws2) -ascii_render_gate wtm (QRot name inv theta ws1 ws2 c ncf) = - "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" - ++ optional inv "*" - ++ (string_of_list "(" "," ")" "()" show ws1) - ++ (string_of_list "; [" "," "]" "" show ws2) - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (GPhase t ws c ncf) = - "GPhase() with t=" ++ show t - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf - ++ string_of_list " with anchors=[" ", " "]" "" show ws -ascii_render_gate wtm (CNot w c ncf) = - "CNot(" ++ show w ++ ")" - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (CGate n w c ncf) = - -- special case - "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c)) - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (CGateInv n w c ncf) = - "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c)) - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (CSwap w1 w2 c ncf) = - "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (QPrep w ncf) = - "QPrep(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (QUnprep w ncf) = - "QUnprep(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (QInit b w ncf) = - "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (CInit b w ncf) = - "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (QTerm b w ncf) = - "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (CTerm b w ncf) = - "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" - ++ ascii_render_nocontrolflag ncf -ascii_render_gate wtm (QMeas w) = - "QMeas(" ++ show w ++ ")" -ascii_render_gate wtm (QDiscard w) = - "QDiscard(" ++ show w ++ ")" -ascii_render_gate wtm (CDiscard w) = - "CDiscard(" ++ show w ++ ")" -ascii_render_gate wtm (DTerm b w) = - "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")" -ascii_render_gate wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = - "Subroutine" ++ show_rep ++ "[" ++ ascii_of_boxid boxid ++ "]" - ++ optional inv "*" - ++ " " - ++ (string_of_list "(" "," ")" "()" show ws1) - ++ (string_of_list " -> (" "," ")" "()" show ws2) - ++ ascii_render_controls wtm c - ++ ascii_render_nocontrolflag ncf - where - show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")" -ascii_render_gate wtm (Comment s inv ws) = - "Comment[" ++ show s ++ "]" - ++ optional inv "*" - ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws) - --- | Generate an ASCII representation of a gate list. -ascii_render_gatelist :: WireTypeMap -> [Gate] -> String -ascii_render_gatelist wtm [] = "" -ascii_render_gatelist wtm (g:gs) = - (ascii_render_gate wtm g) ++ "\n" ++ - (ascii_render_gatelist (track_wiretype wtm g) gs) - where - --- | Generate an ASCII representation of a wiretype. -ascii_render_wiretype :: Wiretype -> String -ascii_render_wiretype Qbit = "Qbit" -ascii_render_wiretype Cbit = "Cbit" - --- | Generate an ASCII representation of a type assignment. -ascii_render_typeas :: (Wire, Wiretype) -> String -ascii_render_typeas (w, t) = - show w ++ ":" ++ ascii_render_wiretype t - --- | Generate an ASCII representation of an arity, preceded by a title --- (input or output). -ascii_render_arity :: String -> Arity -> String -ascii_render_arity title a = - title ++ ": " ++ (string_of_list "" ", " "" "none" ascii_render_typeas (IntMap.toList a)) ++ "\n" - --- | Generate an ASCII representation of an ordered arity, preceded by --- a title (input or output). -ascii_render_oarity :: String -> [Wire] -> Arity -> String -ascii_render_oarity title ws a = - title ++ ": " - ++ (string_of_list "" ", " "" "none" ascii_render_typeas tas_list) ++ "\n" - where - tas_list = [ (w, a IntMap.! w) | w <- ws ] - --- | Generate an ASCII representation of a low-level ordered quantum --- circuit. -ascii_of_ocircuit :: OCircuit -> String -ascii_of_ocircuit ocircuit = - (ascii_render_oarity "Inputs" win a1) ++ - (ascii_render_gatelist a1 gl) ++ - (ascii_render_oarity "Outputs" wout a2) - where - OCircuit (win, circuit, wout) = ocircuit - (a1, gl, a2, _) = circuit - --- | Generate an ASCII representation of a low-level quantum circuit. -ascii_of_circuit :: Circuit -> String -ascii_of_circuit circuit = ascii_of_ocircuit ocircuit where - ocircuit = OCircuit (w_in, circuit, w_out) - (a1, _, a2, _) = circuit - w_in = IntMap.keys a1 - w_out = IntMap.keys a2 - --- | Generate an ASCII representation of a low-level boxed quantum --- circuit. -ascii_of_bcircuit :: BCircuit -> String -ascii_of_bcircuit (c,s) = - (ascii_of_circuit c) ++ - (concat $ map ascii_of_subroutine (Map.toList s)) ++ - "\n" - --- | Generate an ASCII representation of a named subroutine. -ascii_of_subroutine :: (BoxId, TypedSubroutine) -> String -ascii_of_subroutine (boxid, TypedSubroutine ocirc input_strux output_strux ctrble) = - "\n" - ++ "Subroutine: " ++ show name ++ "\n" - ++ "Shape: " ++ show shape ++ "\n" - ++ "Controllable: " ++ (case ctrble of {AllCtl -> "yes"; NoCtl -> "no"; OnlyClassicalCtl -> "classically"}) ++ "\n" - ++ ascii_of_ocircuit ocirc - where - BoxId name shape = boxid - --- ====================================================================== --- * Dynamic ASCII representation of circuits - --- $ --- The dynamic ASCII representation prints a circuit to standard --- output in ASCII format, just like the static ASCII representation. --- However, when a 'dynamic_lift' operation is encountered, it prompts --- the user for the value of the corresponding bit. In effect, the --- user is asked to act as the quantum device or simulator. - --- | Write a prompt to get input from the user. Since the prompt --- doesn't include a newline, the output must be flushed explicitly. -prompt :: String -> IO () -prompt s = do - putStr s - hFlush stdout - --- | Interactively read a bit (either 0 or 1) from standard input. --- This is intended for interactive user input, so it skips white --- space until a 0 or 1 is encountered. In case the first --- non-whitespace character isn't 0 or 1 or '#', the rest of the line --- is ignored and the user is prompted to try again. --- --- However, this also works for non-interactive input, so that the --- input can be redirected from a file. In this case, the characters 0 --- and 1 and whitespace, including newlines, can be interspersed --- freely. \'@#@\' starts a comment that extends until the end of the --- line. -getBit :: IO Bool -getBit = do - c <- getChar - case c of - '0' -> return False - '1' -> return True - '#' -> do - getLine - getBit - c | isSpace c -> getBit - c -> do - getLine - prompt $ "# Expecting 0 or 1. Please try again: " - getBit - --- | Embed a read-write computation in the 'IO' monad, by writing --- gates to the terminal and interactively querying the user (or a --- file on stdin) for dynamic liftings. We also update a 'Namespace' --- while doing so, to collect any subroutines that are defined along --- the way. -run_readwrite_ascii :: WireTypeMap -> ReadWrite a -> Namespace -> IO (a, Namespace) -run_readwrite_ascii wtm (RW_Return a) ns = return (a, ns) -run_readwrite_ascii wtm (RW_Write gate comp) ns = do - putStrLn (ascii_render_gate wtm gate) - run_readwrite_ascii (track_wiretype wtm gate) comp ns -run_readwrite_ascii wtm (RW_Read w cont) ns = do - prompt $ "# Value of wire " ++ show w ++ ": " - bool <- getBit - putStrLn $ "# Value: " ++ show bool - run_readwrite_ascii wtm (cont bool) ns -run_readwrite_ascii wtm (RW_Subroutine name subroutine comp) ns = do - let !ns' = map_provide name subroutine ns - run_readwrite_ascii wtm comp ns' - --- | Interactively output a 'DBCircuit' to standard output. This --- supports dynamic lifting by prompting the user for bit values when --- a dynamic lifting operation is encountered. Effectively the user is --- asked to behave like a quantum device. -print_dbcircuit_ascii :: ErrMsg -> DBCircuit a -> IO () -print_dbcircuit_ascii _ (a0, comp) = do - hSetBuffering stdout LineBuffering -- flush output after each line - putStr (ascii_render_arity "Inputs" a0) - ((a1, _, _),ns) <- run_readwrite_ascii a0 comp namespace_empty - putStr (ascii_render_arity "Outputs" a1) - sequence_ [ putStr $ ascii_of_subroutine subr | subr <- Map.toList ns ] - putStr "\n" - --- ---------------------------------------------------------------------- --- * Graphical representation of circuits - --- | The color white. -white :: Color -white = Color_Gray 1.0 - --- | The color black. -black :: Color -black = Color_Gray 0.0 - --- | A data type that holds all the customizable parameters. -data FormatStyle = FormatStyle { - -- | The RenderFormat to use. - renderformat :: RenderFormat, - -- | The color of the background. - backgroundcolor :: Color, - -- | The color of the foreground (e.g. wires and gates). - foregroundcolor :: Color, - -- | Line width. - linewidth :: Double, - -- | Gap for double line representing classical bit. - coffs :: Double, - -- | Radius of dots for \"controlled\" gates. - dotradius :: Double, - -- | Radius of oplus for \"not\" gate. - oplusradius :: Double, - -- | Horizontal column width. - xoff :: Double, - -- | Difference between width of box and width of label. - gatepad :: Double, - -- | Height of labelled box. - gateheight :: Double, - -- | Width and height of \"cross\" for swap gate. - crossradius :: Double, - -- | Vertical shift for text labels. - stringbase :: Double, - -- | Width of \"bar\" bar. - barwidth :: Double, - -- | Height of \"bar\" bar. - barheight :: Double, - -- | Width of \"D\" symbol. - dwidth :: Double, - -- | Height of \"D\" symbol. - dheight :: Double, - -- | Maximal width of a gate label. - maxgatelabelwidth :: Double, - -- | Maximal width of a wire label. - maxlabelwidth :: Double, - -- | Maximal width of a wire number. - maxnumberwidth :: Double, - -- | Font to use for labels on gates. - gatefont :: Font, - -- | Font to use for comments. - commentfont :: Font, - -- | Color to use for comments. - commentcolor :: Color, - -- | Font to use for labels. - labelfont :: Font, - -- | Color to use for labels. - labelcolor :: Color, - -- | Font to use for numbers. - numberfont :: Font, - -- | Color to use for numbers. - numbercolor :: Color, - -- | Whether to label each subroutine call with shape parameters - subroutineshape :: Bool -} deriving Show - --- | A RenderFormat consisting of some default parameters, --- along with the given RenderFormat. -defaultStyle :: RenderFormat -> FormatStyle -defaultStyle rf = FormatStyle { - renderformat = rf, - backgroundcolor = white, - foregroundcolor = black, - linewidth = 0.02, - coffs = 0.03, - dotradius = 0.15, - oplusradius = 0.25, - xoff = 1.5, - gatepad = 0.3, - gateheight = 0.8, - crossradius = 0.2, - stringbase = 0.25, - barwidth = 0.1, - barheight = 0.5, - dwidth = 0.3, - dheight = 0.4, - maxgatelabelwidth = 1.1, - maxlabelwidth = 0.7, - maxnumberwidth = 0.7, - gatefont = Font TimesRoman 0.5, - commentfont = Font TimesRoman 0.3, - commentcolor = Color_RGB 1 0.2 0.2, - labelfont = Font TimesRoman 0.3, - labelcolor = Color_RGB 0 0 1, - numberfont = Font Helvetica 0.5, - numbercolor = Color_RGB 0 0.7 0, - subroutineshape = True -} - --- | The default PDF Style. -pdf :: FormatStyle -pdf = defaultStyle Format_PDF - --- | The default EPS Style. -eps :: FormatStyle -eps = defaultStyle (Format_EPS 1) - --- | The default PS Style. -ps :: FormatStyle -ps = defaultStyle (Format_PS) - --- ---------------------------------------------------------------------- --- ** General-purpose PostScript functions - --- | Escape special characters in a string literal. -ps_escape :: String -> String -ps_escape [] = [] -ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t -ps_escape ('(' : t) = '\\' : '(' : ps_escape t -ps_escape (')' : t) = '\\' : ')' : ps_escape t -ps_escape (h : t) = h : ps_escape t - --- ---------------------------------------------------------------------- --- ** String formatting - --- | Convert a 'BoxId' to the string in the format \"/name/, shape /x/\". -string_of_boxid :: BoxId -> String -string_of_boxid (BoxId name shape) = name ++ ", shape " ++ shape - --- ---------------------------------------------------------------------- --- ** Functions for dealing with x-coordinates - --- | Pre-processing: figure out the /x/-column of each gate. Returns --- (/n/,/xgs/) where /xgs/ is a list of ('Gate', 'X') pairs, and --- /n/ is the rightmost /x/-coordinate of the circuit. Here we start --- from /x0/ and use constant step /xoff/ taken from the 'FormatStyle'. -assign_x_coordinates :: FormatStyle -> [Gate] -> X -> (X, [(Gate, X)]) -assign_x_coordinates fs gs x0 = - let ((x,ws), xgs) = mapAccumL (\ (x, ws) g -> - -- count the wires attached to the gate. If there is precisely - -- one (unary gate), merge it with adjacent unary gates. Do - -- not merge comments. - let merge = case (g, wirelist_of_gate g) of - (Comment _ _ _, _) -> Nothing - (_, [w]) -> Just w - (_, _) -> Nothing - in - case merge of - Just w -> - if not (w `elem` ws) then - ((x, w:ws), (g, x)) - else - ((x + (xoff fs), [w]), (g, x + (xoff fs))) - _ -> - if ws == [] then - ((x + (xoff fs), []), (g, x)) - else - ((x + 2.0 * (xoff fs), []), (g, x + (xoff fs))) - ) (x0, []) gs - in - if ws == [] then - (x, xgs) - else - (x + (xoff fs), xgs) - --- | A 'Xarity' is a map from wire id's to pairs of a wiretype and a --- starting /x/-coordinate. -type Xarity = Map Wire (Wiretype, X) - --- | Figure out how a gate at coordinate /x/ affects the current 'Xarity'. --- Return a pair (/term/, /new/), where /term/ is the 'Xarity' of wires --- terminated by this gate, and /new/ is the outgoing 'Xarity' of this --- gate. -update_xarity :: Xarity -> Gate -> X -> (Xarity, Xarity) -update_xarity xarity gate x = - let (win, wout) = gate_arity gate - safe_lookup xarity w = - case Map.lookup w xarity of - Just x -> x - Nothing -> (Qbit, x) -- error ("update_xarity: the wire " ++ show w ++ " does not exist. In the gate:\n" ++ ascii_render_gate gate) - (win', wout') = (win \\ wout, wout \\ win) - -- extract terminating wires from xarity - xarity_term = foldl (\xar (w,_) -> Map.insert w (xarity `safe_lookup` w) xar) Map.empty win' - -- extract continuing wires from xarity - xarity_cont = foldl (\xar (w,_) -> Map.delete w xar) xarity win' - -- add new wires to xarity_cont - xarity_new = foldl (\xar (w,t) -> Map.insert w (t,x) xar) xarity_cont wout' - in - (xarity_term, xarity_new) - --- ---------------------------------------------------------------------- --- ** Low-level drawing functions - --- | @'render_line' x0 y0 x1 y1@: Draw a line from (/x0/, /y0/) --- to (/x1/, /y1/). In case of a zero-length line, draw nothing. -render_line :: X -> Y -> X -> Y -> Draw () -render_line x0 y0 x1 y1 | x0 == x1 && y0 == y1 = return () -render_line x0 y0 x1 y1 = draw_subroutine alt $ do - moveto x0 y0 - lineto x1 y1 - stroke - where - alt = [custom_ps $ printf "%f %f %f %f line\n" x0 y0 x1 y1] - --- | @'render_dot' x y@: Draw a filled control dot at (/x/,/y/). -render_dot :: FormatStyle -> X -> Y -> Draw () -render_dot fs x y = draw_subroutine alt $ do - arc x y (dotradius fs) 0 360 - fill (foregroundcolor fs) - where - alt = [custom_ps $ printf "%f %f dot\n" x y] - --- | @'render_circle' x y@: Draw an empty control dot at --- (/x/,/y/). -render_circle :: FormatStyle -> X -> Y -> Draw () -render_circle fs x y = draw_subroutine alt $ do - arc x y (dotradius fs) 0 360 - fillstroke (backgroundcolor fs) - where - alt = [custom_ps $ printf "%f %f circ\n" x y] - --- | @'render_not' x y@: Draw a \"not\" gate at (/x/,/y/). -render_not :: FormatStyle -> X -> Y -> Draw () -render_not fs x y = draw_subroutine alt $ do - arc x y (oplusradius fs) 0 360 - fillstroke (backgroundcolor fs) - render_line (x-(oplusradius fs)) y (x+(oplusradius fs)) y - render_line x (y-(oplusradius fs)) x (y+(oplusradius fs)) - where - alt = [custom_ps $ printf "%f %f oplus\n" x y] - --- | @'render_swap' x y@: Draw a cross (swap gate component) at --- (/x/,/y/). -render_swap :: FormatStyle -> X -> Y -> Draw () -render_swap fs x y = draw_subroutine alt $ do - render_line (x-(crossradius fs)) (y-(crossradius fs)) (x+(crossradius fs)) (y+(crossradius fs)) - render_line (x-(crossradius fs)) (y+(crossradius fs)) (x+(crossradius fs)) (y-(crossradius fs)) - where - alt = [custom_ps $ printf "%f %f cross\n" x y] - --- | @'render_bar' x y@: Draw an init/term bar at (/x/,/y/). -render_bar :: FormatStyle -> X -> Y -> Draw () -render_bar fs x y = draw_subroutine alt $ do - rectangle (x - (barwidth fs)/2) (y - (barheight fs)/2) (barwidth fs) (barheight fs) - fill (foregroundcolor fs) - where - alt = [custom_ps $ printf "%f %f bar\n" x y] - --- | @'render_bar' x y@: Draw a dterm bar at (/x/,/y/). -render_dbar :: FormatStyle -> X -> Y -> Draw () -render_dbar fs x y = draw_subroutine alt $ do - block $ do - translate (x+(barwidth fs)/2) y - scale (dwidth fs) (dheight fs) - moveto (-1) (-0.5) - arc_append (-0.5) 0 0.5 (-90) 90 - lineto (-1) 0.5 - closepath - fill (foregroundcolor fs) - where - alt = [custom_ps $ printf "%f %f dbar\n" x y] - --- | @'render_init' name x y@: Draw an \"init\" gate at --- (/x/,/y/), with state /name/. -render_init :: FormatStyle -> String -> X -> Y -> Draw () -render_init fs name x y = draw_subroutine alt $ do - render_bar fs x y - textbox align_right (gatefont fs) (foregroundcolor fs) (x-(xoff fs)/2+(gatepad fs)/2) y (x-(gatepad fs)/2) y (stringbase fs) name - where - alt = [custom_ps $ printf "(%s) %f %f init\n" (ps_escape name) x y] - --- | @'render_term' name x y@: Draw a \"term\" gate at --- (/x/,/y/), with state /name/. -render_term :: FormatStyle -> String -> X -> Y -> Draw () -render_term fs name x y = draw_subroutine alt $ do - render_bar fs x y - textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name - where - alt = [custom_ps $ printf "(%s) %f %f term\n" (ps_escape name) x y] - --- | @'render_dterm' name x y@: Draw a \"dterm\" gate at --- (/x/,/y/), with state /name/. -render_dterm :: FormatStyle -> String -> X -> Y -> Draw () -render_dterm fs name x y = draw_subroutine alt $ do - render_dbar fs x y - textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name - where - alt = [custom_ps $ printf "(%s) %f %f dterm\n" (ps_escape name) x y] - --- | @'render_namedgate' name inv x y@: draw a named box centered at --- (/x/,/y/). If /inv/ = 'True', append an \"inverse\" symbol to the --- end of the name. -render_namedgate :: FormatStyle -> String -> InverseFlag -> X -> Y -> Draw () -render_namedgate fs name inv x y = draw_subroutine alt $ do - rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs) - fillstroke (backgroundcolor fs) - textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name' - where - alt = [custom_ps $ printf "(%s) %f %f gate\n" (ps_escape name') x y] - name' = name ++ optional inv "*" - w = text_width (gatefont fs) name' - labelwidth = min w (maxgatelabelwidth fs) - gatewidth = labelwidth + (gatepad fs) - --- | @'render_gphasegate' name x y@: draw a global phase gate --- centered at (/x/,/y/). -render_gphasegate :: FormatStyle -> String -> X -> Y -> Draw () -render_gphasegate fs name x y = draw_subroutine alt $ do - render_circgate fs name x (y-0.5) - where - alt = [custom_ps $ printf "(%s) %f %f gphase\n" (ps_escape name) x y] - --- | @'render_circgate' name x y@: draw a named oval centered at --- (/x/,/y/). -render_circgate :: FormatStyle -> String -> X -> Y -> Draw () -render_circgate fs name x y = draw_subroutine alt $ do - oval x y (0.5*gatewidth) (0.4*(gateheight fs)) - fillstroke (backgroundcolor fs) - textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name - where - alt = [custom_ps $ printf "(%s) %f %f circgate\n" (ps_escape name) x y] - w = text_width (gatefont fs) name - labelwidth = min w (maxgatelabelwidth fs) - gatewidth = labelwidth + (gatepad fs) - --- | @'render_blankgate' name x y@: draw an empty box centered --- at (/x/,/y/), big enough to hold /name/. -render_blankgate :: FormatStyle -> String -> X -> Y -> Draw () -render_blankgate fs name x y = draw_subroutine alt $ do - rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs) - fillstroke (backgroundcolor fs) - where - alt = [custom_ps $ printf "(%s) %f %f box\n" (ps_escape name) x y] - w = text_width (gatefont fs) name - labelwidth = min w (maxgatelabelwidth fs) - gatewidth = labelwidth + (gatepad fs) - --- | @'render_comment' center s x y m@: draw the given string --- vertically, with the top of the string near the given --- /y/-coordinate. If /center/=='True', center it at the --- /x/-coordinate, else move it just to the left of the --- /x/-coordinate. /m/ is the maximum height allowed for the comment. -render_comment :: FormatStyle -> Bool -> String -> X -> Y -> Y -> Draw () -render_comment fs center s x y maxh = draw_subroutine alt $ do - textbox align_right (commentfont fs) (commentcolor fs) x (y-maxh) x (y+0.4) b s - where - alt = [custom_ps $ printf "(%s) %f %f %f %f comment\n" (ps_escape s) x y maxh yshift] - b = if center then 0.15 else -0.25 - yshift = -b * nominalsize (commentfont fs) - --- | @'render_label' center s x y@: draw the given label just above --- the given point. If /center/=='True', center it at the --- /x/-coordinate, else move it just to the right of the --- /x/-coordinate. -render_label :: FormatStyle -> Bool -> String -> X -> Y -> Draw () -render_label fs True s x y = draw_subroutine alt $ do - textbox align_center (labelfont fs) (labelcolor fs) (x-(maxlabelwidth fs)) y' (x+(maxlabelwidth fs)) y' (-0.5) s - where - alt = [custom_ps $ printf "(%s) %f %f clabel\n" (ps_escape s) x y'] - y' = y + 0.5 * (coffs fs) -render_label fs False s x y = draw_subroutine alt $ do - textbox align_left (labelfont fs) (labelcolor fs) x y' (x+(maxlabelwidth fs)) y' (-0.5) s - where - alt = [custom_ps $ printf "(%s) %f %f rlabel\n" (ps_escape s) x y'] - y' = y + 0.5 * (coffs fs) - --- | Render the number at the given point (/x/,/y/). If the boolean --- argument is 'True', put the number to the right of /x/, else to the left. -render_number :: FormatStyle -> Int -> Bool -> X -> Y -> Draw () -render_number fs i True x y = draw_subroutine alt $ do - textbox align_left (numberfont fs) (numbercolor fs) (x+0.2) y (x+0.2+(maxnumberwidth fs)) y (stringbase fs) (show i) - where - alt = [custom_ps $ printf "(%s) %f %f rnumber\n" (ps_escape (show i)) x y] -render_number fs i False x y = draw_subroutine alt $ do - textbox align_right (numberfont fs) (numbercolor fs) (x-0.2-(maxnumberwidth fs)) y (x-0.2) y (stringbase fs) (show i) - where - alt = [custom_ps $ printf "(%s) %f %f lnumber\n" (ps_escape (show i)) x y] - --- ---------------------------------------------------------------------- --- ** Higher-level rendering functions - --- | Render a horizontal wire from /x/-coordinates /oldx/ to /x/, --- using /t/ as the type and figuring out the /y/-coordinate from /ys/ --- and /w/. Append to the given string. If the parameters are invalid --- (/w/ not in /ys/), throw an error. -render_typeas :: FormatStyle -> Map Wire Y -> X -> X -> Wire -> Wiretype -> Draw () -render_typeas fs ys oldx x w t = - let y = ys Map.! w in - case t of - Qbit -> do - render_line oldx y x y - Cbit -> do - render_line oldx (y + (coffs fs)) x (y + (coffs fs)) - render_line oldx (y - (coffs fs)) x (y - (coffs fs)) - --- | Render a bunch of horizontal wires from their repective starting --- 'Xarity' to /x/. -render_xarity :: FormatStyle -> Map Wire Y -> Xarity -> X -> Draw () -render_xarity fs ys xarity x = do - sequence_ [ render_typeas fs ys oldx x w t | (w,(t,oldx)) <- Map.toList xarity ] - --- | Format a floating point number in concise form, with limited --- accuracy. -dshow :: Double -> String -dshow dbl = - if abs dbl < 0.01 - then - printf "%.1e" dbl - else - (reverse . strip . reverse) (printf "%.3f" dbl) - where - strip [] = [] - strip ('.' : t) = t - strip ('0' : t) = strip t - strip t = t - --- | @'render_controlwire' /x/ /ys/ /ws/ /c/@: --- Render the line connecting all the box components and all the --- control dots of some gate. --- --- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed --- array of /y/-coordinates, /ws/ is the set of wires for boxes, and --- /c/ is a list of controls. -render_controlwire :: X -> Map Wire Y -> [Wire] -> Controls -> Draw () -render_controlwire x ys ws c = - case ws of - [] -> return () - w:ws -> render_line x y0 x y1 - where - ymap w = ys Map.! w - y = ymap w - cy = map (\(Signed w _) -> ymap w) c - yy = map (\w -> ymap w) ws - y0 = foldr min y (cy ++ yy) - y1 = foldr max y (cy ++ yy) - --- | @'render_controlwire_float' /x/ /ys/ /y/ /c/@: Render the line --- connecting all control dots of the given controls, as well as a --- floating \"global phase\" gate located just below (/x/, /y/). --- --- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed --- array of /y/-coordinates, /y/ is the /y/-coordinate of the wire --- where the floating gate is attached, and /c/ is a list of controls. -render_controlwire_float :: X -> Map Wire Y -> Y -> Controls -> Draw () -render_controlwire_float x ys y c = render_line x y0 x y1 - where - y' = y - 0.5 - cy = map (\(Signed w _) -> ys Map.! w) c - y0 = minimum (y':cy) - y1 = maximum (y':cy) - --- | @'render_controldots' /x/ /ys/ /c/@: Render the control dots --- for the given controls. -render_controldots :: FormatStyle -> X -> Map Wire Y -> Controls -> Draw () -render_controldots fs x ys c = do - sequence_ [ renderdot x | x <- c ] - where - renderdot (Signed w True) = render_dot fs x (ys Map.! w) - renderdot (Signed w False) = render_circle fs x (ys Map.! w) - --- | @'render_multi_gate' /x/ /ys/ /name/ /inv/ /wires/@: Render the --- boxes for an /n/-ary gate of the given /name/, potentially --- /inv/erted, at the given list of /wires/. The first two arguments --- are the current /x/-coordinate and an indexed array of --- /y/-coordinates. -render_multi_gate :: FormatStyle -> X -> Map Wire Y -> String -> InverseFlag -> [Wire] -> Draw () -render_multi_gate fs x ys name inv [w] = - render_namedgate fs name inv x (ys Map.! w) -render_multi_gate fs x ys name inv ws = - sequence_ [ render_namedgate fs (name ++ " " ++ show i) inv x (ys Map.! a) | (a,i) <- zip ws [1..] ] - --- | @'render_multi_named_ctrl' /x/ /ys/ /wires/ /names/@: Render --- the boxes for multiple generalized controls at the given /wires/, --- using the given /names/. We take special care of the fact that --- generalized controls may be used non-linearly. -render_multi_named_ctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> [String] -> Draw () -render_multi_named_ctrl fs x ys ws names = - sequence_ [ render_circgate fs name x (ys Map.! a) | (a,name) <- IntMap.toList map ] - where - -- Combine the labels for w if w has multiple occurrences. - map = IntMap.fromListWith (\x y -> y ++ "," ++ x) (zip ws names) - --- | @'render_multi_genctrl' /x/ /ys/ /wires/@: Render the boxes for --- multiple (numbered) generalized controls at the given /wires/. -render_multi_genctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> Draw () -render_multi_genctrl fs x ys ws = render_multi_named_ctrl fs x ys ws names - where - names = map show [1..] - --- | Number a list of wires in increasing order, at the given --- /x/-coordinate. If the boolean argument is 'True', put the numbers --- to the right of /x/, else to the left. -render_ordering :: FormatStyle -> X -> Map Wire Y -> Bool -> [Wire] -> Draw () -render_ordering fs x ys b ws = - sequence_ [ render_number fs i b x (ys Map.! w) | (w,i) <- numbering ] - where - numbering = zip ws [1..] - --- | Render gate /g/ at /x/-coordinate /x/ and /y/-coordinates as --- given by /ys/, which is a map from wires to --- /y/-coordinates. Returns a pair (/s/,/t/) of draw actions for --- background and foreground, respectively. -render_gate :: FormatStyle -> Gate -> X -> Map Wire Y -> Y -> (Draw (), Draw ()) -render_gate fs g x ys maxh = - let ymap w = ys Map.! w - in - case g of - -- Certain named gates are recognized for custom rendering. - QGate "not" _ [w] [] c ncf -> (s2, t2 >> t3) - where - y = ymap w - s2 = render_controlwire x ys [w] c - t2 = render_controldots fs x ys c - t3 = (render_not fs x y) - QGate "multinot" _ ws [] c ncf -> (s2, t2 >> t3) - where - s2 = render_controlwire x ys ws c - t2 = render_controldots fs x ys c - t3 = sequence_ (map (\w -> (render_not fs x (ymap w))) ws) - QGate "swap" _ [w1,w2] [] c ncf -> (s2, t2 >> t3) - where - y1 = ymap w1 - y2 = ymap w2 - s2 = render_controlwire x ys [w1,w2] c - t2 = render_controldots fs x ys c - t3 = (render_swap fs x y1) >> (render_swap fs x y2) - QGate "trace" _ _ _ _ _ -> (return (), return ()) - QGate name inv ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4) - where - s2 = render_controlwire x ys (ws1 ++ ws2) c - t2 = render_multi_gate fs x ys name inv' ws1 - t3 = render_controldots fs x ys c - t4 = render_multi_genctrl fs x ys ws2 - inv' = inv && not (self_inverse name ws1 ws2) - QRot name inv theta ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4) - where - s2 = render_controlwire x ys (ws1 ++ ws2) c - t2 = render_multi_gate fs x ys name' inv ws1 - t3 = render_controldots fs x ys c - t4 = render_multi_genctrl fs x ys ws2 - name' = substitute name '%' (dshow theta) - GPhase t ws c ncf -> (s2, t2 >> t3) - where - y = case (ws, c) of - ([], []) -> maximum (0.0 : Map.elems ys) - ([], c) -> minimum [ ymap w | Signed w b <- c ] - (ws, c) -> minimum [ ymap w | w <- ws ] - s2 = render_controlwire_float x ys y c - t2 = render_controldots fs x ys c - t3 = (render_gphasegate fs (dshow t) x y) - CNot w c ncf -> (s2, t2 >> t3) - where - y = ymap w - s2 = render_controlwire x ys [w] c - t2 = render_controldots fs x ys c - t3 = (render_not fs x y) - CGate "if" w [a,b,c] ncf -> (s2, t1 >> t3) -- special case - where - y = ymap w - s2 = render_controlwire x ys [w,a,b,c] [] - t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"] - t3 = render_namedgate fs ">" False x y - CGateInv "if" w [a,b,c] ncf -> (s2, t1 >> t3) -- special case - where - y = ymap w - s2 = render_controlwire x ys [w,a,b,c] [] - t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"] - t3 = render_namedgate fs "<" False x y - CGate name w c ncf -> (s2, t2 >> t3) - where - y = ymap w - s2 = render_controlwire x ys (w:c) [] - t2 = render_multi_named_ctrl fs x ys c [ " " | a <- c ] - t3 = render_namedgate fs name False x y - CGateInv name w c ncf -> (s2, t2 >> t3) - where - y = ymap w - s2 = render_controlwire x ys (w:c) [] - t2 = render_multi_named_ctrl fs x ys c [ " " | a <- c ] - t3 = render_namedgate fs name True x y - CSwap w1 w2 c ncf -> (s2, t2 >> t3) - where - y1 = ymap w1 - y2 = ymap w2 - s2 = render_controlwire x ys [w1,w2] c - t2 = render_controldots fs x ys c - t3 = (render_swap fs x y1) >> (render_swap fs x y2) - QPrep w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_namedgate fs "prep" False x y) - QUnprep w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_namedgate fs "unprep" False x y) - QInit b w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_init fs (if b then "1" else "0") x y) - CInit b w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_init fs (if b then "1" else "0") x y) - QTerm b w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_term fs (if b then "1" else "0") x y) - CTerm b w ncf -> (return (), t3) - where - y = ymap w - t3 = (render_term fs (if b then "1" else "0") x y) - QMeas w -> (return (), t3) - where - y = ymap w - t3 = (render_namedgate fs "meas" False x y) - QDiscard w -> (return (), t3) - where - y = ymap w - t3 = (render_bar fs x y) - CDiscard w -> (return (), t3) - where - y = ymap w - t3 = (render_bar fs x y) - DTerm b w -> (return (), t3) - where - y = ymap w - t3 = (render_dterm fs (if b then "1" else "0") x y) - Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep -> (s2, t2 >> t3) - where - ws = union ws1 ws2 - s2 = render_controlwire x ys ws c - t2 = render_multi_gate fs x ys label inv ws - t3 = render_controldots fs x ys c - show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")" - BoxId name shape = boxid - label = name ++ show_rep ++ if (subroutineshape fs) then (", shape " ++ shape) else "" - Comment s inv ws -> (return (), t1 >> t2) - where - t1 = render_comment fs (null ws) s' x (ymap 0) maxh - t2 = sequence_ [render_label fs (null s) l x (ymap w) | (w,l) <- ws] - s' = s ++ optional inv "*" - --- | Render the gates in the circuit. The parameters are: /xarity/: --- the 'Xarity' of the currently pending wires. /xgs/: the list of --- gates, paired with pre-computed /x/-coordinates. /ys/: a map from --- wires to pre-computed /y/-coordinates. /x/: the right-most --- /x/-coordinate where the final wires will be drawn to. /maxh/: the --- maximal height of comments. -render_gates :: FormatStyle -> Xarity -> [(Gate, X)] -> Map Wire Y -> X -> Y -> (Draw (), Draw ()) -render_gates fs xarity xgs ys x maxh = - case xgs of - [] -> - let s2 = render_xarity fs ys xarity x - in (s2, return ()) - (g,newx):gls -> - let (xarity_term, xarity_new) = update_xarity xarity g newx in - let s1 = render_xarity fs ys xarity_term newx in - let (s2, t2) = render_gate fs g newx ys maxh in - let (sx, tx) = render_gates fs xarity_new gls ys x maxh in - (s1 >> s2 >> sx, t2 >> tx) - --- | PostScript definitions of various parameters. -ps_parameters :: FormatStyle -> String -ps_parameters fs = - "% some parameters\n" - ++ printf "%f setlinewidth\n" (linewidth fs) - ++ printf "/gatepad %f def\n" (gatepad fs) - ++ printf "/gateheight %f def\n" (gateheight fs) - ++ printf "/stringbase %f def\n" (stringbase fs) - ++ printf "/dotradius %f def\n" (dotradius fs) - ++ printf "/oplusradius %f def\n" (oplusradius fs) - ++ printf "/crossradius %f def\n" (crossradius fs) - ++ printf "/barwidth %f def\n" (barwidth fs) - ++ printf "/barheight %f def\n" (barheight fs) - ++ printf "/dwidth %f def\n" (dwidth fs) - ++ printf "/dheight %f def\n" (dheight fs) - ++ printf "/maxgatelabelwidth %f def\n" (maxgatelabelwidth fs) - ++ printf "/maxlabelwidth %f def\n" (maxlabelwidth fs) - ++ printf "/maxnumberwidth %f def\n" (maxnumberwidth fs) - ++ "/gatefont { /Times-Roman findfont .5 scalefont setfont } def\n" - ++ "/labelfont { /Times-Roman findfont .3 scalefont setfont } def\n" - ++ "/commentfont { /Times-Roman findfont .3 scalefont setfont } def\n" - ++ "/numberfont { /Times-Roman findfont .5 scalefont setfont } def\n" - ++ "/labelcolor { 0 0 1 setrgbcolor } def\n" - ++ "/commentcolor { 1 0.2 0.2 setrgbcolor } def\n" - ++ "/numbercolor { 0 0.7 0 setrgbcolor } def\n" - --- | PostScript definitions for various drawing subroutines. The --- subroutines provided are: --- --- > x0 y0 x1 y1 line : draw a line from (x0,y0) to (x1,y1) --- > x0 y0 x1 y1 dashedline : draw a dashed line from (x0,y0) to (x1,y1) --- > x y h w rect : draw a rectangle of dimensions w x h centered at (x,y) --- > x y h w oval : draw an oval of dimensions w x h centered at (x,y) --- > x y dot : draw a filled dot at (x,y) --- > x y circ : draw an empty dot at (x,y) --- > x y oplus : draw a "not" gate at (x,y) --- > x y cross : draw a cross ("swap" gate component) at (x,y) --- > x y bar : draw an init/term bar at (x,y) --- > x y dbar : draw a dterm bar at (x,y) --- > name x y box : draw an empty box at (x,y), big enough to fit name --- > name x y gate : draw a named box at (x,y) --- > name x y circgate : draw a named round box at (x,y) --- > name x y gphase : draw a global phase gate (x,y) --- > b x y init : draw an "init" gate at (x,y), with state b --- > b x y term : draw a "term" gate at (x,y), with state b --- > b x y dterm : draw a "dterm" gate at (x,y), with state b --- > string x y m b comment : draw a vertical comment at (x,y), with max height m and baseline adjustment b --- > string x y clabel : draw a wire label at (x,y), x-centered --- > string x y rlabel : draw a wire label at (x,y), right of x --- > string x y lnumber : draw a numbered input at (x,y) --- > string x y rnumber : draw a numbered output at (x,y) - -ps_subroutines :: String -ps_subroutines = - "% subroutine definitions\n" - ++ "/line { moveto lineto stroke } bind def\n" - ++ "/dashedline { moveto gsave [0.3 0.2] .15 setdash lineto stroke grestore } bind def\n" - ++ "/rect { /H exch def /W exch def -.5 W mul .5 H mul moveto W 0 rlineto 0 H neg rlineto W neg 0 rlineto closepath } bind def\n" - ++ "/oval { /H exch def /W exch def gsave .5 W mul .5 H mul scale 0 0 1 0 360 newpath arc gsave 1.0 setgray fill grestore stroke grestore } bind def\n" - ++ "/dot { dotradius 0 360 newpath arc gsave 0 setgray fill grestore newpath } bind def\n" - ++ "/circ { dotradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke } bind def\n" - ++ "/oplus { gsave translate 0 0 oplusradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke 0 oplusradius neg 0 oplusradius line oplusradius neg 0 oplusradius 0 line grestore } bind def\n" - ++ "/cross { gsave translate crossradius dup dup neg dup line crossradius dup neg dup dup neg line grestore } bind def\n" - ++ "/bar { gsave translate barwidth barheight rect fill grestore } bind def\n" - ++ "/dbar { gsave translate barwidth 0.5 mul 0 translate dwidth dheight scale -1 -.5 moveto -.5 0 .5 -90 90 arc -1 .5 lineto closepath fill grestore } bind def\n" - ++ "/box { gsave translate gatefont stringwidth pop /w exch def /w1 w gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke grestore } bind def\n" - ++ "/gate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" - ++ "/circgate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 0.8 gateheight mul oval gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" - ++ "/gphase { gsave translate 0 -0.5 circgate grestore } bind def\n" - ++ "/init { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def -.5 w1 mul 0 translate 0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" - ++ "/term { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" - ++ "/dterm { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 dbar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n" - ++ "/comment { gsave /b exch def /maxh exch def /y exch def /x exch def commentfont commentcolor x y maxh sub x y 0.4 add 1.0 b textbox grestore } bind def\n" - ++ "/clabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth 2 mul div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale -0.5 w mul 0 moveto labelcolor show grestore } bind def\n" - ++ "/rlabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale 0 0 moveto labelcolor show grestore } bind def\n" - ++ "/lnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def -0.2 -0.15 translate 1 fontscale div dup scale -1 w mul 0 moveto numbercolor show grestore } bind def\n" - ++ "/rnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0.2 -0.15 translate 1 fontscale div dup scale 0 0 moveto numbercolor show grestore } bind def\n" - --- | @'page_of_ocircuit' name ocirc@: Render the circuit /ocirc/ on a --- single page. --- --- The rendering takes place in the following user coordinate system: --- --- \[image coord.png] -page_of_ocircuit :: FormatStyle -> Maybe BoxId -> OCircuit -> Document () -page_of_ocircuit fs boxid ocirc = do - newpage bboxx bboxy $ do - when (isJust boxid) $ do - comment ("drawing commands for " ++ string_of_boxid (fromJust boxid)) - - -- set up the user coordinate system - scale sc sc - translate ((xoff fs) + 1) 1 - - -- drawing commands - setlinewidth (linewidth fs) - when (isJust boxid) $ do - textbox align_left (gatefont fs) (foregroundcolor fs) (-(xoff fs)) (raw_height-0.25) raw_width (raw_height-0.25) (stringbase fs) ("Subroutine " ++ string_of_boxid (fromJust boxid) ++ ":") - rendered_wires - rendered_gates - render_ordering fs (-(xoff fs)) ys False w_in - render_ordering fs raw_width ys True w_out - where - -- unit scale: distance, in points, between wires - sc = 10 - - -- decompose OCircuit - OCircuit (w_in, circ, w_out) = ocirc - (a1,gs,a2,_) = circ - - -- figure out y-coordinates and height - ws = wirelist_of_circuit circ - raw_height = fromIntegral $ length ws - ys = Map.fromList (zip (reverse ws) [0.0 ..]) - maxh = raw_height + 0.3 - bboxy = sc * (raw_height + 1) - - -- figure out x-coordinates and width - (raw_width,xgs) = assign_x_coordinates fs gs 0.0 - bboxx = sc * (raw_width + (xoff fs) + 2.0) - - xa1 = IntMap.map (\t -> (t, -(xoff fs))) a1 - (rendered_wires, rendered_gates) = render_gates fs (Map.fromList (IntMap.assocs xa1)) xgs ys raw_width maxh - --- | Render a low-level boxed quantum circuit as a graphical --- 'Document'. If there are subroutines, each of them is placed on a --- separate page. -render_bcircuit :: FormatStyle -> BCircuit -> Document () -render_bcircuit fs (circ, namespace) = do - page_of_ocircuit fs Nothing (OCircuit ([], circ, [])) - sequence_ [ page_of_ocircuit fs (Just boxid) ocirc | (boxid, TypedSubroutine ocirc _ _ _) <- Map.toList namespace] - --- | Render a low-level dynamic quantum circuit as a graphical --- 'Document'. If there are subroutines, each of them is placed on a --- separate page. If the circuit uses dynamic lifting, an error is --- produced. -render_dbcircuit :: FormatStyle -> ErrMsg -> DBCircuit a -> Document () -render_dbcircuit fs e dbcirc = render_bcircuit fs bcirc where - (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc - errmsg x = e ("operation not permitted during graphical rendering: " ++ x) - --- | Print a representation of a low-level quantum circuit, in the --- requested graphics format, directly to standard output. If there --- are boxed subcircuits, each of them is placed on a separate page. -print_bcircuit_format :: FormatStyle -> BCircuit -> IO () -print_bcircuit_format fs bcirc = - render_custom_stdout (renderformat fs) cust (render_bcircuit fs bcirc) - where - cust = custom { - creator = "Quipper", - ps_defs = ps_parameters fs ++ ps_subroutines - } - --- | Print a representation of a low-level dynamic quantum circuit, in --- the requested graphics format, directly to standard output. If --- there are boxed subcircuits, each of them is placed on a separate --- page. If the circuit uses dynamic lifting, an error is produced. -print_dbcircuit_format :: FormatStyle -> ErrMsg -> DBCircuit a -> IO () -print_dbcircuit_format fs e dbcirc = - render_custom_stdout (renderformat fs) cust (render_dbcircuit fs e dbcirc) - where - cust = custom { - creator = "Quipper", - ps_defs = ps_parameters fs ++ ps_subroutines - } - --- ---------------------------------------------------------------------- --- * Interface to external programs - --- | @'system_pdf_viewer' zoom pdffile@: Call a system-specific PDF --- viewer on /pdffile/ file. The /zoom/ argument is out of 100 and may --- or may not be ignored by the viewer. -system_pdf_viewer :: Double -> String -> IO () -system_pdf_viewer zoom pdffile = do - envList <- getEnvironment - if (List.elem ("OS", "Windows_NT") envList) - then do - rawSystem "acroread.bat" [pdffile] - else if (os == "darwin") - then do - rawSystem "open" [pdffile] - rawSystem "sleep" ["1"] -- required or the file may be deleted too soon - else do - rawSystem "acroread" ["/a", "zoom=100", pdffile] - return () - --- ---------------------------------------------------------------------- --- * Previewing - --- | Display a document directly in Acrobat Reader. This may not be --- portable. It requires the external program \"acroread\" to be --- installed. -preview_document :: Document a -> IO a -preview_document = preview_document_custom custom - --- | Display a document directly in Acrobat Reader. This may not be --- portable. It requires the external program \"acroread\" to be --- installed. -preview_document_custom :: Custom -> Document a -> IO a -preview_document_custom custom doc = do - tmpdir <- getTemporaryDirectory - (pdffile, fd) <- openTempFile tmpdir "Quipper.pdf" - a <- render_custom_file fd Format_PDF custom doc - hClose fd - system_pdf_viewer 100 pdffile - removeFile pdffile - return a - --- | Display the circuit directly in Acrobat Reader. This may not be --- portable. It requires the external program \"acroread\" to be --- installed. -preview_bcircuit :: BCircuit -> IO () -preview_bcircuit bcirc = - preview_document doc - where - doc = render_bcircuit pdf bcirc - --- | Display a low-level dynamic quantum circuit directly in Acrobat --- Reader. This may not be portable. It requires the external program --- \"acroread\" to be installed. If the circuit uses dynamic lifting, --- an error is produced. -preview_dbcircuit :: ErrMsg -> DBCircuit a -> IO () -preview_dbcircuit e dbcirc = preview_bcircuit bcirc where - (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc - errmsg x = e ("operation not permitted for PDF preview: " ++ x) - --- ---------------------------------------------------------------------- --- * Gate counts - --- ** Gate types - --- $ The type 'Gate' contains too much information to be used as the --- index for counting gates: all 'CNot' gates, for instance, --- should be counted together, regardless of what wires they are --- applied to. --- --- We define 'Gatetype' to remedy this, with each value of --- 'Gatetype' corresponding to an equivalence class of --- gates as they should appear in gate counts. --- --- During gate counting, a little more information needs to be retained, --- so that operations such as adding controls to subroutine counts can --- be accurately performed. 'AnnGatetype' supplies this information. - --- | An abbreviated representation of the controls of a gate: --- the number of positive and negative controls, respectively. -type ControlType = (Int,Int) - --- | From a list of controls, extract the number of positive and --- negative controls. -controltype :: Controls -> ControlType -controltype c = - (length $ filter get_sign c, length $ filter (not . get_sign) c) - --- | Convenience constant for uncontrolled gates. -nocontrols :: ControlType -nocontrols = (0,0) - --- | A data type representing equivalence classes of basic gates, --- for the output of gatecounts. -data Gatetype = - Gatetype String ControlType - | GatetypeSubroutine BoxId InverseFlag ControlType - deriving (Eq, Ord, Show) - --- | A data type analogous to 'Gatetype', but with extra annotations, --- e.g. a 'NoControlFlag', for use in the computation of gate counts. -data AnnGatetype = - AnnGatetype String (Maybe String) ControlType NoControlFlag ControllableFlag - | AnnGatetypeSubroutine BoxId InverseFlag ControlType NoControlFlag ControllableFlag - deriving (Eq, Ord, Show) - --- | Forget the annotations of an 'AnnGatetype' -unannotate_gatetype :: AnnGatetype -> Gatetype -unannotate_gatetype (AnnGatetype n _ cs _ _) = Gatetype n cs -unannotate_gatetype (AnnGatetypeSubroutine n i cs _ _) = GatetypeSubroutine n i cs - --- | Add controls to an annotated gate type, or throw an error message if it is not controllable; --- unless its 'NoControlFlag' is set, in which case leave it unchanged. -add_controls_gatetype :: ErrMsg -> ControlType -> AnnGatetype -> AnnGatetype -add_controls_gatetype e (x',y') g@(AnnGatetype n n_inv (x,y) ncf cf) = - if ncf then g - else case cf of - AllCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf - OnlyClassicalCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf - NoCtl -> error $ e "add_controls_gatetype: gate " ++ n ++ " is not controllable." - -add_controls_gatetype e (x',y') g@(AnnGatetypeSubroutine n inv (x,y) ncf cf) = - if ncf then g - else case cf of - AllCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf - OnlyClassicalCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf - NoCtl -> error $ e "add_controls_gatetype: subroutine " ++ show n ++ " is not controllable." - --- | Reverse an annotated gate type, of throw an error if it is not reversible. -reverse_gatetype :: ErrMsg -> AnnGatetype -> AnnGatetype -reverse_gatetype e g@(AnnGatetype n n_inv cs ncf cf) = - case n_inv of - Just n' -> (AnnGatetype n' (Just n) cs ncf cf) - Nothing -> error $ e "reverse_gatetype: gate " ++ n ++ " is not reversible" -reverse_gatetype e g@(AnnGatetypeSubroutine n inv cs ncf cf) = - (AnnGatetypeSubroutine n (not inv) cs ncf cf) - --- | Set the 'NoControlFlag' of an annotated gate type to 'True'. -set_ncf_gatetype :: AnnGatetype -> AnnGatetype -set_ncf_gatetype (AnnGatetype n n_inv cs ncf cf) = - (AnnGatetype n n_inv cs True cf) -set_ncf_gatetype (AnnGatetypeSubroutine n inv cs ncf cf) = - (AnnGatetypeSubroutine n inv cs True cf) - --- | Helper function for 'gatetype': append a formatted arity to a string. -with_arity :: String -> Int -> String -n `with_arity` a = n ++ ", arity " ++ show a - --- | Convert a given low-level gate to an annotated gate type -gatetype :: Gate -> AnnGatetype -gatetype (QGate n inv ws vs c ncf) = - AnnGatetype (n' inv') (Just $ n' $ notinv') (controltype c) ncf AllCtl - where - n' b = (n ++ optional b "*") `with_arity` (length ws + length vs) - inv' = inv && not (self_inverse n ws vs) - notinv' = not inv && not (self_inverse n ws vs) -gatetype (QRot n inv t ws vs c ncf) = - AnnGatetype (n' inv) (Just $ n' $ not inv) (controltype c) ncf AllCtl - where n' b = (printf "Rot(%s,%f)" (n++ optional b "*") t) `with_arity` (length ws + length vs) -gatetype (GPhase t w c ncf) = - AnnGatetype (phase_name t) (Just $ phase_name (-t)) (controltype c) ncf AllCtl - where phase_name t = (printf "exp^(%f i pi)" t) -gatetype (CNot w c ncf) = - AnnGatetype "CNot" (Just "CNot") (controltype c) ncf AllCtl -gatetype (CGate n w ws ncf) = - AnnGatetype (n' True) (Just $ n' False) nocontrols ncf AllCtl - where n' b = n ++ optional b "*" `with_arity` length ws -gatetype (CGateInv n w ws ncf) = - AnnGatetype (n' False) (Just $ n' True) nocontrols ncf AllCtl - where n' b = n ++ optional b "*" `with_arity` length ws -gatetype (CSwap w v c ncf) = - AnnGatetype "CSwap" (Just "CSwap") (controltype c) ncf AllCtl -gatetype (QPrep w ncf) = - AnnGatetype "Prep" (Just "Unprep") nocontrols ncf NoCtl -gatetype (QUnprep w ncf) = - AnnGatetype "Unprep" (Just "Prep") nocontrols ncf NoCtl -gatetype (QInit b w ncf) = - AnnGatetype ("Init" ++ b') (Just $ "Term" ++ b') nocontrols ncf NoCtl - where b' = show $ if b then 1 else 0 -gatetype (CInit b w ncf) = - AnnGatetype ("CInit" ++ b') (Just $ "CTerm" ++ b') nocontrols ncf NoCtl - where b' = show $ if b then 1 else 0 -gatetype (QTerm b w ncf) = - AnnGatetype ("Term" ++ b') (Just $ "Init" ++ b') nocontrols ncf NoCtl - where b' = show $ if b then 1 else 0 -gatetype (CTerm b w ncf) = - AnnGatetype ("CTerm" ++ b') (Just $ "CInit" ++ b') nocontrols ncf NoCtl - where b' = show $ if b then 1 else 0 -gatetype (QMeas w) = - AnnGatetype "Meas" Nothing nocontrols False NoCtl -gatetype (QDiscard w) = - AnnGatetype "Discard" Nothing nocontrols False NoCtl -gatetype (CDiscard w) = - AnnGatetype "CDiscard" Nothing nocontrols False NoCtl -gatetype (DTerm b w) = - AnnGatetype "CDiscard" Nothing nocontrols False NoCtl -gatetype (Subroutine boxid inv ws1 a1 ws2 a2 c ncf ctrble reps) = - AnnGatetypeSubroutine boxid inv (controltype c) ncf ctrble -gatetype (Comment _ inv ws) = AnnGatetype ("Comment") (Just "Comment") nocontrols True NoCtl - --- | Convert a gate type to a human-readable string. -string_of_gatetype :: Gatetype -> String -string_of_gatetype (Gatetype s (c1,c2)) = - printf "\"%s\"" s - ++ if c2==0 && c1==0 then "" else - if c2==0 then printf ", controls %d" c1 else - printf " controls %d+%d" c1 c2 -string_of_gatetype (GatetypeSubroutine boxid i (c1,c2)) = - "Subroutine" ++ optional i "*" ++ cs ++ ": " ++ string_of_boxid boxid - where - cs = if c2==0 && c1==0 then "" else - if c2==0 then printf ", controls %d" c1 else - printf " controls %d+%d" c1 c2 - --- ** Gate counts - --- | Gate counts of circuits. -type Gatecount = Map Gatetype Integer - --- | Annotated gate counts of circuits. -type AnnGatecount = Map AnnGatetype Integer - --- | Given the (annotated) gatecount of a circuit, return the gatecount of --- the reverse circuit, or throw an error if any component is not reversible. -reverse_gatecount :: ErrMsg -> AnnGatecount -> AnnGatecount -reverse_gatecount e = Map.mapKeysWith (+) (reverse_gatetype e) - --- | Given the (annotated) gatecount of a circuit, return the gatecount of --- the same circuit with controls added, or throw an error if any component --- is not controllable. -add_controls_gatecount :: ErrMsg -> ControlType -> AnnGatecount -> AnnGatecount -add_controls_gatecount e cs = Map.mapKeysWith (+) (add_controls_gatetype e cs) - --- | Set the ncf of all gates in a gatecount to 'True'. -set_ncf_gatecount :: AnnGatecount -> AnnGatecount -set_ncf_gatecount = Map.mapKeysWith (+) set_ncf_gatetype - --- | Remove the annotations from a gatecount. -unannotate_gatecount :: AnnGatecount -> Gatecount -unannotate_gatecount = Map.mapKeysWith (+) unannotate_gatetype - --- | Input a list of items and output a map from items to counts. --- Example: --- --- > count ['a', 'b', 'a'] = Map.fromList [('a',2), ('b',1)] -count :: (Ord a, Num int) => [(int,a)] -> Map a int -count list = - foldl' (\mp (i,x) -> Map.insertWith' (+) x i mp) Map.empty list - --- | Count the number of gates of each type in a circuit, with annotations, --- treating subroutine calls as atomic gates. -anngatecount_of_circuit :: Circuit -> AnnGatecount -anngatecount_of_circuit (_,gs,_,_) = count $ map (\x -> (repeated x, gatetype x)) $ filter (not . is_comment) gs - where - is_comment (Comment _ _ _) = True - is_comment _ = False - repeated (Subroutine _ _ _ _ _ _ _ _ _ (RepeatFlag repeat)) = repeat - repeated _ = 1 - --- | Count the number of gates of each type in a circuit, --- treating subroutine calls as atomic gates. -gatecount_of_circuit :: Circuit -> Gatecount -gatecount_of_circuit = unannotate_gatecount . anngatecount_of_circuit - --- | Given an 'AnnGatetype' describing a subroutine call --- (possibly repeated), --- and a gate count for the subroutine itself, return the gatecount --- of the subroutine call. --- --- (This may be the reverse of the original subroutine, may have --- controls added, etc.) -gatecount_of_subroutine_call :: ErrMsg -> AnnGatetype -> RepeatFlag -> AnnGatecount -> AnnGatecount -gatecount_of_subroutine_call e (AnnGatetypeSubroutine boxid inv cs ncf ctrble) (RepeatFlag reps) = - (if inv then reverse_gatecount err_inv else id) - . (if cs == nocontrols then id - else case ctrble of - AllCtl -> add_controls_gatecount err_ctrl cs - OnlyClassicalCtl -> add_controls_gatecount err_ctrl cs - NoCtl -> error $ err_ctrble) - . (if reps == 1 then id else (Map.map (* reps))) - . (if ncf then set_ncf_gatecount else id) - where - err_inv = e . (("gatecount_of_subroutine_call, inverting subroutine " ++ longname ++ ": ") ++) - err_ctrl = e . (("gatecount_of_subroutine_call, controlling subroutine " ++ longname ++ ": ") ++) - err_ctrble = e $ "gatecount_of_subroutine_call: subroutine " ++ longname ++ " not controllable" - longname = string_of_boxid boxid - -gatecount_of_subroutine_call e _ _ = error $ e "internal error (gatecount_of_subroutine_call called on non-subroutine)" - --- | Given a circuit and gatecounts for its subroutines, --- give an (aggregated) gatecount for the circuit. -anngatecount_of_circuit_with_sub_cts :: ErrMsg -> Map BoxId AnnGatecount -> Circuit -> AnnGatecount -anngatecount_of_circuit_with_sub_cts e sub_cts (_,gs,_,_) = - foldr action Map.empty gs - where - action (Comment _ _ _) = id - action g@(Subroutine n _ _ _ _ _ _ _ _ reps) = - case Map.lookup n sub_cts of - Nothing -> error $ e $ "subroutine not found: " ++ show n - Just n_ct -> flip (Map.unionWith (+)) $ - gatecount_of_subroutine_call e (gatetype g) reps n_ct - action g = Map.insertWith' (+) (gatetype g) 1 - --- | Give the aggregate gate count of a 'BCircuit'; that is, the --- the total count of basic gates once all subroutines are fully inlined. -aggregate_gatecounts_of_bcircuit :: BCircuit -> Gatecount -aggregate_gatecounts_of_bcircuit (main_circ, namespace) - = unannotate_gatecount $ - anngatecount_of_circuit_with_sub_cts e sub_cts main_circ - where - sub_cts = Map.map (anngatecount_of_circuit_with_sub_cts e sub_cts . circuit_of_typedsubroutine) namespace - e = ("aggregate_gatecounts_of_bcircuit: " ++) - --- ** Wire usage count - --- | Count by how much a low-level gate changes the number of wires in the arity. - --- Implementation note: writing this function explicitly case-by-case appears --- very slightly faster (~0.5%), but more fragile/less maintainable. -gate_wires_change :: Gate -> Integer -gate_wires_change g = - let (a_in,a_out) = gate_arity g - in fromIntegral $ length a_out - length a_in - --- | Find the maximum number of wires used simultaneously in a 'BCircuit', --- assuming all subroutines inlined. -aggregate_maxwires_of_bcircuit :: BCircuit -> Integer -aggregate_maxwires_of_bcircuit (main_circ, namespace) - = maxwires_of_circuit_with_sub_maxwires e sub_maxs main_circ - where - e = ("aggregate_maxwires_of_bcircuit: " ++) - sub_maxs = Map.map (maxwires_of_circuit_with_sub_maxwires e sub_maxs . circuit_of_typedsubroutine) namespace - --- | Given a circuit and gatecounts for its subroutines, --- give an (aggregated) gatecount for the circuit. -maxwires_of_circuit_with_sub_maxwires :: ErrMsg -> Map BoxId Integer -> Circuit -> Integer -maxwires_of_circuit_with_sub_maxwires e sub_maxs (a1,gs,a2,_) = - snd $ foldl (flip action) (in_wires, in_wires) gs - where - in_wires = fromIntegral $ IntMap.size a1 - update w_change (!w_old, !wmax_old) = --- Implementation note: strictness in this pattern is to avoid putting the whole --- tower of “max” applications on the stack. - let w_new = w_old + w_change in (w_new, max wmax_old w_new) - action g@(Subroutine n _ ws1 _ ws2 _ _ _ _ (RepeatFlag r)) = - case Map.lookup n sub_maxs of - Nothing -> error $ "subroutine not found: " ++ show n - Just n_max -> (update $ (fromIntegral $ length ws2) - n_max) - . (update $ n_max - (fromIntegral $ length ws1)) - action g = update $ gate_wires_change g - --- ** Printing gate counts - --- | Print a gate count, as a table of integers and gate types. -print_gatecount :: Gatecount -> IO () -print_gatecount cts = mapM_ - (\(gt,k) -> putStr (printf ("%" ++ show max_digits ++ "d: %s\n") k (string_of_gatetype gt))) - (Map.assocs cts) - where - max_digits = maximum $ 5:(map ((1+) . floor . logBase 10 . fromIntegral) (Map.elems cts)) - --- | Print the simple gate count, plus summary information, for a simple circuit. -print_gatecounts_circuit :: Circuit -> IO () -print_gatecounts_circuit circ@(a1,gs,a2,n) = do - print_gatecount cts - putStrLn $ printf "Total gates: %d" $ sum $ Map.elems cts - putStrLn $ printf "Inputs: %d" $ IntMap.size a1 - putStrLn $ printf "Outputs: %d" $ IntMap.size a2 - putStrLn $ printf "Qubits in circuit: %d" n - where - cts = gatecount_of_circuit circ - --- | Print gate counts for a boxed circuit: --- first the simple gate count for each subroutine separately, --- then the aggregated count for the whole circuit. -print_gatecounts_bcircuit :: BCircuit -> IO () -print_gatecounts_bcircuit bcirc@(circ@(a1,_,a2,_),namespace) = do - print_gatecounts_circuit circ - when (not $ Map.null namespace) $ do - sequence_ [ (putStrLn "") >> (print_gatecounts_subroutine sub) | sub <- Map.toList namespace ] - putStrLn "" - putStrLn "Aggregated gate count:" - let aggregate_cts = aggregate_gatecounts_of_bcircuit bcirc - maxwires = aggregate_maxwires_of_bcircuit bcirc - print_gatecount aggregate_cts - putStrLn $ printf "Total gates: %d" $ sum $ Map.elems aggregate_cts - putStrLn $ printf "Inputs: %d" $ IntMap.size a1 - putStrLn $ printf "Outputs: %d" $ IntMap.size a2 - putStrLn $ printf "Qubits in circuit: %d" maxwires - --- | Print gate counts for a named subroutine. -print_gatecounts_subroutine :: (BoxId, TypedSubroutine) -> IO () -print_gatecounts_subroutine (boxid, TypedSubroutine ocirc _ _ _) = do - putStrLn ("Subroutine: " ++ show name) - putStrLn ("Shape: " ++ show shape) - print_gatecounts_circuit circ - where - OCircuit (_, circ, _) = ocirc - BoxId name shape = boxid - --- | Print gate counts for a static 'DBCircuit'. The circuit may not --- use any dynamic lifting, or else an error will be produced. -print_gatecounts_dbcircuit :: ErrMsg -> DBCircuit a -> IO () -print_gatecounts_dbcircuit e dbcirc = print_gatecounts_bcircuit bcirc where - (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc - errmsg x = e ("operation not permitted during gate count: " ++ x) - --- ---------------------------------------------------------------------- --- * Printing to multiple formats - --- | Available output formats. - -data Format = - EPS -- ^ Encapsulated PostScript graphics. - | PDF -- ^ Portable Document Format. One circuit per page. - | PS -- ^ PostScript. One circuit per page. - | ASCII -- ^ A textual representation of circuits. - | Preview -- ^ Don't print anything, but preview directly on screen (requires the external program /acroread/). - | GateCount -- ^ Print statistics on gate counts. - | CustomStyle FormatStyle - deriving Show - --- | A mapping from lower-case strings (to be used, e.g., with command --- line options) to available formats. -format_enum :: [(String, Format)] -format_enum = [ - ("eps", EPS), - ("pdf", PDF), - ("ps", PS), - ("postscript", PS), - ("ascii", ASCII), - ("preview", Preview), - ("gatecount", GateCount) - ] - --- | Print a low-level quantum circuit directly to the IO monad, using --- the specified format. -print_dbcircuit :: Format -> ErrMsg -> DBCircuit a -> IO () -print_dbcircuit EPS = print_dbcircuit_format eps -print_dbcircuit PDF = print_dbcircuit_format pdf -print_dbcircuit PS = print_dbcircuit_format ps -print_dbcircuit ASCII = print_dbcircuit_ascii -print_dbcircuit Preview = preview_dbcircuit -print_dbcircuit GateCount = print_gatecounts_dbcircuit -print_dbcircuit (CustomStyle fs) = print_dbcircuit_format fs - --- | Print a document to the requested format, which must be one of --- 'PS', 'PDF', 'EPS', or 'Preview'. -print_of_document :: Format -> Document a -> IO a -print_of_document = print_of_document_custom custom - --- | Like 'print_of_document', but also takes a 'Custom' data --- structure. -print_of_document_custom :: Custom -> Format -> Document a -> IO a -print_of_document_custom custom PS doc = render_custom_stdout Format_PS custom doc -print_of_document_custom custom PDF doc = render_custom_stdout Format_PDF custom doc -print_of_document_custom custom EPS doc = render_custom_stdout (Format_EPS 1) custom doc -print_of_document_custom custom Preview doc = preview_document_custom custom doc -print_of_document_custom custom format doc = error ("print_of_document: method " ++ show format ++ " can't be used in this context") - --- ====================================================================== --- * Generic printing - --- | Like 'print_unary', but also takes a stub error message. -print_errmsg :: (QCData qa) => ErrMsg -> Format -> (qa -> Circ b) -> qa -> IO () -print_errmsg e format f shape = print_dbcircuit format e dbcircuit - where - (in_bind, dbcircuit) = encapsulate_dynamic f shape - --- | Print a circuit generating function to the specified format; this --- requires a shape parameter. -print_unary :: (QCData qa) => Format -> (qa -> Circ b) -> qa -> IO () -print_unary = print_errmsg errmsg - where - errmsg x = "print_unary: " ++ x - --- | Print a circuit generating function to the specified --- format. Unlike 'print_unary', this can be applied to a --- circuit-generating function in curried form with /n/ arguments, for --- any /n >= 0/. It then requires /n/ shape parameters. --- --- The type of this heavily overloaded function is difficult to --- read. In more readable form, it has all of the following types: --- --- > print_generic :: Format -> Circ qa -> IO () --- > print_generic :: (QCData qa) => Format -> (qa -> Circ qb) -> a -> IO () --- > print_generic :: (QCData qa, QCData qb) => Format -> (qa -> qb -> Circ qc) -> a -> b -> IO () --- --- and so forth. - -print_generic :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO())) => Format -> qfun -> fun -print_generic format f = g where - f1 = quncurry f - g1 = print_errmsg errmsg format f1 - g = mcurry g1 - errmsg x = "print_generic: " ++ x - --- | Like 'print_generic', but only works at simple types, and --- therefore requires no shape parameters. -print_simple :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO()), QCData_Simple qa) => Format -> qfun -> IO () -print_simple format f = print_errmsg errmsg format f1 fs_shape where - f1 = quncurry f - errmsg x = "print_simple: " ++ x diff --git a/src/Quipper/QClasses.hs b/src/Quipper/QClasses.hs deleted file mode 100644 --- a/src/Quipper/QClasses.hs +++ /dev/null @@ -1,140 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE FlexibleContexts #-} - --- | This module defines quantum analogues of some Haskell type --- classes. For instance, Haskell’s @'Eq' a@ has one method --- --- > (==) :: a -> a -> Bool. --- --- Correspondingly, our @'QEq' a qa ca@ has a method --- --- > q_is_equal :: qa -> qa -> Circ (qa,qa,Qubit). --- --- All quantum type classes assume that their instance types are --- 'QData' (or sometimes 'QCData'). --- --- Quantum type classes are designed to play nicely with the --- translation of "Quipper.CircLifting". - -module Quipper.QClasses where - -import Quipper.Generic -import Quipper.QData -import Quipper.Monad - --- ---------------------------------------------------------------------- --- * The type class QEq - --- | This is a quantum analogue of Haskell’s 'Eq' type class. Default --- implementations are provided; by default, equality is bitwise --- equality of the underlying data structure. However, specific --- instances can provide custom implementations. In this case, --- 'q_is_equal' is a minimal complete definition. -class (QCData qc) => QEq qc where - - -- | Test for equality. - q_is_equal :: qc -> qc -> Circ (qc, qc, Qubit) - q_is_equal qx qy = do - (qx,qy) <- controlled_not qx qy - test <- qinit False - test <- qnot test `controlled` qx .==. qc_false qx - (qx,qy) <- reverse_generic_endo controlled_not qx qy - return (qx,qy,test) - - -- | Test for inequality. - q_is_not_equal :: qc -> qc -> Circ (qc, qc, Qubit) - q_is_not_equal qx qy = do - (qx,qy,test) <- q_is_equal qx qy - qnot_at test - return (qx,qy,test) - --- Right now we make all QCData an instance of 'QEq', and the equality --- is always physical equality. In the future we will probably want to --- replace this by instances for specific types. -instance (QCData qc) => QEq qc - --- ---------------------------------------------------------------------- --- * The type class QOrd - --- | This is a quantum analogue of Haskell's 'Ord' type class. Its --- purpose is to define a total ordering on each of its instances. The --- functions in this class are assumed dirty in the sense that they do --- not uncompute ancillas, and some of the inputs may be returned as --- outputs. The functions are also assumed to be non-linear safe, --- i.e., they apply no gates to their inputs except as control --- sources. Minimal complete definition: 'q_less' or 'q_greater'. The default --- implementations of 'q_max' and 'q_min' assume that both arguments --- are of the same shape (for example, numbers of the same length). -class (QEq qa, QData qa) => QOrd qa where - -- | Test for less than. - q_less :: qa -> qa -> Circ Qubit - q_less x y = q_greater y x - - -- | Test for greater than. - q_greater :: qa -> qa -> Circ Qubit - q_greater x y = q_less y x - - -- | Test for less than or equal. - q_leq :: qa -> qa -> Circ Qubit - q_leq x y = do - s <- q_greater x y - r <- qinit False - qnot_at r `controlled` s .==. False - return r - - -- | Test for greater than or equal. - q_geq :: qa -> qa -> Circ Qubit - q_geq x y = q_leq y x - - -- | Compute the maximum of two values. - q_max :: qa -> qa -> Circ qa - q_max x y = do - q <- q_greater x y - z <- qinit $ qc_false x - (z,x) <- controlled_not z x `controlled` q .==. True - (z,y) <- controlled_not z y `controlled` q .==. False - return z - - -- | Compute the minimum of two values. - q_min :: qa -> qa -> Circ qa - q_min x y = do - q <- q_less x y - z <- qinit $ qc_false x - (z,x) <- controlled_not z x `controlled` q .==. True - (z,y) <- controlled_not z y `controlled` q .==. False - return z - --- =========================================== --- * Functionally-typed wrappers for 'QOrd' methods - --- | @'q_lt' /qx/ /qy/@: test whether /qx/ < /qy/. A functionally typed wrapper for 'q_less'. -q_lt :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) -q_lt qx qy = do - test <- q_less qx qy - return (qx,qy,test) - --- | @'q_gt' /qx/ /qy/@: test whether /qx/ > /qy/. A functionally typed wrapper for 'q_greater'. -q_gt :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) -q_gt qx qy = do - test <- q_greater qx qy - return (qx,qy,test) - --- | @'q_le' /qx/ /qy/@: test whether /qx/ ≤ /qy/. A functionally typed wrapper for 'q_leq'. -q_le :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) -q_le qx qy = do - test <- q_leq qx qy - return (qx,qy,test) - --- | @'q_ge' /qx/ /qy/@: test whether /qx/ ≥ /qy/. A functionally typed wrapper for 'q_geq'. -q_ge :: (QOrd qa) => qa -> qa -> Circ (qa,qa,Qubit) -q_ge qx qy = do - test <- q_geq qx qy - return (qx,qy,test) diff --git a/src/Quipper/QData.hs b/src/Quipper/QData.hs deleted file mode 100644 --- a/src/Quipper/QData.hs +++ /dev/null @@ -1,1358 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS -fcontext-stack=50 #-} - --- -O0 is needed for this file, because -O1 triggers a compiler bug in --- ghc 7.2.2 (see http://hackage.haskell.org/trac/ghc/ticket/6168), --- and -O2 triggers a different compiler bug in ghc 7.2.2 - -{-# OPTIONS_GHC -O0 #-} - --- | This module provides type classes for dealing with various --- \"shaped\" quantum and classical data structures. Examples of data --- structures are tuples, lists, records, registers, arrays, indexed --- arrays, etc. Is it convenient to extend certain operations to --- arbitrary quantum data structures; for example, instead of --- measuring a single qubit and obtaining a bit, one may measure an --- /n/-tuple of qubits and obtain an /n/-tuple of bits. We call an --- operation \"generic\" if it can act on arbitrary data structures. --- --- This module provides shaped types and low-level combinators, in --- terms of which higher-level generic quantum operations can be --- defined. --- --- The low-level combinators provided by this module (with names --- /qcdata_*/ and /qdata_*/) should never be used directly in user --- code (and for this reason, they are not re-exported by --- "Quipper"). Instead, they are intended as building blocks for --- user-level generic functions (in "Quipper.Generic" and related --- modules). The only exception is that the functions may be used in --- libraries or user-level code to define new quantum data --- constructors. Modules that contain such definitions should import --- 'Quipper.Internal'. - -module Quipper.QData where - --- import other Quipper stuff -import Quipper.Monad -import Libraries.Auxiliary -import Libraries.Tuple -import Quipper.Labels -import Quipper.Transformer -import Quipper.Control - -import Data.Typeable -import Libraries.Typeable -import Control.Monad.State - --- ====================================================================== --- * Introduction - --- $ The data types we consider here come in two varieties: --- /homogeneous/ and /heterogeneous/ types. --- --- A /homogeneous/ data type describes a data structure that is built --- up from only one kind of basic data (for example, only qubits, only --- classical bits, or only boolean parameters). The following are --- typical examples of homogeneous types: --- --- > qa = (Qubit, Qubit, [Qubit]) --- > ca = (Bit, Bit, [Bit]) --- > ba = (Bool, Bool, [Bool]). --- --- An important feature of homogeneous types is that they can be --- related to each other by shape. For example, /ca/ above is the --- \"classical version\" of /qa/. We say that the above types /qa/, --- /ca/, and /ba/ all share the same /shape type/. On the other hand, --- they differ in their /leaf types/, which are 'Qubit', 'Bit', and --- 'Bool', respectively. --- --- When naming types, variables, and operations related to homogeneous --- data structures, we often use letters such as /q/, /c/, and /b/ to --- denote, respectively, the quantum, classical, and boolean versions --- of some concept. --- --- Homogeneous types are made available to Quipper programs via the --- 'QData' and 'QShape' type classes. --- --- A /heterogeneous/ data type describes a data structure that may --- contain both classical and quantum bits. A typical example of a --- heterogeneous type is: --- --- > qc = (Qubit, Bit, [Qubit]). --- --- Heterogeneous types are often used to represent sets of --- endpoints of a circuit, or the inputs or outputs to some circuit --- building function. We often use the letters /qc/ in connection with --- heterogeneous types. --- --- Heterogeneous types are made available to Quipper programs via the --- 'QCData' and 'QCDataPlus' type classes. - --- ====================================================================== --- * Primitive definitions - --- $ The type classes of this module are all derived from four --- primitive items, which must be defined by induction on types: --- --- * A type class 'QCData' /qc/, representing structured data types --- made up from classical and quantum leaves. --- --- * A type family 'QCType' /x/ /y/ /qc/, representing the type-level --- substitution operation [nobr /qc/ [/x/ \/ 'Qubit', /y/ \/ 'Bit']]. --- --- * A type family 'QTypeB' /ba/, representing the type-level substitution --- [nobr /ba/ ['Qubit' \/ 'Bool']]. --- --- * A type class 'SimpleType' /qc/, representing \"simple\" data --- types. We say that a data type /t/ is \"simple\" if any two --- elements of /t/ have the same number of leaves. For example, tuples --- are simple, but lists are not. --- --- An instance of 'QCData', 'QCType' and 'QTypeB' must be defined for --- each new kind of quantum data. If the quantum data is simple, an --- instance of 'SimpleType' must also be defined. --- --- All other notions in this module are defined in terms of the above --- four, and therefore need not be defined on a per-type basis. - --- ---------------------------------------------------------------------- --- ** The QCType operation - --- | The type 'QCType' /x/ /y/ /a/ represents the substitution --- [nobr /a/ [/x/ \/ 'Qubit', /y/ \/ 'Bit']]. For example: --- --- > QCType x y (Qubit, Bit, [Qubit]) = (x, y, [x]). --- --- An instance of this must be defined for each new kind of quantum --- data. -type family QCType x y a -type instance QCType x y Qubit = x -type instance QCType x y Bit = y - -type instance QCType x y () = () -type instance QCType x y (a,b) = (QCType x y a, QCType x y b) -type instance QCType x y (a,b,c) = (QCType x y a, QCType x y b, QCType x y c) -type instance QCType x y (a,b,c,d) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d) -type instance QCType x y (a,b,c,d,e) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e) -type instance QCType x y (a,b,c,d,e,f) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f) -type instance QCType x y (a,b,c,d,e,f,g) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g) -type instance QCType x y (a,b,c,d,e,f,g,h) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h) -type instance QCType x y (a,b,c,d,e,f,g,h,i) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h, QCType x y i) -type instance QCType x y (a,b,c,d,e,f,g,h,i,j) = (QCType x y a, QCType x y b, QCType x y c, QCType x y d, QCType x y e, QCType x y f, QCType x y g, QCType x y h, QCType x y i, QCType x y j) -type instance QCType x y [a] = [QCType x y a] -type instance QCType x y (B_Endpoint a b) = B_Endpoint (QCType x y a) (QCType x y b) -type instance QCType x y (Signed a) = Signed (QCType x y a) - --- ---------------------------------------------------------------------- --- ** The QTypeB operation - --- | The type 'QTypeB' /ba/ represents the substitution --- [nobr /ba/ ['Qubit' \/ 'Bool']]. For example: --- --- > QTypeB (Bool, Bool, [Bool]) = (Qubit, Qubit, [Qubit]). --- --- An instance of this must be defined for each new kind of quantum data. -type family QTypeB a -type instance QTypeB Bool = Qubit -type instance QTypeB () = () -type instance QTypeB (a,b) = (QTypeB a, QTypeB b) -type instance QTypeB (a,b,c) = (QTypeB a, QTypeB b, QTypeB c) -type instance QTypeB (a,b,c,d) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d) -type instance QTypeB (a,b,c,d,e) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e) -type instance QTypeB (a,b,c,d,e,f) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f) -type instance QTypeB (a,b,c,d,e,f,g) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g) -type instance QTypeB (a,b,c,d,e,f,g,h) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h) -type instance QTypeB (a,b,c,d,e,f,g,h,i) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h, QTypeB i) -type instance QTypeB (a,b,c,d,e,f,g,h,i,j) = (QTypeB a, QTypeB b, QTypeB c, QTypeB d, QTypeB e, QTypeB f, QTypeB g, QTypeB h, QTypeB i, QTypeB j) -type instance QTypeB [a] = [QTypeB a] -type instance QTypeB (B_Endpoint a b) = B_Endpoint (QTypeB a) (QTypeB b) -type instance QTypeB (Signed a) = Signed (QTypeB a) - --- ---------------------------------------------------------------------- --- ** The QCData class - --- $ The 'QCData' class provides only three primitive combinators: --- 'qcdata_mapM', 'qcdata_zip', and 'qcdata_promote'. These are --- sufficient to define all other shape-generic operations. --- --- An instance of this must be defined for each new kind of quantum data. --- --- The functions 'qcdata_mapM' and 'qcdata_zip' require \"shape type --- parameters\". These are dummy arguments whose /value/ is ignored, --- but whose /type/ is used to determine the shape of the data to map --- over. The dummy terms @'qubit' :: 'Qubit'@ and @'bit' :: 'Bit'@ may --- be used to represent leaves in shape type arguments. --- --- Note to programmers defining new 'QCData' instances: Instances --- /must/ ensure that the functions 'qcdata_mapM' and 'qcdata_zip' --- do not evaluate their dummy arguments. These arguments will often --- be 'undefined'. In particular, if using a pattern match on this --- argument, only a variable or a /lazy/ pattern can be used. - --- | The 'QCData' type class contains heterogeneous data types built --- up from leaves of type 'Qubit' and 'Bit'. It is the basis for --- several generic operations that apply to classical and quantum --- data, such as copying, transformers, simulation, and heterogeneous --- versions of qterm and qdiscard. --- --- 'QCData' and 'QData' are interrelated, in the sense that the --- following implications hold: --- --- > QData qa implies QCData qa --- > CData ca implies QCData ca --- --- Implications in the converse direction also hold whenever /qc/ is a --- fixed known type: --- --- > QCData qc implies QData (QType qc) --- > QCData qc implies CData (CType qc) --- > QCData qc implies BData (BType qc) --- --- However, the type checker cannot prove the above implication in the --- case where /qc/ is a type variable; for this, the more flexible --- (but more computationally expensive) 'QCDataPlus' class can be used. - -class (Labelable qc String, - Typeable qc, - Show qc, - Show (LType qc), - qc ~ QCType Qubit Bit qc, - CType (QType qc) ~ CType qc, - BType (CType qc) ~ BType qc, - QCType Int Bool (CType qc) ~ BType qc - ) => QCData qc where - -- | Map two functions /f/ and /g/ over all the leaves of a - -- heterogeneous data structure. Apply /f/ to all the leaves at - -- 'Qubit' positions, and 'g' to all the leaves at 'Bit' positions. - -- The first argument is a shape type parameter. - -- - -- Example (ignoring the monad for the sake of simplicity): - -- - -- > qcdata_mapM (qubit, bit, [qubit]) f g (x,y,[z,w]) = (f x, g y, [f z, f w]). - -- - -- For data types that have a sense of direction, the mapping should - -- preferably be performed from left to right, but this property is - -- not guaranteed and may change without notice. - qcdata_mapM :: (Monad m) => qc -> (q -> m q') -> (c -> m c') -> QCType q c qc -> m (QCType q' c' qc) - - -- | Zip two heterogeneous data structures together, to obtain a new - -- data structure of the same shape, whose elements are pairs of the - -- corresponding elements of the input data structures. The zipping - -- is /strict/, meaning that both input data structure must have - -- exactly the same shape (same length of lists, etc). The first - -- five arguments are shape type parameters, representing the shape - -- of the data structure, the two leaf types of the first data - -- structure, and the two leaf types of the second data structure, - -- respectively. - -- - -- Example: - -- - -- > qcdata_zip (bit, [qubit]) int bool char string (True, [2,3]) ("b", ['c', 'd']) = ((True, "b"), [(2,'c'), (3,'d')]) - -- > where the shape parameters are: - -- > int = dummy :: Int - -- > bool = dummy :: Bool - -- > char = dummy :: Char - -- > string = dummy :: String - -- - -- The 'ErrMsg' argument is a stub error message to be used in - -- case of failure. - qcdata_zip :: qc -> q -> c -> q' -> c' -> QCType q c qc -> QCType q' c' qc -> ErrMsg -> QCType (q, q') (c, c') qc - - -- | It is sometimes convenient to have a boolean parameter with - -- some aspect of its shape indeterminate. The function - -- 'qcdata_promote' takes such a boolean parameter, as well as a - -- piece of 'QCData', and attempts to set the shape of the former to - -- that of the latter. - -- - -- The kinds of promotions that are allowed depend on the data type. - -- For example, for simple types, 'qcdata_promote' has no work to - -- do and should just return the first argument. For types that are - -- not simple, but where no promotion is desired (e.g. 'Qureg'), - -- 'qcdata_promote' should check that the shapes of the first and - -- second argument agree, and throw an error otherwise. For lists, - -- we allow a longer list to be promoted to a shorter one, but not - -- the other way around. For quantum integers, we allow an integer - -- of indeterminate length to be promoted to a determinate length, - -- but we do not allow a determinate length to be changed to another - -- determinate length. - -- - -- The 'ErrMsg' argument is a stub error message to be used in - -- case of failure. - qcdata_promote :: BType qc -> qc -> ErrMsg -> BType qc - -instance QCData Qubit where - qcdata_mapM shape f g = f - qcdata_zip shape q c q' c' x y e = (x, y) - qcdata_promote a x e = a - -instance QCData Bit where - qcdata_mapM shape f g = g - qcdata_zip shape q c q' c' x y e = (x, y) - qcdata_promote a x e = a - -instance QCData () where - qcdata_mapM shape f g x = return () - qcdata_zip shape q c q' c' x y e = () - qcdata_promote a x e = a - -instance (QCData a, QCData b) => QCData (a,b) where - qcdata_mapM ~(a,b) f g (x,y) = do - x' <- qcdata_mapM a f g x - y' <- qcdata_mapM b f g y - return (x', y') - qcdata_zip ~(a,b) q c q' c' (x1, x2) (y1, y2) e = (z1, z2) where - z1 = qcdata_zip a q c q' c' x1 y1 e - z2 = qcdata_zip b q c q' c' x2 y2 e - qcdata_promote (a,b) (x,y) e = (qcdata_promote a x e, qcdata_promote b y e) - -instance (QCData a, QCData b, QCData c) => QCData (a,b,c) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d) => QCData (a,b,c,d) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e) => QCData (a,b,c,d,e) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f) => QCData (a,b,c,d,e,f) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g) => QCData (a,b,c,d,e,f,g) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h) => QCData (a,b,c,d,e,f,g,h) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h, QCData i) => QCData (a,b,c,d,e,f,g,h,i) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a, QCData b, QCData c, QCData d, QCData e, QCData f, QCData g, QCData h, QCData i, QCData j) => QCData (a,b,c,d,e,f,g,h,i,j) where - qcdata_mapM s f g xs = mmap tuple $ qcdata_mapM (untuple s) f g (untuple xs) - qcdata_zip s q c q' c' xs ys e = tuple $ qcdata_zip (untuple s) q c q' c' (untuple xs) (untuple ys) e - qcdata_promote a x s = tuple $ qcdata_promote (untuple a) (untuple x) s - -instance (QCData a) => QCData [a] where - qcdata_mapM ~[a] f g xs = do - sequence [ qcdata_mapM a f g x | x <- xs] - qcdata_zip ~[a] q c q' c' xs ys e = zs where - zs = [ qcdata_zip a q c q' c' x y e | (x, y) <- zip_strict_errmsg xs ys errmsg] - errmsg = e ("lists differ in length: " ++ show (length xs) ++ " " ++ show (length ys)) - qcdata_promote as xs e = - [ qcdata_promote a x e | (a,x) <- zip_rightstrict_errmsg as xs errmsg ] - where - errmsg = e "list too short" - -instance (QCData a, QCData b) => QCData (B_Endpoint a b) where - qcdata_mapM ~(Endpoint_Qubit a) f g (Endpoint_Qubit x) = do - x' <- qcdata_mapM a f g x - return (Endpoint_Qubit x') - qcdata_mapM ~(Endpoint_Bit b) f g (Endpoint_Bit y) = do - y' <- qcdata_mapM b f g y - return (Endpoint_Bit y') - qcdata_zip ~(Endpoint_Qubit a) q c q' c' (Endpoint_Qubit x) (Endpoint_Qubit y) e = (Endpoint_Qubit z) where - z = qcdata_zip a q c q' c' x y e - qcdata_zip ~(Endpoint_Bit b) q c q' c' (Endpoint_Bit x) (Endpoint_Bit y) e = (Endpoint_Bit z) where - z = qcdata_zip b q c q' c' x y e - qcdata_zip shape q c q' c' x y e = error errmsg where - errmsg = e "mismatching endpoint" - qcdata_promote ~(Endpoint_Qubit a) (Endpoint_Qubit x) e = Endpoint_Qubit z where - z = qcdata_promote a x e - qcdata_promote ~(Endpoint_Bit b) (Endpoint_Bit y) e = Endpoint_Bit z where - z = qcdata_promote b y e - -instance (QCData a) => QCData (Signed a) where - qcdata_mapM ~(Signed a _) f g ~(Signed x b) = do - x' <- qcdata_mapM a f g x - return (Signed x' b) - qcdata_zip ~(Signed a _) q c q' c' (Signed x1 b1) (Signed x2 b2) e = (Signed z b) where - z = qcdata_zip a q c q' c' x1 x2 e - b = if b1 == b2 then b1 else error (e "signs of controls do not match") - qcdata_promote ~(Signed a _) (Signed x b) e = (Signed x' b) where - x' = qcdata_promote a x e - --- ---------------------------------------------------------------------- --- Parameter types - --- Parameter types (such as Int) are also instances of QCData. --- These should be regarded as quantum types that are "all shape" and --- "no qubits". - --- Integers are parameters - -type instance QCType x y Integer = Integer - -type instance QTypeB Integer = Integer - -instance QCData Integer where - qcdata_mapM shape f g n = return n - qcdata_zip shape q c a' c' n m e - | n == m = n - | otherwise = error errmsg - where - errmsg = e "mismatching Integer parameter" - qcdata_promote a x e - | a == x = a - | otherwise = error errmsg - where - errmsg = e "mismatching Integer parameter" - --- Ints are parameters - -type instance QCType x y Int = Int - -type instance QTypeB Int = Int - -instance QCData Int where - qcdata_mapM shape f g n = return n - qcdata_zip shape q c a' c' n m e - | n == m = n - | otherwise = error errmsg - where - errmsg = e "mismatching Int parameter" - qcdata_promote a x e - | a == x = a - | otherwise = error errmsg - where - errmsg = e "mismatching Int parameter" - --- Doubles are parameters - -type instance QCType x y Double = Double - -type instance QTypeB Double = Double - -instance QCData Double where - qcdata_mapM shape f g n = return n - qcdata_zip shape q c a' c' n m e - | n == m = n - | otherwise = error errmsg - where - errmsg = e "mismatching Double parameter" - qcdata_promote a x e - | a == x = a - | otherwise = error errmsg - where - errmsg = e "mismatching Double parameter" - --- Floats are parameters - -type instance QCType x y Float = Float - -type instance QTypeB Float = Float - -instance QCData Float where - qcdata_mapM shape f g n = return n - qcdata_zip shape q c a' c' n m e - | n == m = n - | otherwise = error errmsg - where - errmsg = e "mismatching Float parameter" - qcdata_promote a x e - | a == x = a - | otherwise = error errmsg - where - errmsg = e "mismatching Float parameter" - --- Chars are parameters - -type instance QCType x y Char = Char - -type instance QTypeB Char = Char - -instance QCData Char where - qcdata_mapM shape f g n = return n - qcdata_zip shape q c a' c' n m e - | n == m = n - | otherwise = error errmsg - where - errmsg = e "mismatching Char parameter" - qcdata_promote a x e - | a == x = a - | otherwise = error errmsg - where - errmsg = e "mismatching Char parameter" - - --- ---------------------------------------------------------------------- --- ** The SimpleType class - --- | 'SimpleType' is a subclass of 'QCData' consisting of simple --- types. We say that a data type /t/ is \"simple\" if any two --- elements of /t/ have the same number of leaves. For example, tuples --- are simple, but lists are not. - -class QCData qc => SimpleType qc where - -- | Produce a term of the given shape. This term will contain - -- well-defined data constructors, but may be 'undefined' at the - -- leaves. - fs_shape :: qc - -instance SimpleType Qubit where - fs_shape = qubit - -instance SimpleType Bit where - fs_shape = bit - -instance SimpleType () where - fs_shape = () - -instance (SimpleType a, SimpleType b) => SimpleType (a,b) where - fs_shape = (fs_shape, fs_shape) - -instance (SimpleType a, SimpleType b, SimpleType c) => SimpleType (a,b,c) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d) => SimpleType (a,b,c,d) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e) => SimpleType (a,b,c,d,e) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f) => SimpleType (a,b,c,d,e,f) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g) => SimpleType (a,b,c,d,e,f,g) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h) => SimpleType (a,b,c,d,e,f,g,h) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h, SimpleType i) => SimpleType (a,b,c,d,e,f,g,h,i) where - fs_shape = tuple fs_shape - -instance (SimpleType a, SimpleType b, SimpleType c, SimpleType d, SimpleType e, SimpleType f, SimpleType g, SimpleType h, SimpleType i, SimpleType j) => SimpleType (a,b,c,d,e,f,g,h,i,j) where - fs_shape = tuple fs_shape - --- ====================================================================== --- * Type conversions - --- $ We define convenient abbreviations for conversions to, or --- between, homogeneous types. - --- | The type operator 'QType' converts a classical or heterogeneous --- type to a homogeneous quantum type. More precisely, the type --- 'QType' /a/ represents the substitution [nobr /a/ ['Qubit' \/ 'Bit']]. --- It can be applied to both homogeneous and heterogeneous types, and --- always yields a homogeneous type. For example: --- --- > QType (Bit, [Bit]) = (Qubit, [Qubit]) --- > QType (Qubit, Bit) = (Qubit, Qubit) -type QType a = QCType Qubit Qubit a - --- | The type operator 'CType' converts a classical or heterogeneous --- type to a homogeneous quantum type. More precisely, the type --- 'CType' /a/ represents the substitution [nobr /a/ ['Bit' \/ 'Qubit']]. It --- can be applied to both homogeneous and heterogeneous types, and --- always yields a homogeneous type. For example: --- --- > CType (Qubit, [Qubit]) = (Bit, [Bit]) --- > CType (Qubit, Bit) = (Bit, Bit) -type CType a = QCType Bit Bit a - --- | The type operator 'BType' converts a classical, quantum, or --- heterogeneous type to a homogeneous boolean type. More precisely, --- the type 'BType' /a/ represents the substitution --- [nobr /a/ ['Bool' \/ 'Qubit', 'Bool' \/ 'Bit']]. It can be applied to --- both homogeneous and heterogeneous types, and always yields a --- homogeneous type. For example: --- --- > BType (Qubit, [Qubit]) = (Bool, [Bool]) --- > BType (Qubit, Bit) = (Bool, Bool) -type BType a = QCType Bool Bool a - --- | The type operator 'HType' /x/ converts a classical, quantum, or --- boolean type to a homogeneous type with leaves /x/. More precisely, --- the type 'HType' /x/ /a/ represents the substitution --- [nobr /a/ [/x/ \/ 'Qubit', /x/ \/ 'Bit']]. --- For example: --- --- > HType x (Qubit, [Qubit]) = (x, [x]) --- > HType x (Qubit, Bit) = (x, x) --- --- There is a very subtle difference between 'HType' /x/ /a/ and --- 'QCType' /x/ /x/ /a/. Although these two types are equal for all --- /x/ and /a/, the type checker cannot actually prove that 'QCType' --- /x/ /x/ /a/ is homogeneous from the assumption 'QCData' /a/. It --- can, however, prove that 'HType' /x/ /a/ is homogeneous. Therefore --- 'HType' (or the slightly more efficient special cases 'QType', --- 'CType', 'BType') should always be used to create a homogeneous --- type from a heterogeneous one. -type HType leaf qa = QCType leaf leaf (QType qa) - --- | Construct the shape of a classical type. ---type CShape ca = HShape Bit ca - --- ====================================================================== --- * Shape parameters - --- $ Several operations, such as 'qcdata_mapM' and 'qcdata_zip', --- require a \"shape type parameter\". The purpose of such a parameter --- is only to fix a type; its value is completely unused. --- --- [Introduction to shape type parameters] --- --- $ The need for shape type parameters arises when dealing with a --- data structure whose leaves are of some arbitrary type, rather than --- 'Qubit', 'Bit', or 'Bool'. For example, consider the data structure --- --- > [(1, 2), (3, 4)] --- --- This could be parsed in several different ways: --- --- * as a data structure [(/leaf/, /leaf/), (/leaf/, /leaf/)], where each leaf --- is an integer; --- --- * as a data structure [/leaf/, /leaf/], where each leaf is a pair of --- integers; --- --- * as a data structure /leaf/, where each leaf is a list of pairs of --- integers. --- --- The purpose of a shape type is to disambiguate this situation. In --- shape types, the type 'Qubit' (and sometimes 'Bit', in the case of --- heterogeneous types) takes the place of a leaf. In the three --- situations of the above example, the shape type would be [('Qubit', --- 'Qubit')] in the first case; ['Qubit'] in the second case, the --- 'Qubit' in the third case. --- --- [Difference between shape type parameters and shape term parameters] --- --- A shape type parameter exists only to describe a type; its value is --- irrelevant and often undefined. A shape type parameter describes --- the location of leaves in a type. On the other hand, the purpose of --- a shape term parameter is used to fix the number and locations of --- leaves in a data structure (for example, to fix the length of a --- list). Shape term parameters are also often just called \"shape --- parameters\" in Quipper. --- --- The distinction is perhaps best illustrated in an example. --- A typical shape type parameter is --- --- > undefined :: (Qubit, [Qubit], [[Bit]]) --- --- A typical shape term parameter is --- --- > (qubit, [qubit, qubit, qubit], [[bit, bit], []]) :: (Qubit, [Qubit], [[Bit]]) --- --- Both of them have the same type. The shape type parameter specifies --- that the data structure is a triple consisting of a qubit, a list --- of qubits, and a list of lists of bits. The shape term parameter --- moreover specifies that the first list consists of exactly three --- qubits, and the second lists consists of a list of two bits and a --- list of zero bits. --- --- Note that the value of the shape type parameter is undefined (we --- often use the term 'dummy' instead of 'undefined', to get more --- meaningful error messages). On the other hand, the value of the --- shape term parameter is partially defined; only the /leaves/ are --- of undefined value. --- --- [Functions for specifying shape type parameters] --- --- Since it is not possible, in Haskell, to pass a type as an argument --- to a function, we provide some terms whose only purpose is to --- represent types. All of them have value 'undefined'. Effectively, --- a shape type parameter is a type \"written as a term\". --- --- The following terms can also be combined in data structures to --- represent composite types. For example: --- --- > (qubit, [bit]) :: (Qubit, [Bit]) - --- | A dummy term of any type. This term is 'undefined' and must never --- be evaluated. Its only purpose is to hold a type. -dummy :: a -dummy = error "attempted evaluation of dummy term" - --- | A dummy term of type 'Qubit'. It can be used in shape parameters --- (e.g., 'qc_init'), as well as shape type parameters (e.g., --- 'qcdata_mapM'). -qubit :: Qubit -qubit = dummy - --- | A dummy term of type 'Bit'. It can be used in shape parameters --- (e.g., 'qc_init'), as well as shape type parameters (e.g., --- 'qcdata_mapM'). -bit :: Bit -bit = dummy - --- | A dummy term of type 'Bool'. -bool :: Bool -bool = dummy - --- | Convert a piece of homogeneous quantum data to a shape type --- parameter. This is guaranteed to never evaluate /x/, and returns an --- undefined value. -shapetype_q :: (QData qa) => QType qa -> qa -shapetype_q x = dummy - --- | Convert a piece of homogeneous classical data to a shape type --- parameter. This is guaranteed to never evaluate /x/, and returns an --- undefined value. -shapetype_c :: (QData qa) => CType qa -> qa -shapetype_c x = dummy - --- | Convert a piece of homogeneous boolean data to a shape type --- parameter. This is guaranteed to never evaluate /x/, and returns an --- undefined value. Do not confuse this with the function 'qshape', --- which creates a shape value. -shapetype_b :: (QData qa) => BType qa -> qa -shapetype_b x = dummy - --- | A dummy term of the same type as the given term. If /x/ :: /a/, --- then 'dummy' /x/ :: /a/. This is guaranteed not to evaluate /x/, --- and returns an undefined value. -shape :: a -> a -shape x = dummy - --- ====================================================================== --- * Homogeneous types - --- ---------------------------------------------------------------------- --- ** The QData class - --- $ The 'QData' type class contains homogeneous data types built up --- from leaves of type 'Qubit'. It contains no methods; all of its --- functionality is derived from 'QCData'. It does, however, contain --- a number of equations that help the type checker figure out how to --- convert heterogeneous type to homogeneous ones and vice versa. - --- | The 'QData' type class contains homogeneous data types built up --- from leaves of type 'Qubit'. -class (qa ~ QType (CType qa), - qa ~ QTypeB (BType qa), - qa ~ QCType Qubit Bool qa, - qa ~ QType qa, - QCData qa, - QCData (CType qa) - ) => QData qa - -instance (qa ~ QType (CType qa), - qa ~ QTypeB (BType qa), - qa ~ QCType Qubit Bool qa, - qa ~ QType qa, - QCData qa, - QCData (CType qa) - ) => QData qa - --- ---------------------------------------------------------------------- --- ** Derived combinators on QData - --- $ This section provides several convenient combinators for the --- 'QData' class. All of them are definable from those of --- 'QCData'. - --- | Map a function /f/ over all the leaves of a data structure. The --- first argument is a dummy shape parameter: its value is ignored, but --- its /type/ is used to determine the shape of the data to map over. --- --- Example (ignoring the monad for the sake of simplicity): --- --- > qdata_mapM (leaf, [leaf]) f (x,[y,z,w]) = (f x, [f y, f z, f w]). --- --- For data types that have a sense of direction, the mapping should --- preferably be performed from left to right, but this property is --- not guaranteed and may change without notice. -qdata_mapM :: (QData qa, Monad m) => qa -> (x -> m y) -> HType x qa -> m (HType y qa) -qdata_mapM qa f xa = qcdata_mapM qa f f xa where - --- | Zip two data structures with leaf types /x/ and /y/ together, to --- obtain a new data structure of the same shape with leaf type (/x/, --- /y/). The first three arguments are dummy shape type parameters, representing --- the shape type and the two leaf types, respectively. --- --- The 'ErrMsg' argument is a stub error message to be used in case --- of failure. -qdata_zip :: (QData qa) => qa -> x -> y -> HType x qa -> HType y qa -> ErrMsg -> HType (x, y) qa -qdata_zip qa x y xs ys errmsg = qcdata_zip qa x x y y xs ys errmsg - --- | Sometimes, it is possible to have a boolean parameter with some --- aspect of its shape indeterminate. The function 'qdata_promote' --- takes such a boolean parameter, as well as a piece of quantum data, --- and sets the shape of the former to that of the latter. --- --- Indeterminate shapes can be used with certain operations, such as --- controlling and terminating, where some aspect of the shape of the --- parameter can be determined from the context in which it is --- used. This is useful, e.g., for quantum integers, where one may --- want to specify a control condition by an integer literal such as --- 17, without having to specify the number of bits. Thus, we can --- write, e.g., --- --- > gate `controlled` qi .==. 17 --- --- instead of the more cumbersome --- --- > gate `controlled` qi .==. (intm (qdint_length qi) 17). --- --- Another useful application of this arises in the use of infinite --- lists of booleans (such as @['False'..]@), to specify a control --- condition for a finite list of qubits. --- --- Because this function is used as a building block, we also pass --- an error message to be used in case of failure. This will --- hopefully make it clearer to the user which operation caused the --- error. - -qdata_promote :: (QData qa) => BType qa -> qa -> ErrMsg -> BType qa -qdata_promote ba qa errmsg = qcdata_promote ba qa errmsg - --- | The inverse of 'qdata_zip': Take a data structure with leaf type --- (/x/, /y/), and return two data structures of the same shape with --- leaf types /x/ and /y/, respectively. The first three arguments are --- dummy shape type parameters, analogous to those of 'qdata_zip'. -qdata_unzip :: (QData s) => s -> x -> y -> HType (x, y) s -> (HType x s, HType y s) -qdata_unzip s (sx :: x) (c :: y) z = (x, y) where - x = qdata_map s (fst :: (x, y) -> x) z - y = qdata_map s (snd :: (x, y) -> y) z - --- | Map a function over every leaf in a data structure. Non-monadic --- version of 'qdata_mapM'. -qdata_map :: (QData s) => s -> (x -> y) -> HType x s -> HType y s -qdata_map shape f xs = - getId $ qdata_mapM shape (return . f) xs - --- | Visit every leaf in a data structure, updating an accumulator. -qdata_fold :: (QData s) => s -> (x -> w -> w) -> HType x s -> w -> w -qdata_fold shape f xs w = - getId $ qdata_foldM shape (\x w -> return $ f x w) xs w - --- | Map a function over every leaf in a data structure, while also --- updating an accumulator. This combines the functionality of --- 'qdata_fold' and 'qdata_map'. -qdata_fold_map :: (QData s) => s -> (x -> w -> (y, w)) -> HType x s -> w -> (HType y s, w) -qdata_fold_map shape f xs w = - getId $ qdata_fold_mapM shape (\x w -> return $ f x w) xs w - --- | Monadic version of 'qdata_fold': Visit every leaf in a data --- structure, updating an accumulator. -qdata_foldM :: (QData s, Monad m) => s -> (x -> w -> m w) -> HType x s -> w -> m w -qdata_foldM shape f xs w = do - (ys, w) <- qdata_fold_mapM shape f' xs w - return w - where - f' x w = do - w <- f x w - return ((), w) - --- | Monadic version of 'qdata_fold_map': Map a function over every --- leaf in a data structure, while also updating an accumulator. This --- combines the functionality of 'qdata_foldM' and 'qdata_mapM'. -qdata_fold_mapM :: (QData s, Monad m) => s -> (x -> w -> m (y, w)) -> HType x s -> w -> m (HType y s, w) -qdata_fold_mapM shape f xs w = do - (ys, w) <- runStateT computation w - return (ys, w) - where - -- m' = StateT w m - computation = qdata_mapM shape map_leaf xs - map_leaf x = do - w <- get - (y, w') <- lift $ f x w - put w' - return y - --- | Return a list of leaves of the given homogeneous data structure. --- The first argument is a dummy shape type parameter, and is only used --- for its type. --- --- The leaves are ordered in some deterministic, but arbitrary way. It --- is guaranteed that when two data structures of the same shape type --- and shape (same length of lists etc) are sequentialized, the leaves --- will be ordered the same way. No other property of the order is --- guaranteed, In particular, it might change without notice. -qdata_sequentialize :: (QData s) => s -> HType x s -> [x] -qdata_sequentialize shape xs = xlist where - blist = qdata_fold shape do_leaf xs blist_empty - xlist = list_of_blist blist - - do_leaf :: x -> BList x -> BList x - do_leaf x blist = blist +++ blist_of_list [x] - --- | Take a specimen homogeneous data structure to specify the \"shape\" --- desired (length of lists, etc); then reads the given list of leaves --- in as a piece of homogeneous data of the same shape. The ordering --- of the leaves is assumed to be the same as that which --- 'qdata_sequentialize' produces for the given shape. --- --- A \"length mismatch\" error occurs if the list does not have --- exactly the required length. --- --- Please note that, by contrast with the function --- 'qdata_sequentialize', the first argument is a shape term --- parameter, not a shape type parameter. It is used to decide where --- the qubits should go in the data structure. -qdata_unsequentialize :: (QData s) => s -> [x] -> HType x s -qdata_unsequentialize shape xlist = xs where - xs = case qdata_fold_map shape do_leaf shape xlist of - (xs, []) -> xs - (xs, _) -> error "qdata_unsequentialize: length mismatch" - - -- first argument of do_leaf is dummy - do_leaf :: Qubit -> [x] -> (x, [x]) - do_leaf x (h:t) = (h, t) - do_leaf x [] = error "qdata_unsequentialize: length mismatch" - --- | Combine a shape type argument /q/, a leaf type argument /a/, and --- a shape size argument /x/ into a single shape argument /qx/. Note: --- --- * /q/ captures only the type, but not the size of the data. Only --- the type of /q/ is used; its value can be undefined. This is --- sufficient to determine the depth of leaves in a data structure, --- but not their number. --- --- * /x/ captures only the size of the data, but not its type. In --- particular, /x/ may have leaves of non-atomic types. /x/ must --- consist of well-defined constructors up to the depth of leaves of --- /q/, but the values at the actual leaves of /x/ may be undefined. --- --- * The output /qx/ combines the type of /q/ with the size of /x/, --- and can therefore be used both as a shape type and a shape value. --- Note that the actual leaves of /qx/ will be 'qubit' and 'bit', --- which are synonyms for 'undefined'. --- --- Example: --- --- > q = undefined :: ([Qubit], [[Qubit]]) --- > x = ([undefined, 0], [[undefined], [0, 1]]) --- > qdata_makeshape qc a x = ([qubit, qubit], [[qubit], [qubit, qubit]]) --- --- where /a/ :: @Int@. -qdata_makeshape :: (QData qa) => qa -> a -> HType a qa -> qa -qdata_makeshape q (a::a) x = qdata_map q map_qubit x where - map_qubit = const qubit :: a -> Qubit - --- | Like 'qdata_mapM', except the leaves are visited in exactly the --- opposite order. This is used primarily for cosmetic reasons: For --- example, when initializing a bunch of ancillas, and then --- terminating them, the circuit will look more symmetric if they are --- terminated in the opposite order. -qdata_mapM_op :: (QData s, Monad m) => s -> (x -> m y) -> HType x s -> m (HType y s) -qdata_mapM_op shapetype (f :: x -> m y) xs = do - let shapeterm = qdata_makeshape shapetype (dummy :: x) xs - let xlist = qdata_sequentialize shapeterm xs - ylist <- sequence_right [ f x | x <- xlist ] - let ys = qdata_unsequentialize shapeterm ylist - return ys - --- | Like 'qdata_promote', except take a piece of classical data. -qdata_promote_c :: (QData s) => BType s -> CType s -> ErrMsg -> BType s -qdata_promote_c b c s = qdata_promote b q s where - q = qdata_map (shapetype_c c) map_qubit c - - map_qubit :: Bit -> Qubit - map_qubit = const qubit - --- ---------------------------------------------------------------------- --- ** The CData and BData classes - --- | The 'CData' type class contains homogeneous data types built up --- from leaves of type 'Bit'. -class (QData (QType ca), CType (QType ca) ~ ca) => CData ca -instance (QData (QType ca), CType (QType ca) ~ ca) => CData ca - --- | The 'BData' type class contains homogeneous data types built up --- from leaves of type 'Bool'. -class (QData (QTypeB ba), BType (QTypeB ba) ~ ba) => BData ba -instance (QData (QTypeB ba), BType (QTypeB ba) ~ ba) => BData ba - --- ---------------------------------------------------------------------- --- ** The QShape class - --- $ By definition, 'QShape' /ba/ /qa/ /ca/ means that /ba/, /qa/, and --- /ca/ are, respectively, boolean, quantum, and classical homogeneous --- data types of the same common shape. The 'QShape' class directly --- defined in terms of the 'QData' class. In fact, the two classes are --- interchangeable in the following sense: --- --- > QShape ba qa ca implies QData qa, --- --- and conversely, --- --- > QData qa implies QShape (BType qa) qa (CType qa). --- --- Moreover, the functional dependencies @/ba/ -> /qa/, /qa/ -> /ca/, --- /ca/ -> /ba/@ ensure that each of the three types determines the --- other two. Therefore, in many ways, 'QShape' is just a convenient --- notation for functionality already present in 'QData'. - --- | The 'QShape' class allows the definition of generic functions that --- can operate on quantum data of any \"shape\", for example, nested --- tuples or lists of qubits. --- --- In general, there are three kinds of data: quantum inputs (such as --- 'Qubit'), classical inputs (such as 'Bit'), and classical --- parameters (such as 'Bool'). For example, a 'Qubit' can be --- initialized from a 'Bool'; a 'Qubit' can be measured, resulting in --- a 'Bit', etc. For this reason, the type class 'QShape' establishes a --- relation between three types: --- --- [@qa@] A data structure having 'Qubit' at the leaves. --- --- [@ca@] A data structure of the same shape as @qa@, having 'Bit' at --- the leaves. --- --- [@ba@] A data structure of the same shape as @qa@, having 'Bool' at --- the leaves. --- --- Some functions input a classical parameter for the sole purpose of --- establishing the \"shape\" of a piece of data. The shape refers to --- qualities of a data structure, such as the length of a list, which --- are not uniquely determined by the type. For example, two different --- lists of length 5 have the same shape. When performing a generic --- operation, such as reversing a circuit, it is often necessary to --- specify the shape of the inputs, but not the actual inputs. --- --- In the common case where one only needs to declare one of the types --- /qa/, /ca/, or /ba/, one of the simpler type classes 'QData', --- 'CData', or 'BData' can be used. - -class (QData qa, - CType qa ~ ca, - BType qa ~ ba - ) => QShape ba qa ca | ba -> qa, qa -> ca, ca -> ba - -instance (QData qa, BType qa ~ ba, CType qa ~ ca) => QShape ba qa ca - --- ====================================================================== --- * Heterogeneous types - --- $ A heterogeneous type describes a data structure built up from --- leaves of type 'Qubit' and 'Bit'. Such types are used, for example, --- to represent sets of endpoints in circuits, parameters to --- subroutines and circuit building functions. A typical example is: --- --- > (Bit, Qubit, [Qubit]). - --- ---------------------------------------------------------------------- --- ** Derived combinators on QCData - --- $ The 'QCData' type class only contains the three primitive --- combinators 'qcdata_mapM', 'qcdata_zip', and 'qcdata_promote'. --- Many other useful combinators are definable in terms of these, and --- we provide several of them here. - --- | The inverse of 'qcdata_zip': Take a data structure whose leaves --- are pairs, and return two data structures of the same shape, --- collecting all the left components and all the right components, --- respectively. The first five arguments are shape type parameters, --- analogous to those of 'qcdata_zip'. -qcdata_unzip :: (QCData qc) => qc -> q -> c -> q' -> c' -> QCType (q, q') (c, c') qc -> (QCType q c qc, QCType q' c' qc) -qcdata_unzip s (q :: q) (c :: c) (q' :: q') (c' :: c') z = (x, y) where - x = qcdata_map s (fst :: (q, q') -> q) (fst :: (c, c') -> c) z - y = qcdata_map s (snd :: (q, q') -> q') (snd :: (c, c') -> c') z - --- | Map two functions /f/ and /g/ over the leaves of a heterogeneous --- data structure. Apply /f/ to all the leaves at 'Qubit' positions, --- and 'g' to all the leaves at 'Bit' positions. Non-monadic version --- of 'qcdata_mapM'. -qcdata_map :: (QCData qc) => qc -> (q -> q') -> (c -> c') -> QCType q c qc -> QCType q' c' qc -qcdata_map shape f g xs = - getId $ qcdata_mapM shape (return . f) (return . g) xs - --- | Visit every leaf in a data structure, updating an --- accumulator. This function requires two accumulator functions /f/ --- and /g/, to be used at 'Qubit' positions and 'Bit' positions, --- respectively. -qcdata_fold :: (QCData qc) => qc -> (q -> w -> w) -> (c -> w -> w) -> QCType q c qc -> w -> w -qcdata_fold shape f g xs w = - getId $ qcdata_foldM shape (\x w -> return $ f x w) (\y w -> return $ g y w) xs w - --- | Map a function over every leaf in a data structure, while also --- updating an accumulator. This combines the functionality of --- 'qcdata_fold' and 'qcdata_map'. -qcdata_fold_map :: (QCData qc) => qc -> (q -> w -> (q', w)) -> (c -> w -> (c', w)) -> QCType q c qc -> w -> (QCType q' c' qc, w) -qcdata_fold_map shape f g xs w = - getId $ qcdata_fold_mapM shape (\x w -> return $ f x w) (\x w -> return $ g x w) xs w - --- | Monadic version of 'qcdata_fold': Visit every leaf in a data --- structure, updating an accumulator. This function requires two --- accumulator functions /f/ and /g/, to be used at 'Qubit' positions --- and 'Bit' positions, respectively. -qcdata_foldM :: (QCData qc, Monad m) => qc -> (q -> w -> m w) -> (c -> w -> m w) -> QCType q c qc -> w -> m w -qcdata_foldM shape f g xs w = do - (ys, w) <- qcdata_fold_mapM shape (map_leaf f) (map_leaf g) xs w - return w - where - map_leaf :: (Monad m) => (x -> w -> m w) -> (x -> w -> m ((), w)) - map_leaf f x w = do - w <- f x w - return ((), w) - --- | Monadic version of 'qcdata_fold_map': Map a function over every --- leaf in a data structure, while also updating an accumulator. This --- combines the functionality of 'qcdata_foldM' and 'qcdata_mapM'. -qcdata_fold_mapM :: (QCData qc, Monad m) => qc -> (q -> w -> m (q', w)) -> (c -> w -> m (c', w)) -> QCType q c qc -> w -> m (QCType q' c' qc, w) -qcdata_fold_mapM shape f g xs w = do - (ys, w) <- runStateT computation w - return (ys, w) - where - -- m' = StateT w m - computation = qcdata_mapM shape (map_leaf f) (map_leaf g) xs - - map_leaf :: (Monad m) => (a -> s -> m (b, s)) -> a -> StateT s m b - map_leaf f a = StateT (f a) - --- | Return a list of leaves of the given heterogeneous data --- structure. The first argument is a dummy shape type parameter, and --- is only used for its type. Leaves in qubit positions and bit --- positions are returned, respectively, as the left or right --- components of a disjoint union. --- --- The leaves are ordered in some deterministic, but arbitrary way. It --- is guaranteed that when two data structures of the same shape type --- and shape (same length of lists etc) are sequentialized, the leaves --- will be ordered the same way. No other property of the order is --- guaranteed, In particular, it might change without notice. -qcdata_sequentialize :: (QCData qc) => qc -> QCType q c qc -> [B_Endpoint q c] -qcdata_sequentialize shape xs = xlist where - blist = qcdata_fold shape do_qubit do_bit xs blist_empty - xlist = list_of_blist blist - - do_qubit :: q -> BList (B_Endpoint q c) -> BList (B_Endpoint q c) - do_qubit q blist = blist +++ blist_of_list [Endpoint_Qubit q] - - do_bit :: c -> BList (B_Endpoint q c) -> BList (B_Endpoint q c) - do_bit c blist = blist +++ blist_of_list [Endpoint_Bit c] - --- | Take a specimen heterogeneous data structure to specify the --- \"shape\" desired (length of lists, etc); then reads the given list --- of leaves in as a piece of heterogeneous data of the same --- shape. The ordering of the leaves, and the division of the leaves --- into qubit and bit positions, is assumed to be the same as that --- which 'qcdata_sequentialize' produces for the given shape. --- --- A \"length mismatch\" error occurs if the list does not have --- exactly the required length. A \"shape mismatch\" error occurs if --- the list contains an 'Endpoint_Bit' entry corresponding to a --- 'Qubit' position in the shape, or an 'Endpoint_Qubit' entry --- corresponding to a 'Bit' position. --- --- Please note that, by contrast with the function --- 'qcdata_sequentialize', the first argument is a shape term --- parameter, not a shape type parameter. It is used to decide where --- the qubits and bits should go in the data structure. -qcdata_unsequentialize :: (QCData qc) => qc -> [B_Endpoint q c] -> QCType q c qc -qcdata_unsequentialize shape xlist = xs where - xs = case qcdata_fold_map shape do_qubit do_bit shape xlist of - (xs, []) -> xs - (xs, _) -> error "qcdata_unsequentialize: length mismatch" - - -- first argument of do_qubit and do_bit is dummy - do_qubit :: Qubit -> [B_Endpoint q c] -> (q, [B_Endpoint q c]) - do_qubit x (Endpoint_Qubit h : t) = (h, t) - do_qubit x (Endpoint_Bit h : t) = error "qcdata_unsequentialize: shape mismatch" - do_qubit x [] = error "qcdata_unsequentialize: length mismatch" - - do_bit :: Bit -> [B_Endpoint q c] -> (c, [B_Endpoint q c]) - do_bit x (Endpoint_Bit h : t) = (h, t) - do_bit x (Endpoint_Qubit h : t) = error "qcdata_unsequentialize: shape mismatch" - do_bit x [] = error "qcdata_unsequentialize: length mismatch" - --- | Combine a shape type argument /q/, two leaf type arguments /a/ --- and /b/, and a shape size argument /x/ into a single shape argument --- /qx/. Note: --- --- * /q/ captures only the type, but not the size of the data. Only --- the type of /q/ is used; its value can be undefined. This is --- sufficient to determine the depth of leaves in a data structure, --- but not their number. --- --- * /x/ captures only the size of the data, but not its type. In --- particular, /x/ may have leaves of non-atomic types. /x/ must --- consist of well-defined constructors up to the depth of leaves of --- /q/, but the values at the actual leaves of /x/ may be undefined. --- --- * The output /qx/ combines the type of /q/ with the size of /x/, --- and can therefore be used both as a shape type and a shape value. --- Note that the actual leaves of /qx/ will be 'qubit' and 'bit', --- which are synonyms for 'undefined'. --- --- Example: --- --- > qc = undefined :: ([Qubit], [[Bit]]) --- > x = ([undefined, (0,False)], [[undefined], [Just 2, Nothing]]) --- > qcdata_makeshape qc a b x = ([qubit, qubit], [[bit], [bit, bit]]) --- --- where /a/ :: @(Int,Bool)@, /b/ :: @(Maybe Int)@. -qcdata_makeshape :: (QCData qc) => qc -> a -> b -> QCType a b qc -> qc -qcdata_makeshape q (a::a) (b::b) x = qcdata_map q map_qubit map_bit x where - map_qubit = const qubit :: a -> Qubit - map_bit = const bit :: b -> Bit - --- | Like 'qcdata_mapM', except the leaves are visited in exactly the --- opposite order. This is used primarily for cosmetic reasons: For --- example, when initializing a bunch of ancillas, and then --- terminating them, the circuit will look more symmetric if they are --- terminated in the opposite order. -qcdata_mapM_op :: (QCData qc, Monad m) => qc -> (q -> m q') -> (c -> m c') -> QCType q c qc -> m (QCType q' c' qc) -qcdata_mapM_op shapetype (f :: q -> m q') (g :: c -> m c') xs = do - let shapeterm = qcdata_makeshape shapetype (dummy::q) (dummy::c) xs - let xlist = qcdata_sequentialize shapeterm xs - ylist <- sequence_right [ map_endpointM f g x | x <- xlist ] - let ys = qcdata_unsequentialize shapeterm ylist - return ys - where - map_endpointM f g (Endpoint_Qubit x) = do - x' <- f x - return (Endpoint_Qubit x') - map_endpointM f g (Endpoint_Bit y) = do - y' <- g y - return (Endpoint_Bit y') - --- ---------------------------------------------------------------------- --- ** The QCDataPlus class - --- Implementation note: Since Haskell does not allow cyclic --- dependencies in the definition of type classes, it was a --- non-trivial problem to define 'QShape' and 'QCDataPlus' so that the --- implications go both ways. We solved this problem by basing both --- classes on QCData, together with a generous application of --- equational reasoning. - --- | The 'QCDataPlus' type class is almost identical to 'QCData', --- except that it contains one additional piece of information that --- allows the type checker to prove the implications --- --- > QCDataPlus qc implies QShape (BType qc) (QType qc) (CType qc) --- > QCDataPlus qc implies QData (QType qc) --- > QCDataPlus qc implies CData (CType qc) --- > QCDataPlus qc implies BData (BType qc) --- --- This is sometimes useful, for example, in the context of a function --- that inputs a 'QCData', measures all the qubits, and returns a --- 'CData'. However, the additional information for the type checker --- comes at a price, which is drastically increased compilation time. --- Therefore 'QCDataPlus' should only be used when 'QCData' is --- insufficient. - -class (QCData qc, QData (QType qc)) => QCDataPlus qc -instance (QCData qc, QData (QType qc)) => QCDataPlus qc - --- ---------------------------------------------------------------------- --- ** Fixed size QCDataPlus - --- | 'QCDataPlus_Simple' is a convenience type class that combines --- 'QCDataPlus' and 'SimpleType'. -class (QCData qc, SimpleType qc) => QCData_Simple qc -instance (QCData qc, SimpleType qc) => QCData_Simple qc - --- | 'QCDataPlus_Simple' is a convenience type class that combines --- 'QCDataPlus' and 'SimpleType'. -class (QCDataPlus qc, SimpleType qc) => QCDataPlus_Simple qc -instance (QCDataPlus qc, SimpleType qc) => QCDataPlus_Simple qc - --- Implementation note: We could just have made 'SimpleType' a --- subclass of 'QCData' directly, but this would require the --- type-checker to do lots of additional theorem proving, to the point --- of overflowing the context stack and significantly slowing down --- compilation. - --- ---------------------------------------------------------------------- --- ** The QCLeaf class - --- | The class 'QCLeaf' consists of the two types 'Qubit' and 'Bit'. --- It is primarily used for convenience, in those cases (such as the --- arithmetic library) where some class instance should be defined for --- the cases 'Qubit' and 'Bit', but not for general 'QCData'. It is --- also used, e.g., in the definition of the './=.' operator. -class (QCData q, - SimpleType q, - ControlSource q, - ControlSource (Signed q), - Labelable q String, - QCType Qubit Bit q ~ q, - QCType Bool Bool q ~ Bool) => QCLeaf q - -instance QCLeaf Qubit -instance QCLeaf Bit - --- ---------------------------------------------------------------------- --- ** Canonical string representation - --- $ For the purpose of storing boxed subroutines, it is useful to --- have a unique representation of 'QCData' shapes as strings. The --- currently implementation relies on 'show' to give unique --- representations. Therefore, when defining 'Show' instances for --- 'QCData', one should make sure that the generated strings contain --- enough information to recover both the type and the shape uniquely. - --- | A type to represent a 'Qubit' leaf, for the sole purpose that --- 'show' will show it as \"Q\". -data Qubit_Leaf = Qubit_Leaf -instance Show Qubit_Leaf where - show _ = "Q" - --- | A type to represent a 'Bit' leaf, for the sole purpose that --- 'show' will show it as \"C\". -data Bit_Leaf = Bit_Leaf -instance Show Bit_Leaf where - show _ = "C" - --- | Turn any 'QCData' into a string uniquely identifying its type and --- shape. The current implementation assumes that appropriately unique --- 'Show' instances are defined for all 'QCData'. -canonical_shape :: (QCData qc) => qc -> String -canonical_shape qc = show $ qcdata_map qc do_qubit do_bit qc - where - do_qubit :: Qubit -> Qubit_Leaf - do_qubit q = Qubit_Leaf - - do_bit :: Bit -> Bit_Leaf - do_bit c = Bit_Leaf - --- | The type operator 'LType' converts 'Qubit' to 'Qubit_Leaf' and --- 'Bit' to 'Bit_Leaf'. -type LType a = QCType Qubit_Leaf Bit_Leaf a - --- ====================================================================== --- * Defining new QCData instances - --- $ To define a new kind of quantum data, the following must be --- defined: --- --- * A class instance of 'QCData', --- --- * a type instance of 'QCType', and --- --- * a type instance of 'QTypeB'. --- --- If the new type is simple, an class instance of 'SimpleType' should --- also be defined. --- --- If the new type may be integrated with Template Haskell, a class --- instance of 'CircLiftingUnpack' should also be defined. --- --- To ensure that circuit labeling will work for the new type, a class --- instance of 'Labelable' must also be defined for every member of --- 'QCData'. See "Quipper.Labels" for detailed instructions on how to --- do so. --- --- Modules that define new kinds of quantum data should import --- "Quipper.Internal". diff --git a/src/Quipper/Transformer.hs b/src/Quipper/Transformer.hs deleted file mode 100644 --- a/src/Quipper/Transformer.hs +++ /dev/null @@ -1,624 +0,0 @@ --- This file is part of Quipper. Copyright (C) 2011-2016. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, --- and other details. All rights reserved. --- --- ====================================================================== - -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | This module provides functions for defining general-purpose --- transformations on low-level circuits. The uses of this include: --- --- * gate transformations, where a whole circuit is transformed by --- replacing each kind of gate with another gate or circuit; --- --- * error correcting codes, where a whole circuit is transformed --- replacing each qubit by some fixed number of qubits, and each gate --- by a circuit; and --- --- * simulations, where a whole circuit is mapped to a semantic --- function by specifying a semantic function for each gate. --- --- The interface is designed to allow the programmer to specify new --- transformers easily. To define a specific transformation, the --- programmer has to specify only four pieces of information: --- --- * A type /a/=⟦Qubit⟧, to serve as a semantic domain for qubits. --- --- * A type /b/=⟦Bit⟧, to serve as a semantic domain for bits. --- --- * A monad /m/. This is to allow translations to have side effects --- if desired; one can use the identity monad otherwise. --- --- * For every gate /G/, a corresponding semantic function ⟦/G/⟧. The --- type of this function depends on what kind of gate /G/ is. For example: --- --- @ --- If /G/ :: Qubit -> Circ Qubit, then ⟦/G/⟧ :: /a/ -> /m/ /a/. --- If /G/ :: (Qubit, Bit) -> Circ (Bit, Bit), then ⟦/G/⟧ :: (/a/, /b/) -> /m/ (/b/, /b/). --- @ --- --- The programmer provides this information by defining a function of --- type 'Transformer' /m/ /a/ /b/. See <#Transformers> below. Once a --- particular transformer has been defined, it can then be applied to --- entire circuits. For example, for a circuit with 1 inputs and 2 --- outputs: --- --- @ --- If /C/ :: Qubit -> (Bit, Qubit), then ⟦/C/⟧ :: /a/ -> /m/ (/b/, /a/). --- @ - --- ---------------------------------------------------------------------- --- Grammar note for developers: a "transformer" does a --- "transformation" by "transforming" gates. We use "transform" as a --- verb, "transformation" to describe the process of transforming, and --- "transformer" for the code that describes or does the transformation. --- --- I had initially used the words "iteration", "translation", --- "transform", "transformation", "interpretation", and "semantics" --- interchangeably, which was a huge linguistic mess. - -module Quipper.Transformer where - --- import other Quipper stuff -import Quipper.Circuit -import Libraries.Auxiliary - --- import other stuff -import Control.Monad -import Control.Monad.State -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.IntMap as IntMap -import Data.Typeable - --- ====================================================================== --- * An example transformer --- --- $EXAMPLE --- --- The following is a short but complete example of how to write and --- use a simple transformer. As usual, we start by importing Quipper: --- --- > import Quipper --- --- We will write a transformer called @sample_transformer@, which maps --- every swap gate to a sequence of three controlled-not gates, and --- leaves all other gates unchanged. For convenience, Quipper --- pre-defines an 'identity_transformer', which can be used as a --- catch-all clause to take care of all the gates that don't need to --- be rewritten. --- --- > mytransformer :: Transformer Circ Qubit Bit --- > mytransformer (T_QGate "swap" 2 0 _ ncf f) = f $ --- > \[q0, q1] [] ctrls -> do --- > without_controls_if ncf $ do --- > with_controls ctrls $ do --- > qnot_at q0 `controlled` q1 --- > qnot_at q1 `controlled` q0 --- > qnot_at q0 `controlled` q1 --- > return ([q0, q1], [], ctrls) --- > mytransformer g = identity_transformer g --- --- Note how Quipper syntax has been used to define the replacement --- circuit, consisting of three controlled-not gates. Also, since the --- original swap gate may have been controlled, we have added the --- additional controls with a 'with_controls' operator. --- --- To try this out, we define some random circuit using swap gates: --- --- > mycirc a b c d = do --- > swap_at a b --- > hadamard_at b --- > swap_at b c `controlled` [a, d] --- > hadamard_at c --- > swap_at c d --- --- To apply the transformer to this circuit, we use the generic --- operator 'transform_generic': --- --- > mycirc2 = transform_generic mytransformer mycirc --- --- Finally, we use a @main@ function to display the original circuit --- and then the transformed one: --- --- > main = do --- > print_simple Preview mycirc --- > print_simple Preview mycirc2 - --- ====================================================================== --- * Bindings - --- $bindings --- --- We introduce the notion of a /binding/ as a low-level way to --- describe functions of varying arities. A binding assigns a value to --- a wire in a circuit (much like a \"valuation\" in logic or semantics --- assigns values to variables). --- --- To iterate through a circuit, one will typically specify initial --- bindings for the input wires. This encodes the input of the function --- ⟦/C/⟧ mentioned in the introduction. The bindings are updated as --- one passes through each gate. When the iteration is finished, the --- final bindings assign a value to each output wire of the --- circuit. This encodes the output of the function ⟦/C/⟧. Therefore, --- the interpretation of a circuit is representable as a function from --- bindings (of input wires) to bindings (of output wires), i.e., it --- has the type ⟦/C/⟧ :: 'Bindings' /a/ /b/ -> 'Bindings' /a/ /b/. - --- | An /endpoint/ is either a /qubit/ or a /bit/. In a transformer, --- we have ⟦Endpoint Qubit Bit⟧ = ⟦Qubit⟧ + ⟦Bit⟧. The type 'Endpoint' --- /a/ /b/ is the same as 'Either' /a/ /b/, but we use more suggestive --- field names. -data B_Endpoint a b = - Endpoint_Qubit a - | Endpoint_Bit b - deriving (Eq, Ord, Typeable, Show) - --- | A binding is a map from a set of wires to the disjoint union of --- /a/ and /b/. -type Bindings a b = Map Wire (B_Endpoint a b) - --- | Return the list of bound wires from a binding. -wires_of_bindings :: Bindings a b -> [Wire] -wires_of_bindings = Map.keys - --- | The empty binding. -bindings_empty :: Bindings a b -bindings_empty = Map.empty - --- | Bind a wire to a value, and add it to the given bindings. -bind :: Wire -> B_Endpoint a b -> Bindings a b -> Bindings a b -bind r x bindings = Map.insert r x bindings - --- | Bind a qubit wire to a value, and add it to the given bindings. -bind_qubit_wire :: Wire -> a -> Bindings a b -> Bindings a b -bind_qubit_wire r x bindings = bind r (Endpoint_Qubit x) bindings - --- | Bind a bit wire to a value, and add it to the given bindings. -bind_bit_wire :: Wire -> b -> Bindings a b -> Bindings a b -bind_bit_wire r x bindings = bind r (Endpoint_Bit x) bindings - --- | Retrieve the value of a wire from the given bindings. -unbind :: Bindings a b -> Wire -> B_Endpoint a b -unbind bindings w = case Map.lookup w bindings of - Nothing -> error ("unbind: wire (" ++ show w ++ ") not in bindings: " ++ show (wires_of_bindings bindings)) - Just a -> a - --- | Retrieve the value of a qubit wire from the given bindings. --- Throws an error if the wire was bound to a classical bit. -unbind_qubit_wire :: Bindings a b -> Wire -> a -unbind_qubit_wire bindings w = - case unbind bindings w of - Endpoint_Qubit x -> x - Endpoint_Bit x -> error "Transformer error: expected a qubit, got a bit" - --- | Retrieve the value of a bit wire from the given bindings. --- Throws an error if the wire was bound to a qubit. -unbind_bit_wire :: Bindings a b -> Wire -> b -unbind_bit_wire bindings w = - case unbind bindings w of - Endpoint_Bit x -> x - Endpoint_Qubit x -> error "Transformer error: expected a bit, got a qubit" - --- | Delete a wire from the given bindings. -bind_delete :: Wire -> Bindings a b -> Bindings a b -bind_delete r bindings = Map.delete r bindings - --- | Like 'bind', except bind a list of wires to a list of values. The --- lists must be of the same length. -bind_list :: [Wire] -> [B_Endpoint a b] -> Bindings a b -> Bindings a b -bind_list ws xs bindings = - foldr (\ (w, x) -> bind w x) bindings (zip ws xs) - --- | Like 'bind_qubit_wire', except bind a list of qubit wires to a list of --- values. The lists must be of the same length. -bind_qubit_wire_list :: [Wire] -> [a] -> Bindings a b -> Bindings a b -bind_qubit_wire_list ws xs bindings = - foldr (\ (w, x) -> bind_qubit_wire w x) bindings (zip ws xs) - --- | Like 'bind_bit_wire', except bind a list of bit wires to a list of --- values. The lists must be of the same length. -bind_bit_wire_list :: [Wire] -> [b] -> Bindings a b -> Bindings a b -bind_bit_wire_list ws xs bindings = - foldr (\ (w, x) -> bind_bit_wire w x) bindings (zip ws xs) - --- | Like 'unbind', except retrieve a list of values. -unbind_list :: Bindings a b -> [Wire] -> [B_Endpoint a b] -unbind_list bindings ws = - map (unbind bindings) ws - --- | Like 'unbind_qubit_wire', except retrieve a list of values. -unbind_qubit_wire_list :: Bindings a b -> [Wire] -> [a] -unbind_qubit_wire_list bindings ws = - map (unbind_qubit_wire bindings) ws - --- | Like 'unbind_bit_wire', except retrieve a list of values. -unbind_bit_wire_list :: Bindings a b -> [Wire] -> [b] -unbind_bit_wire_list bindings ws = - map (unbind_bit_wire bindings) ws - --- | A list of signed values of type ⟦Endpoint⟧. This type is an --- abbreviation defined for convenience. -type Ctrls a b = [Signed (B_Endpoint a b)] - --- | Given a list of signed wires (controls), and a list of signed --- values, make a bindings from the wires to the values. Ignore the signs. -bind_controls :: Controls -> Ctrls a b -> Bindings a b -> Bindings a b -bind_controls controls xs bindings = - bind_list (map from_signed controls) (map from_signed xs) bindings - --- | Like 'unbind', but retrieve binding for all wires in a list of --- controls. -unbind_controls :: Bindings a b -> Controls -> Ctrls a b -unbind_controls bindings c = - [Signed (unbind bindings w) b | Signed w b <- c ] - --- $transformers_anchor #Transformers# - --- ---------------------------------------------------------------------- --- * Transformers - --- $transformers --- --- The types 'T_Gate' and 'Transformer' are at the heart of the --- circuit transformer functionality. Their purpose is to give a --- concise syntax in which to express semantic functions for gates. As --- mentioned in the introduction, the programmer needs to specify two --- type /a/ and /b/, a monad /m/, and a semantic function for each --- gate. With the T_Gate' and 'Transformer' types, the definition --- takes the following form: --- --- > my_transformer :: Transformer m a b --- > my_transformer (T_Gate1 f) = f $ --- > my_transformer (T_Gate2 f) = f $ --- > my_transformer (T_Gate3 f) = f $ --- > ... --- --- The type 'T_Gate' is very higher-order, involving a function /f/ --- that consumes the semantic function for each gate. The reason for --- this higher-orderness is that the semantic functions for different --- gates may have different types. --- --- This higher-orderness makes the 'T_Gate' mechanism hard to read, --- but easy to use. Effectively we only have to write lengthy and --- messy code once and for all, rather than once for each transformer. --- In particular, all the required low-level bindings and unbindings --- can be handled by general-purpose code, and do not need to clutter --- each transformer. - --- | The type 'T_Gate' is used to define case distinctions over gates --- in the definition of transformers. For each kind of gate /X/, it --- contains a constructor of the form @(T_X f)@. Here, /X/ identifies --- the gate, and /f/ is a higher-order function to pass the --- translation of /X/ to. - --- Implementation note: in the future, perhaps we can also add two --- variants of this type: one that is specialized to the "simple" --- case, where the semantics functions are assumed not to modify the --- controls; another that is specialized to m = Id. This would make --- the definition of most circuit transformers look less cluttered. - -data T_Gate m a b x = - T_QGate String Int Int InverseFlag NoControlFlag (([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> x) - | T_QRot String Int Int InverseFlag Timestep NoControlFlag (([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> x) - | T_GPhase Double NoControlFlag (([B_Endpoint a b] -> Ctrls a b -> m (Ctrls a b)) -> x) - | T_CNot NoControlFlag ((b -> Ctrls a b -> m (b, Ctrls a b)) -> x) - | T_CGate String NoControlFlag (([b] -> m (b, [b])) -> x) - | T_CGateInv String NoControlFlag ((b -> [b] -> m [b]) -> x) - | T_CSwap NoControlFlag ((b -> b -> Ctrls a b -> m (b, b, Ctrls a b)) -> x) - | T_QPrep NoControlFlag ((b -> m a) -> x) - | T_QUnprep NoControlFlag ((a -> m b) -> x) - | T_QInit Bool NoControlFlag (m a -> x) - | T_CInit Bool NoControlFlag (m b -> x) - | T_QTerm Bool NoControlFlag ((a -> m ()) -> x) - | T_CTerm Bool NoControlFlag ((b -> m ()) -> x) - | T_QMeas ((a -> m b) -> x) - | T_QDiscard ((a -> m ()) -> x) - | T_CDiscard ((b -> m ()) -> x) - | T_DTerm Bool ((b -> m ()) -> x) - | T_Subroutine BoxId InverseFlag NoControlFlag ControllableFlag [Wire] Arity [Wire] Arity RepeatFlag ((Namespace -> [B_Endpoint a b] -> Ctrls a b -> m ([B_Endpoint a b], Ctrls a b)) -> x) - | T_Comment String InverseFlag (([(B_Endpoint a b, String)] -> m ()) -> x) - --- Make 'T_Gate' an instance of 'Show', to enable transformers to --- produce better error messages about unimplemented gates etc. -instance Show (T_Gate m a b x) where - show (T_QGate name n m inv ncf f) = "QGate[" ++ name ++ "," ++ show n ++ "," ++ show m ++ "]" ++ optional inv "*" - show (T_QRot name n m inv t ncf f) = "QRot[" ++ name ++ "," ++ show t ++ "," ++ show n ++ "," ++ show m ++ "]" ++ optional inv "*" - show (T_GPhase t ncf f) = "GPhase[" ++ show t ++ "]" - show (T_CNot ncf f) = "CNot" - show (T_CGate n ncf f) = "CGate[" ++ n ++ "]" - show (T_CGateInv n ncf f) = "CGate[" ++ n ++ "]*" - show (T_CSwap ncf f) = "CSwap" - show (T_QPrep ncf f) = "QPrep" - show (T_QUnprep ncf f) = "QUnprep" - show (T_QInit b ncf f) = "QInit" ++ if b then "1" else "0" - show (T_CInit b ncf f) = "CInit" ++ if b then "1" else "0" - show (T_QTerm b ncf f) = "QTerm" ++ if b then "1" else "0" - show (T_CTerm b ncf f) = "CTerm" ++ if b then "1" else "0" - show (T_QMeas f) = "QMeas" - show (T_QDiscard f) = "QDiscard" - show (T_CDiscard f) = "CDiscard" - show (T_DTerm b f) = "DTerm" ++ if b then "1" else "0" - show (T_Subroutine n inv ncf scf ws a1 vs a2 rep f) = "Subroutine(x" ++ (show rep) ++ ")[" ++ show n ++ "]" ++ optional inv "*" - show (T_Comment n inv f) = "Comment[" ++ n ++ "]" ++ optional inv "*" - --- | A circuit transformer is specified by defining a function of type --- 'Transformer' /m/ /a/ /b/. This involves specifying a monad /m/, --- semantic domains /a/=⟦Qubit⟧ and /b/=⟦Bit⟧, and a semantic function --- for each gate, like this: --- --- > my_transformer :: Transformer m a b --- > my_transformer (T_Gate1 f) = f $ --- > my_transformer (T_Gate2 f) = f $ --- > my_transformer (T_Gate3 f) = f $ --- > ... - --- Implementation note: the use of \"forall\" in this type is to allow --- some freedom in the return type of the continuation 'f' in the --- definition of 'T_Gate'. This makes it easier, for example, to --- compose transformers with other transformers. The use of \"forall\" --- implies that any module that uses the 'Transformer' type may have --- to declare the @Rank2Types@ language extension. This was not --- required in GHC 7.4, but seems to be required in GHC 7.6. -type Transformer m a b = forall x . T_Gate m a b x -> x - --- | A \"binding transformer\" is a function from bindings to --- bindings. The semantics of any gate or circuit is ultimately a --- binding transformer, for some types /a/, /b/ and some monad /m/. We --- introduce an abbreviation for this type primarily as a convenience --- for the definition of 'bind_gate', but also because this type can --- be completely hidden from user code. -type BT m a b = Bindings a b -> m (Bindings a b) - --- | Turn a 'Gate' into a 'T_Gate'. This is the function that actually --- handles the explicit bindings/unbindings required for the inputs --- and outputs of each gate. Effectively it gives a way, for each --- gate, of turning a semantic function into a binding transformer. --- Additionally, this function is passed a Namespace, so that the --- semantic function for T_Subroutine can use it. -bind_gate :: Monad m => Namespace -> Gate -> T_Gate m a b (BT m a b) -bind_gate namespace gate = case gate of - QGate name inv ws vs c ncf -> T_QGate name n m inv ncf (list_binary ws vs c) - where - n = length ws - m = length vs - QRot name inv t ws vs c ncf -> T_QRot name n m inv t ncf (list_binary ws vs c) - where - n = length ws - m = length vs - GPhase t w c ncf -> T_GPhase t ncf (phase_ary w c) - CNot w c ncf -> T_CNot ncf (cunary w c) - CGate n w vs ncf -> T_CGate n ncf (cgate_ary w vs) - CGateInv n w vs ncf -> T_CGateInv n ncf (cgateinv_ary w vs) - CSwap w v c ncf -> T_CSwap ncf (binary_c w v c) - QPrep w ncf -> T_QPrep ncf (qprep_ary w) - QUnprep w ncf -> T_QUnprep ncf (qunprep_ary w) - QInit b w ncf -> T_QInit b ncf (qinit_ary w) - CInit b w ncf -> T_CInit b ncf (cinit_ary w) - QTerm b w ncf -> T_QTerm b ncf (qterm_ary w) - CTerm b w ncf -> T_CTerm b ncf (cterm_ary w) - QMeas w -> T_QMeas (qunprep_ary w) - QDiscard w -> T_QDiscard (qterm_ary w) - CDiscard w -> T_CDiscard (cterm_ary w) - DTerm b w -> T_DTerm b (cterm_ary w) - Subroutine n inv ws a1 vs a2 c ncf scf rep - -> T_Subroutine n inv ncf scf ws a1 vs a2 rep - (\f -> subroutine_ary ws vs c (f namespace)) - Comment s inv ws -> T_Comment s inv (comment_ary ws) - where - unary :: Monad m => Wire -> Controls -> (a -> Ctrls a b -> m (a, Ctrls a b)) -> BT m a b - unary w c f bindings = do - let w' = unbind_qubit_wire bindings w - let c' = unbind_controls bindings c - (w'', c'') <- f w' c' - let bindings1 = bind_qubit_wire w w'' bindings - let bindings2 = bind_controls c c'' bindings1 - return bindings2 - - binary :: Monad m => Wire -> Wire -> Controls -> (a -> a -> Ctrls a b -> m (a, a, Ctrls a b)) -> BT m a b - binary w v c f bindings = do - let w' = unbind_qubit_wire bindings w - let v' = unbind_qubit_wire bindings v - let c' = unbind_controls bindings c - (w'', v'', c'') <- f w' v' c' - let bindings1 = bind_qubit_wire w w'' bindings - let bindings2 = bind_qubit_wire v v'' bindings1 - let bindings3 = bind_controls c c'' bindings2 - return bindings3 - - binary_c :: Monad m => Wire -> Wire -> Controls -> (b -> b -> Ctrls a b -> m (b, b, Ctrls a b)) -> BT m a b - binary_c w v c f bindings = do - let w' = unbind_bit_wire bindings w - let v' = unbind_bit_wire bindings v - let c' = unbind_controls bindings c - (w'', v'', c'') <- f w' v' c' - let bindings1 = bind_bit_wire w w'' bindings - let bindings2 = bind_bit_wire v v'' bindings1 - let bindings3 = bind_controls c c'' bindings2 - return bindings3 - - list_unary :: Monad m => [Wire] -> Controls -> ([a] -> Ctrls a b -> m ([a], Ctrls a b)) -> BT m a b - list_unary ws c f bindings = do - let ws' = unbind_qubit_wire_list bindings ws - let c' = unbind_controls bindings c - (ws'', c'') <- f ws' c' - let bindings1 = bind_qubit_wire_list ws ws'' bindings - let bindings2 = bind_controls c c'' bindings1 - return bindings2 - - list_binary :: Monad m => [Wire] -> [Wire] -> Controls -> ([a] -> [a] -> Ctrls a b -> m ([a], [a], Ctrls a b)) -> BT m a b - list_binary ws vs c f bindings = do - let ws' = unbind_qubit_wire_list bindings ws - let vs' = unbind_qubit_wire_list bindings vs - let c' = unbind_controls bindings c - (ws'', vs'', c'') <- f ws' vs' c' - let bindings1 = bind_qubit_wire_list ws ws'' bindings - let bindings2 = bind_qubit_wire_list vs vs'' bindings1 - let bindings3 = bind_controls c c'' bindings2 - return bindings3 - - qprep_ary :: Monad m => Wire -> (b -> m a) -> BT m a b - qprep_ary w f bindings = do - let w' = unbind_bit_wire bindings w - w'' <- f w' - let bindings1 = bind_qubit_wire w w'' bindings - return bindings1 - - qunprep_ary :: Monad m => Wire -> (a -> m b) -> BT m a b - qunprep_ary w f bindings = do - let w' = unbind_qubit_wire bindings w - w'' <- f w' - let bindings1 = bind_bit_wire w w'' bindings - return bindings1 - - cunary :: Monad m => Wire -> Controls -> (b -> Ctrls a b -> m (b, Ctrls a b)) -> BT m a b - cunary w c f bindings = do - let w' = unbind_bit_wire bindings w - let c' = unbind_controls bindings c - (w'', c'') <- f w' c' - let bindings1 = bind_bit_wire w w'' bindings - let bindings2 = bind_controls c c'' bindings1 - return bindings2 - - qinit_ary :: Monad m => Wire -> m a -> BT m a b - qinit_ary w f bindings = do - w'' <- f - let bindings1 = bind_qubit_wire w w'' bindings - return bindings1 - - cinit_ary :: Monad m => Wire -> m b -> BT m a b - cinit_ary w f bindings = do - w'' <- f - let bindings1 = bind_bit_wire w w'' bindings - return bindings1 - - qterm_ary :: Monad m => Wire -> (a -> m ()) -> BT m a b - qterm_ary w f bindings = do - let w' = unbind_qubit_wire bindings w - () <- f w' - let bindings1 = bind_delete w bindings - return bindings1 - - cterm_ary :: Monad m => Wire -> (b -> m ()) -> BT m a b - cterm_ary w f bindings = do - let w' = unbind_bit_wire bindings w - () <- f w' - let bindings1 = bind_delete w bindings - return bindings1 - - cgate_ary :: Monad m => Wire -> [Wire] -> ([b] -> m (b, [b])) -> BT m a b - cgate_ary w vs f bindings = do - let vs' = unbind_bit_wire_list bindings vs - (w'', vs'') <- f vs' - let bindings1 = bind_bit_wire w w'' bindings - let bindings2 = bind_bit_wire_list vs vs'' bindings1 - return bindings2 - - cgateinv_ary :: Monad m => Wire -> [Wire] -> (b -> [b] -> m [b]) -> BT m a b - cgateinv_ary w vs f bindings = do - let vs' = unbind_bit_wire_list bindings vs - let w' = unbind_bit_wire bindings w - vs'' <- f w' vs' - let bindings1 = bind_bit_wire_list vs vs'' bindings - return bindings1 - - subroutine_ary :: Monad m => [Wire] -> [Wire] -> Controls - -> ([B_Endpoint a b] -> Ctrls a b -> m ([B_Endpoint a b], Ctrls a b)) - -> BT m a b - subroutine_ary ws vs c f bindings = do - let c' = unbind_controls bindings c - let ws' = unbind_list bindings ws - (vs'',c'') <- f ws' c' - let bindings1 = bind_list vs vs'' bindings - let bindings2 = bind_controls c c'' bindings1 - return bindings2 - - phase_ary :: Monad m => [Wire] -> Controls -> ([B_Endpoint a b] -> Ctrls a b -> m (Ctrls a b)) -> BT m a b - phase_ary w c f bindings = do - let w' = map (unbind bindings) w - let c' = unbind_controls bindings c - c'' <- f w' c' - let bindings1 = bind_controls c c'' bindings - return bindings1 - - comment_ary :: Monad m => [(Wire, String)] -> (([(B_Endpoint a b, String)] -> m ()) -> BT m a b) - comment_ary ws f bindings = do - let ws' = zip (unbind_list bindings $ map fst ws) (map snd ws) - f ws' - return bindings - --- ---------------------------------------------------------------------- --- * Applying transformers to circuits - --- | Apply a 'Transformer' ⟦-⟧ to a 'Circuit' /C/, and output the --- semantic function ⟦/C/⟧ :: bindings -> bindings. -transform_circuit :: Monad m => Transformer m a b -> Circuit -> Bindings a b -> m (Bindings a b) -transform_circuit transformer c bindings = - foldM apply bindings gs - where - (_,gs,_,_) = c - apply bindings g = transformer (bind_gate namespace_empty g) bindings - --- | Like 'transform_circuit', but for boxed circuits. --- --- The handling of subroutines will depend on the transformer. --- For \"gate transformation\" types of applications, one typically --- would like to leave the boxed structure intact. --- For \"simulation\" types of applications, one would generally --- recurse through the boxed structure. --- --- The difference is specified in the definition of the transformer --- within the semantic function of the Subroutine gate, whether to --- create another boxed gate or open the box. -transform_bcircuit_rec :: Monad m => Transformer m a b -> BCircuit -> Bindings a b -> m (Bindings a b) -transform_bcircuit_rec transformer (c,namespace) bindings = - foldM apply bindings gs - where - (_,gs,_,_) = c - apply bindings g = transformer (bind_gate namespace g) bindings - --- | Same as 'transform_bcircuit_rec', but specialized to when /m/ is --- the identity operation. -transform_bcircuit_id :: Transformer Id a b -> BCircuit -> Bindings a b -> Bindings a b -transform_bcircuit_id t c b = getId (transform_bcircuit_rec t c b) - --- | To transform Dynamic Boxed circuits, we require a Transformer to define the --- behavior on static gates, but we also require functions for what to do when --- a subroutine is defined, and for when a dynamic_lift operation occurs. This is --- all wrapped in the DynamicTransformer data type. -data DynamicTransformer m a b = DT { - transformer :: Transformer m a b, - define_subroutine :: BoxId -> TypedSubroutine -> m (), - lifting_function :: b -> m Bool - } - --- | Like 'transform_bcircuit_rec', but for dynamic-boxed circuits. --- --- \"Write\" operations can be thought of as gates, and so they are passed to --- the given transformer. The handling of \"Read\" operations is taken care of --- by the \"lifting_function\" of the DynamicTransformer. \"Subroutine\" operations --- call the 'define_subroutine' function of the DynamicTransformer. -transform_dbcircuit :: Monad m => DynamicTransformer m a b -> DBCircuit x -> Bindings a b -> m (x,Bindings a b) -transform_dbcircuit dt (a0,rw) bindings = evalStateT (inner_transform dt (a0,rw) bindings) namespace_empty where - inner_transform :: Monad m => DynamicTransformer m a b -> DBCircuit x -> Bindings a b -> (StateT Namespace m) (x,Bindings a b) - inner_transform dt (a0,rw) bindings = - case rw of - (RW_Return (_,_,x)) -> return (x,bindings) - (RW_Write gate rw') -> do - namespace <- get - bindings' <- lift $ (transformer dt) (bind_gate namespace gate) bindings - inner_transform dt (a0,rw') bindings' - (RW_Read wire rw_cont) -> do - let bit = unbind_bit_wire bindings wire - bool <- lift $ (lifting_function dt) bit - let rw' = rw_cont bool - inner_transform dt (a0,rw') bindings - (RW_Subroutine name subroutine rw') -> do - lift $ (define_subroutine dt) name subroutine - namespace <- get - let namespace' = map_provide name subroutine namespace - put namespace' - inner_transform dt (a0,rw') bindings