diff options
| -rw-r--r-- | Data/XIntMap.hs | 872 |
1 files changed, 69 insertions, 803 deletions
diff --git a/Data/XIntMap.hs b/Data/XIntMap.hs index 6f53f9b..22720cd 100644 --- a/Data/XIntMap.hs +++ b/Data/XIntMap.hs @@ -1,7 +1,7 @@ --- This file is part of Quipper. Copyright (C) 2011-2014. Please see the --- file COPYRIGHT for a list of authors, copyright holders, licensing, +-- This file was part of Quipper. Copyright (C) 2011-2014. Please see the +-- file COPYRIGHT.quipper for a list of authors, copyright holders, licensing, -- and other details. All rights reserved. --- +-- -- ====================================================================== {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,138 +9,29 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} --- | This module provides miscellaneous general-purpose auxiliary --- functions. - -module Libraries.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 +module Data.XIntMap ( 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 (..) + delete, + deletes, + insert, + inserts, + lookup, + member, + empty, + freshkey, + freshkeys, + toIntmap, + size, + dirty, + reserves, + unreserves, + makeclean, ) where -- import other stuff -import Data.List (foldl') - -import Data.Set (Set) -import qualified Data.Set as Set +import Prelude hiding (lookup) -import Data.Map (Map) -import qualified Data.Map as Map +import Data.List (foldl') import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -148,35 +39,6 @@ import qualified Data.IntSet as IntSet import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap -import qualified Data.Traversable as Traversable - --- ---------------------------------------------------------------------- --- * 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 @@ -187,50 +49,7 @@ intset_inserts list set = -- ---------------------------------------------------------------------- --- * 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. +-- * XIntMaps. -- | A 'XIntMap' is just like an 'IntMap', except that it supports -- some additional efficient operations: to find the smallest unused @@ -248,46 +67,46 @@ intmap_mapM = Traversable.mapM data XIntMap a = XIntMap !(IntMap a) !Int !IntSet !IntSet instance (Show a) => Show (XIntMap a) where - show = show . xintmap_to_intmap - + show = show . toIntmap + -- | 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 +delete :: Int -> XIntMap a -> XIntMap a +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 +deletes :: [Int] -> XIntMap a -> XIntMap a +deletes list map = + foldl' (\map k -> 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 +-- | Insert a new key-value pair in the 'XIntMap'. +insert :: Int -> a -> XIntMap a -> XIntMap a +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 +inserts :: [(Int,a)] -> XIntMap a -> XIntMap a +inserts list map = + foldl' (\map (k,v) -> 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) = +lookup :: Int -> XIntMap a -> Maybe a +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) = +member :: Int -> XIntMap a -> Bool +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 +empty :: XIntMap a +empty = (XIntMap m n free h) where m = IntMap.empty n = 0 free = IntSet.empty @@ -295,53 +114,53 @@ xintmap_empty = (XIntMap m n free h) where -- | 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) = +freshkey :: XIntMap a -> Int +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 +freshkeys :: Int -> XIntMap a -> [Int] +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 +toIntmap :: XIntMap a -> IntMap a +toIntmap (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 +size :: XIntMap a -> Int +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 +touched :: XIntMap a -> IntSet +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 +-- | A wire is /dirty/ if it is touched but currently free. +dirty :: XIntMap a -> IntSet +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 +-- the case if it was returned by 'dirty'. +reserve :: Int -> XIntMap a -> XIntMap a +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 +-- this is the case if they were returned by 'dirty'. +reserves :: IntSet -> XIntMap a -> XIntMap a +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) +unreserve :: Int -> XIntMap a -> XIntMap a +unreserve k (XIntMap m n free h) | IntMap.member k m = (XIntMap m n free h) | otherwise = (XIntMap m n free' h) where @@ -350,567 +169,14 @@ xintmap_unreserve k (XIntMap m n free h) -- | 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 +unreserves :: IntSet -> XIntMap a -> XIntMap a +unreserves ks map = + IntSet.fold (\k map -> 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 +makeclean :: XIntMap a -> XIntMap a +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 '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 'zipRightWithM', but ignore the result. -zipRightWithRightStrictM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () -zipRightWithRightStrictM_ f l1 l2 = - sequence_right_ $ zipWith_rightstrict f l1 l2 - --- ** Combinators combining mapping with folding - --- | Fold over two lists with state, and do it right-to-left. For example, --- --- > foldRightPairM (w0, [1,2,3], [a,b,c]) f --- --- will do the following: --- --- > do --- > w1 <- f (w0, 3, c) --- > w2 <- f (w1, 2, b) --- > w3 <- f (w2, 1, a) --- > return w3 -foldRightPairM :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m w -foldRightPairM (w, [], _) f = return w -foldRightPairM (w, _, []) f = return w -foldRightPairM (w, a:as, b:bs) f = do - w <- foldRightPairM (w, as, bs) f - w <- f (w, a, b) - return w - --- | Like 'foldRightPairM', but ignore the final result. -foldRightPairM_ :: (Monad m) => (w, [a], [b]) -> ((w, a, b) -> m w) -> m () -foldRightPairM_ x f = do - foldRightPairM x f - return () - --- | Combine right-to-left zipping and folding. Example: --- --- > fold_right_zip f (w0, [a,b,c], [x,y,z]) = (w3, [a',b',c']) --- > where f (w0,c,z) = (w1,c') --- > f (w1,b,y) = (w2,b') --- > f (w2,a,x) = (w3,a') -fold_right_zip :: ((w, a, b) -> (w, c)) -> (w, [a], [b]) -> (w, [c]) -fold_right_zip f (w, [], []) = (w, []) -fold_right_zip f (w, a:bb, x:yy) = (w2, a':bb') - where - (w1, bb') = fold_right_zip f (w, bb, yy) - (w2, a') = f (w1, a, x) -fold_right_zip f _ = error "fold_right_zip" - --- | Monadic version of 'fold_right_zip'. -fold_right_zipM :: - (Monad m) => ((w, a, b) -> m(w, c)) -> (w, [a], [b]) -> m(w, [c]) -fold_right_zipM f (w, [], []) = return (w, []) -fold_right_zipM f (w, a:bb, x:yy) = do - (w1, bb') <- fold_right_zipM f (w, bb, yy) - (w2, a') <- f (w1, a, x) - return (w2, a':bb') -fold_right_zipM f _ = error "fold_right_zipM" - --- ---------------------------------------------------------------------- --- * Loops. - --- $LOOPS We provide a syntax for \"for\"-style loops. - --- | A \"for\" loop. Counts from /a/ to /b/ in increments of /s/. --- --- Standard notation: --- --- > for i = a to b by s do --- > commands --- > end for --- --- Our notation: --- --- > for a b s $ \i -> do --- > commands --- > endfor - -for :: Monad m => Int -> Int -> Int -> (Int -> m()) -> m() -for a b s f = if s > 0 then aux a (<= b) else aux a (>= b) - where - aux i cond = - if cond i then do - f i - aux (i+s) cond - else - return () - --- | Mark the end of a \"for\"-loop. This command actually does --- nothing, but can be used to make the loop look prettier. -endfor :: Monad m => m() -endfor = return () - --- | Iterate a parameter over a list of values. It can be used as --- follows: --- --- > foreach [1,2,3,4] $ \n -> do --- > <<<loop body depending on the parameter n>>> --- > endfor --- --- The loop body will get executed once for each /n/ ∈ {1,2,3,4}. - -foreach :: Monad m => [a] -> (a -> m b) -> m () -foreach l f = mapM_ f l - --- ---------------------------------------------------------------------- --- * Operations for monads - --- | Every monad is a functor. Input a function /f/ : /a/ → /b/ and output --- /m/ /f/ : /m/ /a/ → /m/ /b/. -mmap :: (Monad m) => (a -> b) -> m a -> m b -mmap f a = a >>= (return . f) - --- | Remove an outer application of a monad from a monadic function. -monad_join1 :: (Monad m) => m (a -> m b) -> a -> m b -monad_join1 mf a = do - f <- mf - f a - --- ---------------------------------------------------------------------- --- * Operations for disjoint unions - --- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return --- /f/ ⊕ /g/ : /a/ ⊕ /c/ → /c/ ⊕ /d/. -map_either :: (a -> b) -> (c -> d) -> Either a c -> Either b d -map_either f g (Left x) = Left (f x) -map_either f g (Right x) = Right (g x) - --- | Monadic version of 'map_either'. -map_eitherM :: (Monad m) => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d) -map_eitherM f g (Left x) = mmap Left (f x) -map_eitherM f g (Right x) = mmap Right (g x) - --- ---------------------------------------------------------------------- --- * Operations for tuples - --- | Take two functions /f/ : /a/ → /b/ and /g/ : /c/ → /d/, and return --- /f/ × /g/ : /a/ × /c/ → /c/ × /d/. -map_pair :: (a -> b) -> (c -> d) -> (a, c) -> (b, d) -map_pair f g (x, y) = (f x, g y) - --- | Monadic version of 'mappair'. -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 - --- ---------------------------------------------------------------------- --- * 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 --- 'relexivity', '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" - --- ---------------------------------------------------------------------- --- * Isomorphism types - --- | The type 'Isomorphism' /a/ /b/ consists of isomorphisms between --- /a/ and /b/, i.e. pairs (/f/,/g/) such that /g/./f/ == id :: /a/ -> /a/, --- /f/./g/ == id :: /b/ -> /b/. --- --- As with e.g. Haskell’s 'Monad' class, it is not possible in general --- to guarantee that the intended laws hold; it is the programmer’s --- responsibility to ensure this. --- --- Under the hood, 'Isomorphism' and 'Identity' are in fact the same; --- they differ just in the API exposed. -newtype Isomorphism a b = Isomorphism (a -> b, b -> a) - --- | Map forwards along an isomorphism. -iso_forwards :: Isomorphism a b -> a -> b -iso_forwards (Isomorphism (f,g)) = f - --- | Map backwards along an isomorphism. -iso_backwards :: Isomorphism a b -> b -> a -iso_backwards (Isomorphism (f,g)) = g - --- ====================================================================== --- * Error messages - --- | Often a low-level function, such as 'qcdata_zip' and --- '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 - |