module Quipper.Labels where
import Quipper.Circuit
import Quipper.Monad
import Libraries.Auxiliary
import Libraries.Tuple
import Quipper.Transformer
import qualified Data.Map as Map
import Data.Map (Map)
import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)
type IndexList = (String, [String])
indexlist_format :: IndexList -> String
indexlist_format (s,idx) =
s ++ string_of_list "[" "," "]" "" id (reverse idx)
indexlist_empty :: IndexList
indexlist_empty = ("", [])
indexlist_subscript :: IndexList -> String -> IndexList
indexlist_subscript (s, idx) i = (s, i:idx)
indexlist_dotted :: IndexList -> String -> IndexList
indexlist_dotted idxl i = (indexlist_format idxl ++ "." ++ i, [])
newtype LabelMonad a = LabelMonad {
getLabelMonad :: IndexList -> (Map Wire String, a)
}
instance Monad LabelMonad where
return a = LabelMonad (\idxl -> (Map.empty, a))
f >>= g = LabelMonad h where
h idxl = (Map.union m1 m2, z) where
(m1, y) = getLabelMonad f idxl
(m2, z) = getLabelMonad (g y) idxl
instance Applicative LabelMonad where
pure = return
(<*>) = ap
instance Functor LabelMonad where
fmap = liftM
labelmonad_get_indexlist :: LabelMonad IndexList
labelmonad_get_indexlist = LabelMonad h where
h idxl = (Map.empty, idxl)
labelmonad_put_binding :: Wire -> String -> LabelMonad ()
labelmonad_put_binding x label = LabelMonad h where
h idxl = (Map.singleton x label, ())
labelmonad_with_indexlist :: IndexList -> LabelMonad a -> LabelMonad a
labelmonad_with_indexlist idxl body = LabelMonad h where
h idxl' = getLabelMonad body idxl
labelmonad_run :: LabelMonad () -> Map Wire String
labelmonad_run body = bindings where
(bindings, _) = getLabelMonad body indexlist_empty
label_wire :: Wire -> String -> LabelMonad ()
label_wire x s = do
idxl <- labelmonad_get_indexlist
let label = s ++ indexlist_format idxl
labelmonad_put_binding x label
with_index :: String -> LabelMonad () -> LabelMonad ()
with_index i body = do
idxl <- labelmonad_get_indexlist
labelmonad_with_indexlist (indexlist_subscript idxl i) body
with_dotted_index :: String -> LabelMonad () -> LabelMonad ()
with_dotted_index i body = do
idxl <- labelmonad_get_indexlist
labelmonad_with_indexlist (indexlist_dotted idxl i) body
indexed :: LabelMonad () -> String -> LabelMonad ()
indexed body i = with_index i body
dotted_indexed :: LabelMonad () -> String -> LabelMonad ()
dotted_indexed body i = with_dotted_index i body
label_empty :: LabelMonad ()
label_empty = return ()
class Labelable a s where
label_rec :: a -> s -> LabelMonad ()
mklabel :: (Labelable a s) => a -> s -> [(Wire, String)]
mklabel a s = Map.toList bindings where
bindings = labelmonad_run (label_rec a s)
instance Labelable Qubit String where
label_rec a s = label_wire (wire_of_qubit a) s
instance Labelable Bit String where
label_rec a s = label_wire (wire_of_bit a) s
instance (Labelable a String) => Labelable (Signed a) String where
label_rec (Signed a b) s =
label_rec a s `dotted_indexed` (if b then "+" else "-")
instance (Labelable a String) => Labelable (Signed a) (Signed String) where
label_rec (Signed a b) (Signed s c)
| b == c = label_rec a s
| otherwise = return ()
instance Labelable () String where
label_rec a s = label_empty
instance Labelable () () where
label_rec a s = label_empty
instance (Labelable a String, Labelable b String) => Labelable (a,b) String where
label_rec (a,b) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
instance (Labelable a String, Labelable b String, Labelable c String) => Labelable (a,b,c) String where
label_rec (a,b,c) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String) => Labelable (a,b,c,d) String where
label_rec (a,b,c,d) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String) => Labelable (a,b,c,d,e) String where
label_rec (a,b,c,d,e) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String) => Labelable (a,b,c,d,e,f) String where
label_rec (a,b,c,d,e,f) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
label_rec f s `indexed` "5"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String) => Labelable (a,b,c,d,e,f,g) String where
label_rec (a,b,c,d,e,f,g) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
label_rec f s `indexed` "5"
label_rec g s `indexed` "6"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String) => Labelable (a,b,c,d,e,f,g,h) String where
label_rec (a,b,c,d,e,f,g,h) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
label_rec f s `indexed` "5"
label_rec g s `indexed` "6"
label_rec h s `indexed` "7"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String) => Labelable (a,b,c,d,e,f,g,h,i) String where
label_rec (a,b,c,d,e,f,g,h,i) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
label_rec f s `indexed` "5"
label_rec g s `indexed` "6"
label_rec h s `indexed` "7"
label_rec i s `indexed` "8"
instance (Labelable a String, Labelable b String, Labelable c String, Labelable d String, Labelable e String, Labelable f String, Labelable g String, Labelable h String, Labelable i String, Labelable j String) => Labelable (a,b,c,d,e,f,g,h,i,j) String where
label_rec (a,b,c,d,e,f,g,h,i,j) s = do
label_rec a s `indexed` "0"
label_rec b s `indexed` "1"
label_rec c s `indexed` "2"
label_rec d s `indexed` "3"
label_rec e s `indexed` "4"
label_rec f s `indexed` "5"
label_rec g s `indexed` "6"
label_rec h s `indexed` "7"
label_rec i s `indexed` "8"
label_rec j s `indexed` "9"
instance (Labelable a sa, Labelable b sb) => Labelable (a,b) (sa,sb) where
label_rec (a,b) (sa,sb) = do
label_rec a sa
label_rec b sb
instance (Labelable a sa, Labelable b sb, Labelable c sc) => Labelable (a,b,c) (sa, sb, sc) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd) => Labelable (a,b,c,d) (sa, sb, sc, sd) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se) => Labelable (a,b,c,d,e) (sa, sb, sc, sd, se) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf) => Labelable (a,b,c,d,e,f) (sa, sb, sc, sd, se, sf) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg) => Labelable (a,b,c,d,e,f,g) (sa, sb, sc, sd, se, sf, sg) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh) => Labelable (a,b,c,d,e,f,g,h) (sa, sb, sc, sd, se, sf, sg, sh) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si) => Labelable (a,b,c,d,e,f,g,h,i) (sa, sb, sc, sd, se, sf, sg, sh, si) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a sa, Labelable b sb, Labelable c sc, Labelable d sd, Labelable e se, Labelable f sf, Labelable g sg, Labelable h sh, Labelable i si, Labelable j sj) => Labelable (a,b,c,d,e,f,g,h,i,j) (sa, sb, sc, sd, se, sf, sg, sh, si, sj) where
label_rec a s = label_rec (untuple a) (untuple s)
instance (Labelable a String) => Labelable [a] String where
label_rec as s = do
sequence_ [ label_rec a s `indexed` show i | (a,i) <- zip as [0..] ]
instance (Labelable a s) => Labelable [a] [s] where
label_rec as ss = do
sequence_ [ label_rec a s | (a,s) <- zip as ss ]
instance (Labelable a String, Labelable b String) => Labelable (B_Endpoint a b) String where
label_rec (Endpoint_Qubit a) s = label_rec a s
label_rec (Endpoint_Bit b) s = label_rec b s
instance (Labelable a s, Labelable b t) => Labelable (B_Endpoint a b) (B_Endpoint s t) where
label_rec (Endpoint_Qubit a) (Endpoint_Qubit s) = label_rec a s
label_rec (Endpoint_Bit b) (Endpoint_Bit t) = label_rec b t
label_rec _ _ = return ()
instance Labelable Integer String where
label_rec a s = label_empty
instance Labelable Int String where
label_rec a s = label_empty
instance Labelable Double String where
label_rec a s = label_empty
instance Labelable Float String where
label_rec a s = label_empty
instance Labelable Char String where
label_rec a s = label_empty
comment :: String -> Circ ()
comment s = comment_with_label s () ()
label :: (Labelable qa labels) => qa -> labels -> Circ ()
label qa labels = comment_with_label "" qa labels
comment_with_label :: (Labelable qa labels) => String -> qa -> labels -> Circ ()
comment_with_label comment qa labels =
comment_label comment False (mklabel qa labels)