  This file is part of Quipper . Copyright ( C ) 2011 - 2014 . Please see the
-- file COPYRIGHT for a list of authors, copyright holders, licensing,
-- and other details. All rights reserved.
-- 
-- ======================================================================

# LANGUAGE FlexibleContexts #

-- | This module provides implementations of an oracle for the
  Triangle Finding Algorithm .
--
-- This oracle injects the graph /G/ into the space 
  { 0 , 1 , . . . , 2 / l/ − 1 } of /l/-bit integers , and each oracle
-- call requires the extensive use of modular arithmetic.
--
-- The circuits produced by running this \"orthodox\" oracle are 
-- very big. We therefore also provide a \"blackbox\" oracle, 
-- which is simply a placeholder for an actual oracle call, 
-- to replace the orthodox oracle when running subroutines and 
  for resource estimation .   The oracle circuit is the same every
-- time it is used, so for resource estimation purposes, it only 
-- needs to be generated once, rather than inlined at every use site.

module Algorithms.TF.Oracle where

import Quipper

import Algorithms.TF.Definitions

import Libraries.Auxiliary

-- ======================================================================

  * Orthodox oracle

  | Algorithm O-1 . The two ' QNode ' inputs /u/ and
-- /v/ are assumed to be of equal length.
o1_ORACLE :: Int -> QNode -> QNode -> Qubit -> Circ (QNode,QNode,Qubit)
o1_ORACLE l = box "o1" $ \u v edge -> do
  comment_with_label "ENTER: o1_ORACLE" (u,v,edge) ("u","v","edge")
  let n = length u
      hn = 2^(n-1)

  ((u,v),e) <- with_computed_fun (u,v)
    (o1_ORACLE_aux l hn)
    (\((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) -> do
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 0 .&&. t_u3v3 .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 1 .&&. t_u3v3 .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 0 .&&. t_u3v3 .==. 0 .&&. t_uHvH .==. 0)
      return (((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)),edge))

  comment_with_label "EXIT: o1_ORACLE" (u,v,edge) ("u","v","edge")
  return (u,v,edge)

-- | Compute the various auxiliary data for 'o1_ORACLE'.
o1_ORACLE_aux :: Int -> Int -> (QNode, QNode) -> Circ ((QNode, QNode), (QIntTF, QIntTF, QIntTF, QIntTF, QIntTF, QIntTF), (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit))
o1_ORACLE_aux l hn = box "o1_aux" $ \(u,v) -> do
      comment_with_label "ENTER: o1_ORACLE_aux" (u,v) ("u","v")
      (u,uint) <- o2_ConvertNode l u hn
      (v,vint) <- o2_ConvertNode l v hn
      (uint,vint,t_uv) <- o3_TestEqual uint vint
  Since we do n’t have “ quantum control ” , we ca n’t say “ if t = = True … return ” here ; 
          instead we just add a “ control on  = = False ” to the later flips of ‘ edge ’ .
         instead we just add a “control on t_uv == False” to the later flips of ‘edge’. -}

      (uint,u17) <- o4_POW17 uint
      (uint,u17,uF) <- o3_TestEqual uint u17
      (vint,v17) <- o4_POW17 vint
      (vint,v17,vF) <- o3_TestEqual vint v17

      let uint_bits = qulist_of_qinttf_lh uint
      let vint_bits = qulist_of_qinttf_lh vint
      uH <- qinit False
      uH <- qnot uH `controlled` (uint_bits !! (l-1))
      vH <- qinit False
      vH <- qnot vH `controlled` (vint_bits !! (l-1))
--    Would like to say ”t_uHvH <- qd_testequal uH vH t_uHvH”, if testequal were generic.
      t_uHvH <- qinit True
      t_uHvH <- qnot t_uHvH `controlled` uH
      t_uHvH <- qnot t_uHvH `controlled` vH

      (u17,u3) <- o5_MOD3 u17
      (v17,v3) <- o5_MOD3 v17
      (u3,v3,t_u3v3) <- o3_TestEqual u3 v3
      
      comment_with_label "EXIT: o1_ORACLE_aux" ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) (("u","v"),("uint","vint","u17","v17","u3","v3"),("uF","vF","uH","vH","t_uv","t_uHvH","t_u3v3"))
      return ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3))

-- | Algorithm O-2. Convert a 'QNode' into a freshly assigned 'QIntTF',
o2_ConvertNode :: Int -> QNode -> Int -> Circ (QNode,QIntTF)
o2_ConvertNode l u hn = ($ u) $ box "o2" $ \u -> do
  comment_with_label "ENTER: o2_ConvertNode" u "u"
  let n = if (length u < l) then (length u) else (error ("ConvertNode: requires n < l.  n = " ++ (show (length u)) ++ ", l = " ++ (show l) ++ "."))

  (u, uint) <- with_computed_fun u
    (\u -> do
      (u,w_low) <- qc_copy_fun u
      w_high <- qinit (replicate (l-n) False)
      return (u,qinttf_of_qulist_lh (w_low ++ w_high)))

    (\(u,w) -> do
      (w,uint) <- o6_SUB w hn
      return ((u,w),uint))
  comment_with_label "EXIT: o2_ConvertNode" (u, uint) ("u", "uint")
  return (u, uint)

  | Algorithm O-3 . Compare if two QIntTF ’s are equal ;
-- return the result in a fresh Qubit. 
-- 
  This function is in general iffy : 00 … 00 and 11 … 11 do /not/ test as equal , as they should .
  However , that case does not arise in the oracle : on the one hand , both 00 … 00 and 11 … 11
-- are literal fixed points of 'o4_POW17', and on the other, 'o5_MOD3' never outputs 00. 
o3_TestEqual :: QIntTF -> QIntTF-> Circ (QIntTF,QIntTF,Qubit)
o3_TestEqual = box "o3" $ \x y -> do
  comment_with_label "ENTER: o3_TestEqual" (x,y) ("x", "y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits)
  t <- qinit False
  t <- qnot t `controlled` [ q .==. 0 | q <- y_bits ]
  y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits)
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  comment_with_label "EXIT: o3_TestEqual" (x, y, t) ("x", "y", "t")
  return (x, y, t)

  | Algorithm O-4 . Compute 17th power of a 31 - bit ' QIntTF ' /x/ , into a
  freshly 31 - bit /QIntTF/.
o4_POW17 :: QIntTF -> Circ (QIntTF,QIntTF)
o4_POW17 = box "o4" $ \x -> do
  comment_with_label "ENTER: o4_POW17" x "x"
  (x, x17) <- with_computed_fun x
    (\x -> do
      (x,x2) <- square x
      (x2,x4) <- square x2
      (x4,x8) <- square x4      
      (x8,x16) <- square x8
      return (x,x2,x4,x8,x16))
    
    (\(x,x2,x4,x8,x16) -> do
      (x,x16,x17) <- o8_MUL x x16
      return ((x,x2,x4,x8,x16),x17))
  comment_with_label "EXIT: o4_POW17" (x, x17) ("x", "x17")
  return (x, x17)

  Alternative coding style : 
 o4_POW17 x = do 
   ( x , x17 ) < - with_computed_fun square x ( \(x , x2 ) - > do 
     ( x2,(x , x17 ) ) < - with_computed_fun square x2 ( \(x2,x4 ) - > do 
       ( x4,(x , x17 ) ) < - with_computed_fun square x4 ( \(x4,x8 ) - > do 
         ( x8,(x , x17 ) ) < - with_computed_fun square x8 (  ) - > do 
           ( x , x16,x17 ) < - o8_MUL x x16 
           return ( ( x8,x16),(x , x17 ) ) ) 
         return ( ( x4,x8),(x , x17 ) ) ) 
       return ( (  , x17 ) ) ) 
     return ( ( x , x2),x17 ) ) 
   return ( x , x17 ) 

o4_POW17 x = do
  (x,x17) <- with_computed_fun square x (\(x,x2) -> do
    (x2,(x,x17)) <- with_computed_fun square x2 (\(x2,x4) -> do
      (x4,(x,x17)) <- with_computed_fun square x4 (\(x4,x8) -> do
        (x8,(x,x17)) <- with_computed_fun square x8 (\(x8,x16) -> do
          (x,x16,x17) <- o8_MUL x x16
          return ((x8,x16),(x,x17)))
        return ((x4,x8),(x,x17)))
      return ((x2,x4),(x,x17)))
    return ((x,x2),x17))
  return (x,x17)
-}

-- | Map a QIntTF /x/ to (/x/,/x/^2).
-- 
-- A subroutine factored out of @'o4_POW17'@.
square :: QIntTF -> Circ (QIntTF,QIntTF)
square x = do
--           comment_with_label "ENTER: square" x "x"
           (x, x2) <- with_computed_fun x qc_copy_fun 
             (\(x,x') -> do
               (x,x',x2) <- o8_MUL x x'
               return ((x,x'),x2))
            comment_with_label " EXIT : square " ( x , x2 ) ( " x " , " x2 " )
           return (x, x2)

  | Algorithm O-5 . Compute residue modulo 3 of the lower - order bits of a
  ' QIntTF ' , into a fresh 2 - bit ' QIntTF ' .
-- 
  This algorithm is size - limited — works for up to 31 - bit integers , but not beyond .
-- 
-- This also currently is mismatched with our specification of QIntTF, since it 
  produces output in the range 1–3 , rather than 0–2 .   However , output of this
-- algorithm is only used via '03_TestEqual', so this is not a problem in practice. 
o5_MOD3 :: QIntTF -> Circ (QIntTF,QIntTF)
o5_MOD3 = box "o5" $ \x -> do
  comment_with_label "ENTER: o5_MOD3" x "x"
  let x_bits = qulist_of_qinttf_lh x
  let l = length x_bits
      l' = if (l <= 31) then (l `div` 2)
                        else error "o5_MOD3: requires l <= 31"
  (x_bits, m_bits) <- with_computed_fun x_bits
    (\x_bits -> do
      s5 <- mmap qulist_of_qinttf_lh $ qinit (inttf 5 15)
    
      (x_bits,s5) <- loop_with_indexM l' (x_bits,s5) (\i (x_bits,s5) -> do
        s5 <- increment_little s5 `controlled` (x_bits !! (2*i))
        s5 <- if (2*i + 1 <= l - 2) -- in case l is even, skip this step on the last iteration. 
              then decrement_little s5 `controlled` (x_bits !! (2*i + 1))
              else return s5
        return (x_bits,s5))

      s3 <- mmap qulist_of_qinttf_lh $ qinit (inttf 3 3)

      (s5,s3) <- loop_with_indexM 2 (s5,s3) (\i (s5,s3) -> do
        s3 <- increment_little s3 `controlled` (s5 !! (2*i))
        s3 <- decrement_little s3 `controlled` (s5 !! (2*i + 1))
        return (s5,s3))
      s3 <- increment_little s3 `controlled` (s5 !! 4)
  
      let s3_high = last s3
          s2 = init s3
      s2 <- increment_little s2 `controlled` s3_high

      return (x_bits,s5,s3_high,s2))

    (\(x_bits,s5,s3_high,s2) -> do
      (s2,m_bits) <- qc_copy_fun s2
      return ((x_bits,s5,s3_high,s2), m_bits))
  let x = qinttf_of_qulist_lh x_bits
  let m = qinttf_of_qulist_lh m_bits
  comment_with_label "EXIT: o5_MOD3" (x, m) ("x", "m")
  return (x, m)

-- | Algorithm O-6. Subtract an integer parameter from a 'QIntTF'.  
  Return the result as a second , freshly assigned ' QIntTF ' .
o6_SUB :: QIntTF -> Int -> Circ (QIntTF,QIntTF)
o6_SUB x y = ($ x) $ box "o6" $ \x -> do
 comment_with_label "ENTER: o6_SUB" x "x"
 (x, d_out) <- with_computed_fun x
  (\x1 -> do
    let x = qulist_of_qinttf_lh x1
    let l = length x
    let y_bits = reverse (boollist_of_int_bh l y)  -- the little-endian binary rep of /y/
  
    d <- qinit (replicate l False) -- will be [the list of bits of] the eventual answer
    d1 <- qinit (replicate l False) -- will hold an intermediate version of the
  subtraction , not “ corrected ” modulo ( 2^l – 1 ) .
    c1 <- qinit (replicate (l+1) False)

    (c1,d1,x) <- loop_with_indexM l (c1,d1,x) (\j (c1,d1,x) -> do
      let c1_j1 = c1 !! (j+1)
      let d1_j = d1 !! j
      c1_j1 <- if y_bits !! j 
              then return c1_j1
              else qnot c1_j1 `controlled` (x !! j)
      c1_j1 <- qnot c1_j1 `controlled` (x !! j) .&&. (c1 !! j)
      c1_j1 <- if  y_bits !! j 
              then return c1_j1
              else qnot c1_j1 `controlled` (c1!!j)
      d1_j <- qnot d1_j `controlled` (x !! j)
      d1_j <- if y_bits !! j 
             then return d1_j
             else qnot d1_j
      d1_j <- qnot d1_j `controlled` (c1 !! j)
      c1 <- return $ overwriteAt (j+1) c1_j1 c1
      d1 <- return $ overwriteAt j d1_j d1
      return (c1,d1,x))

    c2 <- qinit (replicate (l+1) False)
    c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
    c2 <- return $ overwriteAt 0 c2_0 c2
  
    (d,d1,c2) <- loop_with_indexM l (d,d1,c2) (\j (d,d1,c2) -> do
      let c2_j1 = c2 !! (j+1)
      let dj = d !! j
      c2_j1 <- qnot c2_j1 `controlled` (d1 !! j) .&&. (c2 !! j)
      dj <- qnot dj `controlled` (d1 !! j)
      dj <- qnot dj `controlled` (c2 !! j)
      c2 <- return $ overwriteAt (j+1) c2_j1 c2
      d <- return $ overwriteAt j dj d
      return (d,d1,c2))
  
    d_0 <- qnot (d !! 0) `controlled` (c2 !! l)
    d <- return $ overwriteAt 0 d_0 d
    return (x,d,d1,c1,c2))
  -- Having computed the difference /d/ along with much auxiliary data, we save a 
  -- copy of /d/ before undoing all the computation:
  (\(x,d,d1,c1,c2) -> do
     (d,d_out) <- qc_copy_fun d
     return ((x,d,d1,c1,c2),qinttf_of_qulist_lh d_out))
 comment_with_label "EXIT: o6_SUB" (x, d_out) ("x", "d_out")
 return (x, d_out)
  
  | Algorithm O-7 . Add two ' QIntTF 's .   Return the result as a third , freshly assigned ' QIntTF ' .
o7_ADD :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o7_ADD = box "o7" $ \x y -> do 
  comment_with_label "ENTER: o7_ADD" (x, y) ("x", "y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  let l = length x_bits

  ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits)
    (\(x_bits,y_bits) -> do
      s <- qinit (replicate l False) -- holds the eventual sum
      s1 <- qinit (replicate l False) -- holds the uncorrected sum
      c1 <- qinit (replicate (l+1) False) -- holds the carries

      (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do
        let c1_j1 = c1 !! (j+1)
        let s1_j = s1 !! j
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j)
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j)
        c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j)
        s1_j <- qnot s1_j `controlled` (x_bits !! j)
        s1_j <- qnot s1_j `controlled` (y_bits !! j)
        s1_j <- qnot s1_j `controlled` (c1 !! j)
        c1 <- return $ overwriteAt (j+1) c1_j1 c1
        s1 <- return $ overwriteAt j s1_j s1
        return (c1,s1,x_bits,y_bits))

      c2 <- qinit (replicate (l+1) False)
      c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
      c2 <- return $ overwriteAt 0 c2_0 c2
  
      (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do
        let c2_j1 = c2 !! (j+1)
        let sj = s !! j
        c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j)
        sj <- qnot sj `controlled` (s1 !! j)
        sj <- qnot sj `controlled` (c2 !! j)
        c2 <- return $ overwriteAt (j+1) c2_j1 c2
        s <- return $ overwriteAt j sj s
        return (s,s1,c2))
  
      s_0 <- qnot (s !! 0) `controlled` (c2 !! l)
      s <- return $ overwriteAt 0 s_0 s
      
      return (x_bits,y_bits,s,s1,c1,c2))
    
    (\(x_bits,y_bits,s,s1,c1,c2) -> do
      (s,s_out) <- qc_copy_fun s
      return ((x_bits,y_bits,s,s1,c1,c2), s_out))
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  let s = qinttf_of_qulist_lh s_out
  comment_with_label "EXIT: o7_ADD" (x, y, s) ("x", "y", "s")
  return (x, y, s)

  | Controlled version of ' o7_ADD ' . Returns either a copy of the first
-- input (if controls are “off”) or the sum of the inputs 
-- (if controls are “on”).
--
-- We make this version explicitly, rather than just using 'controlled',
-- because the controls only need to be applied to a very few selected 
-- gates in the routine.
o7_ADD_controlled :: (ControlSource ctrl, Labelable ctrl String)
                  => ctrl -> QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o7_ADD_controlled controls x y = do
  comment_with_label "ENTER: o7_ADD_controlled" (controls,x,y) ("ctrl","x","y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  let l = length x_bits

  ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits)
    (\(x_bits,y_bits) -> do
      s <- qinit (replicate l False) -- holds the eventual sum
      s1 <- qinit (replicate l False) -- holds the uncorrected sum
      c1 <- qinit (replicate (l+1) False) -- holds the carries

      (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do
        let c1_j1 = c1 !! (j+1)
        let s1_j = s1 !! j
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j)
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j)
        c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j)
        s1_j <- qnot s1_j `controlled` (x_bits !! j)
        s1_j <- qnot s1_j `controlled` (y_bits !! j)
        s1_j <- qnot s1_j `controlled` (c1 !! j)
        c1 <- return $ overwriteAt (j+1) c1_j1 c1
        s1 <- return $ overwriteAt j s1_j s1
        return (c1,s1,x_bits,y_bits))

      c2 <- qinit (replicate (l+1) False)
      c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
      c2 <- return $ overwriteAt 0 c2_0 c2
  
      (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do
        let c2_j1 = c2 !! (j+1)
        let sj = s !! j
        c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j)
        sj <- qnot sj `controlled` (s1 !! j)
        sj <- qnot sj `controlled` (c2 !! j)
        c2 <- return $ overwriteAt (j+1) c2_j1 c2
        s <- return $ overwriteAt j sj s
        return (s,s1,c2))
  
      s_0 <- qnot (s !! 0) `controlled` (c2 !! l)
      s <- return $ overwriteAt 0 s_0 s
      
      return (x_bits,y_bits,s,s1,c1,c2))

    (\(x_bits,y_bits,s,s1,c1,c2) -> do
      -- Prepare a qubit holding the value of the controls,
      -- since we want to control also on their negation.
  /Can’t/ include this in “ with_computed_fun ” : controls ca n’t be bound
  as QData , and including it unbound yields rather interesting bug .
      temp_control <- qinit False
      temp_control <- qnot temp_control `controlled` controls
      s_out <- qinit (replicate l False)
      (x_bits,s_out) <- mapBinary 
                     (\q q' -> do
                       q' <- qnot q' `controlled` (q .&&. (temp_control .==. 0))
                       return (q,q')) 
                     x_bits s_out
      (s,s_out) <- mapBinary 
                     (\q q' -> do
                       q' <- qnot q' `controlled` (q .&&. (temp_control .==. 1))
                       return (q,q'))
                     s s_out
      temp_control <- qnot temp_control `controlled` controls
      qterm False temp_control
      return ((x_bits,y_bits,s,s1,c1,c2), s_out))
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  let s = qinttf_of_qulist_lh s_out
  comment_with_label "EXIT: o7_ADD_controlled" (x,y,s) ("x","y","s")
  return (x, y, s)


-- | Algorithm O-8. Multiply two 'QIntTF's; return the 
  result as a third , freshly assigned ' QIntTF ' .
o8_MUL :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o8_MUL = box "o8" $ \x y -> do
--  comment_with_label "ENTER: o8_MUL" (x,y) ("x","y")
  let x_bits = qulist_of_qinttf_lh x
  let l = length x_bits

  ((x,y),p) <- with_computed_fun (x,y)
    (\(x, y) -> do
      let x_bits = qulist_of_qinttf_lh x
      -- We will build up a register of partial products, each obtained from the previous
  by adding ( 2^i * y ) if the ith bit of x is set .
      -- For this, we make a copy of y, to be repeatedly doubled as we go.
      (y,tmp_y) <- qc_copy_fun y
      wrk0 <- qinit (inttf l 0)
      (tmp_y,wrks) <- loop_with_indexM l (tmp_y,[wrk0]) 
        (\k (tmp_y,(wrk_prev:wrks_older)) -> do
          (wrk_prev,tmp_y,wrk_new)
            <- o7_ADD_controlled (x_bits !! k) wrk_prev tmp_y
          tmp_y <- double_TF tmp_y
          return (tmp_y,(wrk_new:wrk_prev:wrks_older)))
      return ((qinttf_of_qulist_lh x_bits),y,tmp_y,wrks))

    (\(x,y,tmp_y,(wrks_head:wrks_rest)) -> do
      (wrks_head,p) <- qc_copy_fun wrks_head
      return ((x,y,tmp_y,(wrks_head:wrks_rest)), p))

   comment_with_label " EXIT : o8_MUL " ( x , y , p ) ( " x","y","p " )
  return (x,y,p)

-- | Double a 'QIntTF' in place.
-- 
-- A subroutine factored out of 'o8_MUL'.
double_TF :: QIntTF -> Circ QIntTF
double_TF x = do
  comment_with_label "ENTER: double_TF" x "x"
  x <- case qulist_of_qinttf_lh x of
    [] -> return (qinttf_of_qulist_lh [])
    x_bits -> return (qinttf_of_qulist_lh ((last x_bits):(init x_bits)))
  comment_with_label "EXIT: double_TF" x "x"
  return x

-- ======================================================================

  * Blackbox oracle

-- | A black-box oracle for testing. Produces a labelled black-box gate in
-- place of the actual oracle circuit.

placeholder_oracle :: QNode -> QNode -> Qubit -> Circ Qubit
placeholder_oracle node1 node2 outp_bit = do 
  comment_with_label "placeholder_oracle" (node1, node2, outp_bit) ("node1", "node2", "outp_bit")       
  extended_named_gate_at "OC" [outp_bit] (node1 ++ node2)
  return outp_bit



 file COPYRIGHT for a list of authors, copyright holders, licensing,
 and other details. All rights reserved.
 
 ======================================================================
 | This module provides implementations of an oracle for the

 This oracle injects the graph /G/ into the space 
 call requires the extensive use of modular arithmetic.

 The circuits produced by running this \"orthodox\" oracle are 
 very big. We therefore also provide a \"blackbox\" oracle, 
 which is simply a placeholder for an actual oracle call, 
 to replace the orthodox oracle when running subroutines and 
 time it is used, so for resource estimation purposes, it only 
 needs to be generated once, rather than inlined at every use site.
 ======================================================================
 /v/ are assumed to be of equal length.
 | Compute the various auxiliary data for 'o1_ORACLE'.
    Would like to say ”t_uHvH <- qd_testequal uH vH t_uHvH”, if testequal were generic.
 | Algorithm O-2. Convert a 'QNode' into a freshly assigned 'QIntTF',
 return the result in a fresh Qubit. 
 
 are literal fixed points of 'o4_POW17', and on the other, 'o5_MOD3' never outputs 00. 
 | Map a QIntTF /x/ to (/x/,/x/^2).
 
 A subroutine factored out of @'o4_POW17'@.
           comment_with_label "ENTER: square" x "x"
 
 
 This also currently is mismatched with our specification of QIntTF, since it 
 algorithm is only used via '03_TestEqual', so this is not a problem in practice. 
 in case l is even, skip this step on the last iteration. 
 | Algorithm O-6. Subtract an integer parameter from a 'QIntTF'.  
 the little-endian binary rep of /y/
 will be [the list of bits of] the eventual answer
 will hold an intermediate version of the
 Having computed the difference /d/ along with much auxiliary data, we save a 
 copy of /d/ before undoing all the computation:
 holds the eventual sum
 holds the uncorrected sum
 holds the carries
 input (if controls are “off”) or the sum of the inputs 
 (if controls are “on”).

 We make this version explicitly, rather than just using 'controlled',
 because the controls only need to be applied to a very few selected 
 gates in the routine.
 holds the eventual sum
 holds the uncorrected sum
 holds the carries
 Prepare a qubit holding the value of the controls,
 since we want to control also on their negation.
 | Algorithm O-8. Multiply two 'QIntTF's; return the 
  comment_with_label "ENTER: o8_MUL" (x,y) ("x","y")
 We will build up a register of partial products, each obtained from the previous
 For this, we make a copy of y, to be repeatedly doubled as we go.
 | Double a 'QIntTF' in place.
 
 A subroutine factored out of 'o8_MUL'.
 ======================================================================
 | A black-box oracle for testing. Produces a labelled black-box gate in
 place of the actual oracle circuit.
  This file is part of Quipper . Copyright ( C ) 2011 - 2014 . Please see the

# LANGUAGE FlexibleContexts #

  Triangle Finding Algorithm .
  { 0 , 1 , . . . , 2 / l/ − 1 } of /l/-bit integers , and each oracle
  for resource estimation .   The oracle circuit is the same every

module Algorithms.TF.Oracle where

import Quipper

import Algorithms.TF.Definitions

import Libraries.Auxiliary


  * Orthodox oracle

  | Algorithm O-1 . The two ' QNode ' inputs /u/ and
o1_ORACLE :: Int -> QNode -> QNode -> Qubit -> Circ (QNode,QNode,Qubit)
o1_ORACLE l = box "o1" $ \u v edge -> do
  comment_with_label "ENTER: o1_ORACLE" (u,v,edge) ("u","v","edge")
  let n = length u
      hn = 2^(n-1)

  ((u,v),e) <- with_computed_fun (u,v)
    (o1_ORACLE_aux l hn)
    (\((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) -> do
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 1 .&&. vF .==. 0 .&&. t_u3v3 .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 1 .&&. t_u3v3 .==. 1)
      edge <- qnot edge `controlled` (t_uv .==. 0 .&&. uF .==. 0 .&&. vF .==. 0 .&&. t_u3v3 .==. 0 .&&. t_uHvH .==. 0)
      return (((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)),edge))

  comment_with_label "EXIT: o1_ORACLE" (u,v,edge) ("u","v","edge")
  return (u,v,edge)

o1_ORACLE_aux :: Int -> Int -> (QNode, QNode) -> Circ ((QNode, QNode), (QIntTF, QIntTF, QIntTF, QIntTF, QIntTF, QIntTF), (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit))
o1_ORACLE_aux l hn = box "o1_aux" $ \(u,v) -> do
      comment_with_label "ENTER: o1_ORACLE_aux" (u,v) ("u","v")
      (u,uint) <- o2_ConvertNode l u hn
      (v,vint) <- o2_ConvertNode l v hn
      (uint,vint,t_uv) <- o3_TestEqual uint vint
  Since we do n’t have “ quantum control ” , we ca n’t say “ if t = = True … return ” here ; 
          instead we just add a “ control on  = = False ” to the later flips of ‘ edge ’ .
         instead we just add a “control on t_uv == False” to the later flips of ‘edge’. -}

      (uint,u17) <- o4_POW17 uint
      (uint,u17,uF) <- o3_TestEqual uint u17
      (vint,v17) <- o4_POW17 vint
      (vint,v17,vF) <- o3_TestEqual vint v17

      let uint_bits = qulist_of_qinttf_lh uint
      let vint_bits = qulist_of_qinttf_lh vint
      uH <- qinit False
      uH <- qnot uH `controlled` (uint_bits !! (l-1))
      vH <- qinit False
      vH <- qnot vH `controlled` (vint_bits !! (l-1))
      t_uHvH <- qinit True
      t_uHvH <- qnot t_uHvH `controlled` uH
      t_uHvH <- qnot t_uHvH `controlled` vH

      (u17,u3) <- o5_MOD3 u17
      (v17,v3) <- o5_MOD3 v17
      (u3,v3,t_u3v3) <- o3_TestEqual u3 v3
      
      comment_with_label "EXIT: o1_ORACLE_aux" ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3)) (("u","v"),("uint","vint","u17","v17","u3","v3"),("uF","vF","uH","vH","t_uv","t_uHvH","t_u3v3"))
      return ((u,v),(uint,vint,u17,v17,u3,v3),(uF,vF,uH,vH,t_uv,t_uHvH,t_u3v3))

o2_ConvertNode :: Int -> QNode -> Int -> Circ (QNode,QIntTF)
o2_ConvertNode l u hn = ($ u) $ box "o2" $ \u -> do
  comment_with_label "ENTER: o2_ConvertNode" u "u"
  let n = if (length u < l) then (length u) else (error ("ConvertNode: requires n < l.  n = " ++ (show (length u)) ++ ", l = " ++ (show l) ++ "."))

  (u, uint) <- with_computed_fun u
    (\u -> do
      (u,w_low) <- qc_copy_fun u
      w_high <- qinit (replicate (l-n) False)
      return (u,qinttf_of_qulist_lh (w_low ++ w_high)))

    (\(u,w) -> do
      (w,uint) <- o6_SUB w hn
      return ((u,w),uint))
  comment_with_label "EXIT: o2_ConvertNode" (u, uint) ("u", "uint")
  return (u, uint)

  | Algorithm O-3 . Compare if two QIntTF ’s are equal ;
  This function is in general iffy : 00 … 00 and 11 … 11 do /not/ test as equal , as they should .
  However , that case does not arise in the oracle : on the one hand , both 00 … 00 and 11 … 11
o3_TestEqual :: QIntTF -> QIntTF-> Circ (QIntTF,QIntTF,Qubit)
o3_TestEqual = box "o3" $ \x y -> do
  comment_with_label "ENTER: o3_TestEqual" (x,y) ("x", "y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits)
  t <- qinit False
  t <- qnot t `controlled` [ q .==. 0 | q <- y_bits ]
  y_bits <- mapM (\(p,q) -> qnot q `controlled` p) (zip x_bits y_bits)
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  comment_with_label "EXIT: o3_TestEqual" (x, y, t) ("x", "y", "t")
  return (x, y, t)

  | Algorithm O-4 . Compute 17th power of a 31 - bit ' QIntTF ' /x/ , into a
  freshly 31 - bit /QIntTF/.
o4_POW17 :: QIntTF -> Circ (QIntTF,QIntTF)
o4_POW17 = box "o4" $ \x -> do
  comment_with_label "ENTER: o4_POW17" x "x"
  (x, x17) <- with_computed_fun x
    (\x -> do
      (x,x2) <- square x
      (x2,x4) <- square x2
      (x4,x8) <- square x4      
      (x8,x16) <- square x8
      return (x,x2,x4,x8,x16))
    
    (\(x,x2,x4,x8,x16) -> do
      (x,x16,x17) <- o8_MUL x x16
      return ((x,x2,x4,x8,x16),x17))
  comment_with_label "EXIT: o4_POW17" (x, x17) ("x", "x17")
  return (x, x17)

  Alternative coding style : 
 o4_POW17 x = do 
   ( x , x17 ) < - with_computed_fun square x ( \(x , x2 ) - > do 
     ( x2,(x , x17 ) ) < - with_computed_fun square x2 ( \(x2,x4 ) - > do 
       ( x4,(x , x17 ) ) < - with_computed_fun square x4 ( \(x4,x8 ) - > do 
         ( x8,(x , x17 ) ) < - with_computed_fun square x8 (  ) - > do 
           ( x , x16,x17 ) < - o8_MUL x x16 
           return ( ( x8,x16),(x , x17 ) ) ) 
         return ( ( x4,x8),(x , x17 ) ) ) 
       return ( (  , x17 ) ) ) 
     return ( ( x , x2),x17 ) ) 
   return ( x , x17 ) 

o4_POW17 x = do
  (x,x17) <- with_computed_fun square x (\(x,x2) -> do
    (x2,(x,x17)) <- with_computed_fun square x2 (\(x2,x4) -> do
      (x4,(x,x17)) <- with_computed_fun square x4 (\(x4,x8) -> do
        (x8,(x,x17)) <- with_computed_fun square x8 (\(x8,x16) -> do
          (x,x16,x17) <- o8_MUL x x16
          return ((x8,x16),(x,x17)))
        return ((x4,x8),(x,x17)))
      return ((x2,x4),(x,x17)))
    return ((x,x2),x17))
  return (x,x17)
-}

square :: QIntTF -> Circ (QIntTF,QIntTF)
square x = do
           (x, x2) <- with_computed_fun x qc_copy_fun 
             (\(x,x') -> do
               (x,x',x2) <- o8_MUL x x'
               return ((x,x'),x2))
            comment_with_label " EXIT : square " ( x , x2 ) ( " x " , " x2 " )
           return (x, x2)

  | Algorithm O-5 . Compute residue modulo 3 of the lower - order bits of a
  ' QIntTF ' , into a fresh 2 - bit ' QIntTF ' .
  This algorithm is size - limited — works for up to 31 - bit integers , but not beyond .
  produces output in the range 1–3 , rather than 0–2 .   However , output of this
o5_MOD3 :: QIntTF -> Circ (QIntTF,QIntTF)
o5_MOD3 = box "o5" $ \x -> do
  comment_with_label "ENTER: o5_MOD3" x "x"
  let x_bits = qulist_of_qinttf_lh x
  let l = length x_bits
      l' = if (l <= 31) then (l `div` 2)
                        else error "o5_MOD3: requires l <= 31"
  (x_bits, m_bits) <- with_computed_fun x_bits
    (\x_bits -> do
      s5 <- mmap qulist_of_qinttf_lh $ qinit (inttf 5 15)
    
      (x_bits,s5) <- loop_with_indexM l' (x_bits,s5) (\i (x_bits,s5) -> do
        s5 <- increment_little s5 `controlled` (x_bits !! (2*i))
              then decrement_little s5 `controlled` (x_bits !! (2*i + 1))
              else return s5
        return (x_bits,s5))

      s3 <- mmap qulist_of_qinttf_lh $ qinit (inttf 3 3)

      (s5,s3) <- loop_with_indexM 2 (s5,s3) (\i (s5,s3) -> do
        s3 <- increment_little s3 `controlled` (s5 !! (2*i))
        s3 <- decrement_little s3 `controlled` (s5 !! (2*i + 1))
        return (s5,s3))
      s3 <- increment_little s3 `controlled` (s5 !! 4)
  
      let s3_high = last s3
          s2 = init s3
      s2 <- increment_little s2 `controlled` s3_high

      return (x_bits,s5,s3_high,s2))

    (\(x_bits,s5,s3_high,s2) -> do
      (s2,m_bits) <- qc_copy_fun s2
      return ((x_bits,s5,s3_high,s2), m_bits))
  let x = qinttf_of_qulist_lh x_bits
  let m = qinttf_of_qulist_lh m_bits
  comment_with_label "EXIT: o5_MOD3" (x, m) ("x", "m")
  return (x, m)

  Return the result as a second , freshly assigned ' QIntTF ' .
o6_SUB :: QIntTF -> Int -> Circ (QIntTF,QIntTF)
o6_SUB x y = ($ x) $ box "o6" $ \x -> do
 comment_with_label "ENTER: o6_SUB" x "x"
 (x, d_out) <- with_computed_fun x
  (\x1 -> do
    let x = qulist_of_qinttf_lh x1
    let l = length x
  
  subtraction , not “ corrected ” modulo ( 2^l – 1 ) .
    c1 <- qinit (replicate (l+1) False)

    (c1,d1,x) <- loop_with_indexM l (c1,d1,x) (\j (c1,d1,x) -> do
      let c1_j1 = c1 !! (j+1)
      let d1_j = d1 !! j
      c1_j1 <- if y_bits !! j 
              then return c1_j1
              else qnot c1_j1 `controlled` (x !! j)
      c1_j1 <- qnot c1_j1 `controlled` (x !! j) .&&. (c1 !! j)
      c1_j1 <- if  y_bits !! j 
              then return c1_j1
              else qnot c1_j1 `controlled` (c1!!j)
      d1_j <- qnot d1_j `controlled` (x !! j)
      d1_j <- if y_bits !! j 
             then return d1_j
             else qnot d1_j
      d1_j <- qnot d1_j `controlled` (c1 !! j)
      c1 <- return $ overwriteAt (j+1) c1_j1 c1
      d1 <- return $ overwriteAt j d1_j d1
      return (c1,d1,x))

    c2 <- qinit (replicate (l+1) False)
    c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
    c2 <- return $ overwriteAt 0 c2_0 c2
  
    (d,d1,c2) <- loop_with_indexM l (d,d1,c2) (\j (d,d1,c2) -> do
      let c2_j1 = c2 !! (j+1)
      let dj = d !! j
      c2_j1 <- qnot c2_j1 `controlled` (d1 !! j) .&&. (c2 !! j)
      dj <- qnot dj `controlled` (d1 !! j)
      dj <- qnot dj `controlled` (c2 !! j)
      c2 <- return $ overwriteAt (j+1) c2_j1 c2
      d <- return $ overwriteAt j dj d
      return (d,d1,c2))
  
    d_0 <- qnot (d !! 0) `controlled` (c2 !! l)
    d <- return $ overwriteAt 0 d_0 d
    return (x,d,d1,c1,c2))
  (\(x,d,d1,c1,c2) -> do
     (d,d_out) <- qc_copy_fun d
     return ((x,d,d1,c1,c2),qinttf_of_qulist_lh d_out))
 comment_with_label "EXIT: o6_SUB" (x, d_out) ("x", "d_out")
 return (x, d_out)
  
  | Algorithm O-7 . Add two ' QIntTF 's .   Return the result as a third , freshly assigned ' QIntTF ' .
o7_ADD :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o7_ADD = box "o7" $ \x y -> do 
  comment_with_label "ENTER: o7_ADD" (x, y) ("x", "y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  let l = length x_bits

  ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits)
    (\(x_bits,y_bits) -> do

      (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do
        let c1_j1 = c1 !! (j+1)
        let s1_j = s1 !! j
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j)
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j)
        c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j)
        s1_j <- qnot s1_j `controlled` (x_bits !! j)
        s1_j <- qnot s1_j `controlled` (y_bits !! j)
        s1_j <- qnot s1_j `controlled` (c1 !! j)
        c1 <- return $ overwriteAt (j+1) c1_j1 c1
        s1 <- return $ overwriteAt j s1_j s1
        return (c1,s1,x_bits,y_bits))

      c2 <- qinit (replicate (l+1) False)
      c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
      c2 <- return $ overwriteAt 0 c2_0 c2
  
      (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do
        let c2_j1 = c2 !! (j+1)
        let sj = s !! j
        c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j)
        sj <- qnot sj `controlled` (s1 !! j)
        sj <- qnot sj `controlled` (c2 !! j)
        c2 <- return $ overwriteAt (j+1) c2_j1 c2
        s <- return $ overwriteAt j sj s
        return (s,s1,c2))
  
      s_0 <- qnot (s !! 0) `controlled` (c2 !! l)
      s <- return $ overwriteAt 0 s_0 s
      
      return (x_bits,y_bits,s,s1,c1,c2))
    
    (\(x_bits,y_bits,s,s1,c1,c2) -> do
      (s,s_out) <- qc_copy_fun s
      return ((x_bits,y_bits,s,s1,c1,c2), s_out))
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  let s = qinttf_of_qulist_lh s_out
  comment_with_label "EXIT: o7_ADD" (x, y, s) ("x", "y", "s")
  return (x, y, s)

  | Controlled version of ' o7_ADD ' . Returns either a copy of the first
o7_ADD_controlled :: (ControlSource ctrl, Labelable ctrl String)
                  => ctrl -> QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o7_ADD_controlled controls x y = do
  comment_with_label "ENTER: o7_ADD_controlled" (controls,x,y) ("ctrl","x","y")
  let x_bits = qulist_of_qinttf_lh x
  let y_bits = qulist_of_qinttf_lh y
  let l = length x_bits

  ((x_bits,y_bits),s_out) <- with_computed_fun (x_bits,y_bits)
    (\(x_bits,y_bits) -> do

      (c1,s1,x_bits,y_bits) <- loop_with_indexM l (c1,s1,x_bits,y_bits) (\j (c1,s1,x_bits,y_bits) -> do
        let c1_j1 = c1 !! (j+1)
        let s1_j = s1 !! j
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (y_bits!!j)
        c1_j1 <- qnot c1_j1 `controlled` (x_bits!!j) .&&. (c1!!j)
        c1_j1 <- qnot c1_j1 `controlled` (y_bits!!j) .&&. (c1!!j)
        s1_j <- qnot s1_j `controlled` (x_bits !! j)
        s1_j <- qnot s1_j `controlled` (y_bits !! j)
        s1_j <- qnot s1_j `controlled` (c1 !! j)
        c1 <- return $ overwriteAt (j+1) c1_j1 c1
        s1 <- return $ overwriteAt j s1_j s1
        return (c1,s1,x_bits,y_bits))

      c2 <- qinit (replicate (l+1) False)
      c2_0 <- qnot (c2 !! 0) `controlled` (c1 !! l)
      c2 <- return $ overwriteAt 0 c2_0 c2
  
      (s,s1,c2) <- loop_with_indexM l (s,s1,c2) (\j (s,s1,c2) -> do
        let c2_j1 = c2 !! (j+1)
        let sj = s !! j
        c2_j1 <- qnot c2_j1 `controlled` (s1 !! j) .&&. (c2 !! j)
        sj <- qnot sj `controlled` (s1 !! j)
        sj <- qnot sj `controlled` (c2 !! j)
        c2 <- return $ overwriteAt (j+1) c2_j1 c2
        s <- return $ overwriteAt j sj s
        return (s,s1,c2))
  
      s_0 <- qnot (s !! 0) `controlled` (c2 !! l)
      s <- return $ overwriteAt 0 s_0 s
      
      return (x_bits,y_bits,s,s1,c1,c2))

    (\(x_bits,y_bits,s,s1,c1,c2) -> do
  /Can’t/ include this in “ with_computed_fun ” : controls ca n’t be bound
  as QData , and including it unbound yields rather interesting bug .
      temp_control <- qinit False
      temp_control <- qnot temp_control `controlled` controls
      s_out <- qinit (replicate l False)
      (x_bits,s_out) <- mapBinary 
                     (\q q' -> do
                       q' <- qnot q' `controlled` (q .&&. (temp_control .==. 0))
                       return (q,q')) 
                     x_bits s_out
      (s,s_out) <- mapBinary 
                     (\q q' -> do
                       q' <- qnot q' `controlled` (q .&&. (temp_control .==. 1))
                       return (q,q'))
                     s s_out
      temp_control <- qnot temp_control `controlled` controls
      qterm False temp_control
      return ((x_bits,y_bits,s,s1,c1,c2), s_out))
  let x = qinttf_of_qulist_lh x_bits
  let y = qinttf_of_qulist_lh y_bits
  let s = qinttf_of_qulist_lh s_out
  comment_with_label "EXIT: o7_ADD_controlled" (x,y,s) ("x","y","s")
  return (x, y, s)


  result as a third , freshly assigned ' QIntTF ' .
o8_MUL :: QIntTF -> QIntTF -> Circ (QIntTF,QIntTF,QIntTF)
o8_MUL = box "o8" $ \x y -> do
  let x_bits = qulist_of_qinttf_lh x
  let l = length x_bits

  ((x,y),p) <- with_computed_fun (x,y)
    (\(x, y) -> do
      let x_bits = qulist_of_qinttf_lh x
  by adding ( 2^i * y ) if the ith bit of x is set .
      (y,tmp_y) <- qc_copy_fun y
      wrk0 <- qinit (inttf l 0)
      (tmp_y,wrks) <- loop_with_indexM l (tmp_y,[wrk0]) 
        (\k (tmp_y,(wrk_prev:wrks_older)) -> do
          (wrk_prev,tmp_y,wrk_new)
            <- o7_ADD_controlled (x_bits !! k) wrk_prev tmp_y
          tmp_y <- double_TF tmp_y
          return (tmp_y,(wrk_new:wrk_prev:wrks_older)))
      return ((qinttf_of_qulist_lh x_bits),y,tmp_y,wrks))

    (\(x,y,tmp_y,(wrks_head:wrks_rest)) -> do
      (wrks_head,p) <- qc_copy_fun wrks_head
      return ((x,y,tmp_y,(wrks_head:wrks_rest)), p))

   comment_with_label " EXIT : o8_MUL " ( x , y , p ) ( " x","y","p " )
  return (x,y,p)

double_TF :: QIntTF -> Circ QIntTF
double_TF x = do
  comment_with_label "ENTER: double_TF" x "x"
  x <- case qulist_of_qinttf_lh x of
    [] -> return (qinttf_of_qulist_lh [])
    x_bits -> return (qinttf_of_qulist_lh ((last x_bits):(init x_bits)))
  comment_with_label "EXIT: double_TF" x "x"
  return x


  * Blackbox oracle


placeholder_oracle :: QNode -> QNode -> Qubit -> Circ Qubit
placeholder_oracle node1 node2 outp_bit = do 
  comment_with_label "placeholder_oracle" (node1, node2, outp_bit) ("node1", "node2", "outp_bit")       
  extended_named_gate_at "OC" [outp_bit] (node1 ++ node2)
  return outp_bit


