{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LINE 1 "Quipper/Libraries/ClassicalOptim/QuipperInterface.hs" #-}
-- | This module contains the interface between the simplified circuit
-- model and Quipper's internal circuit model. The main useful
-- exported functions are: 
-- 
-- * @'simplify_classical'@, which optimizes a classical circuit such
-- as those coming from Template Haskell;
-- 
-- * @'classical_to_reversible_optim'@, which provides a mechanism
-- equivalent to @'Q.classical_to_reversible'@, but with optimization
-- inlined.

module Quipper.Libraries.ClassicalOptim.QuipperInterface where

import Data.Maybe

import qualified Data.Map as M
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.IntSet as IS
import qualified Data.IntMap.Strict as IM {- containers-0.5.2.1 -}

import qualified Quipper as Q
import qualified Quipper.Internal.Monad as Q
import qualified Quipper.Internal.QData as Q
import qualified Quipper.Internal.Circuit as Q
import qualified Quipper.Internal.Generic as Q
import qualified Quipper.Internal.Printing as Q
import qualified Quipper.Libraries.Simulation as Q
import qualified Quipper.Libraries.Simulation.ClassicalSimulation as Q
import qualified Quipper.Internal.Transformer as Q
import qualified Quipper.Internal.Control as Q 

import qualified Quipper.Libraries.Arith as Q
import qualified Quipper.Utils.Auxiliary as Q

import Quipper.Libraries.ClassicalOptim.Circuit
import Quipper.Libraries.ClassicalOptim.Simplification


-- ----------------------------------------------------------------------
-- * Auxiliary functions

-- | Extract the list of wires from a piece of quantum data.
getListWire :: (Q.QData qc) => qc -> [Wire]
getListWire x = map Q.wire_of_qubit $ Q.qubits_of_qdata x

-- ----------------------------------------------------------------------
-- * Quipper circuits to simple circuits

-- | Translates a Quipper circuit to a simple circuit. The only gates
-- considered are initializations, terminations, and multi-controlled
-- NOT gates. All other gates are ignored.
-- 
-- Note that simple circuits do not possess termination wires: these
-- wires are simply not terminated, and all subsequent initializations
-- using the same wire ID are sent to fresh wires.
-- 
-- The state of this function is a bit complex, as it keeps track of
-- where the output wires are mapped to.
quipperGateToMyGate :: (IS.IntSet,IM.IntMap Wire,Wire) -> Q.Gate -> ((IS.IntSet,IM.IntMap Wire,Wire), Maybe Gate)
quipperGateToMyGate (s,m,f) (Q.QGate "not" _ [w] _ ctls _) = 
  ((s,m,f), Just $ Cnot (IM.findWithDefault w w m) $ map (\(Q.Signed a b) -> (IM.findWithDefault a a m,b)) ctls)
quipperGateToMyGate (s,m,f) (Q.QInit b w _) = case (IS.member w s) of 
                                              True  -> ((s,IM.insert w f m,f+1), Just $ Init b f)
                                              False -> ((s,m,f), Just $ Init b w)
quipperGateToMyGate (s,m,f) (Q.QTerm b w _) = ((IS.insert w s, m,f), Nothing)
quipperGateToMyGate smf _ = (smf, Nothing)


-- | Get the wire initialized by the gate, if it is an initialization gate.
quipperGateInitW :: Q.Gate -> Maybe Wire
quipperGateInitW (Q.QInit _ w _) = Just w
quipperGateInitW _ = Nothing

-- | Given a list of Quipper gates, get the smallest wire id not in use.
quipperGateFreshWire :: Wire -> [Q.Gate] -> Wire
quipperGateFreshWire w gs = (+) 1 $ L.foldl' max w $ catMaybes $ map quipperGateInitW gs

-- | Send a Quipper 'Q.Circuit' to a 'CircState'.
quipperCircuitToMyCirc :: Q.Circuit -> CircState
quipperCircuitToMyCirc (_, gs, _, n) = 
         emptyState { 
            circuit = catMaybes $ snd $ L.mapAccumL quipperGateToMyGate (IS.empty,IM.empty,quipperGateFreshWire n gs) gs,
            freshWire = n
         }

-- | Send a Quipper 'Q.BCircuit' to a 'CircState'.
quipperBCircuitToMyCirc :: Q.BCircuit -> CircState
quipperBCircuitToMyCirc (c,_) = quipperCircuitToMyCirc c

-- | Generate a custom error message.
myCircErrMsg :: String -> String
myCircErrMsg s = "myCirc: " ++ s

-- | Given a Quipper circuit generating function and a shape argument,
-- return a simple circuit together with the list of non-garbage
-- circuit outputs.
quipperFunToMyCirc :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (CircState,[Wire])
quipperFunToMyCirc f shape =
     let (_, bc, output) = Q.encapsulate_generic myCircErrMsg f shape
     in (quipperBCircuitToMyCirc bc, 
         getListWire output)

-- ----------------------------------------------------------------------
-- * Simple circuits to Quipper circuits

-- | Translate a gate from the simple circuit model into a Quipper gate.
myGateToQuipperGate :: Gate -> Q.Gate
myGateToQuipperGate (Cnot w ctls) = Q.QGate "not" True [w] [] (map (\(w,b) -> Q.Signed w b) ctls) False
myGateToQuipperGate (Init b w) = Q.QInit b w False
myGateToQuipperGate NoOp  = error "myGateToQuipperGate cannot deal with NoOp"

-- | Generate a Quipper comment. The first argument is a comment
-- string, and the second argument is a label to apply to the qubits
-- in the third argument.
makeComment :: String -> String -> [Wire] -> Q.Gate
makeComment comment label ws = 
  Q.Comment comment False $ map (\(i,x) -> (i, label ++ "[" ++ (show x) ++ "]")) (zip ws [0..(length ws)-1])


-- ----------------------------------------------------------------------
-- * Algebraic optimization of Quipper circuits

-- | Optimize a Quipper 'Q.BCircuit'. The second argument is the list
-- of non-garbage outputs. A corresponding list of outputs is also
-- returned along with the circuit.
quipperBCircuitSimpl :: Q.BCircuit -> [Wire] -> (Q.BCircuit,[Wire])
quipperBCircuitSimpl (c,e) output = (((a1,c'',a2',n'),e),o')
   where
   (a1,gs,a2,n) = c
   mycirc = quipperCircuitToMyCirc c
   (c',o') = compressWires (IM.keys a1) $ simplRec $ (\x -> (x,output)) {-set_init_first output-} $ circuit $ mycirc
   i' = IM.keys a1
   c'' = (makeComment "Start classical circuit" "in" i') : 
         (map myGateToQuipperGate c') ++ 
         [makeComment "End classical circuit" "out" o']
   allwires = getAllWires c'
   a2' = IM.fromList $ map (\x -> (x,Q.Qbit)) $ IS.toAscList allwires
   n' = (+) 1 $ head $ IS.toDescList allwires


-- | Optimize a Quipper circuit producing function (together with a
-- shape argument). Return the optimized circuit as a Quipper
-- 'Q.BCircuit', along with a list of the non-garbage circuit outputs.
simplify_classical' :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> (Q.BCircuit, [Wire])
simplify_classical' f shape = 
  let (_,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in
  let list_output = getListWire output in
  quipperBCircuitSimpl bc list_output

-- | Optimize a Quipper circuit-producing function. This assumes that
-- the function only consists of pseudo-classical quantum gates, i.e.,
-- initializations, terminations, and (possibly multiply controlled)
-- NOT gates. The behavior on other kinds of circuits is undefined.
-- The second argument is a shape parameter.
simplify_classical :: (Q.QData x, Q.QData y) => (x -> Q.Circ y) -> x -> Q.Circ y
simplify_classical f shape =
  let (input,bc,output) = Q.encapsulate_generic myCircErrMsg f shape in
  let list_output = getListWire output in
  let (bc',list_output') = quipperBCircuitSimpl bc list_output in
  Q.unencapsulate_generic (input,bc', Q.qdata_of_qubits output $ map Q.qubit_of_wire list_output') shape

-- | Like 'Q.classical_to_reversible', but also apply circuit optimization.
classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb))
classical_to_reversible_optim f = Q.classical_to_reversible (simplify_classical f)

-- | Like 'classical_to_reversible_optim', but insert the optimized
-- circuit as a boxed subroutine.
box_classical_to_reversible_optim :: (Q.QData qa, Q.QData qb) => String -> (qa -> Q.Circ qb) -> ((qa,qb) -> Q.Circ (qa,qb))
box_classical_to_reversible_optim s f = Q.classical_to_reversible (Q.box s $ simplify_classical f)