packages feed

entangle (empty) → 0.1.0

raw patch · 15 files changed

+1553/−0 lines, 15 filesdep +basedep +containersdep +entanglesetup-changed

Dependencies added: base, containers, entangle, matrix, mtl, quipper-core

Files

+ LICENSE view
@@ -0,0 +1,22 @@+MIT License++Copyright (c) 2016-2017 Linda Anticoli, Leonardo Taglialegne++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.+
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ entangle.cabal view
@@ -0,0 +1,27 @@+name:          entangle+version:       0.1.0+cabal-version: >=1.8+build-type:    Simple+license:       MIT+license-file:  LICENSE+data-dir:      ""+maintainer:    leonardo.taglialegne@gmail.com+synopsis:      An application (and library) to convert quipper circuits into Qpmc models.++library+    hs-source-dirs:  src/lib+    exposed-modules: Complex, Expr, QMatrix, Qpmc, QTuple, Transitions, SymbolicMatrix+    other-modules:   BitQubitId, EntangleMonad, GatesMatrices+    build-depends:   base >= 4.0 && <5.0, quipper-core >=0.7 && <0.9, containers >= 0.5&& <0.6, matrix >=0.3 && <0.5, mtl >=2.1 && <2.3+    ghc-options:     -Wall -fno-warn-type-defaults+ -- ghc-options:     -Werror -fno-warn-unused-do-bind -fno-warn-orphans -fprof-auto -fprof-cafs++ +executable entangle+    main-is:        Main.hs+    build-depends:  base >= 4.0 && <5.0, entangle, quipper-core >=0.7 && <0.9, matrix+    buildable:      True+    hs-source-dirs: src/exe+    other-modules:  Examples+ -- ghc-options:    -Werror -fno-warn-type-defaults -fno-warn-orphans -fprof-auto -fprof-cafs+    ghc-options:    -Wall -fno-warn-unused-do-bind
+ src/exe/Examples.hs view
@@ -0,0 +1,482 @@+module Examples where++import           Quipper++data RecAction = Loop | Exit deriving Show++exitOn :: Bool -> Circ RecAction+exitOn True  = return Exit+exitOn False = return Loop++----------------------------------------------------------------------++qftInternal :: [Qubit] -> Circ [Qubit]+qftInternal [] = return []+qftInternal [x] = do+  hadamard x+  return [x]+qftInternal (x:xs) = do+  xs' <- qftInternal xs+  xs'' <- rotations x xs' (length xs')+  x' <- hadamard x+  return (x':xs'')+  where+    -- Auxiliary function used by 'qft'.+    rotations :: Qubit -> [Qubit] -> Int -> Circ [Qubit]+    rotations _ [] _ = return []+    rotations c (q:qs) n = do+      qs' <- rotations c qs n+      q' <- rGate ((n + 1) - length qs) q `controlled` c+      return (q':qs')++----------------------------------------------------------------------++myfourthcirc :: Qubit -> Circ Qubit+myfourthcirc q1 = do+    hadamard q1+    qnot q1+    hadamard q1+    qnot q1+    return q1++mythirdcirc :: (Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit)+mythirdcirc (q1, q2, q3) = do+    qnot_at q2 `controlled` q1+    qnot_at q2 `controlled` q3+    qnot_at q2 `controlled` q1+    qnot_at q2 `controlled` q3+    return (q1, q2, q3)++myothercirc :: Qubit -> Circ Qubit+myothercirc q1 = do+    hadamard q1+    hadamard q1+    return q1++mycirc :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)+mycirc (q1, q2, q3, q4, q5, q6) = do+    qnot_at q1 `controlled` q6+    qnot_at q2 `controlled` q3+    qnot_at q5 `controlled` q6+    qnot_at q4 `controlled` q5+    qnot_at q3 `controlled` q4+    gate_W q1 q3+    return (q1, q2, q3, q4, q5, q6)++deutsch :: (Qubit, Qubit) -> Circ Bit+deutsch (q1, q2) = do+    hadamard q1+    hadamard q2+    qnot_at q2 `controlled` q1+    hadamard q1+    measure q1++deutschJozsaNaive :: (Qubit, Qubit, Qubit) -> Circ (Bit, Bit)+deutschJozsaNaive (q1, q2, q3) = do+    hadamard q1+    hadamard q2+    hadamard q3+    --qnot_at q3 `controlled` [q1,q2]+    --qnot_at q2 `controlled` [q1,q3]+    hadamard q1+    hadamard q2+    measure (q1, q2)++circW :: (Qubit, Qubit) -> Circ (Bit, Bit)+circW (q1, q2) = do+    gate_W q1 q2+    gate_W q2 q1+    measure (q1, q2)++oneq :: Qubit -> Circ Qubit+oneq q1 = do+  hadamard_at q1+  return q1+++doubleMeas :: (Qubit, Qubit, Qubit) -> Circ (Bit, Bit)+doubleMeas (q1, q2, _) = measure (q1, q2)++strange :: (Qubit, Qubit) -> Circ (Bit, Bit)+strange (q1, q2) = do+  c2 <- measure q2+  hadamard q1+  hadamard q1+  c1 <- measure q1+  return (c1, c2)++invCnot :: (Qubit, Qubit) -> Circ (Qubit, Qubit)+invCnot (q1, q2) = do+    qnot_at q1 `controlled` q2+    qnot_at q2 `controlled` q1+    --qnot_at q1 `controlled` q2+    return (q1, q2)++testMultiple :: (Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit)+testMultiple (q1, q2, q3) = do+    gate_W q1 q2+    gate_W q2 q1+    qnot_at q1 `controlled` q3+    return (q1, q2, q3)++groverNaive :: (Qubit, Qubit, Qubit) -> Circ (Bit, Bit)+groverNaive (q1,q2,q3) = do+    hadamard_at q1+    hadamard_at q2+    hadamard_at q3+    --gate_X_at q2+    qnot_at q3 `controlled` [q1, q2]+    --gate_X_at q2+    hadamard_at q1+    hadamard_at q2+    gate_X_at q1+    gate_X_at q2+    hadamard_at q2+    qnot_at q2 `controlled` q1+    hadamard_at q2+    gate_X_at q1+    gate_X_at q2+    hadamard_at q1+    hadamard_at q2+    hadamard_at q3+    measure (q1,q2)++groverNaive2 :: (Qubit, Qubit, Qubit) -> Circ (Bit, Bit)+groverNaive2 (q1,q2,q3) = do+    qa <- hadamard q1+    qb <- hadamard q2+    qc <- hadamard q3+    --gate_X_at q2+    qd <- qnot qc `controlled` [qa, qb]+    --gate_X_at q2+    qe <- hadamard qa+    qf <- hadamard qb+    qg <- gate_X qe+    qh <- gate_X qf+    qj <- hadamard qh+    qk <- qnot qj `controlled` qg+    ql <- hadamard qk+    qm <- gate_X qg+    qn <- gate_X ql+    qo <- hadamard qm+    qp <- hadamard qn+    _ <- hadamard qd+    measure (qo,qp)+++testMatrix_6 :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)+testMatrix_6 (q1, q2, q3, q4, q5, q6) = do+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q6+    return (q1,q2,q3,q4,q5,q6)+++testMatrix_5 :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)+testMatrix_5 (q1, q2, q3, q4, q5, q6, q7) = do+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q7+    return (q1,q2,q3,q4,q5,q6,q7)++testMatrix_4 :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit)+testMatrix_4 (q1, q2, q3, q4, q5, q6, q7, q8) = do+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q7+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q6+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q8+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q8+    return (q1,q2,q3,q4,q5,q6,q7,q8)++testMatrix_3 :: (Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit, Qubit)+testMatrix_3 (q1, q2, q3, q4, q5) = do+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q5+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q5+    return (q1,q2,q3,q4,q5)++testMatrix_2 :: (Qubit, Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit, Qubit)+testMatrix_2 (q1, q2, q3, q4) = do+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q4+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q4+    return (q1,q2,q3,q4)++testMatrix_1 :: (Qubit, Qubit, Qubit) -> Circ (Qubit, Qubit, Qubit)+testMatrix_1 (q1, q2, q3) = do+    qnot_at q1 `controlled` q3+    qnot_at q1 `controlled` q2+    qnot_at q1 `controlled` q3+    return (q1,q2,q3)++test_if :: (Qubit, Qubit, Qubit) -> Circ Qubit+test_if (q1, q2, q3) = do+    m1 <- measure q1+    bool1 <- dynamic_lift m1+    return $ if bool1 then q2 else q3++recCirc :: (Qubit, Qubit) -> Circ (Qubit, Qubit)+recCirc (qa,qb) = do+  qc <- hadamard qa+  qd <- qnot qc `controlled` qb+  m1 <- measure qc+  m2 <- measure qb+  bool1 <- dynamic_lift m1+  _ <- dynamic_lift m2+  if bool1+    then+      return (qd,qb)+    else+      recCirc (qd,qb)++recCirc' :: (Qubit, Qubit) -> Circ RecAction+recCirc' (qa, qb) = do+  qc <- hadamard qa+  qd <- qnot qc `controlled` qb+  m1 <- measure qd+  m2 <- measure qb+  bool1 <- dynamic_lift m1+  bool2 <- dynamic_lift m2+  exitOn $ bool1 && bool2+------------------------------++groverSix :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ (Bit, Bit, Bit, Bit, Bit, Bit)+groverSix (q1,q2,q3, q4, q5, q6, q7) = do+    hadamard_at q1+    hadamard_at q2+    hadamard_at q3+    hadamard_at q4+    hadamard_at q5+    hadamard_at q6+    hadamard_at q7+    --startOracle+    qnot_at q7 `controlled` [q1, q2, q3, q4, q5, q6]+    --endOracle++    --startRotation+    hadamard_at q1+    hadamard_at q2+    hadamard_at q3+    hadamard_at q4+    hadamard_at q5+    hadamard_at q6+    gate_X_at q1+    gate_X_at q2+    gate_X_at q3+    gate_X_at q4+    gate_X_at q5+    gate_X_at q6+    hadamard_at q6+    qnot_at q6 `controlled` [q1, q2, q3, q4, q5]+    hadamard_at q6+    gate_X_at q1+    gate_X_at q2+    gate_X_at q3+    gate_X_at q4+    gate_X_at q5+    gate_X_at q6+    hadamard_at q1+    hadamard_at q2+    hadamard_at q3+    hadamard_at q4+    hadamard_at q5+    hadamard_at q6+    --endRotation++    hadamard_at q7+    measure (q1,q2,q3,q4,q5,q6)++---------------------------------++groverRec :: (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ RecAction+groverRec (q1,q2,q3, q4, q5, q6, q7) = do+    qa <- hadamard q1+    qb <- hadamard q2+    qc <- hadamard q3+    qd <- hadamard q4+    qe <- hadamard q5+    qf <- hadamard q6+    qg <- hadamard q7+    --startOracle+    qnot_at qg `controlled` [qa, qb, qc, qd, qe, qf]+    --endOracle++    --startRotation+    hadamard_at qa+    hadamard_at qb+    hadamard_at qc+    hadamard_at qd+    hadamard_at qe+    hadamard_at qf+    gate_X_at qa+    gate_X_at qb+    gate_X_at qc+    gate_X_at qd+    gate_X_at qe+    gate_X_at qf+    hadamard_at qf+    qnot_at qf `controlled` [qa, qb, qc, qd, qe]+    hadamard_at qf+    gate_X_at qa+    gate_X_at qb+    gate_X_at qc+    gate_X_at qd+    gate_X_at qe+    gate_X_at qf+    hadamard_at qa+    hadamard_at qb+    hadamard_at qc+    hadamard_at qd+    hadamard_at qe+    hadamard_at qf+    --endRotation++    hadamard_at qg+    m1 <- measure qa+    m2 <- measure qb+    m3 <- measure qc+    m4 <- measure qd+    m5 <- measure qe+    m6 <- measure qf+    m7 <- measure qg++    bool1 <- dynamic_lift m1+    bool2 <- dynamic_lift m2+    bool3 <- dynamic_lift m3+    bool4 <- dynamic_lift m4+    bool5 <- dynamic_lift m5+    bool6 <- dynamic_lift m6+    bool7 <- dynamic_lift m7++    --if bool1 && (not bool2) && (not bool3) && (not bool4) && (not bool5) && (not bool6)+    --   then return (qa,qb,qc,qd,qe,qf,qg)+    --   else groverRec (qa,qb,qc,qd,qe,qf,qg)+    exitOn $ bool1 && not bool2 && not bool3 && not bool4 && not bool5 && not bool6 && not bool7++groverRecFive :: (Qubit, Qubit, Qubit, Qubit, Qubit) -> Circ RecAction+groverRecFive (q1,q2,q3, q4, q5) = do+    qa <- hadamard q1+    qb <- hadamard q2+    qc <- hadamard q3+    qd <- hadamard q4+    qe <- hadamard q5++    --startOracle+    qnot_at qe `controlled` [qa, qb, qc, qd]+    --endOracle++    --startRotation+    hadamard_at qa+    hadamard_at qb+    hadamard_at qc+    hadamard_at qd++    gate_X_at qa+    gate_X_at qb+    gate_X_at qc+    gate_X_at qd++    hadamard_at qd+    qnot_at qe `controlled` [qa, qb, qc, qd]+    hadamard_at qd++    gate_X_at qa+    gate_X_at qb+    gate_X_at qc+    gate_X_at qd++    hadamard_at qa+    hadamard_at qb+    hadamard_at qc+    hadamard_at qd++    hadamard_at qe++    m1 <- measure qa+    m2 <- measure qb+    m3 <- measure qc+    m4 <- measure qd+    m5 <- measure qe++    bool1 <- dynamic_lift m1+    bool2 <- dynamic_lift m2+    bool3 <- dynamic_lift m3+    bool4 <- dynamic_lift m4+    bool5 <- dynamic_lift m5++    --if bool1 && (not bool2) && (not bool3) && (not bool4) && (not bool5) && (not bool6)+    --   then return (qa,qb,qc,qd,qe,qf,qg)+    --   else groverRec (qa,qb,qc,qd,qe,qf,qg)+    exitOn $ bool1 && not bool2 && not bool3 && not bool4 && not bool5+++----------------------------++branchCirc :: (Qubit, Qubit) -> Circ RecAction+branchCirc (qa, qb) = do+    hadamard_at qa+    m <- measure qb+    bool <- dynamic_lift m+    if bool+       then hadamard_at qa+       else qnot_at qa+    exitOn bool++{- branchCircBoth :: (Qubit, Qubit) -> Circ (Qubit, Qubit, Bool)+branchCircBoth (qa, qb) = do+    hadamard_at qa+    m <- measure qb+    bool <- dynamic_lift m+    if bool+       then hadamard_at qa+       else qnot_at qa+    return (qa, qb, bool)++branchCircQuipper (qa, qb) = do+  (qa, qb, _) <- branchCircBoth+  return (qa, qb)++branchCircQpmc (qa, qb) = do+  (_, _, bool) <- branchCircBoth+  exitOn bool-}++interfCirc :: (Qubit, Qubit) -> Circ RecAction+interfCirc (qa, qb) = do+  hadamard_at qa+  rGate_at 2 qb `controlled` qa+  qftInternal [qa,qb]+  ma <- measure qa+  mb <- measure qb+  boola <- dynamic_lift ma+  boolb <- dynamic_lift mb+  exitOn $ boola == boolb
+ src/exe/Main.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}++module Main where++import           Quipper++import           Data.Matrix    (Matrix)++import           Complex+import           Examples+import           Expr+import           QMatrix+import           Qpmc+import           QTuple+import           SymbolicMatrix+import           Transitions++-- |fullOut takes a function returning a value in the 'Circ' monad,+-- and outputs the result of transforming it to QPMC code+--fullOut :: QTuple a => (a -> Circ b) -> IO ()+fullOut :: (QTuple a, Show b, QCMatrix m Expr, ToQpmc (m (Complex Expr))) => m x -> (b -> [Transition m Expr]) -> (a -> Circ b) -> IO ()+fullOut _ final c = do+    putStr "---\n"+    let tree = circToTree c+    print tree+    putStr "---\n"+    let transitions = circMatrices final c+    putStrLn $ toQpmc transitions+    putStr "---\n"++nonrecursive :: a -> [Transition m Expr]+nonrecursive = const []++recursive :: RecAction -> [Transition m v]+recursive Exit = []+recursive Loop = [Transition Nothing $ StateName 0 []]++symbolic :: SymbolicMatrix a+symbolic = error "proxy"++numeric :: Matrix a+numeric = error "proxy"++main :: IO ()+main = fullOut+  symbolic+  --numeric++  --nonrecursive grover_naive+  --nonrecursive test_matrix_3+  --nonrecursive test_matrix_3+  --nonrecursive strange+  --nonrecursive mycirc+  --nonrecursive test_if+  --recursive recCirc'+  --recursive branchCirc+  --recursive interfCirc+  recursive groverRec
+ src/lib/BitQubitId.hs view
@@ -0,0 +1,50 @@+module BitQubitId (QubitId, BitId, qubitId, toSize) where++newtype QubitId = QubitId Int deriving (Eq, Ord)+newtype BitId = BitId Int deriving (Eq, Ord)++qubitId :: Int -> QubitId+qubitId i+    | i < 0 = error "Negative qubit id"+    | otherwise = QubitId i++bitId :: Int -> BitId+bitId i+    | i < 0 = error "Negative bit id"+    | otherwise = BitId i++liftQubit :: (Int -> Int -> Int) -> QubitId -> QubitId -> QubitId+liftQubit op (QubitId a) (QubitId b) = qubitId $ op a b++instance Show QubitId where+    show (QubitId i) = "qubit " ++ show i++instance Bounded QubitId where+    minBound = QubitId 0+    maxBound = QubitId maxBound++instance Enum QubitId where+    fromEnum (QubitId i) = i+    toEnum = qubitId++instance Num QubitId where+    (+) = liftQubit (+)+    (-) = liftQubit (-)+    fromInteger = qubitId . fromIntegral+    (*) = error "* makes no sense for QubitId"+    abs = error "abs makes no sense for QubitId"+    signum = error "signum makes no sense for QubitId"++instance Show BitId where+    show (BitId i) = "bit " ++ show i++instance Bounded BitId where+    minBound = BitId 0+    maxBound = BitId maxBound++instance Enum BitId where+    fromEnum (BitId i) = i+    toEnum = bitId++toSize :: QubitId -> Integer+toSize (QubitId i) = 2 ^ i
+ src/lib/Complex.hs view
@@ -0,0 +1,62 @@+module Complex (Complex((:+)), ii) where++-- This module is similar to Data.Complex, but with lighter constraints++infix  6  :+++data Complex a = a :+ a++ii :: Num a => Complex a+ii = 0 :+ 1++instance Num a => Num (Complex a) where+    (a :+ b) + (c :+ d) = (a + c) :+ (b + d)+    (a :+ b) - (c :+ d) = (a - c) :+ (b - d)+    (a :+ b) * (c :+ d) = (a * c - b * d) :+ (b * c + a * d)+    fromInteger n = fromInteger n :+ 0+    abs = error "abs not implemented because it would need a Floating instance for the type variable"+    signum = error "signum makes no sense for complex numbers"++instance Fractional a => Fractional (Complex a) where+    recip (a :+ b) =+        let+            d = a * a + b * b+            rp = a / d+            ip = -1 * b / d+        in+            rp :+ ip+    fromRational r = fromRational r :+ 0++instance Floating a => Floating (Complex a) where+    sqrt z =+        let+            r = aabs z+            rc = r :+ 0+            aabs (a :+ b) = sqrt (a * a + b * b)+        in+            (sqrt r :+ 0) * (z + rc) / (aabs (z + rc) :+ 0)++    pi = error "pi"++    log = error "log not implemented"+    exp = error "exp not implemented"++    tan = error "tan not implemented"+    atan = error "atan not implemented"+    atanh = error "atanh not implemented"++    sin = error "sin not implemented"+    asin = error "asin not implemented"+    sinh = error "sinh not implemented"+    asinh = error "asinh not implemented"++    cos = error "cos not implemented"+    acos = error "acos not implemented"+    cosh = error "cosh not implemented"+    acosh = error "acosh not implemented"++instance (Show a, Eq a, Num a) => Show (Complex a) where+    show (a :+ b)+        | b == 0    = show a+        | a == 0    =                  show b ++ "i"+        | otherwise = show a ++ "+" ++ show b ++ "i"
+ src/lib/EntangleMonad.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE FlexibleContexts #-}++module EntangleMonad where++import           Control.Monad+import           Data.List+import           Data.Map.Lazy       (Map)+import qualified Data.Map.Lazy       as DM+import           Data.Maybe+import           Data.Monoid+--import           Debug.Trace++import           Quipper+import           Quipper.Circuit+import           Quipper.Monad+import           Quipper.Transformer++import           BitQubitId++type BitState = Map BitId Bool++newtype EntangleMonad a = EntangleMonad {+    untangle :: BitState -- ^ state of bits before the operation+             -> [QubitId] -- ^ measured qubits before the operation+             -> CircTree (BitState, [QubitId], a) -- ^ tree after the operation+}++instance Functor EntangleMonad where+    fmap = liftM++instance Applicative EntangleMonad where+    pure = return+    (<*>) = ap++instance Monad EntangleMonad where+    return x = EntangleMonad (\bs ms -> LeafNode (bs, ms, x))+    x >>= f = EntangleMonad $ \bs ms -> do+        (bs', ms', y) <- untangle x bs ms+        untangle (f y) bs' ms'++data CircTree a+    = GateNode String [QubitId] [QubitId] (CircTree a) -- ^ name, affected qubits, controls, child+    | ParameterizedGateNode String Double [QubitId] [QubitId] (CircTree a) -- ^ name, parameter, affected qubits, controls, child+    | MeasureNode QubitId BitId (CircTree a) (CircTree a)+    | LeafNode a++instance Functor CircTree where+    fmap = liftM++instance Applicative CircTree where+    pure = return+    (<*>) = ap++instance Monad CircTree where+    return = LeafNode+    (GateNode n qs cs t) >>= f = GateNode n qs cs (t >>= f)+    (ParameterizedGateNode n p qs cs t) >>= f = ParameterizedGateNode n p qs cs (t >>= f)+    (MeasureNode q b l r) >>= f = MeasureNode q b (l >>= f) (r >>= f)+    (LeafNode x) >>= f = f x++instance Foldable CircTree where+    foldMap f (GateNode _ _ _ t)                = foldMap f t+    foldMap f (ParameterizedGateNode _ _ _ _ t) = foldMap f t+    foldMap f (MeasureNode _ _ l r)             = foldMap f l <> foldMap f r+    foldMap f (LeafNode x)                      = f x++instance Show a => Show (CircTree a) where+    show = showTree 0 show' child where+        child (GateNode _ _ _ c)                = [c]+        child (ParameterizedGateNode _ _ _ _ c) = [c]+        child (MeasureNode _ _ l r)             = [l, r]+        child (LeafNode _)                      = []+        show' (GateNode n qs cs _) = "GateNode \"" ++ n ++ "\" on " ++ qubits ++ (if null controls then "" else " and controls " ++ controls) where+            qubits   = intercalate ", " $ map show qs+            controls = intercalate ", " $ map show cs+        show' (ParameterizedGateNode n t qs cs _) = "ParameterizedGateNode \"" ++ n ++ "\" with parameter " ++ show t ++ " on " ++ qubits ++ (if null controls then "" else " and controls " ++ controls) where+            qubits   = intercalate ", " $ map show qs+            controls = intercalate ", " $ map show cs+        show' (MeasureNode q b _ _) = "MeasureNode on " ++ show q ++ " producing " ++ show b+        show' (LeafNode x) = "LeafNode of " ++ show x++showTree :: Int -> (a -> String) -> (a -> [a]) -> a -> String+showTree i sf cf t = indent i ++ sf t ++ concatMap showChild children where+    children = cf t+    fork = length children > 1+    showChild c = "\n" ++ showTree (if fork then i+1 else i) sf cf c++indent :: Int -> String+indent i = replicate (4*i) ' '++transformGate :: String -> [QubitId] -> [QubitId] -> EntangleMonad ()+transformGate name qs cs = EntangleMonad res where+    res bs ms = GateNode name qs cs $ LeafNode (bs, ms, ())++transformParameterizedGate :: String -> Double -> [QubitId] -> [QubitId] -> EntangleMonad ()+transformParameterizedGate name t qs cs = EntangleMonad res where+    res bs ms = ParameterizedGateNode name t qs cs $ LeafNode (bs, ms, ())++transformMeasure :: QubitId -> EntangleMonad BitId+--transformMeasure i | trace ("Measuring " ++ show (unQubitID i)) False = undefined+transformMeasure i = EntangleMonad res where+    res bs ms = MeasureNode i new l r where+        ms' = i : ms++        lastBit = foldr max minBound $ DM.keys bs+        new = succ lastBit++        bsF = DM.insert new False bs+        l = LeafNode (bsF, ms', new)++        bsT = DM.insert new True bs+        r = LeafNode (bsT, ms', new)++transformDynamicLifting :: BitId -> EntangleMonad Bool+transformDynamicLifting i = EntangleMonad res where+    res bs ms = LeafNode (bs, ms, b) where+        b = fromMaybe False $ DM.lookup i bs++-- |mytransformer is the main transformer.+-- it used to extract the needed information from a Quipper circuit.+mytransformer :: Transformer EntangleMonad QubitId BitId+--mytransformer g | trace (show g) False = undefined+mytransformer (T_QGate name _ _ _ _ f) = f g where+    open (Signed _ False) = error "Negative controls are not supported yet"+    open (Signed x True)  = x+    g wires g_controls controls = do+        transformGate name wires (map (assumeQubit . open) controls)+        return (wires, g_controls, controls)+mytransformer (T_QRot name _ _ _ t _ f) = f g where+    open (Signed _ False) = error "Negative controls are not supported yet"+    open (Signed x True)  = x+    g wires g_controls controls = do+        transformParameterizedGate name t wires (map (assumeQubit . open) controls)+        return (wires, g_controls, controls)+mytransformer (T_QMeas f) = f transformMeasure+mytransformer (T_DTerm _ f) = f (const $ return ())+mytransformer g = error $ "Gate \"" ++ show g ++ "\" is not supported yet"++assumeQubit :: B_Endpoint QubitId BitId -> QubitId+assumeQubit (Endpoint_Qubit qi) = qi+assumeQubit (Endpoint_Bit _) = error "Using bits as controls is not supported yet"++mydtransformer :: DynamicTransformer EntangleMonad QubitId BitId+mydtransformer = DT mytransformer (error "Boxed circuits are not supported yet") transformDynamicLifting++showIndented :: Show a => Int -> a -> String+showIndented i x = indent i ++ replace (show x) where+    replace []        = []+    replace ('\n':ss) = '\n' : indent i ++ replace ss+    replace (s:ss)    = s : replace ss++-- |buildTree takes a 'Circuit', its arity and returns a tree representing it.+buildTree :: DBCircuit x -> Int -> CircTree x+buildTree circuit n = fmap (fst . (\(_, _, x) -> x)) res where+    res = untangle monad DM.empty []+    monad = transform_dbcircuit mydtransformer circuit bindings+    bindings = foldr (\i -> bind_qubit (qubit_of_wire i) (qubitId i)) bindings_empty [1..n]
+ src/lib/Expr.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE PatternGuards #-}++module Expr (Expr, FromDouble(..)) where++import           Data.Ratio++data Expr+    = ILeaf Integer+    | DLeaf Double+    | Expr :+: Expr+    | Expr :*: Expr+    | Expr :/: Expr+    | Abs Expr+    | Sqrt Expr+    | Exp Expr+    | Pi+    deriving Eq++infixl 6 :+:+infixl 7 :*:+infixl 7 :/:++class FromDouble a where+    fromDouble :: Double -> a++instance FromDouble Expr where+    fromDouble = DLeaf++-- eval :: Expr -> Either Integer Double+-- eval (Leaf i) = Left i+-- eval (i :+: j) = lift2 (+) (+) i j+-- eval (i :*: j) = lift2 (*) (*) i j+-- eval (i :/: j) = lift2 div (/) i j+-- eval (Abs i) = lift1 abs abs i+-- eval (Sqrt i) = (Right . sqrt . toDouble . eval) i+--+-- toDouble :: Either Integer Double -> Double+-- toDouble (Left a) = fromInteger a+-- toDouble (Right b) = b+--+-- lift1 :: (Integer -> Integer) -> (Double -> Double) -> Expr -> Either Integer Double+-- lift1 i d e = lift' (eval e) where+--     lift' (Left x) = Left $ i x+--     lift' x = Right $ d (toDouble x)+--+-- lift2 :: (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> Expr -> Expr -> Either Integer Double+-- lift2 i d e f = lift' (eval e) (eval f) where+--     lift' (Left x) (Left y) = Left $ i x y+--     lift' x y = Right $ d (toDouble x) (toDouble y)++instance Num Expr where+    a + b = simplify $ a :+: b+    a * b = simplify $ a :*: b+    abs a = simplify $ Abs a+    signum = undefined+    fromInteger = ILeaf+    negate a = a * ILeaf (-1)++instance Fractional Expr where+    fromRational r = ILeaf (numerator r) / ILeaf (numerator r)+    a / b = simplify $ a :/: b++instance Floating Expr where+    sqrt a = simplify $ Sqrt a+    exp a = simplify $ Exp a+    pi = Pi+    log = undefined+    sin = undefined+    cos = undefined+    asin = undefined+    acos = undefined+    atan = undefined+    sinh = undefined+    cosh = undefined+    asinh = undefined+    acosh = undefined+    atanh = undefined+++simplify :: Expr -> Expr+simplify (ILeaf a :+: ILeaf b)         = ILeaf $ a + b+simplify (ILeaf 0 :+: a)              = simplify a+simplify (a :+: ILeaf 0)              = simplify a+simplify ((a :/: b) :+: c)           = (a + b * c) / b+simplify (a :+: (b :/: c))           = (a * c + b) / c++simplify (ILeaf 0 :*: _)              = 0+simplify (_ :*: ILeaf 0)              = 0+simplify (ILeaf 1 :*: a)              = simplify a+simplify (a :*: ILeaf 1)              = simplify a+simplify (ILeaf a :*: ILeaf b)         = ILeaf $ a * b+simplify ((a :/: b) :*: c)           = (a * c) / b+simplify (a :*: (b :/: c))           = (a * b) / c+simplify (Sqrt a :*: Sqrt b)         = sqrt $ a * b+simplify ((a :*: b) :*: c)           = a * (b * c)+simplify (a :*: ILeaf b)              = ILeaf b * a+simplify (ILeaf a :*: (ILeaf b :*: c)) = ILeaf (a * b) * c+simplify (a :*: (b@(ILeaf _) :*: c))  = b * (a * c)++simplify (a :/: s@(Sqrt _))          = (a * s) / (s * s)+simplify ((a :/: b) :/: c)           = a / (b * c)+simplify (a :/: (b :/: c))           = (a * c) / b+simplify (ILeaf a :/: ILeaf b)         | a `mod` b == 0 = ILeaf $ a `div` b+simplify ((ILeaf a :*: b) :/: ILeaf c) | a `mod` c == 0 = (ILeaf $ a `div` c) * b++simplify (Sqrt (ILeaf a))             | Just r <- perfectSqrt a = ILeaf r+simplify (Sqrt (x :/: y))            = sqrt x / sqrt y++simplify (Abs (ILeaf a))              = ILeaf $ abs a++simplify e                           = e++perfectSqrt :: Integer -> Maybe Integer+perfectSqrt i | i < 0 = Nothing+perfectSqrt a | b * b == a = Just b where+    b = floor $ sqrt $ fromInteger a+perfectSqrt _ = Nothing+++-- showF :: Expr -> String+-- showF = showF' 0+--+-- showF' :: Int -> Expr -> String+-- showF' i e = prefix i ++ showF'' e where+--     prefix 0 = ""+--     prefix i = concat (replicate i "   ")+--     showF'' (Leaf a)  = show a+--     showF'' (x :+: y) = "+\n"    ++ showF' (i+1) x ++ "\n" ++ showF' (i+1) y+--     showF'' (x :*: y) = "*\n"    ++ showF' (i+1) x ++ "\n" ++ showF' (i+1) y+--     showF'' (x :/: y) = "/\n"    ++ showF' (i+1) x ++ "\n" ++ showF' (i+1) y+--     showF'' (Abs a)   = "abs\n"  ++ showF' (i+1) a+--     showF'' (Sqrt a)  = "sqrt\n" ++ showF' (i+1) a++instance Show Expr where+    show (ILeaf i) = show i+    show (DLeaf d) = show d+    show (x :+: y) = "(" ++ show x ++ " + " ++ show y ++ ")"+    show (x :*: y) = "(" ++ show x ++ " * " ++ show y ++ ")"+    show (x :/: y) = "(" ++ show x ++ " / " ++ show y ++ ")"+    show (Abs a)   = "abs(" ++ show a ++ ")"+    show (Sqrt a)  = "sqrt(" ++ show a ++ ")"+    show (Exp a)   = "exp(" ++ show a ++ ")"+    show Pi        = "pi"
+ src/lib/GatesMatrices.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module GatesMatrices (+    nameToMatrix,+    nameToParameterizedMatrix) where++import           Complex+import           Expr+import           QMatrix++-- |nameToMatrix takes a gate name and returns its matrix+nameToMatrix :: (QCMatrix m a, Floating a, Fractional a) => String -> m (Complex a)+nameToMatrix "not"  = pauliX+nameToMatrix "X"    = pauliX+nameToMatrix "Z"    = pauliZ+nameToMatrix "H"    = hadamard+nameToMatrix "W"    = swapSqrt+nameToMatrix "swap" = swap+nameToMatrix n      = error $ "Gate \"" ++ show n ++ "\" is not supported yet"++nameToParameterizedMatrix :: (QCMatrix m a, FromDouble a, Floating a) => String -> Double -> m (Complex a)+nameToParameterizedMatrix "R(2pi/%)" n = phaseShift (2 * pi / fromDouble n)+nameToParameterizedMatrix n       _ = error $ "Parameterized gate \"" ++ show n ++ "\" is not supported yet"
+ src/lib/QMatrix.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module QMatrix (+    MeasureKind(..),++    QMatrix, QCMatrix,+    kronecker, identity, matrix, zero, hadamard,+    pauliX, pauliZ, swap, swapSqrt, phaseShift, measure,+    (<->), (<|>)+    ) where++import           Complex++data MeasureKind = UL | BR++class (Num a, Num (m a)) => QMatrix m a where+    -- |kronecker is the Kronecker product+    kronecker :: m a -> m a -> m a+    identity :: Integer -> m a+    zero :: Integer -> Integer -> m a+    matrix :: Integer -> Integer -> (Integer -> Integer -> a) -> m a+    (<->) :: m a -> m a -> m a+    (<|>) :: m a -> m a -> m a++    -- |hadamard is the matrix for the Hadamard gate+    hadamard :: Floating a => m a+    hadamard = matrix 2 2 hadamardMatrix where+        hadamardMatrix 2 2 = -1 / sqrt 2+        hadamardMatrix _ _ = 1 / sqrt 2++    -- |pauliX is the Pauli X matrix (Not)+    pauliX :: m a+    pauliX = matrix 2 2 pauliXMatrix where+        pauliXMatrix 1 2 = 1+        pauliXMatrix 2 1 = 1+        pauliXMatrix _ _ = 0++    -- |pauliZ is the Pauli Z matrix+    pauliZ :: m a+    pauliZ = matrix 2 2 pauliZMatrix where+        pauliZMatrix 1 1 = 1+        pauliZMatrix 2 2 = -1+        pauliZMatrix _ _ = 0++    -- |swap is a matrix that swaps two qubits+    swap :: m a+    swap = matrix 4 4 swapMatrix where+        swapMatrix 1 1 = 1+        swapMatrix 2 3 = 1+        swapMatrix 3 2 = 1+        swapMatrix 4 4 = 1+        swapMatrix _ _ = 0++    -- |measure is the measure matrix+    -- measure UL is [1, 0; 0, 0] whereas measure BR is [0, 0; 0, 1]+    measure :: MeasureKind -> m a+    measure k =+        let+            gen UL 1 1 = 1+            gen BR 2 2 = 1+            gen _ _ _  = 0+        in+            matrix 2 2 (gen k)+++class (Fractional a, Floating a, QMatrix m (Complex a)) => QCMatrix m a where+    -- |swapSqrt is the gate_W, the square root of the swap matrix+    swapSqrt :: m (Complex a)+    swapSqrt = matrix 4 4 swapSqrtMatrix where+        swapSqrtMatrix 1 1 = 1+        swapSqrtMatrix 2 2 = (1 + ii) / 2+        swapSqrtMatrix 2 3 = (1 - ii) / 2+        swapSqrtMatrix 3 2 = (1 - ii) / 2+        swapSqrtMatrix 3 3 = (1 + ii) / 2+        swapSqrtMatrix 4 4 = 1+        swapSqrtMatrix _ _ = 0++    phaseShift :: a -> m (Complex a)+    phaseShift phi = matrix 2 2 phaseShiftMatrix where+        phaseShiftMatrix 1 1 = 1+        phaseShiftMatrix 2 2 = exp $ ii * (phi :+ 0)+        phaseShiftMatrix _ _ = 0
+ src/lib/QTuple.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module QTuple where++import           Quipper++-- |The 'Tuple' class creates a tuple out of a list.+class QTuple a where+    tupleSize :: a -> Int+    tupleFromList :: [Qubit] -> a++instance QTuple Qubit where+    tupleSize _ = 1+    tupleFromList (q1:_) = q1+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 1 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit) where+    tupleSize _ = 2+    tupleFromList (q1:q2:_) = (q1, q2)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 2 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit) where+    tupleSize _ = 3+    tupleFromList (q1:q2:q3:_) = (q1, q2, q3)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 3 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 4+    tupleFromList (q1:q2:q3:q4:_) = (q1, q2, q3, q4)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 4 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 5+    tupleFromList (q1:q2:q3:q4:q5:_) = (q1, q2, q3, q4,q5)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 5 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 6+    tupleFromList (q1:q2:q3:q4:q5:q6:_) = (q1, q2, q3, q4, q5, q6)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 6 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 7+    tupleFromList (q1:q2:q3:q4:q5:q6:q7:_) = (q1, q2, q3, q4, q5, q6, q7)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 7 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 8+    tupleFromList (q1:q2:q3:q4:q5:q6:q7:q8:_) = (q1, q2, q3, q4, q5, q6, q7, q8)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 8 or more, got" ++ show (length l)++instance QTuple (Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit, Qubit) where+    tupleSize _ = 9+    tupleFromList (q1:q2:q3:q4:q5:q6:q7:q8:q9:_) = (q1, q2, q3, q4, q5, q6, q7, q8, q9)+    tupleFromList l = error $ "Not enough elements passed to tupleFromList, expected 9 or more, got" ++ show (length l)
+ src/lib/Qpmc.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Qpmc where++import           Data.Char+import           Data.Function+import           Data.List+import           Data.Maybe++import           Complex+import           Transitions++class ToQpmc a where+    toQpmc :: a -> String++instance ToQpmc (m (Complex a)) => ToQpmc [Transitions m a] where+    toQpmc ts = "qmc\n"+            ++ concatMap transitionToMatrix (concatMap trDestinations ts)+            ++ "module test\n"+            ++ "  s: [0.." ++ show (foldr (max . snId) 0 named) ++ "] init 0;\n"+            ++ concatMap (\i -> "  b" ++ show i ++ ": bool init false;\n") [0..bs-1]+            ++ concatMap toQpmc (sortBy tsort ts)+            ++ concatMap finalToQpmc finals+            ++ "endmodule" where+        bs = foldr (max . length . snBs . trToState) 0 $ concatMap trDestinations ts+        named :: [StateName]+        named = concatMap (map trToState . trDestinations) ts+        finals :: [StateName]+        finals = filter (\(StateName i _) -> i > 0) $ named \\ map trFromState ts++tsort :: Transitions m a -> Transitions m a -> Ordering+tsort = compare `on` trFromState++stateNameToQpmcGuard :: StateName -> String+stateNameToQpmcGuard (StateName i bs) = "(s = " ++ show i ++ ")" ++ booleans where+    booleans = concatMap (\(b,j) -> " & " ++ (if b then "" else "!") ++ "b" ++ show j) (zip bs [0..])++stateNameToQpmcDestination :: Int -> StateName -> String+stateNameToQpmcDestination prefix (StateName i bs) = "(s' = " ++ show i ++ ")" ++ booleans where+    booleans = concatMap (\(b,j) -> " & " ++ "(b" ++ show j ++ "' = " ++ showLower b ++ ")") (drop prefix $ zip bs [0..])++showLower :: Show a => a -> String+showLower = map toLower . show++-- |finalToQpmc returns the QPMC code for a final state+finalToQpmc :: StateName -> String+finalToQpmc s = "  [] " ++ stateNameToQpmcGuard s ++ " -> true;\n"++-- |transitionToMatrix returns the QPMC code for a matrix+transitionToMatrix :: ToQpmc (m (Complex a)) => Transition m a -> String+transitionToMatrix t = fromMaybe "" $ do+    mat <- trMatrix t+    let inner = toQpmc mat+    let res = "const matrix A" ++ show (trToState t) ++ " = " ++ inner ++ ";\n"+    return res++instance ToQpmc (Transitions m a) where+    toQpmc (Transitions f ds) = "  [] " ++ stateNameToQpmcGuard f ++ " -> " ++ transitions ++ ";\n" where+        transitions = intercalate " + " $ map (transitionToQpmc (length $ snBs f)) ds+        transitionToQpmc prefix (Transition Nothing n) = stateNameToQpmcDestination prefix n+        transitionToQpmc prefix (Transition (Just _) n) = "<<A" ++ show n ++ ">> : " ++ stateNameToQpmcDestination prefix n
+ src/lib/SymbolicMatrix.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module SymbolicMatrix (+    SymbolicMatrix,+    eval+    ) where++import           Complex+import           QMatrix+import           Qpmc++data StandardMatrix a+    = Identity Integer+    | Hadamard+    | PauliX+    | PauliZ+    -- | ControlNot+    | Swap+    | PhaseShift a+    | Measure MeasureKind++data SymbolicMatrix a+    = StandardMatrix (StandardMatrix a)+    | Zero Integer Integer+    | Matrix Integer Integer (Integer -> Integer -> a)+    | Multiply (SymbolicMatrix a) (SymbolicMatrix a)+    | Kronecker (SymbolicMatrix a) (SymbolicMatrix a)+    | HorizontalJoin (SymbolicMatrix a) (SymbolicMatrix a)+    | VerticalJoin (SymbolicMatrix a) (SymbolicMatrix a)++instance Show a => Show (StandardMatrix a) where+    show (Identity i)   = "identity(" ++ show i ++ ")"+    show Hadamard       = "Hadamard"+    show PauliX         = "PauliX"+    show PauliZ         = "PauliZ"+    --show ControlNot     = "CNOT"+    show Swap           = "Swap"+    show (PhaseShift d) = "PhaseShift(" ++ show d ++ ")"+    show (Measure UL)   = "M0"+    show (Measure BR)   = "M1"++instance Show a => Show (SymbolicMatrix a) where+    show (StandardMatrix m) = show m+    show (Zero r c) = "?Zero " ++ show r ++ " " ++ show c+    show (Matrix 2 2 f) = "[" ++ show (f 1 1) ++ ", " ++ show (f 1 2) ++ "; " ++ show (f 2 1) ++ ", " ++ show (f 2 2) ++ "]"+    show (Matrix r c _)  = "?Matrix " ++ show r ++ " " ++ show c+    show (Kronecker a b) = "kron (" ++ show a ++ ", " ++ show b ++ ")"+    show (Multiply a b)  = "?Multiply (" ++ show a ++ ") (" ++ show b ++ ")"+    show (HorizontalJoin l r) = "?HorizontalJoin (" ++ show l ++ ") (" ++ show r ++ ")"+    show (VerticalJoin u d) = "?VerticalJoin (" ++ show u ++ ") (" ++ show d ++ ")"++instance Num (SymbolicMatrix a) where+    (*) (StandardMatrix (Identity _)) b = b+    (*) a (StandardMatrix (Identity _)) = a+    (*) a b                             = Multiply a b++    (+) = error "+ undefined for SymbolicMatrix"+    (-) = error "- undefined for SymbolicMatrix"+    abs = error "abs undefined for SymbolicMatrix"+    signum = error "signum undefined for SymbolicMatrix"+    fromInteger = error "fromInteger undefined for SymbolicMatrix"++instance (Num a) => QMatrix SymbolicMatrix a where+    kronecker a (StandardMatrix (Identity 1)) = a+    kronecker (StandardMatrix (Identity 1)) b = b+    kronecker a b                             = Kronecker a b++    identity = StandardMatrix . Identity++    zero = Zero++    matrix = Matrix+    (<->) = VerticalJoin+    (<|>) = HorizontalJoin++    hadamard = StandardMatrix Hadamard+    pauliX = StandardMatrix PauliX+    pauliZ = StandardMatrix PauliZ+    swap = StandardMatrix Swap+    measure = StandardMatrix . Measure++instance (Floating a, Fractional a, Num a) => QCMatrix SymbolicMatrix a where+    phaseShift t = StandardMatrix $ PhaseShift $ t :+ 0++instance Show a => ToQpmc (SymbolicMatrix a) where+    toQpmc = show++eval :: (Floating a, Show a, QCMatrix m a) => SymbolicMatrix a -> m (Complex a)+eval (Zero r c) = zero r c+eval (Matrix r c f) = matrix r c $ \y x -> f y x :+ 0+eval (Kronecker a b) = kronecker (eval a) (eval b)+eval (Multiply a b) = eval a * eval b+eval (HorizontalJoin a b) = eval a <|> eval b+eval (VerticalJoin a b) = eval a <-> eval b+eval (StandardMatrix m) = eval' m where+    eval' (Identity i)   = identity i+    eval' Hadamard       = hadamard+    eval' PauliX         = pauliX+    eval' PauliZ         = pauliZ+    eval' Swap           = swap+    eval' (PhaseShift d) = phaseShift d+    eval' (Measure k)    = measure k
+ src/lib/Transitions.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Transitions where++import           Quipper+import           Quipper.Circuit+import           Quipper.Monad++import           BitQubitId+import           Complex+import           EntangleMonad+import           Expr+import qualified GatesMatrices+import           QMatrix+import           QTuple++data StateName = StateName {+    snId :: Integer,  -- ^ state id+    snBs :: [Bool]    -- ^ boolean values in the state+} deriving Eq++instance Ord StateName where+    compare a b+        | snId a < snId b = LT+        | snId a > snId b = GT+        | otherwise = compare' (snBs a) (snBs b) where+            compare' [] []              = EQ+            compare' [] _               = LT+            compare' _ []               = GT+            compare' (True:_) (False:_) = LT+            compare' (False:_) (True:_) = GT+            compare' (_:as) (_:bs)      = compare' as bs++instance Show StateName where+    show (StateName i bs) = show i ++ if null bs then "" else "_" ++ map (\b -> if b then 'T' else 'F') (reverse bs)++data Transitions m v = Transitions {+    trFromState    :: StateName,+    trDestinations :: [Transition m v]+}++instance Show (Transitions m v) where+    show (Transitions from dests) = "[Transitions trFromState=" ++ show from ++ " trDestinations=" ++ show dests ++ "]"++data Transition m v = Transition {+    trMatrix  :: Maybe (m (Complex v)),+    trToState :: StateName+}++instance Show (Transition m v) where+    show (Transition _ to) = "[Transition trMatrix=... trToState=" ++ show to ++ "]"++type QubitCount = QubitId+type ControlCount = QubitId++-- |circMatrices takes a function returning a value in the 'Circ' monad,+-- and calculates the list of QPMC transitions needed to represent it.+circMatrices :: (FromDouble a, QTuple q, Show b, QCMatrix m a) => (b -> [Transition m a]) -> (q -> Circ b) -> [Transitions m a]+circMatrices final = treeToTransitions final . circToTree++circToTree :: QTuple a => (a -> Circ b) -> CircTree b+circToTree mcirc = tree where+    arg = tupleFromList $ map qubit_of_wire [1..]+    circ = extract_general arity_empty (mcirc arg)+    argsLength = tupleSize arg+    tree = buildTree circ argsLength++treeToTransitions :: (FromDouble a, Show b, QCMatrix m a) => (b -> [Transition m a]) -> CircTree b -> [Transitions m a]+treeToTransitions final t = go (StateName 0 []) t where+    wires :: [QubitId]+    wires = getWires t+    qubit_max :: QubitId+    qubit_max = foldr max minBound wires+    go sn (LeafNode x) = if null f then [] else [Transitions sn f] where+        f = final x+    go sn@(StateName i bs) (GateNode name qs cts c) = Transitions sn [tr] : go state' c where+        tr = Transition (Just mat) state'+        mat = gateToMatrix qubit_max name qs cts+        state' = StateName (succ i) bs+    go sn@(StateName i bs) (ParameterizedGateNode name k qs cts c) = Transitions sn [tr] : go state' c where+        tr = Transition (Just mat) state'+        mat = parameterizedGateToMatrix qubit_max name k qs cts+        state' = StateName (succ i) bs+    go sn@(StateName i bs) (MeasureNode qi _ l r) = Transitions sn [lt, rt] : go ls l ++ go rs r where+        lmat = between (pred qi) (QMatrix.measure UL) (qubit_max - qi)+        ls = StateName (succ i) (bs ++ [False])+        lt = Transition (Just lmat) ls++        rmat = between (pred qi) (QMatrix.measure BR) (qubit_max - qi)+        rs = StateName (succ i) (bs ++ [True])+        rt = Transition (Just rmat) rs++-- |getWires returns the qubit numbers involved in a gate.+--getWires :: CircTree a -> [QubitId]+getWires :: Show a => CircTree a -> [QubitId]+getWires (LeafNode _)                        = []+getWires (GateNode _ qs cs c)                = qs ++ cs ++ getWires c+getWires (ParameterizedGateNode _ _ qs cs c) = qs ++ cs ++ getWires c+getWires (MeasureNode q _ l r)               = q : getWires l ++ getWires r++-- |sw q t is a function that swaps q and t+sw :: Eq a => a -> a -> (a -> a)+sw q t x | x == q = t+         | x == t = q+         | otherwise = x++-- |gateToMatrix takes the total number of qubits, a gate data and returns the matrix needed to represent it.+gateToMatrix :: QCMatrix m a => QubitCount -> String -> [QubitId] -> [QubitId] -> m (Complex a)+gateToMatrix size name qs cs =+    let+        wires = cs ++ qs+        mi = minimum wires+        swaps = reverse $ generateSwaps wires [mi..]+        controlCount = qubitId $ length cs+        qubitCount = qubitId $ length qs+        ma = pred $ mi + controlCount + qubitCount+        l = pred mi+        m = nameToMatrix controlCount qubitCount name+        r = size - ma+        mat = between l m r+    in+        moving size swaps mat++-- |parameterizedGateToMatrix takes the total number of qubits, a gate data and returns the matrix needed to represent it.+parameterizedGateToMatrix :: (FromDouble a, QCMatrix m a) => QubitCount -> String -> Double -> [QubitId] -> [QubitId] -> m (Complex a)+parameterizedGateToMatrix size name t qs cs =+    let+        wires = cs ++ qs+        mi = minimum wires+        swaps = reverse $ generateSwaps wires [mi..]+        controlCount = qubitId $ length cs+        qubitCount = qubitId $ length qs+        ma = pred $ mi + controlCount + qubitCount+        l = pred mi+        m = nameToParameterizedMatrix t controlCount qubitCount name+        r = size - ma+        mat = between l m r+    in+        moving size swaps mat++-- |generateSwaps takes a finite list of source qubits, a list of target qubits,+-- and returns a list of swaps that moves the qubits into place.+-- Algebrically this is a decomposition of a generic permutation into swaps.+generateSwaps :: Eq t => [t] -> [t] -> [(t, t)]+generateSwaps [] _ = []+generateSwaps _ [] = []+generateSwaps (q:qs) (t:ts)+    | q == t = generateSwaps qs ts+    | otherwise = (q, t) : generateSwaps (map (sw q t) qs) ts++-- |nameToMatrix is the matrix for the given named gate.+-- It returns a matrix with an identity in the top left+-- and the action in the bottom right.+nameToMatrix :: (Floating a, QCMatrix m a) => ControlCount -> QubitCount -> String -> m (Complex a)+nameToMatrix controlCount qubitCount name =+    let+        total_size = toSize (controlCount + qubitCount)+        small_size = if qubitCount == 0 then 0 else toSize qubitCount+        big_size = total_size - small_size+        active = GatesMatrices.nameToMatrix name+    in+        if big_size == 0+            then active+            else+                (identity big_size        <|> zero big_size small_size)+                                          <->+                (zero small_size big_size <|> active)++-- |nameToParameterizedMatrix is the matrix for the given named parameterized gate.+-- It returns a matrix with an identity in the top left+-- and the action in the bottom right.+nameToParameterizedMatrix :: (FromDouble a, QCMatrix m a) => Double -> ControlCount -> QubitCount -> String -> m (Complex a)+nameToParameterizedMatrix t controlCount qubitCount name =+    let+        total_size = toSize (controlCount + qubitCount)+        small_size = if qubitCount == 0 then 0 else toSize qubitCount+        big_size = total_size - small_size+        active = GatesMatrices.nameToParameterizedMatrix name t+    in+        if big_size == 0+            then active+            else+                (identity big_size        <|> zero big_size small_size)+                                          <->+                (zero small_size big_size <|> active)++-- |moving returns a matrix representing:+--   * moving the chosen qubits+--   * applying the given matrix+--   * moving the qubits back to their original position+moving :: QMatrix m a => QubitCount -> [(QubitId, QubitId)] -> m a -> m a+moving size moves m = back * m * forth where+    forth = move size moves+    back  = move size $ reverse moves++-- |move is the matrix that moves the chosen qubits+move :: QMatrix m a => QubitCount -> [(QubitId, QubitId)] -> m a+move size = foldr f $ identity (toSize size) where+    f (t1, t2) m = swapToMatrix size t1 t2 * m++-- |swapToMatrix is the matrix swapping the chosen qubits+swapToMatrix :: QMatrix m a => QubitCount -> QubitId -> QubitId -> m a+swapToMatrix size n m+    | n > m = swapToMatrix size m n+    | n == m = identity $ toSize size+    | n < pred m  = swapToMatrix size n (pred m) * swapToMatrix size (pred m) m+    -- otherwise: n == pred m+    | otherwise = between (pred n) QMatrix.swap (size - m)++-- |between takes a matrix and applies it to the chosen qubits,+-- without modifying the other ones+between :: QMatrix m a => QubitCount -> m a -> QubitCount -> m a+between b m a = before `kronecker` m `kronecker` after where+    before = identity $ toSize b+    after  = identity $ toSize a