{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE DoAndIfThenElse #-} -- | This module contains the core of the classical circuit -- optimization algorithm. module Quipper.Libraries.ClassicalOptim.Simplification where 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 Control.DeepSeq as Seq import Control.Applicative (Applicative(..)) import Control.Monad (liftM, ap) import qualified Quipper.Utils.Auxiliary as Q import Quipper.Libraries.ClassicalOptim.Circuit import Quipper.Libraries.ClassicalOptim.AlgExp -- ---------------------------------------------------------------------- -- * Auxiliary definitions -- | Internal definition of a trace, for debugging purposes. This is a -- no-op, but can be replaced to turn on debugging. trace :: String -> b -> b trace a b = b -- | Change a wire ID in a gate. The first two arguments are the old -- and the new wire ID. moveWire :: Wire -> Wire -> Gate -> Gate moveWire from to NoOp = NoOp moveWire from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) moveWire from to (Cnot w ctls) = Cnot w' ctls' where w' = if (from == w) then to else w ctls' = map moveCtls ctls moveCtls (w,b) = if (from == w) then (to,b) else (w,b) -- | Flip the control on the given wire (from positive to negative or -- vice versa). flipCtl :: Wire -> Gate -> Gate flipCtl _ NoOp = NoOp flipCtl _ (Init b w) = Init b w flipCtl w (Cnot w' ctls) = Cnot w' $ map (\(x,b) -> if (x == w) then (x,not b) else (x,b)) ctls -- | Change a wire ID in a gate and flip the potential control. moveWireFlip :: Wire -> Wire -> Gate -> Gate moveWireFlip from to NoOp = NoOp moveWireFlip from to (Init b w) = if (w == from) then error "moveWire" else (Init b w) moveWireFlip from to (Cnot w ctls) = Cnot w' ctls' where w' = if (from == w) then to else w ctls' = map moveCtls ctls moveCtls (w,b) = if (from == w) then (to,b) else if (to == w) then (w,not b) else (w,b) -- ---------------------------------------------------------------------- -- * Small, simple optimizations -- | Suppress gates acting on garbage wires, i.e., wires that are not in the input set. suppress_garbage :: [Gate] -> IS.IntSet -> [Gate] suppress_garbage ((Cnot w ctls):gs) used = if (IS.member w used) then g:gs1 else gs2 where g = Cnot w ctls gs1 = suppress_garbage gs $ IS.union (IS.insert w used) $ IS.fromList $ L.map fst ctls gs2 = suppress_garbage gs used suppress_garbage (g:gs) used = g:(suppress_garbage gs used) suppress_garbage [] _ = [] -- | Like 'suppress_garbage', but packaged in a manner that is friendly for composition. suppressGarbageGates :: ([Gate],[Wire]) -> ([Gate],[Wire]) suppressGarbageGates (gs,out) = (reverse $ suppress_garbage (reverse gs) $ IS.fromList out, out) -- ---------------------------------------------------------------------- -- * Compression of wire numbering -- $ As the optimization process goes on, many /init/ gates will end -- up being discarded. The function 'compressWires' compacts the wire -- numbering scheme to make a smaller circuit. -- | Get the set of all wires used by the circuit. getAllWires :: [Gate] -> IS.IntSet getAllWires gs = L.foldl' IS.union IS.empty $ L.map aux gs where aux (Cnot w ctls) = IS.insert w $ L.foldl' (flip IS.insert) IS.empty $ L.map fst ctls aux (Init _ w) = IS.singleton w aux NoOp = IS.empty -- | Get the set of wires initialized by the circuit. getInitWires :: [Gate] -> IS.IntSet getInitWires gs = L.foldl' IS.union IS.empty $ map aux gs where aux (Cnot _ _) = IS.empty aux (Init _ w) = IS.singleton w aux NoOp = IS.empty -- | Get the set of input wires, i.e., the ones that are used but not initialized. getInputWires :: [Gate] -> IS.IntSet getInputWires gs = IS.difference (getAllWires gs) (getInitWires gs) -- | Compress the wire numbering. compressWires :: [Wire] -> ([Gate],[Wire]) -> ([Gate],[Wire]) compressWires inputwires (gs,output) = (gs',out') where iws = getInitWires gs begin = if inputwires == [] then 0 else 1 + (head $ reverse $ L.sort inputwires) end = begin + (IS.size iws) listmap = zip ([0..begin-1] ++ (IS.toAscList iws)) [0 .. end] remap = M.fromList $ trace (show listmap) listmap out' = map (remap M.!) output gs' = map (rewire remap) gs rewire m (Cnot w ctls) = Cnot (m M.! w) $ map (\(x,b) -> (m M.! x, b)) ctls rewire m (Init b w) = Init b (m M.! w) rewire m NoOp = NoOp -- ---------------------------------------------------------------------- -- * A useful data structure -- $ When considering a particular point in a circuit (i.e., in a list -- of gates), to decide whether a given wire is used or controlled -- before or after, we keep a data-structure 'UsedWire'. -- | The type of gate IDs. type GateId = Int -- | A set of gate IDs. type GateIdSet = IS.IntSet -- | A map from wires to pairs of 'GateId's. The left member gives the -- ID of the first gate using the wire, and the right member gives the -- ID of the last gate using the wire. type UsedWire = IM.IntMap GateIdSet -- | Get the minimum of a set of gate IDs. gateIdFindMin :: GateIdSet -> Maybe GateId gateIdFindMin g = if (IS.null g) then Nothing else Just (IS.findMin g) -- | Get the maximum of a set of gate IDs. gateIdFindMax :: GateIdSet -> Maybe GateId gateIdFindMax g = if (IS.null g) then Nothing else Just (IS.findMax g) -- | Get the pair corresponding to the given wire. pairUsedWire :: UsedWire -> Wire -> GateIdSet pairUsedWire m w = IM.findWithDefault IS.empty w m -- | Get the first gate using the wire in the future. firstUsedWire :: UsedWire -> Wire -> Maybe GateId firstUsedWire = curry $ gateIdFindMin . (uncurry pairUsedWire) -- | Get the last gate using the wire in the past. Return 0 if none. lastUsedWire :: UsedWire -> Wire -> GateId lastUsedWire w w'= case (curry $ gateIdFindMax . (uncurry pairUsedWire)) w w' of Just w -> w Nothing -> 0 -- | 'nextUsedGate' /ws/ /g/ /g/' /w/: Look for the next gate in /ws/ -- corresponding to wire /w/, starting from /g/. Return /g/' if none. nextUsedGate :: UsedWire -> GateId -> GateId -> Wire -> GateId nextUsedGate ws g g' w = case (do gs <- IM.lookup w ws; IS.lookupGT g gs) of Just g -> g Nothing -> g' -- | For each wire, find the set of gates placing a control on it. circuitControlWires :: GateId -> [Gate] -> UsedWire circuitControlWires id gs = aux id IM.empty gs where aux _ m [] = m aux g m (Init _ _:gs) = aux (g+1) m gs aux g m ((Cnot _ ctls):gs) = aux (g+1) m' gs where wires = map fst ctls m' = L.foldl (\m'' w -> IM.alter (f g) w m'') m wires f g Nothing = Just $ IS.singleton g f g (Just s) = Just $ IS.insert g s aux g m (NoOp:_) = error "circuitControlWires cannot deal with NoOp" -- | For each wire, find the set of gates acting on it with NOT. circuitNotWires :: GateId -> [Gate] -> UsedWire circuitNotWires id gs = aux id IM.empty gs where aux _ m [] = m aux g m (Init _ _:gs) = aux (g+1) m gs aux g m ((Cnot w _):gs) = aux (g+1) m' gs where m' = IM.alter (f g) w m f g Nothing = Just $ IS.singleton g f g (Just s) = Just $ IS.insert g s aux g m (_:gs) = aux (g+1) m gs -- ---------------------------------------------------------------------- -- * Algebraic optimization method -- $ To each wire in a circuit, we attach a set of formulas. At each -- iteration, the wire that gets modified is updated with its new -- value, using all the possible values, possibly together with a -- fresh variable. At each iteration, we also strip away the -- expressions that get too large. Here, the size of an algebraic -- expression is measured by the 'exp_length' function. -- | Calculate the size of an algebraic expression. exp_length :: Exp -> Int exp_length e = L.foldl' (+) 0 $ L.map (\x -> let y = IS.size x in seq y y) $ S.toList e -- | Given a list of sets of expressions, form the conjunction of -- every possible choice of one expression from each set. For example. -- -- > exp_list_and [{a,b}, {c,d}, {e,f}] = -- > [a∧c∧e, a∧c∧f, a∧d∧e, a∧d∧f, b∧c∧e, b∧c∧f, b∧d∧e, b∧d∧f]. exp_list_and :: [S.Set Exp] -> S.Set Exp exp_list_and [] = S.singleton exp_true exp_list_and [l] = l exp_list_and (h:k:t) = exp_list_and (S.fromList [exp_and x y | x <- S.toList h, y <- S.toList k]:t) -- | Evaluate a control with respect to a state. expEvalCtl :: (IM.IntMap (S.Set (Exp,Int))) -> (Wire,Bool) -> S.Set Exp expEvalCtl m (w,True) = S.map fst (m IM.! w) expEvalCtl m (w,False) = S.map exp_not $ S.map fst $ (IM.!) m w -- | Evaluate a gate with respect to a state. expEvalGate :: (IM.IntMap (S.Set (Exp,Int))) -> Gate -> IM.IntMap (S.Set (Exp,Int)) expEvalGate m (Init False w) = IM.insert w (S.singleton (exp_false,0)) m expEvalGate m (Init True w) = IM.insert w (S.singleton (exp_true,1)) m expEvalGate m NoOp = m expEvalGate m (Cnot w ctls) = IM.insert w cnot m where ands = exp_list_and $ L.map (expEvalCtl m) ctls cnot = S.map (\x -> (x,exp_length x)) (S.fromList [exp_xor x y | x <- S.toList $ S.map fst $ (IM.!) m w, y <- S.toList ands ]) -- ---------------------------------------------------------------------- -- ** State of the optimization automaton -- | The state of the automaton. This contains in particular the -- current state, the past and future gates, and a fresh variable. data ExpState = ExpState { gates_to_skip :: IM.IntMap Gate, -- ^ For use with 'stepSwapCirc'. allWiresInCirc :: IS.IntSet, -- ^ All the wires in the circuit. gateId :: GateId, -- ^ ID of the first gate in the future (starts at 1). usedControlWires :: UsedWire, -- ^ Location of the controls. usedNotWires :: UsedWire, -- ^ Location of the NOT gates. future :: [Gate], -- ^ Gates left to explore. past :: [Gate], -- ^ Gates already explored. expMap :: IM.IntMap (S.Set (Exp,Int)), -- ^ Algebraic state of the wires. Also contains the size of the expression, so we don't have to recompute it each time. freshVar :: Integer, -- ^ The next fresh wire. outWires :: [Wire], -- ^ The output wires. sizeCirc :: Int -- ^ Size of the circuit. } instance Seq.NFData Gate where rnf (Init a b) = a `seq` b `seq` () rnf (Cnot w ctls) = ctls `Seq.deepseq` w `Seq.deepseq` () rnf NoOp = () {- instance Seq.NFData ExpState where rnf e = {-allWiresInCirc e `Seq.deepseq` gateId e `Seq.deepseq` usedControlWires e `Seq.deepseq` usedNotWires e `Seq.deepseq` future e `Seq.deepseq` past e `Seq.deepseq` expMap e `Seq.deepseq` freshVar e `Seq.deepseq` outWires e-} () `Seq.deepseq` () -} -- | The initial state for a given set of parameters. initExpState :: IS.IntSet -> [Wire] -> [Gate] -> ExpState initExpState ws_in ws_out gs = ExpState { gates_to_skip = IM.empty, allWiresInCirc = getAllWires gs, gateId = 1, usedControlWires = circuitControlWires 1 gs, usedNotWires = circuitNotWires 1 gs, future = gs, past = [], expMap = IM.fromList $ L.map (\x -> (x, S.singleton (exp_var x, 1))) $ IS.toAscList ws_in, freshVar = fromIntegral $ (+) 1 $ IS.findMax ws_in, outWires = ws_out, sizeCirc = length gs } -- ---------------------------------------------------------------------- -- ** The state monad -- | The state monad corresponding to 'ExpState'. data EvalCirc a = EvalCirc (ExpState -> (ExpState, a)) instance Monad EvalCirc where return x = EvalCirc (\y -> (y,x)) (>>=) (EvalCirc c) f = EvalCirc (\s -> let (s',x) = c s in let (EvalCirc c') = f x in c' s') instance Applicative EvalCirc where pure = return (<*>) = ap instance Functor EvalCirc where fmap = liftM -- ---------------------------------------------------------------------- -- ** Low-level access functions -- | Construct an @'ExpState'@ out of an @'EvalCirc'@. runEvalCirc :: IS.IntSet -> [Wire] -> [Gate] -> EvalCirc a -> ExpState runEvalCirc ws_in ws_out gs (EvalCirc e) = fst $ e $ initExpState ws_in ws_out gs -- | Retrieve the state. getExpState :: EvalCirc ExpState getExpState = EvalCirc (\s -> (s,s)) -- | Set the state. setExpState :: ExpState -> EvalCirc () setExpState s = EvalCirc (\_ -> (s,())) -- ---------------------------------------------------------------------- -- ** Higher-level access functions -- | Create a fresh variable newFreshVar :: EvalCirc Integer newFreshVar = do s <- getExpState let v = freshVar s setExpState (s { freshVar = v + 1 }) return v -- | Pull a new gate to be analyzed out of the future. pullNewGate :: EvalCirc (Maybe Gate) pullNewGate = do s <- getExpState case (future s) of (h:t) -> do setExpState (s { future = t } ) return (Just h) [] -> return Nothing -- | Modify the future gates. changeFuture :: [Gate] -> EvalCirc () changeFuture gs = do s <- getExpState setExpState (s { future = gs } ) return () -- | Update the future using the given parameter function. Return two sets -- of 'gateId's that got modified: the first set concerns the controls, -- the second set the NOT gates. updateFuture :: (Gate -> Gate) -> EvalCirc (IS.IntSet,IS.IntSet) updateFuture f = do s <- getExpState let ((_,!gsModifCtls,!gsModifNots),new_future) = L.mapAccumL (\(gid,gs,gs') g -> let g' = f g in (( gid+1 , if (ctlsOfGate g == ctlsOfGate g') then gs else IS.insert gid gs , if (wireOfGate g == wireOfGate g') then gs' else IS.insert gid gs' ), g')) (1 + (gateId s), IS.empty,IS.empty) (future s) changeFuture new_future return (gsModifCtls,gsModifNots) -- | Store a gate in the past. storeOldGate :: Gate -> EvalCirc () storeOldGate g = do s <- getExpState let p = past s seq g $ seq p $ setExpState (s { past = g:p } ) return () -- | Increase the '@gateId@' (i.e., go forward). incrGateId :: EvalCirc () incrGateId = do s <- getExpState setExpState (s { gateId = 1 + (gateId s) } ) return () -- | Get the set of all wires. getAllWiresInCirc :: EvalCirc IS.IntSet getAllWiresInCirc = do s <- getExpState return (allWiresInCirc s) -- | Set the set of all wires. setAllWiresInCirc :: IS.IntSet -> EvalCirc () setAllWiresInCirc ws = do s <- getExpState ws `seq` setExpState (s {allWiresInCirc = ws}) return () -- | Remove a gate from the set of all wires. removeFromAllWiresInCirc :: Int -> EvalCirc () removeFromAllWiresInCirc w = do ws <- getAllWiresInCirc setAllWiresInCirc $ IS.delete w ws return () -- | Get the algebraic representation of the set of wires. getExpMap :: EvalCirc (IM.IntMap (S.Set (Exp,Int))) getExpMap = do s <- getExpState s `seq` return (expMap s) -- | Set the algebraic representation of the state of wires. setExpMap :: (IM.IntMap (S.Set (Exp,Int))) -> EvalCirc () setExpMap m = do s <- getExpState m `seq` setExpState (s { expMap = m } ) return () -- | Update the database recording the controlled wires. updateUsedControlWires :: (UsedWire -> UsedWire) -> EvalCirc () updateUsedControlWires f = do s <- getExpState let c = f $ usedControlWires s c `seq` setExpState (s { usedControlWires = c } ) return () -- | Update the database recording the NOT gates. updateUsedNotWires :: (UsedWire -> UsedWire) -> EvalCirc () updateUsedNotWires f = do s <- getExpState let c = f $ usedNotWires s c `seq` setExpState (s { usedNotWires = c } ) return () -- | Update the list of output wires. updateOutWires :: ([Wire] -> [Wire]) -> EvalCirc () updateOutWires f = do s <- getExpState let c = f $ outWires s c `seq` setExpState (s { outWires = c } ) return () -- | Add a gate ID to the list of gates to skip. addToSkipGates :: GateId -> Gate -> EvalCirc () addToSkipGates id g = do s <- getExpState let c = IM.insert id g (gates_to_skip s) c `seq` setExpState (s {gates_to_skip = c} ) return () -- | Send a gate to the end of the future. sendEndOfTime :: Gate -> EvalCirc () sendEndOfTime g = do s <- getExpState changeFuture ((future s) ++ [g]) return () -- | Place a gate at the given gate ID in the future. shiftGate :: Gate -> GateId -> EvalCirc () shiftGate g x = do s <- getExpState let (!head, !tail) = splitAt x (future s) let z = head ++ [g] ++ tail z `Seq.deepseq` changeFuture z return () -- ---------------------------------------------------------------------- -- ** Auxiliary functions -- | @pairEqualExp m1 m2 ws@: returns a list of pairs of wires @(x,y)@ -- such that @m2 x = m1 x = m1 y@. pairEqualExp :: (IM.IntMap [Exp]) -> (IM.IntMap [Exp]) -> [Wire] -> [(Wire,Wire)] pairEqualExp m1 m2 ws = L.map fst $ L.filter aux $ L.zip pair_ws (L.map value pair_ws) where all_pairs l = [(x,y) | x <- l, y <- l] pair_ws = all_pairs ws value (x,y) = (m2 IM.! x, m1 IM.! x, m1 IM.! y) aux ((_,_),(a,b,c)) = a == b && b == c -- | From a set of expressions (annotated with sizes), prune the ones -- whose size is larger than /n/. pruneListExp :: Int -> S.Set (Exp,Int) -> S.Set (Exp,Int) pruneListExp n l = S.filter (\x -> snd x <= n) l -- ---------------------------------------------------------------------- -- ** The algebraic optimization automaton -- | Perform a set of filters acting on one gate at a time, looking -- for: -- -- * gates having no effect; -- -- * orphan NOT-gates (i.e. NOT gates negating an out-wire) ; -- -- * simple copy-cats (both positive and negative) ; -- -- * hidden copy-cats. -- -- Return 'False' when the end of the circuit is reached, 'True' otherwise. stepEvalCirc :: EvalCirc Bool stepEvalCirc = do m_before <- getExpMap trace ("the state of the system is " ++ (show $ m_before)) $ return () s <- getExpState if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp... " ++ (show (gateId s))) (return ()) else return () s <- getExpState trace ("outside wires " ++ (show $ outWires s)) $ return () maybe_g <- pullNewGate trace ("pulled new gate " ++ (show maybe_g)) $ return () s <- getExpState case maybe_g of Nothing -> return False Just g -> do -- analyze the gate m_before <- getExpMap let m_after = expEvalGate m_before g case g of NoOp -> error "stepEvalCirc cannot deal with NoOp" Init b w | not ((IM.member w $ usedNotWires s) || (IM.member w $ usedControlWires s) || L.elem w (outWires s))-> do trace "got an orphan init, removing it" $ return () storeOldGate NoOp -- store a placeholder for the gate incrGateId removeFromAllWiresInCirc w -- we could also clean expMap from the reference to w but I think it makes no gain return True Init _ _ -> do trace "got a regular init" $ return () storeOldGate g setExpMap m_after incrGateId return True Cnot w _ | not $ S.null $ S.intersection (m_before IM.! w) (m_after IM.! w) -> do trace "got a cnot where no change happened..." $ return () trace (show m_before) $ return () trace (show m_after) $ return () storeOldGate NoOp incrGateId return True Cnot w [] | not (L.elem w $ outWires s) -> do trace "got a not-gate that can be removed..." $ return () s <- getExpState -- update future changeFuture $ L.map (flipCtl w) $ future s s <- getExpState trace (show $ future s) $ return () storeOldGate NoOp incrGateId return True Cnot w ctls | otherwise -> do trace "got a general cnot" $ return () trace ("state after the gate is " ++ (show m_after)) $ return () allWs <- getAllWiresInCirc s <- getExpState let my_elem x = not (L.elem x $ outWires s) let all_ws = IS.toAscList $ IS.filter future_ctl $ IS.filter (\x -> my_elem x) $ -- not (L.elem x $ outWires s)) $ IS.filter (\x -> not $ S.null $ S.intersection (m_after IM.! x) (m_after IM.! w)) $ IS.filter (w /=) allWs -- IS.fromList $ L.map fst ctls where future_ctl x = (lastUsedWire (usedNotWires s) x) <= gateId s && (lastUsedWire (usedNotWires s) w) <= gateId s let all_ws_neg = IS.toAscList $ IS.filter future_ctl $ IS.filter (\x -> not (L.elem x $ outWires s)) $ IS.filter (\x -> not $ S.null $ S.intersection (m_after IM.! x) (S.map (\(e,i) -> (exp_not e, i)) (m_after IM.! w))) $ IS.filter (w /=) $ IS.fromList $ L.map fst ctls where future_ctl x = (lastUsedWire (usedNotWires s) x) <= gateId s && (lastUsedWire (usedNotWires s) w) <= gateId s trace ("List of outside wires: " ++ (show $ outWires s)) (return ()) trace ("List of available wires: " ++ (show all_ws)) (return ()) trace ("List of available wires with neg: " ++ (show all_ws_neg)) (return ()) case all_ws of [] -> do case all_ws_neg of [] -> do -- There is no "simple" copy-cat... -- Let's try to find a hidden one. s <- getExpState -- This helper function take a wire and look in -- the past for the closest cnot acting on it let getOlderCnot w = case (do set <- IM.lookup w (usedNotWires s); IS.lookupLT (gateId s) set) of Nothing -> Nothing -- there is no previous not Just g' -> -- there is one not... let's check that it is a cnot case ((past s) !! ((gateId s) - g' - 1)) of Cnot _ [ctl] -> Just (g',ctl) _ -> Nothing -- Helper acting on controls: only return -- something if it is a single control. let getOlderCnot_actOnCtls w1 [(w,b)] = do -- monad Maybe other_ctl <- getOlderCnot w1 other_ctl `seq` return ((w,b),other_ctl) getOlderCnot_actOnCtls _ _ = Nothing let retrieveHiddenCnot w1 ctls = do -- monad Maybe -- if (L.elem w $ outWires s) then Nothing -- else return () ((w2,b2),(g',(w3,b3))) <- getOlderCnot_actOnCtls w1 ctls -- make sure w2 and w3 are distinct if (w2 == w3) then Nothing else return () let m = m_after -- check for the property w1 == w2 oplus w3 if (S.null $ S.intersection (S.fromList [exp_xor x y | (x,_) <- S.toList (m IM.! w2), (y,_) <- S.toList (m IM.! w3)]) (S.fromList [x | (x,_) <- S.toList (m IM.! w1)])) then Nothing -- We have two CNOT candidates for hidden copy-cat. else if ((not (L.elem w2 $ outWires s)) && (lastUsedWire (usedNotWires s) w2) <= gateId s && (lastUsedWire (usedControlWires s) w2) <= gateId s) then Just ((w2,b2),(w3,b3)) else if ((not (L.elem w3 $ outWires s)) && (lastUsedWire (usedNotWires s) w3) <= g' && (lastUsedWire (usedControlWires s) w3) <= g') then Just ((w3,b3),(w2,b2)) else Nothing case retrieveHiddenCnot w ctls of Just ((w2,b2),(w3,b3)) -> -- we have a hidden cnot candidate. Great. -- w2 is the wire that is not used with NOT in future do trace "found one hidden copy-cat" $ return () updateOutWires $ map (\x -> if x == w then w2 else x) (gsModifCtls,gsModifNots) <- updateFuture $ moveWire w w2 trace ("moving " ++ (show w) ++ " to " ++ (show w2)) $ return () trace (show gsModifCtls) $ return () trace (show gsModifNots) $ return () s <- getExpState trace ("before: usedNotWire = " ++ (show $ usedNotWires s)) $ return () updateUsedControlWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.union gs gsModifCtls Nothing -> Just gsModifCtls) w2 $ IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c updateUsedControlWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c updateUsedControlWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.insert (gateId s) gs Nothing -> Just $ IS.singleton (gateId s)) w3 c updateUsedNotWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.union gs gsModifNots Nothing -> Just gsModifNots) w2 $ IM.update (\gs -> Just $ IS.difference gs gsModifNots) w c updateUsedNotWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w $ IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.insert (gateId s) gs Nothing -> Just $ IS.singleton (gateId s)) w2 c s <- getExpState trace ("after: usedNotWire = " ++ (show $ usedNotWires s)) $ return () -- Update ExpMap setExpMap $ IM.insert w (m_before IM.! w) $ IM.insert w2 (m_after IM.! w) m_after storeOldGate $ Cnot w2 [(w3,True)] incrGateId return True _ -> -- No hidden Cnot, let's proceed... do let mw = m_after IM.! w f <- if ((S.foldl' (\a (_,i) -> min a i) 3 mw) <= 1) then return id else do v <- newFreshVar return (S.insert (exp_var $ fromIntegral v, 1)) setExpMap $ IM.adjust (\a -> pruneListExp 3 a) w $ IM.adjust f w m_after storeOldGate g incrGateId return True ----------------- -- Case of simple copy-cats (w':_) -> do s <- getExpState updateOutWires $ map (\x -> if x == w then w' else x) s <- getExpState trace (show $ future s) $ return () (gsModifCtls,_) <- updateFuture $ moveWireFlip w w' -- update expMap: now, w is null and w' is not(old w) expMap <- getExpMap setExpMap $ IM.insert w (m_before IM.! w) $ IM.insert w' (S.map (\(e,i) -> (exp_not e,i)) (expMap IM.! w')) expMap trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () trace (show gsModifCtls) $ return () s <- getExpState trace (show $ future s) $ return () s <- getExpState updateUsedControlWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.union gs gsModifCtls Nothing -> Just gsModifCtls) w' $ IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c updateUsedNotWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c storeOldGate (Cnot w' []) -- Set a flip on the w' wire incrGateId return True (w':_) -> do s <- getExpState updateOutWires $ map (\x -> if x == w then w' else x) s <- getExpState trace (show $ future s) $ return () trace ("usedNotWire = " ++ (show $ usedNotWires s)) $ return () (gsModifCtls,_) <- updateFuture $ moveWire w w' trace ("moving " ++ (show w) ++ " to " ++ (show w')) $ return () trace (show gsModifCtls) $ return () s <- getExpState trace (show $ future s) $ return () s <- getExpState updateUsedControlWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.union gs gsModifCtls Nothing -> Just gsModifCtls ) w' $ IM.update (\gs -> Just $ IS.difference gs gsModifCtls) w c updateUsedNotWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w c storeOldGate NoOp -- replace g with NoOp so that gateId stays accurate incrGateId return True -- | Shuffle the circuit by sending the CNOT gates as far as -- possible (i.e., until they hit a control, or to the end). -- Return 'False' when the end of the circuit is reached, 'True' otherwise. stepSwapCirc :: EvalCirc Bool stepSwapCirc = do s <- getExpState case (IM.lookup (gateId s) (gates_to_skip s)) of Just g -> do storeOldGate g incrGateId return True Nothing -> do maybe_g <- pullNewGate trace ("pulled new gate " ++ (show maybe_g)) $ return () s <- getExpState if ((gateId s) `mod` 1000 == 0) then trace ("Timestamp (swap)... " ++ (show (gateId s))) {-(s `Seq.deepseq` (setExpState s))-} (return ()) else return () case maybe_g of Nothing -> return False Just g@(Cnot w1 [(w2,b2)]) | IM.notMember (gateId s) (gates_to_skip s) -> do -- got a CNOT trace ("got a cnot to analyze " ++ (show $ gateId s) ++ " " ++ (show $ gates_to_skip s)) $ return () let id = min (nextUsedGate (usedNotWires s) (gateId s) (1 + sizeCirc s) w2) $ (nextUsedGate (usedControlWires s) (gateId s) (1 + sizeCirc s) w1) trace ("found id = " ++ (show id)) $ return () if ( id > 1 + gateId s ) -- && (id <= (sizeCirc s) ) then do ------------- there is something to move! trace ("can be shifted to " ++ (show (id - 1))) $ return () addToSkipGates (id - 1) g -- shiftGate g (id - 1 - (gateId s)) s <- getExpState trace (show $ future s) $ return () -- Remove references to (gateId s) updateUsedControlWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w2 c updateUsedNotWires $ \c -> IM.update (\gs -> Just $ IS.delete (gateId s) gs) w1 c -- Shift the ones between (gateId s) and id updateUsedNotWires $ IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x else x - 1 updateUsedControlWires $ IM.map $ IS.map $ \x -> if (x <= gateId s) || (x >= id) then x else x - 1 s <- getExpState let z = IM.mapKeys (\x -> if (x <= gateId s) || (x >= id) then x else x - 1) (gates_to_skip s) in z `seq` setExpState (s { gates_to_skip = z} ) -- Set g in position (id - 1) updateUsedControlWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.insert (id - 1) gs Nothing -> Just $ IS.singleton (id - 1)) w2 c updateUsedNotWires $ \c -> IM.alter (\maybe_gs -> case maybe_gs of Just gs -> Just $ IS.insert (id - 1) gs Nothing -> Just $ IS.singleton (id - 1)) w1 c -- Make sure we skip (id - 1) later on. else do ------------- nothing to move... trace "cannot be shifted" $ return () storeOldGate g incrGateId return True Just g -> do trace ("got a random " ++ (show g)) $ return () storeOldGate g incrGateId return True -- | A more elementary version of @'stepSwapCirc'@: shuffle the -- circuit by sending to the end all the NOT gates that can be sent -- there. Return 'False' when the end of the circuit is reached, -- 'True' otherwise. stepSwapCirc_simple :: EvalCirc Bool stepSwapCirc_simple = do maybe_g <- pullNewGate trace ("pulled new gate " ++ (show maybe_g)) $ return () s <- getExpState case maybe_g of Nothing -> return False Just g | (gateId s) == (length $ past s) + (length $ future s) -> do storeOldGate g return False Just g@(Cnot w1 [(w2,b2)]) | (lastUsedWire (usedNotWires s) w2) <= gateId s && (lastUsedWire (usedNotWires s) w1) <= gateId s && (lastUsedWire (usedControlWires s) w1) <= gateId s -> do -- got a CNOT trace "got a cnot that can be sent to the end" $ return () sendEndOfTime g -- do not store gate, but increase gateId incrGateId return True Just g -> do storeOldGate g incrGateId return True -- ---------------------------------------------------------------------- -- ** Some wrappers -- | Run the monad until 'False' occurs. runWhile :: Monad m => (a -> Bool) -> m a -> m () runWhile f c = do r <- c if f r then runWhile f c else return () -- | Strip the 'NoOp' gates from a list of gates. stripNoOp :: [Gate] -> [Gate] stripNoOp = L.filter (/= NoOp) -- | Wrapper around 'stepEvalCirc'. alg_simplify :: ([Gate],[Wire]) -> ([Gate],[Wire]) alg_simplify (gs,out) = (stripNoOp gs',out') where gs' = (reverse $ past s) ++ (future s) out' = outWires s ws_in = getAllWires gs s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepEvalCirc) -- | Wrapper around 'stepSwapCirc'. alg_swap :: ([Gate],[Wire]) -> ([Gate],[Wire]) alg_swap (gs,out) = (stripNoOp gs',out') where gs' = (reverse $ past s) ++ (future s) out' = outWires s ws_in = getAllWires gs s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc) -- | Wrapper around 'stepSwapCirc_simple'. alg_swap_simple :: ([Gate],[Wire]) -> ([Gate],[Wire]) alg_swap_simple (gs,out) = (stripNoOp gs',out') where gs' = (reverse $ past s) ++ (future s) out' = outWires s ws_in = getAllWires gs s = runEvalCirc ws_in out gs $ trace "Starting new circuit!" (runWhile id stepSwapCirc_simple) -- ---------------------------------------------------------------------- -- * Multi-pass optimization -- | Auxiliary function. Simultaneously compute the maximum of the -- lengths of two lists, and their point-wise equality. is_equal_list :: Eq a => [a] -> [a] -> Int -> (Int,Bool) is_equal_list [] [] n = (n,True) is_equal_list (h1:t1) (h2:t2) n | h1 == h2 = is_equal_list t1 t2 (n+1) is_equal_list t1 t2 n = (n + max (length t1) (length t2),False) -- | Get the list of initialized wires from a circuit. get_list_init :: [Gate] -> [Wire] get_list_init ((Init _ w):gs) = w:(get_list_init gs) get_list_init (g:gs) = get_list_init gs get_list_init [] = [] -- | Do several passes of @'alg_simplify'@ until it reaches a fixed point. simplRec' :: ([Gate],[Wire]) -> ([Gate],[Wire]) simplRec' (l,output) = trace (show (l,output)) $ let (l',output') = alg_simplify (l, output) in let (n,b) = is_equal_list l l' 0 in if b then (l,output) else trace (show n) simplRec' $ suppressGarbageGates (l',output') -- | Do several passed of @'alg_swap'@ followed with @'simplRec'@ -- until it reaches a fixed point. simplRec :: ([Gate],[Wire]) -> ([Gate],[Wire]) simplRec (l1,o1) = let (l3,o3) = simplRec' $ alg_swap (l1,o1) in let (n,b) = is_equal_list l1 l3 0 in if b then (l3,o3) else trace "Swapping!" $ simplRec $ (l3,o3)