{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE ScopedTypeVariables  #-}

-- | This module provides a high-level circuit building interface
-- intended to look \"functional\". At a given time, there is a
-- circuit being assembled. This circuit has free endpoints (on the
-- left and right) that can be bound to variables. A qubit or bit is
-- simply an endpoint in such a circuit. \"Applying\" an operation to
-- a qubit or bit simply appends the operation to the current
-- circuit. We use the 'Circ' monad to capture the side effect of
-- assembling a circuit.

module Quipper.Monad (
  -- * The ReadWrite monad
  ReadWrite(..),
  
  -- * The Circ monad  
  Circ,

  -- * Some types
  Qubit,
  Bit,
  Endpoint,
  Signed(..), -- re-exported from Quipper.Circuit
  Ctrl,
  Qulist,
  Bitlist,
  Timestep,   -- re-exported from Quipper.Circuit
  InverseFlag, -- re-exported from Quipper.Circuit
  
  -- * Conversions for wires, qubits, bits, endpoints
  wire_of_qubit,
  wire_of_bit,
  wire_of_endpoint,  
  wires_with_arity_of_endpoints,
  qubit_of_wire,
  bit_of_wire,
  endpoint_of_wire,
  endpoints_of_wires_in_arity,

  -- * Bindings for qubits and bits
  bind_qubit,
  bind_bit,
  unbind_qubit,
  unbind_bit,
  
  -- * Controls for qubits and bits
  clist_add_qubit,
  clist_add_bit,
  
  -- * Namespace management  
  provide_simple_subroutine,
  provide_subroutine,
  provide_subroutines,
  call_subroutine,
  get_namespace,
  set_namespace,

  put_subroutine_definition,
  
  -- * Basic gates
  -- ** Gates in functional style
  qnot,
  hadamard,
  gate_H,
  gate_X,
  gate_Y,
  gate_Z,
  gate_S,  
  gate_S_inv,
  gate_T,
  gate_T_inv,
  gate_E,
  gate_E_inv,
  gate_omega,
  gate_V,
  gate_V_inv,
  swap_qubit,
  expZt,
  rGate,
  gate_W,
  gate_iX,
  gate_iX_inv,
  global_phase,
  global_phase_anchored_list,
  qmultinot_list,
  cmultinot_list,
  named_gate_qulist,
  named_rotation_qulist,
  cnot,
  swap_bit,
  -- ** Gates in imperative style
  qnot_at,
  hadamard_at,
  gate_H_at,
  gate_X_at,
  gate_Y_at,
  gate_Z_at,
  gate_S_at,
  gate_S_inv_at,
  gate_T_at,
  gate_T_inv_at,
  gate_E_at,
  gate_E_inv_at,
  gate_omega_at,
  gate_V_at,
  gate_V_inv_at,
  swap_qubit_at,
  expZt_at,
  rGate_at,
  gate_W_at,
  gate_iX_at,
  gate_iX_inv_at,
  qmultinot_list_at,
  cmultinot_list_at,
  named_gate_qulist_at,
  named_rotation_qulist_at,
  cnot_at,
  swap_bit_at,
  -- ** Bitwise initialization and termination functions
  qinit_qubit,
  qterm_qubit,
  qdiscard_qubit,
  prepare_qubit,
  unprepare_qubit,
  measure_qubit,
  cinit_bit,
  cterm_bit,
  cdiscard_bit,
  dterm_bit,
  
  -- ** Classical gates
  -- $CLASSICAL
  cgate_xor,
  cgate_eq,
  cgate_if_bit,
  cgate_not,
  cgate_and,
  cgate_or,
  cgate,
  cgateinv,
  
  -- ** Subroutines
  subroutine,
  
  -- ** Comments
  comment_label,
  without_comments,
  
  -- ** Dynamic lifting
  dynamic_lift_bit,
  
  -- * Other circuit-building functions
  qinit_plusminus,
  qinit_of_char,
  qinit_of_string,
  qinit_list,
  qterm_list,
  cinit_list,
  
  -- * Higher-order functions
  with_ancilla,
  with_controls,
  controlled,
  without_controls,
  without_controls_if,
  
  -- ** Deprecated special cases
  qinit_qubit_ancilla,
  qterm_qubit_ancilla,
  
  -- * Circuit transformers
  identity_transformer,
  identity_dynamic_transformer,
  apply_circuit_with_bindings,
  apply_bcircuit_with_bindings,
  apply_dbcircuit_with_bindings,
  
  -- * Encapsulated circuits
  extract_simple,
  extract_general,
  extract_in_context,
  extract_in_current_namespace,
  unextract_in_context,
  reverse_encapsulated,
  with_reserve
) where

-- import other Quipper stuff
import Quipper.Circuit
import Libraries.Auxiliary
import Quipper.Transformer
import Quipper.Control

-- import other stuff
import Control.Monad
import Data.Typeable

import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet

-- ======================================================================
-- * The Circ monad

-- ----------------------------------------------------------------------
-- ** States

-- | A flag to indicate whether comments are disabled ('True') or
-- enabled ('False').
type NoCommentFlag = Bool

-- | Holds the state during circuit construction. Currently this has
-- four components: the output arity of the circuit currently being
-- assembled, the current 'Namespace', the currently active
-- 'ControlList' and 'NoControlFlag', and a flag to determine whether
-- comments are disabled. All gates that are appended will have the
-- controls from the 'ControlList' added to them.
data State = State {
  arity :: !ExtArity,
  namespace :: !Namespace,
  clist :: !ControlList,
  ncflag :: !NoControlFlag,
  nocommentflag :: !NoCommentFlag
}

-- | Return a completely empty state, suitable to be the starting
-- state for circuit construction.
empty_state :: State
empty_state = State { 
  arity = arity_empty, 
  namespace = namespace_empty,
  clist = clist_empty,
  ncflag = False,
  nocommentflag = False
  }

-- | Prepare an initial state from the given extended arity.
initial_state :: ExtArity -> State
initial_state arity = empty_state { arity = arity }

-- ----------------------------------------------------------------------
-- ** Definition of Circ

-- $ The 'Circ' monad is a 'ReadWrite' monad, wrapped with an
-- additional state.

-- | The 'Circ' monad encapsulates the type of quantum operations. For
-- example, a quantum operation that inputs two 'Qubit's and outputs a
-- 'Qubit' and a 'Bit' has the following type:
-- 
-- > (Qubit, Qubit) -> Circ (Qubit, Bit)

-- Implementation note: we could have equivalently defined 'Circ'
-- using Haskell's 'StateT' monad transformer, like this:
-- 
-- > Circ = StateT State ReadWrite. 
-- 
-- But it seems clearer, and certainly more self-contained, to write
-- out the monad laws explicitly. Moreover, 'Circ' will probably look
-- better in error messages than 'StateT' 'State' 'ReadWrite'.

newtype Circ a = Circ { getCirc :: State -> ReadWrite (a, State) }

instance Monad Circ where
  return a = Circ (\s -> return (a, s))
  f >>= g = Circ h
    where
      h s0 = do
        (a, s1) <- getCirc f s0
        getCirc (g a) s1

-- every monad is a functor, and so is this one
instance Functor Circ where
  fmap f xs = xs >>= return . f

-- ======================================================================
-- ** Monad access primitives
  
-- $ Developer note: the 5 functions in this section are the /only/
-- operations that are permitted to access the monad internals (i.e.,
-- 'Circ' and 'getCirc') directly.

-- | Get the 'Circ' monad's state.
get_state :: Circ State
get_state = Circ $ \s -> return (s, s)

-- | Set the 'Circ' monad's state.
set_state :: State -> Circ ()
set_state s = Circ $ \t -> return ((), s)

-- | Pass a gate to the 'Circ' monad. Note that this is a low-level
-- monad access function, and does not update other parts of the
-- monad's data. For a higher-level function, see 'apply_gate'.
put_gate :: Gate -> Circ ()
put_gate g = Circ $ \s -> RW_Write g (return ((), s))

-- | Issue a prompt and receive a reply.
do_read :: Wire -> Circ Bool
do_read w = Circ $ \s -> RW_Read w (\bool -> return (bool, s))

-- | Issue a RW_Subroutine primitive
put_subroutine_definition :: BoxId -> TypedSubroutine -> Circ ()
put_subroutine_definition name subroutine = Circ $ \s -> RW_Subroutine name subroutine (return ((), s))

-- | This is the universal \"run\" function for the 'Circ' monad.  It
-- takes as parameters a 'Circ' computation, and an initial state. It
-- outputs 'ReadWrite' computation for the result of the 'Circ'
-- computation and the final state.
run_circ :: Circ a -> State -> ReadWrite (a, State)
run_circ = getCirc

-- ----------------------------------------------------------------------
-- ** Low-level state manipulation
  
-- $ The functions in this section are the /only/ operations that are
-- permitted to operate on states directly (i.e., to use 'get_state'
-- and 'set_state'). All other code in this module should access the
-- state using these abstractions. Code in other modules can't access
-- the state at all, but should use exported functions (and preferably
-- 'QShape.encapsulate_generic') when it is necessary to extract
-- low-level circuits.

-- | Get the 'arity' part of the 'Circ' monad's state.
get_arity :: Circ ExtArity
get_arity = do
  s <- get_state
  return (arity s)

-- | Set the 'arity' part of the 'Circ' monad's state.
set_arity :: ExtArity -> Circ ()
set_arity arity = do
  s <- get_state
  set_state s { arity = arity }
  
-- | Get the 'namespace' part of the 'Circ' monad's state.
get_namespace :: Circ Namespace
get_namespace = do
  s <- get_state
  return (namespace s)
  
-- | Set the 'namespace' part of the 'Circ' monad's state.
set_namespace :: Namespace -> Circ ()
set_namespace namespace = do
  s <- get_state
  set_state s { namespace = namespace }
  
-- | Get the 'clist' part of the 'Circ' monad's state.
get_clist :: Circ ControlList
get_clist = do
  s <- get_state
  return (clist s)
  
-- | Set the 'clist' part of the 'Circ' monad's state.
set_clist :: ControlList -> Circ ()
set_clist clist = do
  s <- get_state
  set_state s { clist = clist }

-- | Get the 'ncflag' part of the 'Circ' monad's state.
get_ncflag :: Circ NoControlFlag
get_ncflag = do
  s <- get_state
  return (ncflag s)
  
-- | Set the 'ncflag' part of the 'Circ' monad's state.
set_ncflag :: NoControlFlag -> Circ ()
set_ncflag ncflag = do
  s <- get_state
  set_state s { ncflag = ncflag }

-- | Get the 'nocommentflag' part of the 'Circ' monad's state.
get_nocommentflag :: Circ NoCommentFlag
get_nocommentflag = do
  s <- get_state
  return (nocommentflag s)
  
-- | Set the 'nocommentflag' part of the 'Circ' monad's state.
set_nocommentflag :: NoCommentFlag -> Circ ()
set_nocommentflag nocommentflag = do
  s <- get_state
  set_state s { nocommentflag = nocommentflag }

-- ----------------------------------------------------------------------
-- ** Circuit extraction

-- | Extract a circuit from a monadic term, starting from the given
-- arity. This is the \"simple\" extract function, which does not
-- allow dynamic lifting. The 'ErrMsg' argument is a stub error message
-- to be used in case an illegal operation is encountered. 
extract_simple :: ErrMsg -> ExtArity -> Circ a -> (BCircuit, a)
extract_simple e arity f = (bcirc, y) where
  comp = extract_general arity f
  (bcirc, y) = bcircuit_of_static_dbcircuit e comp


-- | Run a monadic term in the initial arity, and extract a dynamic
-- boxed circuit.
extract_general :: ExtArity -> Circ a -> DBCircuit a
extract_general arity_in f = (a0, mmap finalize comp) where
  a0 = arity_of_extarity arity_in
  s0 = initial_state arity_in
  comp = run_circ f s0
  finalize (a, s1) = (a1, n, a) where
    arity_out = arity s1
    a1 = arity_of_extarity arity_out
    n = n_of_extarity arity_out    

-- ======================================================================
-- * Some types

-- | The type of qubits.
newtype Qubit = QubitWire Wire
              deriving (Show, Eq, Ord, Typeable)

-- | The type of run-time classical bits (i.e., boolean wires in a
-- circuit).
newtype Bit = BitWire Wire
              deriving (Show, Eq, Ord, Typeable)

-- | An endpoint in a circuit. This is either a 'Qubit' or a 'Bit'.
type Endpoint = B_Endpoint Qubit Bit

-- | A control consists of an 'Endpoint' and a boolean ('True' =
-- perform gate when control wire is 1; 'False' = perform gate when
-- control wire is 0). Note that gates can be controlled by qubits and
-- classical bits.
type Ctrl = Signed Endpoint

-- | Synonym for a qubit list, for convenience.
type Qulist = [Qubit]

-- | Synonym for a bit list, for convenience.
type Bitlist = [Bit]

-- ----------------------------------------------------------------------
-- * Conversions for wires, qubits, bits, endpoints

-- | Extract the underlying low-level wire of a qubit.
wire_of_qubit :: Qubit -> Wire
wire_of_qubit (QubitWire w) = w

-- | Extract the underlying low-level wire of a bit.
wire_of_bit :: Bit -> Wire
wire_of_bit (BitWire w) = w

-- | Construct a qubit from a wire.
qubit_of_wire :: Wire -> Qubit
qubit_of_wire w = QubitWire w

-- | Construct a bit from a wire.
bit_of_wire :: Wire -> Bit
bit_of_wire w = BitWire w

-- | Extract the underlying low-level 'Wire' of an 'Endpoint'.
wire_of_endpoint :: Endpoint -> Wire
wire_of_endpoint (Endpoint_Qubit q) = wire_of_qubit q
wire_of_endpoint (Endpoint_Bit b) = wire_of_bit b

-- | Extract the underlying low-level 'Wiretype' of an 'Endpoint'.
wiretype_of_endpoint :: Endpoint -> Wiretype
wiretype_of_endpoint (Endpoint_Qubit _) = Qbit
wiretype_of_endpoint (Endpoint_Bit _) = Cbit

-- | Break a list of 'Endpoint's down into a list of 'Wire's together with an 'Arity'.  
-- (Partial inverse to 'endpoints_of_wires_in_arity'.)
wires_with_arity_of_endpoints :: [Endpoint] -> ([Wire],Arity)
wires_with_arity_of_endpoints es = 
  let ws_with_ts = map (\e -> (wire_of_endpoint e, wiretype_of_endpoint e)) es
  in (map fst ws_with_ts, IntMap.fromList ws_with_ts)

-- | Create an 'Endpoint' from a low-level 'Wire' and 'Wiretype'.
endpoint_of_wire :: Wire -> Wiretype -> Endpoint
endpoint_of_wire w Qbit = Endpoint_Qubit (qubit_of_wire w)
endpoint_of_wire w Cbit = Endpoint_Bit (bit_of_wire w)

-- | Create a list of 'Endpoint's from a list of 'Wire's together with an 'Arity',
-- assuming all wires are present in the arity.
endpoints_of_wires_in_arity :: Arity -> [Wire] -> [Endpoint]
endpoints_of_wires_in_arity a = map (\w -> endpoint_of_wire w (a IntMap.! w))

-- ----------------------------------------------------------------------
-- * Bindings for qubits and bits

-- | Bind a qubit wire to a value, and add it to the given bindings.
bind_qubit :: Qubit -> a -> Bindings a b -> Bindings a b
bind_qubit q x bindings = bind_qubit_wire (wire_of_qubit q) x bindings

-- | Bind a bit wire to a value, and add it to the given bindings.
bind_bit :: Bit -> b -> Bindings a b -> Bindings a b
bind_bit c x bindings = bind_bit_wire (wire_of_bit c) x bindings

-- | Retrieve the value of a qubit wire from the given bindings.
-- Throws an error if the wire was bound to a classical bit.
unbind_qubit :: Bindings a b -> Qubit -> a
unbind_qubit bindings q = unbind_qubit_wire bindings (wire_of_qubit q)

-- | Retrieve the value of a bit wire from the given bindings.  Throws
-- an error if the wire was bound to a qubit.
unbind_bit :: Bindings a b -> Bit -> b
unbind_bit bindings c = unbind_bit_wire bindings (wire_of_bit c)

-- ----------------------------------------------------------------------
-- * Controls for qubits and bits

-- | Add a single signed qubit as a control to a control list.
clist_add_qubit :: Qubit -> Bool -> ControlList -> ControlList
clist_add_qubit q b cl = clist_add (wire_of_qubit q) b cl

-- | Add a single signed bit as a control to a control list.
clist_add_bit :: Bit -> Bool -> ControlList -> ControlList
clist_add_bit c b cl = clist_add (wire_of_bit c) b cl

instance (ControlSource (Signed a), ControlSource (Signed b)) => ControlSource (Signed (B_Endpoint a b)) where
  to_control (Signed (Endpoint_Qubit q) b) = to_control (Signed q b)
  to_control (Signed (Endpoint_Bit c) b) = to_control (Signed c b)

instance (ControlSource a, ControlSource b) => ControlSource (B_Endpoint a b) where
  to_control (Endpoint_Qubit q) = to_control q
  to_control (Endpoint_Bit c) = to_control c
  
instance ControlSource (Signed Qubit) where
  to_control (Signed q b) = to_control (Signed (wire_of_qubit q) b)
  
instance ControlSource Qubit where  
  to_control q = to_control (Signed q True)
  
instance ControlSource (Signed Bit) where
  to_control (Signed q b) = to_control (Signed (wire_of_bit q) b)
  
instance ControlSource Bit where  
  to_control q = to_control (Signed q True)

-- ======================================================================
-- * Namespace management

-- | @'provideSimpleSubroutine' name circ in_struct out_struct is_classically_controllable@:
-- if /name/ not already bound, binds it to /circ/.
-- Note: when there’s an existing value, does /not/ check that
-- it’s equal to /circ/.  
provide_simple_subroutine :: (Typeable a, Typeable b) => 
  BoxId -> OCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ ()
provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable = do
  s <- get_namespace
  let OCircuit (win, circ, wout) = ocirc
  let c = if controllable_circuit circ then AllCtl else if is_classically_controllable then OnlyClassicalCtl else NoCtl
  let typed_subroutine = TypedSubroutine ocirc input_structure output_structure c
  let s' = map_provide name typed_subroutine s
  set_namespace s'
  put_subroutine_definition name typed_subroutine

-- | @'provideSubroutines' namespace@:
-- Add each subroutine from the /namespace/ to the current circuit,
-- unless a subroutine of that name already exists.
provide_subroutines :: Namespace -> Circ ()
provide_subroutines state = do
  main_state <- get_namespace
  let state1 = Map.union main_state state
  set_namespace state1
  let new_subs = Map.difference state main_state -- returns subroutines that are in state, but not main_state
  mapM_ (\(n,s) -> put_subroutine_definition n s) (Map.toList new_subs) -- puts a RW_Subroutine for each new subroutine definition

-- | @'provideSubroutine' name circ@:
-- if /name/ not already bound, binds it to the main circuit of /circ/,
-- and additionally provides any missing subroutines of /circ/.
provide_subroutine :: (Typeable a, Typeable b) => 
  BoxId -> OBCircuit -> CircuitTypeStructure a -> CircuitTypeStructure b -> Bool -> Circ ()
provide_subroutine name obcirc input_structure output_structure is_classically_controllable = do
  main_state <- get_namespace
  let (ocirc,subsubroutines) = obcirc
  if Map.member name main_state 
    then return () 
    else do
      provide_simple_subroutine name ocirc input_structure output_structure is_classically_controllable
      provide_subroutines subsubroutines

-- ----------------------------------------------------------------------
-- * General gate
      
-- | Apply the specified low-level gate to the current circuit, using
-- the current controls, and updating the monad state accordingly.
-- This includes run-time well-formedness checks. This is a helper
-- function and is not directly accessible by user code.
apply_gate :: Gate -> Circ ()
apply_gate gate = do
  arity <- get_arity
  clist <- get_clist
  ncflag <- get_ncflag
  let gate' = gate_with_ncflag ncflag gate
  let gate'' = control_gate clist gate'
  case gate'' of 
    Nothing -> return ()
    Just g -> do
      let arity' = arity_append g arity
      put_gate g
      set_arity arity'
      return ()

-- ======================================================================
-- * Basic gates

-- ----------------------------------------------------------------------
-- ** Gates in functional style

-- | Apply a NOT gate to a qubit.
qnot :: Qubit -> Circ Qubit
qnot q = do
  named_gate_qulist "not" False [q] []
  return q

-- | Apply a Hadamard gate.
hadamard :: Qubit -> Circ Qubit
hadamard q = do
  named_gate_qulist "H" False [q] []
  return q

-- | An alternate name for the Hadamard gate.
gate_H :: Qubit -> Circ Qubit
gate_H = hadamard

-- | Apply a multiple-not gate, as specified by a list of booleans and
--   qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies 
--   a not gate to /q1/ and /q3/, but not to /q2/.
qmultinot_list :: [(Qubit, Bool)] -> Circ [Qubit]
qmultinot_list qbs = do
  let qs = map fst $ filter snd qbs
  named_gate_qulist "multinot" False qs []
  return (map fst qbs)

-- | Like 'qmultinot_list', but applies to classical bits instead of
-- qubits. 
cmultinot_list :: [(Bit, Bool)] -> Circ [Bit]
cmultinot_list cs = do
  let ws = map (wire_of_bit . fst) $ filter snd cs
  sequence_ [ apply_gate (CNot w [] False) | w <- ws ]
  return (map fst cs)

-- | Apply a Pauli /X/ gate.
gate_X :: Qubit -> Circ Qubit
gate_X q = do
  named_gate_qulist "X" False [q] []
  return q

-- | Apply a Pauli /Y/ gate.
gate_Y :: Qubit -> Circ Qubit
gate_Y q = do
  named_gate_qulist "Y" False [q] []
  return q

-- | Apply a Pauli /Z/ gate.
gate_Z :: Qubit -> Circ Qubit
gate_Z q = do
  named_gate_qulist "Z" False [q] []
  return q

-- | Apply a Clifford /S/-gate.
gate_S :: Qubit -> Circ Qubit
gate_S q = do
  named_gate_qulist "S" False [q] []
  return q
  
-- | Apply the inverse of an /S/-gate.
gate_S_inv :: Qubit -> Circ Qubit
gate_S_inv q = do
  named_gate_qulist "S" True [q] []
  return q
  
-- | Apply a /T/ = √/S/ gate.
gate_T :: Qubit -> Circ Qubit
gate_T q = do
  named_gate_qulist "T" False [q] []
  return q
  
-- | Apply the inverse of a /T/-gate.
gate_T_inv :: Qubit -> Circ Qubit
gate_T_inv q = do
  named_gate_qulist "T" True [q] []
  return q
  
-- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. 
-- 
-- \[image E.png]
-- 
-- This gate is the unique Clifford operator with the properties /E/³
-- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a
-- convenient gate for calculations. For example, every Clifford
-- operator can be uniquely written of the form
-- 
-- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/],
-- 
-- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8,
-- respectively.
gate_E :: Qubit -> Circ Qubit
gate_E q = do
  named_gate_qulist "E" False [q] []
  return q
  
-- | Apply the inverse of an /E/-gate.
gate_E_inv :: Qubit -> Circ Qubit
gate_E_inv q = do
  named_gate_qulist "E" True [q] []
  return q
  
-- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate.
gate_omega :: Qubit -> Circ Qubit
gate_omega q = do
  named_gate_qulist "omega" False [q] []
  return q

-- | Apply a /V/ = √/X/ gate. This is by definition the following gate
-- (see also Nielsen and Chuang, p.182):
-- 
-- \[image V.png]
gate_V :: Qubit -> Circ Qubit
gate_V q = do
  named_gate_qulist "V" False [q] []
  return q

-- | Apply the inverse of a /V/-gate.
gate_V_inv :: Qubit -> Circ Qubit
gate_V_inv q = do
  named_gate_qulist "V" True [q] []
  return q

-- | Apply a SWAP gate.
swap_qubit :: Qubit -> Qubit -> Circ (Qubit,Qubit)
swap_qubit q1 q2 = do
  named_gate_qulist "swap" False [q1, q2] []
  return (q1,q2)

-- | Apply a classical SWAP gate.
swap_bit :: Bit -> Bit -> Circ (Bit,Bit)
swap_bit c1 c2 = do
  apply_gate (CSwap (wire_of_bit c1) (wire_of_bit c2) [] False)
  return (c1,c2)

-- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter.
expZt :: Timestep -> Qubit -> Circ Qubit
expZt t q = do
  named_rotation_qulist "exp(-i%Z)" False t [q] []
  return q

-- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis.
-- 
-- \[image rGate.png]
rGate :: Int -> Qubit -> Circ Qubit
rGate n q = do
  named_rotation_qulist "R(2pi/%)" False (2^n) [q] []
  return q

-- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes
-- the SWAP gate. 
-- 
-- \[image W.png]
-- 
-- The arguments are such that 
-- 
-- > gate_W |0〉 |0〉 = |00〉
-- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2
-- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2
-- > gate_W |1〉 |1〉 = |11〉.
-- 
-- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2]
-- denotes the \"right\" qubit.
gate_W :: Qubit -> Qubit -> Circ (Qubit, Qubit)
gate_W q1 q2 = do
  named_gate_qulist "W" False [q1, q2] []
  return (q1, q2)

-- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/
-- gate, but with two advantages:
-- 
-- * the doubly-controlled /iX/ gate can be implemented in the
-- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/
-- gate requires /T/-count 7);
-- 
-- * the /iX/-gate has determinant 1, and therefore an /n/-times
-- controlled /iX/ gate can be implemented in the Clifford+/T/ gate
-- base with no ancillas.
-- 
-- In particular, the /iX/ gate can be used to implement an additional
-- control with /T/-count 8, like this:
-- 
-- \[image iX.png]
gate_iX :: Qubit -> Circ Qubit
gate_iX q = do
  named_gate_qulist "iX" False [q] []
  return q

-- | Apply a −/iX/ gate. This is the inverse of 'gate_iX'.
gate_iX_inv :: Qubit -> Circ Qubit
gate_iX_inv q = do
  named_gate_qulist "iX" True [q] []
  return q

-- | Apply a global phase change [exp /i/π/t/], where typically /t/ ∈
-- [0,2].  This gate is uninteresting if not controlled; however, it
-- has non-trivial effect if it is used as a controlled gate.
global_phase :: Double -> Circ ()
global_phase t = do
  apply_gate (GPhase t [] [] False)
  return ()

-- | Like 'global_phase', except the gate is also \"anchored\" at a
-- particular bit or qubit. This is strictly for graphical
-- presentation purposes, to provide a hint for where the gate should
-- be printed in a circuit diagram. Backends are free to ignore this
-- hint altogether. The anchor is not actually an input to the gate,
-- and it is legal for the anchoring qubit to also be used as a
-- control control.
global_phase_anchored_list :: Double -> [Endpoint] -> Circ ()
global_phase_anchored_list t qs = do
  apply_gate (GPhase t (map wire_of_endpoint qs) [] False)
  return ()

-- | Apply a generic quantum gate to a given list of qubits and a
-- given list of generalized controls. The generalized controls are
-- really inputs to the gate, but are guaranteed not to be modified
-- if they are in a computational basis state.
named_gate_qulist :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit])
named_gate_qulist name inv operands gencontrols = do
  apply_gate (QGate name inv (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False)
  return (operands, gencontrols)

-- | Like 'named_gate_qulist', but produce a named gate that also
-- depends on a real parameter. This is typically used for rotations
-- or phase gates parameterized by an angle. The name can contain
-- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@.
named_rotation_qulist :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ ([Qubit],[Qubit])
named_rotation_qulist name inv theta operands gencontrols = do
  apply_gate (QRot name inv theta (map wire_of_qubit operands) (map wire_of_qubit gencontrols) [] False)
  return (operands, gencontrols)

-- | Apply a NOT gate to a classical bit.
cnot :: Bit -> Circ Bit
cnot b = do
  apply_gate (CNot (wire_of_bit b) [] False)
  return b

-- ----------------------------------------------------------------------
-- ** Gates in imperative style

-- | Apply a NOT gate to a qubit.
qnot_at :: Qubit -> Circ ()
qnot_at q = do
  qnot q
  return ()

-- | Apply a Hadamard gate.
hadamard_at :: Qubit -> Circ ()
hadamard_at q = do
  hadamard q
  return ()

-- | An alternate name for the Hadamard gate.
gate_H_at :: Qubit -> Circ ()
gate_H_at = hadamard_at

-- | Apply a /qmultinot_list/ gate, as specified by a list of booleans and
--   qubits: @qmultinot_list [(True,q1), (False,q2), (True,q3)]@ applies 
--   a not gate to /q1/ and /q3/, but not to /q2/.
qmultinot_list_at :: [(Qubit, Bool)] -> Circ ()
qmultinot_list_at qs = do
  qmultinot_list qs
  return ()

-- | Like 'qmultinot_list_at', but applies to classical bits instead of
-- qubits. 
cmultinot_list_at :: [(Bit, Bool)] -> Circ ()
cmultinot_list_at cs = do
  cmultinot_list cs
  return ()

-- | Apply a Pauli /X/ gate.
gate_X_at :: Qubit -> Circ ()
gate_X_at q = do
  gate_X q
  return ()

-- | Apply a Pauli /Y/ gate.
gate_Y_at :: Qubit -> Circ ()
gate_Y_at q = do
  gate_Y q
  return ()

-- | Apply a Pauli /Z/ gate.
gate_Z_at :: Qubit -> Circ ()
gate_Z_at q = do
  gate_Z q
  return ()

-- | Apply a Clifford /S/-gate.
gate_S_at :: Qubit -> Circ ()
gate_S_at q = do
  gate_S q
  return ()

-- | Apply the inverse of an /S/-gate.
gate_S_inv_at :: Qubit -> Circ ()
gate_S_inv_at q = do
  gate_S_inv q
  return ()

-- | Apply a /T/ = √/S/ gate.
gate_T_at :: Qubit -> Circ ()
gate_T_at q = do
  gate_T q
  return ()

-- | Apply the inverse of a /T/-gate.
gate_T_inv_at :: Qubit -> Circ ()
gate_T_inv_at q = do
  gate_T_inv q
  return ()

-- | Apply a Clifford /E/ = /H//S/[sup 3]ω[sup 3] gate. 
-- 
-- \[image E.png]
-- 
-- This gate is the unique Clifford operator with the properties /E/³
-- = /I/, /EXE/⁻¹ = /Y/, /EYE/⁻¹ = /Z/, and /EZE/⁻¹ = /X/. It is a
-- convenient gate for calculations. For example, every Clifford
-- operator can be uniquely written of the form
-- 
-- * /E/[sup /a/]/X/[sup /b/]/S/[sup /c/]ω[sup /d/],
-- 
-- where /a/, /b/, /c/, and /d/ are taken modulo 3, 2, 4, and 8,
-- respectively.
gate_E_at :: Qubit -> Circ ()
gate_E_at q = do
  gate_E q
  return ()

-- | Apply the inverse of an /E/-gate.
gate_E_inv_at :: Qubit -> Circ ()
gate_E_inv_at q = do
  gate_E_inv q
  return ()

-- | Apply the scalar ω = [exp /i/π\/4], as a single-qubit gate.
gate_omega_at :: Qubit -> Circ ()
gate_omega_at q = do
  gate_omega q
  return ()

-- | Apply a /V/ = √/X/ gate. This is by definition the following gate
-- (see also Nielsen and Chuang, p.182):
-- 
-- \[image V.png]
gate_V_at :: Qubit -> Circ ()
gate_V_at q = do
  gate_V q
  return ()

-- | Apply the inverse of a /V/-gate.
gate_V_inv_at :: Qubit -> Circ ()
gate_V_inv_at q = do
  gate_V_inv q
  return ()

-- | Apply a SWAP gate.
swap_qubit_at :: Qubit -> Qubit -> Circ ()
swap_qubit_at q1 q2 = do
  swap_qubit q1 q2
  return ()

-- | Apply a classical SWAP gate.
swap_bit_at :: Bit -> Bit -> Circ ()
swap_bit_at c1 c2 = do
  swap_bit c1 c2
  return ()

-- | Apply an [exp −/iZt/] gate. The timestep /t/ is a parameter.
expZt_at :: Timestep -> Qubit -> Circ ()
expZt_at t q = do
  expZt t q
  return ()

-- | Apply a rotation by angle 2π/i/\/2[sup /n/] about the /z/-axis.
-- 
-- \[image rGate.png]
rGate_at :: Int -> Qubit -> Circ ()
rGate_at n q = do
  rGate n q
  return ()

-- | Apply a /W/ gate. The /W/ gate is self-inverse and diagonalizes
-- the SWAP gate. 
-- 
-- \[image W.png]
-- 
-- The arguments are such that 
-- 
-- > gate_W |0〉 |0〉 = |00〉
-- > gate_W |0〉 |1〉 = (|01〉+|10〉) / √2
-- > gate_W |1〉 |0〉 = (|01〉-|10〉) / √2
-- > gate_W |1〉 |1〉 = |11〉.
-- 
-- In circuit diagrams, /W/[sub 1] denotes the \"left\" qubit, and /W/[sub 2]
-- denotes the \"right\" qubit.
gate_W_at :: Qubit -> Qubit -> Circ ()
gate_W_at q1 q2 = do
  gate_W q1 q2
  return ()

-- | Apply an /iX/ gate. This gate is used similarly to the Pauli /X/
-- gate, but with two advantages:
-- 
-- * the doubly-controlled /iX/ gate can be implemented in the
-- Clifford+/T/ gate base with /T/-count 4 (the doubly-controlled /X/
-- gate requires /T/-count 7);
-- 
-- * the /iX/-gate has determinant 1, and therefore an /n/-times
-- controlled /iX/ gate can be implemented in the Clifford+/T/ gate
-- base with no ancillas.
-- 
-- In particular, the /iX/ gate can be used to implement an additional
-- control with /T/-count 8, like this:
-- 
-- \[image iX.png]
gate_iX_at :: Qubit -> Circ ()
gate_iX_at q = do
  gate_iX q
  return ()

-- | Apply a −/iX/ gate. This is the inverse of 'gate_iX_at'.
gate_iX_inv_at :: Qubit -> Circ ()
gate_iX_inv_at q = do
  gate_iX_inv q
  return ()

-- | Apply a generic quantum gate to a given list of qubits and a
-- given list of generalized controls. The generalized controls are
-- really inputs to the gate, but are guaranteed not to be modified
-- if they are in a computational basis state.
named_gate_qulist_at :: String -> InverseFlag -> [Qubit] -> [Qubit] -> Circ ()
named_gate_qulist_at name inv operands gencontrols = do
  named_gate_qulist name inv operands gencontrols  
  return ()

-- | Like 'named_gate_qulist_at', but produce a named gate that also
-- depends on a real parameter. This is typically used for rotations
-- or phase gates parameterized by an angle. The name can contain
-- \'%\' as a place holder for the parameter, for example @\"exp(-i%Z)\"@.
named_rotation_qulist_at :: String -> InverseFlag -> Timestep -> [Qubit] -> [Qubit] -> Circ ()
named_rotation_qulist_at name inv t operands gencontrols = do
  named_rotation_qulist name inv t operands gencontrols  
  return ()

-- | Apply a NOT gate to a classical bit.
cnot_at :: Bit -> Circ ()
cnot_at b = do
  cnot b
  return ()

-- ----------------------------------------------------------------------
-- ** Bitwise initialization and termination functions

-- | Generate a new qubit, initialized to the parameter 'Bool'.
qinit_qubit :: Bool -> Circ Qubit
qinit_qubit b = do
  arity <- get_arity
  let w = arity_unused_wire arity
  apply_gate (QInit b w False)
  return (qubit_of_wire w)

-- | Terminate a qubit asserted to be in state /b/. 
-- 
-- We note that the assertion is relative to the precision: when gates
-- in a circuit are implemented up to some precision ε (either due to
-- physical limitations, or due to decomposition into a discrete gate
-- base), the assertion may only hold up to a corresponding precision
-- as well.
qterm_qubit :: Bool -> Qubit -> Circ ()
qterm_qubit b q = do
  apply_gate (QTerm b (wire_of_qubit q) False)
  return ()

-- | Discard a qubit destructively.
qdiscard_qubit :: Qubit -> Circ ()
qdiscard_qubit q = do
  apply_gate (QDiscard (wire_of_qubit q))
  return ()

-- | Generate a new qubit, initialized from a classical bit. Note that
-- the classical bit is simultaneously terminated. 
prepare_qubit :: Bit -> Circ Qubit
prepare_qubit c = do
  let w = wire_of_bit c
  apply_gate (QPrep w False)
  return (qubit_of_wire w)

-- | Unprepare a qubit asserted to be in a computational basis
-- state. This is the same as a measurement, but must only be applied
-- to qubits that are already known to be in one of the states |0〉 or
-- |1〉, and not in superposition. This operation is rarely (perhaps
-- never?) used in any quantum algorithms, but we include it for
-- consistency reasons, because it is formally the inverse of
-- 'prepare_qubit'.
unprepare_qubit :: Qubit -> Circ Bit
unprepare_qubit q = do
  let w = wire_of_qubit q
  apply_gate (QUnprep w False)
  return (bit_of_wire w)

-- | Apply a measurement gate (turns a qubit into a bit).
measure_qubit :: Qubit -> Circ Bit
measure_qubit q = do
  let w = wire_of_qubit q
  apply_gate (QMeas w)
  return (bit_of_wire w)

-- | Generate a new classical bit, initialized to a boolean parameter
-- /b/.
cinit_bit :: Bool -> Circ Bit
cinit_bit b = do
  arity <- get_arity
  let w = arity_unused_wire arity
  apply_gate (CInit b w False)
  return (bit_of_wire w)

-- | Terminate a classical 'Bit' asserted to be in state 'Bool'.
cterm_bit :: Bool -> Bit -> Circ ()
cterm_bit b c = do
  let w = wire_of_bit c
  apply_gate (CTerm b w False)
  return ()

-- | Terminate a classical 'Bit' with a comment indicating what the
-- observed state of the 'Bit' was, in this particular dynamic run of
-- the circuit. This is typically used to terminate a wire right after
-- a dynamic lifting has been performed.  It is not intended to be a
-- user-level operation.
-- 
-- It is important to note that a 'DTerm' gate does not, in any way,
-- represent an assertion. Unlike a 'CTerm' gate, which asserts that
-- the classical bit will have the stated value at /every/ run of the
-- circuit, the 'DTerm' gate simply records that the classical bit had
-- the stated value at some /particular/ run of the circuit.
--  
-- Operationally (e.g., in a simulator), the 'DTerm' gate can be
-- interpreted in multiple ways. In the simplest case, it is just
-- treated like a 'CDiscard' gate, and the boolean comment
-- ignored. Alternatively, it can be treated as a post-selection gate:
-- if the actual value does not equal the stated value, the entire
-- computation is aborted. Normally, 'DTerm' gates should appear in
-- the /output/, not the /input/ of simulators; therefore, the details
-- of the behavior of any particular simulator on a 'DTerm' gate are
-- implementation dependent.
dterm_bit :: Bool -> Bit -> Circ ()
dterm_bit b c = do
  let w = wire_of_bit c
  apply_gate (DTerm b w)
  return ()

-- | Discard a classical bit destructively.
cdiscard_bit :: Bit -> Circ ()
cdiscard_bit c = do
  let w = wire_of_bit c
  apply_gate (CDiscard w)
  return ()

-- ----------------------------------------------------------------------
-- ** Classical gates

-- $CLASSICAL
--
-- The gates in this section are for constructing classical circuits. 
-- None of these gates alter or discard their inputs; each gate produces 
-- a new wire holding the output of the gate.

-- | Return the \"exclusive or\" of a list of bits. 
cgate_xor :: [Bit] -> Circ Bit
cgate_xor inputs =
  cgate "xor" inputs
  
-- | Test equality of two bits, and return 'True' iff they are equal. 
cgate_eq :: Bit -> Bit -> Circ Bit
cgate_eq a b = cgate "eq" [a,b]

-- | If /a/ is 'True', then return /b/, else return /c/.
cgate_if_bit :: Bit -> Bit -> Bit -> Circ Bit
cgate_if_bit a b c = cgate "if" [a,b,c]

-- | Return the negation of its input. Note that unlike 'cnot' or
-- 'cnot_at', this gate does not alter its input, but returns a newly
-- created bit.
cgate_not :: Bit -> Circ Bit
cgate_not a = cgate "not" [a]

-- | Return the conjunction of a list of bits.
cgate_and :: [Bit] -> Circ Bit
cgate_and inputs = cgate "and" inputs

-- | Return the disjunction of a list of bits.
cgate_or :: [Bit] -> Circ Bit
cgate_or inputs = cgate "or" inputs

-- | Apply a named classical gate. This is used to define all of the
-- above classical gates, but should not usually be directly used by
-- user code.
cgate :: String -> [Bit] -> Circ Bit
cgate name inputs = do
  arity <- get_arity
  let w = arity_unused_wire arity
  apply_gate (CGate name w (map wire_of_bit inputs) False)
  return (bit_of_wire w)

-- | @'cgateinv' name w inputs@: Uncompute a named classical
-- gate. This asserts that /w/ is in the state determined by the gate
-- type and the /inputs/, then uncomputes /w/ in a reversible
-- way. This rarely used gate is formally the inverse of 'cgate'.
cgateinv :: String -> Bit -> [Bit] -> Circ ()
cgateinv name c inputs = do
  let w = wire_of_bit c
  apply_gate (CGateInv name w (map wire_of_bit inputs) False)
  return ()

-- ----------------------------------------------------------------------
-- ** Subroutines

-- | Insert a subroutine gate with specified name, and input/output
-- output types, and attach it to the given endpoints. Return the new
-- endpoints.
--
-- Note that the @['Wire']@ and 'Arity' arguments are used as a /pattern/
-- for the locations/types of wires of the subroutine; the @['Endpoint']@
-- argument (and output) specify what is attached in the current circuit.
-- The two aspects of this pattern that are respected are: the
-- lingeringness of any inputs; and the number and types of wires.
--
-- For instance (assuming for simplicity that all wires are qubits), if
-- the patterns given are “inputs [1,3,5], outputs [1,3,4]”, and the 
-- actual inputs specified are [20,21,25], then the output wires produced 
-- might be e.g. [20,21,23], [20,21,36], or [20,21,8], depending on the 
-- next available free wire.
--
-- More subtly, if
-- the patterns given are “inputs [1,2,3], outputs [3,7,8,1]”,
-- and the inputs given are [10,5,4], then the outputs will be
-- [4,/x/,/y/,10], where /x/, /y/ are two fresh wires.
--
-- Note that lingering wires may change type, for e.g. subroutines that
-- include measurements.
--
-- It is currently assumed that all these lists are linear, i.e. contain
-- no duplicates.
subroutine :: BoxId -> InverseFlag -> ControllableFlag
           -> RepeatFlag -> [Wire] -> Arity -> [Wire] -> Arity
           -> [Endpoint] -> Circ [Endpoint]
subroutine name inv scf rep win_pattern ain_pattern wout_pattern aout_pattern ein = do
  let (win,ain) = wires_with_arity_of_endpoints ein
  -- Check the given input wires match the pattern:
  when (not $ all (\(w_p,w) -> ain_pattern IntMap.! w_p == ain IntMap.! w) $ zip_strict_errmsg win_pattern win e_num_inputs) $ do 
    error e_input_types
  -- Work out which input wires are lingering, and how many new wires are needed:
  let partial_wout = map (\w_p -> let maybe_w = lookup w_p (zip win_pattern win)
                                  in (maybe_w, aout_pattern IntMap.! w_p))
                         wout_pattern
      num_new_wires = length $ filter ((== Nothing) . fst) partial_wout 
  -- Allocate new wires for the non-lingering outputs:
  arity <- get_arity
  let new_wires = arity_unused_wires num_new_wires arity
      eout = insert_new_wires partial_wout new_wires
      (wout,aout) = wires_with_arity_of_endpoints eout
  apply_gate (Subroutine name inv win ain wout aout [] False scf rep)
  return eout
  where
    insert_new_wires :: [(Maybe Wire, Wiretype)] -> [Wire] -> [Endpoint]
    insert_new_wires ((Just w,t):ws) new_wires = (endpoint_of_wire w t):(insert_new_wires ws new_wires)
    insert_new_wires ((Nothing,t):ws) (next_new:new_wires) = (endpoint_of_wire next_new t):(insert_new_wires ws new_wires)
    insert_new_wires [] [] = []
    insert_new_wires _ _ = error e_output_allocation
    e_num_inputs = "subroutine: subroutine " ++ show name ++ " applied to the wrong number of input wires"
    e_input_types = "subroutine: subroutine " ++ show name ++ " applied to input wires of incorrect type"
    e_output_allocation = "internal error: Quipper.Monad.subroutine: output wire allocation"


-- | Look up the specified subroutine in the namespace, and apply it
-- to the specified inputs, or throw an error if they are not appropriately
-- typed.
--
-- The input/output types of this function are determined dynamically
-- by the 'CircuitTypeStructure' stored with the subroutine.
call_subroutine :: (Typeable a, Typeable b) => BoxId -> RepeatFlag -> a -> Circ b
call_subroutine name r x = do
  ns <- get_namespace
  let mc = Map.lookup name ns
  case mc of 
    Nothing -> 
      error ("call_subroutine: subroutine " ++ show name ++ " does not exist in current namespace: " ++ showNames ns)
    Just (TypedSubroutine ocircuit input_structure output_structure scf) -> do
      let OCircuit (win_pattern, circuit, wout_pattern) = ocircuit
      let (ain_pattern, gates, aout_pattern, n) = circuit
      let (win, ain) = case cast input_structure of
            Just suitable_input_structure -> destructure_with suitable_input_structure x
            Nothing -> error ("call_subroutine: subroutine " ++ show name ++ " applied to input of incorrect type")
      let ein = endpoints_of_wires_in_arity ain win
      eout <- subroutine name False scf r win_pattern ain_pattern wout_pattern aout_pattern ein
      let (wout, aout) = wires_with_arity_of_endpoints eout
      
      --  The output structure of the subroutine contains the wires
      --  corresponding to the actual output type of the function and
      --  the wires that were created but forgotten, in
      --  imperative-style. (see comments in 'provide_subroutine_generic').
      let (y,_::([Qubit],[Bit])) = case cast output_structure of
            Just suitable_output_structure -> structure_with suitable_output_structure (wout, aout)
            Nothing -> error ("call_subroutine: attempt to use outputs of subroutine " ++ show name ++ " as incorrect type")
      return y

-- ----------------------------------------------------------------------
-- ** Comments
  
-- | Insert a comment in the circuit. This is not a gate, and has no
-- effect, except to mark a spot in the circuit. The comment has two
-- parts: a string (possibly empty), and a list of labelled wires
-- (possibly empty). This is a low-level function. Users should use
-- 'comment' instead.
comment_label :: String -> InverseFlag -> [(Wire, String)] -> Circ ()
comment_label s inv ws = do
  b <- get_nocommentflag
  when (not b) $ do
    apply_gate (Comment s inv ws)
  return ()

-- | Disable labels and comments for a block of code. The intended
-- usage is like this:
-- 
-- > without_comments $ do {
-- >   <<<code block>>>
-- > }
-- 
-- This is sometimes useful in situations where code is being re-used,
-- for example when one function is implemented in terms of another,
-- but should not inherit comments from it. It is also useful in the
-- definition of recursive function, where a comment should only be
-- applied at the outermost level. Finally, it can be used to suppress
-- comments from parts of circuits for presentation purposes.
without_comments :: Circ a -> Circ a
without_comments body = do
  b <- get_nocommentflag
  set_nocommentflag True
  a <- body
  set_nocommentflag b
  return a
  
-- ----------------------------------------------------------------------
-- ** Dynamic lifting
  
-- | Convert a 'Bit' (boolean circuit output) to a 'Bool' (boolean
-- parameter).
-- 
-- For use in algorithms that require the output of a measurement to
-- be used as a circuit-generation parameter. This is the case, for
-- example, for sieving methods, and also for some iterative
-- algorithms.
-- 
-- Note that this is not a gate, but a meta-operation. The input
-- consists of classical circuit endpoints (whose values are known at
-- circuit execution time), and the output is a boolean parameter
-- (whose value is known at circuit generation time). 
-- 
-- The use of this operation implies an interleaving between circuit
-- execution and circuit generation. It is therefore a (physically)
-- expensive operation and should be used sparingly. Using the
-- 'dynamic_lift_bit' operation interrupts the batch mode operation of
-- the quantum device (where circuits are generated ahead of time),
-- and forces interactive operation (the quantum device must wait for
-- the next portion of the circuit to be generated). This operation is
-- especially expensive if the current circuit contains unmeasured
-- qubits; in this case, the qubits must be preserved while the
-- quantum device remains on standby.
-- 
-- Also note that this operation is not supported in all contexts. It
-- is an error, for example, to use this operation in a circuit that
-- is going to be reversed, or in the body of a boxed subroutine.
-- Also, not all output devices (such as circuit viewers) support this
-- operation.
dynamic_lift_bit :: Bit -> Circ Bool
dynamic_lift_bit c = do
  b <- do_read (wire_of_bit c)
  dterm_bit b c
  return b
  
-- ======================================================================
-- * Other circuit-building functions

-- | Generate a new qubit initialized to |+〉 when /b/='False' and
-- |−〉 when /b/='True'.
qinit_plusminus :: Bool -> Circ Qubit
qinit_plusminus b = do
  q <- qinit_qubit b
  q <- hadamard q
  return q  

-- | Generate a new qubit initialized to one of |0〉, |1〉, |+〉, |−〉,
-- depending on a character /c/ which is \'0\', \'1\', \'+\', or \'-\'.
qinit_of_char :: Char -> Circ Qubit
qinit_of_char '0' = qinit_qubit False
qinit_of_char '1' = qinit_qubit True
qinit_of_char '+' = qinit_plusminus False
qinit_of_char '-' = qinit_plusminus True
qinit_of_char c = error ("qinit_of_char: unimplemented initialization: " ++ [c])

-- | Generate a list of qubits initialized to a sequence of |0〉, |1〉,
-- |+〉, |−〉, defined by a string argument e.g. \"00+0+++\".
qinit_of_string :: String -> Circ [Qubit]
qinit_of_string s = sequence (map qinit_of_char s)

-- | A version of 'qinit_qubit' that operates on lists. 
qinit_list :: [Bool] -> Circ [Qubit]
qinit_list bs = mapM qinit_qubit bs


-- | A version of 'qterm_qubit' that operates on lists. We initialize
-- left-to-right and terminate right-to-left, as this leads to more
-- symmetric and readable circuits, more stable under reversal.
-- 
-- Note: if the left argument to 'qterm_list' is longer than the right
-- argument, then it is truncated. So the first argument can be
-- ('repeat' 'False'). It is an error if the left argument is shorter
-- than the right one.
qterm_list :: [Bool] -> [Qubit] -> Circ ()
qterm_list bs qs =
  zipRightWithRightStrictM_ qterm_qubit bs qs

-- | A version of 'cinit_bit' for lists.
cinit_list :: [Bool] -> Circ [Bit]
cinit_list bs = mapM cinit_bit bs

-- ======================================================================
-- * Higher-order functions

-- | Convenient wrapper around 'qinit' and 'qterm'. This can be used
-- to introduce an ancilla with a local scope, like this:
-- 
-- > with_ancilla $ \h -> do {
-- >   <<<code block using ancilla h>>>
-- > }
-- 
-- The ancilla will be initialized to |0〉 at the beginning of the
-- block, and it is the programmer's responsibility to ensure that it
-- will be returned to state |0〉 at the end of the block.
-- 
-- A block created with 'with_ancilla' is controllable, provided that
-- the body is controllable.
with_ancilla :: (Qubit -> Circ a) -> Circ a
with_ancilla f = do
  q <- without_controls (qinit_qubit False)
  a <- f q
  without_controls (qterm_qubit False q)
  return a

-- | A syntax for \"if\"-style (classical and quantum) controls. 
-- This can be used as follows:
-- 
-- > gate1
-- > with_controls <<controls>> $ do {
-- >   gate2
-- >   gate3
-- > }
-- > gate4
-- 
-- The specified controls will be applied to gate2 and gate3. It is an
-- error to specify a control for a gate that cannot be controlled
-- (such as measurement).
  
with_controls :: ControlSource c => c -> Circ a -> Circ a
with_controls control code = do
  clist_old <- get_clist
  set_clist (combine (to_control control) clist_old)
  a <- code
  set_clist clist_old
  return a
  
-- | An infix operator to apply the given controls to a gate:
-- 
-- > gate `controlled` <<controls>>
-- 
-- It also works with functional-style gates:
-- 
-- > result <- gate `controlled` <<controls>>
-- 
-- The infix operator is left associative, so it can be applied
-- multiple times:
-- 
-- > result <- gate `controlled` <<controls1>> `controlled` <<controls2>>
-- 
-- The latter is equivalent to
-- 
-- > result <- gate `controlled` <<controls1>> .&&. <<controls2>>

controlled :: ControlSource c => Circ a -> c -> Circ a
controlled code control = with_controls control code

infixl 2 `controlled`

-- | Apply a block of gates while temporarily suspending the
-- application of controls.  This can be used to omit controls on
-- gates where they are known to be unnecessary. This is a relatively
-- low-level function and should not normally be called directly by
-- user code. Instead, it is safer to use a higher-level function such
-- as 'with_basis_change'. However, the 'without_controls' operator is
-- useful in certain situations, e.g., it can be used to preserve the
-- 'NoControlFlag' when defining transformers.
-- 
-- Usage:
-- 
-- > without_controls $ do 
-- >   <<code block>>
-- 
-- or:
-- 
-- > without_controls (gate)
-- 
-- Note that all controls specified in the /surrounding/ code are
-- disabled within the 'without_controls' block. This is even true if
-- the 'without_controls' block appears in a subroutine, and the
-- subroutine is later called in a controlled context. On the other
-- hand, it is possible to specify controls /inside/ the
-- 'without_controls' block. Consider this example:
-- 
-- > my_subcircuit = do
-- >   gate1
-- >   without_controls $ do {
-- >     gate2
-- >     gate3 `controlled` <<controls1>>
-- >   }
-- >   gate4
-- >
-- > my_circuit = do
-- >   my_subcircuit `controlled` <<controls2>>
-- 
-- In this example, controls 1 will be applied to gate 3, controls 2
-- will be applied to gates 1 and 4, and no controls will be applied
-- to gate 2.
without_controls :: Circ a -> Circ a
without_controls code = do
  clist_old <- get_clist
  ncflag_old <- get_ncflag
  set_clist clist_empty
  set_ncflag True
  a <- code
  set_clist clist_old
  set_ncflag ncflag_old
  return a
  
-- | Apply 'without_controls' if 'NoControlFlag' is 'True', otherwise
-- do nothing.
without_controls_if :: NoControlFlag -> Circ a -> Circ a
without_controls_if True = without_controls
without_controls_if False = id

-- ----------------------------------------------------------------------
-- ** Deprecated special cases of without_controls

-- | Generate a new qubit, initialized to the parameter 'Bool', that
--   is guaranteed to be used as an ancilla and terminated with
--   'qterm_qubit_ancilla'. Deprecated.
qinit_qubit_ancilla :: Bool -> Circ Qubit
qinit_qubit_ancilla b = do
  without_controls $ do
    qinit_qubit b

-- | Terminate an ancilla asserted to be in state /b/. Deprecated.
qterm_qubit_ancilla :: Bool -> Qubit -> Circ ()
qterm_qubit_ancilla b q = do
  without_controls $ do
    qterm_qubit b q

-- ======================================================================
-- * Circuit transformers

-- | The identity transformer. This just maps a low-level circuits to
-- the corresponding circuit-generating function. It can also be used
-- as a building block in other transformers, to define \"catch-all\"
-- clauses for gates that don't need to be transformed.
identity_transformer :: Transformer Circ Qubit Bit
identity_transformer (T_QGate name _ _ inv ncf f) = f $
  \ws vs c -> without_controls_if ncf $ do
    (ws', vs') <- named_gate_qulist name inv ws vs `controlled` c
    return (ws', vs', c)
identity_transformer (T_QRot name _ _ inv t ncf f) = f $
  \ws vs c -> without_controls_if ncf $ do
    (ws', vs') <- named_rotation_qulist name inv t ws vs `controlled` c
    return (ws', vs', c)
identity_transformer (T_GPhase t ncf f) = f $
  \qs c -> without_controls_if ncf $ do
    global_phase_anchored_list t qs `controlled` c
    return c
identity_transformer (T_CNot ncf f) = f $
  \q c -> without_controls_if ncf $ do
    q' <- cnot q `controlled` c
    return (q', c)
identity_transformer (T_CGate name ncf f) = f $
  \ws -> without_controls_if ncf $ do    
    v <- cgate name ws
    return (v, ws)
identity_transformer (T_CGateInv name ncf f) = f $
  \v ws -> without_controls_if ncf $ do    
    cgateinv name v ws
    return ws
identity_transformer (T_CSwap ncf f) = f $
  \w v c -> without_controls_if ncf $ do
    (w',v') <- swap_bit w v `controlled` c
    return (w',v',c)
identity_transformer (T_QPrep ncf f) = f $
  \w -> without_controls_if ncf $ do    
    v <- prepare_qubit w
    return v
identity_transformer (T_QUnprep ncf f) = f $    
  \w -> without_controls_if ncf $ do    
    v <- unprepare_qubit w
    return v
identity_transformer (T_QInit b ncf f) = f $
  without_controls_if ncf $ do
    w <- qinit_qubit b
    return w
identity_transformer (T_CInit b ncf f) = f $
  without_controls_if ncf $ do
    w <- cinit_bit b
    return w
identity_transformer (T_QTerm b ncf f) = f $
  \w -> without_controls_if ncf $ do
    qterm_qubit b w
    return ()
identity_transformer (T_CTerm b ncf f) = f $
  \w -> without_controls_if ncf $ do
    cterm_bit b w
    return ()
identity_transformer (T_QMeas f) = f $    
  \w -> do
    v <- measure_qubit w
    return v
identity_transformer (T_QDiscard f) = f $
  \w -> do
    qdiscard_qubit w
    return ()
identity_transformer (T_CDiscard f) = f $
  \w -> do
    cdiscard_bit w
    return ()
identity_transformer (T_DTerm b f) = f $
  \w -> do
    dterm_bit b w
    return ()
identity_transformer (T_Subroutine n inv ncf scf ws_pat a1 vs_pat a2 rep f) = f $
  \namespace ws c -> without_controls_if ncf $ do
    provide_subroutines namespace
    vs <- subroutine n inv scf rep ws_pat a1 vs_pat a2 ws `controlled` c
    return (vs,c)
identity_transformer (T_Comment s inv f) = f $
  \ws -> do
    comment_label s inv [ (wire_of_endpoint e, s) | (e,s) <- ws ]
    return ()

-- | The identity transformer can be enriched with a dynamic lifting operation, so
-- as to define a DynamicTransformer
identity_dynamic_transformer_with_lift :: (Bit -> Circ Bool) -> DynamicTransformer Circ Qubit Bit
identity_dynamic_transformer_with_lift f = DT {
  transformer = identity_transformer,
  define_subroutine = \name typed_subroutine -> do
    s <- get_namespace
    let s' = map_provide name typed_subroutine s
    set_namespace s'
    put_subroutine_definition name typed_subroutine,
  lifting_function = f
 }

-- | The identity DynamicTransformer uses the built in do_read operation
identity_dynamic_transformer :: DynamicTransformer Circ Qubit Bit
identity_dynamic_transformer = 
  identity_dynamic_transformer_with_lift (\b -> do_read (wire_of_bit b))

-- | We can define a dynamic transformer with a "constant" lifting function
identity_dynamic_transformer_constant :: Bool -> DynamicTransformer Circ Qubit Bit
identity_dynamic_transformer_constant b = identity_dynamic_transformer_with_lift (\_ -> return b) 

-- | Append the entire circuit /c/ to the current circuit, using the
-- given bindings. Return the new bindings.
apply_circuit_with_bindings :: Circuit -> (Bindings Qubit Bit) 
                            -> Circ (Bindings Qubit Bit)
apply_circuit_with_bindings c bindings =
  transform_circuit identity_transformer c bindings

-- | Append the entire circuit /c/ to the current circuit, using the
-- given bindings, and return the new bindings.  
-- Also, add to the current namespace state any subroutines of /c/ 
-- that are not already provided.
apply_bcircuit_with_bindings :: BCircuit -> (Bindings Qubit Bit) 
                             -> Circ (Bindings Qubit Bit)
apply_bcircuit_with_bindings (c,s) bindings = do
  provide_subroutines s
  apply_circuit_with_bindings c bindings

-- | Append the entire dynamic circuit /c/ to the current circuit,
-- using the given bindings, and return the new bindings.  Also, add
-- to the current namespace state any subroutines of /c/ that are not
-- already provided.
apply_dbcircuit_with_bindings :: DBCircuit a -> Bindings Qubit Bit
                                 -> Circ (Bindings Qubit Bit, a)
apply_dbcircuit_with_bindings dbcircuit bindings = do
  -- until the transformer interface is updated to work with dynamic
  -- circuits, we have to go the route of converting to a static
  -- circuit first. Unfortunately, this means that any dynamic
  -- liftings will given an error.
  let (bcircuit, a) = bcircuit_of_static_dbcircuit errmsg dbcircuit
  out_bindings <- apply_bcircuit_with_bindings bcircuit bindings
  return (out_bindings, a)
  where
    errmsg x = "apply_dbcircuit_with_bindings: operation unimplemented: " ++ x
  
-- ======================================================================
-- * Encapsulated circuits

-- | Similar to 'extract_simple', except we take the current output arity
-- of the /current/ circuit and make that the input arity of the
-- extracted circuit. Therefore, endpoints defined in the current
-- context can be used in /f/. This is a low-level operator, intended
-- for the construction of primitives, such as 'with_computed' or
-- 'with_basis_change', where the inner block can re-use some
-- variables without declaring them explicitly.
--
-- We also reuse the namespace of the current context, to avoid
-- recomputation of shared subroutines. 
-- 
-- As a special feature, also return the set of \"dirty\" wires, i.e.,
-- wires that were used during the execution of the body, but are free
-- at the end.
extract_in_context :: ErrMsg -> Circ a -> Circ (BCircuit, IntSet, a)
extract_in_context e f = do
  arity <- get_arity
  cur_namespace <- get_namespace
  let arity' = xintmap_makeclean arity
   -- f' :: Circ (a, ExtArity)
      f' = do
        set_namespace cur_namespace
        a <- f
        extarity <- get_arity
        return (a, extarity)
      (bcirc, ~(a, extarity)) = extract_simple e arity' f'
  return (bcirc, xintmap_dirty extarity, a)

-- | Intermediate between 'extract_simple' and 'extract_in_context':
-- we build the circuit in the namespace of the current circuit, to 
-- avoid recomputing any shared subroutines.
extract_in_current_namespace :: ErrMsg -> ExtArity -> Circ a -> Circ (BCircuit, a)
extract_in_current_namespace e arity f = do
  cur_namespace <- get_namespace
  return $ extract_simple e arity $ (set_namespace cur_namespace) >> f

-- | Append the 'BCircuit' to the end of the current circuit, using
-- the identity binding. This means, the input wires of 'BCircuit'
-- /must/ be endpoints in the current circuits. This typically happens
-- when 'BCircuit' was obtained from 'extract_in_context' in the
-- current context, or when 'BCircuit' is the inverse of a circuit
-- that has just been applied using 'unextract_in_context'. 
-- 
-- Note that this is a low-level function, intended for the
-- construction of user-level primitives such as 'with_computed' and
-- 'with_basis_change', and 'classical_to_reversible'. 
-- 
-- 'unextract_in_context' uses 'apply_gate' to do the appending,
-- so the current 'ControlList' and 'NoControlFlag' are respected.
-- However, it does not pass through the transformer interface, and
-- therefore low-level wire id's will be exactly preserved.
unextract_in_context :: BCircuit -> Circ ()
unextract_in_context (c,s) = do
  provide_subroutines s
  let (_,gs,_,_) = c
  mapM_ apply_gate gs

-- | Reverse an encapsulated circuit
-- 
-- An encapsulated circuit is a circuit together with data structures
-- holding the input endpoints and output endpoints.  The type of the
-- encapsulated circuit depends on the type of data in the endpoints,
-- so functions to encapsulate and unencapsulate circuits are provided
-- in "Quipper.Generic".
reverse_encapsulated :: (i, BCircuit, o) -> (o, BCircuit, i)
reverse_encapsulated (in_bind, c, out_bind) =
  (out_bind, reverse_bcircuit c, in_bind)

-- ----------------------------------------------------------------------
-- * Temporarily reserving wires

-- | Perform the computation in the body, but temporarily reserve a
-- set of wires. These wires must be initially free, and they must not
-- be used by the body (i.e., the body must respect reserved wires).
with_reserve :: IntSet -> Circ a -> Circ a
with_reserve ws body = do
  arity <- get_arity
  let arity1 = xintmap_reserves ws arity
  set_arity arity1
  a <- body
  arity2 <- get_arity            -- they should still be reserved
  let arity3 = xintmap_unreserves ws arity2
  set_arity arity3
  return a