quipper-rendering (empty) → 0.8

raw patch · 8 files changed

+3366/−0 lines, 8 filesdep +basedep +containersdep +directorysetup-changed

Dependencies added: base, containers, directory, easyrender, mtl, primes, process, quipper-core, random, template-haskell, unix

Files

• COPYRIGHT +66/−0
• README +428/−0
• Setup.hs +2/−0
• quipper-rendering.cabal +41/−0
• src/Libraries/Auxiliary.hs +926/−0
• src/Libraries/CommandLine.hs +72/−0
• src/Libraries/PortableSignals.hs +139/−0
• src/Quipper/Printing.hs +1692/−0

@@ -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.+----------------------------------------------------------------------

@@ -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>    --format=<format>      output format for circuits (default: preview)+  -g <gatebase>  --gatebase=<gatebase>  type of gates to decompose into (default: logical)+  -o <oracle>                           select oracle to use (default: orthodox)+  -n <n>         --height=<n>           set tree height (positive; default 5)+  -c <c>         --color=<c>            color to use with --oracle (0..3, default 0)+  -s <s>         --repeats=<s>          set parameter s (iteration count; default 1)+  -l             --large                set large problem size: n=300, s=336960+  -t <dt>        --dt=<dt>              set parameter dt (simulation time step; default pi/180)+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+Possible values for oracle are: orthodox, simple, blackbox, classical, template, optimized.++Examples of command line options:+---------------------------------++* Show the complete circuit for the BWT algorithm using the+  "orthodox" (official GFI) oracle, with n=5 and s=1:++  ./bwt -C -o orthodox -n 5 -s 1++  (One can point out the different parts of the algorithm: 8 oracle+  calls, and 4 very short diffusion steps).++* Show the same, using the "Template Haskell" oracle: this oracle is+  much larger, but automatically generated from classical code (and+  completely unoptimized):++  ./bwt -C -o template -n 5 -s 1++  The "template oracle" is defined in BWT/Template.hs. See the+  documentation of the module Quipper/CircLifting for how it works.++* Show the graph of the BWT algorithm, which is obtained by+  simulating the orthodox oracle (and therefore offers some evidence+  for the correctness of the oracle implementation):++  ./bwt -G -o orthodox -n 5++* Show the orthodox oracle for n=300. Note that this will result in a+  big file. One has to zoom in substantially to see gates. ++  ./bwt -O -o orthodox -n 300++* Show the complete circuit for the BWT algorithm, but decompose+  everything into binary gates:++  ./bwt -C -o orthodox -n 5 -s 1 -g binary ++* Show the oracle from Figure 1a (alternate oracle).++  ./bwt -C -o figure1a++* The same, decomposed into binary+Toffoli gates, or binary gates+  only, respectively:++  ./bwt -C -o figure1a -g toffoli+  ./bwt -C -o figure1a -g binary++* Show gate counts for BWT algorithm with n=300 and s=1, using+  "orthodox" oracle:++  ./bwt -C -o orthodox -n 300 -s 1 -f gatecount++* Show gate counts for same, after decomposition to binary gates:++  ./bwt -C -o orthodox -n 300 -s 1 -f gatecount -g binary ++Obviously, most other combinations of command line options are also+possible, for example: decompose to toffoli gates and then simulate+and show the graph. Some other combinations are not legal: for+example, decomposing to binary gates and then simulating. (The+classical simulator will complain that the circuit is not boolean; it+contains "V" gates).++* Similarly, one can run demos for the triangle finding+  algorithm using various command line options. ++Note that the triangle finding algorithm is not a deliverable; it is a+work in progress. The only implemented algorithm that is officially a+deliverable is the "orthodox" BWT implementation in BWT.BWT.++Running the bf program+======================++Usage for the Boolean Formula algorithm:+----------------------------------------++Usage: bf [OPTION...]+  -C             --circuit              output the whole circuit (default)+  -D             --demo                 run a demo of the circuit+  -H             --hexboard             output a representation of the initial state of the given oracle, i.e. the game played so far+  -p <part>      --part=<part>          which part of the circuit to use (default: whole)+  -o <oracle>    --oracle=<oracle>      which oracle to use (default: small)+  -m <moves>     --moves=<moves>        which moves have already been made (default: [])+  -f <format>    --format=<format>      output format for circuits (default: _preview)+  -d             --dummy                set to only use a dummy HEX gate instead of the full hex circuit+  -h             --help                 print usage info and exit+  -g <gatebase>  --gatebase=<gatebase>  type of gates to decompose the output circuit into (default: logical)+Possible values for part are: whole, u, oracle, hex, checkwin_red, diffuse, walk, undo_oracle.+Possible values for oracle are: 9by7, small, custom x y t.+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.++Running the cl program+======================++Usage for the Class Number algorithm:+-------------------------------------++Usage: cl [OPTION...]+  -h               --help                 print usage info and exit+  -f <format>      --format=<format>      output format for circuits        (default: ASCII)+  -g <gatebase>    --gatebase=<gatebase>  gates to decompose into           (default: Logical)+  -1                                      output the circuit for stage 1 of the algorithm (default)+  -4                                      output the circuit for stage 4 of the algorithm+  -S <subroutine>  --sub=<subroutine>     output the circuit for a specific subroutine+  -R               --regulator            classically, find the regulator, given Δ+  -F                                      classically, find the fundamental unit, given Δ+  -P                                      classically, find the fundamental solution of Pell’s equation, given Δ+  -d <N>           --delta=<N>            discriminant Δ (a.k.a. D)                 (default: 28)+  -s <N>           --ss=<N>               estimated bound on period S, for stage 1 (default: 2)+  -i <N>                                  estimated bound on log_2 S, for stage 1 (default: 1)+  -r <N>           --rr=<N>               approximate regulator R, for stage 4  (default: 12.345)+  -q <N>                                  The parameter q, for stage 4        (default: 4)+  -k <N>                                  The parameter k, for stage 4        (default: 3)+  -n <N>                                  The parameter n, for stage 4        (default: 3)+  -m <N>                                  The parameter m, for stage 4        (default: 5)+                   --seed=<N>             Random seed (0 for seed from time)(default: 1)+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+Possible values for subroutine are: rho, rhoinv, normalize, dotprod, starprod, fn.++Running the gse program+=======================++Usage for Ground State Estimation algorithm:+--------------------------------------------++Usage: gse [OPTION...]+  -h             --help                 print usage info and exit+  -C             --circuit              output the whole circuit (default)+  -T <indices>   --template=<indices>   output a particular circuit template+  -f <format>    --format=<format>      output format for circuits (default: Preview)+  -g <gatebase>  --gatebase=<gatebase>  gates to decompose into (default: Logical)+  -m <N>         --orbitals=<N>         number of orbitals (default: 4)+  -o <N>         --occupied=<N>         number of occupied orbitals (default: 2)+  -b <N>         --precision=<N>        number of precision qubits (default: 3)+  -D <energy>    --delta_e=<energy>     energy range (default: 6.5536)+  -E <energy>    --e_max=<energy>       maximum energy (default: -3876.941)+                 --n0=<N>               use N_k = n0 * 2^k (default: N_k = 1)+  -l             --large                set large problem size (m=208, o=84, b=12, n0=100)+  -x             --orthodox             use the Coulomb operator of Whitman et al.+                 --h1=<file>            filename for one-electron data (default: "h_1e_ascii")+                 --h2=<file>            filename for two-electron data (default: "h_2e_ascii")+  -d <file>      --datadir=<file>       directory for one- and two-electron data (default: current)+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+Indices can be specified as p,q or p,q,r,s (with no spaces)++Running the qls program+=======================++Usage for Quantum Linear Systems algorithm:+-------------------------------------------++Usage: qls [OPTION...]+  -h             --help                 print usage info and exit+  -C             --circuit              output the whole circuit (default)+  -O <name>      --oracle=<name>        output only the oracle <name> (default: r) +  -f <format>    --format=<format>      output format for circuits (default: gatecount)+  -g <gatebase>  --gatebase=<gatebase>  type of gates to decompose into (default: logical)+  -o <oracle>                           select oracle implementation to use (default: blackbox)+  -p <param>     --param=<param>        choose a set of parameters (default: dummy).+  -P <n>         --peel=<n>             peel <n> layers of boxed subroutines (default: 0).+Possible values for format are: ascii, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+Possible values for oracle implementation are: matlab, blackbox.+Possible values for param are: dummy, small, large.+Possible values for oracle are: r, b, A[band][t|f]. E.g. "-OA1t" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0.++Running the tf program+======================++Usage for Triangle Finding algorithm:+-------------------------------------++Usage: tf [OPTION...]+  -h               --help                     print usage info and exit+  -f <format>      --format=<format>          output format for circuits (default: preview)+  -g <gatebase>    --gatebase=<gatebase>      type of gates to decompose into (default: logical)+  -l <l>           --l=<l>                    parameter l (default: 4)+  -n <n>           --n=<n>                    parameter n (default: 3)+  -r <r>           --r=<r>                    parameter r (default: 2)+  -C               --QWTFP                    output the whole circuit (default)+  -O               --oracle                   output only the oracle+  -s <subroutine>  --subroutine=<subroutine>  output the chosen subroutine (default: adder)+  -Q                                          use alternative qRAM implementation+  -o <oracle>                                 select oracle to use (default: blackbox)+  -A               --arith                    test/simulate the arithmetic routines+  -T               --oracletest               test/simulate the oracle+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+Possible values for oracle are: orthodox, blackbox.+Possible values for subroutine are: zero, initialize, hadamard, setup, qwsh, diffuse, fetcht, storet, fetchstoret, fetche, fetchstoree, update, swap, a15, a16, a17, a18, gcqwalk, gcqwstep, convertnode, testequal, pow17, mod3, sub, add, mult.++Running the usv program+=======================++Usage for Unique Shortest Vector algorithm:+-------------------------------------------++Usage: usv [OPTION...]+  -h             --help                 print usage info and exit+  -f <format>    --format=<format>      output format for circuits (default: eps)+  -g <gatebase>  --gatebase=<gatebase>  type of gates to decompose into (default: logical)+  -n <n>         --n=<n>                parameter n (default: 5)+  -b <b>         --b=<b>                parameter b (default: 5X5 with entries = 1)+  -s <s>         --s=<s>                Random number generator seed s (default: 1)+  -F                                    output subroutine f (depends on b).+  -G                                    output subroutine g (depends on b).+  -H                                    output subroutine h (depends on n).+  -U                                    output algorithm 1 (depends on b).+  -Q                                    output algorithm 2 (depends on b).+  -R                                    output algorithm 3 (depends on b).+  -T                                    output algorithm 4 (depends on n).+  -S                                    output sieving subroutine (depends on n).+  -D                                    output algorithm 5 (depends on n).+  -t                                    test subroutine h (depends on n).+Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount.+Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols.+++Invoking the Quipper compiler+=============================++The Quipper compiler is called "quipper", and is located in the+directory quipper/scripts. The easiest way to use it is to add the+"scripts" directory to the environment variable PATH. If you move the+quipper script around, make sure to keep the other scripts in the same+directory as the quipper script, and to update QUIPPER_BASE in the+"quipper" and "quipperi" scripts to point to the directory where the+Quipper sources are located. On the Windows operating system, you+should use "quipper.bat"; on all other operating systems, just+"quipper" will do. ++In reality, the "quipper" script is a wrapper around the GHC Haskell+compiler, providing some pre-processing and setting required+compilation options. There is also a "quipperi" script for an+interactive version of the compiler, which is akin to "ghci".++To try this out, the directory "tests" contains various small+stand-alone programs that can be compiled with Quipper, and are useful+for demonstrating the basic Quipper idiom. Each program can be+compiled and run like this:++For example:++# to compile and run on Unix (or on Unix with the MSYS/bash):+quipper And_gate.hs+./And_gate++# to compile and run on Windows with cmd.exe:+quipper.bat And_gate.hs+And_gate++Note that there is also a Makefile, so "make" can be used to build the+programs as well.++If the previewer is working properly, the circuit should show up in+Acrobat Reader. If not, either change "Preview" to "EPS" in the file+(for PostScript output), or trouble-shoot the previewer installation+(if you are on Windows, see INSTALLING) and/or contact Benoit Valiron+<benoit.valiron@monoidal.net> or Peter Selinger+<selinger@mathstat.dal.ca> for help.++The naming of built-in gates and many operators can be found out by+looking at the documentation of the "Quipper" module (the main public+interface of the Quipper system).+++Troubleshooting Guidelines+==========================++In case of problems, please contact++ * Benoit Valiron <benoit.valiron@monoidal.net>+ * Peter Selinger <selinger@mathstat.dal.ca>

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,41 @@+name:                quipper-rendering+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 the rendering part, which has been separated to reduce dependencies in quipper-core.+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.Printing+  other-modules:       Libraries.CommandLine, Libraries.PortableSignals, Libraries.Auxiliary+  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, quipper-core >=0.8 && <0.9, random >=1.0 && <1.2, containers >=0.5 && <0.6, unix >=2.6 && <2.8, template-haskell >=2.8 && <2.12, mtl >=2.1 && <2.3, easyrender >=0.1 && <0.2, process >=1.1 && <1.5, directory >=1.2 && <1.3, primes >=0.2 && <0.3+  hs-source-dirs:      src+  default-language:    Haskell2010

@@ -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+-- >   <<<loop body depending on the parameter n>>>+-- > endfor+-- +-- The loop body will get executed once for each /n/ ∈ {1,2,3,4}.++foreach :: Monad m => [a] -> (a -> m b) -> m ()+foreach l f = mapM_ f l++-- ----------------------------------------------------------------------+-- * Operations for monads++-- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output+-- /m/ /f/ : /m/ /a/ → /m/ /b/.+mmap :: (Monad m) => (a -> b) -> m a -> m b+mmap f a = a >>= (return . f)++-- | Remove an outer application of a monad from a monadic function.+monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b+monad_join1 mf a = do+  f <- mf+  f a++-- ----------------------------------------------------------------------+-- * Operations for disjoint unions++-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return+-- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/.+map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d+map_either f g (Left x) = Left (f x)+map_either f g (Right x) = Right (g x)++-- | Monadic version of 'map_either'.+map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)+map_eitherM f g (Left x) = mmap Left (f x)+map_eitherM f g (Right x) = mmap Right (g x)++-- ----------------------------------------------------------------------+-- * Operations for tuples++-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return+-- /f/ × /g/ : /a/ × /c/ → /c/ × /d/.+map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)+map_pair f g (x, y) = (f x, g y)++-- | Monadic version of 'mappair'.+map_pairM :: (Monad m) => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d)+map_pairM f g (a, c) = do+  b <- f a+  d <- g c+  return (b, d)++-- ----------------------------------------------------------------------+-- * Arithmetic operations+  +-- | A version of the 'ceiling' function that returns an 'Integer'.+int_ceiling :: RealFrac a => a -> Integer+int_ceiling = toInteger . ceiling++-- ----------------------------------------------------------------------+-- * Bit vectors++-- | The type of bit vectors. True = 1, False = 0.+type Boollist = [Bool]++-- | Convert an integer to a bit vector. The first argument is the+-- length in bits, and the second argument the integer to be+-- converted. The conversion is big-headian (or equivalently,+-- little-tailian), i.e., the head of the list holds the integer's most+-- significant digit.+boollist_of_int_bh :: Integral a => Int -> a -> Boollist+boollist_of_int_bh m = reverse . boollist_of_int_lh m++-- | Convert an integer to a bit vector. The first argument is the+-- length in bits, and the second argument the integer to be+-- converted. The conversion is little-headian (or equivalently,+-- big-tailian), i.e., the head of the list holds the integer's least+-- significant digit.+boollist_of_int_lh :: Integral a => Int -> a -> Boollist+boollist_of_int_lh m x | m <= 0 = []+boollist_of_int_lh m x = digit : boollist_of_int_lh (m-1) tail where+  digit = (x `mod` 2 == 1)+  tail = x `div` 2++-- | Convert a bit vector to an integer. The conversion is big-headian+-- (or equivalently, little-tailian), i.e., the head of the list holds+-- the integer's most significant digit. This function is unsigned,+-- i.e., the integer returned is ≥ 0.+int_of_boollist_unsigned_bh :: Integral a => Boollist -> a+int_of_boollist_unsigned_bh v = aux v 0+  where+    aux v acc =+      case v of+        [] -> acc+        digit : vs -> aux vs (2*acc+(if digit then 1 else 0))++-- | Convert a bit vector to an integer, signed.+int_of_boollist_signed_bh :: Integral a => Boollist -> a+int_of_boollist_signed_bh [] = 0+int_of_boollist_signed_bh (False:v) = int_of_boollist_unsigned_bh v+int_of_boollist_signed_bh (True:v) = -1 - int_of_boollist_unsigned_bh (map not v)++-- | Exclusive or operation on booleans.+bool_xor :: Bool -> Bool -> Bool+bool_xor a b = (a /= b)++-- | Exclusive or operation on bit vectors.+boollist_xor :: Boollist -> Boollist -> Boollist+boollist_xor = zipWith bool_xor++-- ----------------------------------------------------------------------+-- * Formatting of lists and strings++-- | A general list-to-string function. Example:+-- +-- > string_of_list "{" ", " "}" "{}" show [1,2,3] = "{1, 2, 3}"+string_of_list :: String -> String -> String -> String -> (t -> String) -> [t] -> String+string_of_list lpar comma rpar nil string_of_elt lst =+  let string_of_tail lst =+        case lst of+          [] -> ""+          h:t -> comma ++ string_of_elt h ++ string_of_tail t+  in+  case lst of+    [] -> nil+    h:t -> lpar ++ string_of_elt h ++ string_of_tail t ++ rpar++-- | @'optional' b s@: if /b/ = 'True', return /s/, else the empty+-- string. This function is for convenience.+optional :: Bool -> String -> String+optional True s = s+optional False s = ""++-- ----------------------------------------------------------------------+-- * Lists optimized for fast concatenation++-- | The type of bidirectional lists. This is similar to [a], but+-- optimized for fast concatenation and appending on both sides.+newtype BList a = BList { getBList :: [a] -> [a] }++-- | Convert a List to a 'BList'.+blist_of_list :: [a] -> BList a+blist_of_list s = BList (\x -> s ++ x)++-- | Convert a 'BList' to a List.+list_of_blist :: BList a -> [a]+list_of_blist buf = getBList buf []++-- | Fast concatenation of 'BList's or string buffers.+(+++) :: BList a -> BList a -> BList a+(+++) buf1 buf2 = BList ((getBList buf1) . (getBList buf2))++-- | The empty 'BList'.+blist_empty :: BList a+blist_empty = BList id++-- | Concatenate a list of 'Blist's.+blist_concat :: [BList a] -> BList a+blist_concat l = foldr (+++) blist_empty l++instance (Show a) => Show (BList a) where+        show bl = show (list_of_blist bl) ++-- ----------------------------------------------------------------------+-- * Strings optimized for fast concatenation++-- | A string buffer holds a string that is optimized for fast+-- concatenation. Note that this is an instance of 'BList', and hence+-- 'BList' operations (in particular '+++') can be applied to string+-- buffers. The following functions are synonyms of the respective+-- 'BList' functions, and are provided for convenience.+type Strbuf = BList Char++-- | Convert a string to a string buffer.+strbuf_of_string :: String -> Strbuf+strbuf_of_string = blist_of_list++-- | Convert a string buffer to a string.+string_of_strbuf :: Strbuf -> String+string_of_strbuf = list_of_blist++-- | The empty string buffer.+strbuf_empty :: Strbuf+strbuf_empty = blist_empty++-- | Concatenate a list of string buffers.+strbuf_concat :: [Strbuf] -> Strbuf+strbuf_concat = blist_concat++-- ----------------------------------------------------------------------+-- * The identity monad+      +-- | The identity monad. Using /m/ = 'Id' gives useful special cases+-- of monadic functions.+newtype Id a = Id { getId :: a }++instance Monad Id where+  return a = Id a+  (Id a) >>= b = b a++instance Applicative Id where+  pure = return+  (<*>) = ap++instance Functor Id where+  fmap = liftM++-- ----------------------------------------------------------------------+-- * Identity types+  +-- | The type 'Identity' /a/ /b/ witnesses the fact that /a/ and /b/+-- are the same type. In other words, this type is non-empty if and+-- only if /a/ = /b/. This property is not guaranteed by the type+-- system, but by the API, via the fact that the operators+-- 'relexivity', 'symmetry', and 'transitivity' are the only exposed+-- constructors for this type. The implementation of this type is+-- deliberately hidden, as this is the only way to guarantee its+-- defining property.+-- +-- Identity types are useful in certain situations. For example, they+-- can be used to define a data type which is polymorphic in some type+-- variable /x/, and which has certain constructors that are only+-- available when /x/ is a particular type. For example, in the+-- declaration+-- +-- > data ExampleType x = Constructor1 x | Constructor2 x (Identity x Bool),+-- +-- @Constructor1@ is available for all /x/, but @Constructor2@ is only+-- available when /x/ = 'Bool'.+newtype Identity a b = Identity (a -> b, b -> a)++-- | Witness the fact that /a/=/a/.+reflexivity :: Identity a a+reflexivity = Identity (id, id)++-- | Witness the fact that /a/=/b/ implies /b/=/a/.+symmetry :: Identity a b -> Identity b a+symmetry (Identity (f,g)) = Identity (g,f)++-- | Witness the fact that /a/=/b/ and /b/=/c/ implies /a/=/c/.+transitivity :: Identity a b -> Identity b c -> Identity a c+transitivity (Identity (f,g)) (Identity (f',g')) = Identity (f'',g'') where+  f'' = f' . f+  g'' = g . g'++-- | The identity function 'id' : /a/ → /b/, provided that /a/ and /b/+-- are the same type.+identity :: Identity a b -> a -> b+identity (Identity (f,g)) = f++instance Show (Identity a b) where+  show x = "id"++-- ----------------------------------------------------------------------+-- * Isomorphism types++-- | The type 'Isomorphism' /a/ /b/ consists of isomorphisms between+-- /a/ and /b/, i.e. pairs (/f/,/g/) such that /g/./f/ == id :: /a/ -> /a/,+-- /f/./g/ == id :: /b/ -> /b/. +--+-- As with e.g. Haskell’s 'Monad' class, it is not possible in general+-- to guarantee that the intended laws hold; it is the programmer’s+-- responsibility to ensure this.+--+-- Under the hood, 'Isomorphism' and 'Identity' are in fact the same;+-- they differ just in the API exposed. +newtype Isomorphism a b = Isomorphism (a -> b, b -> a)++-- | Map forwards along an isomorphism.+iso_forwards :: Isomorphism a b -> a -> b+iso_forwards (Isomorphism (f,g)) = f++-- | Map backwards along an isomorphism.+iso_backwards :: Isomorphism a b -> b -> a+iso_backwards (Isomorphism (f,g)) = g++-- ======================================================================+-- * Error messages++-- | Often a low-level function, such as 'qcdata_zip' and+-- 'qcdata_promote', throws an error because of a failure of some+-- low-level condition, such as \"list too short\". To produce error+-- messages that are meaningful to user-level code, these functions do+-- not have a hard-coded error message. Instead, they input a stub+-- error message.+-- +-- A meaningful error message typically consists of at least three parts:+-- +-- * the name of the user-level function where the error occurred, for+-- example: \"reverse_generic\";+-- +-- * what the function was doing when the error occurred, for example:+-- \"operation not permitted in reversible circuit\";+-- +-- * a specific low-level reason for the error, for example: \"dynamic+-- lifting\".+-- +-- Thus, a meaningful error message may be: \"reverse_generic:+-- operation not permitted in reversible circuit: dynamic lifting\".+-- +-- The problem is that the three pieces of information are not usually+-- present in the same place. The user-level function is often a+-- wrapper function that performs several different mid-level+-- operations (e.g., transforming, reversing). The mid-level function+-- knows what operation was being performed when the error occurred,+-- but often calls a lower-level function to do the actual work (e.g.,+-- encapsulating).+--   +-- Therefore, a stub error message is a function that inputs some+-- lower-level reason for a failure (example: \"list too short\") and+-- translates this into a higher-level error message (example:+-- \"qterm: shape of parameter does not data: list too short\").+-- +-- Sometimes, the stub error message may also ignore the low-level+-- message and completely replace it by a higher-level one. For+-- example, a function that implements integers as bit lists may wish+-- to report a problem with integers, rather than a problem with the+-- underlying lists.+type ErrMsg = String -> String++-- ======================================================================+-- * The Curry type class++-- | The 'Curry' type class is used to implement functions that have a+-- variable number of arguments. It provides a family of type+-- isomorphisms+-- +-- @fun  ≅  args -> res,@+-- +-- where+-- +-- > fun = a1 -> a2 -> ... -> an -> res,+-- > args = (a1, (a2, (..., (an, ())))).++class Curry fun args res | args res -> fun where+  -- | Multiple curry: map a function +  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ +  -- to its curried form +  -- /a/[sub 1] → /a/[sub 2] → … → /b/.+  mcurry :: (args -> res) -> fun+  -- | Multiple uncurry: map a function+  -- /a/[sub 1] → /a/[sub 2] → … → /b/+  -- to its uncurried form +  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/.+  muncurry :: fun -> (args -> res)+               +instance Curry b () b where+  mcurry g = g ()+  muncurry x = const x++instance Curry fun args res => Curry (a -> fun) (a,args) res where+  mcurry g x = mcurry (\xs -> g (x,xs))+  muncurry f (x,xs) = muncurry (f x) xs+                

@@ -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"

@@ -0,0 +1,139 @@+-- This file is part of Quipper. Copyright (C) 2011-2016. Please see the+-- file COPYRIGHT for a list of authors, copyright holders, licensing,+-- and other details. All rights reserved.+-- +-- ======================================================================++{-# LANGUAGE CPP #-}++-- | This module provides a thin portability layer for handling user+-- interrupts.+-- +-- The reason is that in the standard Haskell library, this+-- functionality is only available in operating system specific+-- modules, namely "System.Posix.Signals" (for POSIX systems,+-- including Linux) and "GHC.ConsoleHandler" (for Windows).+-- +-- Note that despite this compatibility layer, there are some+-- operating system specific quirks:+-- +-- * In Windows, console events (such as Control-C) can only be+-- received by an application running in a Windows console. Certain+-- environments that look like consoles do not support console events,+-- such as xterm and rxvt windows, and Cygwin shells with @CYGWIN=tty@+-- set.+-- +-- * In Windows, setting a handler for any one signal automatically+-- overrides the handlers for all signals (effectively ignoring them).+-- Also, if the 'Default' or 'Ignore' handler is specified, it+-- applies to all signals.  We do not currently provide a way to+-- specify handlers for multiple signals.++module Libraries.PortableSignals (+  Signal(..),+  Handler(Default,Ignore,Catch,CatchOnce),+  installHandler,+  with_handler+  ) where++#ifdef mingw32_HOST_OS+import qualified GHC.ConsoleHandler as OS+#else+import qualified System.Posix.Signals as OS+#endif+       +-- ----------------------------------------------------------------------+-- * Common interface++-- | A data type for signals. This can be extended as needed.+data Signal =+  Interrupt  -- ^ Control-C event.+  | Close    -- ^ TERM signal (POSIX) or Close event (Windows).++-- | A data type for handlers.+data Handler =+  Default                -- ^ Default action.+  | Ignore               -- ^ Ignore the signal.+  | Catch (IO ())        -- ^ Handle the signal in a new thread when the signal is received.+  | CatchOnce (IO ())    -- ^ Like 'Catch', but only handle the first such signal.+  | OSHandler OS.Handler -- ^ An operating system specific handler.++-- | Install a handler for the given signal. The old handler is+-- returned. +installHandler :: Signal -> Handler -> IO Handler+#ifdef mingw32_HOST_OS+installHandler = installHandler_windows+#else+installHandler = installHandler_posix+#endif++-- | Run a block of code with a given signal handler. The previous+-- handler is restored when the block terminates.+with_handler :: Signal -> Handler -> IO a -> IO a+with_handler signal handler body = do+  oldhandler <- installHandler signal handler+  a <- body+  installHandler signal oldhandler+  return a++-- ----------------------------------------------------------------------+-- * Windows specific code++#ifdef mingw32_HOST_OS++-- | Check if the Windows 'ConsoleEvent' matches the given abstract+-- 'Signal'. We implement this as a relation, rather than a function,+-- to allow for more than one 'ConsoleEvent' to match the same+-- 'Signal', or for more than one 'Signal' to match the same+-- 'ConsoleEvent'.+signal_matches :: OS.ConsoleEvent -> Signal -> Bool+signal_matches OS.ControlC Interrupt = True+signal_matches OS.Close Close = True+signal_matches _ _ = False++-- | Windows implementation of 'installHandler'.+installHandler_windows :: Signal -> Handler -> IO Handler+installHandler_windows signal handler = do+  oldhandler <- OS.installHandler (oshandler handler)+  return (OSHandler oldhandler)+    where+      oshandler Default = OS.Default+      oshandler Ignore = OS.Ignore+      oshandler (Catch body) = OS.Catch $ \event -> do+        if signal_matches event signal+          then body +          else return ()+      oshandler (CatchOnce body) = OS.Catch $ \event -> do+        if signal_matches event signal +          then do+            -- uninstall the handler+            OS.installHandler OS.Default+            body+          else return ()+      oshandler (OSHandler h) = h+      +-- ----------------------------------------------------------------------+-- * POSIX specific code++#else++-- | Map an abstract 'Signal' to a POSIX specific 'OS.Signal'.+ossignal :: Signal -> OS.Signal+ossignal Interrupt = OS.keyboardSignal+ossignal Close = OS.softwareTermination++-- | Map a 'Handler' to a POSIX specific handler.+oshandler :: Handler -> OS.Handler+oshandler Default = OS.Default+oshandler Ignore = OS.Ignore+oshandler (Catch body) = OS.Catch body+oshandler (CatchOnce body) = OS.CatchOnce body+oshandler (OSHandler h) = h++-- | POSIX implementation of 'installHandler'.+installHandler_posix :: Signal -> Handler -> IO Handler+installHandler_posix signal handler = do+  oldhandler <- OS.installHandler (ossignal signal) (oshandler handler) Nothing+  return (OSHandler oldhandler)++#endif

@@ -0,0 +1,1692 @@+-- This file is part of Quipper. Copyright (C) 2011-2016. Please see the+-- file COPYRIGHT for a list of authors, copyright holders, licensing,+-- and other details. All rights reserved.+-- +-- ======================================================================++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE BangPatterns #-}++-- | Pretty-printing of low-level quantum circuits.++module Quipper.Printing (+  -- * ASCII representation of circuits+  ascii_of_bcircuit,+  print_dbcircuit_ascii,+  getBit,+  -- * Gate counts+  print_gatecounts_bcircuit,+  -- * Graphical representation of circuits+  render_dbcircuit,+  -- * Previewing+  preview_bcircuit,+  -- * Printing to multiple formats+  Format(..),+  FormatStyle(..),+  pdf,+  eps,+  ps,+  format_enum,+  print_dbcircuit,+  print_of_document,+  print_of_document_custom,+  -- * Generic printing+  print_unary,+  print_generic,+  print_simple,+  ) where++-- import other Quipper stuff+import Libraries.Auxiliary+import Quipper.Circuit+import Quipper.Generic+import Quipper.Monad+import Quipper.QData++-- import other stuff+import Prelude+import Text.Printf+import Data.Char(isSpace)+import Data.List+import Data.Maybe+import Control.Monad(when)+import Graphics.EasyRender+import System.IO+import System.Process+import System.Directory+import System.Environment+import System.Info++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Map (Map)+import qualified Data.Map as Map++import qualified Data.IntMap as IntMap+import qualified Data.List as List++-- ======================================================================+-- * Auxiliary functions++-- | Determine whether a named gate is self-inverse. The kind of a+-- gate is uniquely determined by its name, and the number of input+-- wires and generalized controls.+-- +-- For now, we only recognize "X", "Y", "Z", "H", "not", "swap", and+-- "W" as self-inverse; it is not currently possible for user code to+-- extend this list.+self_inverse :: String -> [Wire] -> [Wire] -> Bool+self_inverse "X" [q] [] = True+self_inverse "Y" [q] [] = True+self_inverse "Z" [q] [] = True+self_inverse "H" [q] [] = True+self_inverse "not" [q] [] = True+self_inverse "swap" [q1,q2] [] = True+self_inverse "W" [q1,q2] [] = True+self_inverse _ _ _ = False++-- ======================================================================+-- * ASCII representation of circuits++-- $ Convert a circuit to ASCII: one gate per line.++type WireTypeMap = IntMap.IntMap Wiretype++-- | Given a map of wiretypes, and a gate, update the wiretype in the map+-- if the gate changes it.+track_wiretype :: WireTypeMap -> Gate -> WireTypeMap+track_wiretype wtm (QInit    _ w _  ) = IntMap.insert w Qbit wtm+track_wiretype wtm (CInit    _ w _  ) = IntMap.insert w Cbit wtm+track_wiretype wtm (QMeas      w    ) = IntMap.insert w Cbit wtm+track_wiretype wtm (CGate    _ w _ _) = IntMap.insert w Cbit wtm+track_wiretype wtm (CGateInv _ w _ _) = IntMap.insert w Cbit wtm+track_wiretype wtm (QPrep      w _  ) = IntMap.insert w Qbit wtm+track_wiretype wtm (QUnprep    w _  ) = IntMap.insert w Cbit wtm+track_wiretype wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = a2 `IntMap.union` wtm +track_wiretype wtm _ = wtm++-- | Convert a 'BoxId' to the string in the format \"/name/\", shape \"/x/\".+ascii_of_boxid :: BoxId -> String+ascii_of_boxid (BoxId name shape) = show name ++ ", shape " ++ show shape++-- | Generate an ASCII representation of a control. +-- As controls are stored as untyped wires, we can lookup the wiretype in+-- the current map and annotate the control if it's classical.+ascii_render_control :: WireTypeMap -> Signed Wire -> String+ascii_render_control wtm (Signed w b) =+  (if b then "+" else "-") ++ show w ++ ascii_render_control_type wtype+  where +    wtype = if (w `IntMap.member` wtm) then (wtm IntMap.! w) else Qbit+    ascii_render_control_type Qbit = ""+    ascii_render_control_type Cbit = "c"++-- | Generate an ASCII representation of a list of controls.+ascii_render_controls :: WireTypeMap -> Controls -> String+ascii_render_controls wtm c =+  string_of_list " with controls=[" ", " "]" "" (ascii_render_control wtm) c++-- | Generate an ASCII representation of a NoControlFlag+ascii_render_nocontrolflag :: NoControlFlag -> String+ascii_render_nocontrolflag False = ""+ascii_render_nocontrolflag True = " with nocontrol"++-- | Generate an ASCII representation of a single gate.+ascii_render_gate :: WireTypeMap -> Gate -> String+ascii_render_gate wtm (QGate "trace" _ _ _ _ _) = ""+ascii_render_gate wtm (QGate name inv ws1 ws2 c ncf) = +  "QGate[" ++ show name ++ "]" +  ++ optional inv' "*"+  ++ (string_of_list "(" "," ")" "()" show ws1)+  ++ (string_of_list "; [" "," "]" "" show ws2)+  ++ ascii_render_controls wtm c+  ++ ascii_render_nocontrolflag ncf+  where+    inv' = inv && not (self_inverse name ws1 ws2)+ascii_render_gate wtm (QRot name inv theta ws1 ws2 c ncf) = +  "QRot[" ++ show name ++ "," ++ (show theta) ++ "]" +  ++ optional inv "*"+  ++ (string_of_list "(" "," ")" "()" show ws1)+  ++ (string_of_list "; [" "," "]" "" show ws2)+  ++ ascii_render_controls wtm c+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (GPhase t ws c ncf) = +  "GPhase() with t=" ++ show t +  ++ ascii_render_controls wtm c +  ++ ascii_render_nocontrolflag ncf+  ++ string_of_list " with anchors=[" ", " "]" "" show ws+ascii_render_gate wtm (CNot w c ncf) = +  "CNot(" ++ show w ++ ")" +  ++ ascii_render_controls wtm c+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (CGate n w c ncf) = +  -- special case+  "CGate[" ++ show n ++ "]" ++ (string_of_list "(" "," ")" "()" show (w:c))+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (CGateInv n w c ncf) = +  "CGate[" ++ show n ++ "]" ++ "*" ++ (string_of_list "(" "," ")" "()" show (w:c))+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (CSwap w1 w2 c ncf) = +  "CSwap(" ++ show w1 ++ "," ++ show w2 ++ ")" +  ++ ascii_render_controls wtm c+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (QPrep w ncf) = +  "QPrep(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (QUnprep w ncf) = +  "QUnprep(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (QInit b w ncf) = +  "QInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (CInit b w ncf) = +  "CInit" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (QTerm b w ncf) = +  "QTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (CTerm b w ncf) = +  "CTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"+  ++ ascii_render_nocontrolflag ncf+ascii_render_gate wtm (QMeas w) = +  "QMeas(" ++ show w ++ ")"+ascii_render_gate wtm (QDiscard w) = +  "QDiscard(" ++ show w ++ ")"+ascii_render_gate wtm (CDiscard w) = +  "CDiscard(" ++ show w ++ ")"+ascii_render_gate wtm (DTerm b w) = +  "DTerm" ++ (if b then "1" else "0") ++ "(" ++ show w ++ ")"+ascii_render_gate wtm (Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep) = +  "Subroutine" ++ show_rep ++ "[" ++ ascii_of_boxid boxid ++ "]"+  ++ optional inv "*"+  ++ " "+  ++ (string_of_list "(" "," ")" "()" show ws1)+  ++ (string_of_list " -> (" "," ")" "()" show ws2)+  ++ ascii_render_controls wtm c+  ++ ascii_render_nocontrolflag ncf+  where+    show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")"+ascii_render_gate wtm (Comment s inv ws) = +  "Comment[" ++ show s ++ "]" +  ++ optional inv "*"+  ++ (string_of_list "(" ", " ")" "()" (\(w,s) -> show w ++ ":" ++ show s) ws)+  +-- | Generate an ASCII representation of a gate list.+ascii_render_gatelist :: WireTypeMap -> [Gate] -> String+ascii_render_gatelist wtm []     = ""+ascii_render_gatelist wtm (g:gs) =+  (ascii_render_gate wtm g) ++ "\n" ++ +  (ascii_render_gatelist (track_wiretype wtm g) gs)+  where++-- | Generate an ASCII representation of a wiretype.+ascii_render_wiretype :: Wiretype -> String+ascii_render_wiretype Qbit = "Qbit"+ascii_render_wiretype Cbit = "Cbit"++-- | Generate an ASCII representation of a type assignment.+ascii_render_typeas :: (Wire, Wiretype) -> String+ascii_render_typeas (w, t) =+  show w ++ ":" ++ ascii_render_wiretype t++-- | Generate an ASCII representation of an arity, preceded by a title+-- (input or output).+ascii_render_arity :: String -> Arity -> String+ascii_render_arity title a =+  title ++ ": " ++ (string_of_list "" ", " "" "none" ascii_render_typeas (IntMap.toList a)) ++ "\n"++-- | Generate an ASCII representation of an ordered arity, preceded by+-- a title (input or output).+ascii_render_oarity :: String -> [Wire] -> Arity -> String+ascii_render_oarity title ws a =+  title ++ ": " +  ++ (string_of_list "" ", " "" "none" ascii_render_typeas tas_list) ++ "\n"+  where+    tas_list = [ (w, a IntMap.! w) | w <- ws ]++-- | Generate an ASCII representation of a low-level ordered quantum+-- circuit.+ascii_of_ocircuit :: OCircuit -> String+ascii_of_ocircuit ocircuit = +  (ascii_render_oarity "Inputs" win a1) +++  (ascii_render_gatelist a1 gl) +++  (ascii_render_oarity "Outputs" wout a2)+    where+      OCircuit (win, circuit, wout) = ocircuit+      (a1, gl, a2, _) = circuit++-- | Generate an ASCII representation of a low-level quantum circuit.+ascii_of_circuit :: Circuit -> String+ascii_of_circuit circuit = ascii_of_ocircuit ocircuit where+  ocircuit = OCircuit (w_in, circuit, w_out)+  (a1, _, a2, _) = circuit+  w_in = IntMap.keys a1+  w_out = IntMap.keys a2++-- | Generate an ASCII representation of a low-level boxed quantum+-- circuit.+ascii_of_bcircuit :: BCircuit -> String+ascii_of_bcircuit (c,s) = +  (ascii_of_circuit c) +++  (concat $ map ascii_of_subroutine (Map.toList s)) +++  "\n"++-- | Generate an ASCII representation of a named subroutine.+ascii_of_subroutine :: (BoxId, TypedSubroutine) -> String+ascii_of_subroutine (boxid, TypedSubroutine ocirc input_strux output_strux ctrble) =+  "\n" +  ++ "Subroutine: " ++ show name ++ "\n"+  ++ "Shape: " ++ show shape ++ "\n"+  ++ "Controllable: " ++ (case ctrble of {AllCtl -> "yes"; NoCtl -> "no"; OnlyClassicalCtl -> "classically"}) ++ "\n"+  ++ ascii_of_ocircuit ocirc+    where+      BoxId name shape = boxid+  +-- ======================================================================+-- * Dynamic ASCII representation of circuits++-- $+-- The dynamic ASCII representation prints a circuit to standard+-- output in ASCII format, just like the static ASCII representation.+-- However, when a 'dynamic_lift' operation is encountered, it prompts+-- the user for the value of the corresponding bit. In effect, the+-- user is asked to act as the quantum device or simulator.   ++-- | Write a prompt to get input from the user. Since the prompt+-- doesn't include a newline, the output must be flushed explicitly.+prompt :: String -> IO ()+prompt s = do+  putStr s+  hFlush stdout++-- | Interactively read a bit (either 0 or 1) from standard input.+-- This is intended for interactive user input, so it skips white+-- space until a 0 or 1 is encountered. In case the first+-- non-whitespace character isn't 0 or 1 or '#', the rest of the line+-- is ignored and the user is prompted to try again.+-- +-- However, this also works for non-interactive input, so that the+-- input can be redirected from a file. In this case, the characters 0+-- and 1 and whitespace, including newlines, can be interspersed+-- freely. \'@#@\' starts a comment that extends until the end of the+-- line. +getBit :: IO Bool+getBit = do+  c <- getChar+  case c of+    '0' -> return False+    '1' -> return True+    '#' -> do+      getLine+      getBit+    c | isSpace c -> getBit+    c -> do+      getLine+      prompt $ "# Expecting 0 or 1. Please try again: "+      getBit++-- | Embed a read-write computation in the 'IO' monad, by writing+-- gates to the terminal and interactively querying the user (or a+-- file on stdin) for dynamic liftings. We also update a 'Namespace'+-- while doing so, to collect any subroutines that are defined along+-- the way.+run_readwrite_ascii :: WireTypeMap -> ReadWrite a -> Namespace -> IO (a, Namespace)+run_readwrite_ascii wtm (RW_Return a) ns = return (a, ns)+run_readwrite_ascii wtm (RW_Write gate comp) ns = do+  putStrLn (ascii_render_gate wtm gate)+  run_readwrite_ascii (track_wiretype wtm gate) comp ns+run_readwrite_ascii wtm (RW_Read w cont) ns = do+  prompt $ "# Value of wire " ++ show w ++ ": "+  bool <- getBit+  putStrLn $ "# Value: " ++ show bool+  run_readwrite_ascii wtm (cont bool) ns+run_readwrite_ascii wtm (RW_Subroutine name subroutine comp) ns = do+  let !ns' = map_provide name subroutine ns+  run_readwrite_ascii wtm comp ns'++-- | Interactively output a 'DBCircuit' to standard output. This+-- supports dynamic lifting by prompting the user for bit values when+-- a dynamic lifting operation is encountered. Effectively the user is+-- asked to behave like a quantum device.+print_dbcircuit_ascii :: ErrMsg -> DBCircuit a -> IO ()+print_dbcircuit_ascii _ (a0, comp) = do+  hSetBuffering stdout LineBuffering -- flush output after each line+  putStr (ascii_render_arity "Inputs" a0)+  ((a1, _, _),ns) <- run_readwrite_ascii a0 comp namespace_empty+  putStr (ascii_render_arity "Outputs" a1)+  sequence_ [ putStr $ ascii_of_subroutine subr | subr <- Map.toList ns ]+  putStr "\n"++-- ----------------------------------------------------------------------+-- * Graphical representation of circuits++-- | The color white.+white :: Color+white = Color_Gray 1.0++-- | The color black.+black :: Color+black = Color_Gray 0.0++-- | A data type that holds all the customizable parameters.+data FormatStyle = FormatStyle {+  -- | The RenderFormat to use.+  renderformat :: RenderFormat,+  -- | The color of the background.+  backgroundcolor :: Color,+  -- | The color of the foreground (e.g. wires and gates).+  foregroundcolor :: Color,+  -- | Line width.+  linewidth :: Double,+  -- | Gap for double line representing classical bit.+  coffs :: Double,+  -- | Radius of dots for \"controlled\" gates.+  dotradius :: Double,+  -- | Radius of oplus for \"not\" gate.+  oplusradius :: Double,+  -- | Horizontal column width.+  xoff :: Double,+  -- | Difference between width of box and width of label.+  gatepad :: Double,+  -- | Height of labelled box.+  gateheight :: Double,+  -- | Width and height of \"cross\" for swap gate.+  crossradius :: Double,+  -- | Vertical shift for text labels.+  stringbase :: Double,+  -- | Width of \"bar\" bar.+  barwidth :: Double, +  -- | Height of \"bar\" bar.+  barheight :: Double,+  -- | Width of \"D\" symbol.+  dwidth :: Double,+  -- | Height of \"D\" symbol.+  dheight :: Double,+  -- | Maximal width of a gate label.+  maxgatelabelwidth :: Double,+  -- | Maximal width of a wire label.+  maxlabelwidth :: Double,+  -- | Maximal width of a wire number.+  maxnumberwidth :: Double,+  -- | Font to use for labels on gates.+  gatefont :: Font,+  -- | Font to use for comments.+  commentfont :: Font,+  -- | Color to use for comments.+  commentcolor :: Color,+  -- | Font to use for labels.+  labelfont :: Font,+  -- | Color to use for labels.+  labelcolor :: Color,+  -- | Font to use for numbers.+  numberfont :: Font,+  -- | Color to use for numbers.+  numbercolor :: Color,+  -- | Whether to label each subroutine call with shape parameters+  subroutineshape :: Bool+} deriving Show++-- | A RenderFormat consisting of some default parameters, +-- along with the given RenderFormat.+defaultStyle :: RenderFormat -> FormatStyle+defaultStyle rf = FormatStyle {+  renderformat = rf,+  backgroundcolor = white,+  foregroundcolor = black,+  linewidth = 0.02, +  coffs = 0.03,+  dotradius  = 0.15,+  oplusradius = 0.25,+  xoff = 1.5,+  gatepad = 0.3, +  gateheight  = 0.8,+  crossradius = 0.2,+  stringbase = 0.25,+  barwidth = 0.1,+  barheight = 0.5,+  dwidth = 0.3,+  dheight = 0.4,+  maxgatelabelwidth = 1.1,+  maxlabelwidth = 0.7,+  maxnumberwidth = 0.7,+  gatefont = Font TimesRoman 0.5,+  commentfont = Font TimesRoman 0.3,+  commentcolor = Color_RGB 1 0.2 0.2,+  labelfont = Font TimesRoman 0.3,+  labelcolor = Color_RGB 0 0 1,+  numberfont = Font Helvetica 0.5,+  numbercolor = Color_RGB 0 0.7 0,+  subroutineshape = True+}++-- | The default PDF Style.+pdf :: FormatStyle+pdf = defaultStyle Format_PDF++-- | The default EPS Style.+eps :: FormatStyle+eps = defaultStyle (Format_EPS 1)++-- | The default PS Style.+ps :: FormatStyle+ps = defaultStyle (Format_PS)++-- ----------------------------------------------------------------------+-- ** General-purpose PostScript functions++-- | Escape special characters in a string literal.+ps_escape :: String -> String+ps_escape [] = []+ps_escape ('\\' : t) = '\\' : '\\' : ps_escape t+ps_escape ('('  : t) = '\\' : '('  : ps_escape t+ps_escape (')'  : t) = '\\' : ')'  : ps_escape t+ps_escape (h : t)    = h : ps_escape t++-- ----------------------------------------------------------------------+-- ** String formatting++-- | Convert a 'BoxId' to the string in the format \"/name/, shape /x/\".+string_of_boxid :: BoxId -> String+string_of_boxid (BoxId name shape) = name ++ ", shape " ++ shape++-- ----------------------------------------------------------------------+-- ** Functions for dealing with x-coordinates++-- | Pre-processing: figure out the /x/-column of each gate. Returns+-- (/n/,/xgs/) where /xgs/ is a list of ('Gate', 'X') pairs, and+-- /n/ is the rightmost /x/-coordinate of the circuit. Here we start+-- from /x0/ and use constant step /xoff/ taken from the 'FormatStyle'.+assign_x_coordinates :: FormatStyle -> [Gate] -> X -> (X, [(Gate, X)])+assign_x_coordinates fs gs x0 =+  let ((x,ws), xgs) = mapAccumL (\ (x, ws) g ->+        -- count the wires attached to the gate. If there is precisely+        -- one (unary gate), merge it with adjacent unary gates. Do+        -- not merge comments.+        let merge = case (g, wirelist_of_gate g) of+              (Comment _ _ _, _) -> Nothing+              (_, [w]) -> Just w+              (_, _) -> Nothing+        in+        case merge of+          Just w ->+            if not (w `elem` ws) then+              ((x, w:ws), (g, x))+            else+              ((x + (xoff fs), [w]), (g, x + (xoff fs)))+          _ ->+            if ws == [] then+              ((x + (xoff fs), []), (g, x))+            else+              ((x + 2.0 * (xoff fs), []), (g, x + (xoff fs)))+        ) (x0, []) gs+  in+   if ws == [] then+     (x, xgs)+   else+     (x + (xoff fs), xgs)++-- | A 'Xarity' is a map from wire id's to pairs of a wiretype and a+-- starting /x/-coordinate.+type Xarity = Map Wire (Wiretype, X)++-- | Figure out how a gate at coordinate /x/ affects the current 'Xarity'.+-- Return a pair (/term/, /new/), where /term/ is the 'Xarity' of wires+-- terminated by this gate, and /new/ is the outgoing 'Xarity' of this+-- gate.+update_xarity :: Xarity -> Gate -> X -> (Xarity, Xarity)+update_xarity xarity gate x =+  let (win, wout) = gate_arity gate+      safe_lookup xarity w = +        case Map.lookup w xarity of +          Just x -> x+          Nothing -> (Qbit, x) -- error ("update_xarity: the wire " ++ show w ++ " does not exist. In the gate:\n" ++ ascii_render_gate gate)+      (win', wout') = (win \\ wout, wout \\ win)+      -- extract terminating wires from xarity+      xarity_term = foldl (\xar (w,_) -> Map.insert w (xarity `safe_lookup` w) xar) Map.empty win' +      -- extract continuing wires from xarity+      xarity_cont = foldl (\xar (w,_) -> Map.delete w xar) xarity win'+      -- add new wires to xarity_cont+      xarity_new = foldl (\xar (w,t) -> Map.insert w (t,x) xar) xarity_cont wout'+  in+   (xarity_term, xarity_new)++-- ----------------------------------------------------------------------+-- ** Low-level drawing functions++-- | @'render_line' x0 y0 x1 y1@: Draw a line from (/x0/, /y0/)+-- to (/x1/, /y1/). In case of a zero-length line, draw nothing.+render_line :: X -> Y -> X -> Y -> Draw ()+render_line x0 y0 x1 y1 | x0 == x1 && y0 == y1 = return ()+render_line x0 y0 x1 y1 = draw_subroutine alt $ do+  moveto x0 y0+  lineto x1 y1+  stroke+  where+    alt = [custom_ps $ printf "%f %f %f %f line\n" x0 y0 x1 y1]++-- | @'render_dot' x y@: Draw a filled control dot at (/x/,/y/).+render_dot :: FormatStyle -> X -> Y -> Draw ()+render_dot fs x y = draw_subroutine alt $ do+  arc x y (dotradius fs) 0 360+  fill (foregroundcolor fs)+  where+    alt = [custom_ps $ printf "%f %f dot\n" x y]++-- | @'render_circle' x y@: Draw an empty control dot at+-- (/x/,/y/).+render_circle :: FormatStyle -> X -> Y -> Draw ()+render_circle fs x y = draw_subroutine alt $ do+  arc x y (dotradius fs) 0 360+  fillstroke (backgroundcolor fs)+  where+    alt = [custom_ps $ printf "%f %f circ\n" x y]++-- | @'render_not' x y@: Draw a \"not\" gate at (/x/,/y/).+render_not :: FormatStyle -> X -> Y -> Draw ()+render_not fs x y = draw_subroutine alt $ do+  arc x y (oplusradius fs) 0 360+  fillstroke (backgroundcolor fs)+  render_line (x-(oplusradius fs)) y (x+(oplusradius fs)) y+  render_line x (y-(oplusradius fs)) x (y+(oplusradius fs))+  where+    alt = [custom_ps $ printf "%f %f oplus\n" x y]++-- | @'render_swap' x y@: Draw a cross (swap gate component) at+--  (/x/,/y/).+render_swap :: FormatStyle -> X -> Y -> Draw ()+render_swap fs x y = draw_subroutine alt $ do+  render_line (x-(crossradius fs)) (y-(crossradius fs)) (x+(crossradius fs)) (y+(crossradius fs))+  render_line (x-(crossradius fs)) (y+(crossradius fs)) (x+(crossradius fs)) (y-(crossradius fs))+  where  +    alt = [custom_ps $ printf "%f %f cross\n" x y]++-- | @'render_bar' x y@: Draw an init/term bar at (/x/,/y/).+render_bar :: FormatStyle -> X -> Y -> Draw ()+render_bar fs x y = draw_subroutine alt $ do+  rectangle (x - (barwidth fs)/2) (y - (barheight fs)/2) (barwidth fs) (barheight fs)+  fill (foregroundcolor fs)+  where+    alt = [custom_ps $ printf "%f %f bar\n" x y]++-- | @'render_bar' x y@: Draw a dterm bar at (/x/,/y/).+render_dbar :: FormatStyle -> X -> Y -> Draw ()+render_dbar fs x y = draw_subroutine alt $ do+  block $ do+    translate (x+(barwidth fs)/2) y+    scale (dwidth fs) (dheight fs)+    moveto (-1) (-0.5)+    arc_append (-0.5) 0 0.5 (-90) 90+    lineto (-1) 0.5+    closepath+    fill (foregroundcolor fs)+  where+    alt = [custom_ps $ printf "%f %f dbar\n" x y]++-- | @'render_init' name x y@: Draw an \"init\" gate at+-- (/x/,/y/), with state /name/.+render_init :: FormatStyle -> String -> X -> Y -> Draw ()+render_init fs name x y = draw_subroutine alt $ do+  render_bar fs x y+  textbox align_right (gatefont fs) (foregroundcolor fs) (x-(xoff fs)/2+(gatepad fs)/2) y (x-(gatepad fs)/2) y (stringbase fs) name+  where+    alt = [custom_ps $ printf "(%s) %f %f init\n" (ps_escape name) x y]++-- | @'render_term' name x y@: Draw a \"term\" gate at+-- (/x/,/y/), with state /name/.+render_term :: FormatStyle -> String -> X -> Y -> Draw ()+render_term fs name x y = draw_subroutine alt $ do+  render_bar fs x y+  textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name+  where+    alt = [custom_ps $ printf "(%s) %f %f term\n" (ps_escape name) x y]++-- | @'render_dterm' name x y@: Draw a \"dterm\" gate at+-- (/x/,/y/), with state /name/.+render_dterm :: FormatStyle -> String -> X -> Y -> Draw ()+render_dterm fs name x y = draw_subroutine alt $ do+  render_dbar fs x y+  textbox align_left (gatefont fs) (foregroundcolor fs) (x+(gatepad fs)/2) y (x+(xoff fs)/2-(gatepad fs)/2) y (stringbase fs) name+  where+    alt = [custom_ps $ printf "(%s) %f %f dterm\n" (ps_escape name) x y]++-- | @'render_namedgate' name inv x y@: draw a named box centered at+-- (/x/,/y/). If /inv/ = 'True', append an \"inverse\" symbol to the+-- end of the name.+render_namedgate :: FormatStyle -> String -> InverseFlag -> X -> Y -> Draw ()+render_namedgate fs name inv x y = draw_subroutine alt $ do+  rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs)+  fillstroke (backgroundcolor fs)+  textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name'+  where+    alt = [custom_ps $ printf "(%s) %f %f gate\n" (ps_escape name') x y]+    name' = name ++ optional inv "*"+    w = text_width (gatefont fs) name'+    labelwidth = min w (maxgatelabelwidth fs)+    gatewidth = labelwidth + (gatepad fs)+            +-- | @'render_gphasegate' name x y@: draw a global phase gate+-- centered at (/x/,/y/).+render_gphasegate :: FormatStyle -> String -> X -> Y -> Draw ()+render_gphasegate fs name x y = draw_subroutine alt $ do+  render_circgate fs name x (y-0.5)+  where+    alt = [custom_ps $ printf "(%s) %f %f gphase\n" (ps_escape name) x y]++-- | @'render_circgate' name x y@: draw a named oval centered at+-- (/x/,/y/).+render_circgate :: FormatStyle -> String -> X -> Y -> Draw ()+render_circgate fs name x y = draw_subroutine alt $ do+  oval x y (0.5*gatewidth) (0.4*(gateheight fs))+  fillstroke (backgroundcolor fs)+  textbox align_center (gatefont fs) (foregroundcolor fs) (x-labelwidth/2) y (x+labelwidth/2) y (stringbase fs) name+  where+    alt = [custom_ps $ printf "(%s) %f %f circgate\n" (ps_escape name) x y]+    w = text_width (gatefont fs) name+    labelwidth = min w (maxgatelabelwidth fs)+    gatewidth = labelwidth + (gatepad fs)+    +-- | @'render_blankgate' name x y@: draw an empty box centered+-- at (/x/,/y/), big enough to hold /name/.+render_blankgate :: FormatStyle -> String -> X -> Y -> Draw ()+render_blankgate fs name x y = draw_subroutine alt $ do+  rectangle (x-gatewidth/2) (y-(gateheight fs)/2) gatewidth (gateheight fs)+  fillstroke (backgroundcolor fs)+  where+    alt = [custom_ps $ printf "(%s) %f %f box\n" (ps_escape name) x y]+    w = text_width (gatefont fs) name+    labelwidth = min w (maxgatelabelwidth fs)+    gatewidth = labelwidth + (gatepad fs)++-- | @'render_comment' center s x y m@: draw the given string+-- vertically, with the top of the string near the given+-- /y/-coordinate. If /center/=='True', center it at the+-- /x/-coordinate, else move it just to the left of the+-- /x/-coordinate. /m/ is the maximum height allowed for the comment.+render_comment :: FormatStyle -> Bool -> String -> X -> Y -> Y -> Draw ()+render_comment fs center s x y maxh = draw_subroutine alt $ do+  textbox align_right (commentfont fs) (commentcolor fs) x (y-maxh) x (y+0.4) b s+  where+    alt = [custom_ps $ printf "(%s) %f %f %f %f comment\n" (ps_escape s) x y maxh yshift]+    b = if center then 0.15 else -0.25+    yshift = -b * nominalsize (commentfont fs)++-- | @'render_label' center s x y@: draw the given label just above+-- the given point. If /center/=='True', center it at the+-- /x/-coordinate, else move it just to the right of the+-- /x/-coordinate.+render_label :: FormatStyle -> Bool -> String -> X -> Y -> Draw ()+render_label fs True s x y = draw_subroutine alt $ do+  textbox align_center (labelfont fs) (labelcolor fs) (x-(maxlabelwidth fs)) y' (x+(maxlabelwidth fs)) y' (-0.5) s+  where+    alt = [custom_ps $ printf "(%s) %f %f clabel\n" (ps_escape s) x y']+    y' = y + 0.5 * (coffs fs)+render_label fs False s x y = draw_subroutine alt $ do+  textbox align_left (labelfont fs) (labelcolor fs) x y' (x+(maxlabelwidth fs)) y' (-0.5) s+  where+    alt = [custom_ps $ printf "(%s) %f %f rlabel\n" (ps_escape s) x y']+    y' = y + 0.5 * (coffs fs)+    +-- | Render the number at the given point (/x/,/y/). If the boolean+-- argument is 'True', put the number to the right of /x/, else to the left. +render_number :: FormatStyle -> Int -> Bool -> X -> Y -> Draw ()+render_number fs i True x y = draw_subroutine alt $ do+  textbox align_left (numberfont fs) (numbercolor fs) (x+0.2) y (x+0.2+(maxnumberwidth fs)) y (stringbase fs) (show i)+  where+    alt = [custom_ps $ printf "(%s) %f %f rnumber\n" (ps_escape (show i)) x y]+render_number fs i False x y = draw_subroutine alt $ do+  textbox align_right (numberfont fs) (numbercolor fs) (x-0.2-(maxnumberwidth fs)) y (x-0.2) y (stringbase fs) (show i)+  where+    alt = [custom_ps $ printf "(%s) %f %f lnumber\n" (ps_escape (show i)) x y]++-- ----------------------------------------------------------------------+-- ** Higher-level rendering functions++-- | Render a horizontal wire from /x/-coordinates /oldx/ to /x/,+-- using /t/ as the type and figuring out the /y/-coordinate from /ys/+-- and /w/. Append to the given string. If the parameters are invalid+-- (/w/ not in /ys/), throw an error.+render_typeas :: FormatStyle -> Map Wire Y -> X -> X -> Wire -> Wiretype -> Draw ()+render_typeas fs ys oldx x w t =+  let y = ys Map.! w in+  case t of+    Qbit -> do+      render_line oldx y x y+    Cbit -> do+      render_line oldx (y + (coffs fs)) x (y + (coffs fs))+      render_line oldx (y - (coffs fs)) x (y - (coffs fs))++-- | Render a bunch of horizontal wires from their repective starting+-- 'Xarity' to /x/.+render_xarity :: FormatStyle -> Map Wire Y -> Xarity -> X -> Draw ()+render_xarity fs ys xarity x = do+  sequence_ [ render_typeas fs ys oldx x w t | (w,(t,oldx)) <- Map.toList xarity ]++-- | Format a floating point number in concise form, with limited+-- accuracy.+dshow :: Double -> String+dshow dbl = +  if abs dbl < 0.01 +  then+    printf "%.1e" dbl+  else+    (reverse . strip . reverse) (printf "%.3f" dbl)+      where+        strip [] = []+        strip ('.' : t) = t+        strip ('0' : t) = strip t+        strip t = t+        +-- | @'render_controlwire' /x/ /ys/ /ws/ /c/@: +-- Render the line connecting all the box components and all the+-- control dots of some gate. +-- +-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed+-- array of /y/-coordinates, /ws/ is the set of wires for boxes, and+-- /c/ is a list of controls.+render_controlwire :: X -> Map Wire Y -> [Wire] -> Controls -> Draw ()+render_controlwire x ys ws c =+  case ws of+    [] -> return ()+    w:ws -> render_line x y0 x y1      +      where+        ymap w = ys Map.! w+        y = ymap w+        cy = map (\(Signed w _) -> ymap w) c+        yy = map (\w -> ymap w) ws+        y0 = foldr min y (cy ++ yy)+        y1 = foldr max y (cy ++ yy)++-- | @'render_controlwire_float' /x/ /ys/ /y/ /c/@: Render the line+-- connecting all control dots of the given controls, as well as a+-- floating \"global phase\" gate located just below (/x/, /y/). +-- +-- Parameters: /x/ is the current /x/-coordinate, /ys/ is an indexed+-- array of /y/-coordinates, /y/ is the /y/-coordinate of the wire+-- where the floating gate is attached, and /c/ is a list of controls.+render_controlwire_float :: X -> Map Wire Y -> Y -> Controls -> Draw ()+render_controlwire_float x ys y c = render_line x y0 x y1 +  where+    y' = y - 0.5+    cy = map (\(Signed w _) -> ys Map.! w) c+    y0 = minimum (y':cy)+    y1 = maximum (y':cy)++-- | @'render_controldots' /x/ /ys/ /c/@: Render the control dots+-- for the given controls.+render_controldots :: FormatStyle -> X -> Map Wire Y -> Controls -> Draw ()+render_controldots fs x ys c = do+  sequence_ [ renderdot x | x <- c ]+  where+    renderdot (Signed w True) = render_dot fs x (ys Map.! w)+    renderdot (Signed w False) = render_circle fs x (ys Map.! w)++-- | @'render_multi_gate' /x/ /ys/ /name/ /inv/ /wires/@: Render the+-- boxes for an /n/-ary gate of the given /name/, potentially+-- /inv/erted, at the given list of /wires/. The first two arguments+-- are the current /x/-coordinate and an indexed array of+-- /y/-coordinates.+render_multi_gate :: FormatStyle -> X -> Map Wire Y -> String -> InverseFlag -> [Wire] -> Draw ()+render_multi_gate fs x ys name inv [w] = +  render_namedgate fs name inv x (ys Map.! w)+render_multi_gate fs x ys name inv ws =+  sequence_ [ render_namedgate fs (name ++ " " ++ show i) inv x (ys Map.! a) | (a,i) <- zip ws [1..] ]++-- | @'render_multi_named_ctrl' /x/ /ys/ /wires/ /names/@: Render+-- the boxes for multiple generalized controls at the given /wires/,+-- using the given /names/. We take special care of the fact that+-- generalized controls may be used non-linearly. +render_multi_named_ctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> [String] -> Draw ()+render_multi_named_ctrl fs x ys ws names =+  sequence_ [ render_circgate fs name x (ys Map.! a) | (a,name) <- IntMap.toList map ]+  where+    -- Combine the labels for w if w has multiple occurrences.+    map = IntMap.fromListWith (\x y -> y ++ "," ++ x) (zip ws names)++-- | @'render_multi_genctrl' /x/ /ys/ /wires/@: Render the boxes for+-- multiple (numbered) generalized controls at the given /wires/.+render_multi_genctrl :: FormatStyle -> X -> Map Wire Y -> [Wire] -> Draw ()+render_multi_genctrl fs x ys ws = render_multi_named_ctrl fs x ys ws names+  where+    names = map show [1..]+            +-- | Number a list of wires in increasing order, at the given+-- /x/-coordinate. If the boolean argument is 'True', put the numbers+-- to the right of /x/, else to the left.+render_ordering :: FormatStyle -> X -> Map Wire Y -> Bool -> [Wire] -> Draw ()+render_ordering fs x ys b ws =+  sequence_ [ render_number fs i b x (ys Map.! w) | (w,i) <- numbering ]+  where+    numbering = zip ws [1..]++-- | Render gate /g/ at /x/-coordinate /x/ and /y/-coordinates as+-- given by /ys/, which is a map from wires to+-- /y/-coordinates. Returns a pair (/s/,/t/) of draw actions for+-- background and foreground, respectively.+render_gate :: FormatStyle -> Gate -> X -> Map Wire Y -> Y -> (Draw (), Draw ())+render_gate fs g x ys maxh =+  let ymap w = ys Map.! w +  in+  case g of+    -- Certain named gates are recognized for custom rendering.+    QGate "not" _ [w] [] c ncf -> (s2, t2 >> t3)+      where+        y = ymap w+        s2 = render_controlwire x ys [w] c+        t2 = render_controldots fs x ys c+        t3 = (render_not fs x y)+    QGate "multinot" _ ws [] c ncf -> (s2, t2 >> t3)+      where+        s2 = render_controlwire x ys ws c+        t2 = render_controldots fs x ys c+        t3 = sequence_ (map (\w -> (render_not fs x (ymap w))) ws)+    QGate "swap" _ [w1,w2] [] c ncf -> (s2, t2 >> t3)+      where+        y1 = ymap w1+        y2 = ymap w2+        s2 = render_controlwire x ys [w1,w2] c+        t2 = render_controldots fs x ys c+        t3 = (render_swap fs x y1) >> (render_swap fs x y2)+    QGate "trace" _ _ _ _ _ -> (return (), return ())+    QGate name inv ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4)+      where+       s2 = render_controlwire x ys (ws1 ++ ws2) c+       t2 = render_multi_gate fs x ys name inv' ws1+       t3 = render_controldots fs x ys c+       t4 = render_multi_genctrl fs x ys ws2+       inv' = inv && not (self_inverse name ws1 ws2)+    QRot name inv theta ws1 ws2 c ncf -> (s2, t2 >> t3 >> t4)+      where+       s2 = render_controlwire x ys (ws1 ++ ws2) c+       t2 = render_multi_gate fs x ys name' inv ws1+       t3 = render_controldots fs x ys c+       t4 = render_multi_genctrl fs x ys ws2+       name' = substitute name '%' (dshow theta)+    GPhase t ws c ncf -> (s2, t2 >> t3)+      where+        y = case (ws, c) of+          ([], []) -> maximum (0.0 : Map.elems ys)+          ([], c)  -> minimum [ ymap w | Signed w b <- c ]+          (ws, c)  -> minimum [ ymap w | w <- ws ]+        s2 = render_controlwire_float x ys y c+        t2 = render_controldots fs x ys c+        t3 = (render_gphasegate fs (dshow t) x y)+    CNot w c ncf -> (s2, t2 >> t3)+      where+        y = ymap w+        s2 = render_controlwire x ys [w] c+        t2 = render_controldots fs x ys c+        t3 = (render_not fs x y)+    CGate "if" w [a,b,c] ncf -> (s2, t1 >> t3)  -- special case+      where+       y = ymap w+       s2 = render_controlwire x ys [w,a,b,c] []+       t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"]+       t3 = render_namedgate fs ">" False x y+    CGateInv "if" w [a,b,c] ncf -> (s2, t1 >> t3)  -- special case+      where+       y = ymap w+       s2 = render_controlwire x ys [w,a,b,c] []+       t1 = render_multi_named_ctrl fs x ys [a,b,c] ["if", "then", "else"]+       t3 = render_namedgate fs "<" False x y+    CGate name w c ncf -> (s2, t2 >> t3)+      where+       y = ymap w+       s2 = render_controlwire x ys (w:c) []+       t2 = render_multi_named_ctrl fs x ys c [ "  " | a <- c ]+       t3 = render_namedgate fs name False x y+    CGateInv name w c ncf -> (s2, t2 >> t3)+      where+       y = ymap w+       s2 = render_controlwire x ys (w:c) []+       t2 = render_multi_named_ctrl fs x ys c [ "  " | a <- c ]+       t3 = render_namedgate fs name True x y+    CSwap w1 w2 c ncf -> (s2, t2 >> t3)+      where+        y1 = ymap w1+        y2 = ymap w2+        s2 = render_controlwire x ys [w1,w2] c+        t2 = render_controldots fs x ys c+        t3 = (render_swap fs x y1) >> (render_swap fs x y2)+    QPrep w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_namedgate fs "prep" False x y)+    QUnprep w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_namedgate fs "unprep" False x y)+    QInit b w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_init fs (if b then "1" else "0") x y)+    CInit b w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_init fs (if b then "1" else "0") x y)+    QTerm b w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_term fs (if b then "1" else "0") x y)+    CTerm b w ncf -> (return (), t3)+      where+        y = ymap w+        t3 = (render_term fs (if b then "1" else "0") x y)+    QMeas w -> (return (), t3)+      where+        y = ymap w+        t3 = (render_namedgate fs "meas" False x y)+    QDiscard w -> (return (), t3)+      where+        y = ymap w+        t3 = (render_bar fs x y)+    CDiscard w -> (return (), t3)+      where+        y = ymap w+        t3 = (render_bar fs x y)+    DTerm b w -> (return (), t3)+      where+        y = ymap w+        t3 = (render_dterm fs (if b then "1" else "0") x y)+    Subroutine boxid inv ws1 a1 ws2 a2 c ncf scf rep -> (s2, t2 >> t3)+      where+       ws = union ws1 ws2+       s2 = render_controlwire x ys ws c+       t2 = render_multi_gate fs x ys label inv ws+       t3 = render_controldots fs x ys c+       show_rep = if rep == RepeatFlag 1 then "" else "(x" ++ show rep ++ ")"+       BoxId name shape = boxid+       label = name ++ show_rep ++ if (subroutineshape fs) then (", shape " ++ shape) else ""+    Comment s inv ws -> (return (), t1 >> t2)+      where+        t1 = render_comment fs (null ws) s' x (ymap 0) maxh+        t2 = sequence_ [render_label fs (null s) l x (ymap w) | (w,l) <- ws]+        s' = s ++ optional inv "*"++-- | Render the gates in the circuit. The parameters are: /xarity/:+-- the 'Xarity' of the currently pending wires. /xgs/: the list of+-- gates, paired with pre-computed /x/-coordinates. /ys/: a map from+-- wires to pre-computed /y/-coordinates. /x/: the right-most+-- /x/-coordinate where the final wires will be drawn to. /maxh/: the+-- maximal height of comments.+render_gates :: FormatStyle -> Xarity -> [(Gate, X)] -> Map Wire Y -> X -> Y -> (Draw (), Draw ())+render_gates fs xarity xgs ys x maxh =+  case xgs of+    [] ->+      let s2 = render_xarity fs ys xarity x+      in (s2, return ())+    (g,newx):gls ->+      let (xarity_term, xarity_new) = update_xarity xarity g newx in+      let s1 = render_xarity fs ys xarity_term newx in+      let (s2, t2) = render_gate fs g newx ys maxh in+      let (sx, tx) = render_gates fs xarity_new gls ys x maxh in+      (s1 >> s2 >> sx, t2 >> tx)++-- | PostScript definitions of various parameters.+ps_parameters :: FormatStyle -> String+ps_parameters fs =+  "% some parameters\n"+  ++ printf "%f setlinewidth\n" (linewidth fs)+  ++ printf "/gatepad %f def\n" (gatepad fs)+  ++ printf "/gateheight %f def\n" (gateheight fs)+  ++ printf "/stringbase %f def\n" (stringbase fs)+  ++ printf "/dotradius %f def\n" (dotradius fs)+  ++ printf "/oplusradius %f def\n" (oplusradius fs)+  ++ printf "/crossradius %f def\n" (crossradius fs)+  ++ printf "/barwidth %f def\n" (barwidth fs)+  ++ printf "/barheight %f def\n" (barheight fs)+  ++ printf "/dwidth %f def\n" (dwidth fs)+  ++ printf "/dheight %f def\n" (dheight fs)+  ++ printf "/maxgatelabelwidth %f def\n" (maxgatelabelwidth fs)+  ++ printf "/maxlabelwidth %f def\n" (maxlabelwidth fs)+  ++ printf "/maxnumberwidth %f def\n" (maxnumberwidth fs)+  ++ "/gatefont { /Times-Roman findfont .5 scalefont setfont } def\n"+  ++ "/labelfont { /Times-Roman findfont .3 scalefont setfont } def\n"+  ++ "/commentfont { /Times-Roman findfont .3 scalefont setfont } def\n"+  ++ "/numberfont { /Times-Roman findfont .5 scalefont setfont } def\n"+  ++ "/labelcolor { 0 0 1 setrgbcolor } def\n"+  ++ "/commentcolor { 1 0.2 0.2 setrgbcolor } def\n"+  ++ "/numbercolor { 0 0.7 0 setrgbcolor } def\n"++-- | PostScript definitions for various drawing subroutines. The+-- subroutines provided are:+-- +-- > x0 y0 x1 y1 line       : draw a line from (x0,y0) to (x1,y1)+-- > x0 y0 x1 y1 dashedline : draw a dashed line from (x0,y0) to (x1,y1)+-- > x y h w rect           : draw a rectangle of dimensions w x h centered at (x,y)+-- > x y h w oval           : draw an oval of dimensions w x h centered at (x,y)+-- > x y dot           : draw a filled dot at (x,y)+-- > x y circ          : draw an empty dot at (x,y)+-- > x y oplus         : draw a "not" gate at (x,y)+-- > x y cross         : draw a cross ("swap" gate component) at (x,y)+-- > x y bar           : draw an init/term bar at (x,y)+-- > x y dbar          : draw a dterm bar at (x,y)+-- > name x y box      : draw an empty box at (x,y), big enough to fit name+-- > name x y gate     : draw a named box at (x,y)+-- > name x y circgate : draw a named round box at (x,y)+-- > name x y gphase   : draw a global phase gate (x,y)+-- > b x y init        : draw an "init" gate at (x,y), with state b+-- > b x y term        : draw a "term" gate at (x,y), with state b+-- > b x y dterm       : draw a "dterm" gate at (x,y), with state b+-- > string x y m b comment : draw a vertical comment at (x,y), with max height m and baseline adjustment b+-- > string x y clabel      : draw a wire label at (x,y), x-centered+-- > string x y rlabel      : draw a wire label at (x,y), right of x+-- > string x y lnumber     : draw a numbered input at (x,y)+-- > string x y rnumber     : draw a numbered output at (x,y)++ps_subroutines :: String+ps_subroutines = +    "% subroutine definitions\n"+    ++ "/line { moveto lineto stroke } bind def\n"+    ++ "/dashedline { moveto gsave [0.3 0.2] .15 setdash lineto stroke grestore } bind def\n"+    ++ "/rect { /H exch def /W exch def -.5 W mul .5 H mul moveto W 0 rlineto 0 H neg rlineto W neg 0 rlineto closepath } bind def\n"+    ++ "/oval { /H exch def /W exch def gsave .5 W mul .5 H mul scale 0 0 1 0 360 newpath arc gsave 1.0 setgray fill grestore stroke grestore } bind def\n"+    ++ "/dot { dotradius 0 360 newpath arc gsave 0 setgray fill grestore newpath } bind def\n"+    ++ "/circ { dotradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke } bind def\n"+    ++ "/oplus { gsave translate 0 0 oplusradius 0 360 newpath arc gsave 1.0 setgray fill grestore stroke 0 oplusradius neg 0 oplusradius line oplusradius neg 0 oplusradius 0 line grestore } bind def\n"+    ++ "/cross { gsave translate crossradius dup dup neg dup line crossradius dup neg dup dup neg line grestore } bind def\n"+    ++ "/bar { gsave translate barwidth barheight rect fill grestore } bind def\n"+    ++ "/dbar { gsave translate barwidth 0.5 mul 0 translate dwidth dheight scale -1 -.5 moveto -.5 0 .5 -90 90 arc -1 .5 lineto closepath fill grestore } bind def\n"+    ++ "/box { gsave translate gatefont stringwidth pop /w exch def /w1 w gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke grestore } bind def\n"+    ++ "/gate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 gateheight rect gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"+    ++ "/circgate { gsave translate dup gatefont stringwidth pop /w exch def /fontscale w maxgatelabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def /w2 w fontscale div def /w1 w2 gatepad add def w1 0.8 gateheight mul oval gsave 1.0 setgray fill grestore stroke 1 fontscale div dup scale 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"+    ++ "/gphase { gsave translate 0 -0.5 circgate grestore } bind def\n"+    ++ "/init { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def -.5 w1 mul 0 translate 0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"+    ++ "/term { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 bar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"+    ++ "/dterm { gsave translate dup gatefont stringwidth pop /w exch def /w1 w gatepad add def .5 w1 mul 0 translate -0.5 w1 mul 0 dbar 0 .5 w mul sub -0.5 stringbase mul moveto show grestore } bind def\n"+    ++ "/comment { gsave /b exch def /maxh exch def /y exch def /x exch def commentfont commentcolor x y maxh sub x y 0.4 add 1.0 b textbox grestore } bind def\n"+    ++ "/clabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth 2 mul div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale -0.5 w mul 0 moveto labelcolor show grestore } bind def\n"+    ++ "/rlabel { gsave translate dup labelfont stringwidth pop /w exch def /fontscale w maxlabelwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0 0.15 translate 1 fontscale div dup scale 0 0 moveto labelcolor show grestore } bind def\n"+    ++ "/lnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def -0.2 -0.15 translate 1 fontscale div dup scale -1 w mul 0 moveto numbercolor show grestore } bind def\n"+    ++ "/rnumber { gsave translate dup numberfont stringwidth pop /w exch def /fontscale w maxnumberwidth div def /fontscale fontscale 1 le {1} {fontscale} ifelse def 0.2 -0.15 translate 1 fontscale div dup scale 0 0 moveto numbercolor show grestore } bind def\n"+      +-- | @'page_of_ocircuit' name ocirc@: Render the circuit /ocirc/ on a+-- single page.+-- +-- The rendering takes place in the following user coordinate system:+-- +-- \[image coord.png]+page_of_ocircuit :: FormatStyle -> Maybe BoxId -> OCircuit -> Document ()+page_of_ocircuit fs boxid ocirc = do+  newpage bboxx bboxy $ do+    when (isJust boxid) $ do+      comment ("drawing commands for " ++ string_of_boxid (fromJust boxid))+    +    -- set up the user coordinate system+    scale sc sc+    translate ((xoff fs) + 1) 1+    +    -- drawing commands+    setlinewidth (linewidth fs)+    when (isJust boxid) $ do+      textbox align_left (gatefont fs) (foregroundcolor fs) (-(xoff fs)) (raw_height-0.25) raw_width (raw_height-0.25) (stringbase fs) ("Subroutine " ++ string_of_boxid (fromJust boxid) ++ ":")+    rendered_wires+    rendered_gates+    render_ordering fs (-(xoff fs)) ys False w_in+    render_ordering fs raw_width ys True w_out+  where+    -- unit scale: distance, in points, between wires+    sc = 10+    +    -- decompose OCircuit+    OCircuit (w_in, circ, w_out) = ocirc+    (a1,gs,a2,_) = circ+    +    -- figure out y-coordinates and height+    ws = wirelist_of_circuit circ+    raw_height = fromIntegral $ length ws+    ys = Map.fromList (zip (reverse ws) [0.0 ..])+    maxh = raw_height + 0.3+    bboxy = sc * (raw_height + 1)+    +    -- figure out x-coordinates and width+    (raw_width,xgs) = assign_x_coordinates fs gs 0.0+    bboxx = sc * (raw_width + (xoff fs) + 2.0)+    +    xa1 = IntMap.map (\t -> (t, -(xoff fs))) a1+    (rendered_wires, rendered_gates) = render_gates fs (Map.fromList (IntMap.assocs xa1)) xgs ys raw_width maxh++-- | Render a low-level boxed quantum circuit as a graphical+-- 'Document'. If there are subroutines, each of them is placed on a+-- separate page.+render_bcircuit :: FormatStyle -> BCircuit -> Document ()+render_bcircuit fs (circ, namespace) = do+  page_of_ocircuit fs Nothing (OCircuit ([], circ, []))+  sequence_ [ page_of_ocircuit fs (Just boxid) ocirc | (boxid, TypedSubroutine ocirc _ _ _) <- Map.toList namespace]++-- | Render a low-level dynamic quantum circuit as a graphical+-- 'Document'. If there are subroutines, each of them is placed on a+-- separate page.  If the circuit uses dynamic lifting, an error is+-- produced.+render_dbcircuit :: FormatStyle -> ErrMsg -> DBCircuit a -> Document ()+render_dbcircuit fs e dbcirc = render_bcircuit fs bcirc where+  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc+  errmsg x = e ("operation not permitted during graphical rendering: " ++ x)++-- | Print a representation of a low-level quantum circuit, in the+-- requested graphics format, directly to standard output. If there+-- are boxed subcircuits, each of them is placed on a separate page.+print_bcircuit_format :: FormatStyle -> BCircuit -> IO ()+print_bcircuit_format fs bcirc =+  render_custom_stdout (renderformat fs) cust (render_bcircuit fs bcirc)+    where+      cust = custom {+        creator = "Quipper",+        ps_defs = ps_parameters fs ++ ps_subroutines +        }++-- | Print a representation of a low-level dynamic quantum circuit, in+-- the requested graphics format, directly to standard output. If+-- there are boxed subcircuits, each of them is placed on a separate+-- page. If the circuit uses dynamic lifting, an error is produced.+print_dbcircuit_format :: FormatStyle -> ErrMsg -> DBCircuit a -> IO ()+print_dbcircuit_format fs e dbcirc = +  render_custom_stdout (renderformat fs) cust (render_dbcircuit fs e dbcirc)+    where +      cust = custom {+        creator = "Quipper",+        ps_defs = ps_parameters fs ++ ps_subroutines+        }++-- ----------------------------------------------------------------------+-- * Interface to external programs++-- | @'system_pdf_viewer' zoom pdffile@: Call a system-specific PDF+-- viewer on /pdffile/ file. The /zoom/ argument is out of 100 and may+-- or may not be ignored by the viewer.+system_pdf_viewer :: Double -> String -> IO ()+system_pdf_viewer zoom pdffile = do+  envList <- getEnvironment+  if (List.elem ("OS", "Windows_NT") envList)+  then do+    rawSystem "acroread.bat" [pdffile]+  else if (os == "darwin")+  then do+    rawSystem "open" [pdffile]+    rawSystem "sleep" ["1"] -- required or the file may be deleted too soon+  else do+    rawSystem "acroread" ["/a", "zoom=100", pdffile]+  return ()++-- ----------------------------------------------------------------------+-- * Previewing++-- | Display a document directly in Acrobat Reader. This may not be+-- portable. It requires the external program \"acroread\" to be+-- installed.+preview_document :: Document a -> IO a+preview_document = preview_document_custom custom++-- | Display a document directly in Acrobat Reader. This may not be+-- portable. It requires the external program \"acroread\" to be+-- installed.+preview_document_custom :: Custom -> Document a -> IO a+preview_document_custom custom doc = do+  tmpdir <- getTemporaryDirectory+  (pdffile, fd) <- openTempFile tmpdir "Quipper.pdf"+  a <- render_custom_file fd Format_PDF custom doc+  hClose fd+  system_pdf_viewer 100 pdffile+  removeFile pdffile+  return a++-- | Display the circuit directly in Acrobat Reader. This may not be+-- portable. It requires the external program \"acroread\" to be+-- installed.+preview_bcircuit :: BCircuit -> IO ()+preview_bcircuit bcirc =+  preview_document doc+  where+    doc = render_bcircuit pdf bcirc++-- | Display a low-level dynamic quantum circuit directly in Acrobat+-- Reader. This may not be portable. It requires the external program+-- \"acroread\" to be installed. If the circuit uses dynamic lifting,+-- an error is produced.+preview_dbcircuit :: ErrMsg -> DBCircuit a -> IO ()+preview_dbcircuit e dbcirc = preview_bcircuit bcirc where+  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc+  errmsg x = e ("operation not permitted for PDF preview: " ++ x)++-- ----------------------------------------------------------------------+-- * Gate counts++-- ** Gate types++-- $ The type 'Gate' contains too much information to be used as the +-- index for counting gates: all 'CNot' gates, for instance,+-- should be counted together, regardless of what wires they are+-- applied to.+--+-- We define 'Gatetype' to remedy this, with each value of +-- 'Gatetype' corresponding to an equivalence class of+-- gates as they should appear in gate counts.+--+-- During gate counting, a little more information needs to be retained,+-- so that operations such as adding controls to subroutine counts can+-- be accurately performed.  'AnnGatetype' supplies this information.++-- | An abbreviated representation of the controls of a gate: +-- the number of positive and negative controls, respectively.+type ControlType = (Int,Int) ++-- | From a list of controls, extract the number of positive and+-- negative controls.+controltype :: Controls -> ControlType+controltype c =+  (length $ filter get_sign c, length $ filter (not . get_sign) c)++-- | Convenience constant for uncontrolled gates.+nocontrols :: ControlType+nocontrols = (0,0)++-- | A data type representing equivalence classes of basic gates,+-- for the output of gatecounts.+data Gatetype = +  Gatetype String ControlType+  | GatetypeSubroutine BoxId InverseFlag ControlType+ deriving (Eq, Ord, Show)++-- | A data type analogous to 'Gatetype', but with extra annotations,+-- e.g. a 'NoControlFlag', for use in the computation of gate counts.+data AnnGatetype = +    AnnGatetype String (Maybe String) ControlType NoControlFlag ControllableFlag+  | AnnGatetypeSubroutine BoxId InverseFlag ControlType NoControlFlag ControllableFlag+  deriving (Eq, Ord, Show)++-- | Forget the annotations of an 'AnnGatetype'+unannotate_gatetype :: AnnGatetype -> Gatetype+unannotate_gatetype (AnnGatetype n _ cs _ _) = Gatetype n cs+unannotate_gatetype (AnnGatetypeSubroutine n i cs _ _) = GatetypeSubroutine n i cs++-- | Add controls to an annotated gate type, or throw an error message if it is not controllable; +-- unless its 'NoControlFlag' is set, in which case leave it unchanged.+add_controls_gatetype :: ErrMsg -> ControlType -> AnnGatetype -> AnnGatetype+add_controls_gatetype e (x',y') g@(AnnGatetype n n_inv (x,y) ncf cf) =+  if ncf then g+  else case cf of+     AllCtl           -> AnnGatetype n n_inv (x+x',y+y') ncf cf+     OnlyClassicalCtl -> AnnGatetype n n_inv (x+x',y+y') ncf cf+     NoCtl            -> error $ e "add_controls_gatetype: gate " ++ n ++ " is not controllable."++add_controls_gatetype e (x',y') g@(AnnGatetypeSubroutine n inv (x,y) ncf cf) =+  if ncf then g+  else case cf of+     AllCtl           -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf+     OnlyClassicalCtl -> AnnGatetypeSubroutine n inv (x+x',y+y') ncf cf+     NoCtl            -> error $ e "add_controls_gatetype: subroutine " ++ show n ++ " is not controllable."++-- | Reverse an annotated gate type, of throw an error if it is not reversible. +reverse_gatetype :: ErrMsg -> AnnGatetype -> AnnGatetype+reverse_gatetype e g@(AnnGatetype n n_inv cs ncf cf) =+  case n_inv of+    Just n' -> (AnnGatetype n' (Just n) cs ncf cf)+    Nothing -> error $ e "reverse_gatetype: gate " ++ n ++ " is not reversible"+reverse_gatetype e g@(AnnGatetypeSubroutine n inv cs ncf cf) =+  (AnnGatetypeSubroutine n (not inv) cs ncf cf)++-- | Set the 'NoControlFlag' of an annotated gate type to 'True'.+set_ncf_gatetype :: AnnGatetype -> AnnGatetype+set_ncf_gatetype (AnnGatetype n n_inv cs ncf cf) =+                 (AnnGatetype n n_inv cs True cf)+set_ncf_gatetype (AnnGatetypeSubroutine n inv cs ncf cf) =+                 (AnnGatetypeSubroutine n inv cs True cf)++-- | Helper function for 'gatetype': append a formatted arity to a string.+with_arity :: String -> Int -> String+n `with_arity` a = n ++ ", arity " ++ show a++-- | Convert a given low-level gate to an annotated gate type+gatetype :: Gate -> AnnGatetype+gatetype (QGate n inv ws vs c ncf) =+  AnnGatetype (n' inv') (Just $ n' $ notinv') (controltype c) ncf AllCtl+  where +    n' b = (n ++ optional b "*") `with_arity` (length ws + length vs)+    inv' = inv && not (self_inverse n ws vs)+    notinv' = not inv && not (self_inverse n ws vs)+gatetype (QRot n inv t ws vs c ncf) =+  AnnGatetype (n' inv) (Just $ n' $ not inv) (controltype c) ncf AllCtl+  where n' b = (printf "Rot(%s,%f)" (n++ optional b "*") t) `with_arity` (length ws + length vs)+gatetype (GPhase t w c ncf) = +  AnnGatetype (phase_name t) (Just $ phase_name (-t)) (controltype c) ncf AllCtl+  where phase_name t = (printf "exp^(%f i pi)" t)+gatetype (CNot w c ncf) = +  AnnGatetype "CNot" (Just "CNot") (controltype c) ncf AllCtl+gatetype (CGate n w ws ncf) = +  AnnGatetype (n' True) (Just $ n' False) nocontrols ncf AllCtl+  where n' b = n ++ optional b "*" `with_arity` length ws+gatetype (CGateInv n w ws ncf) =+  AnnGatetype (n' False) (Just $ n' True) nocontrols ncf AllCtl+  where n' b = n ++ optional b "*" `with_arity` length ws+gatetype (CSwap w v c ncf) =+  AnnGatetype "CSwap" (Just "CSwap") (controltype c) ncf AllCtl+gatetype (QPrep w ncf) =+  AnnGatetype "Prep" (Just "Unprep") nocontrols ncf NoCtl+gatetype (QUnprep w ncf) = +  AnnGatetype "Unprep" (Just "Prep") nocontrols ncf NoCtl+gatetype (QInit b w ncf) =+  AnnGatetype ("Init" ++ b') (Just $ "Term" ++ b') nocontrols ncf NoCtl+  where b' = show $ if b then 1 else 0+gatetype (CInit b w ncf) =+  AnnGatetype ("CInit" ++ b') (Just $ "CTerm" ++ b') nocontrols ncf NoCtl+  where b' = show $ if b then 1 else 0+gatetype (QTerm b w ncf) =+  AnnGatetype ("Term" ++ b') (Just $ "Init" ++ b') nocontrols ncf NoCtl+  where b' = show $ if b then 1 else 0+gatetype (CTerm b w ncf) =+  AnnGatetype ("CTerm" ++ b') (Just $ "CInit" ++ b') nocontrols ncf NoCtl+  where b' = show $ if b then 1 else 0+gatetype (QMeas w) = +  AnnGatetype "Meas" Nothing nocontrols False NoCtl+gatetype (QDiscard w) =+  AnnGatetype "Discard" Nothing nocontrols False NoCtl+gatetype (CDiscard w) =+  AnnGatetype "CDiscard" Nothing nocontrols False NoCtl+gatetype (DTerm b w) =+  AnnGatetype "CDiscard" Nothing nocontrols False NoCtl+gatetype (Subroutine boxid inv ws1 a1 ws2 a2 c ncf ctrble reps) =+  AnnGatetypeSubroutine boxid inv (controltype c) ncf ctrble+gatetype (Comment _ inv ws) = AnnGatetype ("Comment") (Just "Comment") nocontrols True NoCtl++-- | Convert a gate type to a human-readable string.+string_of_gatetype :: Gatetype -> String+string_of_gatetype (Gatetype s (c1,c2)) =+  printf "\"%s\"" s+  ++ if c2==0 && c1==0 then "" else+     if c2==0 then printf ", controls %d" c1 else+     printf " controls %d+%d" c1 c2+string_of_gatetype (GatetypeSubroutine boxid i (c1,c2)) =+  "Subroutine" ++ optional i "*" ++ cs ++ ": " ++ string_of_boxid boxid+  where+    cs = if c2==0 && c1==0 then "" else+         if c2==0 then printf ", controls %d" c1 else+         printf " controls %d+%d" c1 c2++-- ** Gate counts++-- | Gate counts of circuits.  +type Gatecount = Map Gatetype Integer++-- | Annotated gate counts of circuits.  +type AnnGatecount = Map AnnGatetype Integer++-- | Given the (annotated) gatecount of a circuit, return the gatecount of+-- the reverse circuit, or throw an error if any component is not reversible.+reverse_gatecount :: ErrMsg -> AnnGatecount -> AnnGatecount+reverse_gatecount e = Map.mapKeysWith (+) (reverse_gatetype e)++-- | Given the (annotated) gatecount of a circuit, return the gatecount of+-- the same circuit with controls added, or throw an error if any component+-- is not controllable.+add_controls_gatecount :: ErrMsg -> ControlType -> AnnGatecount -> AnnGatecount+add_controls_gatecount e cs = Map.mapKeysWith (+) (add_controls_gatetype e cs)++-- | Set the ncf of all gates in a gatecount to 'True'.+set_ncf_gatecount :: AnnGatecount -> AnnGatecount+set_ncf_gatecount = Map.mapKeysWith (+) set_ncf_gatetype++-- | Remove the annotations from a gatecount.+unannotate_gatecount :: AnnGatecount -> Gatecount+unannotate_gatecount = Map.mapKeysWith (+) unannotate_gatetype++-- | Input a list of items and output a map from items to counts.+-- Example: +-- +-- > count ['a', 'b', 'a'] = Map.fromList [('a',2), ('b',1)]+count :: (Ord a, Num int) => [(int,a)] -> Map a int+count list =+  foldl' (\mp (i,x) -> Map.insertWith' (+) x i mp) Map.empty list ++-- | Count the number of gates of each type in a circuit, with annotations,+-- treating subroutine calls as atomic gates.+anngatecount_of_circuit :: Circuit -> AnnGatecount+anngatecount_of_circuit (_,gs,_,_) = count $ map (\x -> (repeated x, gatetype x)) $ filter (not . is_comment) gs+  where+    is_comment (Comment _ _ _) = True+    is_comment _ = False+    repeated (Subroutine _ _ _ _ _ _ _ _ _ (RepeatFlag repeat)) = repeat+    repeated _ = 1++-- | Count the number of gates of each type in a circuit,+-- treating subroutine calls as atomic gates.+gatecount_of_circuit :: Circuit -> Gatecount+gatecount_of_circuit = unannotate_gatecount . anngatecount_of_circuit++-- | Given an 'AnnGatetype' describing a subroutine call+-- (possibly repeated),+-- and a gate count for the subroutine itself, return the gatecount +-- of the subroutine call.+--+-- (This may be the reverse of the original subroutine, may have+-- controls added, etc.)+gatecount_of_subroutine_call :: ErrMsg -> AnnGatetype -> RepeatFlag -> AnnGatecount -> AnnGatecount+gatecount_of_subroutine_call e (AnnGatetypeSubroutine boxid inv cs ncf ctrble) (RepeatFlag reps) =+  (if inv then reverse_gatecount err_inv else id)+  . (if cs == nocontrols then id+       else case ctrble of+             AllCtl           -> add_controls_gatecount err_ctrl cs+             OnlyClassicalCtl -> add_controls_gatecount err_ctrl cs+             NoCtl            -> error $ err_ctrble)+  . (if reps == 1 then id else (Map.map (* reps)))+  . (if ncf then set_ncf_gatecount else id) +  where+    err_inv = e . (("gatecount_of_subroutine_call, inverting subroutine " ++ longname ++ ": ") ++)+    err_ctrl = e . (("gatecount_of_subroutine_call, controlling subroutine " ++ longname ++ ": ") ++)+    err_ctrble = e $ "gatecount_of_subroutine_call: subroutine " ++ longname ++ " not controllable"+    longname = string_of_boxid boxid+    +gatecount_of_subroutine_call e _ _ = error $ e "internal error (gatecount_of_subroutine_call called on non-subroutine)"++-- | Given a circuit and gatecounts for its subroutines, +-- give an (aggregated) gatecount for the circuit.+anngatecount_of_circuit_with_sub_cts :: ErrMsg -> Map BoxId AnnGatecount -> Circuit -> AnnGatecount+anngatecount_of_circuit_with_sub_cts e sub_cts (_,gs,_,_) =+  foldr action Map.empty gs+  where+    action (Comment _ _ _) = id+    action g@(Subroutine n _ _ _ _ _ _ _ _ reps) = +      case Map.lookup n sub_cts of+        Nothing -> error $ e $ "subroutine not found: " ++ show n+        Just n_ct -> flip (Map.unionWith (+)) $+                       gatecount_of_subroutine_call e (gatetype g) reps n_ct+    action g = Map.insertWith' (+) (gatetype g) 1++-- | Give the aggregate gate count of a 'BCircuit'; that is, the+-- the total count of basic gates once all subroutines are fully inlined.+aggregate_gatecounts_of_bcircuit :: BCircuit -> Gatecount+aggregate_gatecounts_of_bcircuit (main_circ, namespace)+  = unannotate_gatecount $+    anngatecount_of_circuit_with_sub_cts e sub_cts main_circ+    where+      sub_cts = Map.map (anngatecount_of_circuit_with_sub_cts e sub_cts . circuit_of_typedsubroutine) namespace+      e = ("aggregate_gatecounts_of_bcircuit: " ++)++-- ** Wire usage count++-- | Count by how much a low-level gate changes the number of wires in the arity.++-- Implementation note: writing this function explicitly case-by-case appears+-- very slightly faster (~0.5%), but more fragile/less maintainable.+gate_wires_change :: Gate -> Integer+gate_wires_change g = +  let (a_in,a_out) = gate_arity g+  in fromIntegral $ length a_out - length a_in++-- | Find the maximum number of wires used simultaneously in a 'BCircuit',+-- assuming all subroutines inlined. +aggregate_maxwires_of_bcircuit :: BCircuit -> Integer+aggregate_maxwires_of_bcircuit (main_circ, namespace)+  = maxwires_of_circuit_with_sub_maxwires e sub_maxs main_circ+    where+      e = ("aggregate_maxwires_of_bcircuit: " ++)+      sub_maxs = Map.map (maxwires_of_circuit_with_sub_maxwires e sub_maxs . circuit_of_typedsubroutine) namespace++-- | Given a circuit and gatecounts for its subroutines, +-- give an (aggregated) gatecount for the circuit.+maxwires_of_circuit_with_sub_maxwires :: ErrMsg -> Map BoxId Integer -> Circuit -> Integer+maxwires_of_circuit_with_sub_maxwires e sub_maxs (a1,gs,a2,_) =+  snd $ foldl (flip action) (in_wires, in_wires) gs+  where+    in_wires = fromIntegral $ IntMap.size a1+    update w_change (!w_old, !wmax_old) =+-- Implementation note: strictness in this pattern is to avoid putting the whole+-- tower of “max” applications on the stack.+      let w_new = w_old + w_change in (w_new, max wmax_old w_new)+    action g@(Subroutine n _ ws1 _ ws2 _ _ _ _ (RepeatFlag r)) = +      case Map.lookup n sub_maxs of+        Nothing -> error $ "subroutine not found: " ++ show n+        Just n_max -> (update $ (fromIntegral $ length ws2) - n_max)+                      . (update $ n_max - (fromIntegral $ length ws1))+    action g = update $ gate_wires_change g++-- ** Printing gate counts++-- | Print a gate count, as a table of integers and gate types. +print_gatecount :: Gatecount -> IO ()+print_gatecount cts = mapM_+  (\(gt,k) -> putStr (printf ("%" ++ show max_digits ++ "d: %s\n") k (string_of_gatetype gt)))+  (Map.assocs cts)+  where+    max_digits = maximum $ 5:(map ((1+) . floor . logBase 10 . fromIntegral) (Map.elems cts))++-- | Print the simple gate count, plus summary information, for a simple circuit.+print_gatecounts_circuit :: Circuit -> IO ()+print_gatecounts_circuit circ@(a1,gs,a2,n) = do+  print_gatecount cts+  putStrLn $ printf "Total gates: %d" $ sum $ Map.elems cts+  putStrLn $ printf "Inputs: %d" $ IntMap.size a1+  putStrLn $ printf "Outputs: %d" $ IntMap.size a2+  putStrLn $ printf "Qubits in circuit: %d" n+  where+    cts = gatecount_of_circuit circ++-- | Print gate counts for a boxed circuit:+-- first the simple gate count for each subroutine separately,+-- then the aggregated count for the whole circuit.+print_gatecounts_bcircuit :: BCircuit -> IO ()+print_gatecounts_bcircuit bcirc@(circ@(a1,_,a2,_),namespace) = do+  print_gatecounts_circuit circ+  when (not $ Map.null namespace) $ do+    sequence_ [ (putStrLn "") >> (print_gatecounts_subroutine sub) | sub <- Map.toList namespace ]+    putStrLn ""+    putStrLn "Aggregated gate count:" +    let aggregate_cts = aggregate_gatecounts_of_bcircuit bcirc+        maxwires = aggregate_maxwires_of_bcircuit bcirc+    print_gatecount aggregate_cts+    putStrLn $ printf "Total gates: %d" $ sum $ Map.elems aggregate_cts+    putStrLn $ printf "Inputs: %d" $ IntMap.size a1+    putStrLn $ printf "Outputs: %d" $ IntMap.size a2+    putStrLn $ printf "Qubits in circuit: %d" maxwires++-- | Print gate counts for a named subroutine.+print_gatecounts_subroutine :: (BoxId, TypedSubroutine) -> IO ()+print_gatecounts_subroutine (boxid, TypedSubroutine ocirc _ _ _) = do+  putStrLn ("Subroutine: " ++ show name)+  putStrLn ("Shape: " ++ show shape)+  print_gatecounts_circuit circ+  where+    OCircuit (_, circ, _) = ocirc+    BoxId name shape = boxid++-- | Print gate counts for a static 'DBCircuit'. The circuit may not+-- use any dynamic lifting, or else an error will be produced.+print_gatecounts_dbcircuit :: ErrMsg -> DBCircuit a -> IO ()+print_gatecounts_dbcircuit e dbcirc = print_gatecounts_bcircuit bcirc where+  (bcirc, _) = bcircuit_of_static_dbcircuit errmsg dbcirc+  errmsg x = e ("operation not permitted during gate count: " ++ x)++-- ----------------------------------------------------------------------+-- * Printing to multiple formats++-- | Available output formats.++data Format = +  EPS         -- ^ Encapsulated PostScript graphics.+  | PDF       -- ^ Portable Document Format. One circuit per page.+  | PS        -- ^ PostScript. One circuit per page.+  | ASCII     -- ^ A textual representation of circuits.+  | Preview   -- ^ Don't print anything, but preview directly on screen (requires the external program /acroread/).+  | GateCount -- ^ Print statistics on gate counts.+  | CustomStyle FormatStyle+  deriving Show+    +-- | A mapping from lower-case strings (to be used, e.g., with command+-- line options) to available formats.+format_enum :: [(String, Format)]+format_enum = [+  ("eps", EPS),+  ("pdf", PDF),+  ("ps", PS),+  ("postscript", PS),+  ("ascii", ASCII),+  ("preview", Preview),+  ("gatecount", GateCount)+  ]+                    +-- | Print a low-level quantum circuit directly to the IO monad, using+-- the specified format.+print_dbcircuit :: Format -> ErrMsg -> DBCircuit a -> IO ()+print_dbcircuit EPS = print_dbcircuit_format eps+print_dbcircuit PDF = print_dbcircuit_format pdf+print_dbcircuit PS = print_dbcircuit_format ps+print_dbcircuit ASCII = print_dbcircuit_ascii+print_dbcircuit Preview = preview_dbcircuit+print_dbcircuit GateCount = print_gatecounts_dbcircuit+print_dbcircuit (CustomStyle fs) = print_dbcircuit_format fs++-- | Print a document to the requested format, which must be one of+-- 'PS', 'PDF', 'EPS', or 'Preview'.+print_of_document :: Format -> Document a -> IO a+print_of_document = print_of_document_custom custom++-- | Like 'print_of_document', but also takes a 'Custom' data+-- structure.+print_of_document_custom :: Custom -> Format -> Document a -> IO a+print_of_document_custom custom PS doc = render_custom_stdout Format_PS custom doc+print_of_document_custom custom PDF doc = render_custom_stdout Format_PDF custom doc+print_of_document_custom custom EPS doc = render_custom_stdout (Format_EPS 1) custom doc+print_of_document_custom custom Preview doc = preview_document_custom custom doc+print_of_document_custom custom format doc = error ("print_of_document: method " ++ show format ++ " can't be used in this context")++-- ======================================================================+-- * Generic printing++-- | Like 'print_unary', but also takes a stub error message.+print_errmsg :: (QCData qa) => ErrMsg -> Format -> (qa -> Circ b) -> qa -> IO ()+print_errmsg e format f shape = print_dbcircuit format e dbcircuit+  where +    (in_bind, dbcircuit) = encapsulate_dynamic f shape++-- | Print a circuit generating function to the specified format; this+-- requires a shape parameter.+print_unary :: (QCData qa) => Format -> (qa -> Circ b) -> qa -> IO ()+print_unary = print_errmsg errmsg+  where +    errmsg x = "print_unary: " ++ x++-- | Print a circuit generating function to the specified+-- format. Unlike 'print_unary', this can be applied to a+-- circuit-generating function in curried form with /n/ arguments, for+-- any /n >= 0/. It then requires /n/ shape parameters.+-- +-- The type of this heavily overloaded function is difficult to+-- read. In more readable form, it has all of the following types:+-- +-- > print_generic :: Format -> Circ qa -> IO ()+-- > print_generic :: (QCData qa) => Format -> (qa -> Circ qb) -> a -> IO ()+-- > print_generic :: (QCData qa, QCData qb) => Format -> (qa -> qb -> Circ qc) -> a -> b -> IO ()+-- +-- and so forth.+ +print_generic :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO())) => Format -> qfun -> fun+print_generic format f = g where+  f1 = quncurry f+  g1 = print_errmsg errmsg format f1+  g = mcurry g1+  errmsg x = "print_generic: " ++ x++-- | Like 'print_generic', but only works at simple types, and+-- therefore requires no shape parameters.+print_simple :: (QCData qa, QCurry qfun qa b, Curry fun qa (IO()), QCData_Simple qa) => Format -> qfun -> IO ()+print_simple format f = print_errmsg errmsg format f1 fs_shape where+  f1 = quncurry f+  errmsg x = "print_simple: " ++ x