diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,66 @@ +Contributors are listed here, in alphabetical order by last name. +Unless otherwise noted, the copyright for his or her contributions +rests with each individual author. For contributions by authors whose +name is marked (ACS), the copyright rests with Applied Communication +Sciences. + +Copyright (C) 2011-2016. All rights reserved. +Copyright (C) 2012-2013 Applied Communication Sciences. All rights +reserved. + +Richard Eisenberg +Alexander S. Green +Peter LeFanu Lumsdaine +Keith Kim (ACS) +Siun-Chuon Mau (ACS) +Baranidharan Mohan +Won Ng (ACS) +Joel Ravelomanantsoa-Ratsimihah +Neil J. Ross +Artur Scherer (ACS) +Peter Selinger +Benoît Valiron +Alexandr Virodov (ACS) +Stephan A. Zdancewic + +This research was supported by the Intelligence Advanced Research +Projects Activity (IARPA) via Department of Interior National Business +Center contract numbers D11PC20168 and D12PC00527. The U.S. Government +is authorized to reproduce and distribute reprints for Governmental +purposes notwithstanding any copyright annotation thereon. Disclaimer: +The views and conclusions contained herein are those of the authors +and should not be interpreted as necessarily representing the official +policies or endorsements, either expressed or implied, of IARPA, +DoI/NBC, or the U.S. Government. + +---------------------------------------------------------------------- +LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. The name of the authors and copyright holders may not be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +---------------------------------------------------------------------- diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,428 @@ +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/quipper-core.cabal b/quipper-core.cabal new file mode 100644 --- /dev/null +++ b/quipper-core.cabal @@ -0,0 +1,34 @@ +name: quipper-core +version: 0.8 +synopsis: An embedded, scalable functional programming language for quantum computing. +description: + Quipper is an embedded, scalable functional programming language for quantum computing. It provides, among other things: + . + * A high-level circuit description language. This includes gate-by-gate descriptions of circuit fragments, as well as powerful operators for assembling and manipulating circuits. + * A monadic semantics, allowing for a mixture of procedural and declarative programming styles. + * Built-in facilities for automatic synthesis of reversible quantum circuits, including from classical code. + * Support for hierarchical circuits. + * Extensible quantum data types. + * Programmable circuit transformers. + * Support for three execution phases: compile time, circuit generation time, and circuit execution time. A dynamic lifting operation to allow circuit generation to be parametric on values generated at circuit execution time. + * Extensive libraries of quantum functions, including: libraries for quantum integer and fixed-point arithmetic; the Quantum Fourier transform; an efficient Qram implementation; libraries for simulation of pseudo-classical circuits, Stabilizer circuits, and arbitrary circuits; libraries for exact and approximate decomposition of circuits into specific gate sets. + . + This package contains all of quipper, except for the rendering part, which has been separated into the quipper-to reduce dependencies. +homepage: http://www.mathstat.dal.ca/~selinger/quipper/ +license: BSD3 +license-file: COPYRIGHT +author: Applied Communication Sciences +maintainer: leonardo.taglialegne@gmail.com +copyright: Copyright (C) 2012-2013 Applied Communication Sciences. +-- category: +build-type: Simple +extra-source-files: README +cabal-version: >=1.10 + +library + exposed-modules: Quipper, Quipper.Generic, Quipper.CircLifting, Quipper.Classical, Quipper.QData, 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.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, template-haskell >=2.8 && <2.12, mtl >=2.1 && <2.3, primes >=0.2 && <0.3 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Libraries/Auxiliary.hs b/src/Libraries/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Libraries/Auxiliary.hs @@ -0,0 +1,926 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/CommandLine.hs @@ -0,0 +1,72 @@ +-- 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/RandomSource.hs b/src/Libraries/RandomSource.hs new file mode 100644 --- /dev/null +++ b/src/Libraries/RandomSource.hs @@ -0,0 +1,25 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Sampling.hs @@ -0,0 +1,285 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Template.hs @@ -0,0 +1,67 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Template/Auxiliary.hs @@ -0,0 +1,88 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Template/ErrorMsgQ.hs @@ -0,0 +1,62 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Template/LiftQ.hs @@ -0,0 +1,288 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Template/Lifting.hs @@ -0,0 +1,636 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Tuple.hs @@ -0,0 +1,103 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Libraries/Typeable.hs @@ -0,0 +1,58 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper.hs @@ -0,0 +1,518 @@ +-- 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, + + -- ** 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.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 new file mode 100644 --- /dev/null +++ b/src/Quipper/CircLifting.hs @@ -0,0 +1,563 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Circuit.hs @@ -0,0 +1,769 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Classical.hs @@ -0,0 +1,241 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Control.hs @@ -0,0 +1,260 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Generic.hs @@ -0,0 +1,1623 @@ +-- 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/Labels.hs b/src/Quipper/Labels.hs new file mode 100644 --- /dev/null +++ b/src/Quipper/Labels.hs @@ -0,0 +1,535 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Monad.hs @@ -0,0 +1,1819 @@ +-- 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/QClasses.hs b/src/Quipper/QClasses.hs new file mode 100644 --- /dev/null +++ b/src/Quipper/QClasses.hs @@ -0,0 +1,140 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/src/Quipper/QData.hs @@ -0,0 +1,1358 @@ +-- 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 -freduction-depth=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 new file mode 100644 --- /dev/null +++ b/src/Quipper/Transformer.hs @@ -0,0 +1,624 @@ +-- 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