quantum2.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

-- QReg type class and instances

class QReg a where
  mapIndices :: a -> (Int -> Int) -> a
  indices :: a -> [Int]

data Qubit = Qubit { index :: Int } deriving (Eq, Show)
instance QReg Qubit where
  mapIndices (Qubit i) f = Qubit (f i)
  indices (Qubit i) = [i]

data QPair = QPair Int Int deriving (Eq, Show)
instance QReg QPair where
  mapIndices (QPair i1 i2) f = QPair (f i1) (f i2)
  indices (QPair i1 i2) = [i1, i2]

-- Operation

data Operation s = Operation
  { opName :: String
  , apply :: s -> String
  }

-- Channel and State representations

data DM = DM Float Float deriving (Eq, Show)
data SV = SV Float deriving (Eq, Show)

data Channel = Channel Float Float deriving (Eq, Show)
data Unitary = Unitary Float deriving (Eq, Show)

mockApplyChannel :: Channel -> [Int] -> DM -> String
mockApplyChannel c idxs dm = "channel: " ++ show c ++ " dm" ++ show dm ++ " indices" ++ show idxs

mockApplyUnitary :: Unitary -> [Int] -> SV -> String
mockApplyUnitary u idxs sv = "unitary: " ++ show u ++ " sv" ++ show sv ++ " indices" ++ show idxs

unitaryToChannel :: Unitary -> Channel
unitaryToChannel (Unitary f) = Channel f f

-- Gate interfaces

class GateReader a where
  name :: a -> String

class (GateReader a, QReg q) => Gate a q s where
  on :: a -> q -> Operation s

class GateReader a => ChannelGateReader a where
  getChannel :: a -> Channel

class (ChannelGateReader a, Gate a q DM) => ChannelGate a q where
  applyChannel :: a -> q -> DM -> String
  applyChannel g q dm = mockApplyChannel (getChannel g) (indices q) dm
  on g q = Operation (name g) (\dm -> applyChannel g q dm)

class GateReader a => UnitaryGateReader a where
  getUnitary :: a -> Unitary

class (UnitaryGateReader a, Gate a q SV) => UnitaryGate a q where
  applyUnitary :: a -> q -> SV -> String
  applyUnitary g q sv = mockApplyUnitary (getUnitary g) (indices q) sv
  on g q = Operation (name g) (\sv -> applyUnitary g q sv)
  asChannelGate :: a -> UnitaryChannelGate a
  asChannelGate = UnitaryChannelGate

-- Concrete gates

data BitFlip = BitFlip Float deriving (Eq, Show)
instance GateReader BitFlip where name _ = "BitFlip"
instance ChannelGateReader BitFlip where getChannel (BitFlip p) = Channel p p
instance ChannelGate BitFlip Qubit
instance Gate BitFlip Qubit DM where on = on

data XPowGate = XPowGate Float deriving (Eq, Show)
instance GateReader XPowGate where name _ = "XPowGate"
instance UnitaryGateReader XPowGate where getUnitary (XPowGate f) = Unitary f
instance UnitaryGate XPowGate Qubit
instance Gate XPowGate Qubit SV where on = on

data UnitaryChannelGate a = UnitaryChannelGate a deriving (Eq, Show)

instance (UnitaryGateReader a) => ChannelGateReader (UnitaryChannelGate a) where
  getChannel (UnitaryChannelGate a) = unitaryToChannel (getUnitary a)
instance (GateReader a) => GateReader (UnitaryChannelGate a) where
  name (UnitaryChannelGate a) = name a
instance (UnitaryGate a q) => ChannelGate (UnitaryChannelGate a) q
instance (UnitaryGate a q) => Gate (UnitaryChannelGate a) q DM where
  on = on

-- Simulator

sim :: s -> [Operation s] -> String
sim s = unlines . map (\op -> apply op s)

-- Main

main :: IO ()
main = do
  let dm = DM 0.3 0.5
  let ops = [ on (BitFlip 0.4) (Qubit 4)
            , on (BitFlip 0.4) (Qubit 4)
            , on (asChannelGate (XPowGate 0.4)) (Qubit 4)
            ]
  putStrLn (sim dm ops)