packages feed

quipper-utils (empty) → 0.9.0.0

raw patch · 19 files changed

+3912/−0 lines, 19 filesdep +basedep +containersdep +mtlbuild-type:Customsetup-changed

Dependencies added: base, containers, mtl, newsynth, process, random, template-haskell, unix

Files

@@ -0,0 +1,66 @@+Contributors are listed here, in alphabetical order by last name.+Unless otherwise noted, the copyright for his or her contributions+rests with each individual author. For contributions by authors whose+name is marked (ACS), the copyright rests with Applied Communication+Sciences.++Copyright (C) 2011-2019. All rights reserved.+Copyright (C) 2012-2013 Applied Communication Sciences. All rights+reserved.++Richard Eisenberg+Alexander S. Green+Peter LeFanu Lumsdaine+Keith Kim (ACS)+Siun-Chuon Mau (ACS)+Baranidharan Mohan+Won Ng (ACS)+Joel Ravelomanantsoa-Ratsimihah+Neil J. Ross+Artur Scherer (ACS)+Peter Selinger+Benoît Valiron+Alexandr Virodov (ACS)+Stephan A. Zdancewic++This research was supported by the Intelligence Advanced Research+Projects Activity (IARPA) via Department of Interior National Business+Center contract numbers D11PC20168 and D12PC00527. The U.S. Government+is authorized to reproduce and distribute reprints for Governmental+purposes notwithstanding any copyright annotation thereon. Disclaimer:+The views and conclusions contained herein are those of the authors+and should not be interpreted as necessarily representing the official+policies or endorsements, either expressed or implied, of IARPA,+DoI/NBC, or the U.S. Government.++----------------------------------------------------------------------+LICENSE++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++1. Redistributions of source code must retain the above copyright+  notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+  notice, this list of conditions and the following disclaimer in the+  documentation and/or other materials provided with the+  distribution.++3. The name of the authors and copyright holders may not be used to+  endorse or promote products derived from this software without+  specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT,+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING+IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+----------------------------------------------------------------------
+ ChangeLog view
@@ -0,0 +1,76 @@+December 29, 2019: Release 0.9.0.0++ * Overhauled module structure:+ +   Old:                New:+   ====                ====+   +   Quipper.XYZ         Quipper.Internal.XYZ+   QuipperLib.XYZ      Quipper.Libraries.XYZ+   Libraries.XYZ       Quipper.Utils.XYZ+   Algorithms.XYZ      Quipper.Algorithms.XYZ+   tests               Quipper.Demos+   Programs            Quipper.Programs++ * Re-packaged Quipper as Cabal packages. Added executables quipper,+   quipper-pp, quipperi, quipperdoc in lieu of shell scripts.+ * Moved PDF Previewer to a separate library in Quipper.Utils.Preview+ * Added a MonadFail instance to Circ, to keep ghc >= 7.4 happy+ * Use type class synonyms to avoid warnings about simplifiable class.+ * Compatibility: removed obsolete functoin Map.insertWith'.+ * Added MultiControlledNot demo.+ * Removed dependency on set-monad, which is broken upstream.+ * Fixed some bugs in the stabilizer simulation.+ * Moved QuantumIf from BF to Libraries.+ * Added --help option to all Quipper tools.+ * Removed Quipper.Utils.ShowAll+ * Fixed some compiler errors and removed some unnecessary type class+   assumptions.++July 27, 2016: Release 0.8++ * Portability: compatibility fixes for GHC 8.0. Note: GHC 7.10 is too+   broken and will not be supported by Quipper.+ * Added tests/SimulationTest+ * Added QPrep and QUnPrep to the simulator++October 14, 2014: Release 0.7++ * Portability: compatibility fixes for GHC 7.8.++January 16, 2014: Release 0.6++ * Minor edits and documentation updates.+ * Added a new gate gate_iX_inv+ * Added "alternate" version of synthesis algorithm, using only+   generators of determinant 1 if possible.+ * Synthesis code is now in an external package "newsynth".+ * Rendering code is now in an external package "easyrender".+ * Updated for use with fixedprec-0.2.1.0.++September 2, 2013: Release 0.5++ * Portability: compatibility fixes for GHC 7.6.2.+ * Portability: fixed Windows incompatibility bug. Handling of Ctrl-C+   may or may not work on Windows, depending on console.+ * Added quipperi script, analogous to ghci.+ * New library QuipperLib.ClassicalOptim: algebraic optimization of+   auto-generated classical circuits. Added "optimized" oracle to BWT+   algorithm.+ * QuipperLib.Decompose: Added decomposition into a "standard" gate+   set, consisting of X, Y, Z, H, S, S-dagger, T, T-dagger, and CNOT.+   Added KeepPhase flag to some transformers.+ * QuipperLib.GateDecompositions: added more gates.+ * New library Libraries.Synthesis.RotationDecomposition: implements a+   variant of the algorithm from Nielsen and Chuang to decompose an+   nxn unitary operator into one- and two-level rotations.+ * New library QuipperLib.Unboxing: unboxing transformers.+ * Updated ASCII output format; improved circuit parser efficiency.+ * Miscellaneous bug fixes: malformed W-gates, qdata_of_qubits,+   floorlog.+ * Fixed handling of iterated subroutines in depth transformer.+ * Documentation updates and minor refactoring.++June 19, 2013: Release 0.4++ * First public release.
+ Quipper/Utils/Auxiliary.hs view
@@ -0,0 +1,898 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++-- | This module provides miscellaneous general-purpose auxiliary+-- functions.++module Quipper.Utils.Auxiliary (+  -- * List operations+  applyAt,+  overwriteAt,+  has_duplicates,+  substitute,+  +  -- * Set and Map related operations+  map_provide,+  intset_inserts,+  intmap_zip,+  intmap_zip_errmsg,+  intmap_map,+  intmap_mapM,+  +  -- * XIntMaps+  XIntMap,+  xintmap_delete,+  xintmap_deletes,+  xintmap_insert,+  xintmap_inserts,+  xintmap_lookup,+  xintmap_member,+  xintmap_empty,+  xintmap_freshkey,+  xintmap_freshkeys,+  xintmap_to_intmap,+  xintmap_size,+  xintmap_dirty,+  xintmap_reserves,+  xintmap_unreserves,  +  xintmap_makeclean,+  +  -- * Various map- and fold-like list combinators+  loop,+  loop_with_index,+  fold_right_zip,+  zip_strict,+  zip_strict_errmsg,+  zip_rightstrict,+  zip_rightstrict_errmsg,+  zipWith_strict,+  zipWith_rightstrict,+  +  -- * Monadic versions of list combinators+  loopM,+  loop_with_indexM,+  zipRightWithRightStrictM,+  zipRightWithRightStrictM_,+  fold_right_zipM,+  foldRightPairM,+  foldRightPairM_,+  sequence_right,+  sequence_right_,+  +  -- * Loops+  -- $LOOPS+  for,+  endfor,+  foreach,+  +  -- * Operations for monads+  mmap,+  monad_join1,+  +  -- * Operations for disjoint unions+  map_either,+  map_eitherM,+  +  -- * Operations for tuples+  map_pair,+  map_pairM,+  +  -- * Arithmetic operations+  int_ceiling,+  +  -- * Bit vectors+  Boollist(..),+  boollist_of_int_bh,+  boollist_of_int_lh,+  int_of_boollist_unsigned_bh,+  int_of_boollist_signed_bh,+  bool_xor,+  boollist_xor,+  +  -- * Formatting of lists and strings+  string_of_list,+  optional,+  +  -- * Lists optimized for fast concatenation+  BList,+  blist_of_list,+  list_of_blist,+  (+++),+  blist_empty,+  blist_concat,+  +  -- * Strings optimized for fast concatenation+  Strbuf,+  strbuf_of_string,+  string_of_strbuf,+  strbuf_empty,+  strbuf_concat,+  +  -- * The identity monad+  Id(..),+  +  -- * Identity types+  Identity,+  reflexivity,+  symmetry,+  transitivity,+  identity,+  +  -- * Error messages+  ErrMsg,+  +  -- * The Curry type class+  Curry (..)+  ) where++-- import other stuff+import Data.List (foldl')++import Data.Set (Set)+import qualified Data.Set as Set++import Data.Map (Map)+import qualified Data.Map as Map++import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap++import qualified Data.Traversable as Traversable++import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap)++-- ----------------------------------------------------------------------+-- * List operations++-- | Apply a function to a specified position in a list.+applyAt :: Int -> (a -> a) -> [a] -> [a]+applyAt _ _ [] = []+applyAt 0 f (x:xs) = (f x):xs+applyAt n f (x:xs) = x:(applyAt (n-1) f xs)++-- | Overwrite an element at a specified position in a list.+overwriteAt :: Int -> a -> [a] -> [a]+overwriteAt n a = applyAt n (const a)++-- | Check whether a list has duplicates.+has_duplicates :: Ord a => [a] -> Bool+has_duplicates list = aux list (Set.empty) where+  aux [] _ = False+  aux (h:t) set = if Set.member h set then True else aux t (Set.insert h set)++-- | @'substitute' string character replacement@: +-- Replace the first occurrence of /character/ in /string/ by /replacement/.+substitute :: (Eq a) => [a] -> a -> [a] -> [a]+substitute string character replacement =    +  case break (== character) string of+    (x, []) -> x+    (x, h:y) -> x ++ replacement ++ y++-- ----------------------------------------------------------------------+-- * Set related operations++-- | Insert the elements of a list in an 'IntSet' (cf. 'IntSet.insert').+intset_inserts :: [Int] -> IntSet -> IntSet+intset_inserts list set =+  foldl' (\t x -> IntSet.insert x t) set list+++-- ----------------------------------------------------------------------+-- * Map related operations++-- | Insert the given key-value pair in a 'Map', but only if the given+-- key is not already present. If the key is present, keep the old+-- value.+map_provide :: Ord k => k -> a -> Map k a -> Map k a+map_provide = Map.insertWith (\x y -> y)++-- | Take two 'IntMap's /m/[sub 1] and /m/[sub 2], and form a new+-- 'IntMap' whose domain is that of /m/[sub 2], and whose value at /k/+-- is the pair (/m/[sub 1] ! /k/, /m/[sub 2] ! /k/). It is an error if+-- the domain of /m/[sub 2] is not a subset of the domain of /m/[sub 1].+intmap_zipright :: IntMap x -> IntMap y -> IntMap (x, y)+intmap_zipright m1 m2 = m where+  m = IntMap.mapWithKey f m2+  f k y = case IntMap.lookup k m1 of+    Just x -> (x, y)+    Nothing -> error "intmap_zipright: shape mismatch"+  +-- | Take two 'IntMap's with the same domain, and form a new 'IntMap'+-- whose values are pairs. It is an error if the two inputs don't have+-- identical domains.+intmap_zip :: IntMap x -> IntMap y -> IntMap (x, y)+intmap_zip m1 m2 = intmap_zip_errmsg m1 m2 "intmap_zip: shape mismatch"+  +-- | Like 'intmap_zip', but also takes an error message to use in case of+-- domain mismatch.+intmap_zip_errmsg :: IntMap x -> IntMap y -> String -> IntMap (x, y)+intmap_zip_errmsg m1 m2 errmsg = +  if all (\k -> IntMap.member k m2) (IntMap.keys m1) +    then intmap_zipright m1 m2+    else error errmsg+  +-- | Map a function over all values in an 'IntMap'.+intmap_map :: (x -> y) -> IntMap x -> IntMap y+intmap_map = IntMap.map++-- | Monadic version of 'intmap_map'. Map a function over all values+-- in an 'IntMap'.+intmap_mapM :: (Monad m) => (x -> m y) -> IntMap x -> m (IntMap y)+intmap_mapM = Traversable.mapM++-- ----------------------------------------------------------------------+-- * XIntMaps. ++-- | A 'XIntMap' is just like an 'IntMap', except that it supports+-- some additional efficient operations: to find the smallest unused+-- key, to find the set of all keys ever used in the past, and to+-- reserve a set of keys so that they will not be allocated. Moreover,+-- it keeps track of the highest key ever used (whether or not it is+-- still used in the current map).++-- This is implemented as a tuple (/m/, /n/, /free/, /h/), where /m/ is an+-- 'IntMap', /n/ is an integer such that dom /m/ ⊆ [0../n/-1], /free/+-- ⊆ [0../n/-1] \\ dom /m/ is a set of integers not currently reserved+-- or used, and /h/ is the set of all integers used in the past (the+-- set of /touched/ wires).++data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet++instance (Show a) => Show (XIntMap a) where+  show = show . xintmap_to_intmap+    +-- | Delete a key from the 'XIntMap'.+xintmap_delete :: Int -> XIntMap a -> XIntMap a+xintmap_delete k (XIntMap m n free h) = (XIntMap m' n free' h) where+  m' = IntMap.delete k m+  free' = IntSet.insert k free+  +-- | Delete a list of keys from a 'XIntMap'.+xintmap_deletes :: [Int] -> XIntMap a -> XIntMap a+xintmap_deletes list map =+  foldl' (\map k -> xintmap_delete k map) map list++-- | Insert a new key-value pair in the 'XIntMap'. +xintmap_insert :: Int -> a -> XIntMap a -> XIntMap a+xintmap_insert k v (XIntMap m n free h) = (XIntMap m' n' free' h') where+  m' = IntMap.insert k v m+  h' = IntSet.insert k h+  n' = max n (k+1)+  free' = IntSet.delete k (intset_inserts [n..n'-1] free)++-- | Insert a list of key-value pairs in the 'XIntMap'.+xintmap_inserts :: [(Int,a)] -> XIntMap a -> XIntMap a+xintmap_inserts list map =+  foldl' (\map (k,v) -> xintmap_insert k v map) map list++-- | Look up the value at a key in the 'XIntMap'. Return 'Nothing' if+-- not found.+xintmap_lookup :: Int -> XIntMap a -> Maybe a+xintmap_lookup k (XIntMap m n free h) =+  IntMap.lookup k m++-- | Check whether the given key is in the 'XIntMap'.+xintmap_member :: Int -> XIntMap a -> Bool+xintmap_member k (XIntMap m n free h) =+    IntMap.member k m++-- | The empty 'XIntMap'.+xintmap_empty :: XIntMap a+xintmap_empty = (XIntMap m n free h) where+  m = IntMap.empty+  n = 0+  free = IntSet.empty+  h = IntSet.empty++-- | Return the first free key in the 'XIntMap', but without actually+-- using it yet.+xintmap_freshkey :: XIntMap a -> Int+xintmap_freshkey (XIntMap m n free h) = +  if IntSet.null free then n else IntSet.findMin free++-- | Return the next /k/ unused keys in the 'XIntMap', but without+-- actually using them yet.+xintmap_freshkeys :: Int -> XIntMap a -> [Int]+xintmap_freshkeys k (XIntMap m n free h) = ks1 ++ ks2 where+  ks1 = take k (IntSet.elems free)+  delta = k - (length ks1)+  ks2 = [n .. n+delta-1]++-- | Convert a 'XIntMap' to an 'IntMap'.+xintmap_to_intmap :: XIntMap a -> IntMap a+xintmap_to_intmap (XIntMap m n free h) = m++-- | Return the smallest key never used in the 'XIntMap'.+xintmap_size :: XIntMap a -> Int+xintmap_size (XIntMap m n free k) = n++-- | Return the set of all keys ever used in the 'XIntMap'.+xintmap_touched :: XIntMap a -> IntSet+xintmap_touched (XIntMap m n free h) = h ++-- | A wire is /dirty/ if it is touched but currently free. +xintmap_dirty :: XIntMap a -> IntSet+xintmap_dirty (XIntMap m n free h) = h `IntSet.intersection` free++-- | Reserve a key in the 'XIntMap'. If the key is not free, do+-- nothing. The key must have been used before; for example, this is+-- the case if it was returned by 'xintmap_dirty'.+xintmap_reserve :: Int -> XIntMap a -> XIntMap a+xintmap_reserve k (XIntMap m n free h) = (XIntMap m n free' h) where+  free' = IntSet.delete k free+  +-- | Reserve a set of keys in the 'XIntMap'. For any keys that are not+-- free, do nothing. All keys must have been used before; for example,+-- this is the case if they were returned by 'xintmap_dirty'.+xintmap_reserves :: IntSet -> XIntMap a -> XIntMap a+xintmap_reserves ks (XIntMap m n free h) = (XIntMap m n free' h) where+  free' = free `IntSet.difference` ks++-- | Unreserve a key in the 'XIntMap'. If the key is currently used,+-- do nothing. The key must have been reserved before, and (therefore)+-- must have been used before.+xintmap_unreserve :: Int -> XIntMap a -> XIntMap a+xintmap_unreserve k (XIntMap m n free h) +  | IntMap.member k m = (XIntMap m n free h)+  | otherwise = (XIntMap m n free' h)+    where+      free' = IntSet.insert k free++-- | Unreserve a list of keys in the 'XIntMap'. If any key is+-- currently used, do nothing. All keys must have been reserved+-- before, and (therefore) must have been used before.+xintmap_unreserves :: IntSet -> XIntMap a -> XIntMap a+xintmap_unreserves ks map = +  IntSet.fold (\k map -> xintmap_unreserve k map) map ks++-- | Make an exact copy of the 'XIntMap', except that the set of+-- touched wires is initially set to the set of used wires. In other+-- words, we mark all free and reserved wires as untouched.+xintmap_makeclean :: XIntMap a -> XIntMap a+xintmap_makeclean (XIntMap m n free h) = (XIntMap m n free h') where+  h' = IntMap.keysSet m++-- ----------------------------------------------------------------------+-- * Map- and fold-like list combinators++-- ** Combinators for looping++-- | Like 'loop', but also pass a loop counter to the function being+-- iterated. Example:+-- +-- > loop_with_index 3 x f = f 2 (f 1 (f 0 x))+loop_with_index :: (Eq int, Num int) => int -> t -> (int -> t -> t) -> t+loop_with_index n x f = aux 0 x+  where+    aux i x = if i == n then x else aux (i+1) (f i x)++-- | Monadic version of 'loop_with_index'. Thus, +-- +-- > loop_with_indexM 3 x0 f+-- +-- will do the following:+-- +-- > do+-- >   x1 <- f 0 x0+-- >   x2 <- f 1 x1+-- >   x3 <- f 2 x2    +-- >   return x3+loop_with_indexM :: (Eq int, Num int, Monad m) => int -> t -> (int -> t -> m t) -> m t+loop_with_indexM n x f = aux 0 x+  where+    aux i x =+      if i == n then return x else do+        x <- f i x+        aux (i+1) x++-- | Iterate a function /n/ times. Example: +-- +-- > loop 3 x f = f (f (f x))+loop :: (Eq int, Num int) => int -> t -> (t -> t) -> t+loop n x f = loop_with_index n x (\_ -> f)++-- | Monadic version of 'loop'.+loopM :: (Eq int, Num int, Monad m) => int -> t -> (t -> m t) -> m t+loopM n x f = loop_with_indexM n x (\_ -> f)++-- ** Combinators for sequencing++-- | A right-to-left version of 'sequence': Evaluate each action in the+-- sequence from right to left, and collect the results.+sequence_right :: Monad m => [m a] -> m [a]+sequence_right [] = return []+sequence_right (x:xs) = do+  ys <- sequence_right xs+  y <- x+  return (y:ys)++-- | Same as 'sequence_right', but ignore the result.+sequence_right_ :: Monad m => [m a] -> m ()+sequence_right_ [] = return ()+sequence_right_ (x:xs) = do+  ys <- sequence_right_ xs+  y <- x+  return ()++-- ** Combinators for zipping++-- | A \"strict\" version of 'zip', i.e., raises an error when the+-- lists are not of the same length.+zip_strict :: [a] -> [b] -> [(a, b)]+zip_strict a b = zip_strict_errmsg a b "zip_strict: lists are not of the same length"++-- | Like 'zip_strict', but also takes an explicit error message to+-- use in case of failure.+zip_strict_errmsg :: [a] -> [b] -> String -> [(a, b)]+zip_strict_errmsg [] [] e = []+zip_strict_errmsg (h:t) (h':t') e = (h,h') : zip_strict_errmsg t t' e+zip_strict_errmsg _ _ e = error e++-- | A \"right strict\" version of 'zip', i.e., raises an error when the+-- left list is shorter than the right one. +zip_rightstrict :: [a] -> [b] -> [(a, b)]+zip_rightstrict a b = zip_rightstrict_errmsg a b "zip_rightstrict: list too short"++-- | A version of 'zip_rightstrict' that also takes an explicit error+-- message to use in case of failure.+zip_rightstrict_errmsg :: [a] -> [b] -> String -> [(a, b)]+zip_rightstrict_errmsg _ [] s = []+zip_rightstrict_errmsg (h:t) (h':t') s = (h,h') : zip_rightstrict_errmsg t t' s+zip_rightstrict_errmsg _ _ s = error s++-- | A \"strict\" version of 'zipWith', i.e., raises an error when the+-- lists are not of the same length.+zipWith_strict :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWith_strict f [] [] = []+zipWith_strict f (h:t) (h':t') = f h h' : zipWith_strict f t t'+zipWith_strict f _ _ = error "zipWith_strict: lists are not of the same length"++-- | A \"right strict\" version of 'zipWith', i.e., raises an error when the+-- right list is shorter than the left one.+zipWith_rightstrict :: (a -> b -> c) -> [a] -> [b] -> [c]+zipWith_rightstrict f _ [] = []+zipWith_rightstrict f (h:t) (h':t') = f h h' : zipWith_rightstrict f t t'+zipWith_rightstrict f _ _ = error "zipWith_rightstrict: list too short"++-- | A right-to-left version of 'Control.Monad.zipWithM', which is+-- also \"right strict\", i.e., raises an error when the right list is+-- shorter than the left one. Example:+-- +-- > zipRightWithM f [a,b] [x,y] = [f a x, f b y],+-- +-- computed right-to-left.+zipRightWithRightStrictM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]+zipRightWithRightStrictM f l1 l2 =+  sequence_right $ zipWith_rightstrict f l1 l2++-- | Same as 'zipRightWithRightStrictM', but ignore the result.+zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()+zipRightWithRightStrictM_ f l1 l2 =+  sequence_right_ $ zipWith_rightstrict f l1 l2++-- ** Combinators combining mapping with folding++-- | Fold over two lists with state, and do it right-to-left.  For example,+-- +-- > foldRightPairM (w0, [1,2,3], [a,b,c]) f+-- +-- will do the following:+-- +-- > do+-- >   w1 <- f (w0, 3, c)+-- >   w2 <- f (w1, 2, b)+-- >   w3 <- f (w2, 1, a)+-- >   return w3+foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w+foldRightPairM (w, [], _) f = return w+foldRightPairM (w, _, []) f = return w+foldRightPairM (w, a:as, b:bs) f = do+  w <- foldRightPairM (w, as, bs) f+  w <- f (w, a, b)+  return w++-- | Like 'foldRightPairM', but ignore the final result.+foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m ()+foldRightPairM_ x f = do+  foldRightPairM x f+  return ()++-- | Combine right-to-left zipping and folding. Example:+-- +-- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c'])+-- >  where f (w0,c,z) = (w1,c')+-- >        f (w1,b,y) = (w2,b')+-- >        f (w2,a,x) = (w3,a')+fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c])+fold_right_zip f (w, [], []) = (w, [])+fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb')+  where+    (w1, bb') = fold_right_zip f (w, bb, yy)+    (w2, a') = f (w1, a, x)+fold_right_zip f _ = error "fold_right_zip"++-- | Monadic version of 'fold_right_zip'.+fold_right_zipM ::+  (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c])+fold_right_zipM f (w, [], []) = return (w, [])+fold_right_zipM f (w, a:bb, x:yy) = do+    (w1, bb') <- fold_right_zipM f (w, bb, yy)+    (w2, a') <- f (w1, a, x)+    return (w2, a':bb')+fold_right_zipM f _ = error "fold_right_zipM"++-- ----------------------------------------------------------------------+-- * Loops.++-- $LOOPS We provide a syntax for \"for\"-style loops.++-- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/.+-- +-- Standard notation: +-- +-- > for i = a to b by s do+-- >   commands             +-- > end for+-- +-- Our notation: +-- +-- > for a b s $ \i -> do+-- >   commands+-- > endfor++for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m()+for a b s f = if s > 0 then aux a (<= b) else aux a (>= b)+  where+    aux i cond = +      if cond i then do+        f i+        aux (i+s) cond+      else+        return ()++-- | Mark the end of a \"for\"-loop. This command actually does+-- nothing, but can be used to make the loop look prettier.+endfor :: Monad m => m()+endfor = return ()++-- | Iterate a parameter over a list of values. It can be used as+-- follows:+-- +-- > foreach [1,2,3,4] $ \n -> do+-- >   <<<loop body depending on the parameter n>>>+-- > endfor+-- +-- The loop body will get executed once for each /n/ ∈ {1,2,3,4}.++foreach :: Monad m => [a] -> (a -> m b) -> m ()+foreach l f = mapM_ f l++-- ----------------------------------------------------------------------+-- * Operations for monads++-- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output+-- /m/ /f/ : /m/ /a/ → /m/ /b/.+mmap :: (Monad m) => (a -> b) -> m a -> m b+mmap f a = a >>= (return . f)++-- | Remove an outer application of a monad from a monadic function.+monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b+monad_join1 mf a = do+  f <- mf+  f a++-- ----------------------------------------------------------------------+-- * Operations for disjoint unions++-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return+-- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/.+map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d+map_either f g (Left x) = Left (f x)+map_either f g (Right x) = Right (g x)++-- | Monadic version of 'map_either'.+map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)+map_eitherM f g (Left x) = mmap Left (f x)+map_eitherM f g (Right x) = mmap Right (g x)++-- ----------------------------------------------------------------------+-- * Operations for tuples++-- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return+-- /f/ × /g/ : /a/ × /c/ → /c/ × /d/.+map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)+map_pair f g (x, y) = (f x, g y)++-- | Monadic version of 'map_pair'.+map_pairM :: (Monad m) => (a -> m b) -> (c -> m d) -> (a, c) -> m (b, d)+map_pairM f g (a, c) = do+  b <- f a+  d <- g c+  return (b, d)++-- ----------------------------------------------------------------------+-- * Arithmetic operations+  +-- | A version of the 'ceiling' function that returns an 'Integer'.+int_ceiling :: RealFrac a => a -> Integer+int_ceiling = toInteger . ceiling++-- ----------------------------------------------------------------------+-- * Bit vectors++-- | The type of bit vectors. True = 1, False = 0.+type Boollist = [Bool]++-- | Convert an integer to a bit vector. The first argument is the+-- length in bits, and the second argument the integer to be+-- converted. The conversion is big-headian (or equivalently,+-- little-tailian), i.e., the head of the list holds the integer's most+-- significant digit.+boollist_of_int_bh :: Integral a => Int -> a -> Boollist+boollist_of_int_bh m = reverse . boollist_of_int_lh m++-- | Convert an integer to a bit vector. The first argument is the+-- length in bits, and the second argument the integer to be+-- converted. The conversion is little-headian (or equivalently,+-- big-tailian), i.e., the head of the list holds the integer's least+-- significant digit.+boollist_of_int_lh :: Integral a => Int -> a -> Boollist+boollist_of_int_lh m x | m <= 0 = []+boollist_of_int_lh m x = digit : boollist_of_int_lh (m-1) tail where+  digit = (x `mod` 2 == 1)+  tail = x `div` 2++-- | Convert a bit vector to an integer. The conversion is big-headian+-- (or equivalently, little-tailian), i.e., the head of the list holds+-- the integer's most significant digit. This function is unsigned,+-- i.e., the integer returned is ≥ 0.+int_of_boollist_unsigned_bh :: Integral a => Boollist -> a+int_of_boollist_unsigned_bh v = aux v 0+  where+    aux v acc =+      case v of+        [] -> acc+        digit : vs -> aux vs (2*acc+(if digit then 1 else 0))++-- | Convert a bit vector to an integer, signed.+int_of_boollist_signed_bh :: Integral a => Boollist -> a+int_of_boollist_signed_bh [] = 0+int_of_boollist_signed_bh (False:v) = int_of_boollist_unsigned_bh v+int_of_boollist_signed_bh (True:v) = -1 - int_of_boollist_unsigned_bh (map not v)++-- | Exclusive or operation on booleans.+bool_xor :: Bool -> Bool -> Bool+bool_xor a b = (a /= b)++-- | Exclusive or operation on bit vectors.+boollist_xor :: Boollist -> Boollist -> Boollist+boollist_xor = zipWith bool_xor++-- ----------------------------------------------------------------------+-- * Formatting of lists and strings++-- | A general list-to-string function. Example:+-- +-- > string_of_list "{" ", " "}" "{}" show [1,2,3] = "{1, 2, 3}"+string_of_list :: String -> String -> String -> String -> (t -> String) -> [t] -> String+string_of_list lpar comma rpar nil string_of_elt lst =+  let string_of_tail lst =+        case lst of+          [] -> ""+          h:t -> comma ++ string_of_elt h ++ string_of_tail t+  in+  case lst of+    [] -> nil+    h:t -> lpar ++ string_of_elt h ++ string_of_tail t ++ rpar++-- | @'optional' b s@: if /b/ = 'True', return /s/, else the empty+-- string. This function is for convenience.+optional :: Bool -> String -> String+optional True s = s+optional False s = ""++-- ----------------------------------------------------------------------+-- * Lists optimized for fast concatenation++-- | The type of bidirectional lists. This is similar to [a], but+-- optimized for fast concatenation and appending on both sides.+newtype BList a = BList { getBList :: [a] -> [a] }++-- | Convert a List to a 'BList'.+blist_of_list :: [a] -> BList a+blist_of_list s = BList (\x -> s ++ x)++-- | Convert a 'BList' to a List.+list_of_blist :: BList a -> [a]+list_of_blist buf = getBList buf []++-- | Fast concatenation of 'BList's or string buffers.+(+++) :: BList a -> BList a -> BList a+(+++) buf1 buf2 = BList ((getBList buf1) . (getBList buf2))++-- | The empty 'BList'.+blist_empty :: BList a+blist_empty = BList id++-- | Concatenate a list of 'BList's.+blist_concat :: [BList a] -> BList a+blist_concat l = foldr (+++) blist_empty l++instance (Show a) => Show (BList a) where+        show bl = show (list_of_blist bl) ++-- ----------------------------------------------------------------------+-- * Strings optimized for fast concatenation++-- | A string buffer holds a string that is optimized for fast+-- concatenation. Note that this is an instance of 'BList', and hence+-- 'BList' operations (in particular '+++') can be applied to string+-- buffers. The following functions are synonyms of the respective+-- 'BList' functions, and are provided for convenience.+type Strbuf = BList Char++-- | Convert a string to a string buffer.+strbuf_of_string :: String -> Strbuf+strbuf_of_string = blist_of_list++-- | Convert a string buffer to a string.+string_of_strbuf :: Strbuf -> String+string_of_strbuf = list_of_blist++-- | The empty string buffer.+strbuf_empty :: Strbuf+strbuf_empty = blist_empty++-- | Concatenate a list of string buffers.+strbuf_concat :: [Strbuf] -> Strbuf+strbuf_concat = blist_concat++-- ----------------------------------------------------------------------+-- * The identity monad+      +-- | The identity monad. Using /m/ = 'Id' gives useful special cases+-- of monadic functions.+newtype Id a = Id { getId :: a }++instance Monad Id where+  return a = Id a+  (Id a) >>= b = b a++instance Applicative Id where+  pure = return+  (<*>) = ap++instance Functor Id where+  fmap = liftM++-- ----------------------------------------------------------------------+-- * Identity types+  +-- | The type 'Identity' /a/ /b/ witnesses the fact that /a/ and /b/+-- are the same type. In other words, this type is non-empty if and+-- only if /a/ = /b/. This property is not guaranteed by the type+-- system, but by the API, via the fact that the operators+-- 'reflexivity', 'symmetry', and 'transitivity' are the only exposed+-- constructors for this type. The implementation of this type is+-- deliberately hidden, as this is the only way to guarantee its+-- defining property.+-- +-- Identity types are useful in certain situations. For example, they+-- can be used to define a data type which is polymorphic in some type+-- variable /x/, and which has certain constructors that are only+-- available when /x/ is a particular type. For example, in the+-- declaration+-- +-- > data ExampleType x = Constructor1 x | Constructor2 x (Identity x Bool),+-- +-- @Constructor1@ is available for all /x/, but @Constructor2@ is only+-- available when /x/ = 'Bool'.+newtype Identity a b = Identity (a -> b, b -> a)++-- | Witness the fact that /a/=/a/.+reflexivity :: Identity a a+reflexivity = Identity (id, id)++-- | Witness the fact that /a/=/b/ implies /b/=/a/.+symmetry :: Identity a b -> Identity b a+symmetry (Identity (f,g)) = Identity (g,f)++-- | Witness the fact that /a/=/b/ and /b/=/c/ implies /a/=/c/.+transitivity :: Identity a b -> Identity b c -> Identity a c+transitivity (Identity (f,g)) (Identity (f',g')) = Identity (f'',g'') where+  f'' = f' . f+  g'' = g . g'++-- | The identity function 'id' : /a/ → /b/, provided that /a/ and /b/+-- are the same type.+identity :: Identity a b -> a -> b+identity (Identity (f,g)) = f++instance Show (Identity a b) where+  show x = "id"++-- ======================================================================+-- * Error messages++-- | Often a low-level function, such as+-- 'Quipper.Internal.QData.qcdata_zip' or+-- 'Quipper.Internal.QData.qcdata_promote', throws an error because of+-- a failure of some low-level condition, such as \"list too+-- short\". To produce error messages that are meaningful to+-- user-level code, these functions do not have a hard-coded error+-- message. Instead, they input a stub error message.+-- +-- A meaningful error message typically consists of at least three parts:+-- +-- * the name of the user-level function where the error occurred, for+-- example: \"reverse_generic\";+-- +-- * what the function was doing when the error occurred, for example:+-- \"operation not permitted in reversible circuit\";+-- +-- * a specific low-level reason for the error, for example: \"dynamic+-- lifting\".+-- +-- Thus, a meaningful error message may be: \"reverse_generic:+-- operation not permitted in reversible circuit: dynamic lifting\".+-- +-- The problem is that the three pieces of information are not usually+-- present in the same place. The user-level function is often a+-- wrapper function that performs several different mid-level+-- operations (e.g., transforming, reversing). The mid-level function+-- knows what operation was being performed when the error occurred,+-- but often calls a lower-level function to do the actual work (e.g.,+-- encapsulating).+--   +-- Therefore, a stub error message is a function that inputs some+-- lower-level reason for a failure (example: \"list too short\") and+-- translates this into a higher-level error message (example:+-- \"qterm: shape of parameter does not data: list too short\").+-- +-- Sometimes, the stub error message may also ignore the low-level+-- message and completely replace it by a higher-level one. For+-- example, a function that implements integers as bit lists may wish+-- to report a problem with integers, rather than a problem with the+-- underlying lists.+type ErrMsg = String -> String++-- ======================================================================+-- * The Curry type class++-- | The 'Curry' type class is used to implement functions that have a+-- variable number of arguments. It provides a family of type+-- isomorphisms+-- +-- @fun  ≅  args -> res,@+-- +-- where+-- +-- > fun = a1 -> a2 -> ... -> an -> res,+-- > args = (a1, (a2, (..., (an, ())))).++class Curry fun args res | args res -> fun where+  -- | Multiple curry: map a function +  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/ +  -- to its curried form +  -- /a/[sub 1] → /a/[sub 2] → … → /b/.+  mcurry :: (args -> res) -> fun+  -- | Multiple uncurry: map a function+  -- /a/[sub 1] → /a/[sub 2] → … → /b/+  -- to its uncurried form +  -- (/a/[sub 1], (/a/[sub 2], (…, ())) → /b/.+  muncurry :: fun -> (args -> res)+               +instance Curry b () b where+  mcurry g = g ()+  muncurry x = const x++instance Curry fun args res => Curry (a -> fun) (a,args) res where+  mcurry g x = mcurry (\xs -> g (x,xs))+  muncurry f (x,xs) = muncurry (f x) xs+
+ Quipper/Utils/CommandLine.hs view
@@ -0,0 +1,66 @@+-- | This module provides some functions that are useful in the+-- processing of command line options, and that are shared between+-- several algorithms.++module Quipper.Utils.CommandLine where++import Quipper.Utils.Auxiliary (string_of_list)++-- import other stuff+import System.Exit+import System.IO+import Data.List+import Data.Char++-- ----------------------------------------------------------------------+-- * Option processing+      +-- | Exit with an error message after a command line error. This also+-- outputs information on where to find command line help.+optfail :: String -> IO a+optfail msg = do+  hPutStr stderr msg+  hPutStrLn stderr "Try --help for more info."+  exitFailure++-- | Parse a string to an integer, or return 'Nothing' on failure.+parse_int :: (Integral r) => String -> Maybe r+parse_int s = case reads s of+  [(n, "")] -> Just (fromInteger n)+  _ -> Nothing++-- | Parse a string to a list of integers, or return 'Nothing' on failure.+parse_list_int :: String -> Maybe [Int]      +parse_list_int s = case reads s of+  [(ns, "")] -> Just ns+  _ -> Nothing++-- | Parse a string to a 'Double', or return 'Nothing' on failure.+parse_double :: String -> Maybe Double+parse_double s = case reads s of+  [(n, "")] -> Just n+  _ -> Nothing++-- | In an association list, find the key that best matches the given+-- string. If one key matches exactly, return the corresponding+-- key-value pair. Otherwise, return a list of all key-value pairs+-- whose key have the given string as a prefix. This list could be of+-- length 0 (no match), 1 (unique match), or greater (ambiguous key).+-- Note: the keys in the association list must be lower case. The+-- input string is converted to lower case as well, resulting in+-- case-insensitive matching.+match_enum :: [(String, a)] -> String -> [(String, a)]+match_enum list key =+  case lookup s list of+    Just v -> [(s,v)]+    Nothing -> filter (\(k,v) -> isPrefixOf s k) list+  where+    s = map toLower key+    +-- | Pretty-print a list of possible values for a parameter. The+-- first argument is the name of the parameter, and the second+-- argument is its enumeration.+show_enum :: String -> [(String, a)] -> String    +show_enum param list =+  "Possible values for " ++ param ++ " are: " +++  string_of_list "" ", " "" "no possible values" fst list ++ ".\n"
+ Quipper/Utils/PortableSignals.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE CPP #-}++-- | This module provides a thin portability layer for handling user+-- interrupts.+-- +-- The reason is that in the standard Haskell library, this+-- functionality is only available in operating system specific+-- modules, namely "System.Posix.Signals" (for POSIX systems,+-- including Linux) and "GHC.ConsoleHandler" (for Windows).+-- +-- Note that despite this compatibility layer, there are some+-- operating system specific quirks:+-- +-- * In Windows, console events (such as Control-C) can only be+-- received by an application running in a Windows console. Certain+-- environments that look like consoles do not support console events,+-- such as xterm and rxvt windows, and Cygwin shells with @CYGWIN=tty@+-- set.+-- +-- * In Windows, setting a handler for any one signal automatically+-- overrides the handlers for all signals (effectively ignoring them).+-- Also, if the 'Default' or 'Ignore' handler is specified, it+-- applies to all signals.  We do not currently provide a way to+-- specify handlers for multiple signals.++module Quipper.Utils.PortableSignals (+  Signal(..),+  Handler(Default,Ignore,Catch,CatchOnce),+  installHandler,+  with_handler+  ) where++#ifdef mingw32_HOST_OS+import qualified GHC.ConsoleHandler as OS+#else+import qualified System.Posix.Signals as OS+#endif+       +-- ----------------------------------------------------------------------+-- * Common interface++-- | A data type for signals. This can be extended as needed.+data Signal =+  Interrupt  -- ^ Control-C event.+  | Close    -- ^ TERM signal (POSIX) or Close event (Windows).++-- | A data type for handlers.+data Handler =+  Default                -- ^ Default action.+  | Ignore               -- ^ Ignore the signal.+  | Catch (IO ())        -- ^ Handle the signal in a new thread when the signal is received.+  | CatchOnce (IO ())    -- ^ Like 'Catch', but only handle the first such signal.+  | OSHandler OS.Handler -- ^ An operating system specific handler.++-- | Install a handler for the given signal. The old handler is+-- returned. +installHandler :: Signal -> Handler -> IO Handler+#ifdef mingw32_HOST_OS+installHandler = installHandler_windows+#else+installHandler = installHandler_posix+#endif++-- | Run a block of code with a given signal handler. The previous+-- handler is restored when the block terminates.+with_handler :: Signal -> Handler -> IO a -> IO a+with_handler signal handler body = do+  oldhandler <- installHandler signal handler+  a <- body+  installHandler signal oldhandler+  return a++-- ----------------------------------------------------------------------+-- * Windows specific code++#ifdef mingw32_HOST_OS++-- | Check if the Windows 'ConsoleEvent' matches the given abstract+-- 'Signal'. We implement this as a relation, rather than a function,+-- to allow for more than one 'ConsoleEvent' to match the same+-- 'Signal', or for more than one 'Signal' to match the same+-- 'ConsoleEvent'.+signal_matches :: OS.ConsoleEvent -> Signal -> Bool+signal_matches OS.ControlC Interrupt = True+signal_matches OS.Close Close = True+signal_matches _ _ = False++-- | Windows implementation of 'installHandler'.+installHandler_windows :: Signal -> Handler -> IO Handler+installHandler_windows signal handler = do+  oldhandler <- OS.installHandler (oshandler handler)+  return (OSHandler oldhandler)+    where+      oshandler Default = OS.Default+      oshandler Ignore = OS.Ignore+      oshandler (Catch body) = OS.Catch $ \event -> do+        if signal_matches event signal+          then body +          else return ()+      oshandler (CatchOnce body) = OS.Catch $ \event -> do+        if signal_matches event signal +          then do+            -- uninstall the handler+            OS.installHandler OS.Default+            body+          else return ()+      oshandler (OSHandler h) = h+      +-- ----------------------------------------------------------------------+-- * POSIX specific code++#else++-- | Map an abstract 'Signal' to a POSIX specific 'OS.Signal'.+ossignal :: Signal -> OS.Signal+ossignal Interrupt = OS.keyboardSignal+ossignal Close = OS.softwareTermination++-- | Map a 'Handler' to a POSIX specific handler.+oshandler :: Handler -> OS.Handler+oshandler Default = OS.Default+oshandler Ignore = OS.Ignore+oshandler (Catch body) = OS.Catch body+oshandler (CatchOnce body) = OS.CatchOnce body+oshandler (OSHandler h) = h++-- | POSIX implementation of 'installHandler'.+installHandler_posix :: Signal -> Handler -> IO Handler+installHandler_posix signal handler = do+  oldhandler <- OS.installHandler (ossignal signal) (oshandler handler) Nothing+  return (OSHandler oldhandler)++#endif
+ Quipper/Utils/Preview.hs view
@@ -0,0 +1,84 @@+-- | Platform dependent previewing of PDF files. On Windows, we try to+-- run Acrobat Reader. On Mac, we try to run Preview. On Linux, we try+-- to run Acrobat Reader or Xpdf. If this fails, we abort the program+-- with a platform dependent error message.++module Quipper.Utils.Preview where++import Control.Exception+import System.Environment+import System.Exit+import System.Info+import System.IO+import System.IO.Error+import System.Process++-- | Sequentially try one or more IO computations, until one of them+-- completes without an IO error. If all of them fail, re-throw the+-- error from the last one.+try_several_IO :: [IO a] -> IO a+try_several_IO [] = error "try_several_IO"+try_several_IO [h] = do+  catchIOError h (\e -> throw e)+try_several_IO (h:t) = do+  catchIOError h (\e -> try_several_IO t)++-- | @'system_pdf_viewer' zoom pdffile@: Call a system-specific PDF+-- viewer on /pdffile/ file. The /zoom/ argument is out of 100 and may+-- or may not be ignored by the viewer.+system_pdf_viewer :: Double -> String -> IO ()+system_pdf_viewer zoom pdffile = do+  envList <- getEnvironment+  if (elem ("OS", "Windows_NT") envList) then+    windows_pdf_viewer zoom pdffile+    else if (os == "darwin") then+    macos_pdf_viewer zoom pdffile+    else+    linux_pdf_viewer zoom pdffile++-- | Like 'system_pdf_viewer', but specialized to Windows.+windows_pdf_viewer :: Double -> String -> IO ()+windows_pdf_viewer zoom pdffile = catchIOError body handler+  where+    body = do+      r <- system ("start /WAIT AcroRd32 " ++ pdffile)+      case r of+        ExitSuccess -> return ()+        ExitFailure n -> acrord32_error n+    handler e = do+      name <- getProgName+      hPutStrLn stderr $ name ++ ": unable to preview PDF file. Please ensure that Acrobat Reader is installed."+      exitFailure+    acrord32_error n = do+      name <- getProgName+      hPutStrLn stderr $ name ++ ": unable to preview PDF file. Please ensure that Acrobat Reader is installed."+      exitFailure+      ++-- | Like 'system_pdf_viewer', but specialized to Mac OS.+macos_pdf_viewer :: Double -> String -> IO ()+macos_pdf_viewer zoom pdffile = catchIOError body handler+  where+    body = do+      rawSystem "open" [pdffile]+      rawSystem "sleep" ["1"] -- required or the file may be deleted too soon+      return ()+    handler e = do+      name <- getProgName+      hPutStrLn stderr $ name ++ ": unable to preview PDF file. There seems to be a problem with Preview."+      exitFailure+      +-- | Like 'system_pdf_viewer', but specialized to Linux.+linux_pdf_viewer :: Double -> String -> IO ()+linux_pdf_viewer zoom pdffile = catchIOError body handler+  where+    body = do+      try_several_IO [+        rawSystem "acroread" ["/a", "zoom=" ++ show zoom, pdffile],+        rawSystem "xpdf" ["-z", show zoom, pdffile]+        ]+      return ()+    handler e = do+      name <- getProgName+      hPutStrLn stderr $ name ++ ": unable to preview PDF file. Please ensure that either Acrobat Reader or Xpdf are installed."+      exitFailure
+ Quipper/Utils/RandomSource.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | This module provides a container type for sources of+-- randomness. This makes it possible for a source of randomness (any+-- instance of the 'RandomGen' class) to be stored in a data structure+-- without having to specify its type explicitly.++module Quipper.Utils.RandomSource where++import System.Random++-- | A container type to hold a source of randomness. This can hold+-- any instance of the 'RandomGen' class.+data RandomSource where+  RandomSource :: forall g.(RandomGen g) => g -> RandomSource++instance Show RandomSource where+  show x = "g"
+ Quipper/Utils/Sampling.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++-- --------------------------------------------------------------------+-- | This module provides functions for generating lists of samples+-- from a range of input values. This is primarily useful for+-- generating test cases. Ranges can be specified for types that are+-- members of the 'Interval' class. Each sampling procedure generates+-- a (finite or infinite) list of values from the range. We provide+-- sampling procedures for+-- +-- * generating the range in its entirety ('sample_all')+-- +-- * sampling every /n/th element from a range ('sample_step')+-- +-- * generating a random sample from the range ('sample_random')++module Quipper.Utils.Sampling (+  +  -- * Interval class+  Interval(..),+  +  -- * Zero class+  Zero(..),+  +  -- * Random class+  -- $Random+  Random,+  +  -- * Functions+  sample_all,+  sample_step,+  sample_random,+  sample_all0,+  sample_step0,+  sample_random0  +  ) where++import Quipper.Utils.Tuple++import System.Random+import Data.Tuple+import Data.List++-- --------------------------------------------------------------------+-- | The 'Interval' class contains types for which an interval of+-- values can be specified by giving a lower bound and an upper+-- bound. Intervals are specified as @'interval' min max@, for+-- example: +-- +-- > interval (0,0) (1,2) = [(0,0),(0,1),(0,2),(1,0),(1,1),(1,2)].++class Interval a where+  -- | Takes a range (/min/,/max/) and returns a list of all values with+  -- lower bound /min/ and upper bound /max/.+  interval :: a -> a -> [a]++instance Interval Int where+  interval x y = [x..y]+  +instance Interval Integer where+  interval x y = [x..y]++instance Interval Double where+  interval x y = [x..y]+  +instance Interval Bool where+  interval x y = [x..y]++instance Interval () where+  interval () () = [()]+  +instance (Interval a, Interval b) => Interval (a,b) where+  interval (x0,y0) (x1,y1) = [ (x,y) | x <- interval x0 x1, y <- interval y0 y1 ]++instance (Interval a, Interval b, Interval c) => Interval (a,b,c) where+  interval x y = map tuple (interval (untuple x) (untuple y))+  +instance (Interval a, Interval b, Interval c, Interval d) => Interval (a,b,c,d) where+  interval x y = map tuple (interval (untuple x) (untuple y))+  +instance (Interval a, Interval b, Interval c, Interval d, Interval e) => Interval (a,b,c,d,e) where+  interval x y = map tuple (interval (untuple x) (untuple y))+  +instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f) => Interval (a,b,c,d,e,f) where+  interval x y = map tuple (interval (untuple x) (untuple y))+  +instance (Interval a, Interval b, Interval c, Interval d, Interval e, Interval f, Interval g) => Interval (a,b,c,d,e,f,g) where+  interval x y = map tuple (interval (untuple x) (untuple y))+  +instance Interval a => Interval [a] where+  interval x y = l where+    xy = safe_zip x y "interval: upper and lower bound contain lists of non-matching lengths"+    l = aux xy+    aux [] = [[]]+    aux ((x,y):t) = [ h:t' | h <- interval x y, t' <- aux t ]++-- --------------------------------------------------------------------+-- | Types in the 'Zero' class have an \"origin\", i.e., an element+-- that can conveniently serve as the starting point for intervals.++class Zero a where+  -- | Inputs any element of the type and outputs the corresponding+  -- \"zero\" element, for example:+  -- +  -- > zero ([1,2],3,True) = ([0,0],0,False)+  zero :: a -> a+  +instance Zero Int where+  zero _ = 0+  +instance Zero Integer where+  zero _ = 0++instance Zero Double where+  zero _ = 0++instance Zero Bool where+  zero _ = False++instance Zero () where+  zero () = ()++instance (Zero a, Zero b) => Zero (a,b) where+  zero (a,b) = (zero a, zero b)+  +instance (Zero a, Zero b, Zero c) => Zero (a,b,c) where+  zero x = tuple (zero (untuple x))+  +instance (Zero a, Zero b, Zero c, Zero d) => Zero (a,b,c,d) where+  zero x = tuple (zero (untuple x))+  +instance (Zero a, Zero b, Zero c, Zero d, Zero e) => Zero (a,b,c,d,e) where+  zero x = tuple (zero (untuple x))+  +instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f) => Zero (a,b,c,d,e,f) where+  zero x = tuple (zero (untuple x))+  +instance (Zero a, Zero b, Zero c, Zero d, Zero e, Zero f, Zero g) => Zero (a,b,c,d,e,f,g) where+  zero x = tuple (zero (untuple x))+  +instance Zero a => Zero [a] where+  zero l = map zero l+  +-- --------------------------------------------------------------------+-- $Random +-- We extend the class 'System.Random' with tuples and lists.++-- | 0-tuples+instance Random () where+  randomR ((),()) g = ((), g)+  random g = ((), g)++-- | Pairs+instance (Random a, Random b) => Random (a,b) where+  randomR ((a0,b0),(a1,b1)) g = ((a,b), g'') where+    (a,g') = randomR (a0,a1) g+    (b,g'') = randomR (b0,b1) g'+  random g = ((a,b), g'') where+    (a,g') = random g+    (b,g'') = random g'++-- | Triples+instance (Random a, Random b, Random c) => Random (a,b,c) where+  randomR (a,b) g = (t, g') where+    a1 = untuple a+    b1 = untuple b+    (t1,g') = randomR (a1,b1) g+    t = tuple t1+  random g = (t, g') where+    (t1,g') = random g+    t = tuple t1++-- | 4-Tuples+instance (Random a, Random b, Random c, Random d) => Random (a,b,c,d) where+  randomR (a,b) g = (t, g') where+    a1 = untuple a+    b1 = untuple b+    (t1,g') = randomR (a1,b1) g+    t = tuple t1+  random g = (t, g') where+    (t1,g') = random g+    t = tuple t1++-- | 5-Tuples+instance (Random a, Random b, Random c, Random d, Random e) => Random (a,b,c,d,e) where+  randomR (a,b) g = (t, g') where+    a1 = untuple a+    b1 = untuple b+    (t1,g') = randomR (a1,b1) g+    t = tuple t1+  random g = (t, g') where+    (t1,g') = random g+    t = tuple t1++-- | 6-Tuples+instance (Random a, Random b, Random c, Random d, Random e, Random f) => Random (a,b,c,d,e,f) where+  randomR (a,b) g = (t, g') where+    a1 = untuple a+    b1 = untuple b+    (t1,g') = randomR (a1,b1) g+    t = tuple t1+  random g = (t, g') where+    (t1,g') = random g+    t = tuple t1++-- | 7-Tuples+instance (Random a, Random b, Random c, Random d, Random e, Random f, Random g) => Random (a,b,c,d,e,f,g) where+  randomR (a,b) g = (t, g') where+    a1 = untuple a+    b1 = untuple b+    (t1,g') = randomR (a1,b1) g+    t = tuple t1+  random g = (t, g') where+    (t1,g') = random g+    t = tuple t1++-- | Lists+instance Random a => Random [a] where+  randomR (a,b) g = (l, g') where+    ab = safe_zip a b "randomR: upper and lower bound contain lists of non-matching lengths"+    (g', l) = mapAccumL (\g r -> swap $ randomR r g) g ab+  random g = ([a], g') where+    (a, g') = random g++-- --------------------------------------------------------------------+-- Functions:++-- | @'sample_all' min max@: +-- returns a list of all elements from the range (/min/,/max/). This+-- is actually just a synonym of 'interval'.+sample_all :: Interval a => a -> a -> [a]+sample_all = interval++-- | @'sample_step' n k min max@: +-- returns every /n/th element from the range (/min/,/max/), starting+-- with the /k/th element.+sample_step :: (Integral a, Integral b, Interval c) => a -> b -> c -> c -> [c]+sample_step n k x y = list_step n k (interval x y)++-- | @'sample_random' g min max@: +-- returns an infinite list of random samples from the range+-- (/min/,/max/), using the random number generator /g/.+sample_random :: (Random a, RandomGen g) => g -> a -> a -> [a]+sample_random g x y = randomRs (x,y) g++-- | A variant of 'sample_all' that omits the /min/ argument, and uses+-- the 'zero' element of the type instead.+sample_all0 :: (Zero a, Interval a) => a -> [a]+sample_all0 a = sample_all (zero a) a++-- | A variant of 'sample_step' that omits the /min/ argument, and uses+-- the 'zero' element of the type instead.+sample_step0 :: (Integral a, Integral b, Zero c, Interval c) => a -> b -> c -> [c]+sample_step0 n k a = sample_step n k (zero a) a++-- | A variant of 'sample_random' that omits the /min/ argument, and uses+-- the 'zero' element of the type instead.+sample_random0 :: (Random a, Zero a, RandomGen g) => g -> a -> [a]+sample_random0 g a = sample_random g (zero a) a++-- --------------------------------------------------------------------+-- Local functions:++-- | samples every /n/th element from the list, starting with element /k/+list_step :: (Integral a, Integral b) => a -> b -> [c] -> [c]+list_step n k [] = []+list_step n k (h:t) =+  if k==0 then +    h:(list_step n (n-1) t) +  else+    list_step n (k-1) t+    +-- | same as 'zip', but throw an error if length don't match+safe_zip :: [a] -> [b] -> String -> [(a,b)]+safe_zip l1 l2 msg = +  if length l1 == length l2 +  then zip l1 l2+  else error msg
+ Quipper/Utils/Stabilizers/Clifford.hs view
@@ -0,0 +1,731 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}++-- | This module contains an implementation of a quantum simulator that +-- uses the stabilizer states of the Clifford group (i.e. the Pauli group),+-- to provide efficient simulation of quantum circuits constructed from+-- elements of the Clifford group. The module provides an implementation+-- of the Clifford group operators {x,y,z,h,s,controlled-x} which form a+-- generating set for the Clifford group.+module Quipper.Utils.Stabilizers.Clifford where++import Prelude hiding (lookup,negate)+import Quipper.Utils.Stabilizers.Pauli+import Data.List (foldl')+import Data.Map (Map)+import qualified Data.Map as Map+import Control.Monad.State+import System.Random+import Quantum.Synthesis.Ring (Cplx (..), i)++-- | A qubit is defined as an integer reference.+type Qubit = Int++-- | The state of the system is a representation of a stabilizer tableau.++-- note this isn't a record, so as to help with strictness annotations +data Tableau = ST Qubit !(Map Qubit Sign) !(Map (Qubit,Qubit) Pauli) !(Map Qubit Sign) !(Map (Qubit,Qubit) Pauli)++-- | Accessor function for the next_qubit field of a Tableau+next_qubit :: Tableau -> Qubit+next_qubit (ST nq _ _ _ _) = nq++-- | Accessor function for the sign field of a Tableau+sign :: Tableau -> Map Qubit Sign+sign (ST _ s _ _ _) = s++-- | Accessor function for the tableau field of a Tableau+tableau :: Tableau -> Map (Qubit,Qubit) Pauli+tableau (ST _ _ t _ _) = t++-- | Accessor function for the de_sign field of a Tableau+de_sign :: Tableau -> Map Qubit Sign+de_sign (ST _ _ _ de_s _) = de_s++-- | Accessor function for the de_tableau field of a Tableau+de_tableau :: Tableau -> Map (Qubit,Qubit) Pauli+de_tableau (ST _ _ _ _ de_t) = de_t+++-- | A local Map lookup function that throws an error if the key doesn't exist.+lookup :: (Ord k,Show k, Show v) => k -> Map k v -> v+lookup k m = + case Map.lookup k m of+  Just b -> b+  Nothing -> error ("key: " ++ show k ++ " not in map: " ++ show m)++-- | A tableau can be shown, by enumerating over the qubits in scope.+instance Show Tableau where+ show tab = unlines $ ("Stabilizer:":map show_row qs) ++ ("Destabilizer:":map show_de_row qs)+  where +   qs :: [Qubit]+   qs = [0..(next_qubit tab) - 1]+   show_row :: Qubit -> String +   show_row q_row = show (lookup q_row (sign tab)) +                     ++ unwords (map (show_pauli q_row) qs)+   show_pauli :: Qubit -> Qubit -> String+   show_pauli q_row q_column = show (lookup (q_row,q_column) (tableau tab))+   show_de_row :: Qubit -> String +   show_de_row q_row = show (lookup q_row (de_sign tab)) +                        ++ unwords (map (show_de_pauli q_row) qs)+   show_de_pauli :: Qubit -> Qubit -> String+   show_de_pauli q_row q_column = show (lookup (q_row,q_column) (de_tableau tab))++-- | An initial (empty) tableau.+empty_tableau :: Tableau+empty_tableau = ST 0 Map.empty Map.empty Map.empty Map.empty++-- | A new qubit in the state |0〉 or |1〉 can be added to a tableau.+add_qubit :: Bool -> Tableau -> Tableau+add_qubit b tab = ST (nq + 1) sign' tableau' de_sign' de_tableau'+ where+  nq = next_qubit tab+  sign' = Map.insert nq (if b then Minus else Plus) (sign tab)+  de_sign' = Map.insert nq Plus (de_sign tab)+  tableau' = foldl' insertI (foldl' insertZ (tableau tab) [0..nq]) [0..nq-1]+  de_tableau' = foldl' insertI (foldl' insertX (de_tableau tab) [0..nq]) [0..nq-1]+  insertZ :: Map (Qubit,Qubit) Pauli -> Qubit -> Map (Qubit,Qubit) Pauli+  insertZ tab cq = Map.insert (nq,cq) (if nq == cq then Z else I) tab+  insertX :: Map (Qubit,Qubit) Pauli -> Qubit -> Map (Qubit,Qubit) Pauli+  insertX tab cq = Map.insert (nq,cq) (if nq == cq then X else I) tab+  insertI :: Map (Qubit,Qubit) Pauli -> Qubit -> Map (Qubit,Qubit) Pauli+  insertI tab cq = Map.insert (cq,nq) I tab++-- | A (Clifford) unitary can be defined as a function acting on Pauli operators.+type Unitary = Pauli -> (Sign,Pauli)++instance Eq Unitary where+  u1 == u2 = and [ u1 x == u2 x | x <- ixyz]+    where ixyz = [I,X,Y,Z] ++-- for a unitary U, the action on each Pauli (P) should be defined+-- as the result of UPU*. A complete set of generators for the Clifford+-- group is defined below, so defining a Unitary shouldn't be required+-- at the user-level++-- | The minimal definition of a unitary requires the actions on /X/ and /Z/.+data MinPauli = Xmin | Zmin++-- | The minimal definition of a unitary requires the actions on /X/ and /Z/.+type MinUnitary = MinPauli -> (Sign,Pauli)++-- | The definition of a 'Unitary' can be constructed from a 'MinUnitary'.+from_minimal :: MinUnitary -> Unitary+from_minimal f I = (Plus,I)+from_minimal f X = f Xmin+from_minimal f Z = f Zmin+from_minimal f Y = (sign,pauli)+ where+  (sx,px) = f Xmin+  (sz,pz) = f Zmin+  (spc,pauli) = commute px pz+  sign = signPlus_to_sign $ multiply_signPlus (multiply_signPlus (One sx) (One sz)) (multiply_signPlus (PlusI) (spc))++-- | It is possible to construct a 'Unitary' from a 2×2-matrix.+from_matrix :: (Floating r, Eq r, Show r) => Matrix1 (Cplx r) -> Unitary+from_matrix m = from_minimal minimal+ where+  minimal xy = sp+   where+    xy' = case xy of +           Xmin -> X+           Zmin -> Z+    m_dagger = transpose1 m+    sp = fromMatrix1 $ multiplyMatrix1 m (multiplyMatrix1 (toMatrix1 xy') m_dagger)+ +-- | A unitary can be applied to a qubit in a given tableau. By folding through each row+apply_unitary :: Unitary -> Qubit -> Tableau -> Tableau+apply_unitary u q_column tab = foldl' (apply_unitary_row u q_column) tab [0..nq-1]+ where+  nq = next_qubit tab++-- | Apply the unitary to the given column, in the given row.+apply_unitary_row :: Unitary -> Qubit -> Tableau -> Qubit -> Tableau+apply_unitary_row u q_column tab q_row = ST (next_qubit tab) sign' tableau' de_sign' de_tableau'+   where +    s = sign tab+    current_sign = lookup q_row s+    t = tableau tab+    current_pauli = lookup (q_row,q_column) t+    (change_sign,new_pauli) = u current_pauli+    new_sign = if negative change_sign then negate current_sign else current_sign+    sign' = Map.insert q_row new_sign s+    tableau' = Map.insert (q_row,q_column) new_pauli t+    de_s = de_sign tab+    de_current_sign = lookup q_row de_s+    de_t = de_tableau tab+    de_current_pauli = lookup (q_row,q_column) de_t+    (de_change_sign,de_new_pauli) = u de_current_pauli+    de_new_sign = if negative de_change_sign then negate de_current_sign else de_current_sign+    de_sign' = Map.insert q_row de_new_sign de_s+    de_tableau' = Map.insert (q_row,q_column) de_new_pauli de_t++-- | A two-qubit (Clifford) unitary can be defined as a function acting+-- on a pair of Pauli operators.+type Unitary2 = (Pauli,Pauli) -> (Sign,Pauli,Pauli)++instance Eq Unitary2 where+  u1 == u2 = and [ u1 (x,y) == u2 (x,y) | x <- ixyz, y <- ixyz]+    where ixyz = [I,X,Y,Z] ++-- | The minimal definition of a two-qubit unitary requires the actions on /IX/, /XI/, /IZ/, and /ZI/.+data MinPauli2 = IX | XI | IZ | ZI++-- | The minimal definition of a two-qubit unitary requires the actions on /IX/, /XI/, /IZ/, and /ZI/.+type MinUnitary2 = MinPauli2 -> (Sign,Pauli,Pauli)++-- | The definition of a 'Unitary2' can be constructed from a 'MinUnitary2'.+from_minimal2 :: MinUnitary2 -> Unitary2+from_minimal2 f (I,I) = (Plus,I,I)+from_minimal2 f (I,X) = f IX+from_minimal2 f (X,I) = f XI+from_minimal2 f (I,Z) = f IZ+from_minimal2 f (Z,I) = f ZI+from_minimal2 f (I,Y) = (sign,p1,p2)+  where+   (six,pix1,pix2) = from_minimal2 f (I,X) +   (siz,piz1,piz2) = from_minimal2 f (I,Z)+   (spc1,p1) = commute pix1 piz1+   (spc2,p2) = commute pix2 piz2+   sign = signPlus_to_sign $ multiply_signPlus (PlusI) (multiply_signPlus (multiply_signPlus (One six) (One siz)) (multiply_signPlus (spc1) (spc2)))+from_minimal2 f (Y,I) = (sign,p1,p2)+  where+   (six,pix1,pix2) = from_minimal2 f (X,I) +   (siz,piz1,piz2) = from_minimal2 f (Z,I)+   (spc1,p1) = commute pix1 piz1+   (spc2,p2) = commute pix2 piz2+   sign = signPlus_to_sign $ multiply_signPlus (PlusI) (multiply_signPlus (multiply_signPlus (One six) (One siz)) (multiply_signPlus (spc1) (spc2)))+from_minimal2 f (pauli1,pauli2) = (sign,p1,p2)+  where+   (six,pix1,pix2) = from_minimal2 f (pauli1,I) +   (siz,piz1,piz2) = from_minimal2 f (I,pauli2)+   (spc1,p1) = commute pix1 piz1+   (spc2,p2) = commute pix2 piz2+   sign = signPlus_to_sign $ multiply_signPlus (multiply_signPlus (One six) (One siz)) (multiply_signPlus (spc1) (spc2))++-- | It is possible to construct a 'Unitary2' from a 4×4-matrix.+from_matrix2 :: (Floating r, Eq r, Show r) => Matrix2 (Cplx r) -> Unitary2+from_matrix2 m = from_minimal2 minimal+ where+  minimal xy = sp+   where+    xy' = case xy of +           IX -> (I,X)+           XI -> (X,I) +           IZ -> (I,Z)+           ZI -> (Z,I)+    m_dagger = transpose2 m+    sp = fromMatrix2 $ multiplyMatrix2 m (multiplyMatrix2 (toMatrix2 xy') m_dagger)++-- | It is possible to construct a 'Unitary2' from controlling a 2×2-matrix.+from_matrix_controlled :: (Floating r, Show r, Eq r) => Matrix1 (Cplx r) -> Unitary2+from_matrix_controlled m1 = from_matrix2 (control1 m1)++-- | A two-qubit unitary can be applied to a pair of qubits in a given tableau.+apply_unitary2 :: Unitary2 -> (Qubit,Qubit) -> Tableau -> Tableau+apply_unitary2 u (q1,q2) tab = foldl' apply_unitary2' tab [0..nq-1]+ where+  nq = next_qubit tab+  apply_unitary2' :: Tableau -> Qubit -> Tableau+  apply_unitary2' tab q_row = ST (next_qubit tab) sign' tableau'' de_sign' de_tableau''+   where+    s = sign tab+    current_sign = lookup q_row s+    t = tableau tab+    current_pauli1 = lookup (q_row,q1) t+    current_pauli2 = lookup (q_row,q2) t+    (change_sign,new_pauli1,new_pauli2) = u (current_pauli1,current_pauli2)+    new_sign = if negative change_sign then negate current_sign else current_sign+    sign' = Map.insert q_row new_sign s+    tableau' = Map.insert (q_row,q1) new_pauli1 t+    tableau'' = Map.insert (q_row,q2) new_pauli2 tableau'+    de_s = de_sign tab+    de_current_sign = lookup q_row de_s+    de_t = de_tableau tab+    de_current_pauli1 = lookup (q_row,q1) de_t+    de_current_pauli2 = lookup (q_row,q2) de_t+    (de_change_sign,de_new_pauli1,de_new_pauli2) = u (de_current_pauli1,de_current_pauli2)+    de_new_sign = if negative de_change_sign then negate de_current_sign else de_current_sign+    de_sign' = Map.insert q_row de_new_sign de_s+    de_tableau' = Map.insert (q_row,q1) de_new_pauli1 de_t+    de_tableau'' = Map.insert (q_row,q2) de_new_pauli2 de_tableau'++-- | A measurement, in the computational basis, can be made of a qubit+-- in the Tableau, returning the measurement result, and the resulting+-- Tableau.+measure :: Qubit -> Tableau -> IO (Bool,Tableau)+measure q tab = case anticommute_with_z of+  [] -> -- all of the stabilizers commute with z, so the measurement is +    -- deterministic and doesn't change the tableau, +    -- but we need to calculate the result! +    -- the stabilzer either contains Z_q or -Z_q+   case (filter (\(row,_) -> row == z_row) z_rows) of+    [] -> do -- in this case, we need to see whether the generators form Z_q or -Z_q+     let tab' = reduce q tab+     (res,_) <- measure q tab'+     return (res,tab)+    [(_,row)] -> return (negative (lookup row s),tab)+    _ -> error "measure: multiple Zs found" -- should never occur!+    where+     z_row :: [Pauli]+     z_row = map (\q_col -> if q_col == q then Z else I) [0..(nq-1)]+     z_rows :: [([Pauli],Qubit)]+     z_rows = map (\q_row -> ((map (\q_col ->(lookup (q_row,q_col) t)) [0..(nq-1)]),q_row)) [0..(nq-1)] +  [(_,q_row)] -> do -- exaclty one anti-commutes, measurement result is 50/50+    let tab' = foldl' (\tab r -> if lookup (r,q) (de_tableau tab) `elem` [X,Y] then multiply_de r q_row tab else tab) tab [0..(nq-1)]+    let de_t = de_tableau tab'+    let de_s = de_sign tab'+    let de_s' = Map.insert q_row (lookup q_row s) de_s+    let de_t' = foldl' (\de_t q' -> Map.insert (q_row,q') (lookup (q_row,q') t) de_t) de_t [0..(nq-1)]+    b <- randomIO+    let eigen_value = if b then Minus else Plus+    let s' = Map.insert q_row eigen_value s+    let t' = foldl' (\t q' -> Map.insert (q_row,q') (if q == q' then Z else I) t) t [0..(nq-1)]+    let tab'' = ST nq s' t' de_s' de_t'+    return (negative eigen_value,tab'')+  ((_,q_row1):((_,q_row2):_)) -> -- more than one anti-commutes, so we update the set of stabilizers with the product of the first two anti-commuters+   measure q (multiply q_row2 q_row1 tab)+ where +  nq = next_qubit tab+  t = tableau tab+  s = sign tab+  de_t = de_tableau tab+  de_s = de_sign tab+  gs = map (\q_row -> (lookup (q_row,q) t,q_row)) [0..(nq-1)]+  anticommute_with_z = filter (\(ixyz,_) -> ixyz == X || ixyz == Y) gs++-- | This function reduces a tableau so that it contains either plus+-- or minus /Z/[sub /q/]. Note that it is only called in the case+-- where /Z/[sub /q/] is generated by the tableau (i.e., during+-- measurement).+reduce :: Qubit -> Tableau -> Tableau+reduce qubit tab = foldl' (\t q -> multiply r q t) tab ows+ where+  nq = next_qubit tab+  t = tableau tab+  de_t = de_tableau tab+  (r:ows) = filter (\q_row -> isXY (lookup (q_row,qubit) de_t) ) [0..nq-1]+  isXY p = p == X || p == Y++-- | Multiply the stabilizers for the two given rows, in the given tableau, and+-- update the first row with the result of the multiplication.+multiply :: Qubit -> Qubit -> Tableau -> Tableau+multiply q_row1 q_row2 tab = ST nq s' t' (de_sign tab) (de_tableau tab)+ where+  nq = next_qubit tab+  t = tableau tab+  s = sign tab +  sign1 = lookup q_row1 s+  sign2 = lookup q_row2 s+  sp = One (multiply_sign sign1 sign2)+  (t',sp') = foldl' mul_col (t,sp) [0..(nq-1)] +  s' = Map.insert q_row1 (signPlus_to_sign sp') s+  mul_col :: (Map (Qubit,Qubit) Pauli, SignPlus) -> Qubit -> (Map (Qubit,Qubit) Pauli, SignPlus)+  mul_col (tab,sp) q_col = (Map.insert (q_row1,q_col) p' tab,multiply_signPlus sp sp')+    where+     p1 = lookup (q_row1,q_col) tab+     p2 = lookup (q_row2,q_col) tab+     (sp',p') = commute p1 p2++-- | Multiply row1 of the destabilizer by row2 of the stabilizer. +multiply_de :: Qubit -> Qubit -> Tableau -> Tableau+multiply_de q_row1 q_row2 tab = ST nq s t s_de' t_de'+ where+  nq = next_qubit tab+  t = tableau tab+  s = sign tab+  t_de = de_tableau tab+  s_de = de_sign tab+  sign1 = lookup q_row1 s_de+  sign2 = lookup q_row2 s+  sp = One (multiply_sign sign1 sign2)+  (t_de',sp') = foldl' mul_col (t_de,sp) [0..(nq-1)] +  s_de' = Map.insert q_row1 (signPlus_to_sign sp') s_de+  mul_col :: (Map (Qubit,Qubit) Pauli, SignPlus) -> Qubit -> (Map (Qubit,Qubit) Pauli, SignPlus)+  mul_col (tab_de,sp) q_col = (Map.insert (q_row1,q_col) p' tab_de,multiply_signPlus sp sp')+    where+     p1 = lookup (q_row1,q_col) tab_de+     p2 = lookup (q_row2,q_col) t+     (sp',p') = commute p1 p2++---------------------------------------+-- Generators for the Clifford group --+---------------------------------------++-- All Clifford group operators can be defined in terms of the+-- following gates. The Monadic interface can be used for this+-- purpose. For example.++-- | The Pauli /X/ operator is a Clifford group unitary.+x :: Unitary+x I = (Plus,I)+x X = (Plus,X)+x Y = (Minus,Y)+x Z = (Minus,Z)++-- | We can (equivalently) define Pauli-/X/ as a 'MinUnitary'.+x_min :: MinUnitary+x_min Xmin = (Plus,X)+x_min Zmin = (Minus,Z)++-- | We can (equivalently) construct Pauli-/X/ from a 'MinUnitary'.+x' :: Unitary+x' = from_minimal x_min++-- | We can (equivalently) construct Pauli-/X/ from a matrix.+x'' :: Unitary+x'' = from_matrix (0,1,1,0)++-- | The Pauli /Y/-operator is a Clifford group unitary.+y :: Unitary+y I = (Plus,I)+y X = (Minus,X)+y Y = (Plus,Y)+y Z = (Minus,Z)++-- | We can (equivalently) define Pauli-/Y/ as a 'MinUnitary'.+y_min :: MinUnitary+y_min Xmin = (Minus,X)+y_min Zmin = (Minus,Z)++-- | We can (equivalently) construct Pauli-/Y/ from a 'MinUnitary'.+y' :: Unitary+y' = from_minimal y_min++-- | We can (equivalently) construct Pauli-/Y/ from a matrix.+y'' :: Unitary+y'' = from_matrix (0,-i,i,0)++-- | The Pauli /Z/-operator is a Clifford group unitary.+z :: Unitary+z I = (Plus,I)+z X = (Minus,X)+z Y = (Minus,Y)+z Z = (Plus,Z)++-- | We can (equivalently) define Pauli-/Z/ as a 'MinUnitary'.+z_min :: MinUnitary+z_min Xmin = (Minus,X)+z_min Zmin = (Plus,Z)++-- | We can (equivalently) construct Pauli-/Z/ from a 'MinUnitary'.+z' :: Unitary+z' = from_minimal z_min++-- | We can (equivalently) construct Pauli-/Z/ from a matrix.+z'' :: Unitary+z'' = from_matrix (1,0,0,-1)++-- | The Hadamard-gate is a Clifford group unitary.+h :: Unitary+h I = (Plus,I)+h X = (Plus,Z)+h Y = (Minus,Y)+h Z = (Plus,X)++-- | We can (equivalently) define Hadamard as a 'MinUnitary'.+h_min :: MinUnitary+h_min Xmin = (Plus,Z)+h_min Zmin = (Plus,X)++-- | We can (equivalently) construct Hadamard from a 'MinUnitary'.+h' :: Unitary+h' = from_minimal h_min++-- | We can (equivalently) construct Hadamard from a matrix.+-- Although rounding errors break this!!!+h'' :: Unitary+h'' = from_matrix $ scale1 (Cplx (1/sqrt 2) 0) (1,1,1,-1)++-- | The phase-gate is a Clifford group unitary.+s :: Unitary+s I = (Plus,I) +s X = (Plus,Y)+s Y = (Minus,X)+s Z = (Plus,Z)++-- | We can (equivalently) define phase gate as a 'MinUnitary'.+s_min :: MinUnitary+s_min Xmin = (Plus,Y)+s_min Zmin = (Plus,Z)++-- | We can (equivalently) construct phase gate from a 'MinUnitary'.+s' :: Unitary+s' = from_minimal s_min++-- | We can (equivalently) construct phase gate from a matrix.+s'' :: Unitary+s'' = from_matrix (1,0,0,i)++-- | The phase-gate is a Clifford group unitary.+e :: Unitary+e I = (Plus,I) +e X = (Plus,Y)+e Y = (Plus,Z)+e Z = (Plus,X)++-- | We can (equivalently) define phase gate as a 'MinUnitary'.+e_min :: MinUnitary+e_min Xmin = (Plus,Y)+e_min Zmin = (Plus,X)++-- | We can (equivalently) construct phase gate from a 'MinUnitary'.+e' :: Unitary+e' = from_minimal e_min++-- | We can (equivalently) construct phase gate from a matrix.+e'' :: Unitary+e'' = from_matrix ((-1+i)/2, (1+i)/2, (-1+i)/2, (-1-i)/2)++-- | The controlled-not is a Clifford group 2-qubit unitary.+cnot :: Unitary2+cnot (I,I) = (Plus,I,I)+cnot (I,X) = (Plus,I,X)+cnot (I,Y) = (Plus,Z,Y)+cnot (I,Z) = (Plus,Z,Z)+cnot (X,I) = (Plus,X,X)+cnot (X,X) = (Plus,X,I)+cnot (X,Y) = (Plus,Y,Z)+cnot (X,Z) = (Minus,Y,Y)+cnot (Y,I) = (Plus,Y,X)+cnot (Y,X) = (Plus,Y,I)+cnot (Y,Y) = (Minus,X,Z)+cnot (Y,Z) = (Plus,X,Y)+cnot (Z,I) = (Plus,Z,I)+cnot (Z,X) = (Plus,Z,X)+cnot (Z,Y) = (Plus,I,Y)+cnot (Z,Z) = (Plus,I,Z)++-- | We can (equivalently) define CNot as a 'MinUnitary2'.+cnot_min :: MinUnitary2+cnot_min IX = (Plus,I,X)+cnot_min XI = (Plus,X,X)+cnot_min IZ = (Plus,Z,Z)+cnot_min ZI = (Plus,Z,I)++-- | We can (equivalently) construct CNot from a 'MinUnitary2'.+cnot' :: Unitary2+cnot' = from_minimal2 cnot_min++-- | We can (equivalently) construct CNot from a matrix.+cnot'' :: Unitary2+cnot'' = from_matrix2 ((1,0,0,1),(0,0,0,0),(0,0,0,0),(0,1,1,0))++-- | The controlled-/Z/ is a Clifford group 2-qubit unitary.+cz :: Unitary2+cz (I,I) = (Plus,I,I)+cz (I,X) = (Plus,Z,X)+cz (I,Y) = (Plus,Z,Y)+cz (I,Z) = (Plus,I,Z)+cz (X,I) = (Plus,X,Z)+cz (X,X) = (Plus,Y,Y)+cz (X,Y) = (Minus,Y,X)+cz (X,Z) = (Plus,X,I)+cz (Y,I) = (Plus,Y,Z)+cz (Y,X) = (Minus,X,Y)+cz (Y,Y) = (Plus,X,X)+cz (Y,Z) = (Plus,Y,I)+cz (Z,I) = (Plus,Z,I)+cz (Z,X) = (Plus,I,X)+cz (Z,Y) = (Plus,I,Y)+cz (Z,Z) = (Plus,Z,Z)++-- | We can (equivalently) define controlled-/Z/ as a 'MinUnitary2'.+cz_min :: MinUnitary2+cz_min IX = (Plus,Z,X)+cz_min XI = (Plus,X,Z)+cz_min IZ = (Plus,I,Z)+cz_min ZI = (Plus,Z,I)++-- | We can (equivalently) construct controlled-/Z/ from a 'MinUnitary2'.+cz' :: Unitary2+cz' = from_minimal2 cz_min++-- | We can (equivalently) construct controlled-/Z/ from a matrix.+cz'' :: Unitary2+cz'' = from_matrix2 ((1,0,0,1),(0,0,0,0),(0,0,0,0),(1,0,0,-1))++------------------------------------------------------------------+-- A Monadic Interface for constructing Clifford group circuits --+------------------------------------------------------------------++-- Larger Clifford group circuits can be defined in terms of the+-- following operations. It is envisaged that a Quipper Transformer+-- can be defined to translate appropriate Quipper circuits (i.e.+-- circuits that only use Clifford group operators) into a+-- CliffordCirc so that it can be simulated (efficiently).++-- | A Clifford group circuit is implicitly simulated using+-- a state monad over a 'Tableau'.+type CliffordCirc a = StateT Tableau IO a++-- | Initialize a new qubit.+init_qubit :: Bool -> CliffordCirc Qubit+init_qubit b = do+  tab <- get+  let nq = next_qubit tab+  put (add_qubit b tab)+  return nq ++-- | Initialize multiple qubits.+init_qubits :: [Bool] -> CliffordCirc [Qubit]+init_qubits = mapM init_qubit++-- | Apply a Pauli-/X/ gate to the given qubit.+gate_X :: Qubit -> CliffordCirc ()+gate_X q = do+  tab <- get+  put (apply_unitary x q tab)++-- | Apply a Pauli-/Y/ gate to the given qubit.+gate_Y :: Qubit -> CliffordCirc ()+gate_Y q = do+  tab <- get+  put (apply_unitary y q tab)++-- | Apply a Pauli-/Z/ gate to the given qubit.+gate_Z :: Qubit -> CliffordCirc ()+gate_Z q = do+  tab <- get+  put (apply_unitary z q tab)++-- | Apply a Hadamard gate to the given qubit.+gate_H :: Qubit -> CliffordCirc ()+gate_H q = do+  tab <- get+  put (apply_unitary h q tab)++-- | Apply a phase gate to the given qubit.+gate_S :: Qubit -> CliffordCirc ()+gate_S q = do+  tab <- get+  put (apply_unitary s q tab)++-- | Apply a given 'Unitary' to the given qubit.+gate_Unitary :: Unitary -> Qubit -> CliffordCirc ()+gate_Unitary u q = do+  tab <- get+  put (apply_unitary u q tab)++-- | Apply a controlled-/X/ gate to the given qubits.+controlled_X :: Qubit -> Qubit -> CliffordCirc ()+controlled_X q1 q2 = do+  tab <- get+  put (apply_unitary2 cnot (q1,q2) tab)++-- | Apply a controlled-/Z/ gate to the given qubits.+controlled_Z :: Qubit -> Qubit -> CliffordCirc ()+controlled_Z q1 q2 = do+  tab <- get+  put (apply_unitary2 cz (q1,q2) tab)++-- | Apply a given 'Unitary2' to the given qubits+gate_Unitary2 :: Unitary2 -> Qubit -> Qubit -> CliffordCirc ()+gate_Unitary2 u q1 q2 = do+  tab <- get+  put (apply_unitary2 u (q1,q2) tab)++-- | Measure the given qubit in the computational basis.+measure_qubit :: Qubit -> CliffordCirc Bool+measure_qubit q = do+  tab <- get+  (res,tab') <- lift $ measure q tab+  put tab'+  return res++-- | Measure the given list of qubits.+measure_qubits :: [Qubit] -> CliffordCirc [Bool]+measure_qubits = mapM measure_qubit++-- | For testing purposes, we can show the tableau during a simulation.+show_tableau :: CliffordCirc ()+show_tableau = do+  tab <- get+  lift $ putStrLn (show tab)++----------------------------------------------------+-- Evaluation and Simulation of Clifford circuits --+----------------------------------------------------++-- | Return the evaluated 'Tableau' for the given circuit.+eval :: CliffordCirc a -> IO Tableau+eval cc = execStateT cc empty_tableau++-- | Return the result of simulating the given circuit.+sim :: CliffordCirc a -> IO a+sim cc = evalStateT cc empty_tableau++---------------------------------+-- Some test Clifford circuits --+---------------------------------++-- | A swap gate can be defined in terms of three controlled-not gates.+swap :: Qubit -> Qubit -> CliffordCirc ()+swap q1 q2 = do+  controlled_X q1 q2+  controlled_X q2 q1+  controlled_X q1 q2++-- | A controlled-/Z/ gate can (equivalently) be defined in terms of+-- Hadamard and controlled-/X/.+controlled_Z' :: Qubit -> Qubit -> CliffordCirc ()+controlled_Z' q1 q2 = do+  gate_H q2+  controlled_X q1 q2+  gate_H q2+++-- | Each of the four Bell states can be generated, indexed by a pair+-- of boolean values.+bell :: (Bool,Bool) -> CliffordCirc (Qubit,Qubit)+bell (bx,by) = do+  x <- init_qubit bx+  --show_tableau+  y <- init_qubit by+  --show_tableau+  gate_H x+  --show_tableau+  controlled_X x y+  --show_tableau+  return (x,y)++-- | Create a Bell state, and measure it.+measure_bell00 :: CliffordCirc (Bool,Bool)+measure_bell00 = do+  (bx,by) <- bell (False,False)+  mx <- measure_qubit bx+  --show_tableau+  my <- measure_qubit by+  --show_tableau+  return (mx,my)++-- | A single-qubit operation can be controlled by a classical boolean value.+controlled_if :: Bool -> (Qubit -> CliffordCirc ()) -> Qubit -> CliffordCirc ()+controlled_if b u q = if b then u q else return ()++-- | A simple, single qubit, teleportation circuit.+teleport :: Qubit -> CliffordCirc Qubit+teleport q1 = do+  (q2,q3) <- bell (False,False)+  controlled_X q1 q2+  gate_H q1+  [b1,b2] <- measure_qubits [q1,q2]+  controlled_if b2 gate_X q3+  controlled_if b1 gate_Z q3+  return q3++-- | A wrapper around the teleportation circuit that initializes a qubit+-- in the given boolean state, and measures the teleported qubit.+test_teleport :: Bool -> CliffordCirc Bool+test_teleport b = do+  q <- init_qubit b+  q' <- teleport q+  measure_qubit q'++-- | Measure an equal superposition.+random_bool :: CliffordCirc Bool+random_bool = do+  q <- init_qubit False+  gate_H q+  measure_qubit q
+ Quipper/Utils/Stabilizers/Pauli.hs view
@@ -0,0 +1,199 @@+-- | This module contains a data type to represent the four Pauli operators,+-- along with various operations on them, including commutativity relations.+module Quipper.Utils.Stabilizers.Pauli where++import Prelude hiding (negate)+import Quantum.Synthesis.Ring (Cplx (..), i)++-- | The Pauli operators can be used to generate a stabilizer group for+-- the Clifford operators.+data Pauli = I | X | Y | Z deriving (Show,Eq)++-- | The generators of a stabilizer group require a sign.+data Sign = Plus | Minus deriving (Ord,Eq)++instance Show Sign where+ show Plus = "+"+ show Minus = "-"++-- | Returns a boolean as to whether a 'Sign' is negative (i.e.. 'Minus').+negative :: Sign -> Bool+negative Plus = False+negative Minus = True++-- | Returns the negation of a 'Sign'.+negate :: Sign -> Sign+negate Plus = Minus+negate Minus = Plus++-- | Two signs can be multiplied.+multiply_sign :: Sign -> Sign -> Sign+multiply_sign Plus s = s+multiply_sign Minus s = negate s++--------------------------------------+-- Helper Functions for Commutation --+--------------------------------------++-- | In general, Pauli operators can commute, or anti-commute, so we+-- need to add signs or ±/i/.+data SignPlus = MinusI | PlusI | One Sign++instance Show SignPlus where+  show (One x) = " " ++ show x+  show PlusI = "+i"+  show MinusI = "-i"++-- | Two 'SignPlus's can be multiplied.+multiply_signPlus :: SignPlus -> SignPlus -> SignPlus+multiply_signPlus (One Plus) s = s+multiply_signPlus (One Minus) (One Minus) = One Plus+multiply_signPlus (One Minus) PlusI = MinusI+multiply_signPlus (One Minus) MinusI = PlusI+multiply_signPlus PlusI PlusI = One Minus+multiply_signPlus PlusI MinusI = One Plus+multiply_signPlus MinusI MinusI = One Minus+multiply_signPlus s1 s2 = multiply_signPlus s2 s1++-- | Extract a 'Sign' embedded in a 'SignPlus', or throw an error+-- if the argument is not an embedded 'Sign'.+signPlus_to_sign :: SignPlus -> Sign+signPlus_to_sign (One s) = s+signPlus_to_sign _ = error "signPlus_to_sign: i in sign"++-- | The Levi-Civita symbol, for the permutations of three Pauli operators.+levi_civita :: Pauli -> Pauli -> Pauli -> SignPlus+levi_civita X Y Z = PlusI+levi_civita X Z Y = MinusI+levi_civita Y X Z = MinusI+levi_civita Y Z X = PlusI+levi_civita Z X Y = PlusI+levi_civita Z Y X = MinusI+levi_civita _ _ _ = One Plus++-- | The Kronecker delta for two Pauli operators.+kronecker_delta :: Pauli -> Pauli -> Bool+kronecker_delta x y = x == y++-- | The combination of the commutation and anti-commutation operators can+-- be used to essentially multiply an (ordered) pair of Pauli operators.+commute :: Pauli -> Pauli -> (SignPlus,Pauli)+commute I p = (One Plus,p)+commute p I = (One Plus,p)+commute x y = + if kronecker_delta x y then (One Plus,I) + else case (levi_civita x y X,levi_civita x y Y,levi_civita x y Z) of+       (s,One _,One _) -> (s,X)+       (One _,s,One _) -> (s,Y)+       (One _,One _,s) -> (s,Z)+       _ -> error "commute: Impossible clause reached, somehow"++-- map (\(x,y) -> (x,y,commute x y)) [(x,y) | x <- [I,X,Y,Z], y <- [I,X,Y,Z]]+-- [(I,I,( +,I)),(I,X,( +,X)),(I,Y,( +,Y)),(I,Z,( +,Z)),(X,I,( +,X)),(X,X,( +,I)),(X,Y,(+i,Z)),(X,Z,(-i,Y)),(Y,I,( +,Y)),(Y,X,(-i,Z)),(Y,Y,( +,I)),(Y,Z,(+i,X)),(Z,I,( +,Z)),(Z,X,(+i,Y)),(Z,Y,(-i,X)),(Z,Z,( +,I))]++-- | Represent a 2×2-matrix as a 4-tuple.+type Matrix1 a = (a,a,a,a)++++-- | Give the matrix for each Pauli operator.+toMatrix1 :: (Floating r) => Pauli -> Matrix1 (Cplx r)+toMatrix1 I = (1,0,0,1)+toMatrix1 X = (0,1,1,0)+toMatrix1 Y = (0,-i,i,0)+toMatrix1 Z = (1,0,0,-1)++-- | Scale a 2-by-2 matrix.+scale1 :: (Num a) => a -> Matrix1 a -> Matrix1 a+scale1 x (a,b,c,d) = (x*a,x*b,x*c,x*d)++-- | If a matrix is Pauli, then return the Pauli operator, otherwise+-- throw an error.+fromMatrix1 :: (Floating r, Eq r,Show r) => Matrix1 (Cplx r) -> (Sign,Pauli)+fromMatrix1 m = case filter (\(b,_) -> b) [(toMatrix1 x == m,x) | x <- ixyz] of+  [(_,p)] -> (Plus,p)+  _ -> case filter (\(b,_) -> b) [((scale1 (-1) (toMatrix1 x)) == m,x) | x <- ixyz] of+        [(_,p)] -> (Minus,p)+        _ -> error ("fromMatrix1: " ++ show m ++ " is not a pauli matrix")+ where+  ixyz = [I,X,Y,Z]++-- | Matrix multiplication for 2×2-matrices.+multiplyMatrix1 :: (Num a) => Matrix1 a -> Matrix1 a -> Matrix1 a+multiplyMatrix1 (a00,a01,a10,a11) (b00,b01,b10,b11) = (c00,c01,c10,c11)+ where+  c00 = a00*b00 + a01*b10+  c01 = a00*b01 + a01*b11+  c10 = a10*b00 + a11*b10+  c11 = a10*b01 + a11*b11++-- | Compute the transpose of a 2×2 complex-valued matrix.+transpose1 :: (Num r) => Matrix1 (Cplx r) -> Matrix1 (Cplx r)+transpose1 (a00,a01,a10,a11) = (conjugate a00, conjugate a10, conjugate a01, conjugate a11)+ where+  conjugate (Cplx a b) = Cplx a (-b) ++-- | Return the matrix for Pauli-/Y/, which is /iXZ/.+my_Y :: (Floating r) => Matrix1 (Cplx r)+my_Y = scale1 i $ multiplyMatrix1 (toMatrix1 X) (toMatrix1 Z)++-- | A 4×4-matrix is represented as a 2×2-matrix of 2×2-matrices.+type Matrix2 a = Matrix1 (Matrix1 a)++-- | The tensor product of two 2×2-matrices is a 4×4 matrix.+tensor1 :: (Num a) => Matrix1 a -> Matrix1 a -> Matrix2 a+tensor1 (a,b,c,d) m = (scale1 a m,scale1 b m,scale1 c m,scale1 d m) ++-- | A controlled operation can be expressed with just the operation to be controlled.+control1 :: (Num a) => Matrix1 a -> Matrix2 a+control1 m1 = ((1,0,0,1),(0,0,0,0),(0,0,0,0),m1)++-- | Take the tensor of a pair of Pauli operators, and return a 4×4 matrix.+toMatrix2 :: (Floating r) => (Pauli,Pauli) -> Matrix2 (Cplx r)+toMatrix2 (x,y) = tensor1 (toMatrix1 x) (toMatrix1 y)++-- | Scale a 4×4 matrix.+scale2 :: (Num a) => a -> Matrix2 a -> Matrix2 a+scale2 x (a,b,c,d) = (scale1 x a,scale1 x b,scale1 x c,scale1 x d)++-- | If a matrix is the tensor product of two Pauli operators, then+-- return the pair of Pauli operators, otherwise throw an error.+fromMatrix2 :: (Floating r, Eq r, Show r) => Matrix2 (Cplx r) -> (Sign,Pauli,Pauli)+fromMatrix2 m = case filter (\(b,_) -> b) [(toMatrix2 (x,y)  == m,(x,y)) | x <- ixyz, y <- ixyz] of+  [(_,(p1,p2))] -> (Plus,p1,p2)+  _ -> case filter (\(b,_) -> b) [(scale2 (-1) (toMatrix2 (x,y))  == m,(x,y)) | x <- ixyz, y <- ixyz] of+      [(_,(p1,p2))] -> (Minus,p1,p2)+      _ -> error ("fromMatrix2: " ++ show m ++ " is not a tensor product of two Pauli matrices")+ where+  ixyz = [I,X,Y,Z]++-- | Matrix multiplication for 4×4 matrices.+multiplyMatrix2 :: (Num a) => Matrix2 a -> Matrix2 a -> Matrix2 a+multiplyMatrix2 ((a00,a01,a10,a11),(a02,a03,a12,a13),(a20,a21,a30,a31),(a22,a23,a32,a33)) ((b00,b01,b10,b11),(b02,b03,b12,b13),(b20,b21,b30,b31),(b22,b23,b32,b33)) = ((c00,c01,c10,c11),(c02,c03,c12,c13),(c20,c21,c30,c31),(c22,c23,c32,c33))+ where+  c00 = a00*b00 + a01*b10 + a02*b20 + a03*b30+  c01 = a00*b01 + a01*b11 + a02*b21 + a03*b31+  c02 = a00*b02 + a01*b12 + a02*b22 + a03*b32+  c03 = a00*b03 + a01*b13 + a02*b23 + a03*b33+  c10 = a10*b00 + a11*b10 + a12*b20 + a13*b30+  c11 = a10*b01 + a11*b11 + a12*b21 + a13*b31+  c12 = a10*b02 + a11*b12 + a12*b22 + a13*b32+  c13 = a10*b03 + a11*b13 + a12*b23 + a13*b33+  c20 = a20*b00 + a21*b10 + a22*b20 + a23*b30+  c21 = a20*b01 + a21*b11 + a22*b21 + a23*b31+  c22 = a20*b02 + a21*b12 + a22*b22 + a23*b32+  c23 = a20*b03 + a21*b13 + a22*b23 + a23*b33+  c30 = a30*b00 + a31*b10 + a32*b20 + a33*b30+  c31 = a30*b01 + a31*b11 + a32*b21 + a33*b31+  c32 = a30*b02 + a31*b12 + a32*b22 + a33*b32+  c33 = a30*b03 + a31*b13 + a32*b23 + a33*b33++-- | The transpose of a 4×4 complex valued matrix.+transpose2 :: (Floating r) => Matrix2 (Cplx r) -> Matrix2 (Cplx r)+transpose2 ((a00,a01,a10,a11),(a02,a03,a12,a13),(a20,a21,a30,a31),(a22,a23,a32,a33)) = ((conjugate a00,conjugate a10,conjugate a01,conjugate a11),(conjugate a20,conjugate a30,conjugate a21,conjugate a31),(conjugate a02,conjugate a12,conjugate a03,conjugate a13),(conjugate a22,conjugate a32,conjugate a23,conjugate a33))+ where+  conjugate (Cplx a b) = Cplx a (-b) ++-- | The tensor product /IY/ can be defined by /i/(/IX/)(/IZ/).+my_IY :: (Floating r) => Matrix2 (Cplx r)  +my_IY = scale2 i $ multiplyMatrix2 (toMatrix2 (I,X)) (toMatrix2 (I,Z))
+ Quipper/Utils/Template.hs view
@@ -0,0 +1,66 @@+-- | This module provides the public interface to the template lifting+-- library. It provides functions that input a Haskell declaration or+-- expression (in the form of a Haskell abstract syntax tree), and+-- lift this to another declaration or expression, with all functions+-- lifted into a specified monad.+-- +-- This can be combined with Template Haskell to convert source code+-- to Haskell abstract syntax trees and vice versa.++module Quipper.Utils.Template (+  -- * Example+  -- $EXAMPLE+  +  -- * General lifting functions+  decToMonad,+  expToMonad,+  +  -- * Liftings of specific constants+  module Quipper.Utils.Template.Auxiliary,++  -- * Re-exports from "Language.Haskell.TH".+  TH.Q,+  TH.Dec+  ) where++import Quipper.Utils.Template.Lifting+import Quipper.Utils.Template.Auxiliary+import Language.Haskell.TH as TH++-- $EXAMPLE +-- +-- We give an example to illustrate what is meant by \"lifting\" a+-- term to a monad. Consider the expression+-- +-- > f = \g x -> g x x,+-- +-- which has type+-- +-- > f :: (a -> a -> b) -> (a -> b).+-- +-- We can lift this to the 'IO' monad by +-- +-- * converting the expression to an abstract syntax tree, using the+-- special Template Haskell notation [nobr @[| ... |]@];+-- +-- * applying the 'expToMonad' function;+-- +-- * converting the resulting abstract syntax tree back to a term,+-- using the special Template Haskell notation [nobr @$( ... )@].+-- +-- This allows us to write the following:+-- +-- > f' = $( expToMonad "IO" [| \g x -> g x x |] ),+-- +-- which has type+-- +-- > f' :: IO ((a -> IO (a -> IO b)) -> IO (a -> IO b)),+-- +-- and is in fact equivalent to+-- +-- > f'' = return $ \g ->+-- >         return $ \x -> do+-- >           h <- g x+-- >           y <- h x+-- >           return y+
+ Quipper/Utils/Template/Auxiliary.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | This module is for use with "Quipper.Utils.Template.Lifting". +-- It contains various lifted functions of general use. They are not+-- intended to be used directly (although this would not break+-- anything).++module Quipper.Utils.Template.Auxiliary where++import Quipper.Utils.Auxiliary (fold_right_zip,fold_right_zipM)+import Data.List+import Control.Monad++-- ----------------------------------------------------------------------+-- * List operations++-- | Lifted version of @'(:)' :: a -> [a] -> [a]@.+template_symb_colon_ :: Monad m => m (a -> m ([a] -> m [a]))+template_symb_colon_ = return $ \h -> return $ \t -> return (h:t)++-- | Lifted version of @'[]' :: [a]@.+template_symb_obracket_symb_cbracket_ :: Monad m => m [a]+template_symb_obracket_symb_cbracket_ = return []++-- | Lifted version of @'init' :: [a] -> [a]@.+template_init ::  Monad m => m ([a] -> m [a])+template_init = return $ \l -> return (init l)++-- | Lifted version of @'last' :: [a] -> [a]@.+template_last :: Monad m => m ([a] -> m a)+template_last = return $ \l -> return (last l)++-- | Lifted version of @'(++)' :: [a] -> [a] -> [a]@.+template_symb_plus_symb_plus_ :: Monad m => m ([a] -> m ([a] -> m [a]))+template_symb_plus_symb_plus_ = return $ \l1 -> return $ \l2-> return (l1 ++ l2)++-- | Lifted version of 'zip3'.+template_zip3 :: Monad m => m ([a] -> m ([b] -> m ([c] -> m [(a,b,c)])))+template_zip3 = return $ \x -> return $ \y -> return $ \z -> return (zip3 x y z)++-- | lifted version of @'foldl'@+template_foldl :: Monad m => m ((a -> m (b -> m a)) -> m (a -> m ([b] -> m a)))+template_foldl = return $ \f -> return $ \a -> return $ \lb -> foldM (auxf f) a lb+        where auxf f a b = do+                g <- f a+                g b++-- | lifted version of @'reverse'@+template_reverse :: Monad m => m ([a] -> m [a])+template_reverse = return $ \x -> return (reverse x)+++-- | lifted version of @'zipWith'@+template_zipWith :: Monad m => m ((a -> m (b -> m c)) -> m ([a] -> m ([b] -> m [c])))+template_zipWith = return $ \f -> return $ \a -> return $ \b -> zipWithM (auxf f) a b+        where auxf f a b = do+                g <- f a+                g b++-- | Lifted version of @'fold_right_zip'@+template_fold_right_zip :: +  Monad m => m (((a,b,c) -> m (a,d)) -> m ((a,[b],[c]) -> m (a,[d])))+template_fold_right_zip = return $ \f -> return $ \x -> (fold_right_zipM f x)++-- ----------------------------------------------------------------------+-- * Other operations++-- | Lifted version of the combinator '$'.+template_symb_dollar_ :: Monad m => m ((a -> m b) -> m (a -> m b))+template_symb_dollar_ = return $ \f -> return $ \x -> f x++-- | Lifted version of @'error' :: String -> a@. Using it will make the+-- circuit generation fail with the error described in 'String'.+template_error :: Monad m => m (String -> m a)+template_error = return $ error++-- | Lifted version of @'snd' :: (a,b) -> b@+template_snd :: Monad m => m ((a,b) -> m b)+template_snd = return $ \(a,b) -> return b++
+ Quipper/Utils/Template/ErrorMsgQ.hs view
@@ -0,0 +1,56 @@+-- | This module provides a simple monad to encapsulate error+-- messages within the 'Q' monad.++module Quipper.Utils.Template.ErrorMsgQ where++import Language.Haskell.TH++import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap)++-- | Shortcut for 'Either String a'.+type ErrMsg a = Either String a++-- | Type for the monad encapsulating error messages.+data ErrMsgQ a = ErrMsgQ (Q (ErrMsg a))++instance Monad ErrMsgQ where+    return x = ErrMsgQ $ return $ return x+    (>>=) (ErrMsgQ x) f = ErrMsgQ $ do+              x' <- x+              case x' of +                 Left s -> return (Left s)+                 Right r -> let (ErrMsgQ y) = f r in y++instance Applicative ErrMsgQ where+  pure = return+  (<*>) = ap++instance Functor ErrMsgQ where+  fmap = liftM++-- | Set an error message, to be thrown.+-- Usage:                 +--                  +-- > errorMsg "an error happened"                 +errorMsg :: String -> ErrMsgQ a+errorMsg s = ErrMsgQ (return (Left s))++-- | Make a 'Q' computation error-message aware.+embedQ :: Q a -> ErrMsgQ a+embedQ x = ErrMsgQ $ do x' <- x; return (return x')++-- | Throw the error that has been created, using the given string as+-- a prefix. Usage:+-- +-- > extractQ "name of function: " $ do+-- >   <<commands that may thow an error>>+extractQ :: String -> ErrMsgQ a -> Q a+extractQ prefix (ErrMsgQ x) = +  do+    x' <- x+    case x' of+      Left s -> error (prefix ++ s)+      Right x -> return x++
+ Quipper/Utils/Template/LiftQ.hs view
@@ -0,0 +1,282 @@+-- | This module defines the state monad used in+-- 'Quipper.Utils.Template.Lifting' for Template Haskell +-- term manipulation.+module Quipper.Utils.Template.LiftQ where++import qualified Language.Haskell.TH as TH+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.List as List++import Language.Haskell.TH (Name)+import Control.Monad.State+import Data.Map (Map)+import Data.Set (Set)++import Control.Applicative (Applicative(..))+import Control.Monad (liftM, ap)++import qualified Quipper.Utils.Template.ErrorMsgQ as Err+import Quipper.Utils.Template.ErrorMsgQ (ErrMsgQ)++-- | State of the monad.+data LiftState = LiftState {+  boundVar :: Map Name Int, -- ^ How many times each name is bound.+  prefix :: Maybe String,   -- ^ The template prefix .+  monadName :: Maybe String -- ^ The name of the monad.+}++-- | An empty state.+emptyLiftState :: LiftState+emptyLiftState = LiftState { +  boundVar = Map.empty, +  prefix = Nothing,+  monadName = Nothing+}++-- | Shortcut to @StateT LiftState ErrMsgQ@.+type LiftQState = StateT LiftState ErrMsgQ++-- | The monad.+data LiftQ a = LiftQ (LiftQState a)++instance Monad LiftQ where+  return x = LiftQ $ return x+  (>>=) (LiftQ x) f = LiftQ $ do+           x' <- x+           let (LiftQ y) = f x'+           y++instance Applicative LiftQ where+  pure = return+  (<*>) = ap++instance Functor LiftQ where+  fmap = liftM++-- | Retrieve the state from the monad.+getState :: LiftQ LiftState+getState = LiftQ $ mapStateT (\x -> do ((),s) <- x; return (s,s))+                             (return ())++-- | Set the state of the monad.+setState :: LiftState -> LiftQ ()+setState s = LiftQ $ mapStateT (\_ -> return ((),s))+                               ((return ()) :: LiftQState ())++-- * Various functions to go back and forth between monads.++-- | From 'ErrMsgQ' to 'LiftQ'.+embedErrMsgQ :: ErrMsgQ a -> LiftQ a+embedErrMsgQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- q; return (y,s))+                                   (return ())++-- | From 'TH.Q' to 'LiftQ'.+embedQ :: TH.Q a -> LiftQ a+embedQ q = LiftQ $ mapStateT (\x -> do ((),s) <- x; y <- Err.embedQ q; return (y,s))+                             (return ())++-- | Get 'TH.Q' out of 'LiftQ'+extractQ :: String -> LiftQ a -> TH.Q a+extractQ s (LiftQ x) = Err.extractQ s $ evalStateT x emptyLiftState++-- | Set an error message.+errorMsg :: String -> LiftQ a+errorMsg s = embedErrMsgQ $ Err.errorMsg s+++-- * Working with variable names.++-- | Increase the number of binds of a variable name.+addToBoundVar :: Name -> LiftQ ()+addToBoundVar n = do+   s <- getState+   let new_value = +         if (Map.member n $ boundVar s)+         then 1 + ((boundVar s) Map.! n) +         else 0+   setState $ s { boundVar = Map.insert n new_value $ boundVar s }++-- | Decrease the number of binds of a variable name.+removeFromBoundVar :: Name -> LiftQ ()+removeFromBoundVar n = do+   s <- getState+   if (not $ Map.member n $ boundVar s) +     then errorMsg ((show n) ++ " is not a bound value")+     else let old_value = (boundVar s) Map.! n in+        if old_value == 0+        then setState $ s { boundVar = Map.delete n $ boundVar s }+        else setState $ s { boundVar = Map.insert n (old_value - 1) $ boundVar s }++-- | Run a computation with a particular name being bound.+withBoundVar :: Name -> LiftQ a -> LiftQ a+withBoundVar n comp = do+  addToBoundVar n+  a <- comp+  removeFromBoundVar n+  return a++-- | Run a computation with a particular list of names being bound.+withBoundVars :: [Name] -> LiftQ a -> LiftQ a+withBoundVars names comp = foldl (flip withBoundVar) comp names++-- | Say whether a given name is bound.+isBoundVar :: Name -> LiftQ Bool+isBoundVar n = do+  s <- getState+  return $ Map.member n $ boundVar s+++-- * Other operations on monad state.++-- | Set the template prefix.+setPrefix :: String -> LiftQ ()+setPrefix p = do+   s <- getState+   case (prefix s) of+      Just p' -> errorMsg ("cannot set the prefix to " ++ +                           (show p) ++ +                           ": prefix already defined as " ++ +                           p') +      Nothing -> setState $ s { prefix = Just p }+++-- | Get the template prefix.+getPrefix :: LiftQ String+getPrefix = do+   s <- getState+   case (prefix s) of+      Nothing -> errorMsg "undefined prefix"+      Just p -> return p++-- | Set the monad name.+setMonadName :: String -> LiftQ ()+setMonadName m = do+   s <- getState+   case (monadName s) of+      Just m' -> errorMsg ("cannot set the monad to " ++ +                           (show m) ++ +                           ": monad already defined as " ++ +                           m') +      Nothing -> setState $ s { monadName = Just m }++-- | Get the monad name.+getMonadName :: LiftQ String+getMonadName = do+   s <- getState+   case (monadName s) of+      Nothing -> errorMsg "undefined monad"+      Just m -> return m+++++-- * Functions dealing with variable names.++-- | Make a name out of a string.+mkName :: String -> Name+mkName s = TH.mkName s++-- | Make a name out of a string, monadic-style.+newName :: String -> LiftQ Name+newName st = embedQ $ TH.newName st+++++-- | Make any string into a string containing only @[0-9a-zA-Z_.]@.+-- For example, it replaces any occurrence of @\"+\"@ with+-- @\"symb_plus_\"@.+sanitizeString :: String -> String+sanitizeString name = +  List.concat (List.map +               (\c -> +                 Map.findWithDefault c c +                     (Map.map (\s -> "symb_" ++ s ++ "_")+                              unicodeNames))+               (List.map (\x -> [x]) name))+   where+   unicodeNames :: Map.Map String String+   unicodeNames = Map.fromList+    [("!","exclamation"),+     ("\"","doublequote"),+     ("#","sharp"),+     ("$","dollar"),+     ("%","percent"),+     ("&","ampersand"),+     ("'","quote"),+     ("(","oparent"),+     (")","cparent"),+     ("*","star"),+     ("+","plus"),+     (",","comma"),+     ("-","minus"),+     -- we keep dots+     ("/","slash"),+     (":","colon"),+     (";","semicolon"),+     ("<","oangle"),+     ("=","equal"),+     (">","cangle"),+     ("?","question"),+     ("@","at"),+     ("[","obracket"),+     ("\\","backslash"),+     ("]","cbracket"),+     ("^","caret"),+     -- we keep _+     ("`","graveaccent"),+     ("{","obrace"),+     ("|","vbar"),+     ("}","cbrace"),+     ("~","tilde")]+++-- | Take a string and make it into a valid Haskell name starting with+-- @\"template_\"@.+templateString :: String -> LiftQ String+templateString s = do+  p <- getPrefix+  return (p ++ (sanitizeString s))++-- | Look for the corresponding "template" name.+lookForTemplate :: Name -> LiftQ (Maybe Name)+lookForTemplate n = do+  t_string <- templateString $ TH.nameBase n+  embedQ $ TH.lookupValueName t_string++-- | Make a the template version of a given name.+makeTemplateName :: Name -> LiftQ Name+makeTemplateName n = do+  t_string <- templateString $ TH.nameBase n+  return $ TH.mkName t_string+++-- * Other functions.++-- | Print on the terminal a monadic, printable object.+prettyPrint :: TH.Ppr a => LiftQ a -> IO ()+prettyPrint x = (TH.runQ $ extractQ "prettyPrint: " x) >>= (putStrLn . TH.pprint)+++-- | Project patterns out of a clause.+clauseGetPats :: TH.Clause -> [TH.Pat]+clauseGetPats (TH.Clause pats _ _) = pats+++-- | Check that the list is a non-empty repetition of the same+-- element.+equalNEListElts :: Eq a => [a] -> Bool+equalNEListElts [] = True+equalNEListElts (h:list) = foldl (&&) True $ map (== h) list+++-- | Returns the length of the patterns in a list of clauses. Throw an+-- error if the patterns do not have all the same size.+clausesLengthPats :: [TH.Clause] -> LiftQ Int+clausesLengthPats [] = errorMsg "empty clause"+clausesLengthPats clauses +  | (equalNEListElts $ map length $ map clauseGetPats clauses) = +    return $ length $ clauseGetPats $ head clauses    +clausesLengthPats _ = errorMsg "patterns in clause are not of equal size"+
+ Quipper/Utils/Template/Lifting.hs view
@@ -0,0 +1,630 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}++-- | This module describes stripped-down Template Haskell abstract+-- syntax trees (ASTs) for a subset of Haskell.++module Quipper.Utils.Template.Lifting where++import Control.Monad.State++import qualified Data.Map as Map+import Data.Map (Map)++import qualified Data.List as List++import Data.Maybe (catMaybes)++import qualified Data.Set as Set+import Data.Set (Set)++import qualified Language.Haskell.TH as TH+import Language.Haskell.TH (Name)++-- Get the monad to build the lifting.+import Quipper.Utils.Template.LiftQ+++-- * Abstract syntax trees of a simplified language++-- | There are no \"guarded bodies\". One net effect is to make the+-- \"where\" construct equivalent to a simple \"let\".+type Body = Exp++-- | Literals.+data Lit =+   CharL Char          -- ^ Characters.+ | IntegerL Integer    -- ^ Integers.+ | RationalL Rational  -- ^ Reals.+   deriving (Show)+++-- | Patterns.+data Pat = +    LitP Lit          -- ^ Literal.+  | VarP Name         -- ^ Variable name.+  | TupP [Pat]        -- ^ Tuple.+  | WildP             -- ^ Wildchar.+  | ListP [Pat]       -- ^ List as @[...]@.+  | ConP Name [Pat]   -- ^ Cons: @h:t@.+    deriving (Show)++-- | Match term construct.+data Match =+  Match Pat Body+  deriving (Show)++-- | First-level declaration.+data Dec = +  ValD Name Body+  deriving (Show)++-- | Expression+data Exp = +    VarE Name         -- ^ Variable name.+  | ConE Name         -- ^ Constant name.+  | LitE Lit          -- ^ Literal.+  | AppE Exp Exp      -- ^ Application.+  | LamE Name Exp     -- ^ Lambda abstraction.+  | TupE [Exp]        -- ^ Tuple.+  | CondE Exp Exp Exp -- ^ If-then-else.+  | LetE [Dec] Exp    -- ^ Let-construct.+  | CaseE Exp [Match] -- ^ Case distinction+  | ListE [Exp]       -- ^ List: @[...]@.+  | ReturnE           -- ^ hardcoded constant for @'return'@.+  | MAppE             -- ^ hardcoded constant for @'>>='@.+  deriving (Show)+++-- $ Syntactic sugar to recover do-notation.++-- | Datatype to encode the notation @x <- expr@.+data BindS = BindS Name Exp++-- | A simple @do@: list of monadic @let@ followed by a computation.+doE :: [BindS] -> Exp -> Exp +doE binds exp = foldr doOne exp binds+  where+    doOne :: BindS -> Exp -> Exp+    doOne (BindS n value) computation = AppE (AppE MAppE value) (LamE n computation)+++-- * Variable substitution+    ++-- | Get the set of variable names in a pattern.+getVarNames :: Pat -> Set Name+getVarNames (VarP n) = Set.singleton n+getVarNames (TupP pats) = Set.unions $ map getVarNames pats+getVarNames (ListP pats) = Set.unions $ map getVarNames pats+getVarNames _ = Set.empty++-- | Substitution in a @'Match'@.+substMatch :: Name -> Exp -> Match -> Match+substMatch n s (Match p e) | Set.member n (getVarNames p) = Match p e+                           | True                         = Match p (substExp n s e)+++-- | Substitution in a @'Dec'@.+substDec :: Name -> Exp -> Dec -> Dec+substDec n s (ValD m e) | n == m = ValD m e+                        | True   = ValD m (substExp n s e)++-- | Substitution in an @'Exp'@.+substExp :: Name -> Exp -> Exp -> Exp+substExp n s (VarE m) | n == m = s+                      | True   = (VarE m)+substExp n s (ConE m) = ConE m+substExp n s (LitE l) = LitE l+substExp n s (AppE e1 e2) = AppE (substExp n s e1) (substExp n s e2)+substExp n s (LamE m exp) | n == m = LamE m exp+                          | True   = LamE m $ substExp n s exp+substExp n s (TupE exps) = TupE $ map (substExp n s) exps+substExp n s (CondE e1 e2 e3) = CondE (substExp n s e1) (substExp n s e2) (substExp n s e3)+substExp n s (LetE decs exp) = LetE (map (substDec n s) decs) (substExp n s exp)+substExp n s (CaseE exp matches) = CaseE (substExp n s exp) $ map (substMatch n s) matches+substExp n s (ListE exps) = ListE $ map (substExp n s) exps+substExp n s ReturnE = ReturnE+substExp n s MAppE   = MAppE+++-- | Substitution of several variables in one go.+mapSubstExp :: (Map Name Exp) -> Exp -> Exp+mapSubstExp map exp = List.foldl (\exp (x,y) -> substExp x y exp) exp $ Map.toList map+++-- * Downgrading Template Haskell to AST++-- | Downgrading TH literals to @'Exp'@.+litTHtoExpAST :: TH.Lit -> LiftQ Exp+litTHtoExpAST (TH.CharL c) = return $ LitE $ CharL c+litTHtoExpAST (TH.StringL s) = return $ ListE $ map (LitE . CharL) s+litTHtoExpAST (TH.IntegerL i) = return $ LitE $ IntegerL i      +litTHtoExpAST (TH.RationalL r) = return $ LitE $ RationalL r+litTHtoExpAST x = errorMsg ("lifting not handled for " ++ (show x))++-- | Downgrading TH literals to @'Pat'@.+litTHtoPatAST :: TH.Lit -> LiftQ Pat+litTHtoPatAST (TH.CharL c) = return $ LitP $ CharL c+litTHtoPatAST (TH.StringL s) = return $ ListP $ map (LitP . CharL) s+litTHtoPatAST (TH.IntegerL i) = return $ LitP $ IntegerL i      +litTHtoPatAST (TH.RationalL r) = return $ LitP $ RationalL r+litTHtoPatAST x = errorMsg ("lifting not handled for " ++ (show x))+++-- | Take a list of patterns coming from a @where@ section and output+-- a list of fresh names for normalized @let@s. Also gives a mapping+-- for substituting inside the expressions. Assume all names in the+-- list of patterns are distinct.+normalizePatInExp :: [Pat] -> LiftQ ([Name], Map Name Exp)+normalizePatInExp pats = do+  fresh_names <- mapM newName $ replicate (length pats) "normalizePat"+  let sets_of_old_names = List.map getVarNames pats+  let old_to_fresh old_name =+        List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) fresh_names+  let old_to_pat old_name =+        List.lookup True $ zip (List.map (Set.member old_name) sets_of_old_names) pats+  let list_of_old_names = List.concat $ List.map Set.toList sets_of_old_names+  let maybe_list_map = mapM+            (\x -> do+                fresh <- old_to_fresh x+                pat <-   old_to_pat x+                return (x, CaseE (VarE fresh) [Match pat (VarE x)]))+            list_of_old_names+  case maybe_list_map of+    Nothing -> errorMsg "error in patterns..."+    Just l -> return $ (fresh_names, Map.fromList l)+  ++-- | Build a @let@-expression out of pieces.+whereToLet :: Exp -> [(Pat,Exp)] -> LiftQ Exp+whereToLet exp [] = return exp+whereToLet exp list = do+  (fresh_names, pmap) <- normalizePatInExp $ map fst list+  let decs'' = map (uncurry ValD) $ zip fresh_names $ map snd list+  let decs' = map (\(ValD n e) -> ValD n $ mapSubstExp pmap e) decs''+  return $ +    LetE decs' $ +         CaseE (TupE $ map VarE fresh_names) [Match (TupP $ map fst list) exp]++-- | Build a @'Match'@ out of a TH clause+clauseToMatch :: TH.Clause -> LiftQ Match+clauseToMatch (TH.Clause pats body decs) = do+  pats' <- mapM patTHtoAST pats +  body' <- bodyTHtoAST body +  decs' <- mapM decTHtoAST decs+  exp <- whereToLet body' decs'+  return $ Match (TupP pats') exp++-- | From a list of TH clauses, make a case-distinction wrapped in a+-- lambda abstraction.+clausesToLambda :: [TH.Clause] -> LiftQ Exp+clausesToLambda clauses = do+  -- get length of patterns+  pats_length <- clausesLengthPats clauses+  -- make a list of new names from the function name+  fresh_names <- mapM newName $ replicate pats_length "x"+  -- make matches out of the clauses.+  matches <- mapM clauseToMatch clauses+  -- return a simple function with a case-distinction+  return $ foldr LamE +                 (CaseE (TupE $ map VarE fresh_names) matches)+                 fresh_names+++-- | Downgrade expressions.+expTHtoAST :: TH.Exp -> LiftQ Exp++expTHtoAST (TH.VarE v) = return $ VarE v+expTHtoAST (TH.ConE n) = return $ ConE n+expTHtoAST (TH.LitE l) = litTHtoExpAST l++expTHtoAST (TH.AppE e1 e2) = do +  e1' <- expTHtoAST e1+  e2' <- expTHtoAST e2+  return $ AppE e1' e2'++expTHtoAST (TH.InfixE (Just e1) e2 (Just e3)) = do+  e1' <- expTHtoAST e1+  e2' <- expTHtoAST e2+  e3' <- expTHtoAST e3+  return $ AppE (AppE e2' e1') e3'++expTHtoAST (TH.InfixE Nothing e2 (Just e3)) = do+  e2' <- expTHtoAST e2+  e3' <- expTHtoAST e3+  n <- newName "x"+  return $ LamE n $ AppE (AppE e2' (VarE n)) e3'++expTHtoAST (TH.InfixE (Just e1) e2 Nothing) = do+  e1' <- expTHtoAST e1+  e2' <- expTHtoAST e2+  return $ AppE e2' e1'++expTHtoAST (TH.InfixE Nothing e2 Nothing) = do+  e2' <- expTHtoAST e2+  return e2'++expTHtoAST (TH.LamE pats exp) = +  clausesToLambda [TH.Clause pats (TH.NormalB exp) []]++expTHtoAST (TH.TupE exps) = do+  exps' <- mapM expTHtoAST exps+  return (TupE exps')++expTHtoAST (TH.CondE e1 e2 e3) = do+  e1' <- expTHtoAST e1+  e2' <- expTHtoAST e2+  e3' <- expTHtoAST e3+  return $ CondE e1' e2' e3'++expTHtoAST (TH.LetE decs exp) = do+  decs' <- mapM decTHtoAST decs+  exp' <- expTHtoAST exp+  whereToLet exp' decs' ++expTHtoAST (TH.CaseE exp matches) = do+  exp' <- expTHtoAST exp+  matches' <- mapM matchTHtoAST matches+  return $ CaseE exp' matches'+  +expTHtoAST (TH.ListE exps) = do+  exps' <- mapM expTHtoAST exps+  return $ ListE exps'+  ++expTHtoAST (TH.SigE e _) = expTHtoAST e++expTHtoAST x = errorMsg ("lifting not handled for " ++ (show x))+++-- | Downgrade match-constructs.+matchTHtoAST :: TH.Match -> LiftQ Match+matchTHtoAST (TH.Match pat body decs) = do+   pat' <- patTHtoAST pat+   body' <- bodyTHtoAST body+   decs' <- mapM decTHtoAST decs+   exp <- whereToLet body' decs'+   return $ Match pat' exp++-- | Downgrade bodies into expressions.+bodyTHtoAST :: TH.Body -> LiftQ Exp+bodyTHtoAST (TH.NormalB exp) = expTHtoAST exp+bodyTHtoAST (TH.GuardedB x) = errorMsg ("guarded body not allowed in lifting: " ++ (show x))++-- | Downgrade patterns.+patTHtoAST :: TH.Pat -> LiftQ Pat+patTHtoAST (TH.LitP l) = litTHtoPatAST l+patTHtoAST (TH.VarP n) = return $ VarP n+patTHtoAST (TH.TupP pats) = do pats' <- mapM patTHtoAST pats; return $ TupP pats'+patTHtoAST (TH.WildP) = return WildP+patTHtoAST (TH.ListP pats) = do pats' <- mapM patTHtoAST pats; return $ ListP pats'+patTHtoAST (TH.ConP n pats) = do pats' <- mapM patTHtoAST pats; return $ ConP n pats'+patTHtoAST (TH.InfixP p1 n p2) = do+  p1' <- patTHtoAST p1+  p2' <- patTHtoAST p2+  return $ ConP n [p1',p2']+patTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x))+++++-- | Downgrade first-level declarations.+firstLevelDecTHtoAST :: TH.Dec -> Maybe (LiftQ Dec)+firstLevelDecTHtoAST (TH.FunD name clauses) = Just $ do+  exp <- clausesToLambda clauses+  name' <- makeTemplateName name+  return $ ValD name' $ substExp name (VarE name') exp++firstLevelDecTHtoAST (TH.ValD (TH.VarP name) body decs) = Just $ do+  body' <- bodyTHtoAST body +  decs' <- mapM decTHtoAST decs+  exp <- whereToLet body' decs' +  name' <- makeTemplateName name+  return $ ValD name' $ substExp name (VarE name') exp++firstLevelDecTHtoAST (TH.ValD _ _ _) = Just $+  errorMsg ("only variables and functions can be lifted as first-level declarations")++firstLevelDecTHtoAST (TH.SigD _ _) = Nothing++firstLevelDecTHtoAST x = Just $ errorMsg ("non-implemented lifting: " ++ (show x))+++-- | Downgrade any declarations (including the ones in @where@-constructs).+decTHtoAST :: TH.Dec -> LiftQ (Pat,Exp)++decTHtoAST (TH.FunD name clauses) = do+  exp <- clausesToLambda clauses+  return $ (VarP name, exp)++decTHtoAST (TH.ValD pat body decs) = do+  pat' <- patTHtoAST pat+  body' <- bodyTHtoAST body +  decs' <- mapM decTHtoAST decs+  exp <- whereToLet body' decs'+  return $ (pat', exp)++decTHtoAST x = errorMsg ("non-implemented lifting: " ++ (show x))+++++-- * Upgrade AST to Template Haskell++-- | Abstract syntax tree of the type of the function 'return'.+typReturnE :: LiftQ TH.Type+typReturnE = do+  m_string <- getMonadName+  let m = TH.conT (mkName m_string)+  embedQ [t| forall x. x -> $(m) x |]++-- | Abstract syntax tree of the type of the function '>>='.+typMAppE :: LiftQ TH.Type+typMAppE = do+  m_string <- getMonadName+  let m = TH.conT (mkName m_string)+  embedQ [t| forall x y. $(m) x -> (x -> $(m) y) -> $(m) y |]+++-- | Upgrade literals+litASTtoTH :: Lit -> TH.Lit+litASTtoTH (CharL c) = TH.CharL c+litASTtoTH (IntegerL i) = TH.IntegerL i+litASTtoTH (RationalL r) = TH.RationalL r++-- | Upgrade patterns.+patASTtoTH :: Pat -> TH.Pat+patASTtoTH (LitP l)      = TH.LitP $ litASTtoTH l+patASTtoTH (VarP n)      = TH.VarP n+patASTtoTH (TupP pats)   = TH.TupP $ map patASTtoTH pats+patASTtoTH WildP         = TH.WildP+patASTtoTH (ListP pats)  = TH.ListP $ map patASTtoTH pats+patASTtoTH (ConP n pats) = TH.ConP n $ map patASTtoTH pats++-- | Upgrade match-constructs.+matchASTtoTH :: Match -> LiftQ TH.Match+matchASTtoTH (Match p b) = do+  exp <- expASTtoTH b+  return $ TH.Match (patASTtoTH p) (TH.NormalB exp) []++-- | Upgrade declarations.+decASTtoTH :: Dec -> LiftQ TH.Dec++decASTtoTH (ValD n b) = do+  exp <- expASTtoTH b+  return $ TH.ValD (TH.VarP n) (TH.NormalB exp) []+++-- | Upgrade expressions.+expASTtoTH :: Exp -> LiftQ TH.Exp++expASTtoTH (VarE n) = return $ TH.VarE n+expASTtoTH (ConE n) = return $ TH.ConE n+expASTtoTH (LitE l) = return $ TH.LitE $ litASTtoTH l++expASTtoTH (AppE e1 e2) = do+  e1' <- expASTtoTH e1+  e2' <- expASTtoTH e2+  return $ TH.AppE e1' e2'++expASTtoTH (LamE n e) = do+  e' <- expASTtoTH e+  return $ TH.LamE [TH.VarP n] e'++expASTtoTH (TupE exps) = do+  exps' <- mapM expASTtoTH exps+  return $ TH.TupE exps'++expASTtoTH (CondE e1 e2 e3) = do+  e1' <- expASTtoTH e1+  e2' <- expASTtoTH e2+  e3' <- expASTtoTH e3+  return $ TH.CondE e1' e2' e3'++expASTtoTH (LetE decs e) = do+  decs' <- mapM decASTtoTH decs+  e' <- expASTtoTH e+  return $ TH.LetE decs' e'++expASTtoTH (CaseE e matches) = do+  e' <- expASTtoTH e+  m' <- mapM matchASTtoTH matches+  return $ TH.CaseE e' m'++expASTtoTH (ListE exps) = do+  exps' <- mapM expASTtoTH exps+  return $ TH.ListE exps'++expASTtoTH ReturnE = do+  t <- typReturnE+  maybe_r <- embedQ $ TH.lookupValueName "return"+  case maybe_r of+    Just r -> return $ TH.SigE (TH.VarE r) t+    Nothing -> errorMsg "\'return\' undefined"+  +expASTtoTH MAppE = do+  t <- typMAppE+  maybe_a <- embedQ $ TH.lookupValueName ">>="+  case maybe_a of+    Just a -> return $ TH.SigE (TH.VarE a) t+    Nothing -> errorMsg "\'>>=\' undefined"+++++-- * Lifting AST terms (into AST terms)++-- | Variable referring to the lifting function for integers.+liftIntegerL :: Exp+liftIntegerL = VarE $ mkName "template_integer"++-- | Variable referring to the lifting function for reals.+liftRationalL :: Exp+liftRationalL = VarE $ mkName "template_rational"++-- | Lifting literals.+liftLitAST :: Lit -> LiftQ Exp+liftLitAST (CharL c) = return (AppE ReturnE (LitE $ CharL c))+liftLitAST (IntegerL i) = return $ AppE liftIntegerL (LitE $ IntegerL i)+liftLitAST (RationalL r) =  return $ AppE liftRationalL (LitE $ RationalL r)++-- | Lifting patterns.+liftPatAST :: Pat -> LiftQ Pat+liftPatAST pat = return pat++-- | Lifting match-constructs.+liftMatchAST :: Match -> LiftQ Match+liftMatchAST (Match pat exp) = do+  exp' <- liftExpAST exp+  return $ Match pat exp' ++-- | Lifting declarations.+liftDecAST :: Dec -> LiftQ Dec+liftDecAST (ValD name exp) = do+  exp' <- liftExpAST exp+  return $ ValD name exp'++-- | Lifting first-level declarations.+liftFirstLevelDecAST :: Dec -> LiftQ Dec+liftFirstLevelDecAST (ValD name exp) = withBoundVar name $ do+  exp' <- liftExpAST exp+  return $ ValD name exp'++-- | Lifting expressions.+liftExpAST :: Exp -> LiftQ Exp++liftExpAST (VarE x) = do+  template_name <- lookForTemplate x+  case template_name of+    Nothing -> do+      b <- isBoundVar x+      if b +        then return $ VarE x+        else return $ AppE ReturnE $ VarE x+    Just t  -> return $ VarE t++liftExpAST (ConE n) = do+  template_name <- lookForTemplate n+  case template_name of+    Nothing -> do +      t <- templateString $ TH.nameBase n+      errorMsg ("variable " ++ t ++ " undefined")+    Just t  -> return $ VarE t++liftExpAST (LitE l) = liftLitAST l++liftExpAST (AppE e1 e2) = do+  e1' <- liftExpAST e1+  e2' <- liftExpAST e2+  n1 <- newName "app1"+  n2 <- newName "app2"+  return $ doE [BindS n1 e1', BindS n2 e2'] $ AppE (VarE n1) (VarE n2)++liftExpAST (LamE n exp) = do+  exp' <- liftExpAST exp+  return $ AppE ReturnE $ LamE n exp'++liftExpAST (TupE exps) = do+  exps' <- mapM liftExpAST exps+  fresh_names <- mapM newName $ replicate (length exps) "tupe"+  return $ +    doE (map (uncurry BindS) $ zip fresh_names exps')+        (AppE ReturnE $ TupE $ map VarE fresh_names)++liftExpAST (CondE e1 e2 e3) = do+  e1' <- liftExpAST e1+  e2' <- liftExpAST e2+  e3' <- liftExpAST e3+  return $ AppE (AppE (AppE (VarE (mkName "template_if")) (e1')) (e2')) (e3')+++liftExpAST (LetE decs exp) = +  let existing_names = map (\(ValD n _) -> n) decs+  in+   withBoundVars existing_names $ do+     decs' <- mapM liftDecAST decs+     exp' <- liftExpAST exp+     return $ +       LetE decs' exp'+++liftExpAST (CaseE exp matches) = do+  exp' <- liftExpAST exp+  matches' <- mapM liftMatchAST matches+  fresh_name <- newName "varfromcase"+  return $ doE [BindS fresh_name exp']+               $ CaseE (VarE fresh_name) matches'+  +liftExpAST (ListE exps) = do+  exps' <- mapM liftExpAST exps+  fresh_names <- mapM newName $ replicate (length exps) "varfromlist"+  return $ +    doE (map (uncurry BindS) $ zip fresh_names exps')+       $ AppE ReturnE $ ListE $ map VarE fresh_names++-- These two are not supposed to be there!+liftExpAST ReturnE = undefined+liftExpAST MAppE   = undefined+++-- | make a declaration into a template-declaration (by renaming with+-- the template-prefix).+makeDecTemplate :: Dec -> LiftQ Dec+makeDecTemplate (ValD name exp) = do+  name' <- makeTemplateName name+  return $ ValD name' $ substExp name (VarE name') exp+++-- * Various pretty printing functions+++-- | pretty-printing Template Haskell declarations.+prettyPrintAST :: TH.Q [TH.Dec] -> IO ()+prettyPrintAST x = prettyPrint $ do+  x' <- embedQ x+  y <- sequence $ catMaybes $ map firstLevelDecTHtoAST x'+  mapM decASTtoTH y++-- | Pretty-printing Template Haskell expressions.+prettyPrintLiftExpTH :: TH.Q (TH.Exp) -> IO ()+prettyPrintLiftExpTH x = prettyPrint $ do+  x' <- embedQ x+  y <- expTHtoAST x'+  z <- liftExpAST y+  expASTtoTH z++-- | Pretty-printing expressions.+prettyPrintLiftExpAST :: LiftQ (Exp) -> IO ()+prettyPrintLiftExpAST x = prettyPrint $ do+  z <- x+  z' <- liftExpAST z+  expASTtoTH z'+++-- * The main lifting functions.+++-- | Lift a list of declarations. The first argument is the name of+-- the monad to lift into.+decToMonad :: String -> TH.Q [TH.Dec] -> TH.Q [TH.Dec]+decToMonad s x = extractQ "decToMonad: " $ do+  setMonadName s+  setPrefix "template_"+  dec <- embedQ x+  decAST <- sequence $ catMaybes $ map firstLevelDecTHtoAST dec+  liftedAST <- mapM liftFirstLevelDecAST decAST+  mapM decASTtoTH liftedAST++-- | Lift an expression. The first argument is the name of the monad+-- to lift into.+expToMonad :: String -> TH.Q TH.Exp -> TH.Q TH.Exp+expToMonad s x = extractQ "expToMonad: " $ do+  setMonadName s+  setPrefix "template_"+  dec <- embedQ x+  decAST <- expTHtoAST dec+  liftedAST <- liftExpAST decAST+  expASTtoTH liftedAST++
+ Quipper/Utils/Tuple.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}++-- | This module provides isomorphisms between /n/-tuples and repeated+-- pairs. It is used to be able to write type classes for /n/-tuples+-- more generically. Essentially we want to be able to write code for+-- 17-tuples once and for all, rather than once for each type class we+-- define. Ideally there would be a standard Haskell library for this.+--+-- Two type classes are provided: 'Tuple', and 'TupleOrUnary'.+-- 'Tuple' is recommended for most uses.++module Quipper.Utils.Tuple where++-- I only want to write code involving explicit 7-tuples once in my life++-- | This type class relates types of the form @t = (a,b,c,d)@ (“tupled form”) to+-- types of the form @s = (a,(b,(c,(d,()))))@ (“standard form”), and provides a way to+-- convert between the two representations.+--+-- The tupled form can always be deduced from the standard form.++class TupleOrUnary t s | s -> t where+  -- | For example, maps @(a,(b,(c,(d,()))))@ to @(a,b,c,d)@.+  weak_tuple :: s -> t+  -- | For example, maps @(a,b,c,d)@ to @(a,(b,(c,(d,()))))@.+  weak_untuple :: t -> s++instance TupleOrUnary () () where+  weak_tuple () = ()+  weak_untuple () = ()++instance TupleOrUnary a (a,()) where+  weak_tuple (a,()) = a+  weak_untuple a = (a,())++instance TupleOrUnary (a,b) (a,(b,())) where+  weak_tuple (a,(b,())) = (a,b)+  weak_untuple (a,b) = (a,(b,()))+  +instance TupleOrUnary (a,b,c) (a,(b,(c,()))) where+  weak_tuple (a,(b,(c,()))) = (a,b,c)+  weak_untuple (a,b,c) = (a,(b,(c,())))+  +instance TupleOrUnary (a,b,c,d) (a,(b,(c,(d,())))) where+    weak_tuple (a,(b,(c,(d,())))) = (a,b,c,d)+    weak_untuple (a,b,c,d) = (a,(b,(c,(d,()))))++instance TupleOrUnary (a,b,c,d,e) (a,(b,(c,(d,(e,()))))) where+    weak_tuple (a,(b,(c,(d,(e,()))))) = (a,b,c,d,e)+    weak_untuple (a,b,c,d,e) = (a,(b,(c,(d,(e,())))))++instance TupleOrUnary (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,())))))) where+    weak_tuple (a,(b,(c,(d,(e,(f,())))))) = (a,b,c,d,e,f)+    weak_untuple (a,b,c,d,e,f) = (a,(b,(c,(d,(e,(f,()))))))++instance TupleOrUnary (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,()))))))) where+    weak_tuple (a,(b,(c,(d,(e,(f,(g,()))))))) = (a,b,c,d,e,f,g)+    weak_untuple (a,b,c,d,e,f,g) = (a,(b,(c,(d,(e,(f,(g,())))))))++instance TupleOrUnary (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,())))))))) where+    weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,())))))))) = (a,b,c,d,e,f,g,h)+    weak_untuple (a,b,c,d,e,f,g,h) = (a,(b,(c,(d,(e,(f,(g,(h,()))))))))++instance TupleOrUnary (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) where+    weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,()))))))))) = (a,b,c,d,e,f,g,h,i)+    weak_untuple (a,b,c,d,e,f,g,h,i) = (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))++instance TupleOrUnary (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) where+    weak_tuple (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,())))))))))) = (a,b,c,d,e,f,g,h,i,j)+    weak_untuple (a,b,c,d,e,f,g,h,i,j) = (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))++-- | In almost all instances, the standard form can also be deduced from the tupled form;  +-- the only exception is the unary case.  The 'Tuple' class includes no new methods, +-- adding just this functional dependency.+--+-- While the methods of 'Tuple' are always copied from those of 'TupleOrUnary', +-- they are renamed, so that use of these methods tells the type checker it+-- can use the extra functional dependency.+class (TupleOrUnary t s) => Tuple t s | s -> t, t -> s where+  tuple :: s -> t+  tuple = weak_tuple++  untuple :: t -> s+  untuple = weak_untuple+  +instance Tuple () ()+instance Tuple (a,b) (a,(b,()))+instance Tuple (a,b,c) (a,(b,(c,())))+instance Tuple (a,b,c,d) (a,(b,(c,(d,()))))+instance Tuple (a,b,c,d,e) (a,(b,(c,(d,(e,())))))+instance Tuple (a,b,c,d,e,f) (a,(b,(c,(d,(e,(f,()))))))+instance Tuple (a,b,c,d,e,f,g) (a,(b,(c,(d,(e,(f,(g,())))))))+instance Tuple (a,b,c,d,e,f,g,h) (a,(b,(c,(d,(e,(f,(g,(h,()))))))))+instance Tuple (a,b,c,d,e,f,g,h,i) (a,(b,(c,(d,(e,(f,(g,(h,(i,())))))))))+instance Tuple (a,b,c,d,e,f,g,h,i,j) (a,(b,(c,(d,(e,(f,(g,(h,(i,(j,()))))))))))
+ Quipper/Utils/Typeable.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}++{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++#if __GLASGOW_HASKELL__ < 780+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+#endif++-- | The standard Haskell module "Data.Typeable" only provides+-- instances for tuples up to length 7. Since we need larger tuples,+-- we provide the missing instances here. +-- +-- Unfortunately, there is no easy way to do this portably; once the+-- instances get added to "Data.Typeable", we must remove them here.+-- +-- Please note: type instances do not generate documentation, so there+-- is nothing here to document. Please click on \"Source\" above to+-- see the source code.++module Quipper.Utils.Typeable where++import Data.Typeable++#if __GLASGOW_HASKELL__ >= 708++deriving instance Typeable (,,,,,,,)+deriving instance Typeable (,,,,,,,,)+deriving instance Typeable (,,,,,,,,,)++#else++-- Note: we use scoped type variables so that the typerep is constant;+-- it can be computed at compile time. Same trick as in+-- Data.Typeable.Internal.+instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h) => Typeable (a,b,c,d,e,f,g,h) where+  typeOf _ = typerep+    where+      typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h) ]++instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i) => Typeable (a,b,c,d,e,f,g,h,i) where+  typeOf _ = typerep+    where+      typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i) ]++instance (Typeable a, Typeable b, Typeable c, Typeable d, Typeable e, Typeable f, Typeable g, Typeable h, Typeable i, Typeable j) => Typeable (a,b,c,d,e,f,g,h,i,j) where+  typeOf _ = typerep+    where+      typerep = mkTyCon3 "GHC" "Tuple" "(,,,,,,,,,)" `mkTyConApp` [ typeOf (undefined :: a), typeOf (undefined :: b), typeOf (undefined :: c), typeOf (undefined :: d), typeOf (undefined :: e), typeOf (undefined :: f), typeOf (undefined :: g), typeOf (undefined :: h), typeOf (undefined :: i), typeOf (undefined :: j) ]++#endif
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Superdoc+main = superdocMain
+ quipper-utils.cabal view
@@ -0,0 +1,94 @@+-- The name of the package.+name:                quipper-utils++-- The package version.  See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary:      +-+------- breaking API changes+--                   | | +----- non-breaking API additions+--                   | | | +--- code changes with no API change+version:             0.9.0.0++-- A short (one-line) description of the package.+synopsis:            Utility libraries for Quipper.++-- A longer description of the package.+description:         ++ This package provides some utility libraries for Quipper, the+ embedded functional programming language for quantum computing. These+ libraries are used by Quipper, but do not depend on it. They provide+ general-purpose functionality that could in principle be used by+ other programs, but are are not sufficiently interesting to warrant+ their own packages.++-- URL for the project homepage or repository.+homepage:            http://www.mathstat.dal.ca/~selinger/quipper/++-- The license under which the package is released.+license:             BSD3++-- The file containing the license text.+license-file:        COPYRIGHT++-- The package author(s).+author:              Alexander S. Green, Peter LeFanu Lumsdaine,+                     Neil J. Ross, Peter Selinger, Benoît Valiron++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer:          selinger@mathstat.dal.ca++-- A copyright notice.+copyright:           Copyright (c) 2011-2019. All rights reserved.++-- A classification category for future use by the package catalogue+-- Hackage. These categories have not yet been specified, but the+-- upper levels of the module hierarchy make a good start.+category:            Quipper++-- The type of build used by this package.+build-type:          Custom++-- Constraint on the version of Cabal needed to build this package.+cabal-version:       >= 1.8++-- A list of additional files to be included in source distributions+-- built with setup sdist.+extra-source-files:  ChangeLog++library+  -- Modules exported by the library.+  exposed-modules:   Quipper.Utils.Auxiliary,+                     Quipper.Utils.CommandLine,+                     Quipper.Utils.PortableSignals,+                     Quipper.Utils.Preview,+                     Quipper.Utils.RandomSource,+                     Quipper.Utils.Sampling,+                     Quipper.Utils.Stabilizers.Clifford,+                     Quipper.Utils.Stabilizers.Pauli,+                     Quipper.Utils.Template,+                     Quipper.Utils.Tuple,+                     Quipper.Utils.Typeable                     +  +  -- Modules included in this library but not exported.+  other-modules:     Quipper.Utils.Template.Auxiliary+                     Quipper.Utils.Template.ErrorMsgQ+                     Quipper.Utils.Template.LiftQ+                     Quipper.Utils.Template.Lifting                     +  +  -- Other library packages from which modules are imported.+  build-depends: base >= 4.5 && < 5,+                 template-haskell >= 2.7,+                 containers >= 0.5.2.1,+                 mtl >= 2.1.2,+                 newsynth >= 0.3.0.1,+                 random >= 1.0.1.1,+                 process >= 1.4.2.0++  if !os(windows)+    build-depends: unix >= 2.7++                 +custom-setup+  setup-depends:     base >= 4.5, superdoc >= 0.1