{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LINE 1 "Quipper/Algorithms/TF/Oracle.hs" #-}
{-# LANGUAGE FlexibleContexts #-}
module Quipper.Algorithms.TF.Oracle where
import Quipper
import Quipper.Algorithms.TF.Definitions
import Quipper.Utils.Auxiliary
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
(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)
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)
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)
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))
return (x, x2)
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)
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)
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)
d <- qinit (replicate l False)
d1 <- qinit (replicate l False)
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)
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)
s1 <- qinit (replicate l False)
c1 <- qinit (replicate (l+1) False)
(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)
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)
s1 <- qinit (replicate l False)
c1 <- qinit (replicate (l+1) False)
(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
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)
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
(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))
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
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