{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LINE 1 "Quipper/Algorithms/TF/QWTFP.hs" #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ < 710
{-# OPTIONS -fcontext-stack=50 #-}
#else
{-# OPTIONS -freduction-depth=50 #-}
#endif
module Quipper.Algorithms.TF.QWTFP where
import Prelude hiding (mapM, mapM_)
import Quipper
import Quipper.Internal (BType)
import Quipper.Libraries.Arith
import Quipper.Algorithms.TF.Definitions
import Data.IntMap (IntMap, adjust, insert, size)
import qualified Data.IntMap as IntMap
import Data.Traversable (mapM)
import Data.Foldable (mapM_)
import Control.Monad (foldM)
a1_QWTFP :: QWTFP_spec -> Circ (Bit,CNode,IntMap CNode,IntMap (IntMap Bit))
a1_QWTFP oracle@(n,r,edgeOracle,_) = do
comment "ENTER: a1_QWTFP"
let nn = 2^n
let rr = 2^r
let rbar = max ((2 * r) `div` 3) 1
let rrbar = 2^rbar
let tm = 2^(n - r)
let tw = floor $ sqrt $ fromIntegral rr
testTEdge <- a2_ZERO False
tt <- a3_INITIALIZE (intMap_replicate rr (replicate n False))
i <- a3_INITIALIZE (intm r 0)
v <- a3_INITIALIZE (replicate n False)
(tt, ee) <- a5_SETUP oracle tt
(tt,i,v,ee) <- box_loopM "a1_loop1" tm (tt,i,v,ee)
(\(tt,i,v,ee) -> do
((tt,ee),_) <- with_computed_fun (tt,ee)
(\(tt,ee) -> a15_TestTriangleEdges oracle tt ee)
(\(tt,ee,w,triTestT,triTestTw) -> do
phaseFlipUnless (triTestT .==. 0 .&&. triTestTw .==. 0)
return ((tt,ee,w,triTestT,triTestTw),()))
(tt,i,v,ee) <- box_loopM "a1_loop2" tw (tt,i,v,ee) (\(a,b,c,d) -> a6_QWSH oracle a b c d)
return (tt,i,v,ee))
(tt,ee,w,triTestT,triTestTw) <- a15_TestTriangleEdges oracle tt ee
testTEdge <- qor testTEdge [(triTestT, True), (triTestTw, True)]
testTMeasure <- measure testTEdge
wMeasure <- measure w
ttMeasure <- measure tt
eeMeasure <- measure ee
qdiscard (i,v,triTestT,triTestTw)
comment_with_label "EXIT: a1_QWTFP" (testTMeasure, wMeasure, ttMeasure, eeMeasure) ("testTMeasure", "wMeasure", "ttMeasure", "eeMeasure")
return (testTMeasure, wMeasure, ttMeasure, eeMeasure)
a2_ZERO :: QShape a qa ca => a -> Circ qa
a2_ZERO b = do
comment "ENTER: a2_ZERO"
q <- qinit b
comment_with_label "EXIT: a2_ZERO" q "q"
return q
a3_INITIALIZE :: QShape a qa ca => a -> Circ qa
a3_INITIALIZE reg = do
comment "ENTER: a3_INITIALIZE"
zreg <- a2_ZERO reg
hzreg <- a4_HADAMARD zreg
comment_with_label "EXIT: a3_INITIALIZE" hzreg "hzreg"
return hzreg
a4_HADAMARD :: QData qa => qa -> Circ qa
a4_HADAMARD q = do
comment_with_label "ENTER: a4_HADAMARD" q "q"
q <- map_hadamard q
comment_with_label "EXIT: a4_HADAMARD" q "q"
return q
a5_SETUP :: QWTFP_spec -> (IntMap QNode) -> Circ (IntMap QNode, IntMap (IntMap Qubit))
a5_SETUP oracle@(n,r,edgeOracle,_) = box "a5" $ \tt -> do
comment_with_label "ENTER: a5_SETUP" tt "tt"
let rr = 2^r
ee <- qinit $ IntMap.fromList [(j,(intMap_replicate j False)) | j <- [0..(rr-1)]]
ee <- loop_with_indexM (rr) ee (\k ee ->
loop_with_indexM k ee (\j ee -> do
edgejk <- edgeOracle (tt ! j) (tt ! k) (ee ! k ! j)
ee <- return $ adjust (insert j edgejk) k ee
return ee))
comment_with_label "EXIT: a5_SETUP" (tt,ee) ("tt","ee")
return (tt, ee)
a6_QWSH :: QWTFP_spec -> (IntMap QNode) -> QDInt -> QNode -> (IntMap (IntMap Qubit))
-> Circ (IntMap QNode, QDInt, QNode, IntMap (IntMap Qubit))
a6_QWSH oracle@(n,r,edgeOracle,qram) = box "a6" $ \tt i v ee -> do
comment_with_label "ENTER: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee")
with_ancilla_init (replicate n False) $ \ttd -> do
with_ancilla_init (intMap_replicate (2^r) False) $ \eed -> do
(i,v) <- a7_DIFFUSE (i,v)
((tt,i,v,ee,ttd,eed),_) <- with_computed_fun (tt,i,v,ee,ttd,eed)
(\(tt,i,v,ee,ttd,eed) -> do
(i,tt,ttd) <- qram_fetch qram i tt ttd
(i,ee,eed) <- a12_FetchStoreE i ee eed
(tt,ttd,eed) <- a13_UPDATE oracle tt ttd eed
(i,tt,ttd) <- qram_store qram i tt ttd
return (tt,i,v,ee,ttd,eed))
(\(tt,i,v,ee,ttd,eed) -> do
(ttd,v) <- a14_SWAP ttd v
return ((tt,i,v,ee,ttd,eed),()))
comment_with_label "EXIT: a6_QWSH" (tt, i, v, ee) ("tt", "i", "v", "ee")
return (tt,i,v,ee)
a7_DIFFUSE :: (QData qa) => qa -> Circ qa
a7_DIFFUSE = box "a7" $ \q -> do
comment_with_label "ENTER: a7_DIFFUSE" q "q"
q <- a4_HADAMARD q
phaseFlipUnless $ q .==. qc_false q
q <- a4_HADAMARD q
comment_with_label "EXIT: a7_DIFFUSE" q "q"
return q
a8_FetchT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa)
a8_FetchT = box "a8" $ \i tt ttd -> do
comment_with_label "ENTER: a8_FetchT" (i,tt,ttd) ("i","tt","ttd")
let r = qdint_length i
(i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd)
(\j (i,tt,ttd) -> do
let ttj = tt ! j
(ttj,ttd) <- mapBinary
(\q p -> do
p <- qnot p `controlled` q .&&. i .==. (fromIntegral j)
return (q,p))
(tt ! j) ttd
return (i, insert j ttj tt, ttd))
comment_with_label "EXIT: a8_FetchT" (i,tt,ttd) ("i","tt","ttd")
return (i,tt,ttd)
a9_StoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa)
a9_StoreT = box "a9" $ \i tt ttd -> do
comment_with_label "ENTER: a9_StoreT" (i,tt,ttd) ("i","tt","ttd")
let r = qdint_length i
(i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd)
(\j (i,tt,ttd) -> do
(ttj,ttd) <- mapBinary
(\q p -> do
q <- qnot q `controlled` p .&&. i .==. (fromIntegral j)
return (q,p))
(tt ! j) ttd
return (i, insert j ttj tt, ttd))
comment_with_label "EXIT: a9_StoreT" (i,tt,ttd) ("i","tt","ttd")
return (i,tt,ttd)
a10_FetchStoreT :: (QData qa) => QDInt -> IntMap qa -> qa -> Circ (QDInt, IntMap qa, qa)
a10_FetchStoreT = box "a10" $ \i tt ttd -> do
comment_with_label "ENTER: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd")
let r = qdint_length i
(i,tt,ttd) <- loop_with_indexM (2^r) (i,tt,ttd)
(\j (i,tt,ttd) -> do
(qq,ttd) <- a14_SWAP (tt ! j) ttd
`controlled` i .==. (fromIntegral j)
return (i,(insert j qq tt), ttd))
comment_with_label "EXIT: a10_FetchStoreT" (i,tt,ttd) ("i","tt","ttd")
return (i,tt,ttd)
a11_FetchE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit
-> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit)
a11_FetchE = box "a11" $ \i qs ps -> do
comment_with_label "ENTER: a11_FetchE" (i, qs, ps) ("i", "qs", "ps")
let r = qdint_length i
(i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs,ps) ->
loop_with_indexM j (i,qs,ps) (\k (i,qs,ps) -> do
pk <- qnot (ps ! k) `controlled`
(qs ! j ! k) .&&. i .==. (fromIntegral j)
ps <- return $ insert k pk ps
pj <- qnot (ps ! j) `controlled`
(qs ! j ! k) .&&. i .==. (fromIntegral k)
ps <- return $ insert j pj ps
return (i,qs,ps)))
comment_with_label "EXIT: a11_FetchE" (i, qs, ps) ("i", "qs", "ps")
return (i,qs,ps)
a12_FetchStoreE :: QDInt -> IntMap (IntMap Qubit) -> IntMap Qubit
-> Circ (QDInt, IntMap (IntMap Qubit), IntMap Qubit)
a12_FetchStoreE = box "a12" $ \i qs ps -> do
comment_with_label "ENTER: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps")
let r = qdint_length i
(i,qs,ps) <- loop_with_indexM (2^r) (i,qs,ps) (\j (i,qs, ps) ->
loop_with_indexM j (i,qs, ps) (\k (i,qs, ps) -> do
(q,p) <- a14_SWAP (qs ! j ! k) (ps ! k)
`controlled` i .==. (fromIntegral j)
(qs,ps) <- return (adjust (insert k q) j qs, insert k p ps)
(q,p) <- a14_SWAP (qs ! j ! k) (ps ! j)
`controlled` i .==. (fromIntegral k)
(qs,ps) <- return (adjust (insert k q) j qs, insert j p ps)
return (i,qs,ps)))
comment_with_label "EXIT: a12_FetchStoreE" (i, qs, ps) ("i", "qs", "ps")
return (i,qs,ps)
a13_UPDATE :: QWTFP_spec -> IntMap QNode -> QNode -> IntMap Qubit
-> Circ (IntMap QNode, QNode, IntMap Qubit)
a13_UPDATE oracle@(n,r,edgeOracle,_) = box "a13" $ \tt ttd eed -> do
comment_with_label "ENTER: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed")
(tt,ttd,eed) <- loop_with_indexM (2^r) (tt,ttd,eed) (\j (tt,ttd,eed) -> do
e <- edgeOracle (tt ! j) ttd (eed ! j)
return (tt,ttd,insert j e eed))
comment_with_label "EXIT: a13_UPDATE" (tt,ttd,eed) ("tt","ttd","eed")
return (tt,ttd,eed)
a14_SWAP :: QCData qa => qa -> qa -> Circ (qa, qa)
a14_SWAP q r = do
comment_with_label "ENTER: a14_SWAP" (q,r) ("q", "r")
(q,r) <- swap q r
comment_with_label "EXIT: a14_SWAP" (q,r) ("q", "r")
return (q,r)
standard_qram :: Qram
standard_qram = Qram {
qram_fetch = a8_FetchT,
qram_store = a9_StoreT,
qram_swap = a10_FetchStoreT
}
type GCQWRegs = (IntMap QDInt, QDInt, QDInt, IntMap Qubit, QDInt, Qubit)
a15_TestTriangleEdges ::
QWTFP_spec
-> IntMap QNode
-> IntMap (IntMap Qubit)
-> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit,Qubit)
a15_TestTriangleEdges oracle = box "a15" $ \tt ee -> do
comment_with_label "ENTER: a15_TestTriangleEdges" (tt,ee) ("tt","ee")
(ee,triTestT) <- a16_TriangleTestT ee
(tt,ee,w,triTestT) <- a18_TriangleEdgeSearch oracle tt ee triTestT
(tt,ee,w,triTestTw) <- a17_TriangleTestTw oracle tt ee w
comment_with_label "EXIT: a15_TestTriangleEdges" (tt,ee,w,triTestT,triTestTw) ("tt","ee","w","triTestT","triTestTw")
return (tt,ee,w,triTestT,triTestTw)
a16_TriangleTestT :: IntMap (IntMap Qubit) -> Circ (IntMap (IntMap Qubit), Qubit)
a16_TriangleTestT = box "a16" $ \ee -> do
comment_with_label "ENTER: a16_TriangleTestT" ee "ee"
let rr = size ee
(ee,triTestT) <- with_computed_fun ee
(\ee -> do
cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 3)))) 0)
cTri <- foldM (\cTri (i,j,k) -> do
cTri <- increment cTri `controlled` (ee ! j ! i) .&&. (ee ! k ! i) .&&. (ee ! k ! j)
return cTri)
cTri [(i,j,k) | i <- [0..rr-1], j <- [i+1..rr-1], k <- [j+1..rr-1]]
return (ee,cTri))
(\(ee,cTri) -> do
triTestT <- qinit True
triTestT <- qnot triTestT `controlled` cTri .==. 0
return ((ee,cTri),triTestT))
comment_with_label "EXIT: a16_TriangleTestT" (ee,triTestT) ("ee","triTestT")
return (ee,triTestT)
a17_TriangleTestTw :: QWTFP_spec
-> IntMap QNode
-> IntMap (IntMap Qubit)
-> QNode
-> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit)
a17_TriangleTestTw oracle@(n,r,edgeOracle,_) = box "a17" $ \tt ee w -> do
comment_with_label "ENTER: a17_TriangleTestTw" (tt,ee,w) ("tt","ee","w")
let rr = size ee
with_ancilla_init (intMap_replicate rr False) $ \eed -> do
((tt,ee,w,eed),triTestTw) <- with_computed_fun (tt,ee,w,eed)
(\(tt,ee,w,eed) -> do
eed <- mapWithKeyM (\k e -> do
e <- edgeOracle (tt ! k) w e
return e)
eed
cTri <- qinit (intm (ceiling (logBase 2 (fromIntegral (rr `choose` 2)))) 0)
cTri <- foldM
(\cTri (i,j) ->
increment cTri `controlled` (ee ! j ! i) .&&. (eed ! i) .&&. (eed ! j))
cTri
[(i,j) | i <- [0..rr-1], j <- [i+1..rr-1]]
return (tt,ee,w,eed,cTri))
(\(tt,ee,w,eed,cTri) -> do
triTestTw <- qinit True
triTestTw <- qnot triTestTw `controlled` cTri .==. 0
return ((tt,ee,w,eed,cTri),triTestTw))
comment_with_label "EXIT: a17_TriangleTestTw" (tt,ee,w,triTestTw) ("tt","ee","w","triTestTw")
return (tt,ee,w,triTestTw)
a18_TriangleEdgeSearch :: QWTFP_spec
-> IntMap QNode
-> IntMap (IntMap Qubit)
-> Qubit
-> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit)
a18_TriangleEdgeSearch oracle@(n,r,edgeOracle,_) = box "a18" $ \tt ee triTestT -> do
comment_with_label "ENTER: a18_TriangleEdgeSearch" (tt,ee,triTestT) ("tt","ee","triTestT")
let nn = 2^n
tG = floor (pi/4 *( sqrt ( fromIntegral nn)))
w <- a2_ZERO (replicate n False)
w <- a4_HADAMARD w
box_loopM "a18_loop" tG (tt,ee,w,triTestT) (\(tt,ee,w,triTestT) -> do
((tt,ee,w,triTestT),()) <- with_computed_fun (tt,ee,w,triTestT)
(\(tt,ee,w,triTestT) -> do
(tt,ee,w,triTestT,cTri) <- a19_GCQWalk oracle tt ee w triTestT
cTri_nonzero <- qinit True
cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0
return (tt,ee,w,triTestT,cTri,cTri_nonzero))
(\(tt,ee,w,triTestT,cTri,cTri_nonzero) -> do
phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero
return ((tt,ee,w,triTestT,cTri,cTri_nonzero),()))
w <- a7_DIFFUSE w
return (tt,ee,w,triTestT))
comment_with_label "EXIT: a18_TriangleEdgeSearch" (tt,ee,w,triTestT) ("tt","ee","w","triTestT")
return (tt,ee,w,triTestT)
a19_GCQWalk :: QWTFP_spec
-> IntMap QNode
-> IntMap (IntMap Qubit)
-> QNode
-> Qubit
-> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, Qubit, QDInt)
a19_GCQWalk oracle@(n,r,edgeOracle,qram) = box "a19" $ \tt ee w triTestT -> do
comment_with_label "ENTER: a19_GCQWalk" (tt,ee,w,triTestT) ("tt","ee","w","triTestT")
let nn = 2^n
rr = 2^r
rbar = max ((2 * r) `div` 3) 1
rrbar = 2^rbar
tbarm = max (rr `div` rrbar) 1
tbarw = floor $ sqrt $ fromIntegral rrbar
cTri <- qinit (intm (2*rbar - 1) 0)
with_ancilla_init
((intMap_replicate rrbar (intm r 0)),
(intm rbar 0),
(intm r 0),
(intMap_replicate rrbar False))
$ \(tau,iota,sigma,eew) -> do
tau <- a4_HADAMARD tau
iota <- a4_HADAMARD iota
sigma <- a4_HADAMARD sigma
eew <- mapWithKeyM (\j eew_j -> do
let taub = tau ! j
ttd <- qinit (replicate n False)
(taub, tt, ttd) <- qram_fetch qram taub tt ttd
eew_j <- edgeOracle ttd w eew_j
(taub, tt, ttd) <- qram_fetch qram taub tt ttd
qterm (replicate n False) ttd
return eew_j)
eew
cTri <- foldM (\cTri j -> do
let tau_j = tau ! j
eed <- qinit (intMap_replicate rr False)
(taub,ee,eed) <- a11_FetchE tau_j ee eed
cTri <- foldM (\cTri k -> do
let tau_k = tau ! k
eedd_k <- qinit False
(tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k
cTri <- increment cTri `controlled` eedd_k .&&. (eew ! j) .&&. (eew ! k)
(tauc, eed, eedd_k) <- qram_fetch qram tau_k eed eedd_k
qterm False eedd_k
return cTri)
cTri [j+1..rrbar-1]
(taub,ee,eed) <- a11_FetchE tau_j ee eed
qterm (intMap_replicate rr False) eed
return cTri)
cTri [0..rrbar-1]
(tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT)) <- box_loopM "a19_loop1" tbarm
(tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT))
(\(tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) -> do
((cTri,triTestT),()) <- with_computed_fun (cTri,triTestT)
(\(cTri,triTestT) -> do
cTri_nonzero <- qinit True
cTri_nonzero <- qnot cTri_nonzero `controlled` cTri .==. 0
return (cTri,triTestT,cTri_nonzero))
(\(cTri,triTestT,cTri_nonzero) -> do
phaseFlipIf $ (triTestT .==. 0) .&&. cTri_nonzero
return ((cTri,triTestT,cTri_nonzero),()))
box_loopM "a19_loop2" tbarw (tt,ee,w,(e1,e2,e3,e4,cTri,triTestT)) (\(b,c,d,e) -> a20_GCQWStep oracle b c d e))
comment_with_label "EXIT: a19_GCQWalk" (tt,ee,w,triTestT,cTri) ("tt","ee","w","triTestT","cTri")
return (tt,ee,w,triTestT,cTri)
a20_GCQWStep :: QWTFP_spec
-> IntMap QNode
-> IntMap (IntMap Qubit)
-> QNode
-> GCQWRegs
-> Circ (IntMap QNode, IntMap (IntMap Qubit), QNode, GCQWRegs)
a20_GCQWStep oracle@(n,r,edgeOracle,qram) = box "a20" $
\tt ee w gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT) -> do
comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,tau,iota,sigma,eew,cTri,triTestT) ("tt","ee","w","tau","iota","sigma","eew","cTri","triTestT")
let rr = 2^r
rbar = max ((2 * r) `div` 3) 1
rrbar = 2^rbar
(iota, sigma) <- a7_DIFFUSE (iota, sigma)
((tt,ee,w,gcqwRegs),_) <- with_computed_fun (tt,ee,w,gcqwRegs)
(\(tt,ee,w,gcqwRegs@(tau,iota,sigma,eew,cTri,triTestT)) -> do
ttd <- qinit (replicate n False)
eed <- qinit (intMap_replicate rr False)
taud <- qinit (intm r 0)
eewd <- qinit False
eedd <- qinit (intMap_replicate rrbar False)
(iota, tau, taud) <- qram_fetch qram iota tau taud
(taud, tt, ttd) <- qram_fetch qram taud tt ttd
(iota,eew,eewd) <- qram_swap qram iota eew eewd
(taud,ee,eed) <- a11_FetchE taud ee eed
eedd <- mapWithKeyM (\k eeddb -> do
let taub = tau ! k
(taub, eed, eeddb) <- qram_fetch qram taub eed eeddb
return eeddb)
eedd
cTri <- loop_with_indexM (rrbar-1) cTri (\a cTri -> do
decrement cTri `controlled` (eedd ! a) .&&. (eewd) .&&. (eew ! a))
eewd <- edgeOracle ttd w eewd
eedd <- mapWithKeyM (\k e -> do
let taub = tau ! k
let eeddb = eedd ! k
(taub, eed, eeddb) <- qram_fetch qram taub eed eeddb
return e)
eedd
(taud,ee,eed) <- a11_FetchE taud ee eed
(taud,tt,ttd) <- qram_fetch qram taud tt ttd
(iota,tau,taud) <- qram_store qram iota tau taud
return (tt,ee,w,gcqwRegs,ttd,eed,taud,eewd,eedd))
(\(tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd) -> do
(taud,sigma) <- a14_SWAP taud sigma
return ((tt,ee,w,(tau,iota,sigma,eew,cTri,triTestT),ttd,eed,taud,eewd,eedd),()))
comment_with_label "ENTER: a20_GCQWStep" (tt,ee,w,gcqwRegs) ("tt","ee","w",("tau","iota","sigma","eew","cTri","triTestT"))
return (tt,ee,w,gcqwRegs)