diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,66 @@ +Contributors are listed here, in alphabetical order by last name. +Unless otherwise noted, the copyright for his or her contributions +rests with each individual author. For contributions by authors whose +name is marked (ACS), the copyright rests with Applied Communication +Sciences. + +Copyright (C) 2011-2016. All rights reserved. +Copyright (C) 2012-2013 Applied Communication Sciences. All rights +reserved. + +Richard Eisenberg +Alexander S. Green +Peter LeFanu Lumsdaine +Keith Kim (ACS) +Siun-Chuon Mau (ACS) +Baranidharan Mohan +Won Ng (ACS) +Joel Ravelomanantsoa-Ratsimihah +Neil J. Ross +Artur Scherer (ACS) +Peter Selinger +Benoît Valiron +Alexandr Virodov (ACS) +Stephan A. Zdancewic + +This research was supported by the Intelligence Advanced Research +Projects Activity (IARPA) via Department of Interior National Business +Center contract numbers D11PC20168 and D12PC00527. The U.S. Government +is authorized to reproduce and distribute reprints for Governmental +purposes notwithstanding any copyright annotation thereon. Disclaimer: +The views and conclusions contained herein are those of the authors +and should not be interpreted as necessarily representing the official +policies or endorsements, either expressed or implied, of IARPA, +DoI/NBC, or the U.S. Government. + +---------------------------------------------------------------------- +LICENSE + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. + +3. The name of the authors and copyright holders may not be used to + endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, +INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. +---------------------------------------------------------------------- diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,428 @@ +This file is part of Quipper. Copyright (C) 2011-2016. Please see the +file COPYRIGHT for a list of authors, copyright holders, licensing, +and other details. All rights reserved. + +====================================================================== + +This is Quipper. + +Copyright, License, and Disclaimers +=================================== + +See the file COPYRIGHT. + +Installing the necessary components +=================================== + +For installing on Linux, Mac OS X, and other Unix-like systems: please +first see the instructions in INSTALLING, then continue to read below. + +For installing on Windows: please first see the instructions in +INSTALLING.windows, then continue to read below. + +Configuring the software environment +===================================== + +Before you can compile Quipper, you have to install some Haskell +libraries: + + * random >= 1.0.1.1 + * mtl >= 2.1.2 + * primes >= 0.2.1.0 + * Lattices >= 0.0.1 (note: "Lattices" must be capitalized) + * zlib >= 0.5.4.1 + * easyrender >= 0.1.0.0 + * fixedprec >= 0.2.1.0 + * newsynth >= 0.3.0.1 + * containers >= 0.5.2.1 + * set-monad >= 0.1.0.0 + * QuickCheck >= 2.6 + +This can be done using Cabal. On the command line, use the +following commands: + +cabal update + +then: + +cabal install random +cabal install mtl +cabal install primes +cabal install Lattices +cabal install zlib +cabal install easyrender +cabal install fixedprec +cabal install newsynth +cabal install containers +cabal install set-monad +cabal install QuickCheck + +Note: When upgrading from a previous version of Quipper, please ensure +that the fixedprec library is version 0.2.1.0 or newer; Quipper 0.6 +will not work with earlier versions of fixedprec. Also ensure that the +newsynth library has been compiled against the same version of +fixedprec as Quipper. If you get strange error messages related to +fixedprec, try + +cabal install fixedprec +cabal install newsynth --reinstall + +You now have all the necessary Haskell libraries. + +Special note for GHC 7.4.2: +=========================== + +The combination of GHC 7.4.2 and Template Haskell 2.8.0.0 is not +possible, because it triggers a GHC bug. If you get a compilation +error of the form: "ghc: panic! (the 'impossible' happened)", follow +these steps: + +# Remove Template Haskell 2.8.0.0: + +ghc-pkg unregister --force template-haskell-2.8.0.0 + +# Reinstall QuickCheck (because of a broken dependency). This will +# also install template-haskell-2.7.0.0: + +cabal install QuickCheck + +Special note for GHC 7.10.*: +============================ + +Quipper will not work with ghc 7.10. Please use ghc 7.8 or earlier, or +ghc 8.0 or later. + +Browsing the documentation and source code +========================================== + +While it is possible the browse the Quipper source code in a text +editor, it is much nicer to browse the documented source by pointing +your web browser to doc/frames.html in this Quipper distribution. The +documented source is fully cross-referenced and indexed, with links to +color-coded raw source files. + + +Building the documentation +========================== + +Please note: our documentation uses special mark-up and requires +custom tools to be built. Therefore it is not currently possible for +users to re-build the documentation. + + +Building the included algorithms and programs +============================================= + +Compilation, and execution of generated code, are done from the command +line interface. + +The code can be built with "make" from the main directory. This will +build an executable file in each Algorithm subdirectory, which can be +run with various command line parameters to do different things. Run +each command with option --help to see a summary of the usage +information. + +In the following, we describe the set of options for the algorithms +that were implemented. + + +Running the bwt program +======================= + +Usage for Binary Welded Tree algorithm: +--------------------------------------- + +Usage: bwt [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -O --oracle output only the oracle + -K --oraclec output the "classical" oracle as a classical circuit + -G --graph print colored graph computed from oracle + -S --simulate run simulations of some circuit fragments for tree height n + -f --format= output format for circuits (default: preview) + -g --gatebase= type of gates to decompose into (default: logical) + -o select oracle to use (default: orthodox) + -n --height= set tree height (positive; default 5) + -c --color= color to use with --oracle (0..3, default 0) + -s --repeats= set parameter s (iteration count; default 1) + -l --large set large problem size: n=300, s=336960 + -t
--dt=
set parameter dt (simulation time step; default pi/180) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle are: orthodox, simple, blackbox, classical, template, optimized. + +Examples of command line options: +--------------------------------- + +* Show the complete circuit for the BWT algorithm using the + "orthodox" (official GFI) oracle, with n=5 and s=1: + + ./bwt -C -o orthodox -n 5 -s 1 + + (One can point out the different parts of the algorithm: 8 oracle + calls, and 4 very short diffusion steps). + +* Show the same, using the "Template Haskell" oracle: this oracle is + much larger, but automatically generated from classical code (and + completely unoptimized): + + ./bwt -C -o template -n 5 -s 1 + + The "template oracle" is defined in BWT/Template.hs. See the + documentation of the module Quipper/CircLifting for how it works. + +* Show the graph of the BWT algorithm, which is obtained by + simulating the orthodox oracle (and therefore offers some evidence + for the correctness of the oracle implementation): + + ./bwt -G -o orthodox -n 5 + +* Show the orthodox oracle for n=300. Note that this will result in a + big file. One has to zoom in substantially to see gates. + + ./bwt -O -o orthodox -n 300 + +* Show the complete circuit for the BWT algorithm, but decompose + everything into binary gates: + + ./bwt -C -o orthodox -n 5 -s 1 -g binary + +* Show the oracle from Figure 1a (alternate oracle). + + ./bwt -C -o figure1a + +* The same, decomposed into binary+Toffoli gates, or binary gates + only, respectively: + + ./bwt -C -o figure1a -g toffoli + ./bwt -C -o figure1a -g binary + +* Show gate counts for BWT algorithm with n=300 and s=1, using + "orthodox" oracle: + + ./bwt -C -o orthodox -n 300 -s 1 -f gatecount + +* Show gate counts for same, after decomposition to binary gates: + + ./bwt -C -o orthodox -n 300 -s 1 -f gatecount -g binary + +Obviously, most other combinations of command line options are also +possible, for example: decompose to toffoli gates and then simulate +and show the graph. Some other combinations are not legal: for +example, decomposing to binary gates and then simulating. (The +classical simulator will complain that the circuit is not boolean; it +contains "V" gates). + +* Similarly, one can run demos for the triangle finding + algorithm using various command line options. + +Note that the triangle finding algorithm is not a deliverable; it is a +work in progress. The only implemented algorithm that is officially a +deliverable is the "orthodox" BWT implementation in BWT.BWT. + +Running the bf program +====================== + +Usage for the Boolean Formula algorithm: +---------------------------------------- + +Usage: bf [OPTION...] + -C --circuit output the whole circuit (default) + -D --demo run a demo of the circuit + -H --hexboard output a representation of the initial state of the given oracle, i.e. the game played so far + -p --part= which part of the circuit to use (default: whole) + -o --oracle= which oracle to use (default: small) + -m --moves= which moves have already been made (default: []) + -f --format= output format for circuits (default: _preview) + -d --dummy set to only use a dummy HEX gate instead of the full hex circuit + -h --help print usage info and exit + -g --gatebase= type of gates to decompose the output circuit into (default: logical) +Possible values for part are: whole, u, oracle, hex, checkwin_red, diffuse, walk, undo_oracle. +Possible values for oracle are: 9by7, small, custom x y t. +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. + +Running the cl program +====================== + +Usage for the Class Number algorithm: +------------------------------------- + +Usage: cl [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: ASCII) + -g --gatebase= gates to decompose into (default: Logical) + -1 output the circuit for stage 1 of the algorithm (default) + -4 output the circuit for stage 4 of the algorithm + -S --sub= output the circuit for a specific subroutine + -R --regulator classically, find the regulator, given Δ + -F classically, find the fundamental unit, given Δ + -P classically, find the fundamental solution of Pell’s equation, given Δ + -d --delta= discriminant Δ (a.k.a. D) (default: 28) + -s --ss= estimated bound on period S, for stage 1 (default: 2) + -i estimated bound on log_2 S, for stage 1 (default: 1) + -r --rr= approximate regulator R, for stage 4 (default: 12.345) + -q The parameter q, for stage 4 (default: 4) + -k The parameter k, for stage 4 (default: 3) + -n The parameter n, for stage 4 (default: 3) + -m The parameter m, for stage 4 (default: 5) + --seed= Random seed (0 for seed from time)(default: 1) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for subroutine are: rho, rhoinv, normalize, dotprod, starprod, fn. + +Running the gse program +======================= + +Usage for Ground State Estimation algorithm: +-------------------------------------------- + +Usage: gse [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -T --template= output a particular circuit template + -f --format= output format for circuits (default: Preview) + -g --gatebase= gates to decompose into (default: Logical) + -m --orbitals= number of orbitals (default: 4) + -o --occupied= number of occupied orbitals (default: 2) + -b --precision= number of precision qubits (default: 3) + -D --delta_e= energy range (default: 6.5536) + -E --e_max= maximum energy (default: -3876.941) + --n0= use N_k = n0 * 2^k (default: N_k = 1) + -l --large set large problem size (m=208, o=84, b=12, n0=100) + -x --orthodox use the Coulomb operator of Whitman et al. + --h1= filename for one-electron data (default: "h_1e_ascii") + --h2= filename for two-electron data (default: "h_2e_ascii") + -d --datadir= directory for one- and two-electron data (default: current) +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Indices can be specified as p,q or p,q,r,s (with no spaces) + +Running the qls program +======================= + +Usage for Quantum Linear Systems algorithm: +------------------------------------------- + +Usage: qls [OPTION...] + -h --help print usage info and exit + -C --circuit output the whole circuit (default) + -O --oracle= output only the oracle (default: r) + -f --format= output format for circuits (default: gatecount) + -g --gatebase= type of gates to decompose into (default: logical) + -o select oracle implementation to use (default: blackbox) + -p --param= choose a set of parameters (default: dummy). + -P --peel= peel layers of boxed subroutines (default: 0). +Possible values for format are: ascii, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle implementation are: matlab, blackbox. +Possible values for param are: dummy, small, large. +Possible values for oracle are: r, b, A[band][t|f]. E.g. "-OA1t" asks for band 1 with boolean argument True. For all three oracles, the factors are set up to 1.0. + +Running the tf program +====================== + +Usage for Triangle Finding algorithm: +------------------------------------- + +Usage: tf [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: preview) + -g --gatebase= type of gates to decompose into (default: logical) + -l --l= parameter l (default: 4) + -n --n= parameter n (default: 3) + -r --r= parameter r (default: 2) + -C --QWTFP output the whole circuit (default) + -O --oracle output only the oracle + -s --subroutine= output the chosen subroutine (default: adder) + -Q use alternative qRAM implementation + -o select oracle to use (default: blackbox) + -A --arith test/simulate the arithmetic routines + -T --oracletest test/simulate the oracle +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. +Possible values for oracle are: orthodox, blackbox. +Possible values for subroutine are: zero, initialize, hadamard, setup, qwsh, diffuse, fetcht, storet, fetchstoret, fetche, fetchstoree, update, swap, a15, a16, a17, a18, gcqwalk, gcqwstep, convertnode, testequal, pow17, mod3, sub, add, mult. + +Running the usv program +======================= + +Usage for Unique Shortest Vector algorithm: +------------------------------------------- + +Usage: usv [OPTION...] + -h --help print usage info and exit + -f --format= output format for circuits (default: eps) + -g --gatebase= type of gates to decompose into (default: logical) + -n --n= parameter n (default: 5) + -b --b= parameter b (default: 5X5 with entries = 1) + -s --s= Random number generator seed s (default: 1) + -F output subroutine f (depends on b). + -G output subroutine g (depends on b). + -H output subroutine h (depends on n). + -U output algorithm 1 (depends on b). + -Q output algorithm 2 (depends on b). + -R output algorithm 3 (depends on b). + -T output algorithm 4 (depends on n). + -S output sieving subroutine (depends on n). + -D output algorithm 5 (depends on n). + -t test subroutine h (depends on n). +Possible values for format are: eps, pdf, ps, postscript, ascii, preview, gatecount. +Possible values for gatebase are: logical, binary, toffoli, cliffordt_old, cliffordt, cliffordt_keepphase, standard, strict, approximate, approximate_keepphase, exact, trimcontrols. + + +Invoking the Quipper compiler +============================= + +The Quipper compiler is called "quipper", and is located in the +directory quipper/scripts. The easiest way to use it is to add the +"scripts" directory to the environment variable PATH. If you move the +quipper script around, make sure to keep the other scripts in the same +directory as the quipper script, and to update QUIPPER_BASE in the +"quipper" and "quipperi" scripts to point to the directory where the +Quipper sources are located. On the Windows operating system, you +should use "quipper.bat"; on all other operating systems, just +"quipper" will do. + +In reality, the "quipper" script is a wrapper around the GHC Haskell +compiler, providing some pre-processing and setting required +compilation options. There is also a "quipperi" script for an +interactive version of the compiler, which is akin to "ghci". + +To try this out, the directory "tests" contains various small +stand-alone programs that can be compiled with Quipper, and are useful +for demonstrating the basic Quipper idiom. Each program can be +compiled and run like this: + +For example: + +# to compile and run on Unix (or on Unix with the MSYS/bash): +quipper And_gate.hs +./And_gate + +# to compile and run on Windows with cmd.exe: +quipper.bat And_gate.hs +And_gate + +Note that there is also a Makefile, so "make" can be used to build the +programs as well. + +If the previewer is working properly, the circuit should show up in +Acrobat Reader. If not, either change "Preview" to "EPS" in the file +(for PostScript output), or trouble-shoot the previewer installation +(if you are on Windows, see INSTALLING) and/or contact Benoit Valiron + or Peter Selinger + for help. + +The naming of built-in gates and many operators can be found out by +looking at the documentation of the "Quipper" module (the main public +interface of the Quipper system). + + +Troubleshooting Guidelines +========================== + +In case of problems, please contact + + * Benoit Valiron + * Peter Selinger diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/quipper-rendering.cabal b/quipper-rendering.cabal new file mode 100644 --- /dev/null +++ b/quipper-rendering.cabal @@ -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 diff --git a/src/Libraries/Auxiliary.hs b/src/Libraries/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/src/Libraries/Auxiliary.hs @@ -0,0 +1,926 @@ +-- This file is part of Quipper. Copyright (C) 2011-2016. Please see the +-- file COPYRIGHT for a list of authors, copyright holders, licensing, +-- and other details. All rights reserved. +-- +-- ====================================================================== + +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | This module provides miscellaneous general-purpose auxiliary +-- functions. + +module Libraries.Auxiliary ( + -- * List operations + applyAt, + overwriteAt, + has_duplicates, + substitute, + + -- * Set and Map related operations + map_provide, + intset_inserts, + intmap_zip, + intmap_zip_errmsg, + intmap_map, + intmap_mapM, + + -- * XIntMaps + XIntMap, + xintmap_delete, + xintmap_deletes, + xintmap_insert, + xintmap_inserts, + xintmap_lookup, + xintmap_member, + xintmap_empty, + xintmap_freshkey, + xintmap_freshkeys, + xintmap_to_intmap, + xintmap_size, + xintmap_dirty, + xintmap_reserves, + xintmap_unreserves, + xintmap_makeclean, + + -- * Various map- and fold-like list combinators + loop, + loop_with_index, + fold_right_zip, + zip_strict, + zip_strict_errmsg, + zip_rightstrict, + zip_rightstrict_errmsg, + zipWith_strict, + zipWith_rightstrict, + + -- * Monadic versions of list combinators + loopM, + loop_with_indexM, + zipRightWithRightStrictM, + zipRightWithRightStrictM_, + fold_right_zipM, + foldRightPairM, + foldRightPairM_, + sequence_right, + sequence_right_, + + -- * Loops + -- $LOOPS + for, + endfor, + foreach, + + -- * Operations for monads + mmap, + monad_join1, + + -- * Operations for disjoint unions + map_either, + map_eitherM, + + -- * Operations for tuples + map_pair, + map_pairM, + + -- * Arithmetic operations + int_ceiling, + + -- * Bit vectors + Boollist(..), + boollist_of_int_bh, + boollist_of_int_lh, + int_of_boollist_unsigned_bh, + int_of_boollist_signed_bh, + bool_xor, + boollist_xor, + + -- * Formatting of lists and strings + string_of_list, + optional, + + -- * Lists optimized for fast concatenation + BList, + blist_of_list, + list_of_blist, + (+++), + blist_empty, + blist_concat, + + -- * Strings optimized for fast concatenation + Strbuf, + strbuf_of_string, + string_of_strbuf, + strbuf_empty, + strbuf_concat, + + -- * The identity monad + Id(..), + + -- * Identity types + Identity, + reflexivity, + symmetry, + transitivity, + identity, + + -- * Error messages + ErrMsg, + + -- * The Curry type class + Curry (..) + ) where + +-- import other stuff +import Data.List (foldl') + +import Data.Set (Set) +import qualified Data.Set as Set + +import Data.Map (Map) +import qualified Data.Map as Map + +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet + +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap + +import qualified Data.Traversable as Traversable + +import Control.Applicative (Applicative(..)) +import Control.Monad (liftM, ap) + +-- ---------------------------------------------------------------------- +-- * List operations + +-- | Apply a function to a specified position in a list. +applyAt :: Int -> (a -> a) -> [a] -> [a] +applyAt _ _ [] = [] +applyAt 0 f (x:xs) = (f x):xs +applyAt n f (x:xs) = x:(applyAt (n-1) f xs) + +-- | Overwrite an element at a specified position in a list. +overwriteAt :: Int -> a -> [a] -> [a] +overwriteAt n a = applyAt n (const a) + +-- | Check whether a list has duplicates. +has_duplicates :: Ord a => [a] -> Bool +has_duplicates list = aux list (Set.empty) where + aux [] _ = False + aux (h:t) set = if Set.member h set then True else aux t (Set.insert h set) + +-- | @'substitute' string character replacement@: +-- Replace the first occurrence of /character/ in /string/ by /replacement/. +substitute :: (Eq a) => [a] -> a -> [a] -> [a] +substitute string character replacement = + case break (== character) string of + (x, []) -> x + (x, h:y) -> x ++ replacement ++ y + +-- ---------------------------------------------------------------------- +-- * Set related operations + +-- | Insert the elements of a list in an 'IntSet' (cf. 'IntSet.insert'). +intset_inserts :: [Int] -> IntSet -> IntSet +intset_inserts list set = + foldl' (\t x -> IntSet.insert x t) set list + + +-- ---------------------------------------------------------------------- +-- * Map related operations + +-- | Insert the given key-value pair in a 'Map', but only if the given +-- key is not already present. If the key is present, keep the old +-- value. +map_provide :: Ord k => k -> a -> Map k a -> Map k a +map_provide = Map.insertWith (\x y -> y) + +-- | Take two 'IntMap's /m/[sub 1] and /m/[sub 2], and form a new +-- 'IntMap' whose domain is that of /m/[sub 2], and whose value at /k/ +-- is the pair (/m/[sub 1] ! /k/, /m/[sub 2] ! /k/). It is an error if +-- the domain of /m/[sub 2] is not a subset of the domain of /m/[sub 1]. +intmap_zipright :: IntMap x -> IntMap y -> IntMap (x, y) +intmap_zipright m1 m2 = m where + m = IntMap.mapWithKey f m2 + f k y = case IntMap.lookup k m1 of + Just x -> (x, y) + Nothing -> error "intmap_zipright: shape mismatch" + +-- | Take two 'IntMap's with the same domain, and form a new 'IntMap' +-- whose values are pairs. It is an error if the two inputs don't have +-- identical domains. +intmap_zip :: IntMap x -> IntMap y -> IntMap (x, y) +intmap_zip m1 m2 = intmap_zip_errmsg m1 m2 "intmap_zip: shape mismatch" + +-- | Like 'intmap_zip', but also takes an error message to use in case of +-- domain mismatch. +intmap_zip_errmsg :: IntMap x -> IntMap y -> String -> IntMap (x, y) +intmap_zip_errmsg m1 m2 errmsg = + if all (\k -> IntMap.member k m2) (IntMap.keys m1) + then intmap_zipright m1 m2 + else error errmsg + +-- | Map a function over all values in an 'IntMap'. +intmap_map :: (x -> y) -> IntMap x -> IntMap y +intmap_map = IntMap.map + +-- | Monadic version of 'intmap_map'. Map a function over all values +-- in an 'IntMap'. +intmap_mapM :: (Monad m) => (x -> m y) -> IntMap x -> m (IntMap y) +intmap_mapM = Traversable.mapM + +-- ---------------------------------------------------------------------- +-- * XIntMaps. + +-- | A 'XIntMap' is just like an 'IntMap', except that it supports +-- some additional efficient operations: to find the smallest unused +-- key, to find the set of all keys ever used in the past, and to +-- reserve a set of keys so that they will not be allocated. Moreover, +-- it keeps track of the highest key ever used (whether or not it is +-- still used in the current map). + +-- This is implemented as a tuple (/m/, /n/, /free/, /h/), where /m/ is an +-- 'IntMap', /n/ is an integer such that dom /m/ ⊆ [0../n/-1], /free/ +-- ⊆ [0../n/-1] \\ dom /m/ is a set of integers not currently reserved +-- or used, and /h/ is the set of all integers used in the past (the +-- set of /touched/ wires). + +data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet + +instance (Show a) => Show (XIntMap a) where + show = show . xintmap_to_intmap + +-- | Delete a key from the 'XIntMap'. +xintmap_delete :: Int -> XIntMap a -> XIntMap a +xintmap_delete k (XIntMap m n free h) = (XIntMap m' n free' h) where + m' = IntMap.delete k m + free' = IntSet.insert k free + +-- | Delete a list of keys from a 'XIntMap'. +xintmap_deletes :: [Int] -> XIntMap a -> XIntMap a +xintmap_deletes list map = + foldl' (\map k -> xintmap_delete k map) map list + +-- | Insert a new key-value pair in the 'XIntMap'. +xintmap_insert :: Int -> a -> XIntMap a -> XIntMap a +xintmap_insert k v (XIntMap m n free h) = (XIntMap m' n' free' h') where + m' = IntMap.insert k v m + h' = IntSet.insert k h + n' = max n (k+1) + free' = IntSet.delete k (intset_inserts [n..n'-1] free) + +-- | Insert a list of key-value pairs in the 'XIntMap'. +xintmap_inserts :: [(Int,a)] -> XIntMap a -> XIntMap a +xintmap_inserts list map = + foldl' (\map (k,v) -> xintmap_insert k v map) map list + +-- | Look up the value at a key in the 'XIntMap'. Return 'Nothing' if +-- not found. +xintmap_lookup :: Int -> XIntMap a -> Maybe a +xintmap_lookup k (XIntMap m n free h) = + IntMap.lookup k m + +-- | Check whether the given key is in the 'XIntMap'. +xintmap_member :: Int -> XIntMap a -> Bool +xintmap_member k (XIntMap m n free h) = + IntMap.member k m + +-- | The empty 'XIntMap'. +xintmap_empty :: XIntMap a +xintmap_empty = (XIntMap m n free h) where + m = IntMap.empty + n = 0 + free = IntSet.empty + h = IntSet.empty + +-- | Return the first free key in the 'XIntMap', but without actually +-- using it yet. +xintmap_freshkey :: XIntMap a -> Int +xintmap_freshkey (XIntMap m n free h) = + if IntSet.null free then n else IntSet.findMin free + +-- | Return the next /k/ unused keys in the 'XIntMap', but without +-- actually using them yet. +xintmap_freshkeys :: Int -> XIntMap a -> [Int] +xintmap_freshkeys k (XIntMap m n free h) = ks1 ++ ks2 where + ks1 = take k (IntSet.elems free) + delta = k - (length ks1) + ks2 = [n .. n+delta-1] + +-- | Convert a 'XIntMap' to an 'IntMap'. +xintmap_to_intmap :: XIntMap a -> IntMap a +xintmap_to_intmap (XIntMap m n free h) = m + +-- | Return the smallest key never used in the 'XIntMap'. +xintmap_size :: XIntMap a -> Int +xintmap_size (XIntMap m n free k) = n + +-- | Return the set of all keys ever used in the 'XIntMap'. +xintmap_touched :: XIntMap a -> IntSet +xintmap_touched (XIntMap m n free h) = h + +-- | A wire is /dirty/ if it is touched but currently free. +xintmap_dirty :: XIntMap a -> IntSet +xintmap_dirty (XIntMap m n free h) = h `IntSet.intersection` free + +-- | Reserve a key in the 'XIntMap'. If the key is not free, do +-- nothing. The key must have been used before; for example, this is +-- the case if it was returned by 'xintmap_dirty'. +xintmap_reserve :: Int -> XIntMap a -> XIntMap a +xintmap_reserve k (XIntMap m n free h) = (XIntMap m n free' h) where + free' = IntSet.delete k free + +-- | Reserve a set of keys in the 'XIntMap'. For any keys that are not +-- free, do nothing. All keys must have been used before; for example, +-- this is the case if they were returned by 'xintmap_dirty'. +xintmap_reserves :: IntSet -> XIntMap a -> XIntMap a +xintmap_reserves ks (XIntMap m n free h) = (XIntMap m n free' h) where + free' = free `IntSet.difference` ks + +-- | Unreserve a key in the 'XIntMap'. If the key is currently used, +-- do nothing. The key must have been reserved before, and (therefore) +-- must have been used before. +xintmap_unreserve :: Int -> XIntMap a -> XIntMap a +xintmap_unreserve k (XIntMap m n free h) + | IntMap.member k m = (XIntMap m n free h) + | otherwise = (XIntMap m n free' h) + where + free' = IntSet.insert k free + +-- | Unreserve a list of keys in the 'XIntMap'. If any key is +-- currently used, do nothing. All keys must have been reserved +-- before, and (therefore) must have been used before. +xintmap_unreserves :: IntSet -> XIntMap a -> XIntMap a +xintmap_unreserves ks map = + IntSet.fold (\k map -> xintmap_unreserve k map) map ks + +-- | Make an exact copy of the 'XIntMap', except that the set of +-- touched wires is initially set to the set of used wires. In other +-- words, we mark all free and reserved wires as untouched. +xintmap_makeclean :: XIntMap a -> XIntMap a +xintmap_makeclean (XIntMap m n free h) = (XIntMap m n free h') where + h' = IntMap.keysSet m + +-- ---------------------------------------------------------------------- +-- * Map- and fold-like list combinators + +-- ** Combinators for looping + +-- | Like 'loop', but also pass a loop counter to the function being +-- iterated. Example: +-- +-- > loop_with_index 3 x f = f 2 (f 1 (f 0 x)) +loop_with_index :: (Eq int, Num int) => int -> t -> (int -> t -> t) -> t +loop_with_index n x f = aux 0 x + where + aux i x = if i == n then x else aux (i+1) (f i x) + +-- | Monadic version of 'loop_with_index'. Thus, +-- +-- > loop_with_indexM 3 x0 f +-- +-- will do the following: +-- +-- > do +-- > x1 <- f 0 x0 +-- > x2 <- f 1 x1 +-- > x3 <- f 2 x2 +-- > return x3 +loop_with_indexM :: (Eq int, Num int, Monad m) => int -> t -> (int -> t -> m t) -> m t +loop_with_indexM n x f = aux 0 x + where + aux i x = + if i == n then return x else do + x <- f i x + aux (i+1) x + +-- | Iterate a function /n/ times. Example: +-- +-- > loop 3 x f = f (f (f x)) +loop :: (Eq int, Num int) => int -> t -> (t -> t) -> t +loop n x f = loop_with_index n x (\_ -> f) + +-- | Monadic version of 'loop'. +loopM :: (Eq int, Num int, Monad m) => int -> t -> (t -> m t) -> m t +loopM n x f = loop_with_indexM n x (\_ -> f) + +-- ** Combinators for sequencing + +-- | A right-to-left version of 'sequence': Evaluate each action in the +-- sequence from right to left, and collect the results. +sequence_right :: Monad m => [m a] -> m [a] +sequence_right [] = return [] +sequence_right (x:xs) = do + ys <- sequence_right xs + y <- x + return (y:ys) + +-- | Same as 'sequence_right', but ignore the result. +sequence_right_ :: Monad m => [m a] -> m () +sequence_right_ [] = return () +sequence_right_ (x:xs) = do + ys <- sequence_right_ xs + y <- x + return () + +-- ** Combinators for zipping + +-- | A \"strict\" version of 'zip', i.e., raises an error when the +-- lists are not of the same length. +zip_strict :: [a] -> [b] -> [(a, b)] +zip_strict a b = zip_strict_errmsg a b "zip_strict: lists are not of the same length" + +-- | Like 'zip_strict', but also takes an explicit error message to +-- use in case of failure. +zip_strict_errmsg :: [a] -> [b] -> String -> [(a, b)] +zip_strict_errmsg [] [] e = [] +zip_strict_errmsg (h:t) (h':t') e = (h,h') : zip_strict_errmsg t t' e +zip_strict_errmsg _ _ e = error e + +-- | A \"right strict\" version of 'zip', i.e., raises an error when the +-- left list is shorter than the right one. +zip_rightstrict :: [a] -> [b] -> [(a, b)] +zip_rightstrict a b = zip_rightstrict_errmsg a b "zip_rightstrict: list too short" + +-- | A version of 'zip_rightstrict' that also takes an explicit error +-- message to use in case of failure. +zip_rightstrict_errmsg :: [a] -> [b] -> String -> [(a, b)] +zip_rightstrict_errmsg _ [] s = [] +zip_rightstrict_errmsg (h:t) (h':t') s = (h,h') : zip_rightstrict_errmsg t t' s +zip_rightstrict_errmsg _ _ s = error s + +-- | A \"strict\" version of 'zipWith', i.e., raises an error when the +-- lists are not of the same length. +zipWith_strict :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWith_strict f [] [] = [] +zipWith_strict f (h:t) (h':t') = f h h' : zipWith_strict f t t' +zipWith_strict f _ _ = error "zipWith_strict: lists are not of the same length" + +-- | A \"right strict\" version of 'zipWith', i.e., raises an error when the +-- right list is shorter than the left one. +zipWith_rightstrict :: (a -> b -> c) -> [a] -> [b] -> [c] +zipWith_rightstrict f _ [] = [] +zipWith_rightstrict f (h:t) (h':t') = f h h' : zipWith_rightstrict f t t' +zipWith_rightstrict f _ _ = error "zipWith_rightstrict: list too short" + +-- | A right-to-left version of 'zipWithM', which is also \"right +-- strict\", i.e., raises an error when the right list is shorter than +-- the left one. Example: +-- +-- > zipRightWithM f [a,b] [x,y] = [f a x, f b y], +-- +-- computed right-to-left. +zipRightWithRightStrictM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipRightWithRightStrictM f l1 l2 = + sequence_right $ zipWith_rightstrict f l1 l2 + +-- | Same as 'zipRightWithM', but ignore the result. +zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipRightWithRightStrictM_ f l1 l2 = + sequence_right_ $ zipWith_rightstrict f l1 l2 + +-- ** Combinators combining mapping with folding + +-- | Fold over two lists with state, and do it right-to-left. For example, +-- +-- > foldRightPairM (w0, [1,2,3], [a,b,c]) f +-- +-- will do the following: +-- +-- > do +-- > w1 <- f (w0, 3, c) +-- > w2 <- f (w1, 2, b) +-- > w3 <- f (w2, 1, a) +-- > return w3 +foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w +foldRightPairM (w, [], _) f = return w +foldRightPairM (w, _, []) f = return w +foldRightPairM (w, a:as, b:bs) f = do + w <- foldRightPairM (w, as, bs) f + w <- f (w, a, b) + return w + +-- | Like 'foldRightPairM', but ignore the final result. +foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m () +foldRightPairM_ x f = do + foldRightPairM x f + return () + +-- | Combine right-to-left zipping and folding. Example: +-- +-- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c']) +-- > where f (w0,c,z) = (w1,c') +-- > f (w1,b,y) = (w2,b') +-- > f (w2,a,x) = (w3,a') +fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c]) +fold_right_zip f (w, [], []) = (w, []) +fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb') + where + (w1, bb') = fold_right_zip f (w, bb, yy) + (w2, a') = f (w1, a, x) +fold_right_zip f _ = error "fold_right_zip" + +-- | Monadic version of 'fold_right_zip'. +fold_right_zipM :: + (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c]) +fold_right_zipM f (w, [], []) = return (w, []) +fold_right_zipM f (w, a:bb, x:yy) = do + (w1, bb') <- fold_right_zipM f (w, bb, yy) + (w2, a') <- f (w1, a, x) + return (w2, a':bb') +fold_right_zipM f _ = error "fold_right_zipM" + +-- ---------------------------------------------------------------------- +-- * Loops. + +-- $LOOPS We provide a syntax for \"for\"-style loops. + +-- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/. +-- +-- Standard notation: +-- +-- > for i = a to b by s do +-- > commands +-- > end for +-- +-- Our notation: +-- +-- > for a b s $ \i -> do +-- > commands +-- > endfor + +for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m() +for a b s f = if s > 0 then aux a (<= b) else aux a (>= b) + where + aux i cond = + if cond i then do + f i + aux (i+s) cond + else + return () + +-- | Mark the end of a \"for\"-loop. This command actually does +-- nothing, but can be used to make the loop look prettier. +endfor :: Monad m => m() +endfor = return () + +-- | Iterate a parameter over a list of values. It can be used as +-- follows: +-- +-- > foreach [1,2,3,4] $ \n -> do +-- > <<>> +-- > endfor +-- +-- The loop body will get executed once for each /n/ ∈ {1,2,3,4}. + +foreach :: Monad m => [a] -> (a -> m b) -> m () +foreach l f = mapM_ f l + +-- ---------------------------------------------------------------------- +-- * Operations for monads + +-- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output +-- /m/ /f/ : /m/ /a/ → /m/ /b/. +mmap :: (Monad m) => (a -> b) -> m a -> m b +mmap f a = a >>= (return . f) + +-- | Remove an outer application of a monad from a monadic function. +monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b +monad_join1 mf a = do + f <- mf + f a + +-- ---------------------------------------------------------------------- +-- * Operations for disjoint unions + +-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return +-- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/. +map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d +map_either f g (Left x) = Left (f x) +map_either f g (Right x) = Right (g x) + +-- | Monadic version of 'map_either'. +map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) +map_eitherM f g (Left x) = mmap Left (f x) +map_eitherM f g (Right x) = mmap Right (g x) + +-- ---------------------------------------------------------------------- +-- * Operations for tuples + +-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return +-- /f/ × /g/ : /a/ × /c/ → /c/ × /d/. +map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) +map_pair f g (x, y) = (f x, g y) + +-- | Monadic version of 'mappair'. +map_pairM :: (Monad m) => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d) +map_pairM f g (a, c) = do + b <- f a + d <- g c + return (b, d) + +-- ---------------------------------------------------------------------- +-- * Arithmetic operations + +-- | A version of the 'ceiling' function that returns an 'Integer'. +int_ceiling :: RealFrac a => a -> Integer +int_ceiling = toInteger . ceiling + +-- ---------------------------------------------------------------------- +-- * Bit vectors + +-- | The type of bit vectors. True = 1, False = 0. +type Boollist = [Bool] + +-- | Convert an integer to a bit vector. The first argument is the +-- length in bits, and the second argument the integer to be +-- converted. The conversion is big-headian (or equivalently, +-- little-tailian), i.e., the head of the list holds the integer's most +-- significant digit. +boollist_of_int_bh :: Integral a => Int -> a -> Boollist +boollist_of_int_bh m = reverse . boollist_of_int_lh m + +-- | Convert an integer to a bit vector. The first argument is the +-- length in bits, and the second argument the integer to be +-- converted. The conversion is little-headian (or equivalently, +-- big-tailian), i.e., the head of the list holds the integer's least +-- significant digit. +boollist_of_int_lh :: Integral a => Int -> a -> Boollist +boollist_of_int_lh m x | m <= 0 = [] +boollist_of_int_lh m x = digit : boollist_of_int_lh (m-1) tail where + digit = (x `mod` 2 == 1) + tail = x `div` 2 + +-- | Convert a bit vector to an integer. The conversion is big-headian +-- (or equivalently, little-tailian), i.e., the head of the list holds +-- the integer's most significant digit. This function is unsigned, +-- i.e., the integer returned is ≥ 0. +int_of_boollist_unsigned_bh :: Integral a => Boollist -> a +int_of_boollist_unsigned_bh v = aux v 0 + where + aux v acc = + case v of + [] -> acc + digit : vs -> aux vs (2*acc+(if digit then 1 else 0)) + +-- | Convert a bit vector to an integer, signed. +int_of_boollist_signed_bh :: Integral a => Boollist -> a +int_of_boollist_signed_bh [] = 0 +int_of_boollist_signed_bh (False:v) = int_of_boollist_unsigned_bh v +int_of_boollist_signed_bh (True:v) = -1 - int_of_boollist_unsigned_bh (map not v) + +-- | Exclusive or operation on booleans. +bool_xor :: Bool -> Bool -> Bool +bool_xor a b = (a /= b) + +-- | Exclusive or operation on bit vectors. +boollist_xor :: Boollist -> Boollist -> Boollist +boollist_xor = zipWith bool_xor + +-- ---------------------------------------------------------------------- +-- * Formatting of lists and strings + +-- | A general list-to-string function. Example: +-- +-- > string_of_list "{" ", " "}" "{}" show [1,2,3] = "{1, 2, 3}" +string_of_list :: String -> String -> String -> String -> (t -> String) -> [t] -> String +string_of_list lpar comma rpar nil string_of_elt lst = + let string_of_tail lst = + case lst of + [] -> "" + h:t -> comma ++ string_of_elt h ++ string_of_tail t + in + case lst of + [] -> nil + h:t -> lpar ++ string_of_elt h ++ string_of_tail t ++ rpar + +-- | @'optional' b s@: if /b/ = 'True', return /s/, else the empty +-- string. This function is for convenience. +optional :: Bool -> String -> String +optional True s = s +optional False s = "" + +-- ---------------------------------------------------------------------- +-- * Lists optimized for fast concatenation + +-- | The type of bidirectional lists. This is similar to [a], but +-- optimized for fast concatenation and appending on both sides. +newtype BList a = BList { getBList :: [a] -> [a] } + +-- | Convert a List to a 'BList'. +blist_of_list :: [a] -> BList a +blist_of_list s = BList (\x -> s ++ x) + +-- | Convert a 'BList' to a List. +list_of_blist :: BList a -> [a] +list_of_blist buf = getBList buf [] + +-- | Fast concatenation of 'BList's or string buffers. +(+++) :: BList a -> BList a -> BList a +(+++) buf1 buf2 = BList ((getBList buf1) . (getBList buf2)) + +-- | The empty 'BList'. +blist_empty :: BList a +blist_empty = BList id + +-- | Concatenate a list of 'Blist's. +blist_concat :: [BList a] -> BList a +blist_concat l = foldr (+++) blist_empty l + +instance (Show a) => Show (BList a) where + show bl = show (list_of_blist bl) + +-- ---------------------------------------------------------------------- +-- * Strings optimized for fast concatenation + +-- | A string buffer holds a string that is optimized for fast +-- concatenation. Note that this is an instance of 'BList', and hence +-- 'BList' operations (in particular '+++') can be applied to string +-- buffers. The following functions are synonyms of the respective +-- 'BList' functions, and are provided for convenience. +type Strbuf = BList Char + +-- | Convert a string to a string buffer. +strbuf_of_string :: String -> Strbuf +strbuf_of_string = blist_of_list + +-- | Convert a string buffer to a string. +string_of_strbuf :: Strbuf -> String +string_of_strbuf = list_of_blist + +-- | The empty string buffer. +strbuf_empty :: Strbuf +strbuf_empty = blist_empty + +-- | Concatenate a list of string buffers. +strbuf_concat :: [Strbuf] -> Strbuf +strbuf_concat = blist_concat + +-- ---------------------------------------------------------------------- +-- * The identity monad + +-- | The identity monad. Using /m/ = 'Id' gives useful special cases +-- of monadic functions. +newtype Id a = Id { getId :: a } + +instance Monad Id where + return a = Id a + (Id a) >>= b = b a + +instance Applicative Id where + pure = return + (<*>) = ap + +instance Functor Id where + fmap = liftM + +-- ---------------------------------------------------------------------- +-- * Identity types + +-- | The type 'Identity' /a/ /b/ witnesses the fact that /a/ and /b/ +-- are the same type. In other words, this type is non-empty if and +-- only if /a/ = /b/. This property is not guaranteed by the type +-- system, but by the API, via the fact that the operators +-- 'relexivity', 'symmetry', and 'transitivity' are the only exposed +-- constructors for this type. The implementation of this type is +-- deliberately hidden, as this is the only way to guarantee its +-- defining property. +-- +-- Identity types are useful in certain situations. For example, they +-- can be used to define a data type which is polymorphic in some type +-- variable /x/, and which has certain constructors that are only +-- available when /x/ is a particular type. For example, in the +-- declaration +-- +-- > data ExampleType x = Constructor1 x | Constructor2 x (Identity x Bool), +-- +-- @Constructor1@ is available for all /x/, but @Constructor2@ is only +-- available when /x/ = 'Bool'. +newtype Identity a b = Identity (a -> b, b -> a) + +-- | Witness the fact that /a/=/a/. +reflexivity :: Identity a a +reflexivity = Identity (id, id) + +-- | Witness the fact that /a/=/b/ implies /b/=/a/. +symmetry :: Identity a b -> Identity b a +symmetry (Identity (f,g)) = Identity (g,f) + +-- | Witness the fact that /a/=/b/ and /b/=/c/ implies /a/=/c/. +transitivity :: Identity a b -> Identity b c -> Identity a c +transitivity (Identity (f,g)) (Identity (f',g')) = Identity (f'',g'') where + f'' = f' . f + g'' = g . g' + +-- | The identity function 'id' : /a/ → /b/, provided that /a/ and /b/ +-- are the same type. +identity :: Identity a b -> a -> b +identity (Identity (f,g)) = f + +instance Show (Identity a b) where + show x = "id" + +-- ---------------------------------------------------------------------- +-- * Isomorphism types + +-- | The type 'Isomorphism' /a/ /b/ consists of isomorphisms between +-- /a/ and /b/, i.e. pairs (/f/,/g/) such that /g/./f/ == id :: /a/ -> /a/, +-- /f/./g/ == id :: /b/ -> /b/. +-- +-- As with e.g. Haskell’s 'Monad' class, it is not possible in general +-- to guarantee that the intended laws hold; it is the programmer’s +-- responsibility to ensure this. +-- +-- Under the hood, 'Isomorphism' and 'Identity' are in fact the same; +-- they differ just in the API exposed. +newtype Isomorphism a b = Isomorphism (a -> b, b -> a) + +-- | Map forwards along an isomorphism. +iso_forwards :: Isomorphism a b -> a -> b +iso_forwards (Isomorphism (f,g)) = f + +-- | Map backwards along an isomorphism. +iso_backwards :: Isomorphism a b -> b -> a +iso_backwards (Isomorphism (f,g)) = g + +-- ====================================================================== +-- * Error messages + +-- | Often a low-level function, such as 'qcdata_zip' and +-- 'qcdata_promote', throws an error because of a failure of some +-- low-level condition, such as \"list too short\". To produce error +-- messages that are meaningful to user-level code, these functions do +-- not have a hard-coded error message. Instead, they input a stub +-- error message. +-- +-- A meaningful error message typically consists of at least three parts: +-- +-- * the name of the user-level function where the error occurred, for +-- example: \"reverse_generic\"; +-- +-- * what the function was doing when the error occurred, for example: +-- \"operation not permitted in reversible circuit\"; +-- +-- * a specific low-level reason for the error, for example: \"dynamic +-- lifting\". +-- +-- Thus, a meaningful error message may be: \"reverse_generic: +-- operation not permitted in reversible circuit: dynamic lifting\". +-- +-- The problem is that the three pieces of information are not usually +-- present in the same place. The user-level function is often a +-- wrapper function that performs several different mid-level +-- operations (e.g., transforming, reversing). The mid-level function +-- knows what operation was being performed when the error occurred, +-- but often calls a lower-level function to do the actual work (e.g., +-- encapsulating). +-- +-- Therefore, a stub error message is a function that inputs some +-- lower-level reason for a failure (example: \"list too short\") and +-- translates this into a higher-level error message (example: +-- \"qterm: shape of parameter does not data: list too short\"). +-- +-- Sometimes, the stub error message may also ignore the low-level +-- message and completely replace it by a higher-level one. For +-- example, a function that implements integers as bit lists may wish +-- to report a problem with integers, rather than a problem with the +-- underlying lists. +type ErrMsg = String -> String + +-- ====================================================================== +-- * The Curry type class + +-- | The 'Curry' type class is used to implement functions that have a +-- variable number of arguments. It provides a family of type +-- isomorphisms +-- +-- @fun ≅ args -> res,@ +-- +-- where +-- +-- > fun = a1 -> a2 -> ... -> an -> res, +-- > args = (a1, (a2, (..., (an, ())))). + +class Curry fun args res | args res -> fun where + -- | Multiple curry: map a function + -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ + -- to its curried form + -- /a/[sub 1] → /a/[sub 2] → … → /b/. + mcurry :: (args -> res) -> fun + -- | Multiple uncurry: map a function + -- /a/[sub 1] → /a/[sub 2] → … → /b/ + -- to its uncurried form + -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/. + muncurry :: fun -> (args -> res) + +instance Curry b () b where + mcurry g = g () + muncurry x = const x + +instance Curry fun args res => Curry (a -> fun) (a,args) res where + mcurry g x = mcurry (\xs -> g (x,xs)) + muncurry f (x,xs) = muncurry (f x) xs + diff --git a/src/Libraries/CommandLine.hs b/src/Libraries/CommandLine.hs new file mode 100644 --- /dev/null +++ b/src/Libraries/CommandLine.hs @@ -0,0 +1,72 @@ +-- This file is part of Quipper. Copyright (C) 2011-2016. Please see the +-- file COPYRIGHT for a list of authors, copyright holders, licensing, +-- and other details. All rights reserved. +-- +-- ====================================================================== + +-- | This module provides some functions that are useful in the +-- processing of command line options, and that are shared between +-- several algorithms. + +module Libraries.CommandLine where + +import Libraries.Auxiliary (string_of_list) + +-- import other stuff +import System.Exit +import System.IO +import Data.List +import Data.Char + +-- ---------------------------------------------------------------------- +-- * Option processing + +-- | Exit with an error message after a command line error. This also +-- outputs information on where to find command line help. +optfail :: String -> IO a +optfail msg = do + hPutStr stderr msg + hPutStrLn stderr "Try --help for more info." + exitFailure + +-- | Parse a string to an integer, or return 'Nothing' on failure. +parse_int :: (Integral r) => String -> Maybe r +parse_int s = case reads s of + [(n, "")] -> Just (fromInteger n) + _ -> Nothing + +-- | Parse a string to a list of integers, or return 'Nothing' on failure. +parse_list_int :: String -> Maybe [Int] +parse_list_int s = case reads s of + [(ns, "")] -> Just ns + _ -> Nothing + +-- | Parse a string to a 'Double', or return 'Nothing' on failure. +parse_double :: String -> Maybe Double +parse_double s = case reads s of + [(n, "")] -> Just n + _ -> Nothing + +-- | In an association list, find the key that best matches the given +-- string. If one key matches exactly, return the corresponding +-- key-value pair. Otherwise, return a list of all key-value pairs +-- whose key have the given string as a prefix. This list could be of +-- length 0 (no match), 1 (unique match), or greater (ambiguous key). +-- Note: the keys in the association list must be lower case. The +-- input string is converted to lower case as well, resulting in +-- case-insensitive matching. +match_enum :: [(String, a)] -> String -> [(String, a)] +match_enum list key = + case lookup s list of + Just v -> [(s,v)] + Nothing -> filter (\(k,v) -> isPrefixOf s k) list + where + s = map toLower key + +-- | Pretty-print a list of possible values for a parameter. The +-- first argument is the name of the parameter, and the second +-- argument is its enumeration. +show_enum :: String -> [(String, a)] -> String +show_enum param list = + "Possible values for " ++ param ++ " are: " ++ + string_of_list "" ", " "" "no possible values" fst list ++ ".\n" diff --git a/src/Libraries/PortableSignals.hs b/src/Libraries/PortableSignals.hs new file mode 100644 --- /dev/null +++ b/src/Libraries/PortableSignals.hs @@ -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 diff --git a/src/Quipper/Printing.hs b/src/Quipper/Printing.hs new file mode 100644 --- /dev/null +++ b/src/Quipper/Printing.hs @@ -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