diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -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. +---------------------------------------------------------------------- diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -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. diff --git a/Quipper/Utils/Auxiliary.hs b/Quipper/Utils/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Auxiliary.hs @@ -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 +-- > <<>> +-- > 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 + diff --git a/Quipper/Utils/CommandLine.hs b/Quipper/Utils/CommandLine.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/CommandLine.hs @@ -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" diff --git a/Quipper/Utils/PortableSignals.hs b/Quipper/Utils/PortableSignals.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/PortableSignals.hs @@ -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 diff --git a/Quipper/Utils/Preview.hs b/Quipper/Utils/Preview.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Preview.hs @@ -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 diff --git a/Quipper/Utils/RandomSource.hs b/Quipper/Utils/RandomSource.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/RandomSource.hs @@ -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" diff --git a/Quipper/Utils/Sampling.hs b/Quipper/Utils/Sampling.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Sampling.hs @@ -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 diff --git a/Quipper/Utils/Stabilizers/Clifford.hs b/Quipper/Utils/Stabilizers/Clifford.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Stabilizers/Clifford.hs @@ -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 diff --git a/Quipper/Utils/Stabilizers/Pauli.hs b/Quipper/Utils/Stabilizers/Pauli.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Stabilizers/Pauli.hs @@ -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)) diff --git a/Quipper/Utils/Template.hs b/Quipper/Utils/Template.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Template.hs @@ -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 + diff --git a/Quipper/Utils/Template/Auxiliary.hs b/Quipper/Utils/Template/Auxiliary.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Template/Auxiliary.hs @@ -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 + + diff --git a/Quipper/Utils/Template/ErrorMsgQ.hs b/Quipper/Utils/Template/ErrorMsgQ.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Template/ErrorMsgQ.hs @@ -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 +-- > <> +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 + + diff --git a/Quipper/Utils/Template/LiftQ.hs b/Quipper/Utils/Template/LiftQ.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Template/LiftQ.hs @@ -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" + diff --git a/Quipper/Utils/Template/Lifting.hs b/Quipper/Utils/Template/Lifting.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Template/Lifting.hs @@ -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 + + diff --git a/Quipper/Utils/Tuple.hs b/Quipper/Utils/Tuple.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Tuple.hs @@ -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,())))))))))) diff --git a/Quipper/Utils/Typeable.hs b/Quipper/Utils/Typeable.hs new file mode 100644 --- /dev/null +++ b/Quipper/Utils/Typeable.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Superdoc +main = superdocMain diff --git a/quipper-utils.cabal b/quipper-utils.cabal new file mode 100644 --- /dev/null +++ b/quipper-utils.cabal @@ -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