{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE Rank2Types #-} 
{-# LANGUAGE DoAndIfThenElse #-}

-- | This module provides functions and operators that are \"generic\"
-- on quantum data. We say that a function is generic if it works at
-- any quantum data type, rather than just a specific type such as
-- 'Qubit'. For example, the generic function 'qinit' can be used to
-- initialize a qubit from a boolean, or a pair of qubits from a pair
-- of booleans, or a list of qubits from a list of booleans, and so
-- forth.
-- 
-- Some functions are also generic in the /number/ of arguments they
-- take, in addition to the type of the arguments. 

module Quipper.Internal.Generic (
  -- * Generic gates
  -- ** Initialization and termination
  qinit,
  qterm,
  qdiscard,
  cinit,
  cterm,
  cdiscard,
  qc_init,
  qc_init_with_shape,
  qc_term,
  qc_discard,
  -- ** Measurement and preparation
  measure,
  prepare,
  qc_measure,
  qc_prepare,
  -- ** Global phase gate
  global_phase_anchored,
  -- ** Mapped gates
  map_hadamard,
  map_hadamard_at,
  swap,
  swap_at,
  controlled_not,  
  controlled_not_at,
  bool_controlled_not,
  bool_controlled_not_at,
  qmultinot,
  qmultinot_at,
  -- ** Copying and uncopying
  qc_copy_fun,
  qc_uncopy_fun,
  qc_copy,
  qc_uncopy,
  -- ** Classical gates
  cgate_if,
  circ_if,
  -- ** Named gates
  named_gate,
  named_gate_at,
  named_rotation,
  named_rotation_at,
  extended_named_gate,
  extended_named_gate_at,
  -- ** Dynamic lifting
  dynamic_lift,
  
  -- * Mapping
  mapUnary,
  mapBinary,
  mapBinary_c,
  map2Q,
  qc_mapBinary,

  -- * Conversion to lists
  -- $CONVERSION
  qubits_of_qdata,
  qdata_of_qubits,
  endpoints_of_qcdata,
  qcdata_of_endpoints,
  
  -- * Shape related operations
  qc_false,
  qshape,
  
  -- * Bindings
  qc_bind,
  qc_unbind,
  
  -- * Generic controls
  -- $CONTROL
  (.&&.),
  (.==.),
  (./=.),
  -- * Generic encapsulation
  -- $encapsulate
  encapsulate_generic,
  encapsulate_generic_in_namespace,
  unencapsulate_generic,
  -- $dynamic_encapsulate
  encapsulate_dynamic,
  unencapsulate_dynamic,
  -- * Generic reversing
  reverse_generic,
  reverse_generic_curried,
  reverse_simple,
  reverse_simple_curried,
  reverse_generic_endo,
  reverse_generic_imp,
  reverse_endo_if,
  reverse_imp_if,
  -- * The QCurry type class
  QCurry (..),
  -- * Generic circuit transformations
  transform_unary_dynamic_shape,
  transform_unary_dynamic,
  transform_unary,
  transform_generic,
  transform_unary_shape,
  transform_generic_shape,
  -- * Generic block structure
  with_ancilla_init,
  with_ancilla_list,
  with_computed_fun,
  with_computed,
  with_basis_change,
  with_classical_control,
  -- * Boxed subcircuits
  provide_subroutine_generic,
  box,
  nbox,
  box_loopM,
  loopM_boxed_if,
  inline_subroutine
  ) where

-- import other Quipper stuff
import Quipper.Internal.Circuit
import Quipper.Internal.Monad
import Quipper.Utils.Auxiliary
import Quipper.Utils.Tuple
import Quipper.Internal.Transformer
import Quipper.Internal.Control
import Quipper.Internal.QData

-- import other stuff
import Control.Monad
import Prelude
import Data.Typeable
import qualified Control.Monad.State as State

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

-- ======================================================================
-- * Generic gates

-- ** Initialization and termination

-- | Initialize a qubit from a boolean parameter. More generally,
-- initialize a data structure of qubits from a corresponding data
-- structure of boolean parameters. Examples:
-- 
-- > q <- qinit False
-- > (q0, q1) <- qinit (True, False)
-- > [q0, q1, q2] <- qinit [True, False, True]
qinit :: (QShape ba qa ca) => ba -> Circ qa
qinit ba = qdata_mapM (shapetype_b ba) qinit_qubit ba

-- | Terminate a qubit, asserting its state to equal the boolean
-- parameter. More generally, terminate a data structure of qubits,
-- asserting that their state is as given by a data structure of
-- booleans parameters. Examples:
-- 
-- > qterm False q
-- > qterm (False, False) (q0, q1)
-- > qterm [False, False, False] [q0, q1, q2]
-- 
-- In some cases, it is permissible for some aspect of the parameter's
-- shape to be underspecified, e.g., a longer than necessary list, or
-- an integer of indeterminate length. It is therefore possible, for
-- example, to write:
-- 
-- > qterm 17 qa          -- when qa :: QDInt,
-- > qterm [False..] qa   -- when qa :: [Qubit].
-- 
-- The rules for when a boolean argument can be \"promoted\" in this
-- way are specific to each individual data type.
qterm :: (QShape ba qa ca) => ba -> qa -> Circ ()
qterm ba qa = do
  let shape = shapetype_b ba                  -- shape type  
  let ba' = qdata_promote ba qa errmsg  -- shape data
  let z = qdata_zip shape bool qubit ba' qa errmsg
  qdata_mapM_op shape (\(x,y) -> qterm_qubit x y) z
  return ()
  where
    errmsg s = "qterm: shape of parameter does not match data: " ++ s

-- | Discard a qubit, ignoring its state. This can leave the quantum
-- system in a mixed state, so is not a reversible operation. More
-- generally, discard all the qubits in a quantum data
-- structure. Examples:
-- 
-- > qdiscard q
-- > qdiscard (q0, q1)
-- > qdiscard [q0, q1, q2]
qdiscard :: (QData qa) => qa -> Circ ()
qdiscard qa = do
  qdata_mapM_op (shapetype_q qa) qdiscard_qubit qa
  return ()
  
-- | Initialize a 'Bit' (boolean input) from a 'Bool' (boolean
-- parameter). More generally, initialize the a data structure of Bits
-- from a corresponding data structure of Bools. Examples:
-- 
-- > b <- cinit False
-- > (b0, b1) <- cinit (True, False)
-- > [b0, b1, b2] <- cinit [True, False, True]
cinit :: (QShape ba qa ca) => ba -> Circ ca
cinit ba = qdata_mapM (shapetype_b ba) cinit_bit ba

-- | Terminate a 'Bit', asserting its state to equal the given
-- 'Bool'. More generally, terminate a data structure of Bits,
-- asserting that their state is as given by a data structure of
-- Bools. Examples:
-- 
-- > cterm False b
-- > cterm (False, False) (b0, b1)
-- > cterm [False, False, False] [b0, b1, b2]
-- 
-- In some cases, it is permissible for some aspect of the parameter's
-- shape to be underspecified, e.g., a longer than necessary list, or
-- an integer of indeterminate length. It is therefore possible, for
-- example, to write:
-- 
-- > cterm 17 ca          -- when ca :: CInt,
-- > cterm [False..] ca   -- when ca :: [Bit].
-- 
-- The rules for when a boolean argument can be \"promoted\" in this
-- way are specific to each individual data type.
cterm :: (QShape ba qa ca) => ba -> ca -> Circ ()
cterm ba ca = do
  -- shape type
  let shape = shapetype_b ba
  -- shape data
  let ba' = qdata_promote_c ba ca errmsg
  let z = qdata_zip shape bool bit ba' ca errmsg
  qdata_mapM_op shape (\(x,y) -> cterm_bit x y) z
  return ()
  where
    errmsg s = "cterm: shape of parameter does not match data: " ++ s

-- | Discard a 'Bit', ignoring its state. This can leave the system in
-- a mixed state, so is not a reversible operation. More generally,
-- discard all the Bits in a data structure. Examples:
-- 
-- > cdiscard b
-- > cdiscard (b0, b1)
-- > cdiscard [b0, b1, b2]
cdiscard :: (CData ca) => ca -> Circ ()
cdiscard ca = do
  qdata_mapM_op (shapetype_c ca) cdiscard_bit ca
  return ()

-- | Heterogeneous version of 'qinit'. Please note that the type of
-- the result of this function cannot be inferred from the type of the
-- argument. For example, 
-- 
-- > x <- qc_init False
-- 
-- is ambiguous, unless it can be inferred from the context whether
-- /x/ is a 'Bit' or a 'Qubit'. If the type cannot be inferred from
-- the context, it needs to be stated explicitly, like this:
-- 
-- > x <- qc_init False :: Circ Qubit
--    
-- Alternatively, 'qc_init_with_shape' can be used to fix a specific
-- type.
qc_init :: (QCData qc) => BType qc -> Circ qc
qc_init bs = qc_init_with_shape (undefined :: qc) bs

-- | A version of 'qc_init' that uses a shape type parameter. The
-- first argument is the shape type parameter, and the second argument
-- is a data structure containing boolean initializers. The shape type
-- argument determines which booleans are used to initialize qubits,
-- and which ones are used to initialize classical bits.
-- 
-- Example:
-- 
-- > (x,y) <- qc_init_with_shape (bit,[qubit]) (True, [False,True])
-- 
-- This will assign to /x/ a classical bit initialized to 1, and to
-- /y/ a list of two qubits initialized to |0〉 and |1〉, respectively.
qc_init_with_shape :: (QCData qc) => qc -> BType qc -> Circ qc
qc_init_with_shape shape bs = qcdata_mapM shape qinit_qubit cinit_bit bs

-- | Heterogeneous version of 'qterm'. 
qc_term :: (QCData qc) => BType qc -> qc -> Circ ()
qc_term bs qc = do
  let bs' = qcdata_promote bs qc errmsg
  let z = qcdata_zip qc bool bool qubit bit bs' qc errmsg
  qcdata_mapM_op qc map_qubit map_bit z 
  return ()
  where    
    
    map_qubit :: (Bool, Qubit) -> Circ ()
    map_qubit (b,q) = qterm_qubit b q

    map_bit :: (Bool, Bit) -> Circ ()
    map_bit (b,q) = cterm_bit b q

    errmsg s = "qc_term: shape of parameter does not match data: " ++ s

-- | Heterogeneous version of 'qdiscard'.
qc_discard :: (QCData qc) => qc -> Circ ()
qc_discard qc = do
  qcdata_mapM_op qc qdiscard_qubit cdiscard_bit qc
  return ()

-- ----------------------------------------------------------------------
-- ** Measurement and preparation

-- | Measure a 'Qubit', resulting in a 'Bit'. More generally, measure
-- all the Qubits in a quantum data structure, resulting in a
-- corresponding data structure of Bits. This is not a reversible
-- operation. Examples:
-- 
-- > b <- measure q
-- > (b0, b1) <- measure (q0, q1)
-- > [b0, b1, b2] <- measure [q0, q1, q2]
measure :: (QShape ba qa ca) => qa -> Circ ca
measure qa = qdata_mapM_op (shapetype_q qa) measure_qubit qa

-- | Prepare a 'Qubit' initialized from a 'Bit'. More generally,
-- prepare a data structure of Qubits, initialized from a corresponding
-- data structure of Bits. Examples:
-- 
-- > q <- prepare b
-- > (q0, q1) <- prepare (b0, b1)
-- > [q0, q1, q2] <- prepare [b0, b1, b2]
prepare :: (QShape ba qa ca) => ca -> Circ qa
prepare ca = qdata_mapM (shapetype_c ca) prepare_qubit ca

-- | Heterogeneous version of 'measure'. Given a heterogeneous data
-- structure, measure all of its qubits, and leave any classical bits
-- unchanged.
qc_measure :: (QCData qc) => qc -> Circ (QCType Bit Bit qc)
qc_measure qc = qcdata_mapM_op qc measure_qubit do_bit qc 
  where 
    do_bit :: Bit -> Circ Bit
    do_bit = return                                                         

-- | Heterogeneous version of 'prepare'. Given a heterogeneous data
-- structure, prepare qubits from all classical bits, and leave any
-- qubits unchanged.
qc_prepare :: (QCData qc) => qc -> Circ (QCType Qubit Qubit qc)
qc_prepare qc = qcdata_mapM qc do_qubit prepare_qubit qc 
  where
    do_qubit :: Qubit -> Circ Qubit
    do_qubit = return

-- ----------------------------------------------------------------------
-- * Global phase gate
  
-- | Like 'global_phase', except the gate is also \"anchored\" at a
-- qubit, a bit, or more generally at some quantum data. The anchor
-- is only used as a hint for graphical display. The gate, which is a
-- zero-qubit gate, will potentially be displayed near the anchor(s).
global_phase_anchored :: (QCData qc) => Double -> qc -> Circ ()
global_phase_anchored t qc = global_phase_anchored_list t qs where
  qs = endpoints_of_qcdata qc

-- ----------------------------------------------------------------------
-- * Mapped gates

-- | Apply a Hadamard gate to every qubit in a quantum data structure.
map_hadamard :: (QData qa) => qa -> Circ qa
map_hadamard = mapUnary hadamard

-- | Imperative version of 'map_hadamard'.
map_hadamard_at :: (QData qa) => qa -> Circ ()
map_hadamard_at qa = do
  map_hadamard qa
  return ()

-- | Apply a swap gate to two qubits. More generally, apply swap gates
-- to every corresponding pair of qubits in two pieces of quantum
-- data.
swap :: (QCData qc) => qc -> qc -> Circ (qc,qc)
swap a b = qc_mapBinary swap_qubit swap_bit a b

-- | Apply a swap gate to two qubits. More generally, apply swap gates
-- to every corresponding pair of qubits in two pieces of quantum
-- data.
swap_at :: (QCData qc) => qc -> qc -> Circ ()
swap_at a b = do
  swap a b
  return ()

-- | Apply a controlled-not gate to every corresponding pair of
-- quantum or classical bits in two pieces of QCData. The first
-- argument is the target and the second the (positive) control.  
-- 
-- For now, we require both pieces of QCData to have the same type,
-- i.e., classical bits can be controlled only by classical bits and
-- quantum bits can be controlled only by quantum bits.
-- 
-- Example:
-- 
-- > ((a',b'), (x,y)) <- controlled_not (a,b) (x,y)
-- 
-- is equivalent to
-- 
-- > a' <- qnot a `controlled` x
-- > b' <- qnot b `controlled` y
controlled_not :: (QCData qc) => qc -> qc -> Circ (qc, qc)
controlled_not qc ctrl = do
  let z = qcdata_zip qc qubit bit qubit bit qc ctrl errmsg
  z' <- qcdata_mapM qc map_qubit map_bit z
  let (qc', ctrl') = qcdata_unzip qc qubit bit qubit bit z'
  return (qc', ctrl')
  where
    
    map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit)
    map_qubit (q,c) = do
      qnot_at q `controlled` c
      return (q,c)

    map_bit :: (Bit, Bit) -> Circ (Bit, Bit)
    map_bit (b,c) = do
      cnot_at b `controlled` c
      return (b,c)

    errmsg s = "controlled_not: shapes of control and controlee do not match: " ++ s

-- | Imperative version of 'controlled_not'. Apply a controlled-not
-- gate to every corresponding pair of quantum or classical bits in
-- two pieces of QCData. The first argument is the target and the
-- second the (positive) control.
controlled_not_at :: (QCData qc) => qc -> qc -> Circ ()
controlled_not_at a b = do
  controlled_not a b
  return ()

-- | A version of 'controlled_not' where the control consists of
-- boolean data. Example:
-- 
-- > bool_controlled_not (q, r, s) (True, True, False)
-- 
-- negates /q/ and /r/, but not /s/.
bool_controlled_not :: (QCData qc) => qc -> BType qc -> Circ qc
bool_controlled_not qc a = do
  bool_controlled_not_at qc a
  return qc

-- | A version of 'controlled_not_at' where the control consists of
-- boolean data. Example:
-- 
-- > bool_controlled_not_at (q, r, s) (True, True, False)
-- 
-- negates /q/ and /r/, but not /s/.
bool_controlled_not_at :: (QCData qc) => qc -> BType qc -> Circ ()
bool_controlled_not_at qc a = do
  qmultinot_list_at vq 
  cmultinot_list_at vc 
  where
    v = Map.toList $ qc_bind qc a
    vq = [ (qubit_of_wire q, b) | (q, Endpoint_Qubit b) <- v ]
    vc = [ (bit_of_wire c, b) | (c, Endpoint_Bit b) <- v ]

-- | Negate all qubits in a quantum data structure.
qmultinot :: (QData qa) => qa -> Circ qa
qmultinot qa = do
  qmultinot_at qa
  return qa

-- | Negate all qubits in a quantum data structure.
qmultinot_at :: (QData qa) => qa -> Circ ()
qmultinot_at qa =
  qmultinot_list_at [ (q,True) | q <- qubits_of_qdata qa ]

-- ----------------------------------------------------------------------
-- ** Copying and uncopying

-- | Initialize a new piece of quantum data, as a copy of a given
-- piece.  Returns both the original and the copy.
qc_copy_fun :: (QCData qc) => qc -> Circ (qc,qc)
qc_copy_fun orig = do
  copy <- qc_init (qc_false orig)
  (copy, orig) <- controlled_not copy orig
  return (orig, copy)
    
-- | Given two pieces of quantum data, assumed equal (w.r.t. the
-- computational basis), terminate the second piece (and return the
-- first, unmodified). This is the inverse of 'qc_copy_fun', in the sense
-- that the following sequence of instructions behaves like the
-- identity function:
-- 
-- > (orig, copy) <- qc_copy_fun orig
-- > orig <- qc_uncopy_fun orig copy
qc_uncopy_fun :: (QCData qc) => qc -> qc -> Circ qc
qc_uncopy_fun orig copy = reverse_generic qc_copy_fun orig (orig,copy) 

-- | Create a fresh copy of a piece of quantum data. Note: copying is
-- performed via a controlled-not operation, and is not cloning. This
-- is similar to 'qc_copy_fun', except it returns only the copy, and not
-- the original.
qc_copy :: (QCData qc) => qc -> Circ qc
qc_copy qc = do
  (qc, qc1) <- qc_copy_fun qc
  return qc1

-- | \"Uncopy\" a piece of quantum data; i.e. terminate /copy/,
-- assuming it's a copy of /orig/. This is the inverse of
-- 'qc_copy', in the sense that the following sequence of
-- instructions behaves like the identity function:
-- 
-- > b <- qc_copy a
-- > qc_uncopy a b
qc_uncopy :: (QCData qc) => qc -> qc -> Circ ()
qc_uncopy orig copy = do
  qc_uncopy_fun orig copy
  return ()

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

-- | If /a/ is 'True', return a copy of /b/, else return a copy of
-- /c/. Here /b/ and /c/ can be any data structures consisting of
-- Bits, but /b/ and /c/ must be of the same type and shape (for
-- example, if they are lists, they must be of equal
-- length). Examples:
-- 
-- > output <- cgate_if a b c
-- > (out0, out1) <- cgate_if a (b0, b1) (c0, c1)
-- > [out0, out1, out2] <- cgate_if a [b0, b1, b2] [c0, c1, c2]
cgate_if :: (CData ca) => Bit -> ca -> ca -> Circ ca
cgate_if a b c = do
  let shape = shapetype_c b
  let z = qdata_zip shape bit bit b c errmsg
  d <- qdata_mapM shape (\(x,y) -> cgate_if_bit a x y) z
  return d
  where
    errmsg s = "cgate_if: shapes of 'then' and 'else' part do not match: " ++ s

-- | 'circ_if' is an if-then-else function for classical circuits. 
-- It is a wrapper around 'cgate_if', intended to be used like this:
-- 
-- > result <- circ_if <<<condition>>> (
-- >   <<then-part>>>
-- >   )(
-- >   <<<else-part>>>
-- >   )
-- 
-- Unlike 'cgate_if', this is a meta-operation, i.e., the bodies of
-- the \"then\" and \"else\" parts can be circuit building
-- operations. 
-- 
-- What makes this different from the usual boolean \"if-then-else\"
-- is that the condition is of type 'Bit', i.e., it is only known at
-- circuit execution time. Therefore the generated circuit contains
-- /both/ the \"then\" and \"else\" parts, suitably
-- controlled. Precondition: the \"then\" and \"else\" parts must be
-- of the same type and shape.
circ_if :: (CData ca) => Bit -> Circ ca -> Circ ca -> Circ ca
circ_if a b c = do
  b' <- b
  c' <- c
  cgate_if a b' c'

-- ----------------------------------------------------------------------
-- ** Named gates

-- | Define a new functional-style gate of the given name. Like
-- 'named_gate', except that the generated gate is extended with
-- \"generalized controls\". The generalized controls are additional
-- inputs to the gate that are guaranteed not to be modified if they
-- are in a computational basis state. They are rendered in a special
-- way in circuit diagrams. Usage:
-- 
-- > my_new_gate :: (Qubit,Qubit) -> Qubit -> Circ (Qubit,Qubit)
-- > my_new_gate = extended_named_gate "Q"
-- 
-- This defines a new gate with name \"Q\", two inputs, and one
-- generalized input.
extended_named_gate :: (QData qa, QData qb) => String -> qa -> qb -> Circ qa
extended_named_gate name operands gencontrols = do
  named_gate_qulist_at name False (qubits_of_qdata operands) (qubits_of_qdata gencontrols)
  return operands

-- | Like 'extended_named_gate', except defines an imperative style gate.
-- Usage:
-- 
-- > my_new_gate_at :: (Qubit,Qubit) -> Qubit -> Circ ()
-- > my_new_gate_at = extended_named_gate_at "Q"
-- 
-- This defines a new gate with name \"Q\", two inputs, and one
-- generalized input.
extended_named_gate_at :: (QData qa, QData qb) => String -> qa -> qb -> Circ ()
extended_named_gate_at name operands gencontrols = do
  extended_named_gate name operands gencontrols
  return ()

-- | Define a new functional-style gate of the given name. Usage:
-- 
-- > my_unary_gate :: Qubit -> Circ Qubit
-- > my_unary_gate = named_gate "Q"
-- 
-- > my_binary_gate :: (Qubit, Qubit) -> Circ (Qubit, Qubit)
-- > my_binary_gate = named_gate "R"
--   
-- This defines a new unary gate and a new binary gate, which will be
-- rendered as \"Q\" and \"R\", respectively, in circuit diagrams. 

-- Implementation note: contrary to our usual convention, the binary
-- gate defined above is not in curried form. It would be nice to have
-- a version of this operator that curries the gate.
named_gate :: (QData qa) => String -> qa -> Circ qa
named_gate name operands = do
  extended_named_gate name operands ()

-- | Define a new imperative-style gate of the given name. Usage:
-- 
-- > my_unary_gate_at :: Qubit -> Circ ()
-- > my_unary_gate_at = named_gate_at "Q"
-- 
-- > my_binary_gate_at :: (Qubit, Qubit) -> Circ ()
-- > my_binary_gate_at = named_gate_at "R"
--   
-- This defines a new unary gate and a new binary gate, which will be
-- rendered as \"Q\" and \"R\", respectively, in circuit diagrams. 

named_gate_at :: (QData qa) => String -> qa -> Circ ()
named_gate_at name operands = do
  named_gate name operands
  return ()

-- | Define a new functional-style gate of the given name, and
-- parameterized by a real-valued parameter. This is typically used
-- for rotations or phase gates that are parameterized by an angle.
-- The name can contain \'%\' as a place holder for the parameter.
-- Usage:
-- 
-- > my_unary_gate :: Qubit -> Circ Qubit
-- > my_unary_gate = named_rotation "exp(-i%Z)" 0.123
-- 
-- > my_binary_gate :: TimeStep -> (Qubit, Qubit) -> Circ (Qubit, Qubit)
-- > my_binary_gate t = named_rotation "Q(%)" t
named_rotation :: (QData qa) => String -> Timestep -> qa -> Circ qa
named_rotation name theta operands = do
  named_rotation_qulist_at name False theta (qubits_of_qdata operands) []
  return operands

-- | Define a new imperative-style gate of the given name, and
-- parameterized by a real-valued parameter. This is typically used
-- for rotations or phase gates that are parameterized by an angle.
-- The name can contain \'%\' as a place holder for the parameter.
-- Usage:
-- 
-- > my_unary_gate_at :: Qubit -> Circ ()
-- > my_unary_gate_at = named_rotation "exp(-i%Z)" 0.123
-- 
-- > my_binary_gate_at :: TimeStep -> (Qubit, Qubit) -> Circ ()
-- > my_binary_gate_at t = named_rotation "Q(%)" t
named_rotation_at :: (QData qa) => String -> Timestep -> qa -> Circ ()
named_rotation_at name theta operands = do
  named_rotation name theta operands
  return ()

----------------------------------------------------------------------
-- ** Dynamic lifting

-- | Convert a 'Bit' (boolean circuit output) to a 'Bool' (boolean
-- parameter). More generally, convert a data structure of Bits to a
-- corresponding data structure of Bools.
-- 
-- For use in algorithms that require the output of a measurement to
-- be used as a circuit-generation parameter. This is the case, for
-- example, for sieving methods, and also for some iterative
-- algorithms.
-- 
-- Note that this is not a gate, but a meta-operation. The input
-- consists of classical circuit endpoints (whose values are known at
-- circuit execution time), and the output is a boolean parameter
-- (whose value is known at circuit generation time). 
-- 
-- The use of this operation implies an interleaving between circuit
-- execution and circuit generation. It is therefore a (physically)
-- expensive operation and should be used sparingly. Using the
-- 'dynamic_lift' operation interrupts the batch mode operation of the
-- quantum device (where circuits are generated ahead of time), and
-- forces interactive operation (the quantum device must wait for the
-- next portion of the circuit to be generated). This operation is
-- especially expensive if the current circuit contains unmeasured
-- qubits; in this case, the qubits must be preserved while the
-- quantum device remains on standby.
-- 
-- Also note that this operation is not supported in all contexts. It
-- is an error, for example, to use this operation in a circuit that
-- is going to be reversed, or in the body of a boxed subroutine.
-- Also, not all output devices (such as circuit viewers) support this
-- operation.
dynamic_lift :: (QShape ba qa ca) => ca -> Circ ba
dynamic_lift ca = qdata_mapM (shapetype_c ca) dynamic_lift_bit ca

-- ----------------------------------------------------------------------
-- * Mapping

-- | Map a single qubit gate across every qubit in the data structure.
mapUnary :: (QData qa) => (Qubit -> Circ Qubit) -> qa -> Circ qa
mapUnary f qa = qdata_mapM (shapetype_q qa) f qa

-- | Map a binary gate across every corresponding pair of qubits in
-- two quantum data structures of equal shape.
mapBinary :: (QData qa) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> qa -> qa -> Circ (qa, qa)
mapBinary f q1 q2 = do
  let shape = shapetype_q q1
  let z = qdata_zip shape qubit qubit q1 q2 errmsg
  z' <- qdata_mapM shape (\(x,y) -> f x y) z
  let (q1', q2') = qdata_unzip shape qubit qubit z'
  return (q1', q2')
  where
    errmsg s = "mapBinary: shapes of arguments do not match: " ++ s
  
-- | Like 'mapBinary', except the second data structure is classical.
mapBinary_c :: (QShape ba qa ca) => (Qubit -> Bit -> Circ (Qubit, Bit)) -> qa -> ca -> Circ (qa, ca)
mapBinary_c f q1 c2 = do
  let shape = shapetype_q q1
  let z = qdata_zip shape qubit bit q1 c2 errmsg
  z' <- qdata_mapM shape (\(x,y) -> f x y) z
  let (q1', c2') = qdata_unzip shape qubit bit z'
  return (q1', c2')
  where
    errmsg s = "mapBinary_c: shapes of arguments do not match: " ++ s

-- | Map a binary qubit circuit to every pair of qubits in the quantum
-- data-type. It is a run-time error if the two structures do not have
-- the same size.
map2Q :: (QData qa) => ((Qubit, Qubit) -> Circ Qubit) -> (qa, qa) -> Circ qa
map2Q f (q,p) = do
  let shape = shapetype_q q
  let z = qdata_zip shape qubit qubit q p errmsg
  d <- qdata_mapM shape f z
  return d
  where
    errmsg s = "map2Q: shapes of arguments do not match: " ++ s
  
-- | Heterogeneous version of 'mapBinary'. Map a binary gate /f/
-- across every corresponding pair of qubits, and a binary gate /g/
-- across every corresponding pair of bits, in two quantum data
-- structures of equal shape.
qc_mapBinary :: (QCData qc) => (Qubit -> Qubit -> Circ (Qubit, Qubit)) -> (Bit -> Bit -> Circ (Bit, Bit)) -> qc -> qc -> Circ (qc, qc)
qc_mapBinary f g x y = do
  let z = qcdata_zip x qubit bit qubit bit x y errmsg
  z' <- qcdata_mapM x map_qubit map_bit z
  let (x', y') = qcdata_unzip x qubit bit qubit bit z'
  return (x', y')
  where
    
    map_qubit :: (Qubit, Qubit) -> Circ (Qubit, Qubit)
    map_qubit (x,y) = f x y

    map_bit :: (Bit, Bit) -> Circ (Bit, Bit)
    map_bit (x,y) = g x y

    errmsg s = "qc_mapBinary: shapes of arguments do not match: " ++ s

-- ----------------------------------------------------------------------
-- * Conversion to lists

-- $CONVERSION The functions in this section can be used to convert
-- quantum data structures to and from lists. Do not use them! The
-- conversion is unsafe in the same way pointers to void are unsafe in
-- the C programming language. There is almost always a better and
-- more natural way to accomplish what you need to do.

-- | Return the list of qubits representing the given quantum data.
-- The qubits are ordered in some fixed, but arbitrary way. It is
-- guaranteed that two pieces of qdata of the same given shape will be
-- ordered in the same way. No other property of the order is
-- guaranteed, In particular, the order may change without notice from
-- one version of Quipper to the next.
qubits_of_qdata :: (QData qa) => qa -> [Qubit]
qubits_of_qdata qa = qdata_sequentialize (shapetype_q qa) qa

-- | Take a specimen piece of quantum data to specify the \"shape\"
-- desired (length of lists, etc); then reads the given list of qubits
-- in as a piece of quantum data of the same shape. The ordering of
-- the input qubits is the same as 'qubits_of_qdata' produces for the
-- given shape.
-- 
-- A \"length mismatch\" error occurs if the list does not have
-- exactly the required length.
qdata_of_qubits :: (QData qa) => qa -> [Qubit] -> qa
qdata_of_qubits qa list = qdata_unsequentialize qa list

-- | Return the list of endpoints that form the leaves of the given
-- 'QCData'. The leaves are ordered in some fixed, but arbitrary
-- way. It is guaranteed that two pieces of data of the same given
-- shape will be ordered in the same way. No other property of the
-- order is guaranteed. In particular, the order may change without notice from
-- one version of Quipper to the next.
endpoints_of_qcdata :: (QCData qc) => qc -> [Endpoint]
endpoints_of_qcdata qc = qcdata_sequentialize qc qc

-- | Take a specimen piece of 'QCData' to specify the \"shape\"
-- desired (length of lists, etc); then reads the given list of
-- endpoints in as a piece of quantum data of the same shape. The
-- ordering of the input endpoints equals that produced by
-- 'endpoints_of_qcdata' for the given shape.
-- 
-- A \"length mismatch\" error occurs if the list does not have
-- exactly the required length. A \"shape mismatch\" error occurs if
-- the list contains a 'Qubit' when a 'Bit' was expected, or vice versa. 
qcdata_of_endpoints :: (QCData qc) => qc -> [Endpoint] -> qc
qcdata_of_endpoints qc list = qcdata_unsequentialize qc list where

-- | Take a specimen piece of 'QCData' to specify a shape;
-- return a 'CircuitTypeStructure' that structures appropriate
-- lists of wires with arities into data of this shape, and conversely
-- destructures data of this shape into wires and an arity.
--
-- The caveats mentioned in 'endpoints_of_qcdata' apply equally for
-- this function.
circuit_type_structure_of_qcdata :: (QCData qc) => qc -> CircuitTypeStructure qc
circuit_type_structure_of_qcdata qc = CircuitTypeStructure
  (wires_with_arity_of_endpoints . endpoints_of_qcdata)
  (\(ws,a) -> qcdata_of_endpoints qc $ endpoints_of_wires_in_arity a ws)

-- ----------------------------------------------------------------------
-- * Shape related operations

-- | Return a boolean data structure of the given shape, with every
-- leaf initialized to 'False'.
qc_false :: (QCData qc) => qc -> BType qc
qc_false qc = qcdata_map qc map_qubit map_bit qc 
  where
    map_qubit = const False :: Qubit -> Bool
    map_bit = const False :: Bit -> Bool

-- | Return a quantum data structure of the given boolean shape, with
-- every leaf initialized to the undefined dummy value 'qubit'.
qshape :: (QData qa) => BType qa -> qa
qshape ba = qdata_map (shapetype_b ba) map_qubit ba
  where
    map_qubit = const qubit :: Bool -> Qubit

-- ----------------------------------------------------------------------
-- * Bindings

-- | Take two pieces of quantum data of the same shape (the first of
-- which consists of wires of a low-level circuit) and create
-- bindings.
qc_bind :: (QCData qc) => qc -> QCType a b qc -> Bindings a b
qc_bind qc as = qc_bind_aux qc as bindings_empty
  where
    -- This can't be inlined without upsetting the type checker.
    qc_bind_aux :: (QCData qc) => qc -> QCType a b qc -> Bindings a b -> Bindings a b
    qc_bind_aux qc as (bind_in :: Bindings a b) = bindings where
      a = (dummy :: a) -- shape type
      b = (dummy :: b) -- shape type
      z = qcdata_zip qc qubit bit a b qc as errmsg
      bindings = qcdata_fold qc do_qubit do_bit z bind_in
  
    do_qubit :: (Qubit, a) -> Bindings a b -> Bindings a b
    do_qubit (q, binding) = bind_qubit q binding
  
    do_bit :: (Bit, b) -> Bindings a b -> Bindings a b
    do_bit (c, binding) = bind_bit c binding

    errmsg s = "qc_bind: shapes of arguments do not match: " ++ s

-- | Apply bindings to a piece of quantum and/or classical data
-- holding low-level wires, to get data of the same shape.
qc_unbind :: (QCData qc) => Bindings a b -> qc -> QCType a b qc
qc_unbind (bindings :: Bindings a b) qc =
  qcdata_map qc map_qubit map_bit qc
  where
    map_qubit :: Qubit -> a
    map_qubit q = unbind_qubit bindings q
    
    map_bit :: Bit -> b
    map_bit b = unbind_bit bindings b

-- ======================================================================
-- * Generic controls

-- $CONTROL The following functions define a convenient syntax for
-- controls. With this, we can write controls in much the same way as
-- one would write (a restricted class of) boolean
-- expressions. Examples:
-- 
-- > q1 .==. 0 .&&. q2 .==. 1         for Qubits q1, q2
-- 
-- > q .&&. p                         means  q .==. 1  .&&.  p .==. 1
-- 
-- > qx .==. 5                        for a QDInt qx
-- 
-- > q1 .==. 0 .&&. z <= 7            we can combine quantum and classical controls
-- 
-- > q ./=. b                         the negation of q .==. b;
-- >                                  here b is a boolean.
-- 
-- > [p,q,r,s]                        a list of positive controls
-- 
-- > [(p, True), (q, False), (r, False), (s, True)]
-- >                                  a list of positive and negative controls
--
-- Among these infix operators, @(.&&.)@ binds more weakly than
-- @(.==.)@, @(./=.)@.

-- | Given a piece of quantum data and a possible value for it, return
-- a 'ControlList' representing the condition that the quantum data
-- has that value.
-- 
-- If some aspect of the value's shape is indeterminate, it is
-- promoted to the same shape as the quantum data; therefore, it is
-- possible, for example, to write:
-- 
-- > qc_control qa 17          -- when qa :: QDInt
-- > qc_control qa [False..]   -- when qa :: [Qubit]
qc_control :: (QCData qc) => qc -> BType qc -> ControlList
qc_control qc b = clist where
  b' = qcdata_promote b qc errmsg
  z = qcdata_zip qc qubit bit bool bool qc b' errmsg
  clist = qcdata_fold qc do_qubit do_bit z clist_empty
  
  do_qubit :: (Qubit, Bool) -> ControlList -> ControlList
  do_qubit (q, b) = clist_add_qubit q b
  
  do_bit :: (Bit, Bool) -> ControlList -> ControlList
  do_bit (c, b) = clist_add_bit c b

  errmsg s = "qc_control: shape of control value does not match data: " ++ s

-- | This is an infix operator to concatenate two controls, forming
-- their logical conjunction.
(.&&.) :: (ControlSource a, ControlSource b) => a -> b -> ControlList
exp1 .&&. exp2 = combine (to_control exp1) (to_control exp2)

-- | @(qx .==. x)@: a control which is true just if quantum data /qx/ is in the specified state /x/. 
(.==.) :: (QCData qc) => qc -> BType qc -> ControlList
qx .==. x = qc_control qx x

-- | The notation @(q ./=. x)@ is shorthand for @(q .==. not x)@, when
-- /x/ is a boolean parameter. 
-- 
-- Unlike '.==.', which is defined for any shape of quantum data,
-- './=.' is only defined for a single control bit or qubit.
(./=.) :: (QCLeaf q) => q -> Bool -> ControlList
q ./=. b = to_control [Signed q (not b)]

-- Set the precedence for infix operators '.&&.', '.==.', and './=.'.
infixr 3 .&&. -- same precedence as (&&)
infix 4 .==. -- same precedence as (==)
infix 4 ./=. -- same precedence as (/=)

-- The following allows us to write 0 and 1 instead of 'False' and
-- 'True' everywhere.
instance Num Bool where
  (+) = (/=) 
  (*) = (&&)
  (-) = (/=)
  negate = id
  signum = id
  abs = id
  fromInteger n = (n `mod` 2 == 1)

-- ======================================================================
-- * Generic encapsulation

-- $encapsulate
-- 
-- An encapsulated circuit is a low-level circuit together with data
-- structures holding the input endpoints and output endpoints. A
-- circuit-generating function, with fully specified parameters, can
-- be turned into an encapsulated circuit; conversely, an encapsulated
-- circuit can be turned into a circuit-generating function. Thus,
-- encapsulation and unencapsulation are the main interface for
-- passing between high- and low-level data structures.

-- | Allocate new quantum data of the given shape, in the given
-- arity. Returns the quantum data and the updated arity.
qc_alloc :: (QCData qc) => qc -> ExtArity -> (qc, ExtArity)
qc_alloc qc arity = qcdata_fold_map qc do_qubit do_bit qc arity where
  
  do_qubit :: Qubit -> ExtArity -> (Qubit, ExtArity)
  do_qubit q arity = (qubit_of_wire w, a) 
    where
      (w, a) = arity_alloc Qbit arity
  
  do_bit :: Bit -> ExtArity -> (Bit, ExtArity)
  do_bit c arity = (bit_of_wire w, a)
    where
      (w, a) = arity_alloc Cbit arity

-- | Extract an encapsulated circuit from a circuit-generating
-- function. This requires a shape parameter.
encapsulate_generic :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> (x, BCircuit, y)
encapsulate_generic e f shape = (x, circ, y) where
  (x, arity) = qc_alloc shape arity_empty
  (circ, y) = extract_simple e arity (f x)

-- | As 'encapsulate_generic', but passes the current namespace
-- into the circuit-generating function, to save recomputing
-- shared subroutines
encapsulate_generic_in_namespace :: (QCData x) => ErrMsg -> (x -> Circ y) -> x -> Circ (x, BCircuit, y)
encapsulate_generic_in_namespace e f shape = do
  let (x, arity) = qc_alloc shape arity_empty
  (circ, y) <- extract_in_current_namespace e arity (f x)
  return (x, circ, y)

-- | Turn an encapsulated circuit back into a circuit-generating
-- function.
unencapsulate_generic :: (QCData x, QCData y) => (x, BCircuit, y) -> (x -> Circ y)
unencapsulate_generic (c_in, c, c_out) input = do
  let in_bindings = qc_bind c_in input
  out_bindings <- apply_bcircuit_with_bindings c in_bindings
  let output = qc_unbind out_bindings c_out
  return output

-- $dynamic_encapsulate
-- 
-- A dynamic encapsulated circuit is to an encapsulated circuit like a
-- 'DBCircuit' to a 'BCircuit'. The output is not a static circuit,
-- but an interactive computation expressed through the 'ReadWrite'
-- monad, which can be run on a quantum device to get a static circuit
-- out.

-- | Extract an encapsulated dynamic circuit from a circuit-generating
-- function. This requires a shape parameter.
encapsulate_dynamic :: (QCData x) => (x -> Circ y) -> x -> (x, DBCircuit y)
encapsulate_dynamic f shape = (x, comp) where
  (x, arity) = qc_alloc shape arity_empty
  comp = extract_general arity (f x)

-- | Turn an encapsulated dynamic circuit back into a
-- circuit-generating function.
-- 
-- This currently fails if the dynamic circuit contains output
-- liftings, because the transformer interface has not yet been
-- updated to work with dynamic circuits.
unencapsulate_dynamic :: (QCData x, QCData y) => (x, DBCircuit y) -> (x -> Circ y)
unencapsulate_dynamic (c_in, comp) input = do
  let in_bindings = qc_bind c_in input
  (out_bindings, c_out) <- apply_dbcircuit_with_bindings comp in_bindings
  let output = qc_unbind out_bindings c_out
  return output

-- ======================================================================
-- * Generic reversing

-- | Like 'reverse_unary', but also takes a stub error message. 
reverse_errmsg :: (QCData x, QCData y) => ErrMsg -> (x -> Circ y) -> x -> (y -> Circ x)
reverse_errmsg e f shape y = do
  circuit <- encapsulate_generic_in_namespace errmsg f shape
  let circuit_inv = reverse_encapsulated circuit
      f_inv = unencapsulate_generic circuit_inv
  f_inv y
  where
    errmsg x = e ("operation not permitted in reversible circuit: " ++ x)

-- | Reverse a non-curried circuit-generating function. The second
-- parameter is a shape parameter.
reverse_unary :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x)
reverse_unary = reverse_errmsg errmsg 
  where
    errmsg x = "reverse_unary: " ++ x

-- | Reverse a circuit-generating function. The reversed function
-- requires a shape parameter, given as the input type of the original
-- function.
-- 
-- The type of this highly overloaded function is quite difficult to
-- read.  It can have for example the following types:
-- 
-- > reverse_generic :: (QCData x, QCData y) => (x -> Circ y) -> x -> (y -> Circ x) 
-- > reverse_generic :: (QCData x, QCData y, QCData z) => (x -> y -> Circ z) -> x -> y -> (z -> Circ (x,y)) 
reverse_generic :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y, Curry x_y_xt x (y -> Circ xt)) => x_y -> x_y_xt
reverse_generic f = 
  mcurry $ aux f
  where
    -- An auxiliary function for defining 'reverse_generic'.  (Inlining
    -- this causes difficulty with the type inference for 'mcurry'.)
    --aux :: (QCData x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> x -> (y -> Circ xt)
    aux f shape =
      (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) shape)

    errmsg x = "reverse_generic: " ++ x

-- | Like 'reverse_generic', but takes functions whose output is a
-- tuple, and curries the reversed function.  Differs from
-- 'reverse_generic' in an example such as:
-- 
-- > f                         :: (x -> y -> Circ (z,w))
-- > reverse_generic f         :: x -> y -> ((z,w) -> Circ (x,y))
-- > reverse_generic_curried f :: x -> y -> (z -> w -> Circ (x,y))
-- 
-- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥
-- 2. Applying this to a circuit whose output is a non-tuple type is a
-- type error; in this case, 'reverse_generic' should be used.
reverse_generic_curried :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt, Curry x_y_xt x y_xt) => x_yt -> x_y_xt
reverse_generic_curried f = 
  mcurry $ aux f
  where
    -- An auxiliary function for 'reverse_generic_curried'.  (Inlining
    -- this causes difficulty with the type inference for 'mcurry'.)
    aux :: (QCData x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt) => x_yt -> x -> y_xt
    aux f = 
      (qcurry .) $ \x y -> (fmap weak_tuple) $ (reverse_errmsg errmsg $ (fmap untuple) . (quncurry f)) x y

    errmsg x = "reverse_generic_curried: " ++ x

-- | Like 'reverse_generic', but only works at simple types, and
-- therefore requires no shape parameters.  Typical type instances:
-- 
-- > reverse_simple :: (QCData_Simple x, QCData y) => (x -> Circ y) -> (y -> Circ x)
-- > reverse_simple :: (QCData_Simple x, QCData_Simple y, QCData z) => (x -> y -> Circ z) -> (z -> Circ (x,y))
reverse_simple :: (QCData_Simple x, QCData y, TupleOrUnary xt x, QCurry x_y x y) => x_y -> y -> Circ xt
reverse_simple f = (fmap weak_tuple) . (reverse_errmsg errmsg (quncurry f) fs_shape)
  where
    errmsg x = "reverse_simple: " ++ x

-- | Like 'reverse_simple', but takes functions whose output is a
-- tuple, and curries the reversed function. Typical type instance:
-- 
-- > reverse_simple_curried :: (QCData_Simple x, QCData y, QCData z) => (x -> Circ (y,z)) -> (y -> z -> Circ x)
-- 
-- Note: the output /must/ be a /n/-tuple, where /n/ = 0 or /n/ ≥
-- 2. Applying this to a circuit whose output is a non-tuple type is a
-- type error; in this case, 'reverse_generic' should be used.
reverse_simple_curried :: (QCData_Simple x, QCData y, TupleOrUnary xt x, Tuple yt y, QCurry x_yt x yt, QCurry y_xt y xt)
  => x_yt -> y_xt
reverse_simple_curried f = qcurry $ 
  (fmap weak_tuple) . (reverse_errmsg errmsg ((fmap untuple) . (quncurry f)) fs_shape)
  where
    errmsg x = "reverse_simple_curried: " ++ x

-- | Like 'reverse_generic', but specialized to endomorphic circuits,
-- i.e., circuits where the input and output have the same type (modulo
-- possibly currying) and shape. In this case, unlike 'reverse_generic',
-- no additional shape parameter is required, and the reversed function
-- is curried if the original function was.  Typical type instances:
-- 
-- > reverse_generic_endo :: (QCData x) => (x -> Circ x) -> (x -> Circ x)
-- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ (x,y)) -> (x -> y -> Circ (x,y))
reverse_generic_endo :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => x_xt -> x_xt
reverse_generic_endo = qcurry . ((fmap weak_tuple) .) . 
                         (\f x -> reverse_errmsg errmsg f x x)
                                       . ((fmap weak_untuple) .) . quncurry
  where
    errmsg x = "reverse_generic_endo: " ++ x

-- | Like 'reverse_generic_endo', but applies to endomorphic circuits
-- expressed in \"imperative\" style. Typical type instances:
-- 
-- > reverse_generic_endo :: (QCData x) => (x -> Circ ()) -> (x -> Circ ())
-- > reverse_generic_endo :: (QCData x, QCData y) => (x -> y -> Circ ()) -> (x -> y -> Circ ())
reverse_generic_imp :: (QCData x, QCurry x__ x ()) => x__ -> x__
reverse_generic_imp f = qcurry $ \input -> do
  reverse_generic_endo f' input
  return ()
  where
    f' x = do
      (quncurry f) x
      return x
    
-- | Conditional version of 'reverse_generic_endo'. Invert the
-- endomorphic quantum circuit if the boolean is true; otherwise,
-- insert the non-inverted circuit.
reverse_endo_if :: (QCData x, TupleOrUnary xt x, QCurry x_xt x xt) => Bool -> x_xt -> x_xt
reverse_endo_if False f = f
reverse_endo_if True f = reverse_generic_endo f

-- | Conditional version of 'reverse_generic_imp'. Invert the
-- imperative style quantum circuit if the boolean is true; otherwise,
-- insert the non-inverted circuit.
reverse_imp_if :: (QCData qa, QCurry fun qa ()) => Bool -> fun -> fun
reverse_imp_if False f = f
reverse_imp_if True f = reverse_generic_imp f

-- ======================================================================
-- * The QCurry type class

-- | The 'QCurry' type class is similar to the 'Curry' type class,
-- except that the result type is guarded by the 'Circ' monad. It
-- provides a family of type isomorphisms
-- 
-- @fun  ≅  args -> Circ res,@
-- 
-- where
-- 
-- > fun = a1 -> a2 -> ... -> an -> Circ res,
-- > args = (a1, (a2, (..., (an, ())))).
-- 
-- The benefit of having @Circ@ in the result type is that it ensures
-- that the result type is not itself a function type, and therefore
-- /fun/ has a /unique/ arity /n/. Then /args/ and /res/ are uniquely
-- determined by /fun/, which can be used to write higher-order
-- operators that consume /fun/ of any arity and \"do the right
-- thing\".
  
class QCurry fun args res | fun -> args res, args res -> fun where
  qcurry :: (args -> Circ res) -> fun
  quncurry :: fun -> (args -> Circ res)
  
instance QCurry (Circ b) () b where
  qcurry g = g ()
  quncurry x = const x

instance QCurry fun args res => QCurry (a -> fun) (a,args) res where
  qcurry g x = qcurry (\xs -> g (x,xs))
  quncurry f (x,xs) = quncurry (f x) xs

-- ======================================================================
-- * Generic circuit transformations

-- | Like 'transform_unary_shape', but also takes a stub error message.
transform_errmsg :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => ErrMsg -> Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y')
transform_errmsg e transformer f shape input = do
  let (x, circuit, y) = encapsulate_generic errmsg f shape
  let in_bind = qc_bind x input
  out_bind <- transform_bcircuit_rec transformer circuit in_bind
  let output = qc_unbind out_bind y
  return output
  where
    errmsg x = e ("operation not currently permitted in transformed circuit: " ++ x)

-- | Like 'transform_generic', but applies to arbitrary transformers
-- of type
-- 
-- > Transformer m a b
-- 
-- instead of the special case
-- 
-- > Transformer Circ Qubit Bit.
-- 
-- This requires an additional shape argument. 
transform_unary_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> (x -> Circ y) -> x -> (x' -> m y')
transform_unary_shape = transform_errmsg errmsg 
  where
    errmsg x = "transform_unary_shape: " ++ x

-- | Apply the given transformer to a circuit.
transform_unary :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y)
transform_unary transformer f x = transform_errmsg errmsg transformer f x x
  where
    errmsg x = "transform_unary: " ++ x


-- | Like transform_unary_shape but for a dynamic transformer
transform_unary_dynamic_shape :: (QCData x, QCData y, x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => DynamicTransformer m a b -> (x -> Circ y) -> x -> (x' -> m y')
transform_unary_dynamic_shape dtransformer f shape input = do
  let (x, dbcircuit) = encapsulate_dynamic f shape
  let in_bind = qc_bind x input
  (y,out_bind) <- transform_dbcircuit dtransformer dbcircuit in_bind
  let output = qc_unbind out_bind y
  return output

-- | Like transform_unary but for a dynamic transformer
transform_unary_dynamic :: (QCData x, QCData y) => DynamicTransformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y)
transform_unary_dynamic dtransformer f x = transform_unary_dynamic_shape dtransformer f x x


-- | Like 'transform_generic', but applies to arbitrary transformers
-- of type
-- 
-- > Transformer m a b
-- 
-- instead of the special case
-- 
-- > Transformer Circ Qubit Bit.
-- 
-- This requires an additional shape argument. 
-- 
-- The type of this heavily overloaded function is difficult to
-- read. In more readable form, it has all of the following types:
-- 
-- > transform_generic :: (QCData x) => Transformer m a b -> Circ x -> m (QCData a b x)
-- > transform_generic :: (QCData x, QCData y) => Transformer m a b -> (x -> Circ y) -> x -> (QCData a b x -> m (QCData a b y))
-- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer m a b -> (x -> y -> Circ z) -> x -> y -> (QCData a b x -> QCData a b y -> m (QCData a b z))
-- 
-- and so forth.

transform_generic_shape :: (QCData x, QCData y, QCurry qfun x y, Curry qfun' x' (m y'), Curry qfun'' x qfun', x' ~ QCType a b x, y' ~ QCType a b y, Monad m) => Transformer m a b -> qfun -> qfun''
transform_generic_shape transformer f = g where
  f1 = quncurry f
  g1 = transform_errmsg errmsg transformer f1
  g2 = \x -> mcurry (g1 x)
  g = mcurry g2
  errmsg x = "transform_generic: " ++ x

-- | Apply the given transformer to a circuit.  Unlike
-- 'transform_unary', this function can be applied to a
-- circuit-generating function in curried form with /n/ arguments, for
-- any /n/ ≥ 0.
-- 
-- The type of this heavily overloaded function is difficult to
-- read. In more readable form, it has all of the following types:
-- 
-- > transform_generic :: (QCData x) => Transformer Circ Qubit Bit -> Circ x -> Circ x
-- > transform_generic :: (QCData x, QCData y) => Transformer Circ Qubit Bit -> (x -> Circ y) -> (x -> Circ y)
-- > transform_generic :: (QCData x, QCData y, QCData z) => Transformer Circ Qubit Bit -> (x -> y -> Circ z) -> (x -> y -> Circ z)
-- 
-- and so forth.

transform_generic :: (QCData x, QCData y, QCurry qfun x y) => Transformer Circ Qubit Bit -> qfun -> qfun
transform_generic transformer f = g where
  f1 = quncurry f
  g1 = \x -> transform_errmsg errmsg transformer f1 x x
  g = qcurry g1
  errmsg x = "transform_generic: " ++ x


-- ======================================================================
-- * Generic block structure

-- | Execute a block with local ancillas. Opens a block, initializing an ancilla with a specified classical value, and terminates it with the same value when the block closes. Note: it is the programmer's responsibility to return the ancilla to its original state at the end of the enclosed block. Usage:
-- 
-- > with_ancilla_init True $ \a -> do {
-- >   <<<code block using ancilla a initialized to True>>>
-- > }
-- 
-- > with_ancilla_init [True,False,True] $ \a -> do {
-- >   <<<code block using list of ancillas a initialized to [True,False,True]>>>
-- > }
with_ancilla_init :: (QShape a qa ca) => a -> (qa -> Circ b) -> Circ b
with_ancilla_init x f = do
  qx <- without_controls (qinit x)
  qy <- f qx
  without_controls (qterm x qx)
  return qy

-- | Like 'with_ancilla', but creates a list of /n/ ancillas, all
-- initialized to |0〉. Usage:
-- 
-- > with_ancilla_list n $ \a -> do {
-- >   <<<code block using list of ancillas a>>>
-- > }
with_ancilla_list :: Int -> (Qulist -> Circ a) -> Circ a
with_ancilla_list n f = 
  with_ancilla_init (replicate n False) f

-- | @'with_computed_fun' /x/ /f/ /g/@: computes /x' := f(x)/; then computes /g(x')/, which should be organized as a pair /(x',y)/; then uncomputes /x'/ back to /x/, and returns /(x,y)/.
-- 
-- Important subtlety in usage: all quantum data referenced in /f/, even as controls, must be explicitly bound and returned by /f/, or the reversing may rebind it incorrectly.  /g/, on the other hand, can safely refer to anything that is in scope outside the 'with_computed_fun'.
 
with_computed_fun :: (QCData x, QCData y) => x -> (x -> Circ y) -> (y -> Circ (y,b)) -> Circ (x,b)
with_computed_fun x f g = do
  y <- without_controls (f x)  
  (y,b) <- g y
  x <- without_controls (reverse_generic f x y)
  return (x,b)

-- | @'with_computed' /computation/ /code/@: performs /computation/
-- (with result /x/), then performs /code/ /x/, and finally performs
-- the reverse of /computation/, for example like this:
-- 
-- \[image with_computed.png]
-- 
-- Both /computation/ and /code/ may refer to any qubits that exist in
-- the current environment, and they may also create new
-- qubits. /computation/ may produce arbitrary garbage in addition to
-- its output. 
-- 
-- This is a very general but relatively unsafe operation. It is the
-- user's responsibility to ensure that the computation can indeed be
-- undone. In particular, if /computation/ contains any
-- initializations, then /code/ must ensure that the corresponding
-- assertions will be satisfied in /computation/[sup −1].
-- 
-- Related more specialized, but potentially safer, operations are: 
-- 
-- * 'with_basis_change', which is like 'with_computed', but assumes
-- that /computation/ is unitary, and
-- 
-- * 'Quipper.classical_to_reversible', which assumes that /computation/ is
-- classical (or pseudo-classical), and /code/ is a simple
-- copy-by-controlled-not operation.

with_computed :: (QCData x) => Circ x -> (x -> Circ b) -> Circ b
with_computed computation code = do
  (bcirc, dirty, x) <- extract_in_context errmsg computation
  without_controls $ do
    unextract_in_context bcirc
  y <- with_reserve dirty $ do
    code x
  without_controls $ do
    unextract_in_context (reverse_bcircuit bcirc)
  return y
  where
    errmsg x = "with_computed: operation not permitted in pre-computation: " ++ x

-- | @'with_basis_change' /basischange/ /code/@: performs a basis change,
-- then the /code/, then the inverse of the basis change. Both
-- /basischange/ and /code/ are in imperative style. It is the user's
-- responsibility to ensure that the image of /code/ is contained in
-- the image of /basischange/, or else there will be unmet assertions
-- or runtime errors. Usage:
-- 
-- > with_basis_change basischange $ do
-- >   <<<code>>>
-- >
-- > where
-- >   basischange = do
-- >     <<<gates>>>

with_basis_change :: Circ () -> Circ b -> Circ b
with_basis_change basischange code = do
  with_computed basischange (\x -> code)

-- ======================================================================
-- * Boxed subcircuits


-- | Bind a name to a function as a subroutine in the current
-- namespace. This requires a shape argument, as well as complete
-- parameters, so that it is uniquely determined which actual circuit
-- will be the subroutine. It is an error to call that subroutine
-- later with a different shape argument. It is therefore the user's
-- responsibility to ensure that the name is unique to the subroutine,
-- parameters, and shape. 
--
-- This function does nothing if the name
-- already exists in the namespace; in particular, it does /not/ check
-- whether the given function is equal to the stored subroutine. 
provide_subroutine_generic :: (QCData x, QCData y) => ErrMsg -> BoxId -> Bool -> (x -> Circ y) -> x -> Circ ()
provide_subroutine_generic e name is_classically_controllable f shape = do
  main_state <- get_namespace
  if (Map.member name main_state)
  then return ()
  else do
    (x, bcircuit, y) <- encapsulate_generic_in_namespace errmsg f shape

    -- The 'y' element only corresponds to the output type of the box,
    -- not the complete list of wires outputted by the circuit. This
    -- information is gathered and stored in forgotten_output_qcdata
    -- as ([Qubit],[Bit]).
    let ((_,_,aout,_),_) = bcircuit
        forgotten_output_arity  = strip_qcdata_from_arity y aout
        forgotten_output_qcdata = extract_from_arity forgotten_output_arity

    let ein = endpoints_of_qcdata x
        eout = endpoints_of_qcdata (y,forgotten_output_qcdata)
        win = map wire_of_endpoint ein
        wout = map wire_of_endpoint eout

        input_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata
        input_structure = (\(ws,a) -> qcdata_of_endpoints x $ endpoints_of_wires_in_arity a ws)

        input_CircTypeStructure = CircuitTypeStructure input_destructure input_structure 

        output_destructure = wires_with_arity_of_endpoints . endpoints_of_qcdata
        output_structure = (\(ws,a) -> qcdata_of_endpoints (y,forgotten_output_qcdata) $ endpoints_of_wires_in_arity a ws)

        output_CircTypeStructure = CircuitTypeStructure output_destructure output_structure 

    provide_subroutine name (ob_circuit win bcircuit wout) input_CircTypeStructure output_CircTypeStructure is_classically_controllable
    where
      errmsg x = e ("operation not permitted in boxed subroutine: " ++ x)

      -- Make a 'QCData' out of an arity.
      extract_from_arity :: Arity -> ([Qubit],[Bit])
      extract_from_arity x =
        fst $ IntMap.mapAccumWithKey record_wire ([],[]) x
        where
          record_wire :: ([Qubit],[Bit]) -> Int -> Wiretype -> (([Qubit],[Bit]),Wiretype)
          record_wire (qs,bs) wire Qbit = (((qubit_of_wire wire):qs,bs), Qbit)
          record_wire (qs,bs) wire Cbit = ((qs,(bit_of_wire wire):bs), Cbit)

      -- Take a 'QCData' /x/ and an 'Arity' /a/ and remove all the wires
      -- of /a/ that are already existing in /x/.
      strip_qcdata_from_arity :: (QCData x) => x -> Arity -> Arity
      strip_qcdata_from_arity x a =
        snd $ State.runState (qcdata_mapM x delete_qubit delete_bit x) a
        where
          
          delete_qubit :: Qubit -> State.State Arity ()
          delete_qubit q = do
            s <- State.get
            State.put $ flip IntMap.delete s $ wire_of_qubit q
          
          delete_bit :: Bit -> State.State Arity ()
          delete_bit b = do
            s <- State.get
            State.put $ flip IntMap.delete s $ wire_of_bit b






-- | A generic interface for wrapping a circuit-generating function
-- into a boxed and named subroutine. This takes a name and a
-- circuit-generating function, and returns a new circuit-generating
-- function of the same type, but which inserts a boxed subroutine
-- instead of the actual body of the subroutine.
-- 
-- It is intended to be used like this:
-- 
-- > somefunc :: Qubit -> Circ Qubit
-- > somefunc a = do ...
-- > 
-- > somefunc_boxed :: Qubit -> Circ Qubit
-- > somefunc_boxed = box "somefunc" somefunc
-- 
-- Here, the type of @somefunc@ is just an example; this could indeed
-- be a function with any number and type of arguments, as long as the
-- arguments and return type are quantum data.
-- 
-- It is also possible to inline the 'box' operator directly, in which
-- case it should be done like this:
-- 
-- > somefunc :: Qubit -> Circ Qubit
-- > somefunc = box "somefunc" $ \a -> do ...
-- 
-- Note: The 'box' operator wraps around a complete function,
-- including all of its arguments. It would be incorrect to apply the
-- 'box' operator after some quantum variables have already been
-- defined. Thus, the following is incorrect:
-- 
-- > incorrect_somefunc :: Qubit -> Circ Qubit
-- > incorrect_somefunc a = box "somefunc" $ do ...
-- 
-- It is the user's responsibility not to use the same name for
-- different subroutines. If 'box' is called more than once with the
-- same name and shape of input, Quipper assumes, without checking,
-- that they are subsequent calls to the same subroutine. 
-- 
-- The type of the 'box' operator is overloaded and quite difficult to
-- read.  It can have for example the following types:
-- 
-- > box :: String -> (Qubit -> Circ Qubit) -> (Qubit -> Circ Qubit)
-- > box :: String -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt)) -> (QDInt -> QDInt -> Circ (QDInt,QDInt,QDInt))
box :: (QCData qa, QCData qb, QCurry qa_qb qa qb)
    => String -> qa_qb -> qa_qb
box n = qcurry . (box_internal err n $ RepeatFlag 1) . quncurry
  where
    err e = "box: " ++ e

-- | A version of 'box' with iteration. The second argument is an
-- iteration count.
-- 
-- This can only be applied to functions of a single argument, where
-- the input and output types are the same.
nbox :: (QCData qa) => String -> Integer -> (qa -> Circ qa) -> qa -> Circ qa
nbox n rep = qcurry . (box_internal err n (RepeatFlag rep)) . quncurry
  where
    err e = "nbox: " ++ e

-- | A version of 'nbox' with same type as 'loopM'.
box_loopM :: (Integral int, QCData qa)
    => String -> int -> qa -> (qa -> Circ qa) -> Circ qa
box_loopM n rep = flip (nbox  n $ fromIntegral rep)

-- | A version of 'loopM' that will be boxed conditionally on a
-- boolean condition. Typical usage:
-- 
-- > loopM_boxed_if (s > 1) "name" s x $ \x -> do
-- >   <<<body>>>
-- >   return x
loopM_boxed_if :: (Integral int, QCData qa) => Bool -> String -> int -> qa -> (qa -> Circ qa) -> Circ qa
loopM_boxed_if True name = box_loopM name
loopM_boxed_if False name = loopM

-- | The underlying implementation of 'box' and 'nbox'. It behaves
-- like 'box', but is restricted to unary functions, and takes an
-- 'ErrMsg' argument.
box_internal :: (QCData qa, QCData qb)
             => ErrMsg -> String -> RepeatFlag -> (qa -> Circ qb) -> (qa -> Circ qb)
box_internal e n r f x = do
  let boxid = BoxId n (canonical_shape x)
  provide_subroutine_generic e boxid False f x -- By default, fall back on the general controlling scheme: 
                                               -- set the classical-control flag to False.
  call_subroutine boxid r x


-- | Classical control on a function with same shape of input and
-- output: if the control bit is true the function is fired, otherwise
-- the identity map is used.
-- Note: the constraint on the types is dynamically checked.
with_classical_control :: QCData qa => Bit -> String -> qa -> (qa -> Circ qa) -> Circ qa
with_classical_control c n x f = do
  let boxid = BoxId n (canonical_shape x)
  provide_subroutine_generic err boxid True f x
  call_subroutine boxid (RepeatFlag 1) x `controlled` c
 where
  err e = "with_classical_control: " ++ e

-- | Like 'call_subroutine', except inline the subroutine body from
-- the given namespace, instead of inserting a subroutine call.
-- 
-- Implementation note: this currently copies /all/ subroutine
-- definitions from the given namespace into the current namespace,
-- and not just the ones used by the current subroutine.
-- 
-- Implementation note: this currently only works on lists of endpoints.
inline_subroutine :: BoxId -> Namespace -> [Endpoint] -> Circ [Endpoint]
inline_subroutine name ns inputs = do
  let mc = Map.lookup name ns
  case mc of 
    Nothing -> 
      error ("inline_subroutine: subroutine " ++ show name ++ " does not exist in the given namespace: " ++ showNames ns)
    Just (TypedSubroutine ocircuit _ _ scf) -> do
      let OCircuit (win, circuit, wout) = ocircuit
      provide_subroutines ns
      when (length win /= length inputs) $ do
        error ("inline_subroutine: subroutine " ++ show name ++ " has been applied to incorrect size of QCData")
      let in_bind = bind_list win inputs bindings_empty
      out_bind <- apply_circuit_with_bindings circuit in_bind
      let outputs = unbind_list out_bind wout
      return outputs