From 456e654990710af547370dcc072cb63b136f8efe Mon Sep 17 00:00:00 2001
From: Quipper Contributors <?>
Date: Wed, 24 Sep 2014 19:21:10 +0200
Subject: import quipper[1]'s Libraries.Auxiliary

[1] The Quipper Language, Release 0.6
    http://www.mathstat.dal.ca/~selinger/quipper/
---
 COPYRIGHT              |  66 ++++
 Libraries/Auxiliary.hs | 916 +++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 982 insertions(+)
 create mode 100644 COPYRIGHT
 create mode 100644 Libraries/Auxiliary.hs

diff --git a/COPYRIGHT b/COPYRIGHT
new file mode 100644
index 0000000..bfb4119
--- /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-2014. 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/Libraries/Auxiliary.hs b/Libraries/Auxiliary.hs
new file mode 100644
index 0000000..6f53f9b
--- /dev/null
+++ b/Libraries/Auxiliary.hs
@@ -0,0 +1,916 @@
+-- This file is part of Quipper. Copyright (C) 2011-2014. Please see the
+-- file COPYRIGHT for a list of authors, copyright holders, licensing,
+-- and other details. All rights reserved.
+-- 
+-- ======================================================================
+
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# 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
+  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
+
+-- ----------------------------------------------------------------------
+-- * 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 '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
+                
-- 
cgit v1.2.3