{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LINE 1 "Quipper/Libraries/ClassicalOptim/Circuit.hs" #-}
module Quipper.Libraries.ClassicalOptim.Circuit where
import qualified Data.Map as M
import qualified Data.List as L
import qualified Quipper.Utils.Auxiliary as Q
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
type Wire = Int
data Gate =
NoOp
| Init Bool Wire
| Cnot Wire [(Wire,Bool)]
deriving (Show,Eq)
wireOfGate :: Gate -> Maybe Wire
wireOfGate NoOp = Nothing
wireOfGate (Init _ w) = Just w
wireOfGate (Cnot w _) = Just w
ctlsOfGate :: Gate -> Maybe [(Wire,Bool)]
ctlsOfGate (Cnot _ ctls) = Just ctls
ctlsOfGate _ = Nothing
evalCirc :: M.Map Wire Bool -> [Gate] -> M.Map Wire Bool
evalCirc m [] = m
evalCirc m (NoOp:gs) = evalCirc m gs
evalCirc m ((Init b w):gs) = evalCirc (M.insert w b m) gs
evalCirc m ((Cnot w ctls):gs) = evalCirc (M.adjust (Q.bool_xor (ands m ctls)) w m) gs
where
ands m [] = True
ands m ((w,b):ctls) = ((m M.! w) `Q.bool_xor` (not b)) && (ands m ctls)
data CircState = CS {
circuit :: [Gate],
freshWire :: Wire
} deriving (Show)
emptyState :: CircState
emptyState = CS {circuit = [], freshWire = 0}
data Circ a = Circ (CircState -> (CircState, a))
instance Monad Circ where
return x = Circ (\y -> (y,x))
(>>=) (Circ c) f = Circ (\s -> let (s',x) = c s in
let (Circ c') = f x in
c' s')
instance Applicative Circ where
pure = return
(<*>) = ap
instance Functor Circ where
fmap = liftM
getFresh :: Circ Wire
getFresh = Circ (\s -> (s, freshWire s))
incrementFresh :: Circ ()
incrementFresh = Circ (\s -> (s { freshWire = freshWire s + 1 }, ()))
addGate :: Gate -> Circ ()
addGate g = Circ (\s -> (s {circuit = g : (circuit s)}, ()))
extractCircuit :: Circ a -> [Gate]
extractCircuit (Circ c) = circuit $ fst $ c emptyState
init :: Bool -> Circ Wire
init b = do
w <- getFresh
addGate (Init b w)
incrementFresh
return w
cnot :: Wire -> [(Wire,Bool)] -> Circ ()
cnot w ws = do
addGate (Cnot w ws)
return ()
printCircuit :: Circ a -> IO ()
printCircuit c = do
mapM_ putStrLn $ map show $ reverse $ extractCircuit c
print_quipperStyle :: Gate -> IO ()
print_quipperStyle (Init b w) = putStrLn (" x" ++ (show w) ++ " <- Q.qinit " ++ (show b))
print_quipperStyle (Cnot w ctls) = putStrLn (" Q.qnot x" ++ (show w) ++ " `Q.controlled` " ++
(L.intercalate " Q..&&. " $ map (\(w,b) -> "x" ++ (show w) ++ " Q..==. " ++ (show b) ++ " ") ctls))
print_quipperStyle g = putStrLn (" Q.comment \"" ++ (show g) ++ "\"")